decode_nstd_status_.pl1 11/19/82 1410.9rew 11/19/82 0929.8 63324 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ decode_nstd_status_: proc (status, return_string); /* This procedure will decode the status returned by nstd_ and will return a short description of the status in a varying character string. It is called with two arguments. The first is the 72 bit status. The second is a 50 (or longer) character varying string in which the status interpretation message will be returned. WRITTEN BY DICK SNYDER .... 1971 MODIFIED BY T. CASEY AUGUST 1974, NOVEMBER 1974 */ dcl status bit (72) aligned; dcl phyem char (100) varying; dcl return_string char (*) varying; dcl 1 stat_word aligned based (addr (status)), 2 fill bit (26) unaligned, 2 major bit (4) unaligned, 2 minor bit (6) unaligned; dcl 1 minor_bits aligned based (addr (status)), 2 fill2 bit (30) unaligned, 2 mb1 bit (1) unaligned, 2 mb2 bit (1) unaligned, 2 mb3 bit (1) unaligned, 2 mb4 bit (1) unaligned, 2 mb5 bit (1) unaligned, 2 mb6 bit (1) unaligned; dcl (addr, string, substr) builtin; if major = "0000"b then do; /* Peripheral Subsystem Ready */ if minor = "000000"b then phyem = "tape ready"; else if minor = "001100"b then phyem = "ASCII alert"; else if mb6 &^mb3 then phyem = "write protected"; else if mb5 &substr (minor, 1, 3) = "000"b then phyem = "positioned at BOT"; else if mb4 then phyem = "9 track handler"; else if ^mb5 then do; if substr (minor, 1, 3) = "010"b then phyem = "two bit fill"; else if substr (minor, 1, 3) = "100"b then phyem = "four bit fill"; else if substr (minor, 1, 3) = "110"b then phyem = "six bit fill"; else goto unknown_ready; end; else unknown_ready: phyem = "peripheral subsystem ready - unknown substatus"; end; else if major = "0001"b then do; /* Device Busy */ if minor = "000001"b then phyem = "in rewind"; else if minor = "100000"b then phyem = "device reserved"; else if minor = "000010"b then phyem = "alternate channel in control"; else if minor = "000100"b then phyem = "device loading"; else phyem = "device busy - unknown substatus"; end; else if major = "0010"b then do; /* Device Attention */ if mb1 then goto unknown_attention; else if ^mb2 & substr (minor, 5, 2) = "01"b then phyem = "write protected"; else if mb2 & substr (minor, 5, 2) = "00"b then phyem = "blank tape on write"; else if substr (minor, 4, 2) = "10"b then phyem = "handler in standby"; else if mb3 &^mb5 then phyem = "handler check"; else unknown_attention: phyem = "device attention - unknown substatus"; end; else if major = "0011"b then do; /* Device Data Alert */ if minor = "000001"b then phyem = "transfer timing alert"; else if minor = "000010"b then phyem = "blank tape on read"; else if substr (minor, 5, 2) = "11"b then phyem = "bit detected during erase"; else if mb4 then phyem = "transmission parity alert"; else if mb3 then phyem = "lateral tape parity alert"; else if mb2 then phyem = "longitudinal tape parity alert"; else if mb1 then phyem = "end-of-tape mark"; else phyem = "device data alert - unknown substatus"; end; else if major = "0100"b then do; /* End of File */ if minor = "001111"b then phyem = "eof 7 track"; else if minor = "010011"b then phyem = "eof 9 track"; else if minor = "111111"b then phyem = "data alert"; else phyem = "single character record"; end; else if major = "0101"b then do; /* Command Reject */ if minor = "000000"b then phyem = "invalid set density"; else if minor = "001000"b then phyem = "backspace while at at BOT"; else if minor = "010000"b then phyem = "forward read after write"; else if minor = "100000"b then phyem = "9 track command to 7 track handler"; else if substr (minor, 1, 3) = "000"b then do; if mb6 then phyem = "invalid operation code"; else if mb5 then phyem = "invalid device code"; else if mb4 then phyem = "invalid IDCW parity"; else goto unknown_reject; end; else unknown_reject: phyem = "command reject - unknown substatus"; end; else if major = "0111"b then phyem = "program load termination"; /* MTS 400s only */ else if major = "1000"b then phyem = "peripheral subsystem busy"; /* MTS 400s only */ else if major = "1010"b then do; /* MPC Device Attention */ if minor = "000001"b then phyem = "configuration switch error"; else if minor = "000010"b then phyem = "multiple devices with same id"; else if minor = "000011"b then phyem = "illegal device id number"; else if minor = "001000"b then phyem = "incompatible PE and NRZI modes"; else if minor = "010000"b then phyem = "handler malfunction"; else if minor = "010001"b then phyem = "multiple BOT markers"; else if substr (minor, 1, 4) = "0011"b then phyem = "TCA malfunction"; else phyem = "MPC device attention - unknown substatus"; end; else if major = "1011"b then do; /* MPC Device Data Alert */ if minor = "000001"b then phyem = "transmission parity alert"; else if minor = "000010"b then phyem = "inconsistent command"; else if minor = "000011"b then phyem = "sum check (sic) error"; else if minor = "000100"b then phyem = "byte locked out"; else if minor = "001000"b then phyem = "PE-burst write error"; else if minor = "001001"b then phyem = "preamble error"; else if minor = "100000"b then phyem = "marginal condition"; else if minor = "010000"b then phyem = "multi-track error"; else if minor = "010001"b then phyem = "skew error"; else if minor = "010010"b then phyem = "postamble error"; else if minor = "010011"b then phyem = "NRZI correctable error"; else if minor = "010100"b then phyem = "code alert"; else phyem = "MPC device data alert - unknown substatus"; end; else if major = "1101"b then do; /* MPC command reject */ if minor = "000001"b then phyem = "illegal procedure"; else if minor = "000010"b then phyem = "illegal logical channel number"; else if minor = "000011"b then phyem = "illegal suspended logical channel number"; else if minor = "000100"b then phyem = "IDCW continue bit not set"; else phyem = "MPC command reject - unknown substatus"; end; else phyem = "unknown major status"; return_string = phyem; /* one assignment to the char (*) return string, to avoid/ length-checking code for all the above assignments */ return; end decode_nstd_status_;  gcos_card_utility.pl1 09/12/83 1115.2rew 09/12/83 0913.6 393021 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_card_utility: gcu: proc; /* * This command copies GCOS card image files, changing their format, * content and medium as specified by the control arguments given. * * USAGE: gcu input_specification output_specification * * The input and output specifications are composed of pathnames and * control arguments. The list of arguments that can be used is very long, * and is documented in the MPM, so it will not be repeated here. * * This procedure only processes the command line. It calls the subroutine * gcos_card_utility_ to do the real work. */ %page; /* * WRITTEN BY T. CASEY MAY 1973 * MODIFIED BY T. CASEY * SEPTEMBER 1973 * OCTOBER 1973 * MARCH 1974 * AUGUST 1974 * NOVEMBER 1974 * JULY 1975 * MARCH 1976 * * MODIFIED BY S. AKERS AUGUST, 1981: * Fix range errors in suffix checking. * Make suffix checking more efficient. * * Add "-canonicalize" "-can" "-ncan" * "-gcos_bcd" "-gcb" control_args. * Change handling of canonicalization, * new default is to NOT do it. Ignore * the "-no" control_arg. * * Changed formfeed to %page; * * Fixed control_arg checker so it * doesn't generate stringrange errors. * Modified: Ron Barstad 82-09-28 Fixed typo error in label err(68) * Modified: Ron Barstad 2.0 83-02-08 Fix nested if in -tape arg processing * Added version in "me", started with 2.0 * Modified: Ron Barstad 2.1 83-06-09 Allowed conversion to ascii or gcos_ascii * from BCD media code 0 to be over 80 chars * Modified: Ron Barstad 2.2 83-07-13 Fixed -tape group again, find bad -args >4 chars */ %page; /* D E C L A R A T I O N S */ /* External Entries */ dcl com_err_ ext entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl cv_dec_check_ ext entry (char (*), fixed bin(35)) returns (fixed bin); dcl db ext entry; dcl decode_nstd_status_ ext entry (bit (72) aligned, char (*) varying); dcl expand_path_ entry (ptr, fixed bin(21), ptr, ptr, fixed bin(35)); dcl get_system_free_area_ ext entry returns (ptr); dcl gcos_card_utility_ ext entry (ptr, ptr, fixed bin(35)); dcl hcs_$initiate_count ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), fixed bin(2), ptr, fixed bin(35)); dcl hcs_$terminate_noname ext entry (ptr, fixed bin(35)); dcl (ioa_, ioa_$nnl) ext entry options (variable); dcl ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ( error_table_$badopt , error_table_$inconsistent , error_table_$ioname_not_found , error_table_$noarg ) ext fixed bin(35); /* Builtin */ dcl (addr, baseno, divide, length, max, null, substr, index, reverse, rtrim, unspec) builtin; dcl cleanup condition; /* For argument processing */ dcl ap ptr; dcl al fixed bin(21); dcl arg char (al) based (ap); dcl (nargs, argno) fixed bin; dcl (i, j, k, l, m, n) fixed bin(24); dcl (starting_line_no, ending_line_no, no_of_lines) fixed bin(24)init (0); dcl status bit (72) aligned; dcl code fixed bin(35) aligned based (addr (status)); dcl numeric_arg fixed bin(24); dcl tab_index fixed bin(24)init (0); dcl expected_arg fixed bin(24)init (0); /* For program readability, we assign names to the numeric values that the multi-valued switch - expected_arg - can have */ dcl ( /* names in alphabetic order */ first_line init (31) , last_line init (32) , line_count init (33) , list init (34) , list_file init (35) , tabs init (36) , tape_id init (37) , tape_label init (38) ) fixed bin(24)int static; dcl ( /* switches init off */ io_spec_given (2), /* on when input or output spec is completed */ io_source_given (2), /* on after a tape or file name has been given */ list_finished (2) /* on when a list has been given - only one is allowed */ ) bit (1) aligned init ((2) (1) "0"b); dcl ( fixed_in_db , list_started /* on while reading list elements from arg list */ , verify_suffix /* on if we must check for consistent suffixes in a list of pathnames */ , detach_tapes /* on if only detaching tapes left attached from previous use of this command */ , normal_termination /* distinguish cleanup condition from normal termination */ ) bit (1) aligned init ("0"b); dcl me char (23) aligned int static options (constant) init ("gcos_card_utility (2.2)"); dcl dirname char (168) aligned; dcl ename char (32) aligned; dcl bitcount fixed bin(24); dcl segptr ptr init (null); dcl seglen fixed bin(24); dcl seg_olay char (seglen) based (segptr); dcl rw char (1) aligned; /* "r" or " " (rw) for tape attachments */ dcl newline char (1) unaligned int static init (" "); dcl word_string_len fixed bin(24)init (1); dcl word_string (word_string_len) bit (36) aligned based; dcl (numeric, control) bit (1) init ("0"b); dcl free_ptr ptr based (free_ptr_ptr); /* used in cleanup_proc to free allocated storage */ dcl free_ptr_ptr ptr; /* this is NOT a typing error */ dcl system_free_ptr ptr init (get_system_free_area_ ()); dcl system_free_area area based (system_free_ptr); /* For calling gcos_card_utility_ */ dcl 1 input_structure_area like input automatic; /* place to put input structure */ dcl 1 output_structure_area like output automatic; /* place to put output structure */ %include gcos_utility_args_; %page; /* P R O C E D U R E */ call cu_$arg_count (nargs,code); if nargs = 0 then do; code = error_table_$noarg; call com_err_ (code, me, "^/Usage: gcu input_specification output_specification"); return; end; /* Initialize */ input_ptr = addr (input_structure_area); output_ptr = addr (output_structure_area); unspec (input) = ""b; /* zero out the structures */ unspec (output) = ""b; /* to avoid problems with garbage */ input.list_ptr, input.tape_ptr = null; /* don't want zeros there, though */ output.list_ptr, output.tape_ptr = null; input.sw = input_code; output.sw = output_code; input.com_err = "1"b; /* tell gcos_card_utility_ subroutine to call com_err_ if any errors occur */ io_ptr = input_ptr; /* start with input spec unless user says -output */ input.no_canon = "1"b; /* Default is no canonicalization */ on condition (cleanup) call cleanup_proc; arg_loop: do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, code); if code ^= 0 then call arg_error (2); numeric_arg = cv_dec_check_ (arg, code); /* see if it's a numeric arg */ if code = 0 then numeric = "1"b; else numeric = "0"b; code = 0; /* to avoid confusion if errors later */ if substr (arg, 1, 1) = "-" then control = "1"b; /* see if it's a control arg */ else control = "0"b; if expected_arg ^= 0 then /* if we are expecting anything specific */ interpret_expected_arg: do; /* In alphabetic order by name */ if expected_arg = first_line then do; if ^numeric then call arg_error (3); /* numeric arg missing */ starting_line_no = numeric_arg; expected_arg = 0; end; else if expected_arg = last_line then do; if ^numeric then call arg_error (4); /* expected numeric arg missing */ ending_line_no = numeric_arg; expected_arg = 0; end; else if expected_arg = line_count then do; if ^numeric then call arg_error (5); /* numeric arg missing */ no_of_lines = numeric_arg; expected_arg = 0; end; else if expected_arg = list then do; if list_started then do; /* if not first time */ if control then do; /* control arg signals end of list */ expected_arg = 0; /* back to looking for ctl args */ list_finished (io.sw) = "1"b; /* remember that list was read */ goto interpret_control_arg; /* go process this arg */ end; if al > io.list_name_size then call arg_error (6); /* name too long */ io.list_count = io.list_count + 1; /* bump count */ if io.set = multiple_files /* if pathname */ then do; io_list (io.list_count).names = get_io_pathname (arg); call check_suffix (arg); end; else io_list (io.list_count).names = arg; /* else snumb or edit name */ end; else do; /* first argument in list - it could be the first name, or one of -all, -name, or -file_input */ if control then do; if arg = "-fi" | arg = "-file" | arg = "-file_input" then expected_arg = list_file; /* next arg will be pathname */ else if arg = "-all" then do; if io.sw = output_code then call arg_error (7); /* -all only allowed in input list */ if input.set = multiple_files then call arg_error (8); /* -all only allowed after -gmap ot -library or -imcv */ input.all = "1"b; input.list_count = 99999; /* arbitrary large number */ expected_arg = 0; end; else if arg = "-nm" | arg = "-name" | arg = "-names" then do; if io.sw = input_code then call arg_error (9); /* -name only allowed in output list */ output.name_files = "1"b; output.list_count = 99999; /* arbitrary large number */ expected_arg = 0; end; else call arg_error (10); /* expected arg missing */ end; else do; /* allocate and initialize list */ if al > io.list_name_size then call arg_error (11); /* name too long */ list_started = "1"b; io.list_count = nargs - argno + 1; /* max list length is rest of args */ allocate io_list in (system_free_area) set (io.list_ptr); unspec (io_list) = ""b; /* clear it */ io.list_count = 1; io_list (1).names = arg; /* save first item in list */ end; /* end alloc and init list */ end; /* end first time */ end; /* end expecting list item */ else if expected_arg = list_file then do; expected_arg = 0; /* turn off the expected switch */ call expand_path_ (addr (arg), al, addr (dirname), addr (ename), code); if code ^= 0 then call arg_error (12); /* from a file system call */ call hcs_$initiate_count (dirname, ename, "", bitcount, 0, segptr, code); if segptr = null then call arg_error (13); /* from a file system call */ code = 0; /* clear possble error_table_$segknown, to avoid confusion if a real error occurs later */ seglen = divide (bitcount, 9, 17, 0); k = 0; /* counter for newlines */ n = 1; /* start with first char */ l = seglen; /* have whole seg left to search */ do while (l > 0); /* search whole seg */ m = index (substr (seg_olay, n, l), newline); /* for newlines */ if m ^= 0 then do; /* if we found one */ if m > 1 then /* don't blow up on blank lines */ k = k + 1; /* count newlines (actually counting names) */ if m > io.list_name_size + 1 then call arg_error (14); /* name too long */ l = l - m; /* shorten string yet to be searched */ n = n + m; /* move past this newline */ end; else l = 0; /* no newline at end - but end of segment anyway */ end; /* end of name counting loop */ io.list_count = k; /* actual length of list */ allocate io_list in (system_free_area) set (io.list_ptr); /* allocate storage for list */ unspec (io_list) = ""b; /* clear it */ l = seglen; /* re init length of string to be processed */ n = 1; /* and starting char of the string */ do k = 1 to io.list_count; /* copy names from seg to structure */ indx: m = index (substr (seg_olay, n, l), newline); if m > 1 then do; /* check for blank lines */ if io.set = multiple_files /* if pathname */ then do; io_list (k).names = get_io_pathname (substr (seg_olay, n, m-1)); call check_suffix (substr (seg_olay, n, m-1)); end; else /* else must be snumb or edit name */ io_list (k).names = substr (seg_olay, n, m-1); /* name, less the newline */ end; n = n + m; /* move past name */ l = l - m; /* shorten the string */ if m = 1 then goto indx; /* dont increment k if it was a blank line */ end; list_finished (io.sw) = "1"b; /* remember that we already have the list */ call hcs_$terminate_noname (segptr, code); if code ^= 0 then call arg_error (67); /* OUT OF ORDER - ADDED LATER */ end; /* end of expecting list file do group */ else if expected_arg = tabs then do; if ^numeric then do; /* can't be a tabstop if not numeric */ if tab_index = 0 then call arg_error (15); /* tabstop arguments missing */ else do; /* end of tabstop list is signified by any non numeric arg */ expected_arg = 0; if control then goto interpret_control_arg; else goto interpret_path; end; end; /* end of non numeric do group */ else do; /* it was numeric - see if it is a legal tabstop */ if numeric_arg < 2 | numeric_arg > 80 then call arg_error (16); /* tabstop can't be before col 2 or past col 80 */ if tab_index > 0 then /* if not first tabstop */ if numeric_arg ^> input.tabstops (tab_index) then /* it must be > previous one */ call arg_error (17); /* tabstops not in increasing numeric order */ tab_index = tab_index + 1; if tab_index > 10 then call arg_error (18); /* only 10 tabstops allowed */ input.tabstops (tab_index) = numeric_arg; end; /* end of numeric arg do group */ end; /* end of expecting tabstops do group */ else if expected_arg = tape_id then do; if al > 32 then call arg_error (19); /* tape id too long */ io_tape.id = arg; if control then if arg = "-att" | arg = "-attached" then io_tape.attached = "1"b; expected_arg = 0; end; else if expected_arg = tape_label then do; expected_arg = 0; if numeric then /* check for easiest case first */ io_tape.position = numeric_arg; else do; /* check for label or n,label or label,n */ i = index (arg, ","); /* look for comma */ if i = 0 then do; /* no comma - all label */ m = 1; /* set up substr parameters to pick up whole arg */ n = al; goto check_label; /* and go see if its an ok label */ end; /* set up substring parameters */ k = 1;l = i-1; /* part before comma */ m = i+1;n = al-i; /* part after comma */ j = index (substr (arg, m, n), ","); /* look for extra comma */ if j ^= 0 then call arg_error (20); /* bad tape label format - 2 commas */ cv_dec_label: j = cv_dec_check_ (substr (arg, k, l), code); if code ^= 0 then do; code = 0; /* not an error_table_ code - clear it */ if m = 1 then /* if we already switched */ call arg_error (21); /* bad tape label format - comma but no numeric field */ else do; /* switch fields */ k = m;l = n; /* maybe the second part is numeric */ m = 1;n = i-1; /* and the first is the label */ goto cv_dec_label; /* go try to convert it */ end; /* end switch fields */ end; /* end code = 0 */ io_tape.position = j; /* save position */ check_label: if n > 12 then call arg_error (22); /* bad tape label format - label > 12 chars */ io_tape.label = substr (arg, m, n); end; /* end of check for label or n,label do group */ end; /* end of expecting label do group */ else /* expected arg has bad value */ call arg_error (-1); /* -1 means "program bug" */ end interpret_expected_arg; else if control then /* not expecting anything */ interpret_control_arg: do; /* if control arg, see what it is */ /* In alphabetic order by the long spelling of the argument */ /* -all only allowed in a list; checked for after all legal args, below */ if arg = "-app" | arg = "-append" then do; if io.sw = input_code then call arg_error (23); /* -append legal only for output */ output.append = "1"b; end; else if arg = "-aci" | arg = "-ascii" then do; if io.format ^= 0 then if io.format ^= ascii then call arg_error (24); /* inconsistent format spec */ io.format = ascii; if io.medium ^= 0 then /* DON'T THINK THIS CAN EVER HAPPEN - */ if io.medium ^= file then /* BUT LET'S BE SAFE */ call arg_error (25); /* inconsistent medium spec */ io.medium = file; end; else if arg = "-att" | arg = "-attached" then do; if io.medium ^= tape then call arg_error (50); /* OUT OF ORDER - MESSAGE CHANGED */ io_tape.attached = "1"b; end; else if arg = "-bf" | arg = "-brief" then io.brief = "1"b; else if arg = "-cdk" | arg = "-comdk" then do; io.comdk = "1"b; if io.format ^= 0 then if io.format ^= gcos then call arg_error (26); /* inconsistent format spec */ io.format = gcos; end; else if arg = "-ct" | arg = "-count" then do; if io.sw = output_code then call arg_error (27); /* not allowed for output */ if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */ call arg_error (28); /* inconsistent args */ expected_arg = line_count; end; else if arg = "-db" | arg = "-debug" then input.debug = "1"b; else if arg = "-det" | arg = "-detach" then do; if argno = nargs then /* check for special case */ if argno = 1 /* -detach the only argument */ | (argno = 2 & input.debug) then /* or just preceeded by -debug */ detach_tapes = "1"b; /* if so detach tapes and quit */ detach_tape: call ios_$detach (tape_stream (io.sw), "", "", status); if code ^= 0 then if code ^= error_table_$ioname_not_found then call arg_error (29); /* error detaching tape */ if detach_tapes then do; /* if detaching both tapes */ if io.sw = input_code then do; io_ptr = output_ptr; goto detach_tape; end; else return; /* all done - just called to detach tapes */ end; /* end of just detaching do group */ end; /* end of -detach do group */ /* -file_input only allowed in a list; checked for after all legal args, below */ else if arg = "-ft" | arg = "-first" then do; if io.sw = output_code then call arg_error (30); /* not legal for output */ if starting_line_no ^= 0 then call arg_error (31); expected_arg = first_line; end; else if arg = "-gc" | arg = "-gcos" then do; gcos_arg: if io.format ^= 0 then if io.format ^= gcos then call arg_error (32); /* inconsistent format spec */ io.format = gcos; end; else if arg = "-gca" | arg = "-gcos_ascii" then do; if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */ output.gcos_ascii = "1"b; goto gcos_arg; end; else if arg = "-gcb" | arg = "-gcos_bcd" then do; if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */ output.gcos_bcd = "1"b; goto gcos_arg; end; else if arg = "-gmap" | arg = "-lib" | arg = "-library" then do; input.set = library; input.list_name_size = 4; /* library edit names are 4 chars */ set_up_for_list: /* come here from -imcv to finish setting up for list */ if io.sw = output_code then call arg_error (33); if list_finished (io.sw) then call arg_error (34); /* already given */ expected_arg = list; list_started = "0"b; /* we want to special-case the first list element */ end; else if arg = "-imcv" then do; input.set = imcv; input.list_name_size = 5; /* snumbs are 5 chars max */ goto set_up_for_list; /* go share code with -library */ end; else if arg = "-in" | arg = "-input" then do; if argno > 1 then /* except for first argument, when io.sw is initialized to the default (input_code) */ if argno ^= 2 | ^input.debug then /* (or if first arg was -db and this is the 2nd) */ io_spec_given (io.sw) = "1"b; /* remember that input or output (io.sw says which) specs have already been given */ if io_spec_given (input_code) then /* if input specs have already been given */ call arg_error (35); /* do not allow them to be given again */ io_ptr = input_ptr; /* switch to processing the input specification */ end; else if arg = "-lbl" | arg = "-label" then do; if io.medium ^= tape then call arg_error (36); /* -tape must preceed -retain or -label */ expected_arg = tape_label; end; /* -library is a generalization of -gmap, and is processed above, with -gmap */ else if arg = "-lt" | arg = "-last" then do; if io.sw = output_code then call arg_error (37); /* not allowed for output */ if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */ call arg_error (38); /* inconsistent args */ expected_arg = last_line; end; else if arg = "-ls" | arg = "-list" then do; if io_source_given (io.sw) then call arg_error (39); /* can't say -list if -tape or pathname already given */ io_source_given (io.sw) = "1"b; if list_finished (io.sw) then call arg_error (40); /* only one list allowed */ list_started = "0"b; /* so we can special case the first list item */ expected_arg = list; io.list_name_size = 168; /* max length of pathname */ io.set = multiple_files; if io.medium ^= raw then io.medium = file; if io.format ^= 0 then /* if format already given */ verify_suffix = "0"b; /* ignore suffixes */ else verify_suffix = "1"b; /* otherwise first suffix determines format, and the rest must be consistent with it */ end; else if arg = "-lg" | arg = "-long" then io.long = "1"b; else if arg = "-no" | arg = "-no_canonicalize" | arg = "-ncan" then do; if io.sw = output_code then call arg_error (41); /* legal only for input */ input.no_canon = "1"b; end; else if arg = "-can" | arg = "-canonicalize" then do; if io.sw = output_code then call arg_error (41); /* legal only for input */ input.no_canon = "0"b; end; /* -name only allowed in a list; checked for after all legal args, below */ else if arg = "-out" | arg = "-output" then do; if argno > 1 then if argno ^= 2 | ^input.debug then io_spec_given (io.sw) = "1"b; /* same logic as for input */ if io_spec_given (output_code) then call arg_error (42); io_ptr = output_ptr; /* switch to processing output specification */ end; else if arg = "-raw" then do; if io.medium = tape then call arg_error (43); /* inconsistent medium spec */ io.medium = raw; if io.format ^= 0 then if io.format ^= gcos then call arg_error (44); /* inconsistent format spec */ io.format = gcos; end; else if arg = "-ret" | arg = "-retain" then do; if io.medium ^= tape then call arg_error (45); /* -tape must preceed -retain or -label */ io_tape.retain = "1"b; end; else if arg = "-tabs" then do; if io.sw = output_code then call arg_error (66); /* OUT OF ORDER - ADDED LATER */ if input.tabs_given then call arg_error (46); /* can't give tabs twice */ input.tabs_given = "1"b; expected_arg = tabs; end; else if (arg = "-tape") | (arg = "-tape7") | (arg = "-tape9") then do; if io_source_given (io.sw) then call arg_error (47); /* can't say -tape after giving file name */ io_source_given (io.sw) = "1"b; if io.medium ^= 0 then /* possible -raw -tape */ call arg_error (69); /* OUT OF ORDER - ADDED LATER */ io.medium = tape; if io.format ^= 0 then if io.format ^= gcos then call arg_error (48); /* inconsistent format spec */ io.format = gcos; /* can only be gcos files on tape */ allocate io_tape in (system_free_area) set (io.tape_ptr); unspec (io_tape) = ""b; /* clear it */ io_tape.label = ""; /* want blanks (not zeros) in label field */ if al > 5 then do; /* see if a 7 or 9 on the end */ io_tape.tracks = substr (arg, 6, 1); if (io_tape.tracks ^= "7" & io_tape.tracks ^= "9") |al ^= 6 then call arg_error (49); end; else io_tape.tracks = " "; expected_arg = tape_id; end; /* end of -tape do group */ else if arg = "-tc" | arg = "-tnc" | arg = "-truncate" then io.truncate_ascii = "1"b; /* The following control arguments are only allowed in place of some expected argument, and their occurrence out of context is an error */ else if arg = "-fi" | arg = "-file" | arg = "-file_input" | arg = "-all" | arg = "-nm" | arg = "-name" then call arg_error (51); /* only allowed in place of a list */ else /* bad control arg */ call arg_error (52); end interpret_control_arg; /* interpret non-control arg - i.e. pathname not preceeded by ctl arg */ else interpret_path: do; check_if_given: if io_source_given (io.sw) then /* if a pathname or tape number was already given */ switch_io: do; /* for the current spec, switch to the other one */ /* if -in and -out not given, the default is -in, then -out, with the switch being made when the second pathname is found */ if io.sw = input_code then io_ptr = output_ptr; else call arg_error (53); goto check_if_given; /* in case both have been given */ end switch_io; io.set = single_file; if io.medium ^= raw then /* unless -raw preceeded this */ io.medium = file; io_source_given (io.sw) = "1"b; io.file_name = get_io_pathname (arg); /* expand the pathname */ call check_suffix (arg); /* validate the suffix, if there is one */ end interpret_path; end arg_loop; /* Check input and output specification for completeness and consistency */ if expected_arg ^= 0 then do; /* still expecting an argument? */ if list_started then /* were we in a list, with first item already given? */ list_finished (io.sw) = "1"b; /* it's ok for arg list to end in a list */ else if expected_arg ^= tabs then /* also ok to end with list of tabstops */ call arg_error (54); /* expected arg missing after last arg on line */ end; /* check io stuff */ do io_ptr = input_ptr, output_ptr; if io.format = 0 then io.format = ascii; /* the default */ if io.set = 0 then io.set = single_file; /* if no list was given, this is still zero */ if ^io_source_given (io.sw) then call arg_error (55); /* io spec incomplete - must give tape or file name */ if io.format ^= ascii then if io.truncate_ascii then call arg_error (56); /* -truncate only allowed for ascii */ /* check input-only stuff */ if io.sw = input_code then do; input.first_line = starting_line_no; /* will be zero if -ft not given */ if no_of_lines ^= 0 /* if -ct given */ then input.last_line = max (input.first_line, 1) + no_of_lines -1; /* then compute last line no */ else input.last_line = ending_line_no; /* will be zero if -lt not given */ end; /* check output-only stuff */ if io.sw = output_code then do; if output.append then if output.medium = tape then call arg_error (58); /* can not append to a tape file */ if output.name_files then if input.set ^= library then if input.set ^= imcv then call arg_error (70); /* OUT OF ORDER - ADDED LATER */ end; end; /* Check for tape to disk copy, to avoid deblocking if possible */ do io_ptr = input_ptr, output_ptr; if io.format ^= gcos then goto not_blocks; if io.comdk then goto not_blocks; if io.medium = raw then goto not_blocks; if io.set ^= single_file then goto not_blocks; end; if output.append then goto not_blocks; if output.gcos_ascii then goto not_blocks; if output.gcos_bcd then goto not_blocks; if input.first_line ^= 0 then goto not_blocks; if input.last_line ^= 0 then goto not_blocks; input.format, output.format = blocks; /* We can copy without deblocking */ not_blocks: /* Attach tapes here to minimize mounting and dismounting */ do io_ptr = input_ptr, output_ptr; if io.sw = input_code then rw = "r"; /* attach input tape in read-only mode */ else rw = " "; /* equivalent to "rw" for ios_$attach */ if io.medium = tape then if ^io_tape.attached then do; /* ***** NOTE ***** The method of specifying tracks and density is undergoing some changes (July 1975). The validity of this code must be reviewed periodically. */ if io_tape.tracks ^= " " then do; /* if tracks given by -tape7 or -tape9 */ i = index (io_tape.id, " "); /* find end of tape name and append ",Ntrack" */ if substr (io_tape.id, i-5, 5) ^= "track" then /* but make sure it's not there already */ if i <= 26 then /* and there's room to put it there */ substr (io_tape.id, i, 7) = "," || io_tape.tracks || "track"; end; io_tape.attached = "1"b; /* for cleanup_proc; turn on BEFORE calling attach */ call ios_$attach (tape_stream (io.sw), "nstd_", io_tape.id, rw, status); if code ^= 0 then call arg_error (59); /* error attaching tape */ end; /* end tape and not attached do group */ end; /* end attach tapes do loop */ /* now call subroutine to do the real work */ call gcos_card_utility_ (input_ptr, output_ptr, code); if code ^= 0 then if ^input.com_err then /* if subroutine did not call com_err_ */ call com_err_ (code, me); revert cleanup; normal_termination = "1"b; /* tell cleanup_proc that this is not cleanup condition */ call cleanup_proc; /* used for cleanup and normal termination */ quit: return; %page; /* I N T E R N A L P R O C E D U R E S */ /* Procedure to format and print error messages */ arg_error: proc (error_code); dcl error_code fixed bin(24); /* identifies the place where the error occurred. Each call has a different number, even if the message is the same. The first 64 are in order in the program. Those above 64 were added later and are out of order. */ dcl max_error_code fixed bin(24)init (71); /* next available error_code value is 72 */ dcl bad_arg char (168) varying; /* the bad argument or pathname */ dcl (err_msg, msg2) char (200) varying; /* portions of message text */ dcl mnames (11:20) char (8) aligned int static init ( "filename", "snumb", "editname", "filename", "ascii", "gcos", "blocks", "raw", "tape", "file"); bad_arg = arg; /* the bad thing is the current argument */ goto arg_error_common; /* Entry called from get_io_pathname - second argument is the bad pathname */ path_error: entry (error_code, err_path); dcl err_path char (*); /* might be from a file instead of an argument */ bad_arg = err_path; /* argment or file item to be printed */ arg_error_common: if error_code < 2 | error_code > max_error_code then do; err_msg = "Program bug. ^a"; goto call_com_err; end; /* Use error_code as an index into a transfer vector that the compiler will build for us. This is implemented efficiently in the v2pl1 compiler */ goto err (error_code); /* Since we checked the upper and lower bound of error code above, no problems can arise */ err (2): err_msg = "^a From cu_$arg_ptr."; goto call_com_err; err (3): err (4): err (5): err_msg = "Numeric, before ^a"; goto et_noarg; /* go set code = error_table_$noarg */ err (6): err (11): err_msg = "Name in list is too long: ^a^/Max length of ^a is ^d."; msg2 = mnames (io.set); numeric_arg = io.list_name_size; goto call_com_err; err (7): err (27): err (30): err (33): err (37): err (41): err (66): err_msg = "This argument is only allowed in the input specification: ^a"; goto call_com_err; err (8): err_msg = "-all only allowed immediately following -gmap, -library, or -imcv"; goto call_com_err; err (9): err (23): err (72): err_msg = "This argument is only allowed in the output specification: ^a"; goto call_com_err; err (10): err_msg = "list item, before ^a"; goto et_noarg; err (12): err (60): err_msg = "From expand_path_ ^a"; goto call_com_err; err (13): err_msg = "From hcs_$initiate_count ^a"; goto call_com_err; err (14): bad_arg = substr (seg_olay, n, m-1); /* pick up bad name from file */ goto err (6); /* and go set up the "too long" message */ err (15): err_msg = "Tabstops, before ^a"; goto et_noarg; err (16): err_msg = "Illegal tabstop value: ^a^/Value must be 2 thru 80."; goto call_com_err; err (17): err_msg = "Tabstop value out of order: ^a^/Previous value was ^s^d"; numeric_arg = input.tabstops (tab_index); goto call_com_err; err (18): err_msg = "Only 10 tabstops allowed: ^a is the 11th."; goto call_com_err; err (19): err_msg = "Tape number too long: ^a^/Max length is 32 characters."; goto call_com_err; err (20): err_msg = "Bad tape label format - 2 commas: ^a"; goto call_com_err; err (21): err_msg = "Bad tape label format - comma but no numeric field: ^a"; goto call_com_err; err (22): err_msg = "Bad tape label format - file name too long: ^a^/Max length is 12 characters."; bad_arg = substr (bad_arg, m, n); goto call_com_err; err (24): err (26): err (32): err (44): err (48): err (61): err (62): err (63): err (64): msg2 = mnames (io.format); goto inconsistent_message; /* go set err_msg and error_table_$inconsistent */ err (25): err (43): err (69): msg2 = mnames (io.medium); goto inconsistent_message; err (28): err (31): err (38): err_msg = "^a and the previously specified -first, -last, or -count."; goto et_inconsistent; err (29): err_msg = "From ios_$detach the previously retained tape."; goto tape_message; /* check for and decode tape hardware status */ err (34): err (40): err_msg = "Only one list is allowed in the input or output specification: ^a"; goto call_com_err; err (35): msg2 = "the input specification"; goto given_message; err (36): err (45): err_msg = "-tape must preceed ^a"; goto call_com_err; err (39): err (47): msg2 = "a pathname or tape number"; goto given_message; err (42): err (53): msg2 = "the output specification"; goto given_message; err (46): msg2 = "a set of tabstops"; goto given_message; err (49): err_msg = "Illegal form of -tape argument: ^a"; goto call_com_err; err (50): err_msg = "^a only allowed after -tape, in place of, or in addition to, tape number"; goto call_com_err; err (51): err_msg = "^a only allowed in place of a list."; goto call_com_err; err (52): code = error_table_$badopt; err_msg = "^a"; goto call_com_err; err (54): err_msg = "After ^a"; goto et_noarg; err (55): err_msg = "^a pathname or tape number"; bad_arg = io_names (io.sw); goto et_noarg; err (56): err_msg = "-truncate only allowed for an ASCII file"; goto call_com_err; err (57): err_msg = "-no_canonicalize only allowed for an ASCII file."; goto call_com_err; err (58): err_msg = "-append is not allowed for a tape output file."; goto call_com_err; err (59): err_msg = "from ios_$attach ^a"; goto tape_id_message; err (65): err_msg = "From ios_$detach ^a"; goto tape_id_message; err (67): err (68): err_msg = "From hcs_$terminate_noname ^a"; goto call_com_err; err (70): err_msg = "-name only allowed when input is gmap, library, or imcv."; goto call_com_err; /* Set up error codes and messages common to several of the above */ et_noarg: code = error_table_$noarg; goto call_com_err; inconsistent_message: err_msg = "^/^a and ^a (previously specified or implied)."; et_inconsistent: code = error_table_$inconsistent; goto call_com_err; given_message: err_msg = "^a is an error because ^a was previously given."; goto call_com_err; tape_id_message: bad_arg = io_tape.id; tape_message: if substr (status, 1, 1) then do; /* hardware status */ msg2 = bad_arg; /* save the tape id */ call decode_nstd_status_ (status, bad_arg); err_msg = "^a^/" || err_msg; /* print decoded status before rest of message */ end; goto call_com_err; call_com_err: call com_err_ (code, me, err_msg, bad_arg, msg2, numeric_arg); if argno <= nargs then /* if not past end of arglist */ call ioa_$nnl ("Argument number ^d. ", argno); if nargs > 0 then call ioa_ ("^a specification.", io_names (io.sw)); if input.debug then do; call ioa_ ("arg error number ^d", error_code); call ioa_ ("CALLING DB"); call db; end; if ^fixed_in_db then do; normal_termination = ^normal_termination; /* by flipping the switch instead of turning it on, we avoid an infinite loop in the case where cleanup_proc gets an error detaching tape, and if the switch is on, it calls us back again to print an error message */ call cleanup_proc; /* detach tapes and free allocated storage */ goto quit; end; fixed_in_db = "0"b; /* turn off switch for next time */ return; end arg_error; %page; check_suffix: proc (given_path); /* This procedure checks the suffix (if any) in the pathname, and complains to the user if the suffix does not match the control arguments which were specified. If the suffix is acceptable, it is used to provide gcos_card_utility_ with the data type contained in the file. */ dcl given_path char (*) parm; dcl suffix_string char (32) varying; call get_suffix (given_path, suffix_string); if length (suffix_string) ^= 0 /* only if suffix exists */ then do; if io.format = 0 /* If format not given, get it from suffix. */ then do; if suffix_string = ".ascii" then io.format = ascii; else if suffix_string = ".gcos" then io.format = gcos; else if suffix_string = ".raw" then do; io.format = gcos; io.medium = raw; end; else if suffix_string = ".comdk" then do; io.format = gcos; io.comdk = "1"b; end; if io.medium = 0 then io.medium = file; /* If not raw or tape, then file. */ end; else if verify_suffix then do; /* check for consistent suffixes within a list */ if suffix_string = ".ascii" then do; if io.format ^= ascii then call path_error (61, given_path); /* inconsistent suffixes */ end; else if suffix_string = ".gcos" then do; if io.format ^= gcos then call path_error (62, given_path); /* inconsistent suffixes */ end; else if suffix_string = ".raw" then do; if io.format ^= gcos | io.medium ^= raw then call path_error (63, given_path); /* inconsistent suffixes */ end; else if suffix_string = ".comdk" then do; /* comdk is not inconsistent with gcos - but if it was not the first suffix given, then the gcos suffix determines the format */ if io.format ^= gcos then call path_error (64, given_path); /* inconsistent suffixes */ end; end; /* end of verify suffix do group */ end; /* end of suffix-checker */ return; end check_suffix; %page; /* Procedure to detach tapes and free allocated storage. Called on cleanup condition, and also for normal termination. The switch, normal_termination, tells us which it is. */ cleanup_proc: proc; /* Detach tapes (unless user said -retain) */ do io_ptr = input_ptr, output_ptr; if io.tape_ptr ^= null then do; /* there is a tape */ if io_tape.retain then do; /* but user said retain */ if io_tape.attached then /* if the tape is really attached */ if ^io.brief then /* and user did not say -brief */ call com_err_ (0, me, "Tape ^a will remain attached.", io_tape.id); end; /* end retain */ else do; /* detach it */ if io_tape.attached then do; /* only if it is already attached */ call ios_$detach (tape_stream (io.sw), "", "", status); if code ^= 0 then do; if normal_termination then /* avoid infinite loop */ call arg_error (65); /* OUT OF ORDER - ADDED LATER */ end; /* end code ^= 0 */ end; /* end attached */ end; /* end ^retain */ end; /* end io.tape_ptr ^= null */ end; /* end detach tapes do loop */ /* Free allocated storage */ do free_ptr_ptr = addr (input.list_ptr), addr (input.tape_ptr), addr (output.list_ptr), addr (output.tape_ptr); if free_ptr ^= null then if baseno (system_free_ptr) = baseno (free_ptr) then /* make sure it is in free area */ free free_ptr -> word_string; /* can point to any old thing - only the pointer is passed to the free routine */ end; if segptr ^= null then do; call hcs_$terminate_noname (segptr, code); if code ^= 0 then if normal_termination then call arg_error (68); /* OUT OF ORDER- ADDED LATER */ end; end cleanup_proc; %page; /* Procedure to expand pathname */ get_io_pathname: proc (given_path) returns (char (168)); dcl given_path char (*); dcl expanded_path char (168); dcl pl fixed bin(21); pl = length (given_path); call expand_path_ (addr (given_path), pl, addr (expanded_path), null, code); if code ^= 0 then call path_error (60, given_path); return (expanded_path); end get_io_pathname; %page; get_suffix: proc (input_string, return_suffix); /* This procedure returns the suffix of an input_string (.gcos, .ascii, etc.). If there are more than two components in an input_string, the last one is returned. If there is no suffix, the suffix field is returned null. */ dcl input_string char(*) parm; dcl return_suffix char(*) varying parm; dcl work_string char(168) varying; dcl dot_index fixed bin (24); dcl dot char(1) internal static options(constant) init("."); work_string = reverse (rtrim (input_string)); dot_index = index (work_string, dot); if dot_index ^= 0 then return_suffix = reverse (substr (work_string, 1, dot_index)); else return_suffix = ""; return; end get_suffix; end gcos_card_utility;  gcos_card_utility_.pl1 09/12/83 1115.2rew 09/12/83 0913.7 1126494 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_card_utility_: proc (a_input_ptr, a_output_ptr, a_code); /* This subroutine does the work of the gcu (gcos_card_utility) command. It is called with pointers to two structures in the argument list, one containing all information pertaining to input, the other, all information pertaining to output. These structures contain pointers to other structures, which contain information about magnetic tape I/O, or lists of input or output items. These structures are only allocated if needed. Otherwise, the pointers to them are null. All these structures are described by the include file: gcos_utility_args_.incl.pl1 Actual space for these structures is allocated in gcos_card_utility.pl1 This procedure is composed of a large number of internal procedures, for the purpose of making it easily extensible, and to allow the flow of control to be easily followed by readers of the code. The procedures are arranged in alphabetic order by name, following the main procedure. */ %page; /* WRITTEN BY T. CASEY MAY 1973 MODIFIED BY T. CASEY SEPTEMBER 1973 * OCTOBER 1973 * MARCH 1974 * AUGUST 1974 * DECEMBER 1974 * JULY 1975 * MARCH 1976 * JANUARY 1977 * MODIFIED BY D. WARD APRIL 1981: * Changed to octal bit constants. * Changed \014 to %page; * MODIFIED BY S. AKERS AUGUST 1981: * Fixed problem of writing zero-length * BCWs to tapes when prior input block * is exactly 320 words. * * Added conversion from gcos_ascii to * gcos_bcd. * * Cleaned up format of program, putting * more stuff into internal procedures. * * Fixed bug which caused an EOF RCW to * be written to a tape. * * Changed Multics ASCII output to * omit trailing blanks. * * Fixed bug in converting GCOS ASCII * to GCOS BCD. * * Modified: Ron Barstad 2.1 83-06-09 Allowed conversion to ascii or gcos_ascii * from BCD media code 0 to be over 80 chars * Modified: Ron Barstad 2.2 83-07-13 Read and believe "char position" field of rcw of gcos records. */ %page; /* D E C L A R A T I O N S */ /* Arguments */ dcl a_code fixed bin(35) parm; dcl a_input_ptr ptr parm; dcl a_output_ptr ptr parm; /* Argument Structures */ %include gcos_utility_args_; /* Error Table Entries */ dcl error_table_$action_not_performed ext fixed bin(35); /* External Static */ dcl (gcos_control_tables_$activity_table, gcos_control_tables_$cardtable (8) char (8), gcos_control_tables_$exc_offset fixed bin(17), gcos_control_tables_$nonact fixed bin(24), gcos_control_tables_$tablelen fixed bin(17), gcos_control_tables_$tabstops) external static; /* External Entries */ dcl ( clock_ entry returns (fixed bin(71)), com_err_ entry options (variable), command_query_ entry options (variable), db entry, decode_clock_value_ entry (fixed bin(71), fixed bin(24), fixed bin(24), fixed bin(24), fixed bin(71), fixed bin(24), char (3) aligned), decode_nstd_status_ entry (bit (72) aligned, char (*) varying), gcos_cv_ascii_gebcd_check_ entry (ptr, fixed bin(24), ptr, fixed bin(35)), gcos_cv_gebcd_ascii_ entry (ptr, fixed bin(24), ptr), ioa_ entry options (variable), ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned), ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned), ios_$order entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned), ios_$read entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned), ios_$seek entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned), ios_$setdelim entry (char (*) aligned, fixed bin(24), bit (9), fixed bin(24), bit (9), bit (72) aligned), ios_$setsize entry (char (*) aligned, fixed bin(24), bit (72) aligned), ios_$tell entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned), ios_$write entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned), system_info_$installation_id entry (char (*)) ) external; dcl (addr, addrel, before, bin, bit, divide, fixed, hbound, index, length, max, min, mod, null, reverse, rtrim, string, substr, unspec, verify) builtin; dcl cleanup condition; /* Work areas and overlays for them */ dcl ascii_block char (input_block_len) based (input_block_ptr); dcl input_block (320) bit (36) aligned /* PLACE FOR ios_$read TO PUT THE DATA */; dcl input_block_len fixed bin(24); dcl input_block_ptr ptr; dcl 1 bcw aligned based, 2 bsn bit (18) unaligned, 2 length bit (18) unaligned; dcl 1 bcw_word based (input_block_ptr) aligned, 2 bcw_num fixed bin (18) unsigned unaligned, 2 bcw_len fixed bin (18) unsigned unaligned; dcl ascii_card char (ascii_line_len) aligned based (addr (ascii_line)); dcl ascii_line char (1280) aligned /* PLACE TO PUT ASCII LINE TRANSLATED FROM BCD */; dcl ascii_line_ptr ptr; dcl ascii_line_len fixed bin(24)init (80); /* a variable, in case we ever want to create variable length output lines */ dcl gcos_work_area (320) bit (36) aligned; /* PLACE TO PUT GCOS RECORD, TRANSLATED FROM ASCII OR RAW INPUT */ dcl gcos_work_area_ptr ptr; dcl 1 bcd_card aligned based (bcd_work_area_ptr), 2 rcw bit (36) unaligned, 2 column (84) bit (6) unaligned; dcl 1 bin_card aligned based, 2 rcw bit (36) unaligned, 2 column (80) bit (12) unaligned; dcl comdk_card_ptr ptr; dcl 1 comdk_card aligned based (comdk_card_ptr), /* for decoding input comdk cards */ 2 rcw bit (36) unaligned, 2 col1 bit (12) unaligned, /* col 1 */ 2 seq_no bit (24) unaligned, /* cols 2, 3 */ 2 checksum bit (36) unaligned, /* cols 4-6 */ 2 char (132) bit (6) unaligned, /* cols 7-72 */ 2 seq_col (8) bit (12) unaligned; /* col 73-80 */ dcl 1 k_card like comdk_card aligned based (comdk_work_area_ptr) /* for encoding output comdk cards */; dcl bit_string bit (bit_string_len) unaligned based /* overlay for moving bcd chars */; dcl bit_string_len fixed bin(24); dcl char_string char (char_string_len) unaligned based /* overlay for moving ASCII chars */; dcl char_string_len fixed bin(24); dcl word_string (word_string_len) bit (36) aligned based /* overlay for moving words */; dcl word_string_len fixed bin(24); dcl bcd_work_area (15) bit (36) aligned /* PLACE TO BUILD BCD RECORD FROM COMDK CARDS */; dcl bcd_work_area_ptr ptr; dcl gcos_record_len fixed bin(24); dcl gcos_record_ptr ptr; dcl 1 gcos_record aligned based (gcos_record_ptr), /* overlay for wherever a gcos record is - in input_block, in gcos_work_area, or in bcd_work_area */ 2 rcw bit (36) aligned, 2 data_words (gcos_record_len) bit (36) aligned; dcl 1 rcw aligned based, 2 length bit (18) unaligned, 2 char_pos bin (2) unsigned unaligned, 2 eof bit (4) unaligned, 2 zeroes bit (2) unaligned, 2 media_code bit (4) unaligned, 2 report_code bit (6) unaligned; dcl raw_card (80) bit (12) unaligned /* PLACE TO BUILD RAW OUTPUT CARD TRANSLATED FROM BCD */; dcl raw_card_ptr ptr; dcl comdk_work_area (28) bit (36) aligned /* PLACE TO BUILD OUTPUT COMDK CARDS */; dcl comdk_work_area_ptr ptr; dcl write_buffer (320) bit (36) aligned /* PLACE TO ACCUMULATE OUTPUT RECORDS FOR ios_$write */; dcl write_buffer_ptr ptr; dcl act_ptr ptr /* to look up tabstops for an activity */; dcl 1 act_table_entry aligned based (act_ptr), /* overlay for table entry for one activity */ 2 fill1 fixed bin(24), 2 fill2 char (4), 2 tab_index fixed bin(24); /* position in tabstops table of settings for this activity */ dcl tabstop_ptr ptr /* pointer to external static tabstop table */; dcl 1 tabstops aligned based (tabstop_ptr), 2 count fixed bin(24)aligned, /* number of sets of tabstops */ 2 tab (0:tabstops.count - 1), 3 stop (10) fixed bin(24)aligned; /* each set is 10 or fewer stops */ /* Tape label structures */ dcl 1 header_label aligned based (label_ptr), 2 btl bit (72) aligned, /* GE/b/b600/bBTL/b */ 2 installation bit (36) aligned, 2 reel_ser_no bit (36) aligned, /* /bxxxxx */ 2 file_ser_no bit (36) aligned, /* must = reel_ser_no, for single-reel files */ 2 reel_seq_no bit (36) aligned, /* /b/bxxxx - xxxx=1 for single-reel files */ 2 creation_date bit (36) aligned, /* /byyddd */ 2 retention_days bit (36) aligned, /* /b/b/bxxx */ 2 file_name bit (72) aligned, 2 unused (3) bit (36) aligned, 2 prverr bit (36) aligned; /* /b/b/b/b/b/b */ dcl 1 saved_header_label like header_label aligned automatic; dcl 1 partial_label aligned based (label_ptr), 2 btl bit (72) aligned, 2 installation bit (36) aligned, 2 reel_ser_no bit (36) aligned, 2 zero_words (6) bit (36) aligned, /* must be zero, for partial label */ 2 unused (4) bit (36) aligned; dcl 1 trailer_label aligned based (label_ptr), 2 eof bit (36) aligned, /* /bEOF/b/b or /bEOR/b/b */ 2 block_count bit (36) aligned, 2 unused (11) bit (36) aligned, 2 next_reel bit (36) aligned; /* /b/b/b/b/b/b */ /* Switches */ dcl ( appending_to_output, eof, eoj, file_eob, file_eof, found_last_line, input_comdk_open, just_looking, looking_for_first_line, looking_for_last_line, no_end_card, output_comdk_open, rcw_eof ) bit (1) aligned init ("0"b); dcl no_label (2) bit (1) aligned init ((2) (1)"0"b); /* Error Handling Variables */ dcl code fixed bin(35) based (addr (status)); dcl status bit (72) aligned; /* Fixed Bin */ dcl tod fixed bin(71); dcl ( bcd_col_index, bin_cards_skipped, block_serial_number, comdk_char_index, comdk_error_count, comdk_out_index, dom, dow, element_size, elements_wanted, elements_written, err_num, field_len, file_record_count, first_key, i, input_block_count, input_record_count, item_index, item_length, j, k, last_key, list_index, month, next_input_index, next_output_index, nondollar_tab_index, offset, output_block_count, output_block_len, output_record_count, path_len, prev_comdk_seq_no, raw_cards_bad, raw_chars_bad, remaining_block_len, remaining_output_words, string_len, year ) fixed bin(24)init (0); dcl chase fixed bin(1) init (1); dcl seq_col (5:8) fixed bin(24)/* numeric values of punches in cols 77-80 */; /* Pointers - Additional pointers are declared adjacent to the variables whose addresses they are initialized to */ dcl ( label_ptr, output_word_ptr, saved_record_ptr) ptr; /* Strings */ /* ASCII strings */ dcl punches char (36) varying; dcl punch (12) char (3) int static init ("-12", "-11", "-0", "-1", "-2", "-3", "-4", "-5", "-6", "-7", "-8", "-9"); dcl inst char (32); dcl me char (20) int static init ("gcos_card_utility_"); dcl tape_status_message char (50) varying; dcl (input_stream_name, output_stream_name) char (32) aligned; dcl ascii_search_key (15) char (15) aligned int static init ( "$ snumb ", "$ gmap ", "$ 355map ", "$ object ", "$ forty ", "$ fortran ", "$ ids ", "$ pl1 ", "$ cobol ", "$ asm66 ", "$ cbl74 ", "$ cbl68 ", "$ malt ", "$ ilang ", "$ ids2 "); dcl answer char (8) varying init (""); dcl card_type char (8) aligned; dcl edit_name char (8); dcl item_name char (8) aligned /* edit name or snumb */; dcl next_output_suffix char (6) aligned; dcl zone char (3) aligned; dcl ascii_newline char (1) int static init (" "); dcl ascii_backspace char (1) int static init (""); dcl ascii_pads char (4) int static init ("") /* four octal 177's */; dcl ascii_tab char (1) int static init (" "); /* BCD and binary strings */ dcl bcd_blank_card (14) bit (36) aligned int static init ((13) (6) "010000"b, "010000010000"b); /* we HOPE this puts blanks in 80 6-bit chars, and fills the rest of the last word with zeros */ dcl bcd_btl bit(72)static int options(constant) init("272520200600002022634320"b3) /* GEbb600bBTLb (BCD). */; dcl bcd_beofbb bit(36)static int options(constant)init("202546262020"b3) /* bEOFbb (BCD). */; dcl bcd_beorbb bit(36)static int options(constant)init("202546512020"b3) /* bEORbb (BCD). */; dcl bcd_b1 bit(36)static int options(constant)init("200000000000"b3) /* b00000 (BCD). */; dcl bcd_b2 bit(36)static int options(constant)init("202000000000"b3) /* bb0000 (BCD). */; dcl bcd_b3 bit(36)static int options(constant)init("202020000000"b3) /* bbb000 (BCD). */; dcl bcd_b6 bit(36)static init options(constant)init((6)"20"b3) /* 6 blanks (BCD). */; dcl ascii_header_rcw bit(36) static int options(constant) init("000024001000"b3); /* rec len = 20; media code = 8 */ dcl bcd_rcw bit(36)static int options(constant)init("000016000200"b3); /* rec len = 14; media code = 0010 (bcd card) */ dcl bin_rcw bit(36)static int options(constant)init( "000033000100"b3); /* rec len = 27; media code = 0001 (binary card) */ dcl eof_rcw bit(36)static int options(constant)init( "000000170000"b3); /* rec len = 0; eof = bcd_eof; media code,report code = 0 */ dcl bcd_endjob bit(36)static int options(constant)init( "254524414622"b3) /* ENDJOB (BCD). */; dcl gcd_star_eof bit(36)static int options(constant)init( "545454254626"b3) /* ***EOF (BCD). */; dcl bcd_search_key (15)bit(36)static int options(constant)init( "624564442220"b3 /* SNUMBb (BCD). */ ,"274421472020"b3 /* GMAPbb (BCD). */ ,"030505442147"b3 /* 355MAP (BCD). */ ,"462241252363"b3 /* OBJECT (BCD). */ ,"264651637020"b3 /* FORTYb (BCD). */ ,"264651635121"b3 /* FORTRA (BCD). */ ,"312462202020"b3 /* IDSbbb (BCD). */ ,"474301202020"b3 /* PL1bbb (BCD). */ ,"234622464320"b3 /* COBOLb (BCD). */ ,"216244060620"b3 /* ASM66b (BCD). */ ,"232243070420"b3 /* CBL74b (BCD). */ ,"232243061020"b3 /* CBL68b (BCD). */ ,"442143632020"b3 /* MALTbb (BCD). */ ,"314321452720"b3 /* ILANGb (BCD). */ ,"312462022020"b3 /* IDS2bb (BCD). */ ); dcl bcd_dkend bit(36)static int options(constant)init( "244225452420"b3) /* DKENDb (BCD). */; dcl bcd_edit_name (8) bit (6) unaligned; dcl comdk_col_1 bit(12)static int options(constant)init("5005"b3); dcl ascii_header_media_code bit (4) unaligned int static init ("1000"b) /* media code 8 - header for gcos TSS ascii file */; dcl ascii_media_code bit (4) unal int static init ("0110"b) /* media code 6 - ASCII */; dcl bcd_blank bit(6)static int options(constant)init("20"b3) /* blank (BCD). */; dcl bcd_dollar bit(6)static int options(constant)init( "53"b3) /* $ (BCD). */; dcl bcd_eof bit(4)static int options(constant)init("1111"b); dcl bcd_media_code bit (4) unaligned int static init ("0010"b) /* media code 2 - BCD card */; dcl plain_bcd_media_code bit (4) unal int static init ("0000"b) /* media code 0 - BCD variable length record */; dcl pten (0:5) int static fixed bin(24)init (1, 10, 100, 1000, 10000, 100000); /* TRANSLATION TABLES FOR CONVERSION FROM-TO RAW CARD IMAGES */ /* BCD characters, in same order as their corresponding card punch codes in bin_table, below */ dcl bcd_table (0:63) bit (6) aligned internal static init ( "010000"b, /* " " */ "001001"b, /* "9" */ "001000"b, /* "8" */ "000111"b, /* "7" */ "001111"b, /* "?" */ "000110"b, /* "6" */ "001110"b, /* ">" */ "000101"b, /* "5" */ "001101"b, /* ":" */ "000100"b, /* "4" */ "001100"b, /* "@" */ "000011"b, /* "3" */ "001011"b, /* "#" */ "000010"b, /* "2" */ "001010"b, /* "[" */ "000001"b, /* "1" */ "000000"b, /* "0" */ "111001"b, /* "z" */ "111000"b, /* "y" */ "110111"b, /* "x" */ "111111"b, /* "!" */ "110110"b, /* "w" */ "111110"b, /* """ */ "110101"b, /* "v" */ "111101"b, /* "=" */ "110100"b, /* "u" */ "111100"b, /* "%" */ "110011"b, /* "t" */ "111011"b, /* "," */ "110010"b, /* "s" */ "111010"b, /* "<-" */ "110001"b, /* "/" */ "101010"b, /* "-" */ "101001"b, /* "r" */ "101000"b, /* "q" */ "100111"b, /* "p" */ "101111"b, /* "'" */ "100110"b, /* "o" */ "101110"b, /* ";" */ "100101"b, /* "n" */ "101101"b, /* ")" */ "100100"b, /* "m" */ "101100"b, /* "*" */ "100011"b, /* "l" */ "101011"b, /* "$" */ "100010"b, /* "k" */ "100001"b, /* "j" */ "100000"b, /* "|" */ "011010"b, /* "&" */ "011001"b, /* "i" */ "011000"b, /* "h" */ "010111"b, /* "g" */ "011111"b, /* "\" */ "010110"b, /* "f" */ "011110"b, /* "<" */ "010101"b, /* "e" */ "011101"b, /* "(" */ "010100"b, /* "d" */ "011100"b, /* "]" */ "010011"b, /* "c" */ "011011"b, /* "." */ "010010"b, /* "b" */ "010001"b, /* "a" */ "110000"b /* "+" */ ); /* card punch codes for the GEBCD characters, arranged in ascending order of their numeric values, to allow lookup of INPUT raw card column contents, using a half-interval (binary) search */ dcl bin_table (0: 63) bit (12) aligned internal static init ( "000000000000"b, /* " " */ "000000000001"b, /* "9" */ "000000000010"b, /* "8" */ "000000000100"b, /* "7" */ "000000000110"b, /* "?" */ "000000001000"b, /* "6" */ "000000001010"b, /* ">" */ "000000010000"b, /* "5" */ "000000010010"b, /* ":" */ "000000100000"b, /* "4" */ "000000100010"b, /* "@" */ "000001000000"b, /* "3" */ "000001000010"b, /* "#" */ "000010000000"b, /* "2" */ "000010000010"b, /* "[" */ "000100000000"b, /* "1" */ "001000000000"b, /* "0" */ "001000000001"b, /* "z" */ "001000000010"b, /* "y" */ "001000000100"b, /* "x" */ "001000000110"b, /* "!" */ "001000001000"b, /* "w" */ "001000001010"b, /* """ */ "001000010000"b, /* "v" */ "001000010010"b, /* "=" */ "001000100000"b, /* "u" */ "001000100010"b, /* "%" */ "001001000000"b, /* "t" */ "001001000010"b, /* "," */ "001010000000"b, /* "s" */ "001010000010"b, /* "<-" */ "001100000000"b, /* "/" */ "010000000000"b, /* "-" */ "010000000001"b, /* "r" */ "010000000010"b, /* "q" */ "010000000100"b, /* "p" */ "010000000110"b, /* "'" */ "010000001000"b, /* "o" */ "010000001010"b, /* ";" */ "010000010000"b, /* "n" */ "010000010010"b, /* ")" */ "010000100000"b, /* "m" */ "010000100010"b, /* "*" */ "010001000000"b, /* "l" */ "010001000010"b, /* "$" */ "010010000000"b, /* "k" */ "010100000000"b, /* "j" */ "011000000000"b, /* "|" */ "100000000000"b, /* "&" */ "100000000001"b, /* "i" */ "100000000010"b, /* "h" */ "100000000100"b, /* "g" */ "100000000110"b, /* "\" */ "100000001000"b, /* "f" */ "100000001010"b, /* "<" */ "100000010000"b, /* "e" */ "100000010010"b, /* "(" */ "100000100000"b, /* "d" */ "100000100010"b, /* "]" */ "100001000000"b, /* "c" */ "100001000010"b, /* "." */ "100010000000"b, /* "b" */ "100100000000"b, /* "a" */ "101000000000"b /* "+" */ ); /* card punch codes for the GEBCD characters, arranged in order of the numeric values of their corresponding 6-bit BCD codes, to allow OUTPUT raw card column contents to be obtained using the BCD character as an index into the table */ dcl raw_table (0:63) bit (12) aligned int static init ( "001000000000"b, /* 0 */ "000100000000"b, /* 1 */ "000010000000"b, /* 2 */ "000001000000"b, /* 3 */ "000000100000"b, /* 4 */ "000000010000"b, /* 5 */ "000000001000"b, /* 6 */ "000000000100"b, /* 7 */ "000000000010"b, /* 8 */ "000000000001"b, /* 9 */ "000010000010"b, /* [ */ "000001000010"b, /* # */ "000000100010"b, /* @ */ "000000010010"b, /* : */ "000000001010"b, /* > */ "000000000110"b, /* ? */ "000000000000"b, /* blank */ "100100000000"b, /* A */ "100010000000"b, /* B */ "100001000000"b, /* C */ "100000100000"b, /* D */ "100000010000"b, /* E */ "100000001000"b, /* F */ "100000000100"b, /* G */ "100000000010"b, /* H */ "100000000001"b, /* I */ "100000000000"b, /* & */ "100001000010"b, /* . */ "100000100010"b, /* ] */ "100000010010"b, /* ( */ "100000001010"b, /* < */ "100000000110"b, /* \ */ "011000000000"b, /* | */ "010100000000"b, /* J */ "010010000000"b, /* K */ "010001000000"b, /* L */ "010000100000"b, /* M */ "010000010000"b, /* N */ "010000001000"b, /* O */ "010000000100"b, /* P */ "010000000010"b, /* Q */ "010000000001"b, /* R */ "010000000000"b, /* - */ "010001000010"b, /* $ */ "010000100010"b, /* * */ "010000010010"b, /* ) */ "010000001010"b, /* ; */ "010000000110"b, /* ' */ "101000000000"b, /* + */ "001100000000"b, /* / */ "001010000000"b, /* S */ "001001000000"b, /* T */ "001000100000"b, /* U */ "001000010000"b, /* V */ "001000001000"b, /* W */ "001000000100"b, /* X */ "001000000010"b, /* Y */ "001000000001"b, /* Z */ "001010000010"b, /* <- (left arrow) */ "001001000010"b, /* , */ "001000100010"b, /* % */ "001000010010"b, /* = */ "001000001010"b, /* " */ "001000000110"b /* ! */ ); %include query_info; %include gcos_xlate_bcd_ascii_; %page; /* P R O C E D U R E */ /* Initialization */ input_ptr = a_input_ptr; /* copy argument structure pointers to */ output_ptr = a_output_ptr; /* local storage, for better accessing code */ nondollar_tab_index = -1; /* initialize to "no value assigned" code */ query_info.yes_or_no_sw = "1"b; /* we ask only yes or no questions */ on condition (cleanup) call cleanup_proc; unspec (write_buffer) = ""b; /* zero the output buffer, to avoid garbage at the ends of short records */ if output.name_files then do; /* set suffix for output file names */ if output.format = ascii then next_output_suffix = ".ascii"; else if output.medium = raw then next_output_suffix = ".raw"; else if output.comdk then next_output_suffix = ".comdk"; else next_output_suffix = ".gcos"; end; do io_ptr = input_ptr, output_ptr; if io.medium = tape then if io_tape.label = "-nl" | io_tape.label = "-no_label" | io_tape.label = "-no_labels" then no_label (io.sw) = "1"b; end; input_block_ptr = addr (input_block); /* get pointers to work areas */ ascii_line_ptr = addr (ascii_line); gcos_work_area_ptr = addr (gcos_work_area); bcd_work_area_ptr = addr (bcd_work_area); raw_card_ptr = addr (raw_card); comdk_work_area_ptr = addr (comdk_work_area); write_buffer_ptr = addr (write_buffer); /* do not get ptr to ext static tabstop table now. wait to see if it is needed. do it in open_input. */ /* Processing (What there is of it...) */ if input.set = single_file then call process_single_file; else if input.set = imcv then call process_imcv; else if input.set = library then call process_library_file; else if input.set = multiple_files then call process_multiple_files; else call fatal_error (1); /* error_table_$badcall */ /* Just return normally, no fuss, no bother. */ a_code = code; return; /* Whoops! Something went bust, so gotta clean up first. */ cleanup_and_return: call cleanup_proc; a_code = code; return; /* END OF MAIN PROCEDURE. INTERNAL PROCEDURES AND DEBUGGING ENTRIES FOLLOW */ %page; bcd_string: proc (in_string, in_count) returns (bit (*) aligned); dcl in_string char (*); dcl ret_bits bit (ret_len) aligned based (addr (work_bits)); dcl work_bits bit (72) aligned; dcl work_chars char (12) aligned; dcl (digit, i, in_count, in_no, indx, num, ret_len, xnum) fixed bin(24); work_chars = in_string; /* align the input string */ call gcos_cv_ascii_gebcd_check_ (addr (work_chars), in_count, addr (work_bits), code); if code ^= 0 then do; call ioa_ ("Error in character ^d of : ~a", code, in_string); code = 0; /* code is position of bad char - not error table code */ call fatal_error (2); /* bad string - can't convert to BCD */ end; return_string: /* come here from bcd_string_bin entry point */ ret_len = in_count*6; /* compute length in bits of the BCD string */ return (ret_bits); bcd_string_bin: entry (in_no, in_count) returns (bit (*) aligned); indx = 1; num = in_no; do i = in_count-1 by -1 to 0; /* convert digits left to right */ xnum = mod (num, pten (i)); /* get digits to right of the one we want */ /* pten(i) contains 10**i */ digit = divide (num-xnum, pten (i), 17, 0); /* get digit we want */ if indx = 1 then /* if first time around loop */ if digit > 9 then /* check for number too large for field */ call fatal_error (3); /* number to large for BCD field */ substr (work_bits, indx, 6) = bit (fixed (digit, 6)); /* make BCD char from digit */ indx = indx + 6; /* move to next digit in receiving field */ num = xnum; /* work with digits to right of one just converted */ end; goto return_string; /* go return the string when done converting */ end bcd_string; %page; canonicalizer: proc (input_string_ptr, initial_input_characters, output_card_ptr, initial_output_columns); /* NOTE: a copy of this internal procedure exists also in gcos_gein_pass1_. The initialization is different, but the canonicalization is the same. Any changes should be made to both copies, if appropriate. */ dcl initial_input_characters fixed bin(24); dcl input_string char (initial_input_characters) based (input_string_ptr); dcl input_string_ptr ptr; dcl initial_output_columns fixed bin(24); dcl output_card char (initial_output_columns) based (output_card_ptr); dcl output_card_ptr ptr; dcl ( next_input_character, next_output_column, next_backspace, /* relative to next_input_character */ next_tab, /* relative to next_input_character */ remaining_input_characters, remaining_output_columns, character_count, blank_count, first_blank, i, backspace_count ) fixed bin(24); dcl (more_backspaces, more_tabs) bit (1) aligned; dcl tabstop (10) fixed bin(24)based (tab_ptr) /* tabstops currently in use */; dcl tab_ptr ptr /* pointer to tabs currently in use */; /* INITIALIZE */ next_input_character, next_output_column = 1; remaining_input_characters = initial_input_characters; remaining_output_columns = initial_output_columns; more_backspaces, more_tabs = "1"b; /* we want to look for backspaces and tabs at the start */ if substr (input_string, remaining_input_characters, 1) = ascii_newline /* if last char is a newline */ then remaining_input_characters = remaining_input_characters - 1; /* then get rid of it */ if substr (input_string, 1, 1) = "$" then set_dollar_tabs: do; tab_ptr = addr (tab (0)); /* get pointer to dollar tabs */ end set_dollar_tabs; else /* not a dollar card */ set_nondollar_tabs: do; if input.tabs_given then /* if user supplied nondollar tabstops */ tab_ptr = addr (input.tabstops); /* get pointer to user-supplied tabstops */ else do; /* otherwise use the ones we looked up */ if nondollar_tab_index = -1 then call fatal_error (4); /* check for case of: 1) not a complete job, so no activity card to determine tabs from, and 2) no tabs given by user, resulting in no tabstops to use */ else tab_ptr = addr (tab (nondollar_tab_index)); /* get pointer to tabs for this activity */ end; end set_nondollar_tabs; /* MAIN LOOP. FILL UP OUTPUT CARD */ canon_loop: do while (remaining_output_columns > 0); /* keep going while there is any room on output card */ if more_backspaces then /* if there MIGHT be more backspaces */ find_next_backspace: do; /* then look for one */ next_backspace = index (substr (input_string, next_input_character, remaining_input_characters), ascii_backspace); if next_backspace = 0 then more_backspaces = "0"b; /* if none found, remember not to look again */ end find_next_backspace; if more_tabs then /* if there MIGHT be more tabs */ find_next_tab: do; /* then look for one */ next_tab = index (substr (input_string, next_input_character, remaining_input_characters), ascii_tab); if next_tab = 0 then more_tabs = "0"b; /* if none found, remember not to look again */ end find_next_tab; if more_backspaces then /* if we found a backspace */ look_at_backspace: do; /* see if it is in a legal position */ /* maybe sometime allow backspaces to be in places other than immediately following tabs, but for now, it's an error */ if ^more_tabs | next_backspace ^= next_tab+1 then call fatal_error (5); end look_at_backspace; if more_tabs then /* if we found a tab, we want to move the characters before it */ process_tab: do; /* to the output card, and fill with blanks to next tab stop */ character_count = min ( /* compute the number of characters */ next_tab - 1, /* before the tab */ remaining_output_columns); /* but not more than there's room for on output card */ first_blank = next_output_column + character_count; do i = 1 to hbound (tabstop, 1) /* look for a tabstop */ while (tabstop (i) <= first_blank); /* that's past the characters */ /* if it's in the column immediately after the characters, then go to the next one, the way a typewriter will */ end; if i <= hbound (tabstop, 1) then /* if we found one */ blank_count = min ( /* compute the number of blanks */ tabstop (i) - first_blank, /* needed to get there */ remaining_output_columns); /* but not more than there's room for on output card */ else /* if no more tabstops, replace tab with one blank */ blank_count = min (1, remaining_output_columns); end process_tab; else no_more_tabs: do; /* if there are no more tabs, we want to move the rest of the input characters to the output card, and fill the rest of it with blanks */ character_count = min ( /* compute rest of characters to move */ remaining_input_characters, /* all the rest, since no more tabs */ remaining_output_columns); /* but not more than there's room for on output card */ blank_count = max (0, /* compute blanks needed to fill rest of card */ remaining_output_columns - remaining_input_characters); end no_more_tabs; if character_count > 0 then /* move characters to output card, if there are any */ move_characters: do; substr (output_card, next_output_column, character_count) = substr (input_string, next_input_character, character_count); remaining_input_characters = remaining_input_characters - character_count; next_input_character = next_input_character + character_count; remaining_output_columns = remaining_output_columns - character_count; next_output_column = next_output_column + character_count; end move_characters; if blank_count > 0 then /* fill with blanks, if any */ move_blanks: do; substr (output_card, next_output_column, blank_count) = ""; remaining_output_columns = remaining_output_columns - blank_count; next_output_column = next_output_column + blank_count; end move_blanks; if more_tabs then do; /* move past tab in input string */ remaining_input_characters = remaining_input_characters - 1; next_input_character = next_input_character + 1; end; if more_backspaces then backspace: do; /* if we found a backspace, we will: 1) see if there's more than one of them, and 2) move back that many columns, deleting whatever is there, (probably only blanks ) */ do i = next_input_character to initial_input_characters while (substr (input_string, i, 1) = ascii_backspace); end; character_count = i - next_input_character; /* count backspace characters */ backspace_count = min (character_count, /* count columns to backspace */ next_output_column - 1); /* but don't backspace past beginning of card */ /* skip over input backspace characters */ remaining_input_characters = remaining_input_characters - character_count; next_input_character = next_input_character + character_count; /* backspace on output card */ remaining_output_columns = remaining_output_columns + backspace_count; next_output_column = next_output_column - backspace_count; end backspace; end canon_loop; /* WE FALL THRU HERE WHEN remaining_output_columns BECOMES ZERO */ if remaining_input_characters > 0 then /* if input left over */ if ^input.truncate_ascii then /* and user did not say -truncate */ call fatal_error (6); /* complain */ if ^input.tabs_given then /* if user did not supply the nondollar tab stops */ if substr (output_card, 1, 1) = "$" then look_up_tabstops: do; /* we will determine them from the type of activity */ card_type = substr (output_card, 8, 8); /* get card type */ do i = 1 to gcos_control_tables_$tablelen /* look it up in cardtable */ while (card_type ^= gcos_control_tables_$cardtable (i)); end; /* fall thru if found, or end of table */ /* don't really care which */ if i >= gcos_control_tables_$exc_offset then /* if its not before the first activity card */ if i < gcos_control_tables_$nonact then /* and not after the last one */ act_card: do; /* then it must be one */ act_ptr = addr (gcos_control_tables_$activity_table); /* pointer to data table */ act_ptr = addrel (act_ptr, (i - gcos_control_tables_$exc_offset)*3); /* pointer to data for this activity */ nondollar_tab_index = act_table_entry.tab_index; /* index to tabs for this activity */ end act_card; end look_up_tabstops; return; end canonicalizer; %page; check_bin_cards: proc; if bin_cards_skipped > 0 then do; call ioa_ ("^a: ^d non-bcd-card records skipped just before:^/^a", me, bin_cards_skipped, ascii_card); bin_cards_skipped = 0; end; return; end check_bin_cards; %page; check_for_eod: proc returns (bit (1)); /* check for end of library deck */ dcl i fixed bin(24); if eof then goto eod; if output.format = ascii | output.gcos_ascii then do; if substr (ascii_card, 1, 1) = "$" then do; /* a dollar card can indicate end of deck */ if substr (ascii_card, 1, 15) = "$ dkend " then goto eod; do i = 2 to 15; /* check for missing end card - this might be a GMAP, 355MAP, or OBJECT card */ if substr (ascii_card, 1, 15) = ascii_search_key (i) then goto noend; end; goto eod; /* NOTE - we are assuming that any other dollar card also ends the library deck, without starting a new one */ end; end; else do; /* check it in BCD */ if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do; if substr (string (gcos_record), 79, 36) = bcd_dkend then goto eod; do i = 2 to 15; if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then goto noend; end; goto eod; /* see NOTE above */ end; end; return ("0"b); noend: no_end_card = "1"b; eod: return ("1"b); end check_for_eod; %page; check_for_eoj: proc returns (bit (1)); if eof then return ("1"b); if output.format = ascii | output.gcos_ascii then do; /* check it in ascii */ if substr (ascii_card, 1, 15) = ascii_search_key (1) then do; /* $ snumb */ no_end_card = "1"b; return ("1"b); end; end; else do; /* check it in BCD */ if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do; if substr (string (gcos_record), 79, 36) = bcd_search_key (1) then do; /* SNUMB */ no_end_card = "1"b; return ("1"b); end; end; /* end dollar card */ end; /* end check it in BCD */ return ("0"b); end check_for_eoj; %page; cleanup_proc: proc; dcl i fixed bin(24); /* Detach file streams. Leave tapes for caller to detach or retain. */ do i = 1 to 2; call ios_$detach ((file_stream (i)), "", "", status); end; return; end cleanup_proc; %page; close_comdk_output: proc; k_card.char (comdk_out_index) = "111110"b; /* 76 octal - end of comdk */ call write_comdk_card; /* write out the last card */ output_comdk_open = "0"b; /* remember that comdk is no longer open */ return; end close_comdk_output; %page; close_input: proc; io_ptr = input_ptr; /* in case of error, to indicate which file */ if input.medium = tape then do; if found_last_line then /* if we stopped because of -last or -count */ if ^file_eof then do; /* and the last block has not been read */ call ios_$order (output_stream_name, "forward_file", null, status); if code ^= 0 then call interpret_tape_status; if ^file_eof then call fatal_error (61); end; if ^no_label (io.sw) then do; /* if labeled tape, read trailer label */ label_ptr = input_block_ptr; file_eof = "0"b; read_trailer: call read_block; /* read the trailer label */ if file_eof then do; if rcw_eof then do; /* if we had not yet read the eof tape mark */ rcw_eof = "0"b; /* we just did */ goto read_trailer; /* so go try to read trailer again */ end; call fatal_error (7); /* eof when trailer label expected */ end; /* end file_eof do group */ if input_block_len ^= 14 then call fatal_error (8); /* data record when trailer label expected */ if trailer_label.eof ^= bcd_beofbb then /* /bEOF/b/b */ if trailer_label.eof ^= bcd_beorbb then /* /bEOR/b/b */ call fatal_error (9); /* bad trailer label format */ input_block_count = input_block_count - 2; /* deduct the eof and the trailer label */ if fixed (trailer_label.block_count) ^= input_block_count then if ^input.brief then call ioa_ ("^a: warning: block count in trailer label (^d) ^= blocks read (^d).", me, fixed (trailer_label.block_count), input_block_count); call read_block; /* read the eof mark after the trailer label */ if ^file_eof then call fatal_error (10); /* expected eof after trailer not found */ end; /* end of labeled tape do group */ else do; /* unlabeled tape */ if rcw_eof then do; /* if we have not yet read the eof tape mark */ file_eof, rcw_eof = "0"b; /* turn off switches */ call read_block; /* and read it now */ if ^file_eof then /* if eof tape mark not there */ call fatal_error (60); /* expected eof after unlabeled tape file missing */ end; end; end; else do; call ios_$detach (input_stream_name, "", "", status); if code ^= 0 then call fatal_error (11); end; tape_status_message = ""; return; end close_input; %page; close_output: proc; io_ptr = output_ptr; /* in case of error, to indicate which file */ if output_comdk_open then /* if we were writing a comdk */ call close_comdk_output; /* put out the last card */ if output.medium ^= raw /* if an ordinary GCOS file */ then if output.format ^= ascii then if output.format ^= blocks then if output.medium ^= tape /* and not a tape file, */ then call write_gcos_record (addr (eof_rcw), 1); /* then write eof record */ if output.medium = tape then do; call write_tape_eof; /* write eof and check error code */ if ^no_label (io.sw) then do; /* if labeled tape, build and write trailer label */ label_ptr = write_buffer_ptr; /* build it in the write buffer */ unspec (trailer_label) = ""b; /* clear it first */ trailer_label.eof = bcd_beofbb; /* /bEOF/b/b */ trailer_label.block_count = bit (fixed (output_block_count, 36)); trailer_label.next_reel = bcd_b6; /* six bcd blanks */ call write_tape_label; /* write label and eof, checking error codes */ /* build partial label */ word_string_len = 14; /* length of label */ /* use word_string overlay because structure assignment compiles into element-by-element assignment */ addr (header_label) -> word_string = addr (saved_header_label) -> word_string; /* partial label is header label, */ unspec (partial_label.zero_words) = ""b; /* with words 5-10 zeroed */ call write_tape_label; /* write it and an eof, checking error codes */ /* now, in case there is more to write on the tape, backspace to beginning of partial label, so it will be overwritten if there is more */ do i = 1 to 2; file_eof = "0"b; call ios_$order (output_stream_name, "backspace_file", null, status); if code ^= 0 then call interpret_tape_status; if ^file_eof then /* should get eof status from backspace file */ call fatal_error (12); /* error while backspacing over partial label */ end; /* read the eof before the partial label */ call ios_$read (output_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status); file_eof = "0"b; if code ^= 0 then call interpret_tape_status; if ^file_eof then call fatal_error (13); /* while positioning to partial label */ end; /* end of labeled tape do group */ end; else do; call ios_$detach (output_stream_name, "", "", status); if code ^= 0 then call fatal_error (14); end; tape_status_message = ""; return; end close_output; %page; copy_jobs: proc; do list_index = 1 to input.list_count while (^eof); call find_list_item; if ^eof then do; if output.set = multiple_files then call open_next_output; call copy_one_job; if output.set = multiple_files then call close_output; end; end; end copy_jobs; %page; copy_one_deck: proc; /* procedure to copy one library deck */ dcl first_card bit (1) aligned; eof, eoj = "0"b; first_card = "1"b; do while (^eoj); if ^first_card then eoj = check_for_eod (); /* see if this card is an end of deck indicator */ else first_card = "0"b; if ^eof then /* if there is a card there */ if ^no_end_card then /* and its not the first card of the next deck, write it */ call write_output; /* first card was read by find_list_item */ if ^eoj then call read_and_convert_input; end; end copy_one_deck; %page; copy_one_file: proc; eof = "0"b; do while (^eof); call read_and_convert_input; if ^eof then call write_output; end; return; end copy_one_file; %page; copy_one_job: proc; dcl first_card bit (1) aligned; eof, eoj = "0"b; first_card = "1"b; do while (^eoj); if ^first_card then eoj = check_for_eoj (); else first_card = "0"b; if ^eof then /* if there is a card there */ if ^no_end_card then /* and its not the first card of the next job, write it */ call write_output; /* first card ( $ snumb) was read by find_list_item */ if ^eoj then call read_and_convert_input; end; end copy_one_job; %page; cv_bin_to_bcd: proc (input_ptr, output_ptr); dcl ( direction, /* direction of half-interval search */ i, /* loop index */ interval, /* increment for half-interval search */ j, /* loop index */ k, search_index /* index into binary table */ ) fixed bin(24)aligned; dcl ( input_ptr, /* pointer to binary data (argument) */ output_ptr /* pointer to bcd output (argument) */ ) ptr aligned; dcl ( bad_card, /* turned on if a bad char is found */ bin_char_not_found /* ON until bin_table search is successful */ ) bit (1) aligned; dcl ( divide ) builtin; dcl 1 bcd_chars aligned based (output_ptr), /* bcd output structure */ 2 bcd_char (0:79) bit (6) unaligned; dcl bin_char (0:79) bit (12) unaligned based (input_ptr) /* mask for looking at binary input */; dcl this_char bit (12) aligned /* copy char to aligned string to avoid hardware bug in cmpb */; /* perform conversion */ bad_card = "0"b; cv_card: do i = 0 to 79; /* convert 80 characters */ this_char = bin_char (i); /* copy to aligned string to avoid hardware bug */ if this_char = "0"b /* make quick check for blank */ then bcd_char (i) = bcd_blank; else /* not binary blank */ translate_char: do; direction = 1; /* set up half-interval search */ interval = 32; search_index = 0; bin_char_not_found = "1"b; search_table: do j = 1 to 6 while (bin_char_not_found); search_index = search_index + direction*interval; /* compute index into binary table */ if this_char = bin_table (search_index) /* match found */ then do; bcd_char (i) = bcd_table (search_index); /* set bcd character */ bin_char_not_found = "0"b; end; else /* not a match */ do; if this_char > bin_table (search_index) /* set direction of search increment */ then direction = 1; else direction = -1; interval = divide (interval, 2, 17, 0); /* set search increment magnitude */ end; end search_table; if bin_char_not_found then /* no match found */ illegal_char: do; /* not a GEBCD card code */ bcd_char (i) = bcd_blank; /* leave column blank */ if ^bad_card then do; /* if first bad char on card */ bad_card = "1"b; /* remembr it */ raw_cards_bad = raw_cards_bad + 1; /* count cards */ end; raw_chars_bad = raw_chars_bad + 1; /* count bad characters */ if ^input.brief then do; /* tell user what's wrong, unless told not to */ punches = ""; /* clear the string first */ do k = 1 to 12; /* then tell user which rows were punched */ if substr (this_char, k, 1) then /* if this row punched */ punches = punches || punch (k); /* add row number to string to be printed */ end; substr (punches, 1, 1) = " "; /* get rid of leading "-" */ call ioa_ ("^a: raw card ^d, column ^d - not GEBCD punch:^a^/Processing continues.", me, input_block_count, i+1, punches); end; end illegal_char; end translate_char; end cv_card; return; end cv_bin_to_bcd; %page; fatal_error: proc (error_code); dcl error_code fixed bin(24); /* identifies the place where the error occurred. Each call has a different number, even if the message is the same. The first 58 are in order in the program. Those above 58 were added later and are out of order. */ dcl fixed_in_db bit (1) aligned init ("0"b); dcl max_error_code fixed bin(24)init (61) /* next available code is 62 */; dcl (err_msg, msg2) char (200) varying init (""); if ^input.com_err then goto set_code; /* print only if caller said to */ if error_code < 1 | error_code > max_error_code then do; err_msg = "Program error - bad internal error code: ^s^d"; err_num = error_code; goto call_com_err; end; goto err (error_code); err (1): err (44): err (55): err_msg = "Invalid input arguments."; goto call_com_err; err (2): err_msg = "ASCII character without BCD equivalent in the above value from the command line."; goto call_com_err; err (3): err_msg = "Program error - converting numeric to BCD for tape label."; goto call_com_err; err (4): err_msg = "No activity card before data cards in ^a. Must give either -tabs or -no_canonicalize."; goto call_com_err; err (5): err_msg = "Backspace not immediately preceeded by tab, in ^a, line ^d"; goto set_line_no; err (6): err (41): err_msg = "Line > 80 characters and -truncate not given: ^a, line ^d."; goto set_line_no; err (7): err_msg = "File mark where trailer label expected, on ^a ^s^a"; goto call_com_err; err (8): err_msg = "Data record where trailer label expected, on ^a ^s^a"; goto call_com_err; err (9): err_msg = "Bad trailer label on ^a ^s^a"; goto call_com_err; err (10): err_msg = "Expected filemark after trailer not found on ^a ^s^a"; goto call_com_err; err (11): err (14): err_msg = "From ios_$detach ^a"; /* detaching input or output file - not tape */ goto call_com_err; err (12): err_msg = "While backspacing over partial label on ^a ^s^a ^a"; goto call_com_err; err (13): err_msg = "While positioning to partial label on ^a ^s^a ^a"; goto call_com_err; err (15): err_msg = "End of file in middle of comdk: ^a, BCD card ^d"; goto set_line_no; err (16): err_msg = "Non-comdk card in middle of comdk: ^a, BCD card ^d"; goto set_line_no; err (17): err (22): err_msg = "Comdk sequence number error: ^a, BCD card ^d"; goto set_line_no; err (18): err_msg = "Null comdk card: ^a, BCD card ^d"; goto set_line_no; err (19): err (23): err_msg = "Bad comdk field length: ^a, BCD card ^d"; goto set_line_no; err (20): err_msg = "Bad comdk string length: ^a, BCD card ^d"; goto set_line_no; err (21): err_msg = "Comdk field > remainder of BCD card: ^a, BCD card ^d"; goto set_line_no; err (24): err (27): err_msg = "From ios_$attach ^a"; goto call_com_err; err (25): err (28): err_msg = "From ios_$setsize ^a"; goto call_com_err; err (26): err_msg = "From ios_$setdelim ^a"; goto call_com_err; err (29): err_msg = "From ios_$tell last ^a"; goto call_com_err; err (30): err_msg = "From ios_$seek last first ^a"; goto call_com_err; err (31): err_msg = "Program error - unable to append to existing gcos file ^a"; goto call_com_err; err (32): err_msg = "While rewinding ^a ^s^a ^a"; goto call_com_err; err (33): err_msg = "Unexpected filemark read while positioning ^a (file number ^d) ^a"; goto call_com_err; err (34): err_msg = "While positioning ^a (file number ^d) ^a ^a"; goto call_com_err; err (35): err_msg = "Partial label (end of information) read while positioning ^a ^s^a"; goto call_com_err; err (36): err_msg = "Expected header label not found, while positioning ^a ^s^a"; goto call_com_err; err (37): err_msg = "End of reel label (file continued on another reel) read while positioning ^a ^s^a"; goto call_com_err; err (38): err_msg = "Expected trailer label not found, while positioning ^a ^s^a"; goto call_com_err; err (39): err_msg = "Program error while positioning ^a ^s^a"; goto call_com_err; err (40): err_msg = "No newline for over 1280 characters - not an ASCII file: ^a, line ^d"; goto set_line_no; err (42): err_msg = "ASCII character without BCD equivalent: ^/^a, line ^d"; goto set_line_no; err (43): err_msg = "BCD card record > 18 words: ^a, card ^d"; goto set_line_no; err (45): err (46): err_msg = "From ios_$read:"; goto set_block_no; err (47): err_msg = "Read error - wrong number of elements read:"; goto set_block_no; err (48): err_msg = "Read error - zero length block:"; goto set_block_no; err (49): err_msg = "Bad length in block control word:"; goto set_block_no; err (50): err_msg = "Error while deblocking - bad block or record control word:"; goto set_block_no; err (51): err (52): err_msg = "From ios_$write"; goto set_out_block_no; err (53): err_msg = "Write error - wrong number of elements written:"; goto set_out_block_no; err (54): err_msg = "Program error - attempt to write GCOS record > 319 words into"; goto set_out_block_no; err (56): err_msg = "Program error - bad record length or media code for raw output file: ^a, card ^d"; err_num = output_block_count; goto call_com_err; err (57): err_msg = "While writing filemark on ^a ^s^a ^a"; goto call_com_err; err (58): err_msg = "While writing label on ^a ^s^a ^a"; goto call_com_err; err (59): err_msg = "Program error - while encoding output comdk."; goto call_com_err; err (60): err_msg = "Expected filemark after last block of unlabeled tape file not found on ^a^s^a"; goto call_com_err; err (61): err_msg = "While skipping to trailer label."; goto set_block_no; set_block_no: err_num = input_block_count; goto set_block_msg; set_out_block_no: err_num = output_block_count; goto set_block_msg; set_block_msg: err_msg = err_msg || " ^a, block ^d ^s^a"; goto call_com_err; set_line_no: err_num = file_record_count; if input.set = library then msg2 = " edit name = "; else if input.set = imcv then msg2 = " snumb = "; else goto call_com_err; msg2 = msg2 || item_name; err_msg = err_msg || " ^a"; /* add control to print msg2 */ call_com_err: call com_err_ (code, me, err_msg, io.file_name, err_num, msg2, tape_status_message); if input.debug then do; call ioa_ ("error number gcu_^d", error_code); call ioa_ ("CALLING DB"); call db; if fixed_in_db then return; end; set_code: if code = 0 then code = error_table_$action_not_performed; goto cleanup_and_return; end fatal_error; %page; find_list_item: proc; /* procedure to find the next $ GMAP, $ 355MAP, $ OBJECT $ FORTRAN, $COBOL, or $ SNUMB card that has one of the selected item names on it */ dcl i fixed bin(24); dcl saved_comdk_sw bit (1) aligned; saved_comdk_sw = input.comdk; /* save value of comdk switch */ input.comdk = "0"b; /* and turn it off, to save the cost of uncoming decks that are not being copied */ just_looking = "1"b; /* suppress the "bin cards skipped" messages */ if no_end_card then do; /* if no end card in previous item */ no_end_card = "0"b; /* we already have one of the key cards in the buffer */ if output.format = ascii | output.gcos_ascii then goto have_aci; /* so go look at it */ else goto have_bcd; /* in ascii or bcd, as the case may be */ end; find_item_read: call read_and_convert_input; /* read next record */ if eof then do; input.comdk = saved_comdk_sw; /* possible multiple file input */ just_looking = "0"b; /* so clean up */ if looking_for_first_line then /* if we never found the -first card */ if saved_comdk_sw then /* and we were not uncompressing */ call ioa_ ("^a: Warning: comdks were NOT being uncompressed during the search for card ^d, resulting in a lower card count than you expected", me, input.first_line); return; end; if output.format = ascii | output.gcos_ascii then do; /* ASCII card */ if substr (ascii_card, 1, 1) ^= "$" then /* if not a dollar card */ goto find_item_read; /* go read the next one */ do i = first_key to last_key; /* these indices select either: 1) $ SNUMB card, or 2) $ GMAP, $ 355MAP, or $ OBJECT card */ if substr (ascii_card, 1, 15) = ascii_search_key (i) then /* if this is one of those cards */ goto have_aci; /* go get the name off it */ end; /* if we fall thru here, it is not one of they key cards */ goto find_item_read; /* so go read the next card */ have_aci: item_name = substr (ascii_card, item_index, item_length); /* pick up edit name or snumb */ end; else if gcos_record_ptr -> rcw.media_code = bcd_media_code then do; /* BCD card */ if gcos_record_ptr -> bcd_card.column (1) ^= bcd_dollar then /* if not dollar card */ goto find_item_read; /* go read next one */ do i = first_key to last_key; /* indices pick out either: 1) $ SNUMB card, or 2) $ GMAP, $ 355MAP, or $ OBJECT */ if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then /* if this is one of them */ goto have_bcd; /* go get the name off it */ end; /* if we fall thru, it is not one of the key cards */ goto find_item_read; /* so go read the next one */ have_bcd: item_name = ""; /* blank out ascii item name */ do i = 0 to item_length-1; /* and convert BCD item name to ASCII */ substr (item_name, i+1, 1) = xlate (fixed (gcos_record_ptr -> bcd_card.column (item_index+i))); end; end; else goto find_item_read; /* binary card. read next one */ /* if we fall thru here, we have a key card, and we have gotten the item name from it */ if item_length = 5 then do; /* if snumb card, check for short snumb */ i = index (item_name, ","); /* look for comma */ if i ^= 0 then /* if there was one */ substr (item_name, i) = ""; /* blank out it, and whatever follows */ end; if input.all then goto print_being_copied; /* if user said -all, we copy all input items */ do i = 1 to input.list_count /* if not, look up this name in the input list */ /* comparing only the first N characters of the item name */ /* with the input list items */ while (input_list (i).names ^= substr (item_name, 1, input.list_name_size)); end; /* where N is the length of the input list items */ /* This is temporary until the command procedure and the input_list structure in the include file can be changed to allow variable length item names, longer than 4 characters (up to 8) */ if i = input.list_count + 1 then do; /* if not found */ if input.long then call ioa_ (item_name); goto find_item_read; /* keep reading */ end; input_list (i).used = "1"b; /* keep track of which ones we found, for later error message printing */ /* It might be good to add code to check for a name appearing more than once in the input file, and warn the user, and ask if it should be copied again */ print_being_copied: if input.long | output.long then call ioa_ ("^a being copied", item_name); input.comdk = saved_comdk_sw; just_looking = "0"b; return; /* we found one */ end find_list_item; %page; get_comdk: proc (record_ptr, record_len); dcl fb_temp fixed bin(24); dcl record_len fixed bin(24); dcl record_ptr ptr; record_len = 14; /* we will always return a bcd card */ record_ptr = bcd_work_area_ptr; /* in the work area reserved for us */ word_string_len = 14; /* move 14 words */ addrel (record_ptr, 1) -> word_string = /* into the work area */ addr (bcd_blank_card) -> word_string; /* initializing it to 80 bcd blanks */ bcd_col_index = 1; /* start filling in card at col 1 */ uncom_loop: if field_len = 0 then do; /* end of comdk card - read next one */ call read_record (comdk_card_ptr, fb_temp); if eof then call fatal_error (15); /* eof in middle of comdk */ if (fb_temp ^= 27 & fb_temp ^= 24) /* if not proper length */ | comdk_card.col1 ^= comdk_col_1 /* or not comdk code in col 1 */ then call fatal_error (16); /* non-comdk card in comdk */ fb_temp = fixed (comdk_card.seq_no); if fb_temp ^= prev_comdk_seq_no + 1 then call fatal_error (17); /* bad comdk sequence number */ prev_comdk_seq_no = fb_temp; field_len = fixed (comdk_card.char (1)); if field_len = 0 then call fatal_error (18); /* null comdk card */ comdk_char_index = 2; end; if field_len = 63 then do; /* end of bcd card */ field_len = fixed (comdk_card.char (comdk_char_index)); /* get next field length */ comdk_char_index = comdk_char_index + 1; if field_len = 62 then do; /* end of this comdk */ if comdk_error_count >0 then call ioa_ ("^d field length errors", comdk_error_count); if input.set = library then call ioa_ ("(in ^a)", item_name); input_comdk_open = "0"b; /* so don't come here next time */ end; return; end; if field_len > 55 then call fatal_error (19); /* bad comdk field length */ string_len = fixed (comdk_card.char (comdk_char_index)); /* this string length */ comdk_char_index = comdk_char_index + 1; if comdk_char_index + string_len > 132 then /* first char after string */ call fatal_error (20); /* comdk string runs off comdk card */ if bcd_col_index + field_len > 85 then do; if input.debug then do; comdk_error_count = comdk_error_count + 1; if ^input.brief then do; call ioa_ ("Illegal comdk: field runs off end of BCD card"); call ioa_ ("comdk card number ^d, character ^d is field length of ^d", prev_comdk_seq_no, comdk_char_index-2, field_len); call ioa_ ("BCD card number ^d, column ^d is next col to fill", file_record_count, bcd_col_index); call ioa_ ("Skipping field and blanking rest of BCD card"); end; goto next_string; end; else call fatal_error (21); /* comdk field runs off bcd card */ end; bcd_col_index = bcd_col_index + field_len - string_len; /* move past blanks */ bit_string_len = string_len*6; /* string length in bits, for move */ /* move the string into the bcd card */ addr (bcd_card.column (bcd_col_index)) -> bit_string = addr (comdk_card.char (comdk_char_index)) -> bit_string; bcd_col_index = bcd_col_index + string_len; /* next vacant column */ next_string: comdk_char_index = comdk_char_index + string_len; /* index of next field length */ field_len = fixed (comdk_card.char (comdk_char_index)); /* next field length */ comdk_char_index = comdk_char_index + 1; /* next item on comdk card */ goto uncom_loop; end get_comdk; %page; interpret_tape_status: proc; if substr (status, 1, 3) = "100"b then do; /* if this is hardware status, decode it */ if substr (status, 27, 4) = "0100"b /* major status End of File */ & (substr (status, 31, 6) = "001111"b /* EOF 7track */ | substr (status, 31, 6) = "010011"b) /* EOF 9track */ then file_eof = "1"b; else call decode_nstd_status_ (status, tape_status_message); end; /* if not hardware status, just return */ return; end interpret_tape_status; %page; julian_day: proc (month, dom, year) returns (fixed bin); dcl mlen (12) fixed bin(24)int static init (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); dcl (i, month, dom, year, jday) fixed bin(24); jday = 0; do i = 1 to month-1; /* add up days in preceeding months */ jday = jday+mlen (i); end; jday = jday + dom; /* add date in this month */ if month > 2 then /* if March or later */ if mod (year, 4) = 0 then /* and this is leap year */ jday = jday + 1; /* add in Feb 29 */ return (jday); end julian_day; %page; make_gcos_record: proc; /* come here to build gcos records */ gcos_record_ptr = gcos_work_area_ptr; /* build record in gcos_work_area */ if output.gcos_ascii then do; char_string_len = ascii_line_len; /* length of ascii char string to move */ addrel (gcos_record_ptr, 1) -> char_string = ascii_card; /* move it into gcos record */ i = mod (char_string_len, 4); /* number of chars in partially filled word */ if i ^= 0 then do; /* if there is a partially filled word */ i = 4-i; /* compute number of pad characters needed to fill it out */ char_string_len = char_string_len + i; /* lengthen string by that much */ substr (addrel (gcos_record_ptr, 1) -> char_string, ascii_line_len+1, i) = substr (ascii_pads, 1, i); end; /* and move in the pad characters */ gcos_record.rcw = ""b; /* clear the rcw, and fill in some fields */ gcos_record_len = divide (char_string_len, 4, 17, 0); /* word length of record */ gcos_record_ptr -> rcw.length = bit (fixed (gcos_record_len, 18)); /* into rcw */ gcos_record_ptr -> rcw.media_code = ascii_media_code; /* media code = 6 */ if i ^= 0 then do; /* if last word is partially filled */ i = 4-i; /* get back the number of chars in it */ substr (gcos_record.rcw, 19, 2) = bit (bin (i, 2)); /* and put it in the rcw, in a new field that used to be part of the eof indicator */ end; end; else do; /* regular BCD record wanted */ gcos_record_len = 14; /* fixed bin(24)copy of rcw.length */ gcos_record.data_words = bcd_b6; /* fill with BCD spaces */ call gcos_cv_ascii_gebcd_check_ (ascii_line_ptr, ascii_line_len, addrel (gcos_record_ptr, 1), code); if code ^= 0 then do; call ioa_ ("Error on character ^d of:^/^a", code, ascii_card); code = 0; /* code is position of bad char - not error table code */ call fatal_error (42); end; gcos_record.rcw = bcd_rcw; end; return; end make_gcos_record; %page; open_comdk_input: proc (record_ptr, record_len); dcl record_len fixed bin(24); dcl record_ptr ptr; comdk_error_count = 0; input_comdk_open = "1"b; /* remember that comdk is open */ comdk_card_ptr = record_ptr; /* point to first comdk card */ prev_comdk_seq_no = fixed (comdk_card.seq_no); if prev_comdk_seq_no ^= 1 then call fatal_error (22); /* bad initial comdk seq no */ field_len = fixed (comdk_card.char (1)); /* first field len */ if field_len < 1 | field_len > 55 then call fatal_error (23); /* bad initial comdk field len */ comdk_char_index = 2; /* since we got char 1 above */ bcd_work_area_ptr -> gcos_record.rcw = bcd_rcw; /* initialize the rcw */ return; end open_comdk_input; %page; open_comdk_output: proc; dcl (i, j) fixed bin(24); string (k_card) = ""b; /* clear the 28 word buffer used to build comdk cards */ k_card.rcw = bin_rcw; /* rec len = 27, media code = 1 */ k_card.col1 = comdk_col_1; /* 5005 octal (12-0-7-9 punch) */ comdk_out_index = 1; /* start with first char on output card */ k_card.seq_no = bit (bin (1, 24)); /* fixed bin(24)24 constant 1 */ /* Initialize sequence columns (73-80) to "EEEE0000" where EEEE is the first 4 characters of the edit name */ if input.set = library then edit_name = substr (item_name, 1, 4); else if input.medium = tape then edit_name = "...."; else do; /* get an edit name from the file name */ i, j = 1; /* don't want it to be ">udd", so find entry name */ find_edit_name: j = index (substr (input.file_name, i), ">"); /* look for another ">" */ if j ^= 0 then do; /* found one */ i = i + j; /* move past it */ goto find_edit_name; end; edit_name = substr (input.file_name, i, 4); end; unspec (bcd_edit_name) = bcd_string (edit_name, 4); /* convert edit name to bcd */ do i = 1 to 4; /* use numeric value of bcd character as index into table */ k_card.seq_col (i) = raw_table (fixed (bcd_edit_name (i))); /* of card punch patterns for those chars */ end; do i = 5 to 8; /* initialize col 77-80 to zeros */ k_card.seq_col (i) = raw_table (0); seq_col (i) = 0; /* fixed bin(24)copy of 77-80, for incrementing */ end; output_comdk_open = "1"b; return; end open_comdk_output; %page; open_input: proc; io_ptr = input_ptr; /* for position tape, and to tell which file, if error */ if input.medium = tape then do; /* the tape will already be attached */ input_stream_name = tape_stream (input.sw); element_size = 36; elements_wanted = 320; call position_tape; /* reads and verifies labels */ end; /* end open tape */ else do; input_stream_name = file_stream (input.sw); call ios_$attach (input_stream_name, "file_", input.file_name, "r", status); if code ^= 0 then call fatal_error (24); if input.medium = raw then do; element_size = 960; /* 12 rows X 80 columns */ elements_wanted = 1; input_block_ptr = addrel (gcos_work_area_ptr, 1); /* read directly into the record, after the rcw */ /* by reading the record directly into gcos_work_area, we save copying it later */ /* input_block_ptr tells ios_$read where to put the input */ end; else if input.format = ascii then do; element_size = 9; /* the default - set in case changed previously */ elements_wanted = 1280; /* the buffer size */ end; else do; /* all other possibilities */ element_size = 36; /* one word */ elements_wanted = 320; /* one block */ end; call ios_$setsize (input_stream_name, element_size, status); if code ^= 0 then call fatal_error (25); end; /* end open non tape */ if input.format = ascii then do; if ^input.no_canon then /* if we are going to call canonicalizer */ tabstop_ptr = addr (gcos_control_tables_$tabstops); /* get pointer to tab table */ /* by waiting to do it now, we avoid initiating segment gcos_control_tables_ in cases where we are not going to use anything in it */ call ios_$setdelim (input_stream_name, 1, unspec (ascii_newline), 1, unspec (ascii_newline), status); if code ^= 0 then call fatal_error (26); /* we had to set the delimiter back to newline, since the ios_$setsize call removes the default delimiter */ end; file_eob = "1"b; /* always read a block on first read call */ file_eof = "0"b; /* not eof 'til we read an eof */ rcw_eof = "0"b; found_last_line = "0"b; looking_for_first_line, looking_for_last_line = "0"b; if input.first_line > 0 then looking_for_first_line = "1"b; else /* don't start looking for last line til first line found */ if input.last_line > 0 then looking_for_last_line = "1"b; tape_status_message = ""; if input.long then call ioa_ ("^a being read", input.file_name); return; end open_input; %page; open_next_input: proc; next_input_index = next_input_index + 1; input.file_name = input_list (next_input_index).names; call open_input; input_list (next_input_index).used = "1"b; file_record_count = 0; /* causes -first, -last, -count to be applied separately to each input file */ return; end open_next_input; %page; open_next_output: proc; next_output_index = next_output_index + 1; if next_output_index > output.list_count then do; if ^input.brief then do; io_ptr = input_ptr; call report_missing_items; end; goto cleanup_and_return; end; if output.name_files then do; if index (substr (item_name, 1, item_length), " ") > 1 then output.file_name = before (item_name, " ")||next_output_suffix; else output.file_name = substr (item_name, 1, item_length)||next_output_suffix; end; else do; output.file_name = output_list (next_output_index).names; output_list (next_output_index).used = "1"b; end; call open_output; return; end open_next_output; %page; open_output: proc; io_ptr = output_ptr; /* for position_tape, and to tell which file, if error */ if output.medium = tape then do; output_stream_name = tape_stream (output.sw); /* tape is already attached */ call position_tape; if ^no_label (io.sw) then do; /* if labeled tape, build and write header label */ label_ptr = write_buffer_ptr; /* build it in the write buffer */ unspec (header_label) = ""b; /* clear it first */ header_label.btl = bcd_btl; /* GE/b/b600/bBTL/b */ call system_info_$installation_id (inst); /* get installation id */ header_label.installation = bcd_string (inst, 6); /* first 6 chars of it in BCD */ header_label.reel_ser_no = bcd_b1; /* blank first char */ substr (header_label.reel_ser_no, 7, 30) = bcd_string (string (output_tape.id), 5); /* ser no in last 5 chars */ header_label.file_ser_no = header_label.reel_ser_no; /* always the same for single reel files */ header_label.reel_seq_no = bcd_b2; /* blank first 2 chars */ substr (header_label.reel_seq_no, 36, 1) = "1"b; /* last 24 bits are the fixed binary number 1 */ header_label.creation_date = bcd_b1; /* blank first char */ call decode_clock_value_ (clock_ (), month, dom, year, tod, dow, zone); /* get date */ substr (header_label.creation_date, 7, 12) = bcd_string_bin (mod (year, 100), 2); /* last 2 digits of year, in BCD */ substr (header_label.creation_date, 19, 18) = bcd_string_bin (julian_day (month, dom, year), 3); /* 3 digit julian day, in BCD */ header_label.retention_days = bcd_b3; /* first 3 chars blank */ /* last 3 all zero - no retention days */ header_label.file_name = bcd_string (string (output_tape.label), 12); header_label.prverr = bcd_b6; /* 6 BCD blanks */ word_string_len = 14; /* length of label */ addr (saved_header_label) -> word_string = addr (header_label) -> word_string; /* save it to use for building partial label later */ /* use word_string overlay, since structure assignment compiles into element-by-element assignment */ call write_tape_label; /* write label and eof, checking error codes */ end; /* end of labeled tape do group */ end; else do; output_stream_name = file_stream (output.sw); call ios_$attach (output_stream_name, "file_", output.file_name, "rw", status); /* attach in "rw" mode, to allow reading to end of file to be appended to, if there is one */ if code ^= 0 then call fatal_error (27); /* set element size */ if output.medium = raw then element_size = 960; else if output.format = ascii then element_size = 9; else element_size = 36; call ios_$setsize (output_stream_name, element_size, status); if code ^= 0 then call fatal_error (28); call ios_$tell (output_stream_name, "last", "first", offset, status); if code ^= 0 then call fatal_error (29); appending_to_output = "0"b; /* initialize switch to off */ if offset ^= 0 then /* if output seg has something in it already */ if output.append then /* and user said -append */ appending_to_output = "1"b; /* then remember to do so */ else do; /* else ask what to do */ call command_query_ (addr (query_info), answer, me, "^a already exists. Do you want to overwrite it?", output.file_name); if answer = "no" then goto cleanup_and_return; else do; /* truncate the output file */ call ios_$seek (output_stream_name, "last", "first", 0, status); if code ^= 0 then call fatal_error (30); end; end; /* end ask user about existing file */ end; /* end attach non tape */ if output.medium ^= raw then if output.format ^= ascii then if output.format ^= blocks then do; if appending_to_output then do; call ios_$read (output_stream_name, gcos_record_ptr, 0, 320, gcos_record_len, status); return; end; else do; remaining_output_words = 319; output_word_ptr = addrel (write_buffer_ptr, 1); block_serial_number = 1; write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18)); output_block_len = 0; /* fixed bin(24)copy of bcw.length */ write_buffer_ptr -> bcw.length = (18)"0"b; if output.gcos_ascii then do; /* write an empty 20-word record at the start of a gcos ascii file to be compatible in format with the real gcos */ output_block_len = output_block_len + 21; /* 20 words plus rcw */ write_buffer_ptr -> bcw.length = bit (bin (output_block_len, 18)); output_word_ptr -> word_string (1) = ascii_header_rcw; output_word_ptr = addrel (output_word_ptr, 21); remaining_output_words = remaining_output_words - 21; end; end; end; tape_status_message = ""; if output.long then call ioa_ ("^a being written", output.file_name); /* print file name or tape message */ return; end open_output; %page; position_tape: proc; dcl expected_input fixed bin(24)/* next thing expected from tape */; dcl (header init (1), /* names for things expected from tape */ trailer init (2), eof_after_header init (3), eof_after_trailer init (4), eof_after_forward_file init (5) )int static fixed bin(24); dcl file_number fixed bin(17)init (0); dcl position_found bit (1) aligned init ("0"b); /* to remember that we found the position, while we are reading past the eof mark after a label */ dcl ascii_file_name char (12) aligned; dcl ascii_ser_no char (5) aligned; dcl i fixed bin(24); dcl 1 hdr aligned based (label_ptr), /* overlay for header label */ 2 fill1 (3) bit (36) aligned, /* to pick up chracters in reel_ser_no and file_name */ 2 ser (0:5) bit (6) unaligned, /* one at a time */ 2 fill2 (4) bit (36) aligned, 2 fname (12) bit (6) unaligned; /* don't care about rest of it */ dcl 1 tape_message aligned based (addr (io.file_name)), (2 io_name char (6), 2 b1 char (1), 2 tape char (4), 2 b2 char (1), 2 tape_id char (5), 2 b3 char (1), 2 file char (4), 2 b4 char (1), 2 fileno char (3), 2 b5 char (1), 2 filename char (12)) unaligned; /* Put tape information into io.filename, for convenience of message printing */ io.file_name = ""; /* tape_message overlays beginning of io.file_name */ tape_message.tape = "tape"; tape_message.io_name = substr (io_names (io.sw), 1, length (tape_message.io_name)); /* "input" or "output" */ tape_message.tape_id = substr (io_tape.id, 1, length (tape_message.tape_id)); /* Check for nothing to do */ if io_tape.position = 0 then do; /* if user did not give position */ if io.sw = output_code then return; /* use current position for output */ else if no_label (io.sw) then return; /* do the same for input, if there are no labels */ else if io_tape.label = "" then /* or, if input file name not given */ goto omit_rewind; /* just read past the header label */ end; /* Rewind tape */ call ios_$order ((tape_stream (io.sw)), "rewind", null, status); if code ^= 0 then call fatal_error (32); /* error rewinding tape */ if io.sw = output_code | no_label (io.sw) then if io_tape.position = 1 then goto set_fileno; /* we are already there */ omit_rewind: /* come here to just read past header label of current file */ /* Initialize for search loop */ label_ptr = input_block_ptr; if no_label (io.sw) then do; /* if unlabeled tape */ expected_input = eof_after_forward_file; /* just skip to requested position */ file_number = 1; /* we are already at first file */ end; else expected_input = header; /* Search loop */ position_loop: file_eof = "0"b; err_num = file_number; /* in case of error while positioning */ if expected_input = eof_after_forward_file then /* skip over data records */ call ios_$order ((tape_stream (io.sw)), "forward_file", null, status); else /* just read labels and eof marks */ call ios_$read ((tape_stream (io.sw)), input_block_ptr, 0, elements_wanted, input_block_len, status); if code ^= 0 then do; call interpret_tape_status; /* check for eof or other error */ if file_eof then do; /* eof mark read */ if expected_input = eof_after_forward_file then do; if ^no_label (io.sw) then /* unless this is an unlabeled tape, */ expected_input = trailer; /* the next thing will be a trailer label */ else do; /* it is an unlabeled tape */ if io.long then /* tell user that previous file was skipped */ call ioa_ ("tape ^a, file ^d will be skipped", io_tape.id, file_number); file_number = file_number + 1; /* increment file number */ if file_number = io_tape.position then /* if this is the file we want */ goto set_fileno; /* go put its number into message and return */ end; end; else if expected_input = eof_after_trailer then if position_found then goto set_filename; /* positioned for writing label of output file */ else expected_input = header; else if expected_input = eof_after_header then if position_found then goto set_filename; /* positioned for reading input data records */ else expected_input = eof_after_forward_file; /* skip over data records */ else call fatal_error (33); /* unexpected eof while positioning tape */ end; /* end eof mark read */ else call fatal_error (34); /* io error while positioning tape */ end; /* end code ^= 0 */ else if expected_input = header then do; /* want header label */ if header_label.btl = bcd_btl then do; /* this is one */ expected_input = eof_after_header; file_number = file_number + 1; if unspec (partial_label.zero_words) = ""b then /* check for partial label */ call fatal_error (35); /* partial label while positioning tape */ if file_number = 1 then do; /* first file on tape */ do i = 1 to 5; /* convert reel serial number in label to ASCII */ substr (ascii_ser_no, i, 1) = xlate (fixed (hdr.ser (i))); end; if substr (io_tape.id, 1, 4) = "-att" then /* if we did not know the serial no */ tape_message.tape_id, io_tape.id = ascii_ser_no; /* we do now */ else do; /* if we already knew it, verify correct tape */ if substr (io_tape.id, 1, 5) ^= ascii_ser_no then do; /* need substr because of possible trailing ",Ntrack in id */ call command_query_ (addr (query_info), answer, me, "Label on ^a tape contains reel serial number ^a. You specified reel ^a. Do you wish to proceed?", io_names (io.sw), ascii_ser_no, io_tape.id); if answer = "no" then goto cleanup_and_return; end; /* end mismatched ser nos */ end; /* end we already knew ser no */ end; /* end file number = 1 */ do i = 1 to 12 ; /* convert file name in label to ASCII */ substr (ascii_file_name, i, 1) = xlate (fixed (hdr.fname (i))); end; if io_tape.position ^= 0 then do; /* if user gave position */ if file_number = io_tape.position then do; /* and this is it */ if io_tape.label ^= "" then do; /* if file name also given */ if ascii_file_name ^= io_tape.label then do; /* compare them */ call command_query_ (addr (query_info), answer, me, "File ^d on tape ^a is named ^a. You specified the file name: ^a. Do you wish to proceed?", file_number, io_tape.id, ascii_file_name, io_tape.label); if answer = "no" then goto cleanup_and_return; io_tape.label = ascii_file_name; /* replace given name by one from tape label */ end; /* end names not the same */ end; /* end user gave label */ position_found = "1"b; end; /* end this is specified position */ end; /* end user gave position */ else do; /* user did not give position */ /* this has to be input */ if io_tape.label = "" then /* we were just reading past header label */ goto found_input_position; /* of current file */ if ascii_file_name = io_tape.label then found_input_position: position_found = "1"b; end; if io.long then do; if position_found then answer = "copied"; else answer = "skipped"; call ioa_ ("tape ^a, file ^d (^a) will be ^a." , ascii_ser_no, file_number, ascii_file_name, answer); end; end; /* end this is a header label */ else call fatal_error (36); /* expected header label not found */ end; /* end expecting header label */ else if expected_input = trailer then do; if trailer_label.eof = bcd_beofbb then do; expected_input = eof_after_trailer; if io.sw = output_code then do; /* for output, stop after trailer of previous file */ if file_number = io_tape.position - 1 then do; /* if this file immediately preceeds the one to be written */ position_found = "1"b; if io.long then call ioa_ ("Output will be written on tape ^a after file ^d (^a).", ascii_ser_no, file_number, ascii_file_name); end; end; /* end output */ end; /* end eof label */ else if trailer_label.eof = bcd_beorbb then call fatal_error (37); /* eor label while positioning */ else call fatal_error (38); /* expected trailer label missing while positioning */ end; /* end expecting trailer */ else call fatal_error (39); /* bug in position tape */ goto position_loop; set_filename: /* put file name into tape message */ tape_message.filename = io_tape.label; /* fall thru and put file number in it too */ set_fileno: ; dcl p13 pic "(12)z9"; dcl 1 p13_ovl based(addr(p13)) ,2 l10 char(10)unal ,2 r3 char( 3)unal ; p13 = file_number; tape_message.fileno = p13_ovl.r3; /* last 3 of the 10 digits returned by char for fixed bin(17) */ tape_message.file = "file"; return; end position_tape; %page; process_imcv: proc; call open_input; if output.set ^= multiple_files then call open_output; /* set up parameters for find_list_item */ item_index = 16; /* snumb begins in col 16 */ item_length = 5; /* and can be up to 5 chars long */ first_key = 1; /* look for $ SNUMB */ last_key = 1; /* only */ eof = "0"b; call copy_jobs; /* Now do the grubby work */ if output.set ^= multiple_files then call close_output; else if ^output.name_files then if next_output_index < output.list_count then if ^output.brief then do; io_ptr = output_ptr; call report_missing_items; end; if eof then do; if ^input.all then if list_index ^= input.list_count + 1 then if ^input.brief then do; io_ptr = input_ptr; call report_missing_items; end; if looking_for_first_line then call report_suspicious_eof; end; call close_input; end process_imcv; %page; process_library_file: proc; call open_input; if output.set ^= multiple_files then call open_output; eof = "0"b; /* set up parameters for find_list_item */ item_index = 73; /* edit name starts in col 73 */ item_length = 8; /* and is up to 8 chars long */ first_key = 2; /* look for $ GMAP (2) */ /* $ 355MAP (3) */ /* $ OBJECT (4) */ /* $ FORTRAN (5) */ last_key = 15; /* or $ IDS2 (15) */ copy_library_decks: do list_index = 1 to input.list_count while (^eof); call find_list_item; if ^eof then do; if output.set = multiple_files then call open_next_output; call copy_one_deck; if output.set = multiple_files then call close_output; end; end copy_library_decks; if input.long then call ioa_ ("^/End of Library copy."); if output.set ^= multiple_files then call close_output; else if ^output.name_files then if next_output_index < output.list_count then if ^output.brief then do; io_ptr = output_ptr; call report_missing_items; end; if eof then do; if ^input.all then /* if all decks were not being copied */ if list_index ^= input.list_count + 1 then if ^input.brief then do; io_ptr = input_ptr; call report_missing_items; end; if looking_for_first_line then call report_suspicious_eof; end; call close_input; end process_library_file; %page; process_multiple_files: proc; if output.set ^= multiple_files then call open_output; copy_files: do list_index = 1 to input.list_count; call open_next_input; if output.set = multiple_files then call open_next_output; call copy_one_file; call close_input; if output.set = multiple_files then call close_output; end copy_files; if output.set ^= multiple_files then call close_output; else /* check for all of the output files written */ if ^output.name_files then /* but only if names were given */ if next_output_index ^= output.list_count then if ^output.brief then do; io_ptr = output_ptr; call report_missing_items; end; end process_multiple_files; %page; process_single_file: proc; call open_input; if output.set = multiple_files then /* if user did a dumb thing - i.e. gave several output files, but only one input file */ call open_next_output; /* we will be sensible, by writing into the first one, instead of trying to write into a file whose name is given by the garbage in an uninitialized variable */ else call open_output; call copy_one_file; call close_input; call close_output; if output.set = multiple_files then /* if user did a dumb thing */ if output.list_count > 1 then /* and it was a very dumb thing */ if ^output.brief then do; /* if he is willing to be told about it */ io_ptr = output_ptr; /* tell him */ call report_missing_items; end; end process_single_file; %page; put_comdk: proc (record_ptr, record_len); dcl record_len fixed bin(24); dcl record_ptr ptr; dcl b_col fixed bin(24)/* current column from b_card */; dcl extra_chars fixed bin(24)/* number of chars past the limit of 55 per field */; dcl field_len fixed bin(24)/* length of compressed field, including leading blanks */; dcl saved_string_len fixed bin(24)/* remember nonblank count when limit of 55 is exceeded */; dcl string_len fixed bin(24)/* length of trailing nonblank string in compressed field */; dcl string_start fixed bin(24)/* b_col where nonblank string starts */; dcl 1 b_card like bcd_card aligned based (record_ptr); dcl blank bit (1) aligned /* on if current char from b_card is blank */; dcl in_blanks bit (1) aligned /* on while in a string of 3 or more blanks */; dcl prev_blanks fixed bin(24)/* counter used to find 3 or more consecutive blanks */; prev_blanks, field_len, string_len = 0; string_start = 1; /* first string starts in col 1 */ in_blanks = "1"b; /* to compress 1 or 2 blanks at start of card */ if comdk_out_index = 132 then /* if current output card is full */ call finish_comdk_card; /* write it out and initialize a new one */ do b_col = 1 to 80; /* scan input card for compressible fields */ if b_card.column (b_col) = bcd_blank then blank = "1"b; else blank = "0"b; if ^blank then /* if in a nonblank string */ if comdk_out_index > 129 then /* but there is no room for another field */ /* on the current output card */ call finish_comdk_card; /* write it out and initialize another one */ field_len = field_len + 1; /* add this char to length of field */ if in_blanks then do; /* if already in a string of blanks */ if ^blank then do; /* not blank - end of blank string */ in_blanks = "0"b; string_len = 1; /* start a new nonblank string */ string_start = b_col; /* at this column */ end; end; /* end of in blanks do group */ else do; /* not in blanks */ string_len = string_len + 1; /* add this char to length of nonblank string */ if blank then do; /* if this is a blank */ if prev_blanks = 2 then do; /* we found 3 consecutive blanks */ in_blanks = "1"b; prev_blanks = 0; if field_len > 3 then do; /* if there was a field before the blanks */ field_len = field_len - 3; /* remove the them from it */ string_len = string_len - 3; call put_comdk_string; /* and write it out */ end; string_len = 0; /* new field has no trailing nonblanks yet */ field_len = 3; /* but it has 3 leading blanks */ end; /* end found 3 blanks do group */ else prev_blanks = prev_blanks + 1; /* count blanks */ end; /* end this is a blank do group */ else /* not a blank */ prev_blanks = 0; /* reset, in case 1 or 2 blanks preceeded this nonblank */ end; /* end not in blanks do group */ if ^in_blanks then do; /* we might not be in blanks now, although we were before */ if field_len = 56 then /* if 1 char too many */ if b_col = 80 then /* but this is the last column */ /* the check for >=57, below, will fail */ goto field_too_long; /* so go write out the first 55 chars now */ if field_len >= 57 then do; /* max field length is 55, but we let it go longer, in case the card ends in a long string of blanks, or there are 3 consecutive blanks in chars 54-57 */ field_too_long: /* come here if 56th char is in col 80 */ extra_chars = field_len - 55; call put_long_comdk_string; /* go put out first 55 chars, and adjust for extras */ end; /* end >=57 char do group */ if ^blank then do; /* if no possibility of getting into blanks */ extra_chars = string_len + 2 + comdk_out_index -132; /* check for full output card */ if extra_chars >= 0 then do; /* if we will fill or overfill it */ if extra_chars = 0 then /* we might exactly fill the output card */ if field_len = 56 then /* with character 56 of a field (illegal) */ extra_chars = 1; /* because we let it grow to 57 (see above) */ call put_long_comdk_string; /* go put out first 55 chars and adjust for extras */ end; /* end of string-fills-card do group */ end; /* end of this-is-not-a-blank do group */ end; /* end not-in-blanks-now do group */ end; /* end 1 to 80 loop on b_col */ /* Fall thru here after looking at all 80 columns */ if prev_blanks > 0 then do; /* discard 1 or 2 trailing blanks */ string_len = string_len - prev_blanks; field_len = field_len - prev_blanks; end; if string_len > 0 then /* if the card ends in a nonblank string */ call put_comdk_string; /* put it out now */ k_card.char (comdk_out_index) = "111111"b; /* 77 octal - end of bcd card */ comdk_out_index = comdk_out_index + 1; return; /* * * * * * * * * * * INTERNAL PROCEDURES WITHIN THIS INTERNAL PROCEDURE */ put_comdk_string: proc; /* FOR DEBUGGING */ if field_len > 55 then goto k_len_err; if string_len + 2 > 132 - comdk_out_index then k_len_err: call fatal_error (59); /* program error while encoding output comdk */ k_card.char (comdk_out_index) = bit (fixed (field_len, 6)); comdk_out_index = comdk_out_index + 1; k_card.char (comdk_out_index) = bit (fixed (string_len, 6)); comdk_out_index = comdk_out_index + 1; if string_len > 0 then do; /* if there is a non blank string */ bit_string_len = string_len * 6; /* move it as based bit string */ addr (k_card.char (comdk_out_index)) -> bit_string = addr (b_card.column (string_start)) -> bit_string; comdk_out_index = comdk_out_index + string_len; end; if comdk_out_index = 132 then /* if card completely full */ call finish_comdk_card; /* write it out */ /* however, if there is room for the end of bcd card and end of deck indicators, we will put off writing it out until we know if there is more data */ return; end put_comdk_string; /* * * * * * * * * * * */ put_long_comdk_string: proc; field_len = field_len - extra_chars; /* get rid of the extra chars */ saved_string_len = string_len; /* remember how many nonblanks there were */ string_len = max (0, string_len - extra_chars); /* possibility of more than 55 blanks */ call put_comdk_string; /* put out the 55 char field */ field_len = extra_chars; /* the left over chars start a new field */ string_len = min (saved_string_len, extra_chars); /* if nonblank after many blanks, string_len will be 1, while extra_chars will be larger */ string_start = b_col - string_len + 1; /* position of first nonblank extra char */ if comdk_out_index > 129 then /* if there is no room for another field on the current output card */ if string_len > 0 then /* but we have the makings of another field */ if prev_blanks ^= string_len then /* and there is no possibility of its being all blank */ call finish_comdk_card; /* write out the current output card and initialize another */ if ^in_blanks then do; if prev_blanks = string_len then /* if first 1 or 2 chars of left over string are blank */ prev_blanks, string_len = 0; /* get rid of them */ if string_len = 0 then /* if there are no nonblank chars */ in_blanks = "1"b; /* any leading blanks get compressed out */ else if b_card.column (string_start) = bcd_blank then do; string_start = string_start + 1; string_len = string_len - 1; end; end; end put_long_comdk_string; /* * * * * * * * * * * */ finish_comdk_card: proc; dcl i fixed bin(24); k_card.char (comdk_out_index) = "000000"b; /* end of comdk card - more to come */ call write_comdk_card; /* write out the card */ string (k_card.char) = "0"b; /* clear the 132 output characters */ comdk_out_index = 1; /* and start with the first one */ k_card.seq_no = bit (fixed (1+fixed (k_card.seq_no), 24)); /* increment sequence number */ /* Increment sequence field - columns 77-80 */ i = 8; /* seq_col(1:8) correspond to card col(73:80) */ seq_carry: seq_col (i) = seq_col (i) + 1; if seq_col (i) = 10 then seq_col (i) = 0; /* check for carry */ k_card.seq_col (i) = raw_table (seq_col (i)); if seq_col (i) = 0 then do; /* if we carried 1 */ i = i - 1; /* add it to the column to the left */ if i >= 5 then goto seq_carry; /* but don't overflow into column 76 */ end; return; end finish_comdk_card; end put_comdk; %page; read_and_convert_ascii: proc; dcl i fixed bin(24); call read_block; /* read_block will return file_eof when it is returning the last block. read_and_convert_input checks file_eof before calling us, so we do not have to check for eof here */ if input_block_len = elements_wanted then if substr (ascii_block, input_block_len, 1) ^= ascii_newline then call fatal_error (40); /* no newline for a long way in ascii file */ if substr (ascii_block, input_block_len, 1) = ascii_newline then /* if there is a trailing newline */ input_block_len = input_block_len - 1; /* get rid of it */ if input_block_len = 0 then do; /* check for empty line */ input_block_len = input_block_len + 1; /* aos instead of lda sta */ substr (ascii_block, 1, 1) = " "; /* put in 1 blank to avoid trouble later */ end; if input.no_canon then do; /* if we are not canonicalizing, fix up line length here */ if (output.gcos_ascii) | (output.format = ascii) then ascii_line_len = input_block_len; /* records are variable length */ else do; /* otherwise they are fixed length 80 column card images */ ascii_line_len = 80; if input_block_len > 80 then do; /* if input line is too long */ if ^input.truncate_ascii then /* and user did not say truncate */ call fatal_error (41); /* complain */ input_block_len = 80; /* else truncate */ end; end; ascii_card = ascii_block; /* copy input line into work area */ end; /* end no_canonicalize do group */ else do; /* we are canonicalizing */ if (output.gcos_ascii) | (output.format = ascii) then /* if variable length records */ ascii_line_len = length (ascii_line); /* allow max length for canonicalized line */ else ascii_line_len = 80; /* else make it 80 column card image */ call canonicalizer (input_block_ptr, input_block_len, ascii_line_ptr, ascii_line_len); if output.gcos_ascii then do; /* now get rid of the trailing blanks, if we allowed max length for variable length line */ i = verify (reverse (ascii_card), " "); /* i will be position of first nonblank */ ascii_line_len = ascii_line_len - i + 1; /* so get rid of i-1 trailing blanks */ end; end; /* end of canonicalize do group */ if output.format ^= ascii then call make_gcos_record; return; end read_and_convert_ascii; %page; read_and_convert_gcos: proc; dcl i fixed bin(24); dcl fill_index fixed bin (24); dcl media_code bit (4) unaligned; skip_card: ; /* come here after discarding a non-bcd card, to get another card */ if input.comdk then call read_comdk (gcos_record_ptr, gcos_record_len); else call read_record (gcos_record_ptr, gcos_record_len); /* we now have a gcos record, complete with rcw */ if eof then do; /* maybe we don't have a record... */ if output.format = ascii | output.gcos_ascii then if ^output.brief then do; ascii_card = "END OF FILE"; /* supply something to print, since there is no card */ call check_bin_cards; /* and go see if deck ended with binary cards */ end; return; end; media_code = gcos_record_ptr -> rcw.media_code; if media_code = ascii_header_media_code then do; if input.long then call ioa_ ("discarding gcos ascii header record"); goto skip_card; end; else if media_code = ascii_media_code then do; /* if we have a gcos ascii record */ ascii_line_len = 4*fixed (gcos_record_ptr -> rcw.length); /* record length in chars */ if (gcos_record_ptr -> rcw.char_pos ^= 0) then ascii_line_len = ascii_line_len -4 +(gcos_record_ptr -> rcw.char_pos); char_string_len = ascii_line_len; /* length of string to move */ ascii_card = addrel (gcos_record_ptr, 1) -> char_string; /* move it out of record */ if ascii_line_len < 6 /* gotta pad first word */ then do; fill_index = ascii_line_len +1; ascii_line_len = 6; substr (ascii_card, fill_index, (7 - fill_index)) = " "; end; end; if output.format = ascii | output.gcos_ascii then do; if (media_code = bcd_media_code) | (media_code = plain_bcd_media_code) then do; /* if bcd record */ /* or media code = 0 */ if (gcos_record_len > 18) & (media_code = bcd_media_code) then call fatal_error (43); if gcos_record_len <= 14 /* if this is an ordinary BCD card */ then ascii_line_len = 80; /* make it exactly 80 columns */ else ascii_line_len = gcos_record_len*6; /* if BCD record is longer than a card */ ascii_card = ""; /* blank out 'ascii_line_len' characters (the conversion routine doesn't) */ call gcos_cv_gebcd_ascii_ (addrel (gcos_record_ptr, 1), min (ascii_line_len, gcos_record_len*6), ascii_line_ptr); if ^input.brief then call check_bin_cards; /* go see if binary cards preceeded this one */ if output.gcos_ascii /* chop off trailing blanks */ then do; ascii_line_len = length (rtrim (ascii_card)); if ascii_line_len = 0 /* but leave at least one char so we don't get shot down */ then do; ascii_line_len = ascii_line_len + 1; substr (ascii_card, ascii_line_len, 1) = " "; end; call make_gcos_record; end; end; else if media_code ^= ascii_media_code then do; /* if not BCD or ASCII record, we have to discard it on ASCII output */ if ^input.brief then if ^just_looking then /* we skip thru comdks while looking for edit name or snumb */ bin_cards_skipped = bin_cards_skipped + 1; /* keep track of binary cards, to print in message later */ goto skip_card; /* skip this binary card; go get next card */ end; end; else /* output is BCD */ if media_code = ascii_media_code then /* if we have gcos_ascii input */ call make_gcos_record; /* go convert it to BCD */ return; end read_and_convert_gcos; %page; read_and_convert_input: proc; /* a call to this procedure will: 1) read next record from input file, whatever its type, and 2) convert it to proper format for output, except for compressing for comdk output, which is done in write_output */ io_ptr = input_ptr; /* to tell which file, if error */ read_next_record: /* come here while searching for first line */ file_record_count = file_record_count + 1; if looking_for_last_line then if file_record_count > input.last_line then do; found_last_line = "1"b; goto return_eof; end; if looking_for_first_line then if file_record_count >= input.first_line then do; looking_for_first_line = "0"b; if input.last_line > 0 then looking_for_last_line = "1"b; end; if file_eof then if file_eob then if ^input_comdk_open then do; return_eof: eof = "1"b; return; end; if input.format = ascii then call read_and_convert_ascii; else if input.format = blocks then do; if file_eof then do; eof = "1"b; return; end; call read_block; if input.medium = tape then if file_eof then do; eof = "1"b; return; end; end; else if input.format = gcos then call read_and_convert_gcos; else call fatal_error (44); input_record_count = input_record_count + 1; if looking_for_first_line then goto read_next_record; return; end read_and_convert_input; %page; read_block: proc; /* procedure to call ios_$read and interpret status code */ call ios_$read (input_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status); input_block_count = input_block_count + 1; /* count blocks */ if input.medium ^= tape then do; file_eof = substr (status, 46, 1); if code ^= 0 then call fatal_error (45); if file_eof then if output.medium = tape /* chop off the EOF RCW if tape output */ then bcw_word.bcw_len = bcw_word.bcw_len - 1; end; /* end check non-tape status */ else do; if code ^= 0 then do; file_eof = "0"b; call interpret_tape_status; if ^file_eof then /* if not just end of file */ call fatal_error (46); /* tape read error */ else do; /* skip block length checking if end of file */ if output.medium = tape /* chop off the EOF RCW if tape output */ then bcw_word.bcw_len = bcw_word.bcw_len - 1; return; end; end; end; /* end check tape status */ if input.format ^= ascii then if input.medium ^= tape then if elements_wanted ^= input_block_len then call fatal_error (47); if input_block_len = 0 then call fatal_error (48); return; end read_block; %page; read_comdk: proc (record_ptr, record_len); /* returns a bcd or binary card in a gcos record; uncompresses any comdks that it reads */ dcl record_len fixed bin(24); dcl record_ptr ptr; if input_comdk_open then call get_comdk (record_ptr, record_len); /* if already in a comdk */ else do; call read_record (record_ptr, record_len); if eof then return; if (record_len = 27|record_len = 24) then /* if the length is that of a binary card */ if record_ptr -> bin_card.column (1) = comdk_col_1 /* and col 1 has the comdk code in it */ then do; /* then this is the start of a comdk */ call open_comdk_input (record_ptr, record_len); /* send comdk card to open routine */ call get_comdk (record_ptr, record_len); /* now go get first uncomed card from it */ end; end; return; end read_comdk; %page; read_gcos_record: proc (record_ptr, record_len); /* procedure to read next record from a standard system format gcos file */ dcl record_len fixed bin(24); dcl record_ptr ptr; if file_eob then do; /* if no more records in this block */ if file_eof then do; /* check for end of file from last read block call */ eof = "1"b; /* tell caller, if eof */ return; /* and return */ end; /* else keep reading */ call read_block; /* get next block */ /* End of file checking is made complicated by the fact that the file_ dim returns an EOF status from the same call that returns the last words in the file, and we have to remember that status and act on it the NEXT time we want to read a block. The nstd_ dim, however, returns EOF when there are no more tape records to be returned. If we are reading a tape, we have to check for EOF again, now. */ if input.medium = tape then /* if reading tape */ if file_eof then do; /* and there are no more records */ eof = "1"b; /* tell caller */ return; /* and return to him immediately */ end; remaining_block_len = fixed (input_block_ptr -> bcw.length); /* get block length */ if remaining_block_len > 319 | remaining_block_len < 1 then call fatal_error (49); file_eob = "0"b; /* remember that we got block */ record_ptr, saved_record_ptr = addrel (input_block_ptr, 1); /* get first record */ end; else /* else just get next record */ record_ptr, saved_record_ptr = addrel (saved_record_ptr, fixed (saved_record_ptr -> rcw.length) + 1); if record_ptr -> rcw.eof = bcd_eof then do; /* check for eof record */ rcw_eof, eof, file_eof, file_eob = "1"b; /* if so, turn on all end switches */ return; /* and return */ end; record_len = fixed (record_ptr -> rcw.length); /* get record length */ remaining_block_len = remaining_block_len - record_len - 1; /* decrement block length */ if remaining_block_len < 0 then call fatal_error (50); /* should never go negative */ if remaining_block_len = 0 then file_eob = "1"b; /* check for end of block */ return; end read_gcos_record; %page; read_raw_record: proc (record_ptr, record_len); /* procedure to get next card from a raw card file, and return it in a gcos standard record */ dcl record_len fixed bin(24); dcl record_ptr ptr; if file_eof then do; eof = "1"b; return; end; record_ptr = gcos_work_area_ptr; gcos_work_area = "0"b; /* clear work area */ call read_block; /* read one 960-bit string into it, in words 2-28 */ if substr (gcos_work_area (2), 10, 3) = "101"b then do; /* 7-9 punch ? */ gcos_work_area (1) = bin_rcw; /* rcw for binary card */ record_len = 27; end; else do; /* bcd card */ call cv_bin_to_bcd (input_block_ptr, input_block_ptr); /* NOTE translation in place: output is half as long as input */ gcos_work_area (1) = bcd_rcw; /* rcw for bcd record */ record_len = 14; end; return; end read_raw_record; %page; read_record: proc (record_ptr, record_len); /* procedure to get the next gcos record; decides whether to read from a gcos file, or build one from the next card in a raw file; comdk cards are passed to the caller unchanged */ dcl record_len fixed bin(24); dcl record_ptr ptr; if input.medium = raw then call read_raw_record (record_ptr, record_len); else call read_gcos_record (record_ptr, record_len); return; end read_record; %page; report_missing_items: proc; dcl i fixed bin(24); if io.sw = input_code then do; if ^eof then do; /* must have run out of output names */ call ioa_ ("^a: Output list exhausted while input items remain to be copied. The following input item(s) have not been copied:^/^a", me, item_name); end; else call ioa_ ("^a: The following input items were not found:", me); end; else call ioa_ ("^a: Input list exhausted while output file names remain. The following output file(s) have not been written:", me); if io.list_ptr = null then /* must be input -all, and there is no list */ call ioa_ ("^/And any that follow it in the input file."); else do i = 1 to io.list_count; if ^io_list (i).used then call ioa_ (io_list (i).names); end; return; end report_missing_items; %page; report_suspicious_eof: proc; call ioa_ ("^a: End of file after card ^d of ^a, while seeking card ^d", me, file_record_count, input.file_name, input.first_line); return; end report_suspicious_eof; %page; write_block: proc (block_ptr, block_len); /* procedure to call ios_$write and interpret status code */ dcl block_ptr ptr; dcl block_len fixed bin(24); /* THIS block_len IS THE TOTAL NUMBER OF ELEMENTS TO BE WRITTEN; FOR A GCOS BLOCK, THE CALLER MUST ADD 1 TO bcw.length TO OBTAIN THE CORRECT VALUE */ /* Don't write a zero-length (BCW-only) block to a tape */ if output.format = ascii | block_len > 1 then do; output_block_count = output_block_count + 1; call ios_$write (output_stream_name, block_ptr, 0, block_len, elements_written, status); if code ^= 0 then do; if output.medium = tape then do; call interpret_tape_status; call fatal_error (51); /* tape write error */ end; else call fatal_error (52); end; if elements_written ^= block_len then call fatal_error (53); end; return; end write_block; %page; write_comdk: proc (record_ptr, record_len); dcl dont_compress bit (1) aligned; dcl record_len fixed bin(24); dcl record_ptr ptr; dont_compress = "0"b; if record_ptr -> rcw.media_code ^= bcd_media_code then dont_compress = "1"b; /* don't compress binary cards */ else /* it is a bcd card */ if record_ptr -> bcd_card.column (1) = bcd_dollar then dont_compress = "1"b; /* don't compress dollar cards, either */ if output_comdk_open then do; if dont_compress then do; /* close it */ call close_comdk_output; call write_record (record_ptr, record_len); /* and then write this record */ end; else call put_comdk (record_ptr, record_len); end; /* end comdk open */ else do; /* comdk not open */ if dont_compress then call write_record (record_ptr, record_len); else do; call open_comdk_output; call put_comdk (record_ptr, record_len); end; end; /* end comdk not open */ return; end write_comdk; %page; write_comdk_card: proc; dcl checksum fixed bin(71); dcl i fixed bin(24); /* compute checksum of word 1 and words 3-24 of the comdk record */ checksum = fixed (comdk_work_area_ptr -> gcos_record.data_words (1), 36); do i = 3 to 24; if checksum >= 68719476736 then /* 2**36 */ checksum = checksum - 68719476736 + 1; /* a carry into bit 37 gets added to bit 1 */ checksum = checksum + fixed (comdk_work_area_ptr -> gcos_record.data_words (i), 36); end; /* NOTE: a carry into bit 37 when the LAST word is added is ignored and not added to bit 1 - this is apparently the way GEFRC does it, so we will do the same */ /* put checksum into record */ k_card.checksum = bit (fixed (checksum, 36)); /* write it out */ call write_record (comdk_work_area_ptr, 27); return; end write_comdk_card; %page; write_gcos_record: proc (record_ptr, record_len); dcl record_ptr ptr; dcl record_len fixed bin(24); /* THIS record_len INCLUDES THE RCW; THE CALLER MUST ADD 1 TO rcw.length TO OBTAIN THE CORRECT VALUE */ dcl block_len fixed bin(24)/* to send block length to write block */; dcl record (record_len) bit (36) based; if record_len > 319 then call fatal_error (54); if record_len > remaining_output_words then do; /* write out the block */ if output.medium = tape then /* for tape files */ block_len = output_block_len + 1; /* write 320 words or less */ else /* for disk files, we pad blocks to 320 words */ block_len = 320; /* so a read of 320 words will get exactly one block */ call write_block (write_buffer_ptr, block_len); unspec (write_buffer) = ""b; /* zero the output buffer, to avoid garbage at the ends of short blocks */ remaining_output_words = 319; output_word_ptr = addrel (write_buffer_ptr, 1); block_serial_number = block_serial_number + 1; write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18)); output_block_len = 0; /* fixed bin(24)copy of bcw.length */ end; output_block_len = output_block_len + record_len; write_buffer_ptr -> bcw.length = bit (fixed (output_block_len, 18)); output_word_ptr -> record = record_ptr -> record; output_word_ptr = addrel (output_word_ptr, record_len); remaining_output_words = remaining_output_words - record_len; if record_len = 1 then do; /* record_len of 1 must be an end-of-file word (000000170000 octal), so force out the block */ if output.medium = tape then do; /* tape files should not end with eof records */ write_buffer_ptr -> bcw.length = bit (bin (output_block_len-1, 18)); /* adjust bcw.length */ block_len = output_block_len; /* write one less word (omit the eof_rcw) */ end; else block_len = 320; /* if not tape, write exactly 320 words */ call write_block (write_buffer_ptr, block_len); end; return; end write_gcos_record; %page; write_output: proc; dcl i fixed bin(24); io_ptr = output_ptr; /* to tell which file, if error */ if output.format = gcos then do; if output.comdk then call write_comdk (gcos_record_ptr, gcos_record_len); else call write_record (gcos_record_ptr, gcos_record_len); end; else if output.format = ascii then do; i = length (rtrim (ascii_card)) + 1; /* get rid of trailing blanks */ if output.truncate_ascii then if i > 81 then i = 81; /* chop the line at 80 chars */ substr (ascii_line, i, 1) = ascii_newline; /* last char must be newline */ call write_block (ascii_line_ptr, i); end; else if output.format = blocks then do; if output.medium = tape then i = bcw_word.bcw_len + 1; /* pick up block length, including bcw */ else if input.medium = tape /* if tape to segment copy */ then i = 320; /* pad output block to 320 words */ else i = input_block_len; /* if not tape, write out exactly what was read in */ call write_block (input_block_ptr, i); end; else call fatal_error (55); output_record_count = output_record_count + 1; return; end write_output; %page; write_raw_record: proc (record_ptr, record_len); dcl record_len fixed bin(24); dcl record_ptr ptr; dcl i fixed bin(24); dcl raw_ptr ptr; if (record_len = 27|record_len = 24) /* if binary card */ &record_ptr -> rcw.media_code = "0001"b then do; raw_ptr = addrel (record_ptr, 1); /* data starts right after rcw */ goto write_raw; /* go write it out */ end; else if record_len = 14 /* if BCD card */ &record_ptr -> rcw.media_code = "0010"b then do; do i = 1 to 80; raw_card (i) = raw_table (fixed (record_ptr -> bcd_card.column (i))); end; raw_ptr = raw_card_ptr; write_raw: call write_block (raw_ptr, 1); /* write one 960-bit element */ return; end; else call fatal_error (56); /* bad record length or media code */ end write_raw_record; %page; write_record: proc (record_ptr, record_len); dcl record_len fixed bin(24); dcl record_ptr ptr; if output.medium = raw then call write_raw_record (record_ptr, record_len); else call write_gcos_record (record_ptr, record_len + 1); /* +1 because rcw not included in record_len, and write_gcos_record wants total number of words to be written */ return; end write_record; %page; write_tape_eof: proc; call ios_$order (output_stream_name, "eof", null, status); if code ^= 0 then do; call interpret_tape_status; call fatal_error (57); /* error while writing tape eof */ end; return; end write_tape_eof; %page; write_tape_label: proc; /* write a label on magnetic tape */ call write_block (label_ptr, 14); if code ^= 0 then do; call interpret_tape_status; call fatal_error (58); /* error writing tape label */ end; output_block_count = output_block_count - 1; /* do not count label as a block - exact count is needed to put in trailer label */ call write_tape_eof; /* write eof mark and check error code */ return; end write_tape_label; /* ******************************************************************************************************************** */ /* ******************************************************************************************************************** */ /* ******************************************************************************************************************** */ /* ******************************************************************************************************************** */ end gcos_card_utility_;  gcos_create_file.pl1 11/19/82 1410.9rew 11/19/82 0930.8 53532 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_create_file: gcf: proc (); /* *************************************************************** *************************************************************** * * * G C O S C R E A T E F I L E * * This command is used to create a Multics segment or * multisegment file to be used as a GCOS file with the GCOS * Environment Simulator. The GCOS attributes of the file are * recognized by this command and are passed to the support * subroutine which actually creates the file. * The command syntax is: * * gcos_create_file {<-control_arg>} * * where -control_arg is one of the following: * * -llinks file size in llinks * -links file size in links * * * Written by M. R. Jordan, 12/10/77 * * *************************************************************** *************************************************************** */ dcl ME char (16) static internal options (constant) init ("gcos_create_file"); /* my name */ dcl addr builtin; dcl arg char (arg_len) based (arg_ptr); /* string to access current arg */ dcl arg_len fixed bin; /* len of current arg */ dcl arg_ptr ptr; /* loc of current arg */ dcl code fixed bin (35); /* status code used in calls */ dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dname char (168); /* directory name of target */ dcl ename char (32); /* entry name of target */ dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$wrong_no_of_args fixed bin (35) ext; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl gcos_create_file_ entry (char (*), char (*), ptr, fixed bin (35)); dcl multiplier fixed bin (18); /* multiplier to get file size in words */ dcl nargs fixed bin; /* number of args supplied by user */ %include gcos_file_info; dcl 1 my_gcos_file_info like gcos_file_info; /* Get the number of arguments passed to the command. */ call cu_$arg_count (nargs); if nargs < 1 then do; call com_err_ (error_table_$noarg, ME, "^/Usage is: gcos_create_file filename {-links N|-llinks N}"); return; end; /* Now get the file name argument. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME, "Error referencing argument 1."); return; end; call expand_pathname_ (arg, dname, ename, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; /* Initialize the file info structure with default values. */ my_gcos_file_info.version = 1; my_gcos_file_info.size_in_llinks = 1; my_gcos_file_info.max_size_in_llinks = 0; my_gcos_file_info.flags.random = "0"b; my_gcos_file_info.flags.pad = (35)"0"b; my_gcos_file_info.flags.original_file_has_been_written = "0"b; my_gcos_file_info.flags.user_specified_attributes = (35)"0"b; my_gcos_file_info.ids_attributes.first_page_in_subfile = 0; my_gcos_file_info.ids_attributes.last_page_in_subfile = 0; my_gcos_file_info.ids_attributes.multiuser = "0"b; my_gcos_file_info.ids_attributes.reserveed_1 = (17)"0"b; my_gcos_file_info.ids_attributes.words_per_page = 0; my_gcos_file_info.ids_attributes.reserved_2 = (18)"0"b; my_gcos_file_info.ids_attributes.lines_per_page = 0; my_gcos_file_info.ids_attributes.reserved_3 = (18)"0"b; my_gcos_file_info.ids_attributes.page_fill_percent = "202020"b3; my_gcos_file_info.ids_attributes.reserved_4 = (6)"0"b; my_gcos_file_info.ids_attributes.area_number = 0; my_gcos_file_info.ids_attributes.reserved_5 = (6)"0"b; my_gcos_file_info.ids_attributes.num_pages_in_area = 0; my_gcos_file_info.ids_attributes.minus_one = -1; my_gcos_file_info.ids_attributes.reserved_6 (*) = (36)"0"b; /* Now process all control arguments. */ if nargs> 1 then do; call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME, "Error referencing argument 2."); return; end; if arg = "-links" then multiplier = 12; else if arg = "-llinks" then multiplier = 1; else do; call com_err_ (error_table_$badopt, ME, "^a", arg); return; end; if nargs > 2 then do; call cu_$arg_ptr (3, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME, "Error referencing argument 3."); return; end; my_gcos_file_info.size_in_llinks = cv_dec_check_ (arg, code)*multiplier; if code ^= 0 then do; call com_err_ (error_table_$bad_conversion, ME, "Error converting ""^a"" to decimal integer.", arg); return; end; if nargs > 3 then do; call com_err_ (error_table_$wrong_no_of_args, ME, "Too many arguments supplied."); return; end; end; else do; call com_err_ (error_table_$noarg, ME, "Decimal file size missing."); return; end; end; /* Now that we have all of the pertinent information, create the file. */ call gcos_create_file_ (dname, ename, addr (my_gcos_file_info), code); if code ^= 0 then do; call com_err_ (code, ME, "^a^[>^]^a", dname, (dname ^= ">"), ename); end; return; end gcos_create_file;  gcos_create_file_.pl1 11/19/82 1410.9rew 11/19/82 0930.8 48150 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_create_file_: proc (a_dname, a_ename, a_info_ptr, a_code); /* *************************************************************** *************************************************************** * * * This subroutine is called to create a segment or multisegment * file that is to be used as a GCOS file with the GCOS * Environment Simulator. The data structure gcos_file_info * contains all GCOS file attributes that can be specified by the * caller. The size is converted to a total bit count and an MSF * is created if necessary. * * * Written by M. R. Jordan, 12/10/77 * * *************************************************************** *************************************************************** */ dcl BITS_PER_LLINK fixed bin static internal options (constant) init (11520); dcl RW fixed bin (5) static internal options (constant) init (01010b); dcl SMA fixed bin (5) static internal options (constant) init (01011b); dcl a_code fixed bin (35); /* returned status code */ dcl a_dname char (*); /* directory name passed by caller */ dcl a_ename char (*); /* entry name passed by caller */ dcl a_info_ptr ptr; /* ptr to file info passed by caller */ dcl bit_count fixed bin (24); /* bit count passed to hcs_ */ dcl code fixed bin (35); /* status code from hcs_ */ dcl comp_name char (32) ; /* component name for msf component */ dcl comp_name_len fixed bin; /* length of component name */ dcl component fixed bin; /* component number */ dcl cu_$level_get entry () returns (fixed bin); dcl divide builtin; dcl dname char (168); /* directory name used in calls to hcs_ */ dcl ecode fixed bin (35); /* temp status code */ dcl ename char (32); /* entry name used in calls to hcs_ */ dcl get_group_id_$tag_star entry () returns (char (32)); 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)); dcl hcs_$delentry entry (char (*), char (*), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl max_bits_per_seg fixed bin (24); dcl max_llinks_per_seg fixed bin; dcl msf_name char (168) ; /* name of msf being created */ dcl msf_name_len fixed bin; /* length of msf name */ dcl ncomp fixed bin; /* number of components needed */ dcl rings (3) fixed bin (3) ; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (24) ext; dcl total_bit_count fixed bin (71); /* total bit count to represent # llinks */ dcl user_id char (32); /* person.project.* */ %include gcos_file_info; /* Copy all input arguments. */ dname = a_dname; ename = a_ename; gcos_file_info_ptr = a_info_ptr; /* Initialize a few essential data items. */ code = 0; max_bits_per_seg = sys_info$max_seg_size*36; max_llinks_per_seg = divide (max_bits_per_seg, BITS_PER_LLINK, 17, 0); rings (*) = cu_$level_get (); user_id = get_group_id_$tag_star (); /* Determine the number of components to be created and the total bit count needed. */ ncomp = divide (gcos_file_info.size_in_llinks+max_llinks_per_seg-1, max_llinks_per_seg, 17); total_bit_count = gcos_file_info.size_in_llinks*BITS_PER_LLINK; /* BITS_PER_LLINK = 320 * 36 */ /* If only one component is to be created, do so. Otherwise, create a MSF with the required number of components. */ if ncomp = 1 then call Create_A_Seg (); else call Create_A_MSF (); /* We are all finished. Clean up and get out. */ a_code = code; return; /* This internal procedure creates a multisegment file with the proper bit count and access. */ Create_A_MSF: proc (); call hcs_$append_branchx (dname, ename, SMA, rings, user_id, 1, 0, (ncomp), code); if code ^= 0 then return; do component = 0 to ncomp-1; if total_bit_count <= max_bits_per_seg then bit_count = total_bit_count; else bit_count = max_bits_per_seg; total_bit_count = total_bit_count-bit_count; call ioa_$rsnnl ("^a^[>^]^a", msf_name, msf_name_len, dname, (dname ^= ">"), ename); call ioa_$rsnnl ("^d", comp_name, comp_name_len, component); call hcs_$append_branchx (substr (msf_name, 1, msf_name_len), substr (comp_name, 1, comp_name_len), RW, rings, user_id, 0, 0, bit_count, code); if code ^= 0 then do; call hcs_$delentry (dname, ename, ecode); return; end; end; return; end Create_A_MSF; /* This internal procedure creates a segment with the proper bit count and access. */ Create_A_Seg: proc (); bit_count = total_bit_count; call hcs_$append_branchx (dname, ename, RW, rings, user_id, 0, 0, bit_count, code); if code ^= 0 then return; end Create_A_Seg; end gcos_create_file_;  gcos_gsr_read_.pl1 11/19/82 1410.9rew 11/19/82 0930.4 65358 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This procedure will return one record from a gcos standard format 320 word block. It will read from the stream "attname" and return a pointer to the record just read in buffp, the length of the read data will be in reclen, the record header (media and report codes) will be in rcrdhdr, and eofsw will be set if this record is the last in the last block WRITTEN BY DICK SNYDER 1971 MODIFIED BY P.M. HABER SEPTEMBER 1973 MODIFIED BY T. CASEY APRIL 1974, AUGUST 1974, NOVEMBER 1974 */ gcos_gsr_read_: proc (attname, buffp, reclen, rcrdhdr, eofsw, fx_code); dcl attname char (*); dcl eofsw bit (1); dcl buffp ptr; dcl reclen fixed bin; dcl rcrdhdr bit (12); dcl fx_code fixed bin (35); dcl 1 word based aligned, 2 upper bit (18) unaligned, 2 lower bit (18) unaligned; dcl ios_$read ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl (error_table_$bad_file, error_table_$file_already_opened, error_table_$file_not_opened) ext fixed bin (35); dcl forcesw bit (1) init ("0"b); dcl (first, last) ptr int static init (null); dcl 1 c_block based (cp), /* control block for a file being read */ 2 name char (32), /* file name */ 2 mybuf char (1280), /* read buffer */ 2 rcrdp ptr, 2 myeofsw bit (1), 2 readsw bit (1), 2 blklen fixed bin, 2 forward ptr, 2 backward ptr; dcl cp ptr init (null) int static; dcl st bit (72) aligned; dcl code fixed bin (35) based (addr (st)); dcl stringlen fixed bin; dcl mybufp ptr; dcl j fixed bin; dcl (addr, addrel, baseno, fixed, null, substr) builtin; dcl closing bit (1) aligned init ("0"b); dcl get_system_free_area_ ext entry returns (ptr); dcl system_free_ptr ptr int static init (null); dcl system_free_area area based (system_free_ptr); /* */ COMMON: /* come here from gsr_read_close entry point */ fx_code = 0; /* initialize return code */ if first = null then go to error; /* attempt to read without initing */ cp = first; /* get ptr to first control block */ srch_loop: if attname = c_block.name then go to hit; cp = c_block.forward; if cp ^= null then go to srch_loop; /* continue to look */ error: fx_code = error_table_$file_not_opened; return; hit: if closing then goto nodata; /* if entered at gsr_read_close entry point */ mybufp = addr (c_block.mybuf); if readsw then do; if myeofsw then do; /* eof already encountered */ nodata: if c_block.backward = null then do; /* first block in chain */ first = c_block.forward; /* set first to point to next block */ if first ^= null then /* don't reference thru null ptr if only 1 block */ first -> c_block.backward = null; /* set back point in next block to null */ /* (it is new first blk) */ end; else if c_block.forward = null then do; /* last block in chain */ last = c_block.backward; /* set up new last ptr */ last -> c_block.forward = null; /* previous block is new last block */ end; else do; /* block is in middle of chain */ c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */ c_block.forward -> c_block.backward = c_block.backward; end; free cp -> c_block in (system_free_area); /* deallocate block */ if closing then return; /* if entered at gsr_read_close entry point */ eofsw = "1"b; reclen = 0; return; end; read: call ios_$read (attname, mybufp, 0, 320, j, st); if substr (st, 1, 3) = "100"b /* hardware status returned */ then do; if substr (st, 27, 4) = "0100"b /* "tape mark" status */ then do; myeofsw = "1"b; /* return eof condition to caller */ substr (st, 1, 36) = "0"b; /* and zero out returned error code */ end; else goto io_error; /* not "tape mark" status, error */ end; else /* not hardware status */ do; if code ^= 0 then do; /* error occurred */ io_error: fx_code = code; /* return error code */ return; end; myeofsw = substr (st, 1, 46); /* take eof switch from normal location */ end; readsw = "0"b; if j = 0 then go to nodata; /* nothing read */ rcrdp = addrel (mybufp, 1); /* point to first record */ blklen = fixed (mybufp -> word.lower, 17); /* reinit block len */ if blklen > 319 | blklen < 1 then do; /* test for legal block length */ buffp = mybufp; /* return pointer to bad bcw, in case caller wants to examine or display it */ goto fmt_err; end; end; if substr (rcrdp -> word.lower, 1, 6) = "001111"b then goto nodata; /* check for eof in rcw */ reclen = fixed (rcrdp -> word.upper, 17); /* get record len */ if reclen >= blklen | reclen > 318 | reclen = 0 then do; /* check for legal record length */ buffp = rcrdp; /* return pointer to bad rcw, in case caller wants to examine or display it */ goto fmt_err; end; rcrdhdr = substr (rcrdp -> word.lower, 7, 12); /* return report and media codes */ blklen = blklen - reclen - 1; /* decrement block len */ if blklen = 0 then readsw = "1"b; /* remember to read new block if end of block */ eofsw = "0"b; buffp = addrel (rcrdp, 1); /* point to data */ rcrdp = addrel (rcrdp, reclen+1); /* point to next record */ return; /* Come here if bcw or rcw had bad length field */ fmt_err: fx_code = error_table_$bad_file; goto nodata; /* Must enter here before reading to init control block */ gsr_read_init: entry (attname, fx_code); fx_code = 0; /* initialize return code */ if first = null then go to create; /* no blocks yet */ cp = first; /* see if guy is attmepting to init same file twice */ cr_loop: if attname = c_block.name then do; fx_code = error_table_$file_already_opened; return; end; if c_block.forward = null then go to create; cp = c_block.forward; /* on to next one */ go to cr_loop; create: if system_free_ptr = null then system_free_ptr = get_system_free_area_ (); allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */ if first = null then do; cp, first = last; /* this is first and only block */ c_block.backward = null; /* no back block */ end; else do; c_block.forward = last; /* fill in forward pointer in last block */ last -> c_block.backward = cp; /* fill in backward pointer in this block */ cp = last; /* point now to new block */ end; c_block.forward = null; /* no next block */ c_block.readsw = "1"b; /* cause read at next call */ c_block.myeofsw = "0"b; /* no eof */ c_block.name = attname; return; gsr_read_close: entry (attname, fx_code); closing = "1"b; goto COMMON; end gcos_gsr_read_;  gcos_gsr_write_.pl1 11/19/82 1410.9rew 11/19/82 0930.5 60561 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This procedure will write one record in gecos standard format. It will write blocks to the stream "attname", it will copy the record into a block from the place pointed to by buffp, it will copy the number of words specified by reclen, it will use the supplied report code, and if eofsw is on, it will force the current block to be written out even if not full ( and will not allow anymore write calls until reinitialized). WRITTEN BY DICK SNYDER 1971 MODIFIED BY P.M. HABER SEPTEMBER 1973 MODIFIED BY T. CASEY APRIL 1974 */ gcos_gsr_write_: proc (attname, buffp, reclen, report_code, eofsw, fx_code); dcl attname char (*); dcl eofsw bit (1); dcl report_code bit (12); dcl buffp pointer; dcl reclen fixed bin; dcl fx_code fixed bin (35); dcl 1 word based aligned, 2 upper bit (18) unaligned, 2 lower bit (18) unaligned; dcl ios_$write ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl (error_table_$file_not_opened, error_table_$file_already_opened) ext fixed bin (35); dcl thing char (20) varying; dcl forcesw bit (1) init ("0"b); dcl (first, last) pointer int static init (null); dcl 1 c_block based (cp), /* control block for a file being written */ 2 name char (32), /* file name */ 2 mybuf char (1280), /* write buffer */ 2 rcrdp pointer, 2 serial_no fixed bin, 2 blklen fixed bin, 2 forward pointer, 2 backward pointer; dcl cp pointer int static init (null); dcl st bit (72) aligned; dcl code fixed bin (35) based (addr (st)); dcl stringlen fixed bin; dcl basedstring bit (stringlen) based; dcl mybufp pointer; dcl j fixed bin; dcl (addr, addrel, baseno, null, unspec, substr) builtin; dcl closing bit (1) aligned init ("0"b); dcl get_system_free_area_ ext entry returns (ptr); dcl system_free_ptr ptr int static init (null); dcl system_free_area area based (system_free_ptr); COMMON: /* come here from gsr_write_close entry */ fx_code = 0; /* initialize return argument */ if first = null then go to error; /* attempt to write without initing */ cp = first; /* get pointer to first control block */ srch_loop: if attname = c_block.name then go to hit; cp = c_block.forward; if cp ^= null then go to srch_loop; /* continue to look */ error: fx_code = error_table_$file_not_opened; return; hit: if closing then goto free_buffer; /* if entered at gsr_write_close entry */ mybufp = addr (c_block.mybuf); if blklen = -1 then do; /* new block */ newblk: mybufp -> word.upper = substr (unspec (serial_no), 19, 18); /* put serial no in block */ serial_no = serial_no+1; /* update serial no */ blklen = 0; rcrdp = addrel (mybufp, 1); /* point to first record header */ end; if blklen + reclen > 318 then do; /* new record won't fit in current block */ force: mybufp -> word.lower = substr (unspec (blklen), 19, 18); /* put block len in block */ blklen = -1; call ios_$write (attname, mybufp, 0, 320, j, st); /* write block */ if code ^= 0 then do; fx_code = code; /* return error code */ return; end; if forcesw then do; /* all done if eof being written */ free_buffer: if c_block.backward = null then do; /* first block in chain */ first = c_block.forward; /* set first to point to next block */ if first ^= null then /* don't reference thru null ptr if only 1 block */ first -> c_block.backward = null; /* set back point in next block to null */ /* (it is new first block ) */ end; else if c_block.forward = null then do; /* last block in chain */ last = c_block.backward; /* set up new last pointer */ last -> c_block.forward = null; /* previous block is new last block */ end; else do; /* we have block in middle of chain */ c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */ c_block.forward -> c_block.backward = c_block.backward; end; free cp -> c_block in (system_free_area); /* deallocate block */ return; end; go to newblk; end; if reclen ^= 0 then do; rcrdp -> word.upper = substr (unspec (reclen), 19, 18); /* put record len in rcrd header */ rcrdp -> word.lower = "0"b; /* put report and */ substr (rcrdp -> word.lower, 7, 12) = report_code; /* media codes in rcrd header */ rcrdp = addrel (rcrdp, 1); /* now point to data area */ stringlen = 36*reclen; /* get length of rcrd in bits */ rcrdp -> basedstring = buffp -> basedstring; /* copy record into buffer */ rcrdp = addrel (rcrdp, reclen); /* point to next record header */ blklen = blklen+reclen+1; /* update block length */ end; forcesw = eofsw; /* supposed to write eof? */ if forcesw then go to force; /* yes */ return; /* Must enter here before writing to init control block */ gsr_write_init: entry (attname, fx_code); fx_code = 0; /* initialize returned code */ if first = null then go to create; /* no blocks yet */ cp = first; /* see if guy is attmepting to init same file twice */ cr_loop: if attname = c_block.name then do; fx_code = error_table_$file_already_opened; return; end; if c_block.forward = null then go to create; cp = c_block.forward; /* on to next one */ go to cr_loop; create: if system_free_ptr = null then system_free_ptr = get_system_free_area_ (); allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */ if first = null then do; cp, first = last; /* this is first and only block */ c_block.backward = null; /* no back block */ end; else do; c_block.forward = last; /* fill in forward pointer in last block */ last -> c_block.backward = cp; /* fill in backward pointer in this block */ cp = last; /* point now to new block */ end; c_block.forward = null; /* no next block */ c_block.blklen = -1; c_block.serial_no = 1; c_block.name = attname; return; gsr_write_close: entry (attname, fx_code); closing = "1"b; /* remember we are just going to free a buffer */ goto COMMON; /* go look for it */ end gcos_gsr_write_;  gcos_label_tape.pl1 11/19/82 1410.9rew 11/19/82 0918.5 150282 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_label_tape: gclt: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Written: Scott C. Akers FEB 82 */ /* Changed: Ron Barstad Oct 1982 To accept only 5 char for tape label */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* Syntax: gcos_label_tape REEL_NUM {NEW_NUM} {-control_args} Function: Writes a GCOS label on a tape. Arguments: REEL_NUM is the number on the label of the tape reel to be used. NEW_NUM is the new serial number to be written on the tape. If it is the same as the REEL_NUM, it may be omitted. Control arguments: -density N, -den N Specify the tape density. Default is 1600 BPI. -track N, -tk N Specify 7- or 9-track tape. Default is 9-track. -erase | -no_erase Erase/don't erase the tape before labeling it. Default is to overwrite the old label (if it exists), and leave the remaining data intact (-no_erase). Notes: If no control arguments are given, the command: gclt xyz12 is equivalent to the command: gclt xyz12 xyz12 -tk 9 -den 1600 -no_erase If conflicting control arguments are given, the rightmost control argument is used (e.g. "gclt m1266 -tk 7 -tk 9" will label a 9-track tape.) */ %page; call init_routine; /* Set default values. */ on condition (cleanup) begin; call close_file; goto exit_gclt; end; call cu_$arg_list_ptr (arg_list_ptr); /* Get an argument pointer. */ if get_args (arg_list_ptr) /* Validate the args. */ then if built_label () /* Try to build the label. */ then if tape_labeled () /* Attempt to do the labeling. */ then if label_ok () /* Make sure it matches. */ then call goodie_message; /* Tell user it succeeded. */ call close_file; /* Close and detach the tape. */ exit_gclt: ; return; %page; asc_to_bcd: proc (in_string, out_string, field_length) returns (bit (1)); /* Translates an ASCII character /* string to its BCD equivalent, /* padding on the right to fill /* output field. */ dcl field_length fixed bin parm; dcl in_string char (*) parm; dcl out_string bit (*) parm; error = "0"b; fill_count = 0; max_xlate = min (length (rtrim (in_string)), field_length); do counter = 1 to max_xlate while (^error); if in_char (counter) <= hbound (asc_to_bcd_table, 1) then do; out_char (counter) = asc_to_bcd_table (in_char (counter)); fill_count = fill_count + 1; end; else do; call com_err_ (error_table_$bad_conversion, MYNAME, "^/ASCII character ""^o"" has no BCD counterpart.", in_char (counter)); error = "1"b; end; end; if ^error then do counter = fill_count+1 to field_length; out_char (counter) = "20"b3; end; return (^error); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl error bit (1); dcl in_char (length (rtrim (in_string))) fixed bin (9) unsigned unaligned based (addr (in_string)); dcl max_xlate fixed bin; dcl out_char (field_length) bit (6) unaligned based (addr (out_string)); end asc_to_bcd; %page; built_label: proc returns (bit (1)); /* Fills in label structure. */ if new_vol_id = " " then new_vol_id = atd_structure.vol_id; /* Use old VOL_ID if new one not given. */ if asc_to_bcd ("ge 600 btl", tape_label.label_id, 12) then if asc_to_bcd (ascii_inst_id, tape_label.installation_id, 6) then if asc_to_bcd (" " || new_vol_id, tape_label.tape_serial_number, 6) then if asc_to_bcd (" " || new_vol_id, tape_label.file_serial_number, 6) then if asc_to_bcd (" 0001", tape_label.reel_sequence_number, 6) then if asc_to_bcd (" " || ascii_cr_date, tape_label.creation_date, 6) then if asc_to_bcd (" ", tape_label.file_name, 12) then if asc_to_bcd ("gcos env simulator", tape_label.blurb, 18) then if asc_to_bcd (" ", tape_label.blanks, 6) then return ("1"b); return ("0"b); end built_label; %page; close_file: proc; code = 0; if iocb_ptr ^= null () then do; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); call iox_$destroy_iocb (iocb_ptr, code); if code ^= 0 then call com_err_ (code, MYNAME, "^/Error while trying to detach/close ^a", stream_name); end; return; end close_file; %page; day_of_year: proc returns (char (3)); call datebin_$dayr_clk (clock_reading, num_day); return (ltrim (char (num_day,17))); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl num_day fixed bin; end day_of_year; %page; get_args: proc (arg_list_ptr) returns (bit(1)); /* Does the argument processing. */ dcl arg_list_ptr ptr parm; error = "0"b; call cu_$arg_count_rel (arg_count, arg_list_ptr, code); if code ^= 0 then do; call com_err_ (code, MYNAME); error = "1"b; end; if arg_count > 0 then do arg_no = 1 to arg_count while (^error); call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr); if code = 0 then do; if substr (arg, 1, 1) = "-" then do; error = ^valid_ctl_arg (arg); expect.new_vol_id = "0"b; end; else error = ^valid_vanilla_arg (arg); end; end; else do; call com_err_ (error_table_$noarg, MYNAME, "^/You must supply a reel number."); error = "1"b; end; return (^error); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl arg char (arg_len) based (arg_ptr); dcl error bit (1); end get_args; %page; goodie_message: proc; /* Tells user labeling succeeded. */ call ioa_ ("^/Tape# ^a labeled as ""^a""^/", atd_structure.vol_id, new_vol_id); return; end goodie_message; %page; init_routine: proc; /* Sets up default values. */ clock_reading = clock_ (); erase = "0"b; /* Default is to not erase. */ iocb_ptr = null (); unspec (compare_buffer) = "0"b; unspec (tape_label) = "0"b; unspec (expect) = "0"b; expect.reel_id = "1"b; new_vol_id = " "; atd_string = " "; /* Fill with blanks first. */ atd_structure.dim = "tape_nstd_"; /* Now fill in the goodies. */ atd_structure.tracks = "-track 9"; atd_structure.write = "-write"; atd_structure.block_size = "-block 2800"; atd_structure.density = "-density 1600"; ascii_cr_date = year_num () || day_of_year (); call system_info_$installation_id (ascii_inst_id); return; end init_routine; %page; label_ok: proc returns (bit (1)); call iox_$control (iocb_ptr, "rewind", (null ()), code); if code = 0 then call iox_$read_record (iocb_ptr, (addr (compare_buffer)), (14*4), return_count, code); if code = 0 then do; if tape_label_string ^= compare_buffer then do; code = error_table_$bad_label; call print_label_contents; end; end; else call com_err_ (code, MYNAME, "^/Error attempting to verify label."); return (code = 0); end label_ok; %page; print_label_contents: proc; call com_err_ (code, MYNAME, "^/Error while verifying label"); overlay_ptr = addr (tape_label); call com_err_$suppress_name (0,MYNAME, "^2^/^-EXPECTED DATA" ||"^/^w ^w ^w ^w" ||"^/^w ^w ^w ^w" ||"^/^w ^w ^w ^w" ||"^/^w ^w", dump_overlay (1), dump_overlay (2), dump_overlay (3), dump_overlay (4), dump_overlay (5), dump_overlay (6), dump_overlay (7), dump_overlay (8), dump_overlay (9), dump_overlay (10), dump_overlay (11), dump_overlay (12), dump_overlay (13), dump_overlay (14)); overlay_ptr = addr (compare_buffer); call com_err_$suppress_name (0,MYNAME, "^2^/^-ACTUAL DATA" ||"^/^w ^w ^w ^w" ||"^/^w ^w ^w ^w" ||"^/^w ^w ^w ^w" ||"^/^w ^w", dump_overlay (1), dump_overlay (2), dump_overlay (3), dump_overlay (4), dump_overlay (5), dump_overlay (6), dump_overlay (7), dump_overlay (8), dump_overlay (9), dump_overlay (10), dump_overlay (11), dump_overlay (12), dump_overlay (13), dump_overlay (14)); return; end print_label_contents; %page; tape_attached: proc returns (bit (1)); stream_name = "lbl_" || rtrim (atd_structure.vol_id); call iox_$attach_name (stream_name, iocb_ptr, atd_string, null (), code); if code = 0 then call iox_$open (iocb_ptr, (6), ("0"b), code); if code = 0 then call iox_$control (iocb_ptr, "rewind", (null ()), code); if code = 0 then if tape_erased () then code = 0; if code ^= 0 then call com_err_ (code, MYNAME, "^/Error while attaching/positioning tape."); return (code = 0); end tape_attached; %page; tape_erased: proc returns (bit (1)); code = 0; if erase then do; do while (code = 0); call iox_$control ( iocb_ptr, "erase", null (), code); end; if code = error_table_$tape_error then code = 0; if code = 0 then call iox_$control (iocb_ptr, "rewind", (null ()), code); if code ^= 0 then call com_err_ (code, MYNAME, "^/Error while erasing tape."); end; return (code = 0); end tape_erased; %page; tape_labeled: proc returns (bit (1)); if tape_attached () then do; call iox_$write_record (iocb_ptr, addr (tape_label), (14*4), code); if code ^= 0 then call com_err_ (code, MYNAME, "^/Error while trying to write new label."); else do; call iox_$control (iocb_ptr, "write_eof", (null ()), code); if code ^= 0 then call com_err_ (code, MYNAME, "^/Error while writing EOF. "); end; end; else code = error_table_$not_attached; return (code = 0); end tape_labeled; %page; valid_ctl_arg: proc (ctl_arg) returns (bit (1)); dcl ctl_arg char (*) parm; error = "0"b; if arg_no < 2 then do; call com_err_ (error_table_$noarg, MYNAME, "^/You must supply a reel number."); error = "1"b; end; else do; if ctl_arg = "-density" | ctl_arg = "-den" then expect.density = "1"b; else if ctl_arg = "-track" | ctl_arg = "-tk" then expect.track = "1"b; else if ctl_arg = "-erase" then erase = "1"b; else if ctl_arg = "-no_erase" then erase = "0"b; else do; call com_err_ (error_table_$bad_arg, MYNAME, "^/Argument: ^a",ctl_arg); error = "1"b; end; end; return (^error); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl error bit (1); end valid_ctl_arg; %page; valid_vanilla_arg: proc (vanilla_arg) returns (bit (1)); dcl vanilla_arg char (*) parm; error = "0"b; if expect.reel_id then do; if length (rtrim (vanilla_arg)) > 5 then do; call com_err_ (error_table_$bigarg, MYNAME, "^/Maximum of 5 characters for reel_id."); error = "1"b; end; else do; atd_structure.vol_id = rtrim (vanilla_arg); expect.new_vol_id = "1"b; expect.reel_id = "0"b; end; end; else if expect.new_vol_id then do; if length (rtrim (vanilla_arg)) > 5 then do; call com_err_ (error_table_$bigarg, MYNAME, "^/Maximum of 5 characters for new vol_id."); error = "1"b; end; else do; new_vol_id = rtrim (vanilla_arg); expect.new_vol_id = "0"b; end; end; else if expect.track then do; if vanilla_arg = "9" | vanilla_arg = "7" then do; atd_structure.tracks = "-track " || rtrim (vanilla_arg); expect.track = "0"b; end; else do; call com_err_ (0, MYNAME, "Only 7- or 9-track tapes may be specified."); error = "1"b; end; end; else if expect.density then do; if vanilla_arg = "6250" | vanilla_arg = "1600" | vanilla_arg = "800" | vanilla_arg = "556" | vanilla_arg = "200" then do; atd_structure.density = "-density " || rtrim (vanilla_arg); expect.density = "0"b; end; else do; call com_err_ (0, MYNAME, "Bad density specification: ^a" || "^/Valid densities:^-6250^-1600^-800^-556^-200", vanilla_arg); error = "1"b; end; end; return (^error); end valid_vanilla_arg; %page; year_num: proc returns (char (2)); call date_time_ (clock_reading, date_string); return (substr (date_string, 7, 2)); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl date_string char (50); end year_num; %page; dcl addr builtin; dcl arg_count fixed bin; dcl arg_len fixed bin (21); dcl arg_list_ptr pointer; dcl arg_no fixed bin; dcl arg_ptr pointer; dcl ascii_cr_date char (6); dcl ascii_inst_id char (20); dcl atd_string char (60) based (addr (atd_structure)); dcl char builtin; dcl cleanup condition; dcl clock_ entry() returns(fixed bin(71)); dcl clock_reading fixed bin (71); dcl code fixed bin (35); dcl com_err_ entry() options(variable); dcl com_err_$suppress_name entry() options(variable); dcl compare_buffer bit (14*36) aligned; dcl counter fixed bin; dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin(35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr); dcl datebin_$dayr_clk entry (fixed bin(71), fixed bin); dcl date_time_ entry (fixed bin(71), char(*)); dcl dump_overlay (14) bit (36) based (overlay_ptr); dcl erase bit (1); dcl error bit (1); dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$bad_label fixed bin (35) ext static; dcl error_table_$bigarg fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_attached fixed bin (35) ext static; dcl error_table_$tape_error fixed bin (35) ext static; dcl fill_count fixed bin; dcl hbound builtin; dcl ioa_ entry() options(variable); dcl iocb_ptr pointer; dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl iox_$close entry (ptr, fixed bin(35)); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl iox_$destroy_iocb entry (ptr, fixed bin(35)); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl length builtin; dcl ltrim builtin; dcl min builtin; dcl MYNAME char (10) internal static options (constant) init ("gclt"); dcl new_vol_id char (6); dcl null builtin; dcl overlay_ptr pointer; dcl return_count fixed bin (21); dcl rtrim builtin; dcl stream_name char (12); dcl system_info_$installation_id entry (char(*)); dcl substr builtin; dcl tape_label_string bit (14*36) based (addr (tape_label)); dcl unspec builtin; %page; dcl 1 tape_label aligned, 2 label_id bit (72) unaligned, 2 installation_id bit (36) unaligned, 2 tape_serial_number bit (36) unaligned, 2 file_serial_number bit (36) unaligned, 2 reel_sequence_number bit (36) unaligned, 2 creation_date bit (36) unaligned, 2 retention_days bit (36) unaligned, 2 file_name bit (72) unaligned, 2 blurb bit (108) unaligned, 2 blanks bit (36) unaligned; dcl 1 atd_structure aligned, 2 dim char (11) unaligned, 2 fill_1 char (1) unaligned, 2 vol_id char (6) unaligned, 2 fill_2 char (1) unaligned, 2 tracks char (8) unaligned, 2 fill_3 char (1) unaligned, 2 write char (6) unaligned, 2 fill_4 char (1) unaligned, 2 block_size char (11) unaligned, 2 fill_5 char (1) unaligned, 2 density char (13) unaligned; dcl 1 expect aligned, 2 reel_id bit (1) unaligned, 2 new_vol_id bit (1) unaligned, 2 density bit (1) unaligned, 2 track bit (1) unaligned; %page; %include asc_to_bcd_table; end gcos_label_tape;  gcos_sys_xlate_.alm 11/19/82 1410.9rew 11/19/82 0949.7 63648 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " " G C O S S Y S O U T T R A N S L A T O R " " This program takes 3 arguments. The first is a pointer to a 320 word buffer which " contains a GCOS system standard format block. The second is a pointer to an output area " for the translated output. The third is a return argument which is the number " of ascii characters which were placed in the output buffer. " " Certain special bcd character conventions are recognized: " " 17 ignored " 77n n is a line skip count unless n is 20 " in which case a skip to head of form " is called for. " 7777X put any character X in the buffer " " Two ASCII conventions are recognized: " " records with media codes > 5 are ASCII, and characters are copied without translation. " " records with media code = 6 have no trailing newlines, so one will be appended. " " " " INDEX REGISTER USAGE " " X1 holds remaining block size (in words) " X3 holds current offset in input buffer (characters) " X4 holds size of current record not yet processed (characters) " X5 holds size of current record (words) " X6 holds current offset in output buffer (characters) " " " " WRITTEN BY DICK SNYDER FEBRUARY 3,1971 " MODIFIED BY T. CASEY, AUGUST 1973, TO PRODUCE UPPERCASE OUTPUT " MODIFIED BY T. CASEY, MARCH 1974 TO: " IGNORE ANY GARBAGE IN RECORD AFTER 77n " MAKE UPPER OR LOWER CASE TRANSLATION AN OPTION " ACCEPT ASCII RECORDS " MODIFIED BY D. KAYDEN JANUARY 1975 TO USE EIS " MODIFIED BY R.H. MORRISON 5/19/76 " CHANGED uc_table AND lc_table TO CONFORM TO REAL GCOS " Modified by M. R. Jordan, September 1976 to process all printer escapes " MODIFIED BY: Dave Ward March 1978 TO: " Process overprint correctly, i.e., "!0" " BCD control sequence implies carriage-return. " " " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" name gcos_sys_xlate_ entry gcos_sys_xlate_ entry gcos_sys_xlate_lc_ gcos_sys_xlate_lc_: save eppbb lc_table point to lower case table tra get_args gcos_sys_xlate_: save eppbb uc_table point to upper case table get_args: spriap sp|0 save ap for return arg access eppbp ap|2,* eppbp bp|0,* bp->input buffer eppap ap|4,* eppap ap|0,* ap->output buffer eax6 0 set output buffer offset lxl1 bp|0 get block size eppbp bp|1 point to first record xlrcd: cmpx1 bp|0 make sure rec len < curr block len tmoz fini it isn't..we're done sbx1 bp|0 decrement remaining block size sbx1 1,du including rcw ldx5 bp|0 get record size tze fini yes..eof and end of block " " Check for ASCII media code, and set switches appropriately " lda bp|0 get media code from rcw als 26 by getting rid of the 26 bits to its left arl 32 and the 6 bits to its right eppbp bp|1 point to beginning of record data cmpa =8,dl tss type 8? tze endrec ignore this one cmpa =o5,dl ASCII or BCD? tpl xlasc if >= 5, its ASCII eaq 0,5 get record length in chars mpy 6,dl eax4 0,qu save it in x4 eax3 0 set char offset in record lp: stz tally tct (pr,x3,rl) scan for a "!" or "?" desc6a bp|0,x4 arg tctable arg tally lxl7 tally number of chars passed over tze lp1 none stx7 tally mvt (pr,x3,rl),(pr,x6,rl) translate nonedit chars passed over desc6a bp|0,x7 desc9a ap|0,x7 arg bb|0 adx3 tally increment input record offset adx6 tally increment output buffer offset sbx4 tally decrement remaining record length cmpx4 2,du at least 2 chars left ? tmi endrec done with record lp1: mlr (pr,x3),(pr),fill(00) extract next 3 chars desc6a bp|0,3 desc6a temp,6 lda temp ana =o770000,du examine first char cmpa =o770000,du is it a "!" tnz ignore no - must be a "?" lda temp examine second character ana =o7700,du cmpa =o7700,du is it another "!" tnz space no - form spacing request cmpx4 3,du were there 3 chars left tmi endrec no - done with record mvt (pr),(pr,x6) translate third char desc6a temp(2),1 desc9a ap|0,1 arg bb|0 adx6 1,du increment output buffer offset adx3 3,du increment input record offset sbx4 3,du decrement remaining record length tpnz lp scan rest of record tra endrec done with record ignore: adx3 1,du increment input record offset sbx4 1,du decrement remaining record length tpnz lp scan rest of record tra endrec done with record " " " Come here when other than an ignore or escaped print is to be performed. " " space: arl 6+4 split the key and value tra *+1,au do the right thing tra feed_countdown 00xxxx => feed by countdown tra feed_vfu 01xxxx => feed to xxxx on VFU loop tra insert_spaces 10xxxx => insert 8*xxxx spaces null 11xxxx => if not 77(8) then no action no_action: adx3 2,du increment input record offset sbx4 2,du decrement remaining record length tpnz lp scan rest of record tra endrec done with record insert_spaces: als 4+3 get 8*xxxx in au ana =o170,du mlr (),(pr,x6,rl),fill(040) desc9a *,0 desc9a ap|0,au sta temp save the number of spaces inserted adx6 temp update the output offset adx3 2,du increment the input record offset sbx4 2,du decrement the remaining record length tpnz lp scan rest of record tra endrec done with record feed_vfu: mlr (),(pr,x6),fill(014) desc9a *,0 desc9a ap|0,1 adx6 1,du tra endrec feed_countdown: tnz feeds " Provide for !0 => overprint. " Output 1 carriage return. lda 1,du mrl (),(pr,x6,rl),fill(015) desc9a *,0 desc9a ap|0,au tra fin_feeds " Provide newlines. " Number of newlines in a-reg bits 18-21. feeds: als 4 get the number of lines ana =o17,du mlr (),(pr,x6,rl),fill(012) desc9a *,0 desc9a ap|0,au add right number of newlines fin_feeds: sta temp adx6 temp increment output buffer offset endrec: eppbp bp|0,5 move pointer to next record cmpx1 0,du end of block yet ? tnz xlrcd no fini: eppap sp|0,* restore ap stz ap|6,* return no of chars sxl6 ap|6,* return xlasc: eaq 0,5 get record length in chars qls 2 mlr (pr,rl),(pr,x6,rl) desc9a bp|0,qu desc9a ap|0,qu stq temp adx6 temp increment output buffer offset cmpa 6,dl is this media code 6 tnz endrec no mlr (),(pr,x6),fill(012) add a newline desc9a *,0 desc9a ap|0,1 adx6 1,du increment output buffer offset tra endrec " " " Translation tables...BCD to ASCII " " uc_table: aci x0123456789[#@:>?x aci x ABCDEFGHI&.](<\x aci x^JKLMNOPQR-$*);'x aci x+/STUVWXYZ_,%="!x lc_table: aci X0123456789[#@:>?X aci X abcdefghi&.](<\X aci X^jklmnopqr-$*);'X aci X+/stuvwxyz_,%="!X tctable: dec 0,0,0,1 dec 0,0,0,0 dec 0,0,0,0 dec 0,0,0,1 temp temp,tally end  gcos_sysprint.pl1 11/19/82 1410.9rew 11/19/82 0948.9 285273 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_sysprint: gsp: proc; /* GSP will translate a sysout or print file, produced by the gcos environment simulator, from BCD to ASCII, and either print it on the user's terminal, or write it into a file (whose pathname is supplied) for later dprinting. USAGE: gcos_sysprint input_path {output_path} {-lower_case} 1) input_path is the pathname of a sysout or print file. If it contains the special records that are placed in the output file by the simulator, it will be treated as a sysout file, and: a) The execution report will be located within the file and printed first and b) The records for each activity will be grouped by report code, and printed for each activity. Otherwise, the file will be treated as a print file, and its records will be converted and printed in the order in which they appear in the input file, with no grouping or reordering of any kind. 2) output_path is the optional pathname of an output file. If it is not supplied, lines will be printed on the terminal as they are converted. If the file already exists, it will be replaced with no warning. 3) -lower_case (-lc) is an optional control argument whose use will cause BCD alphabetic characters to be translated to lower case ASCII, instead of the default of upper case. Translation is performed by gcos_sys_xlate_ (or its entry point, gcos_sys_xlate_lc_, if -lower_case is given), which will recognize ASCII media codes (those >= 5), and copy the ASCII characters without translation, allowing mixed upper and lower case output to be produced from ASCII input records. */ %page; /* *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* HISTORY *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* */ /* Author: Dick Snyder 1971 Change: Tom Casey Sep73, Dec73, Mar74, Aug74 Change: Dave Ward 01/13/81 Change: Dave Ward 01/20/81 potential bug indexing pdstring. Change: Dave Ward 02/17/81 write_line proc. Delete initial form feed. Change: Scott C. Akers 09/24/81 Rewrite the whole thing from scratch, using iox_ instead of ios_, increasing the modularity of the program, and chopping out oodles of GOTOs. Eliminate sorting of report codes. Ignore -temp_dir ctl_arg. Change: Ron Barstad 10/07/82 Increased size of outbuf to accomidate possible conversion of bcd control sequences into more than 1 ascii char */ %page; /* D__e_t_a_i_l_s GSP processes two kinds of files: regular GCOS ASCII files, and files which contain BCD print_line images (variable-length records). When GSP is first called, it checks the file to see if it's a vanilla-flavored GCOS file, or a SYSOUT file. It then calls one of two routines, if the file fits one of these categories, or prints an error messages and quits if the file is inconsistent or nonconforming. The first (and simplest) routine is "process_simple_file", which converts GCOS ASCII files to Multics ASCII in a form suitable for printing. It simply reads a block from the input file, and ships it off to write_line for conversion and printing. The second is "process_sysout_file", which searches the input file for the execution report, and prints it first. If there is no execution report, a warning is printed. Once the execution report (if it exists) has been processed, we search for the individual activities which make up the rest of the file. They are already ordered within the file, but the reports within an activity are not grouped neatly together. Instead, it is possible that some records for report 74 will be followed by a few records for report 00, and then some more stuff for 74. It is the responsibility of GSP to collect all the records with matching report codes before we can process the next report. Each activity has an offset relative to the beginning of the input file. The offset (in 320-word blocks) is placed in the acty_table entry corresponding to the ordinal number of the activity. In order to find all the records which belong to a specific report, we have two routines, "find_next_rept_code" and "find_current_report_code", which scan each activity looking for report codes. As each report code is encountered, an entry is made for it in the "encountered" table. Once all records in a given report are printed, an entry for that report code is made in the "done" table. This insures that the report code will not be considered again within this activity. << continued >> */ %page; /* The actual output mechanism is fairly straightforward, but tedious. Once a block is read in, it is scanned for occurrences of the current report code. Each record which contains the current report code is placed in an output block, and its length is added to the SIZE field of the output block control word (BCW). When the input block is exhausted, the output block is shipped off to write_line for conversion and printing. There were other possible methods for accomplishing the task. The original method was to gather up all the records for one report, and put them in a separate file. Then, the next report was gathered up and put away. This continued until all the records had been picked up and put somewhere else. This entailed the opening of up to 65 or 70 files for a large, complicated activity. The process directory was often not large enough to hold all these, and a special directory had to be specified as a workspace. It was also necessary to move all that data back together again to assemble the final report. This was very costly. Another method made use of a linked list to keep track of each record in the file. This, too, entails some overhead, and the list could (potentially) be too large to fit in a single segment, and would overflow the process_directory. The big advantage of this method is that it does not require shuffling large amounts of data from file to file except for the final output stage. It does, however, necessitate the maintenance of a segment or segments (each 255 pages long) to hold the list, so there is still the potential need to specify a directory for workspace. The method I finally chose involves a bit more data-shuffling, but requires no more than two files to be open during the invocation of the command. These are, naturally, the input and (possibly) output files. If the output is to be directed to the user's terminal, only the input file is opened. This completely eliminates the need for a workspace directory of any kind, because data is moved from the input file as needed, converted, and placed in the output file. No extra files are needed, regardless of the size of the input or output files. Upon looking over the declarations, you will notice that there are some moderately kinky uses of based structures. Please be careful when modifying the code, since pointers are fragile creatures. It is not at all uncommon to change a pointer and discover that your I/O control block has magically disappeared. << END >> */ %page; on condition (cleanup) /* Set up handlers. */ goto abnormal_exit; call cu_$arg_count (nargs); if nargs = 0 then do; call com_err_ (error_table_$noarg, /* No arguments. */ ENTRY_NAME, USAGE); goto quick_exit; end; call init_routine; /* Initialize before reading args. */ call cu_$arg_list_ptr (arglistp); /* Get a pointer to the args */ call process_args; /* Process the args */ if code ^= 0 then goto abnormal_exit; /* Bail out if error. */ call check_file; /* See if file is sysout or vanilla flavored. */ if code ^= 0 then do ; call com_err_ (code, ENTRY_NAME, "^/^a",real_path); goto abnormal_exit; end; if sysout_sw then call process_sysout_file; else call process_simple_file; if code = 0 then goto normal_exit; else goto abnormal_exit; normal_exit: ; /* If all goes well */ abnormal_exit: ; /* When all doesn't go well */ call fixup_before_dying; /* Don't leave loose ends dangling */ quick_exit: ; /* Bail out if no args specified */ return; %page; attach_stream: proc (stream_name, iocb_ptr, /* attaches all I/O streams */ pathname, mode); dcl stream_name char(*) parm; /* INPUT */ dcl iocb_ptr pointer parm; /* INPUT */ dcl pathname char(168) parm; /* INPUT */ dcl mode char(2) parm; /* INPUT */ dcl attach_descr char(200); dcl open_mode fixed bin; dcl (stream_io init (3), stream_in init (1) ) fixed bin internal static options (constant); attach_descr = "vfile_ " || pathname; /* Build the attach description */ call iox_$attach_name (stream_name, iocb_ptr, attach_descr, (null), code); if code = 0 /* Don't mess with this unless */ | code = error_table_$noentry /* the attachment went O.K. */ then do; code = 0; if mode = "r" then open_mode = stream_in; else open_mode = stream_io; call iox_$open (iocb_ptr, open_mode, ("0"b), code); end; return; end attach_stream; %page; build_block: proc; /* Build a block for output */ BCW.BSN = BCW.BSN + 1; /* Set this so write_line knows there's a valid block. */ RECORD_PTR = addr (BLOCK.DATA); block_ptr = addr (BCW.data); /* Set up pointer to output block. */ BCW.block_size = 0; /* Start with empty output block. */ rec_count = 0; do while (rec_count < BLOCK.SIZE); /* Move all records whose report code matches the current one. */ if RCW.REPORT_CODE = current_rept_code then do; out_record = in_record; BCW.block_size = BCW.block_size + RCW.LENG + 1; block_ptr = addrel (block_ptr, RCW.LENG + 1); end; rec_count = rec_count + RCW.LENG + 1; RECORD_PTR = addrel (RECORD_PTR, RCW.LENG + 1); end; return; end build_block; %page; check_file: proc; /* See if file is sysout or simple file. If it's sysout, then set sysout_sw. If it's not a legal GCOS file, return a non-zero error code. */ call rewind_file (in_ptr); if code = 0 then do; call read_stream (in_ptr, buffp, 16, dummy); if code = 0 then do; if BCW.BSN ^= 1 then code = error_table_$bad_file; else do; if first_record.rec1 = "rec1" then sysout_sw = "1"b; else sysout_sw = "0"b; end; end; end; else code = 0; return; end check_file; %page; detach_stream: proc (iocb_ptr); /* Detach an I/O stream */ dcl iocb_ptr pointer parm; /* INPUT */ if iocb_ptr ^= null then do; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); call iox_$destroy_iocb (iocb_ptr, code); end; return; end detach_stream; %page; expand_path: proc (n, in_path, dir_name, e_name)returns (bit (1)); /* Expand in_path into dir_name and e_name and combine the two into real_path. */ dcl dir_name char(*) parm; /* OUTPUT */ dcl e_name char(*) parm; /* OUTPUT */ dcl n fixed bin parm; /* INPUT */ dcl in_path char(*) parm; /* INPUT */ call expand_pathname_ (in_path, dir_name, e_name, code); if code = 0 then do; real_path = rtrim (dir_name) || ">" || rtrim (e_name); return ("0"b); end; else do; call com_err_ (code, ENTRY_NAME, "^/""^a""^[ (arg ^i)^;^s^]", in_path, n>0, n); return ("1"b); end; end expand_path; %page; find_activities: proc; /* Find activities in a sysout file */ call rewind_file (in_ptr); if code = 0 then do; acty_table (1) = 0; /* First activity */ acty_index = 2; acty_count, acty_offset = 0; unspec (buffer) = "0"b; more_actys = "1"b; do while (more_actys); /* Pick up all the activity offsets. */ acty_table (acty_index) = 0; acty_offset = 0; do while (acty_offset = 0); call read_stream (in_ptr, /* Grab a block */ buffp, (sysout_chunk.chars), dummy); if code ^= 0 | eofsw /* We should NEVER have an EOF. /* We'll know we're done when /* we see the "start ex rpt" string. */ then do; if code = 0 then code = error_table_$end_of_info; call com_err_ (code, ENTRY_NAME, "^/Error while reading input file."); end; else do; acty_offset = index (buffer, "start ex rpt"); if acty_offset = 0 then do; acty_offset = index (buffer, "end activity"); if acty_offset > (4 * BCW.block_size) then acty_offset = 0; acty_table (acty_index) = acty_table (acty_index) + sysout_chunk.blocks; end; else do; more_actys = "0"b; end; end; end; acty_index = acty_index + 1; end; acty_count = acty_index - 3; end; return; end find_activities; %page; find_current_rept_code: proc; /* Scan the block for the current report code (current_rept_code), and set "found" true if we find it. Otherwise, leave it false. As we're doing this, we also make entries in the "encountered" table, so we know what report codes are left to be checked. */ rec_count = 0; found = "0"b; RECORD_PTR = addr (BLOCK.DATA); do while (rec_count < BLOCK.SIZE); encountered (RCW.REPORT_CODE) = "1"b; if RCW.REPORT_CODE = current_rept_code & ^done (current_rept_code) then found = "1"b; rec_count = rec_count + RCW.LENG + 1; RECORD_PTR = addrel (RECORD_PTR, RCW.LENG+1); end; return; end find_current_rept_code; %page; find_next_rept_code: proc; /* Scan the block for the next report code. Note: This routine cannot be merged with find_current_rept code because it is not always called. */ rec_count = 0; RECORD_PTR = addr (BLOCK.DATA); current_rept_code = 62; /* Gotta pretend we've already got a dead one. */ do while (rec_count < BLOCK.SIZE & done (current_rept_code)); encountered (RCW.REPORT_CODE) = "1"b; current_rept_code = RCW.REPORT_CODE; rec_count = rec_count + RCW.LENG + 1; RECORD_PTR = addrel (RECORD_PTR, RCW.LENG+1); end; if ^done (current_rept_code) /* If we find a winner */ then call make_rept_code_banner; /* then print the banner. */ return; end find_next_rept_code; %page; fixup_before_dying: proc; /* clean up for both normal and abnormal terminations */ call detach_stream (in_ptr); call detach_stream (out_ptr); return; end fixup_before_dying; %page; init_routine: proc; /* Perform initialization stuff */ in_dir, in_ent, out_dir, out_ent = " "; out_stream = "user_output"; in_ptr, out_ptr = null; sysout_sw = "0"b; buffp = addr (buffer); outbufp = addr (outbuf); recbuffp = addrel (buffp, 1); recordp = addrel (buffp,2); output_record_count = 0; acty_table = 0; do ptr_index = 0 to (chunk_size.blocks - 1); buff_ptr(ptr_index) = addrel (buffp, (320*ptr_index)); end; return; end init_routine; %page; make_rept_code_banner: proc; /* Prints report code headers on terminal or output file. */ if out_ptr = null then call ioa_$ioa_switch (iox_$user_output, "^2/ SNUMB# ^5a, Activity # ^2d, REPORT CODE = ^2o^2/", snumb, acty_index, current_rept_code); else call ioa_$ioa_switch (out_ptr, "^| SNUMB# ^5a, Activity # ^2d, REPORT CODE = ^2o^2/", snumb, acty_index, current_rept_code); return; end make_rept_code_banner; %page; more_reports_in_acty: proc returns (bit (1)); /* Returns true if there are more reports in the current activity, and returns false otherwise. */ match = "0"b; do test_index = 0 to 63 while (^match); match = (encountered (test_index) & ^done (test_index)); end; return (match); dcl match bit(1); dcl test_index fixed bin; end more_reports_in_acty; %page; position_file: proc (file_ptr, file_position); /* Sets the file pointer to the indicated word */ dcl file_ptr ptr parm; /* INPUT */ dcl file_position fixed bin (21) parm; /* INPUT */ call iox_$position (file_ptr, (2), (4 * file_position), code); return; end position_file; %page; process_args: proc; /* Argument processing. If an error occurs, it is reported here, so the caller doesn't have to do anything but die. */ do argno = 1 to nargs; call cu_$arg_ptr_rel (argno, argp, argl, code, arglistp); if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "^/Arg ^i.", argno); goto exit_p_a; end; if argno = 1 then do; /* First arg must be input file. */ in_stream = "gcos_sysprint_input_"; if expand_path (argno, arg, in_dir, in_ent) then do; code = error_table_$badopt; call com_err_ (code, ENTRY_NAME, "^/Arg #^i (^a)", argno, arg); goto exit_p_a; end; call attach_stream (in_stream, in_ptr, real_path, "r"); if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "^/Cannot attach input stream ^a:^/^a", in_stream, real_path); goto exit_p_a; end; end; /* END OF ARG 1 PROCESSING */ /* Get possible second argument - name of file to write output into */ else if argno = 2 then do; if substr (arg, 1, 1) = "-" then do; /* must be control arg */ call process_ctl_arg; if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "^/Arg #^i (^a)", argno, arg); goto exit_p_a; end; end; else do; filesw = "1"b; /* it must be a file name */ out_stream = "GSP_output_"; /* write output file thru this stream */ if expand_path (argno, arg, out_dir, out_ent) then do; call com_err_ (code, ENTRY_NAME, "^/Arg #^i (^a)", argno, arg); goto exit_p_a; end; call attach_stream (out_stream, /* attach output name */ out_ptr, real_path, "rw"); if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "^/Cannot attach output stream ^a:^/^a", out_stream, real_path); goto exit_p_a; end; end; end; /* END OF ARG 2 PROCESSING */ else if temp_sw then temp_sw = "0"b; /* if previous arg was -temp_dir, this is the path */ else do; call process_ctl_arg; if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, arg); goto exit_p_a; end; end; end; exit_p_a: ; return; end process_args; %page; process_ctl_arg: proc; /* Parse the control arguments */ code = 0; if arg = "-lc" | arg = "-lower_case" then lc_switch = "1"b; else if arg = "-td" | arg = "-temp_dir" then temp_sw = "1"b; /* path of temp_dir will be next arg */ else code = error_table_$badopt; return; end process_ctl_arg; %page; process_ex_rept: proc; /* Process the execution report */ acty_index = 0; /* For write_line, if error */ call rewind_file (in_ptr); if code = 0 then call read_stream (in_ptr, buffp, 28, dummy); /* Get info for execution report */ if code = 0 then do; snumb = first_record.jobs_snumb; /* Pick up SNUMB and EX REPT offset */ if first_record.er_offset = 0 then do; call com_err_ (0, ENTRY_NAME, "WARNING: Incomplete sysout file - execution report missing"); end; else do; call position_file (in_ptr, (first_record.er_offset)); if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "Attempting to position input file"); end; else do; call read_stream ( in_ptr, buffp, (chunk_size.chars), dummy); do while (^eofsw & code = 0); do ptr_index = 0 to (output_block_count - 1) while (code = 0); buffp = buff_ptr (ptr_index); call write_line; end; if code = 0 then do; buffp = addr (buffer); call read_stream ( in_ptr, buffp, (chunk_size.chars), dummy); end; end; end; end; end; return; end process_ex_rept; %page; process_rept_codes: proc; /* Collect and print report codes within an activity. */ /* Determine the absolute file position for this activity. */ acty_offset = acty_offset + (320 * acty_table (acty_index)); done, encountered = "0"b; /* Reset the "done" flags for this activity. */ current_rept_code = 62; /* Force a guaranteed non-kosher report code (76 octal). */ encountered (62) = "1"b; /* Gotta fake out the "more report" finder. */ do while (code = 0 & more_reports_in_acty ()); done (62) = "1"b; /* So we don't keep looking for this rept code */ call position_file (in_ptr, (acty_offset)); do rept_index = 1 to acty_table (acty_index+1) while (code = 0); call read_stream ( in_ptr, addr (BLOCK), 1280, dummy); if code = 0 then do; if done (current_rept_code) then call find_next_rept_code; /* Find the next report code */ if ^done (current_rept_code) then do; call find_current_rept_code; /* Scan block for current report code. */ if found /* If we find it */ then do; call build_block; /* Build the output block. */ call write_line; /* Write block to output stream. */ end; end; end; end; done (current_rept_code) = "1"b; /* Mark this report code as "used up". */ end; return; end process_rept_codes; %page; process_simple_file: proc; /* Process a regular GCOS file */ call rewind_file (in_ptr); /* Rewind the input file */ call read_stream (in_ptr, /* Pick up the first 3 blocks. */ buffp, (chunk_size.chars), dummy); if code ^= 0 | eofsw then call com_err_ (code, ENTRY_NAME, "^/Error while reading ^a", in_stream); else do while (^eofsw); do ptr_index = 0 to (output_block_count - 1); buffp = buff_ptr (ptr_index); call write_line; end; buffp = addr (buffer); call read_stream (in_ptr, buffp, (chunk_size.chars), dummy); end; return; end process_simple_file; %page; process_sysout_file: proc; /* Process a SYSOUT file */ call process_ex_rept; /* Do the execution summary first. */ if code = 0 /* Bail out if it blows up. */ then do; call find_activities; /* Locate all the activities in this file. */ call rewind_file (in_ptr); acty_offset = 0; /* Reset the activity offset, because we use it in the report-code processor to determine our absolute file position. */ do acty_index = 1 to acty_count; BCW.BSN = 0; /* Reset before each activity. */ call process_rept_codes; end; end; return; end process_sysout_file; %page; read_stream: proc (iocb_ptr, buffer_ptr, how_many, qty_got); /* Read from the indicated stream and place the data in the buffer pointed to by buffer_ptr. If fewer than the requested number of characters are read, we set a flag, and return the EOF indication the next time around. If the read comes up short for any reason other than error_table_$short_record, we return an error. */ dcl (iocb_ptr, buffer_ptr) ptr parm; /* INPUT, INPUT */ dcl (how_many, qty_got) fixed bin (21) parm; /* INPUT, OUTPUT */ dcl short_switch bit (1) internal static init ("0"b); if short_switch then do; eofsw = "1"b; short_switch = "0"b; end; else do; eofsw = "0"b; call iox_$get_chars ( iocb_ptr, buffer_ptr, how_many, qty_got, code); if code ^= 0 then if code = error_table_$end_of_info then do; eofsw = "1"b; code = 0; end; else if code = error_table_$short_record /* Short blocks are O.K. We'll get an EOF next time 'round. */ then do; code = 0; short_switch = "1"b; end; end; output_block_count = ceil (divide (qty_got, (4*320), 17)); return; end read_stream; %page; rewind_file: proc (iocb_ptr); /* Rewind the specified file */ dcl iocb_ptr ptr parm; /* INPUT */ call iox_$position (iocb_ptr, (-1), 0, code); if code ^= 0 then call com_err_ (code, ENTRY_NAME, "^/Could not rewind file."); return; end rewind_file; %page; write_line: proc; /* Write the next output line. */ if BCW.BSN ^= 0 & BCW.block_size ^= 0 then do; if lc_switch /* if -lowercase control argument given */ then call gcos_sys_xlate_lc_ (buffp, /* translate buffer from BCD to lowercase ASCII */ outbufp, conv_count); else call gcos_sys_xlate_ (buffp, /* translate buffer from BCD to uppercase ASCII */ outbufp, conv_count); output_record_count = output_record_count + 1; j = conv_count; if output_record_count = 1 & char1 = "014"b3 then call write_stream (out_ptr, addr (out1(2)), (j-1)); else call write_stream (out_ptr, outbufp, (j)); if code ^= 0 then do; call com_err_ (code, ENTRY_NAME, "^/Error attempting to write Activity # ^2d." || "^/Block # ^6o (octal), ^6d (decimal)^/", acty_index, BCW.BSN, BCW.BSN); end; end; return; end write_line; %page; write_stream: proc (iocb_ptr, buffer_ptr, qty_sent); /* Write on the specified output stream */ dcl stream_ptr ptr; dcl (iocb_ptr ptr, /* INPUT */ buffer_ptr ptr, /* INPUT */ qty_sent fixed bin (21) ) parm; /* INPUT */ if iocb_ptr = null /* See if terminal I/O */ then stream_ptr = iox_$user_output; else stream_ptr = iocb_ptr; call iox_$put_chars (stream_ptr, buffer_ptr, qty_sent, code); return; end write_stream; %page; /* Variables for gcos_sysprint: */ /* IDENTIFIER ATTRIBUTES */ dcl acty_table (1:64) fixed bin (35); dcl (acty_index, acty_count, acty_offset) fixed bin; dcl (addr, addrel) builtin; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl arglistp pointer; dcl block_ptr pointer; dcl buffer char (chunk_size.chars); dcl buffp pointer; dcl buff_ptr (0:chunk_size.blocks) pointer; dcl ceil builtin; dcl char1 bit(9) unaligned based (outbufp); dcl 1 chunk_size internal static aligned options (constant), 2 blocks fixed bin init (3), 2 words fixed bin init (960), 2 chars fixed bin init (3840); dcl cleanup condition; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl conv_count fixed bin; dcl cu_$arg_count ext entry (fixed bin); dcl cu_$arg_ptr_rel ext entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr); dcl cu_$arg_list_ptr ext entry (ptr); dcl divide builtin; dcl done (0:63) bit (1); dcl encountered (0:63) bit (1); dcl ENTRY_NAME char(19) int static options (constant) init ("gcos_sysprint(10.0)"); dcl eofsw bit (1); dcl (error_table_$badopt, error_table_$bad_file, error_table_$end_of_info, error_table_$noarg, error_table_$noentry, error_table_$short_record ) ext fixed bin (35); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl filesw bit (1) init ("0"b); dcl file_index fixed bin init (-1) /* current file index used */; dcl found bit (1); dcl gcos_sys_xlate_ ext entry (pointer, pointer, fixed bin); dcl gcos_sys_xlate_lc_ ext entry (pointer, pointer, fixed bin); dcl index builtin; dcl in_dir char(168); dcl in_ent char(32); dcl in_ptr pointer; dcl in_record char (4*(RCW.LENG+1)) based (RECORD_PTR); dcl in_stream char(32); dcl (ioa_$ioa_switch entry() options(variable), iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)), iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)), iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)), iox_$close entry (ptr, fixed bin(35)), iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)), iox_$detach_iocb entry (ptr, fixed bin(35)), iox_$destroy_iocb entry (ptr, fixed bin(35)), iox_$user_output pointer static ) external; dcl j fixed bin(21); dcl lc_switch bit (1) aligned init ("0"b) /* "1"b => "-lower_case was given" */; dcl more_actys bit (1); dcl nargs fixed bin; dcl null builtin; dcl current_rept_code fixed bin (6) unsigned unaligned; dcl out1 (2) char(1) unaligned based (outbufp); dcl outbuf char (2100); dcl outbufp pointer; dcl output_block_count fixed bin; dcl output_record_count fixed bin; dcl out_dir char(168); dcl out_ent char(32); dcl out_ptr pointer; dcl out_record char (4*(RCW.LENG+1)) based (block_ptr); dcl out_stream char(32); dcl ptr_index fixed bin; dcl rec_count fixed bin (35); dcl recbuffp ptr; dcl recordp pointer; dcl rept_index fixed bin (35); dcl rtrim builtin; dcl snumb char (5) init (""); dcl substr builtin; dcl 1 sysout_chunk internal static options (constant), 2 blocks fixed bin (21) init (1), 2 words fixed bin (21) init (320), 2 chars fixed bin (21) init (1280); dcl sysout_sw bit (1) aligned /* "1"b => "this is a sysout file" */; dcl temp_sw bit (1) aligned init ("0"b) /* on when path of temp dir expected */; dcl real_path char (168); dcl unspec builtin; dcl USAGE char(78)static int options(constant) init( "^/USAGE: gcos_sysprint input_path {output_path} {-lower_case}" ); dcl 1 first_record aligned based (recordp), /* overlay for very first record of a sysout file */ 2 newline_word bit (36), /* contains BCD newline, for benefit of gcos_sys_xlate_ */ 2 rec1 char (4), /* must = "rec1" before we believe the rest of this stuff */ 2 er_offset fixed bin aligned, /* offset to seek to, to read execution report */ 2 jobs_snumb char (5) /* snumb of this job, for heading lines */; dcl 1 BCW aligned based (buffp), 2 BSN fixed bin (18) unsigned unaligned, 2 filler_1 bit (9) unaligned, 2 block_size fixed bin (9) unsigned unaligned, 2 data char (1276) unaligned; dcl dummy fixed bin (21); %page; %include gcos_block_overlay; end gcos_sysprint;  gcos_syspunch.pl1 11/19/82 1544.7rew 11/19/82 1544.1 112446 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This procedure takes a segment which contains BCD and/or binary card images in GCOS standard format and produces another segment, NAME.raw, which is acceptable for punching by the daemon in "raw" mode. */ %page; /* Written by Dick Snyder ??? 71 Modified by P. Haber AUG 73 Modified by T. Casey DEC 74 Modified by R.H. Morrison MAY 76 Modified by S. C. Akers NOV 81 Clean up after termination. Improve modularity. Perform argument validation. Convert to iox_. Change expand_path_ to expand_pathname_. Eliminate use of gcos_gsr_read_. Remove GOTOs. */ %page; gcos_syspunch: gspn: proc; on condition (cleanup) call syspunch_cleanup; call process_arg; /* Check for legal pathname. */ if code = 0 then do; call attach_input; /* Attach the I/O streams. */ if code = 0 then do; call attach_output; if code = 0 then call convert_file; /* Do the actual work. */ end; call syspunch_cleanup; /* Clean up after ourselves */ end; return; %page; attach_input: proc; /* Attach the input stream. */ call iox_$attach_name ("gcos_syspunch_input_", in_ptr, "vfile_ " || in_path, (null), code); if code = 0 then call iox_$open (in_ptr, 1, ("0"b), code); if code ^= 0 then call com_err_ (code, my_name, "^/^a", in_path); return; end attach_input; /* ****************************************************************************************** ****************************************************************************************** ****************************************************************************************** */ attach_output: proc; /* Attach the output stream. */ call hcs_$make_seg ((out_dir), out_name, "", 11, out_ptr, code); if code ^= 0 then do; if code = error_table_$segknown | code = error_table_$namedup then code = 0; /* Certain codes are O.K. */ else call com_err_ (code, my_name, "^/^a", out_path); end; return; end attach_output; %page; convert_bcd: proc; /* Convert a BCD card image. */ do i = 1 to record_len; /* Put a punch image of BCD char in card image */ out_olay.cols (i) = transmog (fixed (bit (in_olay (i), 6), 17)); end; do j = i to 80; out_olay.cols (j) = ""b; /* Blank fill remaining columns. */ end; call get_record; /* Get the next record. */ return; end convert_bcd; /* ****************************************************************************************** ****************************************************************************************** ****************************************************************************************** */ convert_binary: proc; /* Convert binary card image. */ i = record_len * 6; /* Get bit length of record. */ outbuf = bits; /* Copy record into output record. */ if i < 960 then substr (outbuf, i+1, 960-i) = ""b; /* Zero out rest of punch record. */ call get_record; /* Get the next record. */ return; end convert_binary; %page; convert_file: proc; /* Perform the actual conversion. */ BLOCK.SIZE, curr_bsn, outindex, words_used = 0; /* Initialize some things. */ data_read, eofsw = "0"b; /* Haven't read anything yet. */ call get_record; /* Get a data record. */ if ^eofsw & code = 0 then data_read = "1"b; /* Remember that we read some data. */ do while (^eofsw & code = 0); outindex = outindex+1; /* Bump output card image index. */ if RCW.MEDIA_CODE = 1 /* Binary card image. */ then call convert_binary; else if RCW.MEDIA_CODE = 2 /* Hollerith card image. */ then call convert_bcd; else do; call com_err_ (0, my_name, "Record not binary or Hollerith card image.^2/^a^5o^10x^a^7d^/", "Block #", BLOCK.BSN, " Record #", outindex); code = error_table_$improper_data_format; /* So we get out of the loop */ end; out_ptr = addr (out_olay.next_out_olay); end; if code ^= 0 then call com_err_ (code, my_name, "^/Error while reading:^/^a", in_path); if ^data_read & eofsw then call com_err_ (0, my_name, "No data found on file:^/^a", in_path); call hcs_$set_bc ((out_dir), out_name, /* Set bitcount of output seg. */ 960*outindex, code); if code ^= 0 then call com_err_ (code, my_name, "^/Attempting to set bitcount on: ^/^a", out_path); return; end convert_file; %page; get_record: proc; /* Takes care of reading the the input file and returning a record. */ code = 0; /* Start off clean. */ if words_used >= BLOCK.SIZE /* Any more data in this block? */ then do; call iox_$get_chars (in_ptr, addr(BLOCK), 1280, how_many, code); if code = 0 then do; curr_bsn = curr_bsn + 1; /* Bump block counter. */ if BLOCK.BSN = curr_bsn then do; RECORD_PTR = addr(BLOCK.DATA); if RCW.EOF_MARKER = "0"b then do; inp = addrel (RECORD_PTR, 1); words_used = RCW.LENG + 1; record_len = RCW.LENG * 6; if record_len > 80 then record_len = 80; end; else eofsw = "1"b; end; else do; code = error_table_$bad_file; call com_err_ (0,my_name, "Block serial number error while reading block #^5o", curr_bsn, in_path); end; end; else if code = error_table_$end_of_info then do; eofsw = "1"b; code = 0; end; else call com_err_ (code, my_name, "^/Error while reading:^/^a", in_path); end; else do; RECORD_PTR = addrel (RECORD_PTR, (RCW.LENG + 1)); if RCW.EOF_MARKER = "0"b then do; inp = addrel (RECORD_PTR, 1); words_used = words_used + RCW.LENG + 1; record_len = RCW.LENG * 6; if record_len > 80 then record_len = 80; end; else eofsw = "1"b; end; return; end get_record; %page; process_arg: proc; /* Check the input pathname for legality */ code = 1; /* Assume we're gonna fail. It will get reset if we make it to the arg-checker. */ call cu_$arg_count (nargs); if nargs < 1 then call com_err_ (error_table_$noarg, my_name, "^/You must supply a pathname."); else if nargs > 1 then call com_err_ (error_table_$too_many_args, my_name, "^/Only one argument allowed."); else do; call cu_$arg_ptr (1, argp, arglen, code); /* Get pathname. */ if code = 0 then do; input_arg = substr (arg, 1, arglen); /* Chop garbage off end of arg */ call expand_pathname_ (input_arg, in_dir, in_name, code); if code = 0 then in_path = rtrim (in_dir) || ">" || in_name; else call com_err_ (code, my_name, "^/^a", input_arg); end; else call com_err_ (code, my_name); end; if code = 0 then do; call expand_pathname_$add_suffix ( in_name, /* Build output pathname. */ "raw", out_dir, out_name, code); if code = 0 then out_path = rtrim (out_dir) || ">" || out_name; else call com_err_ (code, my_name, "^/^a.raw", in_name); end; return; end process_arg; %page; syspunch_cleanup: proc; /* Close files and clean up. */ if in_ptr ^= null then do; call iox_$close (in_ptr, code); call iox_$detach_iocb (in_ptr, code); call iox_$destroy_iocb (in_ptr, code); end; return; end syspunch_cleanup; %page; dcl (arglen, i, j, outindex) fixed bin; dcl (argp, inp, out_ptr) pointer; dcl arg char (168) based (argp); dcl bits bit (i) aligned based (inp); dcl code fixed bin (35); dcl curr_bsn fixed bin (35); dcl data_read bit (1); dcl eofsw bit (1); dcl how_many fixed bin (21); dcl in_dir char (168); dcl in_name char (32); dcl in_olay (80) bit (6) unaligned based (inp); dcl in_path char (168); dcl in_ptr pointer init (null); dcl input_arg char (168); dcl my_name char(16) internal static options (constant) init ("gcos_syspunch"); dcl nargs fixed bin; dcl out_dir char (168); dcl out_name char (32); dcl outbuf bit (960) unaligned based (out_ptr); dcl out_path char (168); dcl record_len fixed bin; dcl words_used fixed bin; %page; dcl 1 out_olay based (out_ptr) unaligned, 2 cols (80) bit (12) unaligned, 2 next_out_olay bit (1) unaligned; %include gcos_block_overlay; %page; dcl cleanup condition; dcl ( addr, addrel, bit, fixed, index, null, rtrim, substr ) builtin; dcl ( error_table_$bad_file, error_table_$end_of_info, error_table_$improper_data_format, error_table_$namedup, error_table_$noarg, error_table_$segknown, error_table_$too_many_args ) fixed bin(35) ext static; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)); dcl com_err_ ext entry options (variable); dcl expand_pathname_ ext entry (char(*), char(*), char(*), fixed bin(35)); dcl expand_pathname_$add_suffix ext entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl hcs_$set_bc ext entry (char(*), char(*), fixed bin(24), fixed bin(35)); dcl hcs_$make_seg ext entry (char (*) aligned, char (*), char (*), fixed bin (5), pointer, fixed bin (35)); dcl (iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)), iox_$close entry (ptr, fixed bin(35)), iox_$destroy_iocb entry (ptr, fixed bin(35)), iox_$detach_iocb entry (ptr, fixed bin(35)), iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)) ) external; %page; dcl transmog (0: 63) bit (12) aligned internal static init ( "001000000000"b, /* 0 */ "000100000000"b, /* 1 */ "000010000000"b, /* 2 */ "000001000000"b, /* 3 */ "000000100000"b, /* 4 */ "000000010000"b, /* 5 */ "000000001000"b, /* 6 */ "000000000100"b, /* 7 */ "000000000010"b, /* 8 */ "000000000001"b, /* 9 */ "000010000010"b, /* [ */ "000001000010"b, /* # */ "000000100010"b, /* @ */ "000000010010"b, /* : */ "000000001010"b, /* > */ "000000000110"b, /* ? */ "000000000000"b, /* blank */ "100100000000"b, /* A */ "100010000000"b, /* B */ "100001000000"b, /* C */ "100000100000"b, /* D */ "100000010000"b, /* E */ "100000001000"b, /* F */ "100000000100"b, /* G */ "100000000010"b, /* H */ "100000000001"b, /* I */ "100000000000"b, /* & */ "100001000010"b, /* . */ "100000100010"b, /* ] */ "100000010010"b, /* ( */ "100000001010"b, /* < */ "100000000110"b, /* \ */ "011000000000"b, /* ^ */ "010100000000"b, /* J */ "010010000000"b, /* K */ "010001000000"b, /* L */ "010000100000"b, /* M */ "010000010000"b, /* N */ "010000001000"b, /* O */ "010000000100"b, /* P */ "010000000010"b, /* Q */ "010000000001"b, /* R */ "010000000000"b, /* - */ "010001000010"b, /* $ */ "010000100010"b, /* * */ "010000010010"b, /* ) */ "010000001010"b, /* ; */ "010000000110"b, /* ' */ "101000000000"b, /* + */ "001100000000"b, /* / */ "001010000000"b, /* S */ "001001000000"b, /* T */ "001000100000"b, /* U */ "001000010000"b, /* V */ "001000001000"b, /* W */ "001000000100"b, /* X */ "001000000010"b, /* Y */ "001000000001"b, /* Z */ "001010000010"b, /* <- (left arrow) */ "001001000010"b, /* , */ "001000100010"b, /* % */ "001000010010"b, /* = */ "001000001010"b, /* " */ "001000000110"b /* ! */ ) options (constant); end gcos_syspunch; 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