gcos_big_tape_blocks_.pl1 12/11/84 1355.9rew 12/10/84 1041.6 13842 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_big_tape_blocks_: proc ()returns (bit (1)); /* Subroutine that reports whether the caller can use "big" tape blocks. Author: Dave Ward 04/22/81 */ call use_big_tape_blocks_ (code); if code = 0 then return ("0"b); if code = error_table_$big_ws_req then do; /* Does not have access. */ call com_err_ ( code , "gcos_big_tape_blocks_" , "^/Caller can not use big tape blocks." ||"^/Contact personnel from SysMaint." ||"^/Need read and ^[execute^;write^] on ^a>^a," ||"^/or read and ^[execute^;write^] on ^a>^a." , nex (1), dir (1), ent (1) , nex (2), dir (2), ent (2) ); return ("1"b); end; call com_err_ ( code , "gcos_big_tape_blocks_" , "^/UNEXPECTED ERROR, could not get mode for caller, contact SysMaint." ); return ("1"b); %page; /* Variables for gcos_big_tape_blocks_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl error_table_$big_ws_req fixed bin(35) ext static; dcl ioa_ entry() options(variable); dcl use_big_tape_blocks_ entry (fixed bin(35)); %page; %include use_big_tape_blocks; end gcos_big_tape_blocks_; gcos_fms.pl1 12/11/84 1355.9rew 12/10/84 1021.5 167283 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_fms: gfms: proc; /* Display information, excluding data files, from a gcos user or master save tape. Author: Dave Ward 09/30/80 Change: Dave Ward 10/04/80 arguments. Change: Dave Ward 10/15/80 -den, -gf, -tr, -tll. Change: Dave Ward 10/19/80 -file, -no_file and -input_file Change: Dave Ward 10/27/80 added -scan_ss option. Change: Dave Ward 11/25/80 revised control arguments. Change: Dave Ward 01/27/81 provide gfms_return condition. Change: Dave Ward 02/02/81 print_calling_sequence_ Change: Dave Ward 04/22/81 print big tape blocks not available. Change: Scott C. Akers 02/08/82 Add -spn, -drm, -rest control_args. Convert all names to gfms_. Change: Ron Barstad 83-04-05 Make usage message standard, dcl builtins, delete unused dcls Change: Ron Barstad 83-06-03 Add -den spec to attach description Change: Ron Barstad 84-11-16 Forced tape reel number to upper case */ call cu_$af_return_arg ( /* Obtain reference to caller's input arguments. */ na /* (output) number of arguments. */ , rsp /* (output) pointer to return argument. */ , rsl /* (output) length of return argument. */ , code /* (output) status. */ ); if code = 0 then do; /* 1) Called as an active function. */ get_arg = cu_$af_arg_ptr; /* Use active function argument getter. */ put_err = active_fnc_err_; end; else rsp = addr (rsx); /* Default return string. */ rsl = 5; /* Default length. */ if code = error_table_$not_act_fnc then do; /* 2) Not called as active function. */ get_arg = cu_$arg_ptr; /* Use "normal" argument getter. */ put_err = com_err_; end; else do; call com_err_ ( /* 3) Could not obtain args. */ code , "gcos_fms" , "^/Could not obtain argument information. Quitting." ); return; end; if gcos_big_tape_blocks_ () then do; rs = "false"; return; end; if na<1 then do; wrong_number_args: ; call put_err ( /* Wrong number arguments. */ error_table_$noarg , "gcos_fms ("||version||")" , "^/Usage:^-gfms REEL_NUMBER {-CONTROL_ARGS}" ); /* DON'T Print in error output cryptic form of calling sequence. (following is kept as a comment call gfms_calling_sequence_ ( "arg:" , " -den n|Tape density is n (default dynamic)." , " -dump|Exhaustive display of tape info." , " -file name...|Accept only files named (default is all files)." , " -if file|File names in segment (with suffix .gfms)." ||" One name per line, may be prefixed with ^ for not." , " -no_ga|Do not supply gtss file attributes (default is to supply)." , " -no_tll|Don't print total llinks (default is to print)." , " -no_unload|Do not unload files (default is to unload)." , " -not_file name...|Accept no file named." , " -prfn|Print sorted list of file names (default is not)." , " -scan_ss|Only print substructure records (default is not)." , " -tk n|Tape is n track (default is 9)." , " -restore UMC_NAME|Restore only UMC specified." , " -rest UMC_NAME|Same as -restore." , " -smc_pathname path|Specify where to do the restore. (Default is working_dir.)" , " -spn path|Same as -smc_pathname." , " -directory_mapping DRM_RULE|Specify whether to place files in working_dir," ||" >udd>UMC_NAME, or SMC pathname. (Default is ""wd"")" , " -drm DRM_RULE|Same as -directory_mapping." ); */ return; end; call init_routine; /* Obtain temp segments for description tree, file names lists. */ call get_temp_segments_ ( "gfms" , tsp , code ); if code ^= 0 then do; call put_err ( code , "gfms" , "Obtaining 3 temp segments." ); return; end; /* Process caller's arguments. */ do i = 1 to na; call get_arg (i, ap, al, code); /* Obtain the next argument (arg). */ if code ^= 0 then do; call put_err ( code , "gfms" , "Argument ^i." , i ); goto error_exit; end; if al<1 then do; /* Argument is zero length string. */ call put_err ( error_table_$smallarg , "gfms" , "Argument ^i zero length. Quitting." , i ); goto error_exit; end; if substr (arg, 1, 1) = "-" then do; /* Control argument. */ if last_was_file & (file_name_count = 0) then do; call put_err ( 0 , "gfms" , "File name control argument not followed by file name." ); goto error_exit; end; last_was_file = "0"b; file_name_count = -1; l = hbound (control_arg, 1); do f = 1 to l; /* Search for control arg name. */ if substr (arg, 2) = control_arg (f).name then do; last_was_file = "0"b; goto carg (control_arg (f).val); end; end; call put_err ( /* Unknown control arg. */ error_table_$badopt , "gfms" , "Arg ^i ""^a"". Quitting." , i , arg ); goto error_exit; end; if file_name_count >= 0 then do; file_name_count = file_name_count+1; if gfms_file_name_ (not_file, arg) then arg_err = "1"b; goto next_arg; end; if need_input_file then do; need_input_file = "0"b; if gfms_input_file_list_ (arg) then arg_err = "1"b; goto next_arg; end; if need_track then do; need_track = "0"b; if arg = "7" then tape_track = "7"; else if arg = "9" then tape_track = "9"; else do; call put_err ( 0 , "gfms" , "Only 7 or 9 track provided for. Quitting." ); goto error_exit; end; goto next_arg; end; if need_density then do; need_density = "0"b; do k = lbound (tape_densities, 1) to hbound (tape_densities, 1); if arg = tape_densities (k) then do; ftd, ltd = k; /* Use density table entry k. */ den_arg = arg; goto next_arg; end; end; call put_err ( error_table_$bad_density , "gfms" , "Only densities ^a provided for. Quitting." , string (tape_densities) ); goto error_exit; end; if need_umc_name then do; need_umc_name = "0"b; gfms_ext$umc_name = arg; goto next_arg; end; if need_mapping_rule then do; need_mapping_rule = "0"b; if arg = "wd" | arg = "smc" | arg = "umc" then do; gfms_ext$mapping_rule = arg; if arg = "smc" & ^got_smc_path then need_smc_path = "1"b; if arg = "umc" then gfms_ext$working_dir = ">udd"; if arg = "wd" then gfms_ext$working_dir = rtrim (get_wdir_ ()); goto next_arg; end; else do; call put_err (error_table_$badopt, "gfms", "^/Mapping Rules are:^-WD^-SMC^-UMC"); goto error_exit; end; end; if need_smc_path then do; need_smc_path = "0"b; call expand_pathname_ ((arg), dname, ename, code); if code = 0 then do; gfms_ext$working_dir = rtrim (dname) || ">" || ename; goto next_arg; end; else do; call put_err (code, "gfms", "^/Illegal SMC pathname: ^/^a", arg); goto error_exit; end; end; /* Tape reel number. */ reel_number = translate(arg,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz"); goto next_arg; %page; carg (01): ; /* density */ need_density = "1"b; goto next_arg; carg (02): ; /* "dump" */ dump = "1"b; /* Do dump tape information. */ gfms_ext$print_routines.ioa = ioa_; gfms_ext$print_routines.ioa_nnl = ioa_$nnl; goto next_arg; carg (03): ; /* "file" */ file_name_count = 0; /* 0 => obtain names. */ not_file = "0"b; last_was_file = "1"b; goto next_arg; carg (04): ; /* "input_file" */ need_input_file = "1"b; goto next_arg; carg (05): ; /* not gtss file attributes. */ gf = "0"b; goto next_arg; carg (06): ; /* no total llinks. */ tll = "0"b; goto next_arg; carg (07): ; /* "no_unload" */ unload = "0"b; goto next_arg; carg (08): ; /* not_file. */ file_name_count = 0; /* 0 => obtain names. */ not_file = "1"b; last_was_file = "1"b; goto next_arg; carg (09): ; /* "pr_file_names" */ prfn = "1"b; goto next_arg; carg (10): ; scan_ss = "1"b; goto next_arg; carg (11): ; /* track n */ need_track = "1"b; goto next_arg; carg (12): ; /* smc smc_path */ need_smc_path = "1"b; goto next_arg; carg (13): ; /* drm mapping_rule */ need_mapping_rule = "1"b; goto next_arg; carg (14): ; /* restore umc*/ need_umc_name = "1"b; goto next_arg; not_provided: ; call ioa_ ("Control arg ""^a"" ^i not yet provided." , control_arg (f).name , i ); goto next_arg; next_arg: ; end; if (number_names>0) & dump then call gfms_dump_do_files_; if leftovers () /* If any args are left hanging */ | arg_err then do; error_exit: ; call release_temp_segs; rs = "false"; return; end; %page; /* Store the attach description. */ attach_description = "tape_nstd_ " /* name of I/O module. */ ||rtrim(reel_number) ||" -bk 15624" /* => up to 3906 words (file content records largest). */ ||" -tk "||tape_track ; if den_arg ^= "" then attach_description = rtrim(attach_description)||" -den "||rtrim(den_arg); /* Establish "on" conditions. */ on cond (gfms_fail) begin; call put_err ( 0 , "gfms" , "FAILED." ); call clean_up; goto exit; end; on cond (cleanup) call clean_up; on cond (gfms_return) goto exit; /* Process the tape. */ string (tape_reel_information) = ""; call gfms_header_label_ (); /* display tape label. */ call gfms_serial_number_record_ (); /* display tape serial number record. */ call gfms_task_block_record_ (master_save); /* display tape block record (tbr). */ if master_save then call gfms_smc_records_ (); call gfms_substructure_records_ (); call gfms_file_content_records_ (); /* Close and detach the tape. */ call clean_up; exit: ; return; %page; clean_up: proc; call release_temp_segs; /* Perform close and detach (cleanup condition) activities. */ if gfms_close_ () then return; call gfms_detach_; return; end clean_up; %page; init_routine: proc; /* Performs all the initialization. */ /* Set default options. */ arg_err = "0"b; /* No argument errors yet. */ tape_track = "9"; close, detach = "0"b; /* Don't close or detach. */ gf = "1"b; /* provide gtss file attributes. */ tll = "1"b; /* print file total llinks. */ dump = "0"b; /* Do not dump tape information. */ prfn = "0"b; /* Don't print file names. */ unload = "1"b; /* Do unload files. */ ftd = lbound (tape_densities, 1); ltd = hbound (tape_densities, 1); /* upper bound of tape densities table. */ two_words = "0"b; nlp = addr (two_words); gfms_ext$print_routines.ioa = null_proc; gfms_ext$print_routines.ioa_nnl = null_proc; gfms_ext$working_dir = rtrim (get_wdir_ ()); gfms_ext$mapping_rule = "wd"; gfms_ext$umc_name = ""; last_was_file , got_smc_path , need_density , need_input_file , need_mapping_rule , need_smc_path , need_track , need_umc_name , scan_ss = "0"b; file_name_count = -1; /* -1 => no file name needed. */ reel_number = ""; den_arg = ""; return; end init_routine; %page; leftovers: proc () returns (bit(1)); if reel_number = "" then do; call put_err ( error_table_$noarg , "gfms" , "Tape reel number has not been supplied." ); return ("1"b); end; if need_input_file then do; call put_err ( error_table_$noarg , "gfms" , "-input_file control argument not followed by input file name." ); return ("1"b); end; if need_density then do; call put_err ( error_table_$noarg , "gfms" , "-density control argument not followed by density value." ); return ("1"b); end; if need_track then do; call put_err ( error_table_$noarg , "gfms" , "-track control argument not followed by track value." ); return ("1"b); end; if file_name_count = 0 then do; call put_err ( error_table_$noarg , "gfms" , "-file control argument not followed by file names." ); return ("1"b); end; if need_mapping_rule then do; call put_err ( error_table_$noarg , "gfms" , "Mapping rule not given." || "^/Mapping Rules are:^-WD^-SMC^-UMC" ); return ("1"b); end; if need_umc_name then do; call put_err ( error_table_$noarg , "gfms" , "UMC name not given." ); return ("1"b); end; if need_smc_path then do; call put_err ( error_table_$noarg , "gfms" , "SMC pathname not given." ); return ("1"b); end; return ("0"b); /* All is well so far. */ end leftovers; %page; release_temp_segs: proc; /* Release temp segment for description tree. */ call release_temp_segments_ ( "gfms" , tsp , code ); if code ^= 0 then call put_err ( code , "gfms" , "Releasing 3 temp segments." ); return; end release_temp_segs; null_proc: proc;return;end; /* Procedure that does nothing. */ %page; /* Variables for gcos_fms: */ /* IDENTIFIER ATTRIBUTES */ dcl active_fnc_err_ entry() options(variable); dcl addr builtin; dcl al fixed bin; dcl ap ptr; dcl arg char(al)unal based(ap); dcl arg_err bit(1); dcl cleanup condition ext; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl den_arg char (8); dcl dname char (168); dcl ename char (32); dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$bad_density fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$not_act_fnc fixed bin(35) ext static; dcl error_table_$smallarg fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl f fixed bin; dcl file_name_count fixed bin; dcl gcos_big_tape_blocks_ entry() returns(bit(1)); dcl get_arg entry(fixed bin,ptr,fixed bin,fixed bin(35)) variable auto; dcl get_temp_segments_ entry (char(*), (*)ptr, fixed bin(35)); dcl gfms_close_ entry() returns(bit(1)); dcl gfms_detach_ entry options(variable); dcl gfms_dump_do_files_ entry; dcl gfms_fail condition ext; dcl gfms_file_content_records_ entry(); dcl gfms_file_name_ entry (bit(1), char(*)) returns(bit(1)); dcl gfms_header_label_ entry(); dcl gfms_input_file_list_ entry (char(*)) returns(bit(1)); dcl gfms_return condition ext; dcl gfms_serial_number_record_ entry(); dcl gfms_smc_records_ entry(); dcl gfms_substructure_records_ entry(); dcl gfms_task_block_record_ entry(bit(1)); dcl got_smc_path bit(1); dcl hbound builtin; dcl i fixed bin; dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl k fixed bin; dcl l fixed bin; dcl last_was_file bit(1); dcl lbound builtin; dcl master_save bit(1); dcl na fixed bin; dcl need_density bit(1); dcl need_input_file bit(1); dcl need_mapping_rule bit(1); dcl need_smc_path bit(1); dcl need_track bit(1); dcl need_umc_name bit(1); dcl not_file bit(1); dcl put_err entry variable options(variable); dcl reel_number char(7); dcl release_temp_segments_ entry (char(*), (*)ptr, fixed bin(35)); dcl rs char(rsl)var based(rsp); dcl rsl fixed bin(21); dcl rsp ptr; dcl rsx char(5)var; dcl rtrim builtin; dcl string builtin; dcl substr builtin; dcl tape_track char(1); dcl tsp (3)aligned ptr based(addr(gfms_ext$temp_segs)); dcl two_words bit(72)aligned; dcl get_wdir_ entry() returns(char(168)); %page; dcl 1 control_arg (23) static int options(constant) , 3 name char(20)init( /* 01 01 */ "den" ,/* 02 01 */ "density" ,/* 03 02 */ "dump" ,/* 04 03 */ "file" ,/* 05 04 */ "if" ,/* 06 04 */ "input_file" ,/* 07 05 */ "no_ga" ,/* 08 05 */ "no_gtss_attributes" ,/* 09 06 */ "no_tll" ,/* 10 06 */ "no_total_llinks" ,/* 11 07 */ "no_unload" ,/* 12 08 */ "not_file" ,/* 13 09 */ "prfn" ,/* 14 09 */ "print_file_names" ,/* 15 10 */ "scan_ss" ,/* 16 11 */ "tk" ,/* 17 11 */ "track" ,/* 18 12 */ "spn" ,/* 19 12 */ "smc_pathname" ,/* 20 13 */ "drm" ,/* 21 13 */ "directory_mapping" ,/* 22 14 */ "rest" ,/* 23 14 */ "restore" ) , 3 val fixed bin init( /* 01 */ 01 /* "den" */ ,/* 02 */ 01 /* "density" */ ,/* 03 */ 02 /* "dump" */ ,/* 04 */ 03 /* "file" */ ,/* 05 */ 04 /* "if" */ ,/* 06 */ 04 /* "input_file" */ ,/* 07 */ 05 /* "no_ga" */ ,/* 08 */ 05 /* "no_gtss_attributes" */ ,/* 09 */ 06 /* "no_tll" */ ,/* 10 */ 06 /* "no_total_llinks" */ ,/* 11 */ 07 /* "no_unload" */ ,/* 12 */ 08 /* "not_file" */ ,/* 13 */ 09 /* "prfn" */ ,/* 14 */ 09 /* "print_file_names" */ ,/* 15 */ 10 /* "scan_ss" */ ,/* 16 */ 11 /* "tk" */ ,/* 17 */ 11 /* "track" */ ,/* 18 */ 12 /* "spn" */ ,/* 19 */ 12 /* "smc_pathname"*/ ,/* 20 */ 13 /* "drm"*/ ,/* 21 */ 13 /* "directory_mapping"*/ ,/* 22 */ 14 /* "rest"*/ ,/* 23 */ 14 /* "restore"*/ ) ; %page; %include gfms_version; %page; %include gfms_tape_densities; %page; %include gfms_ext; %page; %include gfms_do_files; end gcos_fms; gfms_ascii_.pl1 12/11/84 1355.9rew 12/10/84 1041.7 13014 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_ascii_: proc (bs)returns (char (*)); /* Convert BCD character in input bit string "bs" to ascii characters and return. Author: Dave Ward 09/30/80 Modified: Ron Barstad 83-03-10 Changed call to gtss_bcd_ascii_ to gfms_bcd_ascii_ which had already been installed Corrected precision of number of char to convert */ dcl bs bit(*)parm; nc = divide (length (bs), 6, 24); substr (r, 1, nc) = " "; call gfms_bcd_ascii_ ( /* upper case bcd to ascii. */ addr (bs) /* Location of bcd characters. */ , nc /* Number ofcharacters. */ , addr (r) /* location of ascii characters output. */ ); return (rtrim (substr (r, 1, nc))); dcl addr builtin; dcl divide builtin; dcl gfms_bcd_ascii_ entry(ptr,fixed bin(24),ptr); dcl length builtin; dcl nc fixed bin(24); dcl r char(400)aligned; dcl rtrim builtin; dcl substr builtin; %page; %include gfms_ext; end gfms_ascii_; gfms_ascii_bcd_.alm 12/11/84 1355.9rew 12/10/84 1041.7 13257 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " ASCII to BCD conversion routine. " " dcl gfms_ascii_bcd_ entry(ptr,FB,ptr); " Parm 1: Pointer to (input) ascii string. " Parm 2: Length of (input) string. " Parm 3: Pointer to (output) bcd string. " (caller must assure output string long enough). " " Author: Dave Ward 08/03/81 " (from gfms_ascii_bcd_) " name gfms_ascii_bcd_ entry gfms_ascii_bcd_ gfms_ascii_bcd_: eppbp ap|2,* bp -> input data eppbp bp|0,* lda ap|4,* a = length eppbb ap|6,* bb -> output buffer eppbb bb|0,* mvt (pr,rl),(pr,rl) desc9a bp|0,al desc6a bb|0,al arg table short_return table: oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020077076013 oct 053074032057 oct 035055054060 oct 073052033061 oct 000001002003 oct 004005006007 oct 010011015056 oct 036075016017 oct 014021022023 oct 024025026027 oct 030031041042 oct 043044045046 oct 047050051062 oct 063064065066 oct 067070071012 oct 037034040072 oct 057021022023 oct 024025026027 oct 030031041042 oct 043044045046 oct 047050051062 oct 063064065066 oct 067070071012 oct 040034020020 end gfms_bcd_ascii_.alm 12/11/84 1355.9rew 12/10/84 1041.7 11475 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " bcd to ascii (upper case) " " dcl gfms_bcd_ascii_ entry(ptr,fixed bin(24),ptr); " Arguments: " 1. Pointer to input bcd characters (6 bit). " 2. Number of characters. " 3. Pointer to ascii output string. " " Author: Dave Ward 08/03/81 " From Mike Jordan's gdb_bcd_ascii_.alm " name gfms_bcd_ascii_ entry gfms_bcd_ascii_ gfms_bcd_ascii_: eppbp ap|2,* bp->input data eppbp bp|0,* lda ap|4,* get char count eppap ap|6,* ap->output buffer eppap ap|0,* mvt (pr,rl),(pr,rl) desc6a bp|0,al desc9a ap|0,al arg upper short_return entry lc lc: eppbp ap|2,* bp->input data eppbp bp|0,* lda ap|4,* get char count eppap ap|6,* ap->output buffer eppap ap|0,* mvt (pr,rl),(pr,rl) desc6a bp|0,al desc9a ap|0,al arg lower short_return upper: aci |0123456789[#@:>?| aci | ABCDEFGHI&.](<\| aci |^JKLMNOPQR-$*);'| aci |+/STUVWXYZ_,%="!| lower: aci |0123456789[#@:>?| aci | abcdefghi&.](<\| aci |^jklmnopqr-$*);'| aci |+/stuvwxyz_,%="!| end gfms_calling_sequence_.pl1 12/11/84 1355.9rew 12/10/84 1041.7 52767 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_calling_sequence_: proc; /* Print the input arguments (strings) on error_output stream with the following considerations: strings containing "|" are justified and information after the "|" are folded under this character, e.g., abc | stuff xxx d | more stuff Author: Dave Ward 02/02/81 Change: Dave Ward 02/03/81 fold lines not containing |. Change: Scott C. Akers 02/08/82 Change name from print_calling_sequence_ to gfms_calling_sequence_ for binding into bound_gfms. */ ll = get_line_length_$stream ("error_output", code); call cu_$arg_count (na); mm = 0; /* Set initial max m. */ /* Obtain parameter information. */ do i = 1 to na while (i <= hbound (a, 1)); call cu_$arg_ptr (i, p (i), l (i), code); if code ^= 0 then do; call com_err_ ( code , "gfms_calling_sequence_" , "Arg ^i" , i ); return; end; /* Measure for | location. */ m (i) = index (argi, "|"); mm = max (mm, m (i)); end; /* Print the strings. */ do i = 1 to (i-1); if (m (i) = 0) | (mm > (ll-5)) then do; /* Either no |, or | too far to the right (a Reagen bar). */ if length (argi) <= ll then /* Not more than ll characters to print. */ call out (argi); else /* More than ll characters to print. */ call fold (argi); end; else do; /* String contains |. */ call out (substr (argi, 1, m (i)-1)); if m (i)m (i) then /* There are characters after the |. */ call pr_rest (after_bar); end; call out (NL); end; fail: ; return; %page; fold: proc (s); /* Output ll characters, break on space, fold remainder. */ dcl s char(*)parm; if length (s) <= ll then do; call out (s); return; end; k = index (reverse (substr (s, 1, ll)), " "); if k>0 then do; l = length (rtrim (substr (s, 1, ll-k))); if l>0 then do; call out (substr (s, 1, l)); call out (NL); end; l = ll - (k-1) + 1; /* Location 1st character of remainder. */ if (length (s)-l+1)>ll then call fold (substr (s, l)); else do; /* Right justify final piece. */ call out (substr ((100)" ", 1, ll- (length (s)-l+1))); call out (substr (s, l)); end; return; end; /* No blanks in string. */ call out (substr (s, 1, ll)); call out (NL); call fold (substr (s, ll+1)); return; dcl k fixed bin; dcl l fixed bin; end fold; %page; out: proc (s); /* Print string "s". */ dcl s char(*)parm; call iox_$put_chars ( iox_$error_output , addr (s) , length (s) , code ); if code ^= 0 then do; call com_err_ ( code , "gfms_calling_sequence_" , "String ""^a""" , s ); goto fail; end; return; end out; %page; pr_rest: proc (s); /* Print the string "s" as the rest of the string after |. */ dcl s char(*)parm; call out (" "); l = ll-mm-2; /* Print characters available. */ pl = length (s); if pl <= l then do; /* Not more than ll characters to print. */ call out (s); return; end; /* More than ll characters, print up to ll characters on this line and fold the remainder. */ k = index (reverse (substr (s, 1, l)), " "); if k = 0 then do; /* No space found. */ call out (substr (s, 1, l)); fc = l+1; ln = pl-l; if ln<1 then return; end; else do; /* Print up to space. */ call out (rtrim (substr (s, 1, l- (k-1)))); fc = l-k+2; ln = pl-fc+1; if ln<1 then return; end; call out (NL); call out (substr ((100)" ", 1, mm-1)); call out (" |"); call pr_rest (substr (s, fc, ln)); return; dcl fc fixed bin; dcl k fixed bin; dcl l fixed bin; dcl ln fixed bin; dcl pl fixed bin; end pr_rest; %page; /* Variables for gfms_calling_sequence_: */ /* IDENTIFIER ATTRIBUTES */ dcl after_bar char(l(i)-m(i))unal based(addr(ari(m(i)+1))) /* i-th argument, characters after |. */; dcl argi char(l(i))unal based(p(i)) /* i-th argument, character string. */; dcl ari (l(i))char(1)unal based(p(i)) /* i-th argument, array of characters. */; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl get_line_length_$stream entry (char(*), fixed bin(35)) returns(fixed bin); dcl hbound builtin; dcl i fixed bin; dcl index builtin; dcl iox_$error_output ptr ext static; dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl ll fixed bin; dcl max builtin; dcl min builtin; dcl mm fixed bin; dcl na fixed bin; dcl reverse builtin; dcl substr builtin; dcl NL char(1)static int options(constant)init(" "); dcl 1 a (1000)aligned , 2 p ptr , 2 l fixed bin(21) , 2 m fixed bin ; end gfms_calling_sequence_; gfms_close_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 9558 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_close_: proc returns (bit (1)); /* Close I/O switch "gfms_input", return "1" and report if failure. Author: Dave Ward 10/18/80 */ if ^close then return ("0"b); call iox_$close ( cbp /* (input) pointer to switch's control block. */ , code /* (output) I/O system status code. */ ); if code = 0 then return ("0"b); /* Successful. */ call com_err_ ( code , "gfms" , "closing (^p) description^/^a" , cbp , attach_description ); return ("1"b); /* Failed. */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl iox_$close entry (ptr, fixed bin(35)); %page; %include gfms_ext; end gfms_close_; gfms_date_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 10944 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_date_: proc (bcd_date)returns (char (8)); /* Return date MM/DD/YY from input of 6 bcd characters (36 bits) MMDDYY. Author: Dave Ward 10/04/80 Change: Dave Ward 02/04/81 recoded using r array. */ dcl bcd_date bit(36)aligned parm; r (1) = a (c (1)); r (2) = a (c (2)); /* Month MM. */ r (3) = "/"; r (4) = a (c (3)); r (5) = a (c (4)); /* Day DD. */ r (6) = "/"; r (7) = a (c (5)); r (8) = a (c (6)); /* Year YY. */ return (string (r)); %page; /* Variables for gfms_date_: */ /* IDENTIFIER ATTRIBUTES */ dcl c (6)fixed bin(6)unsigned unal based(addr(bcd_date)); dcl r (8)char(1); dcl a (0:63)char(1)static int options(constant)init( "0" , "1" , "2" , "3" , "4" , "5" , "6" , "7" , "8" , "9" , (54)(1)"#" ); %page; %include gfms_ext; end gfms_date_; gfms_detach_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 8658 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_detach_: proc; /* Detach the I/O switch "gfms_input" located by cbp. Author: Dave Ward 10/18/80 */ if ^detach then return; call iox_$detach_iocb ( cbp /* (input) pointer to switch's control block. */ , code /* (output) I/O system status code. */ ); if code ^= 0 then call com_err_ ( code , "gfms" , "detaching description^/^a" , attach_description ); return; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); %page; %include gfms_ext; end gfms_detach_; gfms_dump_description_tree_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 30150 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_dump_description_tree_: proc; /* Dump description tree. Author: Dave Ward 10/23/80 */ call ioa_ ("^|DUMP OF cat/desc:"); /* Dump cat. */ call ioa_ ("^16xprntsc chldlk chldcs name"); do i = 1 to n_cat; call ioa_ ( "^6i. ^[catalog^;^3xfile^]^3( ^6i^) ^a" , i , cat (i).is_cat , cat (i).parent_sector , cat (i).child_link , cat (i).child_sector , cat (i).ascii_name ); end; /* DUMP description. */ call ioa_ ("^11xlink sector maxsiz mode name"); do i = 1 to n_desc; call ioa_$nnl ( "^6i. ^3( ^6i^) ^4b ^a" , i , description (i).link , description (i).sector , description (i).attributes.max_size_llinks , description (i).attributes.mode , gfms_ascii_ ((description (i).name)) ); if description (i).attributes.user_info.present then call ioa_$nnl (" ^12.3b", "0"b||attributes (i).value); call ioa_$nnl ("^/"); end; /* Check hash chains consume all entries. */ string (cu) = "0"b; call tc (cat_child, cu, "1"b); call tc (file_child, cu, "1"b); if ^string (cu) ^= "0"b then do; /* cat entries unaccounted for. */ do i = 1 to hbound (cu, 1); if cu (i) = "0"b then call ioa_ ( "cat^3i NOT USED ^a" , i , cat (i).ascii_name ); end; end; string (du) = "0"b; call tc (desc, du, "0"b); if ^string (du) ^= "0"b then do; /* cat entries unaccounted for. */ do i = 1 to hbound (du, 1); if du (i) = "0"b then call ioa_ ( "cat^3i NOT USED ^a" , i , cat (i).ascii_name ); end; end; fail: ; return; tc: proc (l, u, c); /* Trace chains from start list "l", marking "u" for all entries found. "c" is "1"b of this is for cat, versus for description. */ dcl c bit(1) parm; dcl l (0:1020)fixed bin(18)unsigned parm; dcl u (*)bit(1)unal parm; do i = 0 to 1020; if l (i)>0 then do; k = l (i); do while (k>0); if k>hbound (u, 1) then do; call com_err_ ( 0 , "gfms_dump_description_tree_" , "BUG: link ^i > number entries ^[cat^;desc^] ^i" , k , c , hbound (u, 1) ); goto fail; end; u (k) = "1"b; /* Mark used. */ if c then k = cat (k).child_link; else k = description (k).link; end; end; end; return; dcl i fixed bin; dcl k fixed bin; end tc; %page; /* Variables for gfms_dump_description_tree_: */ /* IDENTIFIER ATTRIBUTES */ dcl com_err_ entry() options(variable); dcl cu (n_cat)bit(1)unal based(addr(u)); dcl du (n_desc)bit(1)unal based(addr(u)); dcl gfms_ascii_ entry (bit(*)) returns(char(*)); dcl i fixed bin; dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl u bit(36000)aligned; %page; %include gfms_description_tree; %include gfms_ext; end; gfms_dump_do_files_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 11277 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_dump_do_files_: proc; /* Dump the file name list. Author: Dave Ward 10/19/80 Change: Dave Ward 10/30/80 new do files structure. */ call ioa ("DUMP OF FILE NAMES:"); t = 0; /* Total count. */ do sp = addr (file_start), addr (cat_start); do k = lbound (start, 1) to hbound (start, 1); j = start (k); if j>0 then do; n = 0; do while (j>0); t = t+1; n = n+1; call ioa ( "^4i. ^4i ^4i ^[no ^; ^]^a" , t , k , n , not (j) , name (j) ); j = link (j); end; end; end; end; return; dcl j fixed bin; dcl k fixed bin; dcl n fixed bin; dcl sp ptr; dcl start (0:1020)fixed bin based(sp); dcl t fixed bin; %include gfms_do_files; %include gfms_ext; end gfms_dump_do_files_; gfms_dump_rec_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 31194 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_dump_rec_: proc (p, n); /* Display catalog record BCD and octal. Author: Dave Ward 11/05/80 Change: Dave Ward 11/06/80 number of words parameter. Change: Dave Ward 11/25/80 notify zero words requested. */ dcl n fixed bin parm; dcl p ptr parm; if n<1 then do; call ioa_$ioa_switch_nnl ( iox_$error_output , "ZERO WORDS READ. NO DUMP." ); return; end; f = n-1; /* upper bound 0,1,...,n-1. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^5x"); do i = 0 to 7; /* Print header. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^13x^i", i); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); do i = 0 by 8 to f; if i>0 then if last_line = current_line then do; if first then do; first = "0"b; call ioa_$ioa_switch_nnl (iox_$error_output, "^6x^12(=^)"); call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); end; goto next_line; end; first = "1"b; call ioa_$ioa_switch_nnl (iox_$error_output, "^4i.", i); do j = i to (i+8-1) while (j <= f); /* Print bcd. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^13a", bcd (w (j))); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/^5x"); do j = i to (i+8-1) while (j <= f); /* Print octal. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^6.3b'^6.3b", wl (j), wr (j)); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); next_line: ; end; return; %page; bcd: proc (w)returns (char (13)); /* Convert 6 bcd characters to ascii, convert blanks to underlines (bcd has no underline character, so this distinguishes bcd blanks). Return the 6 characters as a 2 strings of 6 characters each, space in middle, each input character preceeded by a space. */ dcl w bit(36)aligned parm; string (s) = gfms_ascii_ ((w)); /* Convert bcd to ascii. */ string (s) = translate (string (s), "_", " "); /* Convert spaces to underlines. */ string (r) = " "; /* Blank the result. */ do i = 0 to 5; if i<3 then k = 1; else k = 2; r ((i*2)+k) = s (i); /* Distribute to every other character of the output. */ end; return (string (r)); dcl i fixed bin; dcl k fixed bin; dcl r (0:12)char(1)unal; dcl s (0:5)char(1)unal; end bcd; %page; /* Variables for gfms_dump_rec_: */ /* IDENTIFIER ATTRIBUTES */ dcl current_line bit(8*36)aligned based(addr(w(i))); dcl f fixed bin; dcl first bit(1); dcl gfms_ascii_ entry (bit(*)) returns(char(*)); dcl i fixed bin; dcl ioa_$ioa_switch_nnl entry() options(variable); dcl iox_$error_output ptr ext static; dcl j fixed bin; dcl last_line bit(8*36)aligned based(addr(w(i-8))); dcl w (0:f)bit(36)aligned based(p); dcl 1 w2 (0:f)aligned based(p) , 2 wl bit(18)unal , 2 wr bit(18)unal ; end gfms_dump_rec_; gfms_end_of_input_.pl1 12/11/84 1355.9rew 12/10/84 1041.8 28836 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_end_of_input_: proc (bp, bl, nb)returns (bit (1)); /* End of information reached attempting to read a record. Determine if tape is multi-reel, in which case, proceed to the next reel, fill the remainder of the record (based on "bp" of length "bl" bytes of which "nb" have been input) and return "0"b. If trailing label indicates EOF (end of file) then return "1"b, there is no more input. Author: Dave Ward 10/18/80 */ dcl bl fixed bin(21) parm /* Length of buffer (bytes). */; dcl bp ptr parm /* Pointer to input buffer. */; dcl nb fixed bin(21) parm /* Number of bytes no in buffer. */; if gfms_trailer_label_ () then return ("1"b); /* Multireel tape concluded. */ /* Continue file from next tape reel. */ call gfms_header_label_; /* Process label from next reel. */ /* Obtain the next FILE CONTENT record from tape. */ call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (rec_space) /* (input) record buffer. */ , size (rec_space)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms_file_content_records_" , "Attempting to read EOI record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (rec_space)*4 , nbr , attach_description ); fail: ; signal cond (gfms_fail); end; if (nb + nbr) > bl then do; /* Exceeded bytes in buffer. */ call com_err_ ( 0 , "gfms_end_of_input_" , "Record split over reels exceeds buffer bytes ^i" ||"^/^i bytes read from last reel, ^i bytes from current reel." , bl , nb , nbr ); signal cond (gfms_fail); end; buffer.new = substr (rec_space, 1, nbr); nb = nb+nbr; /* Reset to total bytes now in buffer. */ return ("0"b); %page; /* Variables for gfms_end_of_input_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl divide builtin; dcl error_table_$long_record fixed bin(35) ext static; dcl gfms_fail condition ext; dcl gfms_header_label_ entry; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl gfms_trailer_label_ entry() returns(bit(1)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl nbr fixed bin(21); dcl rec_space char(15624)aligned /* 15624 = 3906 words (file content data records). */; dcl 1 buffer aligned based(bp) , 3 old char(nb)unal , 3 new char(nbr)unal ; %page; %include gfms_ext; end gfms_end_of_input_; gfms_ext.cds 12/11/84 1355.9r w 12/10/84 1041.9 27099 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ gfms_ext:proc; /* Generate object for "gfms_ext" data. Author: Dave Ward 1981 Modified: Ron Barstad 83-07-21 Remove dependency on ted_com, add include file */ /** Initialize cds_args **/ cds_args_ptr=addr(space_for_cds_args); unspec(space_for_cds_args)="0"b; /** Reference structure input to cds to assure it is in runtime table. **/ if addr(gfms_ext)=null() then ; /** No text section **/ cds_args_ptr -> cds_args.sections (1).p = null (); cds_args_ptr -> cds_args.sections (1).len = 0; cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT"; /** Static section **/ cds_args_ptr -> cds_args.sections (2).p = addr (gfms_ext); /* Caller's data. */ cds_args_ptr -> cds_args.sections (2).len = size (gfms_ext); /* No. words in data structure. */ cds_args_ptr -> cds_args.sections (2).struct_name = "gfms_ext"; cds_args_ptr -> cds_args.seg_name = "gfms_ext"; /* Entryname of object segment. */ cds_args_ptr -> cds_args.num_exclude_names = 0; /* All level 2 names are entry points. */ cds_args_ptr -> cds_args.exclude_array_ptr = null (); cds_args_ptr -> cds_args.switches.defs_in_link = "0"b; /* Definitions contiguous to text section. */ cds_args_ptr -> cds_args.switches.separate_static = "0"b; /* Static in linkage section (to bind). */ cds_args_ptr -> cds_args.switches.have_text = "0"b; /* No text section. */ cds_args_ptr -> cds_args.switches.have_static = "1"b; /* There is a static section. */ cds_args_ptr -> cds_args.switches.pad = "0"b; /* Must be zeroes (see create_data_segment_). */ call create_data_segment_ (cds_args_ptr, code); if code ^= 0 then call com_err_ (code, "cds_gfms_ext"); else call com_err_( 0,"gfms_ext","Object for gfms_ext created [^i words].",size(gfms_ext)); return; %page; /** Data for cds **/ dcl addr builtin; dcl cds_args_ptr ptr init(null()); dcl code fixed bin(35); dcl com_err_ entry options(variable); dcl create_data_segment_ entry(ptr,fixed bin(35)); dcl null builtin; dcl size builtin; dcl unspec builtin; dcl 1 space_for_cds_args aligned like cds_args; %page; /** This data structure must exactly match that of gfms_ext.incl.pl1 **/ dcl 1 gfms_ext aligned, 2 print_routines aligned like gfms_ext$print_routines, 2 temp_segs aligned like gfms_ext$temp_segs, 2 tape_file aligned like gfms_ext$tape_file, 2 options aligned like gfms_ext$options, 2 working_dir char (168) var, 2 mapping_rule char(3), 2 umc_name char(12); %page; %include gfms_ext; %page; %include cds_args; end; gfms_file_content_records_.pl1 12/11/84 1355.9rew 12/10/84 1022.3 318816 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_file_content_records_: proc (); /* Display FILE CONTENT records information. Author: Dave Ward 10/03/80 Change: Dave Ward 10/08/80 isolate printing names. Change: Dave Ward 10/10/80 create and move date to file. Change: Dave Ward 10/13/80 lower case names, handle record_quota_overflow Change: Dave Ward 10/15/80 total records, record entry. Change: Dave Ward 10/16/80 corrected totaling records. Change: Dave Ward 10/17/80 provide gtss file attributes. Change: Dave Ward 10/29/80 adjusted to new tree description. Change: Dave Ward 10/30/80 adjusted to new file name list. Change: Dave Ward 11/12/80 creation date from content record. Change: Dave Ward 11/25/80 bug in selective unloading. Change: Scott C. Akers 02/08/82 Get working directory from gfms_ext$working_dir. Don't blow up on bad file, just skip it. Selective unloading by UMC, use UMC to specify pathname if "-drm umc" applies. Change: Ron Barstad 11/24/82 Fix bug on restoring MSFs--cl was not being set to 0 on new seg Change: Ron Barstad 12/23/82 Fix bug on return from quota overflow fix command level Change: Ron Barstad 11/21/84 Added rtrims to formation of msf paths */ call ioa ("^|FILE CONTENT RECORDS INFORMATION:"); first_warning = "1"b; rqo_in_progress = "0"b; /* Whether processing record quota overflow (0 => not). */ fcbp = null (); /* MSF fcb pointer. */ wd = gfms_ext$working_dir; /* Obtain caller's working directory. */ i = 0; /* Total file count. */ bf = ""; /* Bad file string. */ file_name_list.next_entry = 1; /* Next available start entry. */ file_name_list.nn = 0; /* Number of file names. */ file_name_list.total_llinks = 0; /* Total number llinks in all files. */ if unload then /* Unloading, provide for record quota overflow. */ on condition (record_quota_overflow) call process_rqo ( /* Procedure to call if quota exceeded. */ "Creating file:" ||"^/"||rtrim(wd)||rtrim(sub_dir)||">"||rtrim (file_entry) ); LOOP_1: do while (get_rec () = GOT_RECORD); /* Obtain next file content record. */ if file_continued = "0"b then GROUP_1: do; /* Start f next file. */ i = i+1; /* Count of files. */ t = file_size; /* Total file llinks. */ a = file_llinks_in_record; /* Accumulated file llinks (1st record). */ call block_info; call display_header (bf); call define_file ( /* Establish Multics file in which to unload. */ file_name2 /* (input) file name. */ , file_desc_sect_num /* (input) sector number of file description record. */ , t /* (input) total length of file llinks. */ , bf /* (input) string of codes why file bad. */ , cfd /* (output) gcos catalog/file description. */ , sub_dir /* (output) multics directory path. */ , gcos_file_name /* (output) GCOS file name (upper case). */ , file_entry /* (output) multics file entry name (lower case). */ , fne_ptr /* (output) pointer to file name entry. */ , have_file /* (output) "1"b file definition successful. */ ); unloading_file = "0"b; /* Assume we are not to unload file. */ if have_file then if unload then if do_file (cfd, gcos_file_name) then GROUP_2: do; call create_file ( wd , sub_dir , file_entry , fcbp , c (0) , have_file ); if have_file then do; if gf then /* Provide gtss file attributes. */ call gfms_gtss_attributes_ ( rtrim(wd)||sub_dir /* (input) directory. */ , file_entry /* (input) file name. */ , fne_ptr /* (input) pointer to file name entry. */ , fcr.file_creation_date /* (input) creation date BCD. */ ); cn = 0; /* Current component number. */ cp = c (0); /* Pointer to the Multics file (segment). */ cl, nll = a; /* Number of llinks to move (will not exceed 1st segment <= 3840 words). */ unspec (cp -> move_llinks) = unspec (addr (fcr.words66_nw) -> move_llinks); unloading_file = "1"b; /* File is being unloaded. */ end; end GROUP_2; LOOP_2: do while (t>a); /* total llinks > accumulated llinks. */ i = i+1; if get_rec () = END_OF_FILE then do; call com_err_ ( 0 , "gfms_file_content_records_" , "end of input during continuation record in file ^a" , cfd ); signal condition (gfms_fail); end; if file_continued = "0"b then do; /* This should be a continued record. */ call com_err_ ( 0 , "gfms_file_content_records_" , "File ^a file size ^i accumulated ^i uncontinued record." , cfd , t , a ); end; call block_info; call display_header (bf); if unloading_file then call unload_record; a = a + file_llinks_in_record; /* Number of accumulated llinks moved. */ end LOOP_2; /* "close" the file. */ if unloading_file then do; call msf_manager_$adjust ( fcbp , cn , cl*320*36 , "1"b /* Set the bit count. */ ||"1"b /* truncate the final component. */ ||"1"b /* terminate the component. */ , code ); if code ^= 0 then do; call com_err_ ( code , "gfms_file_content_records_" , "Unable to adjust at component ^i:" ||"^/""^a""" , cn , rtrim(wd)||rtrim(sub_dir)||">"||file_entry ); end; call msf_manager_$close (fcbp); end; if t ^= a then do; /* Accumulated records not equal to total. */ call com_err_ ( 0 , "gfms_file_content_records_" , "File ^a size ^i accumulated ^i." , cfd , t , a ); end; end GROUP_1; else do; /* Continued record after file completed. */ call com_err_ ( 0 , "gfms_file_content_records_" , "Continued record after file ^a completed." , cfd ); end; end LOOP_1; if prfn | tll then call gfms_print_names_ (nn); return; %page; bcd: proc (w)returns (char (13)); /* Convert 6 bcd characters to ascii, convert blanks to underlines (bcd has no underline character, so this distinguishes bcd blanks). Return the 6 characters as a 2 strings of 6 characters each, space in middle, each input character preceeded by a space. */ dcl w bit(36)aligned parm; string (s) = gfms_ascii_ ((w)); /* Convert bcd to ascii. */ string (s) = translate (string (s), "_", " "); /* Convert spaces to underlines. */ string (r) = " "; /* Blank the result. */ do i = 0 to 5; if i<3 then k = 1; else k = 2; r ((i*2)+k) = s (i); /* Distribute to every other character of the output. */ end; return (string (r)); dcl i fixed bin; dcl k fixed bin; dcl r (0:12)char(1)unal; dcl s (0:5)char(1)unal; end bcd; %page; block_info: proc; /* Display and verify block information from file content record. */ call ioa ( "^6i. (block^6i) size^6i record-size^6i" , i , block_serial_number , block_size , record_size ); if no_files_in_record ^= 1 then do; call ioa ("number of files in record not 1 (^i)", no_files_in_record); do i = 0 to 65 by 4; call ioa_nnl ("^12x^2i. ", i); do j = i to (i+3) while (j <= 65); call ioa_nnl (" ^12.3b", w (j)); end; call ioa_nnl ("^/"); end; end; return; end block_info; %page; create_directory: proc (wd, dr); /* Create subdirectories specified by "dr" under directory specified by "wd" */ dcl dr char(168)var parm; dcl wd char(168)var parm; n = 1; on condition (record_quota_overflow) call process_rqo ( "Creating directory:" ||"^/"||rtrim(wd)||">"||rtrim(dr)||">"||ent ); do while (n <= length (dr)); k = index (substr (dr, n), ">"); if k = 0 then k = length (dr)-n+2; if n> 1 then wdir = rtrim(wd)||">"||substr (dr, 1, n-2); else wdir = wd; ent = substr (dr, n, k-1); call hcs_$append_branchx ( wdir /* (input) pathname of containing directory. */ , ent /* (input) name of subdirectory. */ , 01011b /* (input) status, modify and append access for *.*.*. */ , rings /* (input) ring brackets. */ , "*.*.*" /* (input) person project for access. */ , 1 /* (input) directory being created. */ , 0 /* (input) copy switch not on. */ , 0 /* (input) no bit count. */ , code /* (output) storage system status. */ ); if code ^= 0 then if code ^= error_table_$namedup then do; call com_err_ ( code , "gfms" , "Directory: ^a>^a (retryable)" , wdir , ent ); signal condition (gfms_fail); end; n = n+k; end; revert condition (record_quota_overflow); return; dcl ent char(32); dcl k fixed bin; dcl n fixed bin; dcl wdir char(168); end create_directory; %page; create_file: proc (wd, dir, ent, fcbp, p1, fc); /* Create MSF file wd>dir>ent. Set fcbp to MSF file control block (fcb). Set pointer p1 to 1st component. Set fc "1"b if successful. */ dcl dir char(168)var parm; dcl ent char(32)parm; dcl fc bit(1)parm; dcl fcbp ptr parm; dcl p1 ptr parm; dcl wd char(168)var parm; number_of_attempts = 0; try2: ; call msf_manager_$open ( rtrim(wd)||dir , ent , fcbp , code ); if code ^= 0 then if code ^= error_table_$noentry then do; if code = error_table_$no_dir then do; number_of_attempts = number_of_attempts+1; if number_of_attempts = 1 then do; if length (dir)>1 then call create_directory (wd, substr (dir, 2)); goto try2; end; end; call com_err_ ( code , "gfms_file_content_records_" , "Attempting to create:" ||"^/""^a""" , rtrim(wd)||rtrim(dir)||">"||ent ); fc = "0"b; /* Could not create the file. */ return; end; call msf_manager_$get_ptr ( /* Obtain pointer to 1st component. */ fcbp , 0 /* 1st component number. */ , "1"b /* (input) => create file if non-existent. */ , p1 /* (output) pointer to component 0. */ , bc /* (output) bit count. */ , code ); if code ^= 0 then do; if code ^= error_table_$namedup then if code ^= error_table_$segknown then do; call com_err_ ( code , "gfms_file_content_records_" , "Unable to obtain pointer to 1st component of:" ||"^/""^a""" , rtrim(wd)||rtrim(dir)||">"||ent ); fc = "0"b; /* Could not create the file. */ return; end; call msf_manager_$adjust ( /* Truncate existing file. */ fcbp /* (input) pointer to file control block. */ , 0 /* (input) MSF component. */ , 0 /* (input) bit count. */ , "0"b /* (3 bits input) do not set bit count. */ ||"1"b /* truncate the component. */ ||"0"b /* do not terminate the component. */ , code /* (output) status code. */ ); if code ^= 0 then call com_err_ ( code , "gfms" , "Unable to truncate existing file ^a^a>^a" , wd , dir , ent ); end; fc = "1"b; return; dcl number_of_attempts fixed bin; end create_file; %page; define_file: proc (n, s, l, bfc, cfn, dir, fn, ent, fep, defined); /* Look up sector number "s" in the description tree and display the catalog description found. "n" is the BCD name of the file in the header information. "l" is the total length of the file in llinks (=> 320 words @). "bfc" is the bad file code string. "cfn" is to be output the catalog/file name obtained. "dir" is the Multics (sub) directory pathname. "fn" is GCOS file name (upper case). "ent" is the Multics file entry name (fn lower case). "fep" is output set to file name entry. "defined" is "1"b if file defined, else "0"b. */ dcl bfc char(20)var parm; dcl cfn char(200)var parm; dcl defined bit(1)parm; dcl dir char(168)var parm; dcl ent char(32)parm; dcl fep ptr parm; dcl fn char(12)var parm; dcl l fixed bin parm; dcl n bit(72)aligned parm; dcl s fixed bin(18)unsigned unal parm; defined = "1"b; /* Assume file will be defined. */ cfn /* GCOS catalog file description. */ , dir = ""; /* Multics directory pathname. */ fn = rtrim (gfms_ascii_ ((n))); /* GCOS file name (i.e., upper case).. */ ent = translate (fn, lower, upper); /* Multics entry name (lower case). */ /* Locate description record. */ d = start_list.desc (mod (s, hbound (start_list.desc, 1)+1)); do while (d>0); if description (d).sector = s then goto found_desc; d = description (d).link; end; call com_err_ ( /* Unable to find desc. */ 0 , "gfms_file_content_records_" , "Can not find description for sector ^6i (^6.3b oct) ""^a""" , s , unspec (s) , fn ); fail: ; defined = "0"b; /* File not defined. */ goto finish_define_file; found_desc: ; /* Locate file entry of catalog. */ f = start_list.file_child (mod (s, hbound (start_list.file_child, 1)+1)); do while (f>0); if cat (f).child_sector = s then goto found_file; f = cat (f).child_link; end; call com_err_ ( /* Unable to find file catalog. */ 0 , "gfms_file_content_records_" , "Can not find sector ^6i (^6.3b oct) ""^a"" file in catalog." , s , unspec (s) , fn ); goto fail; found_file: ; if (n ^= description (d).name) | (n ^= cat (f).name) then call com_err_ ( /* Names not consistant. */ 0 , "gfms_file_content_records_" , "Names from content, description and catalog not consistant:" ||"^/""^a"", ""^a"" and ""^a""" ||"^/ Using first name." , gfms_ascii_ ((n)) , gfms_ascii_ ((description (d).name)) , gfms_ascii_ ((cat (f).name)) ); /* Search the tree (backwards) to determine the GCOS catalog/file description and correspondingly the Multics pathname. */ next_level_up_tree: ; cs = cat (f).parent_sector; /* Catalog sector of my parent. */ f = start_list.cat_child (mod (cs, hbound (start_list.cat_child, 1)+1)); do while (f>0); if cat (f).child_sector = cs then do; /* Found my parent. */ if length (cfn) = 0 then cfn, dir = cat (f).ascii_name; else do; cfn = cat (f).ascii_name||"/"||cfn; dir = cat (f).ascii_name||">"||dir; end; goto next_level_up_tree; end; f = cat (f).child_link; end; /* Unable to find previous parent. => There is no parent, i.e., catalog/file description terminated. */ /* Collect file information. */ fep, fnep = addr (file_name_list.start_entry (file_name_list.next_entry)); file_name_entry.char_length.defl = length (bfc); file_name_entry.char_length.naml = length (fn); file_name_entry.char_length.catl = length (cfn); if (file_name_list.next_entry + size (file_name_entry)) > hbound (file_name_list.start_entry, 1) then do; if first_warning then call com_err_ ( error_table_$too_many_names , "gfms_file_content_records_" , "Only space for first ^i file names. Continuing." , file_name_list.nn ); first_warning = "0"b; end; else do; /* Store the next file name entry. */ nn = nn+1; file_name_entry.llinks = l; file_name_entry.defective = bfc; file_name_entry.name = fn; file_name_entry.catalog = cfn; unspec (file_name_entry.attr) = unspec (description (d).attributes); file_name_list.next_entry = file_name_list.next_entry + size (file_name_entry); /* Locate next available entry. */ end; total_llinks = total_llinks + l; /* Total llinks for all files. */ finish_define_file: ; cfn = cfn||"/"||fn; /* Complete catalog file description. */ if length (dir)>0 then dir = ">"|| translate (dir, lower, upper); return; dcl cs fixed bin(18)unsigned; dcl d fixed bin; dcl f fixed bin; end define_file; %page; display_header: proc (bfc); /* Display file content header. */ dcl bfc char(20)var parm /* bad file code. */; call ioa_nnl ("^11x"); call ioa_nnl (" file_name2 ^12a", gfms_ascii_ ((file_name2))); call ioa_nnl (" user_name ^12a", gfms_ascii_ ((user_name))); call ioa_nnl (" file_size ^6i llinks", file_size); call ioa_nnl (" file_continued ^1b", file_continued); call ioa_nnl (" file_llinks_in_record ^6i", file_llinks_in_record); call ioa_nnl ("^/^11x"); call ioa_nnl (" record_code ^a", record_code_type ()); call ioa_nnl (" file_desc_sect_num ^6i", file_desc_sect_num); call ioa_nnl ("^/^11x"); if abort_locked ^= "0"b then do; bfc = bfc||" AL"; call ioa_nnl (" abort_locked ^1b", abort_locked); end; if defective_space ^= "0"b then do; bfc = bfc||" DS"; call ioa_nnl (" defective_space ^1b", defective_space); end; if saved_while_write_busy ^= "0"b then do; bfc = bfc||" WB"; call ioa_nnl (" saved_while_write_busy ^1b", saved_while_write_busy); end; if file_creation_date ^= "0"b then call ioa_nnl (" file_creation_date ^12a", gfms_date_ (file_creation_date)); if defective_llinks ^= "0"b then do; bfc = bfc||" DL"; call ioa_nnl (" defective_llinks ^4.3b", defective_llinks); end; if part_of_file ^= "0"b then do; bfc = bfc||" PF"; call ioa_nnl (" part_of_file ^1b", part_of_file); end; call ioa_nnl ("^/"); return; end display_header; %page; do_file: proc (c, f)returns (bit (1)); /* Return "1"b if caller designated that catalog file description "c" or file "f" is to be unloaded. */ dcl c char(200)var parm; dcl f char(12)var parm; if file_names.number_names < 1 then return ("1"b); /* => do all. */ k = file_start (gfms_hash_ ((f), hbound (file_start, 1)+1)); do while (k>0); /* Examine if file name specified. */ if file_name (k).name = f then do; if file_name (k).not then return ("0"b); /* Do not unload file f. */ return ("1"b); /* Do unload file f. */ end; k = file_name (k).link; end; k = cat_start (gfms_hash_ ((c), hbound (cat_start, 1)+1)); do while (k>0); /* Examine if file name specified. */ if file_name (k).name = c then do; if file_name (k).not then return ("0"b); /* Do not unload file f. */ return ("1"b); /* Do unload file f. */ end; k = file_name (k).link; end; return ("0"b); /* Neither specified. Don't unload. */ dcl gfms_hash_ entry (char(*), fixed bin) returns(fixed bin); dcl k fixed bin; %include gfms_do_files; end do_file; %page; dump_rec: proc (p, l); /* Display record BCD and octal. */ dcl l fixed bin parm; dcl p ptr parm; n = l-1; /* Number counting from 0 of l words. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^5x"); do i = 0 to 7; /* Print header. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^13x^i", i); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); do i = 0 by 8 to n; if i>0 then if last_line = current_line then do; if first then do; first = "0"b; call ioa_$ioa_switch_nnl (iox_$error_output, "^6x^12(=^)"); call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); end; goto next_line; end; first = "1"b; call ioa_$ioa_switch_nnl (iox_$error_output, "^4i.", i); do j = i to (i+8-1) while (j <= n); /* Print bcd. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^13a", bcd (w (j))); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/^5x"); do j = i to (i+8-1) while (j <= n); /* Print octal. */ call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^6.3b'^6.3b", wl (j), wr (j)); end; call ioa_$ioa_switch_nnl (iox_$error_output, "^/"); next_line: ; end; return; dcl current_line bit(min(8,l-i)*36)aligned based(addr(w(i))); dcl first bit(1); dcl i fixed bin; dcl ioa_$ioa_switch_nnl entry() options(variable); dcl iox_$error_output ptr ext static; dcl j fixed bin; dcl last_line bit(min(8,l-i)*36)aligned based(addr(w(i-8))); dcl n fixed bin; dcl w (0:n)bit(36)aligned based(p); dcl 1 w2 (0:n)aligned based(p) , 2 wl bit(18)unal , 2 wr bit(18)unal ; end dump_rec; %page; get_rec: proc returns (fixed bin); /* Obtain the next FILE CONTENT record from tape. Returns END_OF_FILE when no more input. Returns GOT_RECORD when a good record is read. Returns SKIP_FILE when a sick record is read. If we're restoring a specific UMC, then get_rec "eats" all records which don't belong to the user name specified, and only returns when one of the foregoing conditions is satisfied. */ more: ; call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (fcr_space) /* (input) record buffer. */ , size (fcr_space)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then if code = error_table_$end_of_info then if gfms_end_of_input_ ( addr (fcr_space) /* (input) pointer to input buffer. */ , size (fcr_space)*4 /* (input) length of buffer (bytes). */ , nbr /* (input/output) current number bytes in buffer. */ ) then return (END_OF_FILE); /* No more tape input. */ else goto cont; /* Next reel in process. */ else if code ^= error_table_$long_record then do; call com_err_ ( code , "gfms_file_content_records_" , "Attempting to read file content record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (fcr_space)*4 , nbr , attach_description ); fail: ; signal condition (gfms_fail); end; cont: ; lc_uname = translate (gfms_ascii_ ((user_name)), lower, upper); if gfms_ext$umc_name ^= "" /* Skip this record if it's not related to the specified UMC. */ & lc_uname ^= gfms_ext$umc_name then goto more; if gfms_ext$mapping_rule = "umc" /* Gotta put the stuff in the right place. */ then wd = rtrim (gfms_ext$working_dir) || ">" || rtrim (lc_uname) || ">" || rtrim (lc_uname); if mod (nbr, 4) ^= 0 then /* Make sure length in words is consistent. */ call com_err_ ( 0 , "gfms_file_content_records_" , "Bytes read (^i) not word modulo, will truncate to word and continue." , nbr ); nwr = divide (nbr, 4, 17); /* Number of words read. */ if nwr = 66 then if block_size = 65 then if record_size = 64 then if no_files_in_record = 1 then if file_llinks_in_record = 0 then do; /* Empty content record. */ call com_err_ ( 0 , "gfms_file_content_records_" , "Empty content record (file ^i) for ""^a""" , i , gfms_ascii_ ((file_name2)) ); i = i+1; /* Count file. */ goto more; end; nw = nwr-1; /* upper bound of fcr structure. */ if nw < lbound (words66_nw, 1) then do; call com_err_ ( 0 , "gfms_file_content_records_" , "Faulty file content record." ||"^/file ^i, ^i bytes read." ||"^2/File contents will be inconsistent." , i , nbr ); call dump_rec (addr (fcr_space), nwr); return (SKIP_FILE); /* Skip this file. */ end; return (GOT_RECORD); end get_rec; %page; process_rqo: proc (m); /* Process record quota overflow (message m). */ dcl m char(*)parm; call user_info_$process_type (t); if t ^= 1 then do; /* Not interactive caller. */ call com_err_ ( 0 , "gfms" , "Record quota overflow. "||m ); signal condition (gfms_fail); end; if rqo_in_progress then do; call com_err_ ( 0 , "gfms" , "Successive record quota overflow." ||"^/Can not continue." ); signal condition (gfms_fail); end; rqo_in_progress = "1"b; version = query_info_version_4; yes_or_no_sw = "1"b; /* Accept only yes or no. */ suppress_name_sw = "1"b; /* Include name. */ suppress_spacing = "1"b; cp_escape_control = "00"b; /* Obey default. */ status_code = error_table_$rqover; /* record quota overflow. */ query_code = 0; question_iocbp, answer_iocbp = null (); repeat_time = 0; /* Don't repeat question. */ call command_query_ ( addr (query_info) , ans , "gfms" , "Record quota overflow. "||m ||"^/Do you want to correct? " ); if ans = "no" then signal condition (gfms_fail); on condition (program_interrupt) rqo_in_progress = "0"b; call ioa_ ("You're at command level. Correct and ""pi"""); call cu_$cl (); if ^rqo_in_progress then return; call com_err_ ( 0 , "gfms_file_content_records_" , "Record quota overflow. Cannot continue." ); signal condition (gfms_fail); dcl ans char(3)var; dcl command_query_ entry() options(variable); dcl cu_$cl entry(); dcl program_interrupt condition ext; dcl t fixed bin; dcl user_info_$process_type entry (fixed bin); end process_rqo; %page; record_code_type: proc returns (char (*)); /* Evaluate record code. */ if record_code = 0 then return ("NORMAL"); if record_code = 1 then return ("DELAYED FILE, CONTENT FOLLOWS HEADER"); if record_code = 2 then return ("DELAYED FILE, CONTENT LATER"); if record_code = 4 then return ("NO CONTENT SAVED"); return ("UNKNOW RECORD CODE "||ltrim (char (record_code))); end record_code_type; %page; unload_record: proc; /* Unload the current data record into the Multics file. */ l = file_llinks_in_record; /* Expected number of llinks to move. */ if (cl + l) > llinks_per_segment then do; /* About to span a Multics segment. */ pl, nll = llinks_per_segment - cl; /* Fill out the segment. */ l = l - pl; /* Reduce llinks in record by amount moved. */ unspec (addrel (cp, 320*cl) -> move_llinks) = /* Move initial part of record. */ unspec (addr (fcr.words66_nw) -> move_llinks); /* Move to next MFS component. */ cn = cn+1; if cn > hbound (c, 1) then do; /* Exceeded MSF number of components. */ call com_err_ ( code , "gfms_file_content_records_" , "Exceeded ^i maximum number allowed MSF components:" ||"^/""^a""" , hbound (c, 1) , rtrim(wd)||rtrim(sub_dir)||">"||file_entry ); signal condition (gfms_fail); /* FOR NOW. */ end; call msf_manager_$get_ptr ( /* Obtain the next MSF component (segment). */ fcbp , cn /* Component number. */ , "1"b /* (input) => create file if non-existent. */ , c (cn) , bc /* (output) bit count. */ , code ); if code ^= 0 then if code ^= error_table_$segknown then do; call com_err_ ( code , "gfms_file_content_records_" , "Unable to obtain pointer to component ^i of:" ||"^/""^a""" , cn , rtrim(wd)||rtrim(sub_dir)||">"||file_entry ); signal condition (gfms_fail); end; cp = c (cn); cl = 0; /* Reset to next component segment. */ end; else pl = 0; /* Start of data record to be moved. */ nll = l; /* Number llinks to move. */ unspec (addrel (cp, 320*cl) -> move_llinks) = /* Move final part of record. */ unspec (addrel (addr (fcr.words66_nw), 320*pl) -> move_llinks); cl = cl + nll; /* Curren length. */ return; end unload_record; %page; /* Variables for gfms_file_content_records_: */ /* IDENTIFIER ATTRIBUTES */ dcl a fixed bin; dcl addr builtin; dcl addrel builtin; dcl bc fixed bin(24); dcl bf char(20)var; dcl c (0:499)ptr; dcl cat_ptr ptr init(null()); dcl cfd char(200)var; dcl char builtin; dcl cl fixed bin(24); /* current length in llinks of seg */ dcl cn fixed bin; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl cp ptr; dcl divide builtin; dcl END_OF_FILE fixed bin internal static options (constant) init (3); dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$long_record fixed bin(35) ext static; dcl error_table_$namedup fixed bin(35) ext static; dcl error_table_$noentry fixed bin(35) ext static; dcl error_table_$no_dir fixed bin(35) ext static; dcl error_table_$rqover fixed bin(35) ext static; dcl error_table_$segknown fixed bin(35) ext static; dcl error_table_$too_many_names fixed bin(35) ext static; dcl fcbp ptr; dcl fcr_space (3906)bit(36)aligned; dcl file_entry char(32); dcl first_warning bit(1); dcl fne_ptr ptr init(null()); dcl gcos_file_name char(12)var; dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_date_ entry (bit(36) aligned) returns(char(8)); dcl gfms_end_of_input_ entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1)); dcl gfms_fail condition ext; dcl gfms_gtss_attributes_ entry (char(186), char(32), ptr, bit(36) aligned); dcl gfms_print_names_ entry(fixed bin); dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl GOT_RECORD fixed bin internal static options (constant) init (2); dcl have_file bit(1); dcl hbound builtin; dcl i fixed bin; dcl index builtin; dcl ioa_ entry() options(variable); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl j fixed bin; dcl l fixed bin; dcl lbound builtin; dcl lc_uname char (12); dcl length builtin; dcl llinks_per_segment fixed bin static int options(constant)init(816); dcl lower char(26)static int options(constant)init("abcdefghijklmnopqrstuvwxyz"); dcl ltrim builtin; dcl min builtin; dcl mod builtin; dcl move_llinks (nll) bit(36*320)aligned based; dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); dcl nbr fixed bin(21); dcl nll fixed bin; dcl null builtin; dcl nw fixed bin; dcl nwr fixed bin; dcl pl fixed bin; dcl record_quota_overflow condition ext; dcl rings (3)fixed bin(3)static int options(constant)init(4,4,4); dcl rqo_in_progress bit(1); dcl rtrim builtin; dcl SKIP_FILE fixed bin internal static options (constant) init (1); dcl size builtin; dcl string builtin; dcl substr builtin; dcl sub_dir char(168)var; dcl t fixed bin; dcl translate builtin; dcl unloading_file bit(1); dcl unspec builtin; dcl upper char(26)static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl w (0:65)bit(36)aligned based(addr(fcr_space)); dcl wd char(168)var; dcl hcs_$append_branchx entry ( char(*) , char(*) , fixed bin(5) , (3) fixed bin(3) , char(*) , fixed bin(1) , fixed bin(1) , fixed bin(24) , fixed bin(35) ); %page; /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-27 FILE CONTENT RECORDS (<=3906 words) */ dcl 1 fcr aligned based(addr(fcr_space)) , 3 word0 , 4 block_serial_number fixed bin(18)unsigned unal , 4 block_size fixed bin(18)unsigned unal , 3 word1 , 4 record_size fixed bin(18)unsigned unal , 4 b18_35 bit(18)unal , 3 content_header , 4 word2 , 5 record_code fixed bin(4)unsigned unal , 5 no_files_in_record fixed bin(4)unsigned unal /* always 1. */ , 5 serial_no_records_in_file fixed bin(4)unsigned unal , 5 SMC_section_no fixed bin(6)unsigned unal , 5 RFG1 bit(18)unal /* RFG => reserved For GCOS. */ , 4 words3_4 , 5 user_name bit(72) , 4 word5 , 5 file_desc_sect_num fixed bin(18)unsigned unal , 5 RFG6 bit(1)unal , 5 abort_locked bit(1)unal , 5 RFG7 bit(7)unal , 5 defective_space bit(1)unal , 5 RFG8 bit(7)unal , 5 saved_while_write_busy bit(1)unal , 4 word6 , 5 file_creation_date bit(36) , 4 word7 , 5 time_at_create bit(24)unal , 5 prior_creation bit(12)unal , 4 word8 , 5 file_continued bit(1)unal , 5 file_llinks_in_record fixed bin(4)unsigned unal , 5 RFG2 bit(1)unal , 5 defective_llinks bit(12)unal , 5 RFG3 bit(18)unal , 4 word9 , 5 part_of_file bit(1)unal , 5 RFG4 bit(11)unal , 5 file_size fixed bin(24)unsigned unal , 4 words10_11 , 5 file_name bit(72) , 4 words12_13 , 5 file_name2 bit(72) , 4 words14_64 , 5 RFG5 (14:64)bit(36) , 4 word65 , 5 checksum bit(36) , 3 words66_nw (66:nw)bit(36) ; %page; %include gfms_description_tree; %page; %include gfms_ext; %page; %include gfms_file_name_list; %page; %include query_info; end gfms_file_content_records_; gfms_file_name_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 17784 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_file_name_: proc (nf, fn)returns (bit (1)); /* Hash file name "fn" as selected or not selected (nf="0"b or nt="1"b). Return "1"b if failure. Author: Dave Ward 10/19/80 Change: Dave Ward 10/30/80 provide catalog (/) and file name. */ dcl fn char(*)parm; dcl nf bit(1)parm; if number_names >= hbound (file_name, 1) then do; if number_names = hbound (file_name, 1) then call com_err_ ( 0 , "gfms_file_name_" , "Exhausted ^i entries available in file name list." , hbound (file_name, 1) ); number_names = number_names+1; return ("1"b); /* Failure. */ end; if index (fn, "/")>0 then sp = addr (cat_start); else sp = addr (file_start); uc_fn = translate ( fn , "ABCDEFGHIJKLMNOPQRSTUVWXYZ" , "abcdefghijklmnopqrstuvwxyz" ); k = gfms_hash_ ((uc_fn), hbound (start, 1)+1); number_names = number_names+1; file_name (number_names).not = nf; file_name (number_names).link = start (k); start (k) = number_names; file_name (number_names).name = uc_fn; return ("0"b); /* Success. */ %page; /* Variables for gfms_file_name_: */ /* IDENTIFIER ATTRIBUTES */ dcl com_err_ entry() options(variable); dcl gfms_hash_ entry (char(*), fixed bin) returns(fixed bin); dcl index builtin; dcl k fixed bin; dcl sp ptr; dcl start (0:1020)fixed bin based(sp); dcl translate builtin; dcl uc_fn char(168)var; %page; %include gfms_do_files; %page; %include gfms_ext; end gfms_file_name_; gfms_gtss_attributes_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 23229 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_gtss_attributes_: proc (dir, ent, fep, date); /* Provide gtss attributes on file dir>ent Author: Dave Ward 10/17/80 Change: Dave Ward 10/30/80 fep parameter, new file name list. Change: Dave Ward 11/12/80 change date to a parameter. Change: Dave Ward 11/21/80 corrected setting mode random. */ dcl date bit(36)aligned parm; dcl dir char(168)parm; dcl ent char(32)parm; dcl fep ptr parm; fnep = fep; gtss_file_values.version = 1; gtss_file_values.dname = dir; gtss_file_values.ename = " "; gtss_file_values.new_ename = ent; gtss_file_values.change_name = "0"b; /* Do not change name of file. */ gtss_file_values.set_switch.mode_random , gtss_file_values.set_switch.maxll , gtss_file_values.set_switch.curll , gtss_file_values.set_switch.busy , gtss_file_values.set_switch.attr , gtss_file_values.set_switch.null_file , gtss_file_values.set_switch.number_allocations , gtss_file_values.set_switch.creation_date = "1"b; gtss_file_values.data_flags.mode_random = ((file_name_entry.attr.mode & "0100"b) ^= "0"b); gtss_file_values.data_fields.maxll = file_name_entry.attr.max_size_llinks; gtss_file_values.data_fields.curll = file_name_entry.llinks; gtss_file_values.data_flags.busy = "0"b; gtss_file_values.attributes.attr = file_name_entry.user_info.value; gtss_file_values.data_flags.null_file = "0"b; gtss_file_values.data_fields.number_allocations = 0; gtss_file_values.creation_date = gfms_ascii_ ((date)); call gtss_attributes_mgr_$set (addr (gtss_file_values), code); if code ^= 0 then call com_err_ ( code , "gfms_gtss_attributes_" , "For ^a>^a." , dir , ent ); return; %page; /* Variables for gfms_gtss_attributes_ */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl gtss_attributes_mgr_$set entry (ptr, fixed bin(35)); dcl gfms_ascii_ entry (bit(*)) returns(char(*)); %page; %include gfms_file_name_list; %page; %include gtss_file_values; %page; %include gfms_description_tree; %page; %include gfms_ext; end gfms_gtss_attributes_; gfms_hash_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 10980 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_hash_: proc (s, m) returns (fixed bin); /* Return "v" mod "m", where "v" is the binary value obtained by catenating the length, first character, middle character, and last (right) character of "s" (as binary values, 9 bits @). Author: Dave Ward 05/28/80 (from HASH.pl1) */ dcl m fixed bin parm; dcl s char (*) parm; l = length (s); unspec (bv) = substr (unspec (l), 28, 9) || unspec (substr (s, 1, 1)) || unspec (substr (s, divide ((l+1), 2, 35, 0), 1)) || unspec (substr (s, l, 1)); return ((mod (bv, m))); dcl bv fixed bin (35); dcl divide builtin; dcl l fixed bin (35); dcl mod builtin; dcl substr builtin; dcl unspec builtin; %page; %include gfms_ext; end gfms_hash_ ; gfms_hash_cat_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 24930 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_hash_cat_: proc (b_name, a_name, ic, ps, cs); /* Store the catalog entry in the description tree. Entry is a catalog (ic="1"b) or a file (ic="0"b). Sector number of parent is "ps" and of child is "cs". The name of the entry is BCD "b_name" and equivently ASCII "a_name". Author: Dave Ward 11/08/80 */ dcl b_name bit(72)aligned parm; dcl a_name char(12)var parm; dcl ic bit(1)parm; dcl ps fixed bin(18)unsigned unal parm; dcl cs fixed bin(18)unsigned parm; /* Record entry name in cat array. */ n_cat = n_cat+1; if n_cat > hbound (cat, 1) then do; call com_err_ ( 0 , "gfms_hash_cat_" , "Exhausted ^i entries of cat table." , hbound (cat, 1) ); signal cond (gfms_fail); end; cat (n_cat).name = b_name; /* entry name BCD. */ cat (n_cat).ascii_name = a_name; /* entry name ASCII. */ cat (n_cat).is_cat = ic; /* catalog ("1"b) or file ("0"b) entry. */ cat (n_cat).parent_sector = ps; /* sector of my parent. */ cat (n_cat).child_sector = cs; /* sector of my child (subcatalog or file description). */ /* Hash child sector number into one of two lists according to whether this is a catalog entry or a file entry. */ if ic then /* entry is a catalog. */ slp = addr (start_list.cat_child); else /* entry is a file. */ slp = addr (start_list.file_child); k = mod (cs, hbound (slp -> start_list, 1)+1); j = slp -> start_list (k); do while (j>0); /* Assure name not currently hashed. */ if cat (j).child_sector = cs then do; call com_err_ ( 0 , "gfms_hash_cat_" , "BUG, multiple occurance of ""^a"" (sector ^6i ^6.3b oct)" , a_name , cs , unspec (cs) ); return; end; j = cat (j).child_link; end; /* New name to enter in the hashed list. */ cat (n_cat).child_link = slp -> start_list (k); /* Link new name to previous hash entry. */ slp -> start_list (k) = n_cat; /* Link this name as the first in hash list. */ return; %page; /* Variables for gfms_hash_cat_: */ /* IDENTIFIER ATTRIBUTES */ dcl gfms_fail condition ext; dcl com_err_ entry() options(variable); dcl mod builtin; dcl hbound builtin; dcl addr builtin; dcl j fixed bin; dcl k fixed bin; dcl slp ptr; dcl start_list (0:1020)fixed bin(18)unsigned based; %page; %include gfms_description_tree; %page; %include gfms_ext; end gfms_hash_cat_; gfms_header_label_.pl1 12/11/84 1355.9rew 12/10/84 1022.4 88551 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_header_label_: proc; /* Process the tape header label. Author: Dave Ward 10/17/80 Change: Dave Ward 01/27/81 signal gfms_return if attach fails. Change: Dave Ward 02/23/82 completed tape density algorithm (modeled after read_tape_and_query) Change: Ron Barstad 84-11-21 fixed subsequent tape density checking and reel sequence check */ close, detach = "0"b; /* Assume failure. */ call attach; detach = "1"b; /* detach allowed, attach completed. */ call open; close = "1"b; /* close allowed, open completed. */ call get_density (); call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (tape_label) /* (input) record buffer. */ , size (tape_label)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms_header_label_" , "Attempting to read tape header label file." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (tape_label)*4 , nbr , attach_description ); fail: ; call gfms_dump_rec_ ( addr (tape_label) , divide (nbr+3, 4, 17) ); signal cond (gfms_fail); end; if label_identifier ^= GE__600_BTL_ then do; call com_err_ ( 0 , "gfms_header_label_" , "Label identifier ""^12a"" not ""GE 600 BTL """ , gfms_ascii_ ((label_identifier)) ); goto fail; end; prn = gfms_ascii_ ((prverr)); /* Previous reel number in error. */ reel_serial = gfms_ascii_ ((reel_serial_number)); file_serial = gfms_ascii_ ((file_serial_number)); reel_sequence = gfms_ascii_ ((reel_sequence_number)); if file_serial_num = " " then do; /* Initialize saved label information. */ reel_serial_num = reel_serial; file_serial_num = file_serial; reel_sequence_num = (6)"0"; end; call validate_label; call ioa ("^|HEADER LABEL INFORMATION:"); call ioa ("label_identifier^6(.^) ""GE 600 BTL """); call ioa ("installation_id^7(.^) ^a", gfms_ascii_ ((installation_id))); call ioa ("reel_serial_number^4(.^) ^a", reel_serial); call ioa ("file_serial_number^4(.^) ^a", file_serial); call ioa ("reel_sequence_number^2(.^) ^a", reel_sequence); string (yyddd) = gfms_ascii_ ((creation_date)); call ioa ("creation_date^9(.^) year "||year||" day-of-year "||day_of_year); call ioa ("retention_days^8(.^) ^a", gfms_ascii_ ((retention_days))); call ioa ("file_name^13(.^) ^a", gfms_ascii_ ((file_name))); call ioa ("user_info^13(.^) ^a", gfms_ascii_ ((user_info))); call ioa ("prverr^16(.^) ^a", prn); /* Position to the file after the label file. */ call iox_$control ( cbp /* (input) pointer to I/O switch. */ , "forward_file" /* (input) control order. */ , null () /* (input) NOT USED FOR THIS ORDER. */ , code /* (output) I/O status code. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms" , "positioning to file after header label. description^/^c" , attach_description ); goto fail; end; return; %page; attach: proc; /* Attach I/O switch "gfms_input" to I/O module tape_nstd_. */ call iox_$attach_name ( "gfms_input" /* (input) I/O switch name. */ , cbp /* (output) pointer to switch's control block. */ , attach_description /* (input) attach description. */ , null () /* (input) usual search rules to find tape_nstd_. */ , code /* (output) I/O system status code. */ ); if code = 0 then return; call com_err_ ( code , "gfms" , "attaching with description^/^a" , attach_description ); signal cond (gfms_return); dcl code fixed bin(35); dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl null builtin; end attach; %page; get_density: proc; /* Determine the density of the input tape by successively trying tape densities until successful. If failure report, close and detach. */ ad = ""; do i = ftd to ltd; ad = ad||tape_densities (i); call iox_$control ( cbp /* (input) pointer to I/O switch. */ , "d"||tape_densities (i) /* (input) set tape density control order. */ , null () /* (input) NOT USED FOR THIS ORDER. */ , code /* (output) I/O status code. */ ); if code = 0 then do; /* Able to open at density d(i). */ call iox_$read_record ( /* Attempt to read at the density set. */ cbp /* (input) pointer to control block. */ , addr (tape_label) /* (input) record buffer. */ , size (tape_label)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); call iox_$control ( /* Rewind the tape. */ cbp , "rewind" , null () , (0) /* Status code. Ignored. */ ); if code = 0 then /* Able to read at the density. */ return; /* Success. */ end; end; call com_err_ ( code , "gfms" , "unable to set any density (^a) description^/^a" , ad , attach_description ); call gfms_close_; call gfms_detach_; goto fail; dcl ad char(25)var; dcl code fixed bin(35); dcl i fixed bin; dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); %include gfms_tape_densities; end get_density; %page; open: proc; /* Open I/O switch. */ call iox_$open ( cbp /* (input) pointer to control block. */ , 4 /* (input) sequential input. */ , "0"b /* (input) UNUSED. */ , code ); if code = 0 then return; call com_err_ ( code , "gfms" , "sequential input opening for attach description^/^a" , attach_description ); call gfms_detach_; goto fail; dcl code fixed bin(35); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); end open; %page; validate_label: proc; /* Validate that label is consistant with previous label. */ if file_serial ^= file_serial_num then do; call com_err_ ( 0 , "gfms_header_label_" , "Current reel ^a, sequence number ^a, in file ^a" ||"^/Expecting file ^a(reel ^a, sequence ^a)." , file_serial , reel_sequence , reel_serial , file_serial_num , reel_serial_num , reel_sequence_num ); goto fail; end; if verify (ltrim (reel_sequence), "0123456789")>0 then do; call com_err_ ( 0 , "gfms_header_label_" , "Reel sequence number ""^a"" not all numeric." , reel_sequence ); goto fail; end; if prn = " " then /* preceding EOR label not erroneous. */ if fixed (substr(reel_sequence,2), 17) ^= (fixed (substr(reel_sequence_num,2), 17)+1) then do; call com_err_ ( 0 , "gfms_header_label_" , "Reel ^a (file ^a) out of sequence." ||"^/last sequence ^a, current sequence ^a." , reel_serial , file_serial , reel_sequence_num , reel_sequence ); goto fail; end; else if reel_serial ^= reel_serial_num then do; call com_err_ ( 0 , "gfms_header_label_" , "File ^a sequence number ^a reel serial ^a, expected reel serial ^a." , file_serial , reel_sequence , reel_serial , reel_serial_num ); call command_query_$yes_no (yes, 0, "gcos_fms", "Do you want to ignore the reel serial mismatch and process the mounted tape next?", "Ignore?"); if ^yes then goto fail; end; return; end validate_label; %page; /* Variables for gfms_header_label_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl command_query_$yes_no entry() options(variable); dcl divide builtin; dcl file_serial char(6); dcl GE__600_BTL_ bit(72)static int options(constant)init("272520200600002022634320"b3); dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_close_ entry; dcl gfms_detach_ entry; dcl gfms_dump_rec_ entry (ptr, fixed bin); dcl gfms_fail condition ext; dcl gfms_return condition ext; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl ioa_ entry() options(variable); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl nbr fixed bin(21); dcl prn char(6); dcl reel_sequence char(6); dcl reel_serial char(6); dcl size builtin; dcl yes bit(1); /* See DD07 (April 1974) FILE AND RECORD CONTROL Page 11-2 standard label format. */ dcl 1 tape_label aligned , 3 label_identifier bit(72) , 3 installation_id bit(36) , 3 reel_serial_number bit(36) , 3 file_serial_number bit(36) , 3 reel_sequence_number bit(36) , 3 creation_date bit(36) , 3 retention_days bit(36) , 3 file_name bit(72) , 3 user_info bit(108) , 3 prverr bit(36) ; dcl 1 yyddd aligned , 3 blank char(1)unal , 3 year char(2)unal , 3 day_of_year char(3)unal ; %page; %include gfms_ext; end gfms_header_label_; gfms_input_file_list_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 29205 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_input_file_list_: proc (fn)returns (bit (1)); /* Obtain list of names from input file "fn[.gfms]". File contains list of gcos catalog/file descriptions optionally preceeded by "^" (not) character indicating file is not o be selected. Return "1"b if failure occurs. Author: Dave Ward 10/19/80 */ dcl fn char(*)parm; call expand_pathname_$add_suffix ( fn /* (input) pathanme. */ , "gfms" /* (input) suffix name. */ , dir /* (output) directory. */ , ent /* (output) entry name. */ , code /* (output) eror code. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms_input_file_list_" , "Could not expand ""^a""" , fn ); return ("1"b); /* Failed. */ end; call hcs_$initiate_count ( /* Obtain input file. */ dir /* (input) directory name. */ , ent /* (input) entry name. */ , "" /* (input) null reference name. */ , bc /* (output) file's bit count. */ , 1 /* (input) not a copy. */ , fp /* (output) pointer to input file. */ , code /* (output) status code. */ ); if fp = null () then do; call com_err_ ( code , "gfms_input_file_list_" , "Input file ""^a>^a""" , dir , ent ); return ("1"b); /* Failed. */ end; /* Process names from input file. */ il = divide (bc+8, 9, 24); nc = 1; dcl f bit(1)init("0"b); do while (nc <= il); k = index (substr (is, nc), NL); if k = 0 then nc = il-nc+2; if k>1 then do; /* Non-null line. */ n = "0"b; /* => no "^". */ if k>2 then do; if substr (is, nc, 1) = "^" then do; n = "1"b; /* => "^"file. */ nc = nc+1; k = k-1; end; end; if gfms_file_name_ (n, substr (is, nc, k-1)) then f = "1"b; end; nc = nc+k; end; return (f); %page; /* Variables for gfms_input_file_list_: */ /* IDENTIFIER ATTRIBUTES */ dcl bc fixed bin(24); dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl dir char(168); dcl ent char(32); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl fp ptr; dcl gfms_file_name_ entry (bit(1), char(*)) returns(bit(1)); dcl hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)); dcl il fixed bin; dcl ioa_ entry() options(variable); dcl is char(il)aligned based(fp); dcl k fixed bin; dcl n bit(1); dcl nc fixed bin(24); dcl NL char(1)static int options(constant)init(" "); %page; %include gfms_do_files; %page; %include gfms_ext; end gfms_input_file_list_; gfms_print_names_.pl1 12/11/84 1355.9rew 12/10/84 1022.4 79965 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_print_names_: proc (n); /* Sort and print file names (n names) Author: Dave Ward 10/10/80 Change: Dave Ward 10/15/80 totals. Change: Dave Ward 10/16/80 separate file name and catalog. Change: Dave Ward 10/30/80 reel, date time header. Change: Dave Ward 11/11/80 bug in sort comparison routine. Change: Dave Ward 11/18/80 periods in attributes and defect display. */ dcl n fixed bin parm; j = 1; /* Index to first start entry. */ do i = 1 to n; /* Prepare index to file name entries. */ fnep = addr (start_entry (j)); /* Locate next file name entry. */ sa (i) = j; /* j => index to entry. */ j = j + size (file_name_entry); end; if prfn then do; call SORT ((n), sa, cmp); /* Print in sorted order. */ if dump then call ioa_$nnl ("^|"); /* New page if dumping or printing tree. */ call date_time_ (clock_ (), dt); call ioa_ ( "gcos_fms (version ^a)" ||"^/tape reel ^a ^a" , version , file_serial_num , dt ); call ioa_ ( "^/" /* Skip line after header. */ || "^23tS sequential file" ||"^/^23tR random" ||"^/^23tA ascii" ||"^/^23tI I-D-S" ||"^/" ||" maximum v| user defect file" /* 1st header line. */ ||"^/" /* Skip a line. */ ||" llinks llinks mode information code name catalog" /* 2nd header line. */ ); print_name, last_name = " "; do i = 1 to n; fnep = addr (start_entry (sa (i))); /* Located next file name entry in sorted order. */ if file_name_entry.name = last_name then print_name = " "; else print_name, last_name = file_name_entry.name; l = length (file_name_entry.defective); call ioa_ ( "^4i." /* name count. */ ||"^7i" /* current size. */ ||"^[ no limit^s^;^9i^]" /* max size. */ ||"^1x^4a" /* mode */ ||"^1x^[^12.3b^;^6( .^)^s^]" /* user info. */ ||"^1x^[^va^;.^s^s^]^va" /* defective. */ ||"^1x^12a" /* file name. */ ||"^1x^a" /* catalog */ , i , file_name_entry.llinks , file_name_entry.attr.max_size_llinks = 0, file_name_entry.attr.max_size_llinks , md (file_name_entry.attr.mode) , file_name_entry.attr.present, file_name_entry.attr.value , l>0, l, file_name_entry.defective, 12-max (1, l), substr ((6)" .", 1, 12-max (1, l)) , print_name , file_name_entry.catalog ); end; if tll then call ioa_ ( "TOTAL^7i" , total_llinks ); end; else if tll then call ioa_ ( "^6i llinks ^6i files." , total_llinks , n ); return; %page; cmp: proc (i1, i2)returns (fixed bin); /* Compare 2 file name entries to determine sorted order. */ dcl i1 fixed bin parm; dcl i2 fixed bin parm; p1 = addr (start_entry (i1)); p2 = addr (start_entry (i2)); if f1.name < f2.name then return (0); if f1.name > f2.name then return (1); if f1.catalog < f2.catalog then return (0); if f1.catalog > f2.catalog then return (1); if f1.llinks < f2.llinks then return (0); if f1.llinks > f2.llinks then return (1); return (0); dcl p1 ptr; dcl p2 ptr; dcl 1 f1 aligned based(p1) , 3 llinks fixed bin(24) /* llinks in file. */ , 3 attr like description_tree.attributes , 3 char_length /* Lengths of variable. */ , 4 defl fixed bin , 4 naml fixed bin , 4 catl fixed bin , 3 defective char(f1.char_length.defl)unal , 3 name char(f1.char_length.naml)unal , 3 catalog char(f1.char_length.catl)unal ; dcl 1 f2 aligned based(p2) , 3 llinks fixed bin(24) /* llinks in file. */ , 3 attr like description_tree.attributes , 3 char_length /* Lengths of variable. */ , 4 defl fixed bin , 4 naml fixed bin , 4 catl fixed bin , 3 defective char(f2.char_length.defl)unal , 3 name char(f2.char_length.naml)unal , 3 catalog char(f2.char_length.catl)unal ; end cmp; %page; md: proc (m)returns (char (4)); /* Evaluate mode m. */ dcl m bit(4)unal parm; r = " "; if m & "1000"b then substr (r, 1, 1) = "S"; /* Sequential. */ if m & "0100"b then substr (r, 2, 1) = "R"; /* Random. */ if m & "0010"b then substr (r, 3, 1) = "A"; /* ASCII. */ if m & "0001"b then substr (r, 4, 1) = "I"; /* IDS. */ return (r); dcl r char(4); end md; %page; SORT: proc (len, lst, cmp); /* _l_s_t, of length _l_e_n, is the ordering of the data to be sorted. Using the comparison procedure _c_m_p, return _l_s_t ordered according to the comparisons. _c_m_p has two input parameters. These are two entries from the _l_s_t that point to the next two data elements to be sorted. If the data element pointed to by the first parameter is "next" then _c_m_p returns a zero, 0, else returns a one, 1. Author: Dave Ward 06/16/80 */ dcl cmp entry(fixed bin,fixed bin) returns(fixed bin) parameter; dcl len fixed bin parameter; dcl lst (*) fixed bin parameter; /* calculate the lengths of lists and their start pointers in a linear set. */ if len<2 then return; t = 0; l = len; do n = 1 by 1 while (l>1); s (n) = t; /* start of the next list. */ if mod (l, 2) = 1 then l = l+1; /* make the length even. */ t = t+l; /* accumulate the lengths. */ l = l/2; /* next list is 1/2 the length of the present list. */ end; n = n-1; begin; /* Local block. */ /* pointers to input list. */ do i = 1 to len; m (i) = i; end; /* fill in all lists. */ do i = 2 to n; lft = s (i-1); rit = s (i) ; do j = 1 by 2 to (rit - lft); x = lft+j; v1 = m (x); v2 = m (x+1); if v2>0 then if cmp (lst (v1), lst (v2)) = 1 then v1 = v2; rit = rit+1; m (rit) = v1; end; end; /* calculate the list of pointers in o */ y = s (n)+1; do i = 1 to len; v1 = m (y); v2 = m (y+1); if (v1 = 0) & (v2 = 0) then i = len; /* End "i" loop. */ else do; if v1 = 0 then v1 = v2; else if v2>0 then if cmp (lst (v1), lst (v2)) = 1 then v1 = v2; o (i) = lst (v1); /* next output value. */ m (v1) = 0; /* delete the last winner. */ do j = 2 to n; /* get the next winner. */ lft = s (j-1); if mod (v1, 2) = 1 then v2 = v1+1; else v2 = v1-1; x = (v1+1)/2; v1 = m (v1+lft); v2 = m (v2+lft); if v1 = 0 then v1 = v2; else if v2>0 then if cmp (lst (v1), lst (v2)) = 1 then v1 = v2; m (x+s (j)) = v1; v1 = x; end; end; end; i = i-1; len = i; /* output the length of the output list. */ do i = 1 to i; /* copy over the output list. */ lst (i) = o (i); end; /* Declarations for local block. */ dcl m (t) fixed bin init((t)0); dcl o (len) fixed bin; end; /* Local block. */ /* Global declarations. */ dcl i fixed bin; dcl j fixed bin; dcl l fixed bin; dcl lft fixed bin; dcl mod builtin; dcl n fixed bin; dcl rit fixed bin; dcl s (36)fixed bin /* Indices to "bottoms" of lists. */; dcl t fixed bin; dcl v1 fixed bin; dcl v2 fixed bin; dcl x fixed bin; dcl y fixed bin; end SORT; %page; /* Variables for gfms_print_names_: */ /* IDENTIFIER ATTRIBUTES */ dcl clock_ entry() returns(fixed bin(71)); dcl date_time_ entry (fixed bin(71), char(*)); dcl dt char(24); dcl i fixed bin; dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl j fixed bin; dcl l fixed bin; dcl last_name char(12); dcl print_name char(12); dcl sa (n)fixed bin; %page; %include gfms_file_name_list; %page; %include gfms_ext; %page; %include gfms_description_tree; %page; %include gfms_version; end gfms_print_names_; gfms_serial_number_record_.pl1 12/11/84 1355.9rew 12/10/84 1041.9 30078 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_serial_number_record_: proc (); /* Display tape serial number record information. Author: Dave Ward 10/01/80 */ call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (tsnr) /* (input) record buffer. */ , size (tsnr)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms_serial_number_record_" , "Attempting to read tape serial number record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (tsnr)*4 , nbr , attach_description ); fail: ; signal cond (gfms_fail); end; call ioa ("^|TAPE SERIAL NUMBER RECORD INFORMATION (block 1):"); if word0.b00_17 = 1 /* Must be block 1 of record. */ & word0.b18_35 = 65 & word1.b00_17 = 64 & word1.b18_35 = "000017"b3 then do; /* Expected constants. */ call ioa ("serial number of copy this volume ^a", gfms_ascii_ ((word2))); call ioa ("serial number of latest journal tape ^a", gfms_ascii_ ((word2))); end; else do; /* Constant(s) improper. */ call com_err_ ( 0 , "gfms_serial_number_record_" , "serial number record constants not as expected." ); call gfms_dump_rec_ ( addr (tsnr) , divide (nbr+3, 4, 17) ); goto fail; end; return; %page; /* Variables for gfms_serial_number_record_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_dump_rec_ entry (ptr, fixed bin); dcl gfms_fail condition ext; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl hbound builtin; dcl i fixed bin; dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl j fixed bin; dcl nbr fixed bin(21); dcl size builtin; dcl word (0:size(tsnr)-1)bit(36)aligned based(addr(tsnr)); /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-24 TAPE SERIAL NUMBER RECORD (66 words) */ dcl 1 tsnr aligned , 3 word0 /* File and Record Control BCW. */ , 4 b00_17 fixed bin(18)unsigned unal , 4 b18_35 fixed bin(18)unsigned unal , 3 word1 /* File and Record Control RCW. */ , 4 b00_17 fixed bin(18)unsigned unal , 4 b18_35 bit(18)unal , 3 word2 bit(36) /* tape serial number of copy of vol. */ , 3 word3 bit(36) /* tape serial number of latest journal tape. */ , 3 words4_65 (4:65)bit(36) /* Reserved for GCOS. */ ; %page; %include gfms_ext; end gfms_serial_number_record_; gfms_smc_records_.pl1 12/11/84 1355.9rew 12/10/84 1042.0 75564 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_smc_records_: proc (); /* Display SMC records information. Author: Dave Ward 10/02/80 Change: Dave Ward 10/20/80 verify EOF record. Change: Dave Ward 11/05/80 add type 6 cat info to tree. Change: Dave Ward 11/08/80 hash catalog. Change: Ron Barstad 11/24/82 fix bug preventing unload of master save --must ignore type "77"b3 records */ call ioa ("^|SMC RECORDS INFORMATION:"); tc = 0; /* Total count of catalog records. */ do i = 1 by 1 while (get_rec ()); call ioa ( "^6i. (block^6i) size^6i record-size^6i" , i , block_serial_number , block_size , record_size ); /* Display smc records. */ rl = nw-1; /* Remaining length (words) for catalog records. */ if mod (rl, size (gfms_catrec_6)) ^= 0 then do; call com_err_ ( 0 , "gfms_smc_records_" , "Not modulo (^i) number of words for catalog records (^i)" , size (gfms_catrec_6) , rl ); fail: ; signal cond (gfms_fail); end; /* Set pointer to initial catalog record. */ cat_ptr = addr (type6_records); do while (rl>0); tc = tc+1; /* Catalog record count. */ call ioa ("^8x[^6i] type 6 catalog.", tc); if gfms_catrec_6.type = "77"b3 then goto cont; if gfms_catrec_6.type ^= "06"b3 then do; call com_err_ ( 0 , "gfms_smc_records_" , "SMC NOT TYPE 6 RECORD" ); call gfms_dump_rec_ (cat_ptr, 64); goto fail; end; do j = 1 to hbound (smc_entry, 1); /* Process type 6 catalog smc entries. */ if (smc_name (j) = "0"b) | (smc_name (j) = (12)"20"b3) then goto cont; call cat_6_entry ( j , gfms_catrec_6.dupl_sector_no , addr (gfms_catrec_6.smc_entry (j)) ); end; cont: ; if j = 1 then call ioa ("^17xNO ENTRIES."); rl = rl - size (gfms_catrec_6); if rl > 0 then cat_ptr = addrel (cat_ptr, size (gfms_catrec_6)); end; end; return; %page; cat_6_entry: proc (j, ps, smcep); /* Provide tree description information from type 6 catalog smc entry. "j" is index to entry. "ps" is parent sector, "smcep" locates smc entry. */ dcl j fixed bin parm; dcl ps fixed bin(18)unsigned unal parm; dcl smcep ptr parm; n = rtrim (gfms_ascii_ ((smce.smc_name))); call ioa ( "^17x^1i. ^12a ^[^^on-device^; on-device^] cat-0-sector ^6i" ||"^/^20xparent ^6i cat-llinks ^6i allowed ^2.3b llinks-in-use ^6i max-llinks ^[unlimited^s^;^6i^]" /* line 1 values. */ , j , n , smce.umc_on_device , smce.umc_llink*5 /* sector of child (type 0 catalog). */ /* line 2 values. */ , ps /* sector or parent. */ , smce.catalog_llinks , string (smce.smc_perms) , smce.llinks_in_use , smce.llinks_allowed = 0 , smce.llinks_allowed ); call gfms_hash_cat_ ( smce.smc_name /* (input) name BCD. */ , n /* (input) name ASCII. */ , "1"b /* (input) entry is catalog. */ , ps /* (input) sector of parent. */ , smce.umc_llink*5 /* (input) sector of child. */ ); return; dcl n char(12)var; dcl 1 smce aligned based(smcep) like gfms_catrec_6.smc_entry; end cat_6_entry; %page; get_rec: proc returns (bit (1)); /* Obtain the next SMC record from tape. Return "0"b when record read is the EOF record (position past the EOF record). Return "1"b when SMC record read. */ call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (smc_space) /* (input) record buffer. */ , size (smc_space)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then if code = error_table_$end_of_info then if gfms_end_of_input_ ( addr (smc_space) /* (input) pointer to input buffer. */ , size (smc_space)*4 /* (input) length of buffer (bytes). */ , nbr /* (input/output) current number bytes in buffer. */ ) then do; /* No more tape input. */ call com_err_ ( 0 , "gfms_substructure_records_" , "End of tape input reached in SMC records." ); signal cond (gfms_fail); end; else goto cont; /* Next reel in process. */ else if code ^= error_table_$long_record then do; call com_err_ ( code , "gfms_smc_records_" , "Attempting to read smc record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (smc_space)*4 , nbr , attach_description ); fail: ; signal cond (gfms_fail); end; /* Assure length in words is conistent. */ cont: ; if mod (nbr, 4) ^= 0 then call com_err_ ( 0 , "gfms_smc_records_" , "Bytes read (^i) not word modulo, will truncate to word and continue." , nbr ); nwr = divide (nbr, 4, 17); /* Number of words read. */ nw = nwr-1; /* upper bound of smc structure. */ if nw < 2 then do; call com_err_ ( 0 , "gfms_smc_records_" , "Record ^i bytes long (<2 words)" , nbr ); goto fail; end; /* Determine if EOF record reached. */ if smc.eof_mark = "170017"b3 then do; p = addr (smc_space); if p -> k65 ^= 65 | p -> k64 ^= 64 | p -> EOF_number ^= 1 then call com_err_ ( 0 , "gfms_smc_records_" , "Faulty EOF record. Continuing." ||"^/1st 4 words:^4( ^12.3b^)" , unspec (p -> EOF_record.word0) , unspec (p -> EOF_record.word1) , unspec (p -> EOF_record.word2) , unspec (p -> EOF_record.word3) ); call ioa ( "^6i. (block^6i) EOF record." , i , p -> EOF_record.bsn ); return ("0"b); end; return ("1"b); dcl p ptr; %include gfms_EOF_record; end get_rec; %page; /* Variables for gfms_smc_records_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl cat_ptr ptr init(null()); dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl divide builtin; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$long_record fixed bin(35) ext static; dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_dump_rec_ entry (ptr,fixed bin); dcl gfms_end_of_input_ entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1)); dcl gfms_fail condition ext; dcl gfms_hash_cat_ entry (bit(72) aligned, char(12) var, bit(1), uns fixed bin(18) unal, uns fixed bin(18)); dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl hbound builtin; dcl i fixed bin; dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl j fixed bin; dcl mod builtin; dcl nbr fixed bin(21); dcl null builtin; dcl nw fixed bin; dcl nwr fixed bin; dcl rl fixed bin; dcl rtrim builtin; dcl size builtin; dcl smc_space (3842)bit(36)aligned; dcl string builtin; dcl tc fixed bin; dcl unspec builtin; dcl w (0:63)bit(36)aligned based(cat_ptr); %page; /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-25 SMC RECORDS (<=3842 words) */ dcl 1 smc aligned based(addr(smc_space)) , 3 word0 , 4 block_serial_number fixed bin(18)unsigned unal , 4 block_size fixed bin(18)unsigned unal , 3 word1 , 4 record_size fixed bin(18)unsigned unal , 4 eof_mark bit(18)unal , 3 words2_3841 , 4 type6_records (2:nw)bit(36) ; %page; %include gfms_catrec_6; %page; %include gfms_ext; end gfms_smc_records_; gfms_substructure_records_.pl1 09/20/89 1352.4rew 09/20/89 1351.1 204039 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-05-11,RBarstad), approve(89-09-19,MCR8117), audit(89-06-26,Parisek), install(89-09-20,MR12.3-1069): Allowed for catalog descriptors (type 1) to be out of sequence. This is possible from a fragmented file system. END HISTORY COMMENTS */ gfms_substructure_records_: proc (); /* Display SUBSTRUCTURE records information. Author: Dave Ward 10/28/80 Change: Dave Ward 11/07/80 print parent sector of type 0 cat. Change: Dave Ward 11/11/80 carry parent sector from 0 to 1 cat records. Change: Dave Ward 01/28/81 allow unfound parent sector. Change: Ron Barstad 12/23/82 Fixed several bugs: 1. skipping catalog entries after first null entry 2. treating empty(type 63) catalog records as error- this prevented processing of dontdo and doonlys and single cat or file saves */ call ioa ("^|SUBSTRUCTURE RECORDS INFORMATION:"); bc /* Count of blocks. */ , e /* Count of total empty catalog records. */ , tc /* Total count of catalog records. */ , rl /* => require a new input record (see scan). */ = 0; unspec (parent_list) = "0"b; call scan; if scan_ss then do; call gfms_dump_description_tree_; signal cond (gfms_fail); end; return; %page; cat_0_1_entry: proc (ps, cel, ep); /* Store the catalog entries (files or subcatalogs) in the description tree. Link entries back to the parent catalog (at tree cat entry "fcl"). */ dcl cel fixed bin parm; dcl ep ptr parm; dcl ps fixed bin(18)unsigned unal parm; if ps = 0 then return; /* there is no parent */ cep = ep; /* Pointer to initial name entry in catalog. */ do i = 1 to cel; if (ce.name = "0"b) | (ce.name = (12)"20"b3) then goto cont; /* skip on null or blank entry name. */ n = rtrim (gfms_ascii_ ((ce.name))); /* n => name of this entry. */ ic = ce.entry_is_catalog; /* Entry is a subcatalog. */ cs = ce.description_sector_org; /* Sector where my child is found. */ call ioa ( "^12x^2i. ^12a ^[^^on-device^; on-device^] ^[catalog^; file^] ^6i" , i , n , ce.not_on_this_device , ic , cs ); call gfms_hash_cat_ ( ce.name /* entry name BCD. */ , n /* entry name ASCII. */ , ic /* "1"b=> catalog, "0"b=> file. */ , ps /* sector number of parent. */ , cs /* sector number of child. */ ); cont: ; if i < cel then /* Position to the next name entry. */ cep = addrel (cep, size (ce)); end; return; dcl cs fixed bin(18)unsigned; dcl gfms_hash_cat_ entry (bit(72) aligned, char(12) var, bit(1), uns fixed bin(18) unal, uns fixed bin(18)); dcl i fixed bin; dcl ic bit(1); dcl n char(12)var; end cat_0_1_entry; %page; cat_2_entry: proc; /* Record descriptor information and link it to its catalog structure (in the description tree). Optionally display this (type 2 catalog) information. */ call ioa ("^8x^3i type 2 file description record.", tc); /* Obtain next desc entry. */ n_desc = n_desc+1; if n_desc > hbound (description, 1) then do; call com_err_ ( 0 , "gfms_substructure_records_" , "Exhausted ^i entries of desc table." , hbound (description, 1) ); signal cond (gfms_fail); end; description (n_desc).name = gfms_catrec_2.filename; s, description (n_desc).sector = gfms_catrec_2.dupl_sector_no; /* Hash the sector number in the desc list. */ k = mod (s, hbound (start_list.desc, 1)+1); i = start_list.desc (k); do while (i>0); /* Assure sector number unique. */ if description (i).sector = s then do; call com_err_ ( 0 , "gfms_substructure_records_" , "BUG, duplicate entries in desc list (^i sector no.)" ||"^/file ^12a smc ^12a" , s , gfms_ascii_ ((gfms_catrec_2.filename)) , gfms_ascii_ ((gfms_catrec_2.SMC_name)) ); return; end; i = description (i).link; end; /* s is a new sector number entry. */ description (n_desc).link = start_list.desc (k); /* Link to previous chain. */ start_list.desc (k) = n_desc; /* Link new sector number to start of chain. */ call ioa ( "^12x" ||"file ^12a " ||"smc ^12a " ||"created by ^12a " ||"on ^a" , gfms_ascii_ ((gfms_catrec_2.filename)) , gfms_ascii_ ((gfms_catrec_2.SMC_name)) , gfms_ascii_ ((gfms_catrec_2.creator_name)) , gfms_date_ (gfms_catrec_2.create_date) ); /* Sector number of descriptor. */ call ioa_nnl ("^12xdesc-sect^6i", s); /* Maximum file size. */ if max_size_in_llinks then description (n_desc).max_size_llinks = maximum_file_size; else description (n_desc).max_size_llinks = maximum_file_size * 12; /* 12 llinks = link. */ if maximum_file_size = 0 then call ioa_nnl ("^1xmax-file-size UNLIMITED"); else call ioa_nnl ( "^1xmax-file-size ^i " ||"^[ llinks^; links^]" ||"^[ orig-file-written^; orig-file-not-written^]" , maximum_file_size , max_size_in_llinks , file_written_to ); /* User specified information. */ description (n_desc).user_info.present = user_specified_info_present; if user_specified_info_present then do; description (n_desc).user_info.value = user_info_bits; call ioa_nnl (" ^12.3b", "0"b||user_info_bits); end; else description (n_desc).user_info.value = "0"b; /* Mode (type) of file. */ modep = addr (description (n_desc).mode); mode = "0"b; if random_file then do; mode = mode | "0100"b; call ioa (" RANDOM"); end; if ASCII_file then do; mode = mode|"0010"b; call ioa (" ASCII"); end; if I_D_S_file then do; mode = mode|"0001"b; call ioa (" IDS"); end; if ^random_file & ^ASCII_file & ^I_D_S_file then do; mode = mode | "1000"b; call ioa (" SEQUENTIAL"); end; if file_on_nonstructured_vol = "1"b then call ioa ("nonstructured volume (NOT CURRENTLY PROVIDED FOR)"); else do; /* Structured volume. */ do i = 1 to hbound (gfms_catrec_2.structured_info, 1); cep = addr (gfms_catrec_2.structured_info (i)); if cep -> b36 = "0"b then return; if substr (cep -> b36, 1, 4) ^= "0101"b then /* not a device description. */ call ioa ( "^12xnumber llinks ^i starting llink ^i ^[ DEFECTIVE^;^s^]" , number_llinks , starting_llink , defective ); end; end; return; dcl i fixed bin; dcl k fixed bin; dcl mode bit(4)unal based(modep); dcl modep ptr; dcl s fixed bin(18)unsigned; end cat_2_entry; %page; find_parent_sector: proc (pr, sn)returns (fixed bin (18)unsigned); /* Look up prior sector number "pr" in the hash list recording parent sector number. Store sector number "sn" in hash list along with the recorded parent sector found. Return parent sector found. If no parent sector found then return zero. This catalog record is ignored. */ dcl pr fixed bin(18)unsigned unal parm; dcl sn fixed bin(18)unsigned unal parm; k = mod (pr, hbound (parent_list, 1)+1); do j = k to hbound (parent_list, 1), 0 to (k-1); if parent_list (j).cat_sector = pr then do; /* found. */ parent_list (j).cat_sector = 0; /* Make entry available. */ ps = parent_list (j).parent_sector; call save_parent_sector (sn, (ps)); return (ps); end; end; return (0); /* not found */ dcl j fixed bin(18)unsigned; dcl k fixed bin(18)unsigned; dcl ps fixed bin(18)unsigned; end find_parent_sector; %page; first_rec: proc (cp); /* Display first record(s) information. Set "cp" to locate catalog records. */ dcl cp ptr parm; bc = bc+1; /* Block count. */ call ioa ( "^6i. (block^6i) size^6i record-size^6i" , bc , sub.block_serial_number , sub.block_size , sub.record_size ); /* Display substructure records. */ rl = nw-1; /* Remaining length (words) for catalog records. */ if mod (rl, size (gfms_catrec_0)) ^= 0 then do; call com_err_ ( 0 , "gfms_substructure_records_" , "Not modulo (^i) number of words for catalog records (^i)" , size (gfms_catrec_0) , rl ); fail: ; signal cond (gfms_fail); end; /* Set pointer to initial catalog record. */ cp = addr (sub.catalog_records); return; end first_rec; %page; force_parent_sector: proc (pr, sn, cel, ep)returns (fixed bin (18)unsigned); /* IF the entry in the type 1 catalog list is not null THEN put prior sector number "pr" in the hash list as the parent sector. Store sector number "sn" in hash list along with the recorded parent. Return sn as parent sector. This "step" parent will be replaced with the "true" parent when the subsequent type 0 or type 1 catalog pointed to by pr comes along. (If it doesn't, then the files and catalogs in this and linked type 1's are dumped at the top level and not where they belong.) ELSE return zero. This catalog record is ignored. */ dcl pr fixed bin(18)unsigned unal parm; /* prior sector */ dcl sn fixed bin(18)unsigned unal parm; /* this sector */ dcl cel fixed bin parm; /* count of entries */ dcl ep ptr parm; /* first entry pointer */ cep = ep; /* Pointer to initial name entry in catalog. */ do i = 1 to cel; if (ce.name ^= "0"b) then if (ce.name ^= (12)"20"b3) then goto force; if i < cel then /* Position to the next name entry. */ cep = addrel (cep, size (ce)); end; return(0); /* all null */ force: call save_parent_sector (pr, pr); ps = find_parent_sector (pr, sn); call ioa ("^11x *** Parent not found yet. Prior ^6i, Sector ^6i, StepParent ^6i.", pr, sn, ps); return (ps); /************/ dcl ps fixed bin(18)unsigned; dcl i fixed bin; end force_parent_sector; %page; get_rec: proc returns (bit (1)); /* Obtain the next SUBSTRUCTURE record from tape. Return "1"b when record read is the EOF record (position past the EOF record). Return "0"b when SUBSTRUCTURE record read. */ call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (sub_space) /* (input) record buffer. */ , size (sub_space)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then if code = error_table_$end_of_info then if gfms_end_of_input_ ( addr (sub_space) /* (input) pointer to input buffer. */ , size (sub_space)*4 /* (input) length of buffer (bytes). */ , nbr /* (input/output) current number bytes in buffer. */ ) then do; /* No more tape input. */ call com_err_ ( 0 , "gfms_substructure_records_" , "End of tape input reached in substructure records." ); signal cond (gfms_fail); end; else goto cont; /* Next reel in process. */ else if code ^= error_table_$long_record then do; call com_err_ ( code , "gfms_substructure_records_" , "Attempting to read substructure record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (sub_space)*4 , nbr , attach_description ); fail: ; signal cond (gfms_fail); end; /* Assure length in words is conistent. */ cont: ; if mod (nbr, 4) ^= 0 then call com_err_ ( 0 , "gfms_substructure_records_" , "Bytes read (^i) not word modulo, will truncate to word and continue." , nbr ); nwr = divide (nbr, 4, 17); /* Number of words read. */ nw = nwr-1; /* upper bound of sub structure. */ if nw < 2 then do; call com_err_ ( 0 , "gfms_substructure_records_" , "Record ^i bytes long (<2 words)" , nbr ); goto fail; end; /* Determine if EOF record reached. */ if sub.eof_mark = "170017"b3 then do; p = addr (sub_space); if p -> k65 ^= 65 | p -> k64 ^= 64 | p -> EOF_number ^= 1 then call com_err_ ( 0 , "gfms_sub_records_" , "Faulty EOF record. Continuing." ||"^/1st 4 words:^4( ^12.3b^)" , unspec (p -> EOF_record.word0) , unspec (p -> EOF_record.word1) , unspec (p -> EOF_record.word2) , unspec (p -> EOF_record.word3) ); call ioa ( "^6i. (block^6i) EOF record." , i , p -> EOF_record.bsn ); return ("1"b); /* EOF record input, no more substructure. */ end; return ("0"b); /* Next substructure record. */ dcl p ptr; %include gfms_EOF_record; end get_rec; %page; reunite_orphan: proc (step_parent, true_parent); /* replace the step_parent sector with the true parent sector in the parent_list and gfms_hash table. Needed to restore the actual cat/file structure. See force_parent_sector. */ dcl step_parent fixed bin (18) unsigned unal parm; dcl true_parent fixed bin (18) unsigned unal parm; dcl i fixed bin; if step_parent = true_parent then return; do i = 0 to hbound(parent_list,1); if parent_list(i).parent_sector = step_parent then parent_list(i).parent_sector = true_parent; end; do i = 1 to n_cat; if cat(i).parent_sector = step_parent then cat(i).parent_sector = true_parent; end; call ioa ("^11x *** Replaced StepParent ^6i with Parent ^6i.", step_parent, true_parent); return; end reunite_orphan; %page; save_parent_sector: proc (cs, ps); /* Save parent sector number "ps" in a hash list to provide for type 1 catalog records obtaining parent sector of corresponding type 0 catalog record. */ dcl cs fixed bin(18)unsigned unal parm; dcl ps fixed bin(18)unsigned unal parm; k = mod (cs, hbound (parent_list, 1)+1); do j = k to hbound (parent_list, 1), 0 to (k-1); if parent_list (j).cat_sector = 0 then do; /* Available. */ parent_list (j).cat_sector = cs; if (parent_list (j).parent_sector ^= ps) then if (parent_list (j).parent_sector ^= 0) then call reunite_orphan(cs, ps); else parent_list (j).parent_sector = ps; return; end; end; /* No entryies available. */ call com_err_ ( 0 , "gfms_substructure_records_" , "Exhaused ^i entries available for parent sector list." ||" GCOS file structure is too large or too fragmented." , hbound (parent_list, 1) ); signal cond (gfms_fail); dcl j fixed bin(18)unsigned; dcl k fixed bin(18)unsigned; return; end save_parent_sector; %page; scan: proc; /* Scan the input tape substructure records. For type 0 and 1 catalog records, store entry information in cat array. For type 2 catalog records, store description information. */ more: ; if rl < 1 then do; /* Obtain next input record. */ if get_rec () then return; call first_rec (cat_ptr); /* Display header, position to 1st catalog record. */ end; else /* Record already available. */ cat_ptr = addrel (cat_ptr, size (cat_common)); /* Position to the next catalog record (within input record). */ tc = tc+1; /* Catalog record count. */ t = cat_common.type; /* Type of catalog record. */ goto cat (CTYPE (t)); cat (-1): ; call com_err_ ( 0 , "gfms_substructure_records_" , "Catalog type ^i not expected on save tape." , t ); call gfms_dump_rec_ (cat_ptr, 64); goto cont; cat (0): ; /* Catalog description */ call ioa ( "^8x^3i Type 0 catalog record (Prior ^6i, Parent-sector ^6i, Next ^6i)." ||"^/^12x^12a create by ^12a on ^a modified ^a." , tc , gfms_catrec_0.prior_cat_sector_org , gfms_catrec_0.dupl_sector_no , gfms_catrec_0.cat_contin_sector_org , gfms_ascii_ ((gfms_catrec_0.catname)) , gfms_ascii_ ((gfms_catrec_0.creator_name)) , gfms_date_ (gfms_catrec_0.create_date) , gfms_date_ (gfms_catrec_0.modified_date) ); call save_parent_sector (gfms_catrec_0.dupl_sector_no, gfms_catrec_0.dupl_sector_no); call cat_0_1_entry ( gfms_catrec_0.dupl_sector_no , hbound (gfms_catrec_0.entry, 1) , addr (gfms_catrec_0.entry) ); goto cont; cat (1): ; /* Catalog description (type 0) continuation */ call ioa ("^8x^3i Type 1 catalog record. Prior ^6i, Sector ^6i, Next ^6i, empty ^3i." , tc , gfms_catrec_1.prior_cat_sector_org , gfms_catrec_1.dupl_sector_no , gfms_catrec_1.cat_contin_sector_org , e ); p_sec = find_parent_sector (gfms_catrec_1.prior_cat_sector_org, gfms_catrec_1.dupl_sector_no); if p_sec = 0 then p_sec = force_parent_sector (gfms_catrec_1.prior_cat_sector_org , gfms_catrec_1.dupl_sector_no , hbound (gfms_catrec_1.entry, 1) , addr (gfms_catrec_1.entry) ); call cat_0_1_entry (p_sec , hbound (gfms_catrec_1.entry, 1) , addr (gfms_catrec_1.entry) ); goto cont; cat (2): ; /* File Description */ call ioa ("^8x^3i Type 2 catalog record.", tc); call cat_2_entry; goto cont; cat (3): ; /* type 2 continuation ? */ cat (4): ; /* Specific permissions */ cat (5): ; /* type 4 continuation */ cat (7): ; /* attributes */ cat (9): ; /* timed passwords */ cat (62): ; call ioa ( "^8x^3i Type ^2i catalog (^3i) not currently provided for." ,tc , t , CTYPE (t) ); goto cont; cat (63): ; /* Empty catalog record. */ e = e+1; /* Count empties. */ call ioa ("^8x^3i Empty (type 63) catalog record. Prior ^6i, sector ^6i, empty ^3i." , tc , gfms_catrec_1.prior_cat_sector_org , gfms_catrec_1.dupl_sector_no , e ); goto cont_1; cont: ; e = 0; /* all catalog types but empty initialize empty count */ cont_1: ; rl = rl - size (cat_common); goto more; /*************/ dcl p_sec fixed bin(18) unsigned unal; dcl t fixed bin; dcl 1 cat_common aligned based(cat_ptr) , 3 word0 , 4 type fixed bin(06)unsigned unal , 4 fill1 bit(30)unal , 3 words1_63 (1:63)bit(36) ; dcl CTYPE (0:63)fixed bin static int options(constant)init( /* 00 */ 0 ,/* 01 */ 1 ,/* 02 */ 2 ,/* 03 */ 3 ,/* 04 */ 4 ,/* 05 */ 5 ,/* 06 */ -1 /* Not allowed. */ ,/* 07 */ 7 ,/* 08 */ -1 /* Not allowed. */ ,/* 09 */ 9 ,/* 10-61 */ (52)-1 ,/* 62 (76octal) */ 62 ,/* 63 (77octal) */ 63 ); end scan; %page; /* Variables for gfms_substructure_records_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl b36 bit(36)aligned based; dcl bc fixed bin; dcl cat_ptr ptr init(null()); dcl cep ptr; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl divide builtin; dcl e fixed bin; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$long_record fixed bin(35) ext static; dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_date_ entry (bit(36) aligned) returns(char(8)); dcl gfms_dump_description_tree_ entry; dcl gfms_dump_rec_ entry (ptr,fixed bin); dcl gfms_end_of_input_ entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1)); dcl gfms_fail condition ext; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl hbound builtin; dcl i fixed bin; dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl mod builtin; dcl nbr fixed bin(21); dcl null builtin; dcl nw fixed bin; dcl nwr fixed bin; dcl rl fixed bin; dcl rtrim builtin; dcl size builtin; dcl substr builtin; dcl sub_space (3842)bit(36)aligned; dcl tc fixed bin; dcl unspec builtin; dcl 1 ce aligned like gfms_catrec_0.entry based(cep); dcl 1 parent_list (0:1020)aligned , 3 cat_sector fixed bin(18)unsigned unal , 3 parent_sector fixed bin(18)unsigned unal ; %page; /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-26 SUBSTRUCTURE RECORDS (<=3842 words) */ dcl 1 sub aligned based(addr(sub_space)) , 3 word0 , 4 block_serial_number fixed bin(18)unsigned unal , 4 block_size fixed bin(18)unsigned unal , 3 word1 , 4 record_size fixed bin(18)unsigned unal , 4 eof_mark bit(18)unal , 3 words2_3841 , 4 catalog_records (2:nw)bit(36) ; /* From DC26 ??? page 4-12 description of array of FD2VAR fields in type 2 catalog record. */ dcl 1 FS2VAR aligned based(cep) , 3 b0_1 bit(2)unal , 3 defective bit(1)unal , 3 number_llinks fixed bin(15)unsigned unal , 3 starting_llink fixed bin(18)unsigned unal ; %page; %include gfms_description_tree; %page; %include gfms_catrec_0; %page; %include gfms_catrec_1; %page; %include gfms_catrec_2; %page; %include gfms_ext; end gfms_substructure_records_; gfms_tape_status_.pl1 12/11/84 1355.9rew 12/10/84 1042.0 10179 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_tape_status_: proc (p)returns (bit (12)); /* Return tape_nstd_ request_status. Author: Dave Ward 10/28/80 */ dcl p ptr parm; call iox_$control ( p /* (input) pointer to switch's control block. */ , "request_status" /* (input) control order. */ , addr (s12) /* (input) pointer to 12 bit status. */ , code /* (output) status code. */ ); if code ^= 0 then call com_err_ ( code , "gfms_tape_status_" , "pointer to switch iocb (^p)" , p ); return (s12); dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl s12 bit(12)aligned; end gfms_tape_status_; gfms_task_block_record_.pl1 12/11/84 1355.9rew 12/10/84 1042.0 90117 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_task_block_record_: proc (ms); /* Display task block record information. "ms" is set to "1"b if tape is a master save, or "0"b if a user save (any other type of save is reported and processing discontinued). Author: Dave Ward 10/01/80 Change: Dave Ward 10/03/80 compensated for words5_6 not 0 as advertised. */ dcl ms bit(1)parm; call iox_$read_record ( cbp /* (input) pointer to control block. */ , addr (tbr_space) /* (input) record buffer. */ , size (tbr_space)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then if code ^= error_table_$long_record then do; call com_err_ ( code , "gfms_task_block_record_" , "Attempting to read task block record." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (tbr_space)*4 , nbr , attach_description ); fail: ; signal cond (gfms_fail); end; /* Assure length in words is conistent. */ if mod (nbr, 4) ^= 0 then call com_err_ ( 0 , "gfms_task_block_record_" , "Bytes read (^i) not word modulo, will truncate to word and continue." , nbr ); nwr = divide (nbr, 4, 17); /* Number of words read. */ nw = nwr-1; /* upper bound of tbr structure. */ call ioa ("^|TASK BLOCK RECORD INFORMATION (block 2):"); if word0.b00_17 = 2 /* Must be block 2 of record. */ & word1.b18_35 = "0"b & word2.savhdr = "622165302451"b3 then do; /* bcd SAVHDR */ call ioa ("block_size^4(.^) ^i", block_size); call ioa ("record_size^3(.^) ^i", record_size); call ioa ("date^10(.^) ^a", gfms_date_ (date)); call ioa ("clock_pulses^2(.^) ^i", clock_pulses); rw = nwr - 7; /* Words remaining for copy of task block. */ sqll = rw - 12 - 1; /* Words remaining for qualifier list. */ /* Verify "some" FACT fields. */ if task_header = 1 & word0.b18_35 = "0"b & type_code = 10 & serial_num = (10)"1"b3 & subtask_header = 2 & word3.b18_35 = "0"b & report_code = 33 & file_code = "4754"b3 /* bcd "P*" */ & last_word.b00_17 = (6)"7"b3 & last_word.b18_35 = "0"b then do; /* FACT constants as expected. */ call ioa (" FACT overlay info:"); if subtask_code = 1 then do; ms = "1"b; /* Master save. */ call ioa (" MASTER SAVE"); end; else if subtask_code = 2 then do; ms = "0"b; /* User save. */ call ioa (" USER SAVE"); end; else do; call ioa (" Subtask code ^i.^/ TYPE NOT PROCESSED BY THIS COMMAND, TERMINATING." , subtask_code ); goto fail; end; call ioa (" subtask options ^6.3b", string (subtask_options)); call ioa (" user ^a", gfms_ascii_ ((user_name))); call ioa (" qualifier list:"); i = 1; do while (i <= sqll); if subtask_qualifier_list (i).b00_17 = 3 then do; /* => subtask qualifier. */ j = subtask_qualifier_list (i).b18_35; /* Qualifier code. */ if (j<1) | (j>10) then do; call ioa (" QUALIFIER CODE (^i) OUT OF RANGE 1 to 10.", j); goto dump_fact; end; call ioa_nnl ("^2x[^4i]^1x", i); i = i+1; goto stq (j); stq (01): ; call ioa ("(01) User Save."); do while (i <= sqll); if subtask_word (i) = (12)"7"b3 then do; i = i+1; goto cont; end; call ioa ( "^14x^6.3b ^6.3b" , substr (subtask_word (i), 01, 18) , substr (subtask_word (i), 19, 18) ); i = i+1; end; off_end: ; call ioa ("EXCEEDED END OF SUBTASK LIST (^i entries)", sqll); goto dump_fact; stq (02): ; call ioa ("(02) Master Save DON'T DO or DO ONLY names"); display_names: ; do while (i <= sqll); if subtask_word (i) = (12)"7"b3 then do; i = i+1; goto cont; end; call ioa ("^14x^a", gfms_ascii_ (Name)); i = i+2; end; goto off_end; stq (03): ; call ioa ("(03) Device Names"); do while (i <= sqll); if subtask_word (i) = (12)"7"b3 then do; i = i+1; goto cont; end; call ioa ("^14x^a", gfms_ascii_ (substr (subtask_word (i), 1, 18))); i = i+1; end; goto off_end; stq (04): ; call ioa ("(^2i) -NO DISPLAY-"); display_word: ; do while (i <= sqll); if subtask_word (i) = (12)"7"b3 then do; i = i+1; goto cont; end; call ioa ("^14x^12.3b", subtask_word (i)); i = i+1; end; goto cont; stq (05): ; call ioa ("(05) New Names"); goto display_names; stq (06): ; call ioa ("(06) Pack Identification"); goto display_word; stq (07): ; call ioa ("(07) ALL"); call ioa ( "(07) Date ^6a Time ^6a" , gfms_date_ (Date (i)) , gfms_ascii_ (Time (i)) ); i = i+1; goto cont; stq (08): ; call ioa ("(08) ILLEGAL Qualifier Code."); goto dump_fact; stq (09): ; call ioa ("(09) SMC Sections ^32b", subtask_word (i)); i = i+1; goto cont; stq (10): ; call ioa ( "(10) Journal Search ^6a ^6a" , gfms_date_ (Date (i)) , gfms_ascii_ (Time (i)) ); i = i+2; goto cont; cont: ; end; end; end; else do; /* FACT constants not as expected. */ call ioa ("FACT constants not as expected (octal dump):"); dump_fact: ; do i = 0 to hbound (fact_word, 1) by 4; call ioa_nnl ("^3i. ", i); do j = i to (i+3); call ioa_nnl (" ^12.3b", fact_word (j)); end; call ioa_nnl ("^/"); end; goto fail; end; end; else do; /* Constant(s) improper. */ call ioa ("constants not as expected (octal dump):"); do i = 0 to hbound (word, 1) by 4; call ioa_nnl ("^3i. ", i); do j = i to (i+3); call ioa_nnl (" ^12.3b", word (j)); end; call ioa_nnl ("^/"); end; goto fail; end; return; %page; /* Variables for gfms_task_block_record_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl error_table_$long_record fixed bin(35) ext static; dcl fact_word (0:size(FACT_Overlay_Interface)-1)bit(36)aligned based(addr(FACT_Overlay_Interface)); dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_date_ entry (bit(36) aligned) returns(char(8)); dcl gfms_fail condition ext; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl i fixed bin; dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl j fixed bin; dcl l fixed bin; dcl Name bit(72)based(addr(subtask_qualifier_list(i))); dcl nbr fixed bin(21); dcl nw fixed bin; dcl nwr fixed bin; dcl rw fixed bin; dcl size builtin; dcl sqll fixed bin; dcl subtask_word (sqll)bit(36)based(addr(subtask_qualifier_list)); dcl tbr_space (1117)bit(36)aligned; dcl word (0:nw)bit(36)aligned based(addr(tbr)); %page; /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-25 TASK BLOCK RECORD (<=1117 words) */ dcl 1 tbr aligned based(addr(tbr_space)) , 3 word0 , 4 b00_17 fixed bin(18)unsigned unal , 4 block_size fixed bin(18)unsigned unal , 3 word1 , 4 record_size fixed bin(18)unsigned unal , 4 b18_35 bit(18)unal , 3 word2 , 4 savhdr bit(36) /* bcd constant "SAVHDR" */ , 3 word3 , 4 date bit(36) /* bcd MMDDYY */ , 3 word4 , 4 clock_pulses fixed bin(36)unsigned unal , 3 words5_6 bit(72) /* should be zero. */ , 3 words7_nw (7:nw)bit(36) /* Copy of task block. */ ; %page; /* See DD14, Rev 1 (June 1976) SYSTEM TABLES Page 16-30 FACT Overlay Interface */ dcl 1 FACT_Overlay_Interface aligned based(addr(tbr.words7_nw)) , 3 word0 , 4 task_header fixed bin(18)unsigned unal , 4 b18_35 bit(18)unal , 3 word1 , 4 restore bit(01)unal , 4 b01_17 bit(17)unal /* Reserved for GCOS. */ , 4 task_ordinal fixed bin(18)unsigned unal , 3 word2 , 4 type_code fixed bin(06)unsigned unal /* 10 decimal. */ , 4 serial_num bit(30)unal /* octal 1's. */ , 3 word3 , 4 subtask_header fixed bin(18)unsigned unal /* 2. */ , 4 b18_35 bit(18)unal , 3 word4 , 4 subtask_code fixed bin(18)unsigned unal , 4 subtask_options (18:35)bit(1)unal , 3 word5 bit(36) /* Reserved. */ , 3 words6_7 , 4 user_name bit(72) , 3 words8_9 bit(72) /* Reserved. */ , 3 word10 , 4 address_of_return_pair bit(18)unal , 4 b18_35 bit(18)unal /* Reserved. */ , 3 word11 , 4 report_code fixed bin(18)unsigned unal /* decimal 33. */ , 4 b18_23 bit(06)unal /* Reserved. */ , 4 file_code bit(12)unal /* P*. */ , 3 word12 , 4 subtask_qualifier_list (sqll) , 5 b00_17 fixed bin(18)unsigned unal , 5 b18_35 fixed bin(18)unsigned unal , 3 last_word , 4 b00_17 bit(18)unal , 4 b18_35 bit(18)unal ; dcl 1 stq_ovl (sqll)aligned based(addr(subtask_qualifier_list)) , 2 Date bit(36) , 2 Time bit(36)unal ; %page; %include gfms_ext; end gfms_task_block_record_; gfms_test_ascii_.pl1 12/11/84 1355.9rew 12/10/84 1042.0 4239 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ x: proc; call ioa_ ("^a", gfms_ascii_ ("212223"b3)); dcl ioa_ entry() options(variable); dcl gfms_ascii_ entry (bit(*)) returns(char(*)); end; gfms_test_date_.pl1 12/11/84 1355.9rew 12/10/84 1042.0 6552 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ test_gfms_date_: proc; call ioa_ ("^12.3b = ""^a""", (12)"7"b3, gfms_date_ ((12)"7"b3)); call ioa_ ("^12.3b = ""^a""", (12)"0"b3, gfms_date_ ((12)"0"b3)); call ioa_ ("^12.3b = ""^a""", (6)"11"b3, gfms_date_ ((6)"11"b3)); call ioa_ ("^12.3b = ""^a""", "010000041000"b3, gfms_date_ ("010000041000"b3)); dcl ioa_ entry() options(variable); dcl gfms_date_ entry (bit(36) aligned) returns(char(8)); end; gfms_trailer_label_.pl1 12/11/84 1355.9rew 12/10/84 1022.4 33453 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gfms_trailer_label_: proc ()returns (bit (1)); /* Process the tape trailer label. Return "1"b if this is end of file (EOF) label versus end of reel (EOR) label. Author: Dave Ward 10/17/80 Changed: Ron Barstad 84-11-21 Fixed processing of multiple tape saves. */ call iox_$read_record ( /* Read the trailer record. */ cbp /* (input) pointer to control block. */ , addr (tape_label) /* (input) record buffer. */ , size (tape_label)*4 /* (input) buffer length in bytes. */ , nbr /* (output) number of bytes read. */ , code /* (output) I/O system status. */ ); if code ^= 0 then do; call com_err_ ( code , "gfms_trailer_label_" , "Attempting to read tape trailer label file." ||"^/Tape status ^4.3b" ||"^/buffer length ^i (bytes)." ||"^/bytes read ^i." ||"^/attach description ""^a""" , gfms_tape_status_ (cbp) , size (tape_label)*4 , nbr , attach_description ); signal cond (gfms_fail); end; if end_label = "202546262020"b3 then /* " EOF " bcd. */ r = "1"b; /* EOF */ else if end_label = "202546512020"b3 then /* " EOR " bcd */ r = "0"b; /* EOR */ else do; /* Neither EOF or EOR. */ call com_err_ ( 0 , "gfms_trailer_label_" , "Trailer label, ""^6a"", not EOF or EOR." , gfms_ascii_ ((end_label)) ); call gfms_dump_rec_ ( addr (tape_label) , divide (nbr+3, 4, 17) ); signal cond (gfms_fail); end; call ioa ("^|TRAILER LABEL INFORMATION:"); call ioa ("end_label......... ^a", gfms_ascii_ ((end_label))); if r then reel_serial_num = "NOREEL"; else do; call ioa ("next_reel_serial.. ^a", gfms_ascii_ ((next_reel_serial))); reel_serial_num = gfms_ascii_ ((next_reel_serial)); substr (reel_serial_num, 1, 1) = " "; /* strip off the "#" */ sequence_pic = decimal (reel_sequence_num, 6) + 1; reel_sequence_num = sequence_pic; if (gfms_close_ ()) then signal cond (gfms_fail); call gfms_detach_ (); attach_description = before (attach_description, " ") || reel_serial_num || after (after (attach_description, " "), " "); end; return (r); %page; /* Variables for gfms_trailer_label_: */ /* IDENTIFIER ATTRIBUTES */ dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl divide builtin; dcl gfms_ascii_ entry(bit(*))returns(char(*)); dcl gfms_close_ entry() returns(bit(1)); dcl gfms_detach_ entry options(variable); dcl gfms_dump_rec_ entry (ptr, fixed bin); dcl gfms_fail condition ext; dcl gfms_tape_status_ entry (ptr) returns(bit(12)); dcl ioa_ entry() options(variable); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl nbr fixed bin(21); dcl r bit(1); dcl sequence_pic pic "zz9999"; dcl size builtin; /* See DD07 (April 1974) FILE AND RECORD CONTROL Page 11-3 trailer label format. */ dcl 1 tape_label aligned , 3 end_label bit(36) , 3 block_count bit(36) , 3 arbitrary (3:13)bit(36) , 3 next_reel_serial bit(36) ; %page; %include gfms_ext; end gfms_trailer_label_; use_big_tape_blocks_.pl1 12/11/84 1355.9rew 12/10/84 1042.1 22986 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ use_big_tape_blocks_: proc (code); /* Determine whether caller has access to Multics facilities (see dir, ent arrays) to provide for tape blocks larger than 11888 bytes (See "tape_nstd_" I/O module, AX49. The parameter "code" is returned in one of three categories: 1) zero implies the caller has access, 2) error_table_$big_ws_req the caller does not, 3) any other value implies there was failure in attempting to determine (a normal multics status code). Include file "use_big_tape_blocks.incl.pl1" provides declarations for dir, ent arrays. Author: Dave Ward 04/21/81 */ dcl code fixed bin(35)parm; code = 0; /* Assume caller has access. */ call user_info_ (per, prj, act); per_prj = rtrim (per)||"."||rtrim (prj)||".*"; do i = 1 to hbound (dir, 1); mode = 0; call hcs_$get_user_effmode ( dir (i), ent (i) /* (input) directory and entry name. */ , per_prj /* (input) PERSON.PROJECT.* */ , get_ring_ () , mode /* (output). */ , code /* (output) status. */ ); if code ^= 0 then return; /* Failure to determine. */ if read then if nex (i) then do; if exec then return; /* Success, has access. */ end; else do; if writ then return; /* Success, has access. */ end; end; code = error_table_$big_ws_req; return; /* Success, does not have access. */ %page; /* Variables for use_big_tape_blocks_: */ /* IDENTIFIER ATTRIBUTES */ dcl act char(32); dcl error_table_$big_ws_req fixed bin(35) ext static; dcl get_ring_ entry() returns(fixed bin(3)); dcl hcs_$get_user_effmode entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)); dcl i fixed bin; dcl mode fixed bin(5); dcl per char(22); dcl per_prj char(32); dcl prj char(9); dcl user_info_ entry (char(*), char(*), char(*)); dcl 1 mode2 aligned based(addr(mode)) , 3 skip1 bit(32)unal , 3 read bit( 1)unal , 3 exec bit( 1)unal , 3 writ bit( 1)unal , 3 skip2 bit( 1)unal ; %page; %include use_big_tape_blocks; end use_big_tape_blocks_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved