dfast_.pl1 11/05/82 1316.6rew 11/04/82 1552.0 236079 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_: proc (person_id, arg_home_dir, project_id, tty_line_id, logout_arg); /* This procedure is the listener for DFAST as well as the parser for edit commands. */ dcl arg_home_dir char (*); /* home directory from pit */ dcl project_id char (*); /* project_id for tty command */ dcl tty_line_id char (*); /* tty line */ dcl logout_arg char (*); /* = "hold" for HELLO */ dcl person_id char (*); /* name at login */ /* constants */ dcl command_names char (148) int static options (constant) init ("com,edi,lis,tty,bri,nbr,sor,ren,new,uns,sav,rep,old,bui,app,ign,scr,use,bye,goo,hel,PUN,bil,len,sys,exp,ful,hal,one,two,TAP,KEY,DIR,typ,run"); /* * 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 */ dcl READ fixed bin init (1) int static options (constant); /* directory_: read into the current segment. */ dcl SAVE fixed bin init (2) int static options (constant); /* directory_: store only if the segment does not exist. */ dcl REPLACE fixed bin init (3) int static options (constant); /* directory_: store only if the segment does exist. */ dcl DELETE fixed bin init (4) int static options (constant); /* directory_: delete the segment */ dcl TRUNCATE fixed bin init (6) int static options (constant); /* directory_: truncate the segment. */ dcl APPEND fixed bin init (1) int static options (constant); /* edit_: append alter to current segment */ dcl SORT fixed bin init (2) int static options (constant); /* edit_: merge alter and current and sort */ dcl BUILD fixed bin int static options (constant) init (5); /* edit_: append to current segment */ dcl ALTER fixed bin int static options (constant) init (6); /* edit_: append to alter segment */ dcl LENGTH fixed bin int static options (constant) init (7); /* edit_: merge temporary segments and give length */ dcl arg_delimit char (4) int static options (constant) init (" ,;"); /* tab blank comma semi-colon */ dcl dfast_name char (5) int static options (constant) init ("dfast"); dcl white_space char (2) int static options (constant) init (" "); /* tab blank */ dcl character_set char (68) int static options (constant) init (">._-0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ "); dcl digit char (10) defined (character_set) pos (5); /* digits */ dcl letter char (52) defined (character_set) pos (15); /* letters */ dcl name_char char (68) defined (character_set) pos (1); /* legal segment name characters */ dcl lowercase_letters char (26) defined (character_set) pos (15); dcl uppercase_letters char (26) defined (character_set) pos (41); /* automatic */ dcl input char (256); dcl input_length fixed bin; /* line length without the new-line */ dcl arg char (256) var; dcl ready bit (1); /* ON if ready message should be printed */ dcl (length, index, verify, substr, addr, divide, search, null, translate) builtin; dcl (i, num_1, request) fixed bin; dcl header bit (1) unal; /* ON = list with header */ dcl sort bit (1) unal; /* dfast_line_edit_: ON sort; OFF no sort */ dcl string char (256) var; dcl code fixed bin (35); dcl quit condition; /* external */ dcl clock_ entry () returns (fixed bin (71)); dcl condition_ entry (char (*), entry); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl date_time_ entry (fixed bin (71), char (*)); dcl error_table_$long_record fixed bin (35) ext; dcl dfast_command_processor_ entry (ptr, char (*), char (*), fixed bin (35)); dcl dfast_compile_ entry (ptr, fixed bin (35)); dcl dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35)); dcl dfast_edit_ entry (fixed bin, char (*), ptr, fixed bin (35)); dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_explain_ entry (char (*) var, char (*), fixed bin (35)); dcl dfast_line_edit_ entry (char (256) var, ptr, bit (1) unal, fixed bin (35)); dcl dfast_list_ entry (ptr, char (*), fixed bin, bit (1) unal, bit (1) unal, fixed bin (35)); dcl dfast_merge_ entry (bit (1), ptr, fixed bin (35)); dcl fast_related_data_$in_fast_or_dfast bit (1) aligned ext; dcl fast_related_data_$in_dfast bit (1) aligned ext; dcl dfast_run_ entry (ptr, fixed bin (35)); dcl dfast_set_system_ entry (char (256) var, bit (1) unal, char (*), fixed bin (35)); dcl dfast_terminal_control_ entry (fixed bin, char (*), ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hmu entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$user_input ptr ext static; dcl iox_$user_output ptr ext static; dcl resource_usage entry (); dcl sys_info$max_seg_size fixed bin (35) ext; dcl edit_info_ptr ptr; dcl 1 f aligned like dfast_edit_info; %include dfast_edit_info; %include dfast_error_codes; /* */ call initial; if code ^= 0 then return; on quit begin; ready = "1"b; call iox_$control (iox_$user_input, "resetread", addr (input), code); call ioa_$ioa_switch (iox_$user_output, "QUIT^/"); goto READY; end; call condition_ ("any_other", any_other_handler); /* * This loop prints the ready message and reads a line from the terminal. These conventions are used: * * 1. Special case the BUILD mode. * a. If the line contains only a new_line character, BUILD mode is terminated. * b. Otherwise the line is appended to the end of the current_file. * 2. Blank lines are ignored. * 3. Text lines begin with a digit and are stored in temporary segment alt to be merged later. * 4. Command lines: * a. Single command lines begin with an alphabetic character. Only the first three characters * are used. * b. Multi-command lines begin with any character except a digit or an alphabetic charcter. * (ie. /tty/run/lis ) */ READY: do while ("1"b); if ready then do; call date_time_ (clock_ (), input); call ioa_$ioa_switch (iox_$user_output, "ready ^a^/", substr (input, 11, 4)); end; ready = "0"b; call iox_$get_line (iox_$user_input, addr (input), 256, input_length, code); if code ^= 0 then do; if code = error_table_$long_record then call dfast_error_ (error_long_rec, "", ""); end; else if f.build_mode then do; if input_length = 1 then do; f.build_mode = "0"b; ready = "1"b; end; else call dfast_edit_ (BUILD, substr (input, 1, input_length), edit_info_ptr, code); end; else do; i = verify (substr (input, 1, input_length -1), white_space); if i > 0 then do; if index (digit, substr (input, i, 1)) > 0 then call dfast_edit_ (ALTER, substr (input, i, input_length - i + 1), edit_info_ptr, code); else do; /* command */ if ^f.brief_mode then ready = "1"b; if index (letter, substr (input, i, 1)) > 0 then call command (substr (input, i, input_length - i), code); else call multi_command ((i)); end; end; end; end; RETURN: return; /* */ /* This procedure is used to find the next argument on the line. It expects the form: [blank | tab] [argument] [blank | tab | comma | semi-colon] Any of the fields may be null. If no argument and no delimitor is found, then the procedure returns "0"b. Otherwise "1"b is returned. */ get_arg: proc (line, argument) returns (bit (1)); dcl argument char (256) var; /* next argument (output) */ dcl line char (256) var; /* input buffer */ dcl line_length fixed bin; /* length of line on input */ dcl argument_length fixed bin; /* length of argument */ dcl start fixed bin; /* index in line of start of argument */ line_length = length (line); if line_length > 0 then do; start = verify (line, white_space); if start > 0 then do; argument_length = search (substr (line, start), arg_delimit); if argument_length = 0 then argument_length = line_length - start + 1; else argument_length = argument_length - 1; argument = substr (line, start, argument_length); start = start + argument_length + 1; /* move beyond the argument delimitor */ if start > line_length then line = ""; else line = substr (line, start, line_length - start + 1); return ("1"b); end; end; return ("0"b); end get_arg; /* */ line_number: proc (string, num) returns (bit (1)); dcl string char (*) var; dcl num fixed bin; num = cv_dec_check_ ((string), code); if code = 0 then do; if num > 0 then return ("1"b); else call dfast_error_ (error_bad_line, "", (arg)); end; else return ("0"b); end line_number; /* */ /* This procedure parses the line for a pathname and verifies that it contains legal characters. If the name is not found and request is set, the user is queried for a name. * * Code Pathname Explaination * * 0 ^= "" A legal pathname was found and is returned. * 0 = "" No pathname was given and the query was not requested. * bad_name (not set) The pathname given contained one or more illegal characters. * name_miss (not set) The name was not given on the line or with the query and request was set. */ get_name: proc (line, name, request, code); dcl line char (256) var; dcl name char (*) var; /* pathname (output) */ dcl request bit (1); /* ON if should request name (input) */ dcl code fixed bin (35); if ^get_arg (line, arg) then do; if ^request then do; name = ""; return; end; call get_user_response ("0"b, "enter name: ", arg); if arg = "" then code = error_name_miss; end; if code = 0 then do; if verify (arg, name_char) > 0 then code = error_bad_name; else name = arg; end; if code ^= 0 then if code ^= error_name_miss then call dfast_error_ (code, dfast_name, (arg)); return; end get_name; /* */ /* This command parses the command line for a command and executes it. It returns code: * code = 0 The command was successfully completed or was a null command. * code ^= 0 An error prevented the command from being completed. */ command: proc (line, code); dcl line char (256) var; dcl code fixed bin (35); if get_arg (line, arg) then do; arg = translate (arg, lowercase_letters, uppercase_letters); if length ((arg)) > 2 then do; request = index (command_names, substr (arg, 1, 3)); if request ^= 0 then do; request = divide (request +3, 4, 17); goto command_label (request); end; end; call dfast_command_processor_ (edit_info_ptr, (arg), (line), code); end; return; /* */ /* * compile [fortran | basic] */ command_label (1): if get_arg (line, arg) then call set_system (code); if code = 0 then call dfast_compile_ (edit_info_ptr, code); return; /* * edit [] */ command_label (2): if arg = "editns" | arg = "edins" then sort = "0"b; else sort = "1"b; call dfast_line_edit_ (line, edit_info_ptr, sort, code); return; /* list: omit header if user is in brief_mode or request was lisn, lisnh, listnh [alt | cur] [] [] */ command_label (3): if f.brief_mode then header = "0"b; else if substr (arg, length (arg), 1) = "n" then header = "0"b; else if substr (arg, length (arg) -1, 2) = "nh" then header = "0"b; else header = "1"b; call parse_list_punch (line, header, "0"b); return; /* tty */ command_label (4): if f.basic_system then if f.dbasic then string = "dbasic"; else string = "basic"; else string = "fortran"; call ioa_$ioa_switch (iox_$user_output, "name = ^a, system = ^a, user = ^a.^a, line = ^a", f.current_name, string, person_id, project_id, tty_line_id); return; /* brief */ command_label (5): f.brief_mode = "1"b; ready = "0"b; return; /* nbrief */ command_label (6): f.brief_mode = "0"b; return; /* sort */ command_label (7): call dfast_edit_ (SORT, "", edit_info_ptr, code); return; /* * rename [] * new [] */ command_label (8): command_label (9): call get_name (line, string, "1"b, code); if code = 0 then do; if index (string, ">") = 0 then do; f.current_name = string; call dfast_set_system_ (f.current_name, f.basic_system, "", 0); /* ignore code: OK if no suffix */ end; else do; code = error_bad_name; call dfast_error_ (code, "name", (string)); end; end; else if code = error_name_miss then code = 0; /* ignore a chage of mind by user */ if request = 9 then call reset_edit_info; return; /* * unsave [] */ command_label (10): call segment_control (line, DELETE); return; /* save [] */ command_label (11): call segment_control (line, SAVE); return; /* * replace [] */ command_label (12): call segment_control (line, REPLACE); return; /* * old [] [] */ command_label (13): call segment_control (line, READ); if code = 0 then do; if f.source_segment then do; call dfast_set_system_ (f.current_name, f.basic_system, "", code); if code ^= 0 then do; code = 0; if get_arg (line, arg) then call set_system (code); else do; call get_user_response ("0"b, "enter system name: ", arg); call set_system (code); do while (code ^= 0); call get_user_response ("1"b, "answer 'basic', 'dbasic', or 'fortran': ", arg); call set_system (code); end; end; end; end; end; return; /* build */ command_label (14): if ^f.source_segment then call dfast_error_ (error_obj_nop, "build", ""); else do; if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code = 0 then f.build_mode = "1"b; end; return; /* append */ command_label (15): call dfast_edit_ (APPEND, "", edit_info_ptr, code); return; /* ignore */ command_label (16): f.alter_length = 0; return; /* scratch */ command_label (17): if verify (line, white_space) = 0 then call reset_edit_info; else call segment_control (line, TRUNCATE); return; /* user */ command_label (18): call hmu (); return; /* bye and goodbye */ command_label (19): command_label (20): logout_arg = ""; call bye_request; return; /* * hello * * help */ command_label (21): if arg = "hello" then do; logout_arg = "-hold"; call bye_request; return; end; else call dfast_explain_ ("", "help", code); return; /* punch */ command_label (22): call parse_list_punch (line, "0"b, "1"b); return; /* bill */ command_label (23): call resource_usage; return; /* length */ command_label (24): call dfast_edit_ (LENGTH, "", edit_info_ptr, code); return; /* * system [fortran | basic] */ command_label (25): if ^get_arg (line, arg) then call get_user_response ("1"b, "enter system: ", arg); call set_system (code); return; /* * explain */ command_label (26): call dfast_explain_ (line, "explain", code); return; /* These commands change the input/output mode of the terminal. The order is important. * * (27) fullduplex * (28) halfduplex * (29) one_case * (30) two_case * (31) tape * (32) keyboard * (33) direct */ command_label (27): command_label (28): command_label (29): command_label (30): command_label (31): command_label (32): command_label (33): call dfast_terminal_control_ (request - 26, "", edit_info_ptr, code); if request = 33 then ready = "1"b; return; /* * type * * ::= tn300 | tty37 | tty33 */ command_label (34): if ^get_arg (line, arg) then arg = ""; call dfast_terminal_control_ (request - 26, (arg), edit_info_ptr, code); return; /* * run [fortran | basic] */ command_label (35): if get_arg (line, arg) then call set_system (code); if code = 0 then call dfast_run_ (edit_info_ptr, code); return; end command; /* */ /* This procedure is used to read into or store from the current segment and to delete segments If a pathname is given on the line, it is used. Otherwise the current name is used. If no pathname is given and the current name is "no name", then and error message is printed and an error code is returned. */ segment_control: proc (line, action); dcl line char (256) var; dcl action fixed bin; /* directory_: read, save, replace, delete */ dcl request bit (1); /* get_name: ON if should request name */ if f.current_name = "no name" then request = "1"b; else request = "0"b; call get_name (line, string, request, code); if code = error_name_miss then call dfast_error_ (code, dfast_name, ""); else if code = 0 then do; if string = "" then string = f.current_name; call dfast_directory_ (action, (string), edit_info_ptr, null, code); if action ^= DELETE then f.edit_done = "0"b; end; return; end segment_control; /* */ /* * This procedure prints a message and then reads one line from user_input. If the line contains * at least one non_blank character, response is set and the procedure returns. If a blank * line is input, there are two actions depending on repeat: * * "1"b the message is printed again. * "0"b response is set to "" and the procedure returns */ get_user_response: proc (repeat, message, response); dcl repeat bit (1); /* ON if should repeat for blank lines */ dcl message char (*); dcl response char (*) var; /* the response enterred by the user */ dcl temp_buffer char (256); dcl amt_read fixed bin; /* num_characters read */ dcl start fixed bin; /* index of start of response */ dcl num_chars fixed bin; /* number of characters in response */ response = ""; do while ("1"b); call iox_$put_chars (iox_$user_output, addr (message), length (message), code); call iox_$get_line (iox_$user_input, addr (temp_buffer), 256, amt_read, code); amt_read = amt_read - 1; if amt_read > 0 then do; start = verify (substr (temp_buffer, 1, amt_read), white_space); if start > 0 then do; num_chars = index (substr (temp_buffer, start, amt_read), white_space) -1; if num_chars = -1 then num_chars = amt_read - start + 1; response = substr (temp_buffer, start, num_chars); return; end; end; if ^repeat then return; end; end get_user_response; /* */ /* * This procedure parses arg for a system name. Only the first three letters are used. * The system may be fortran or basic or dbasic. The system can not be changed: * 1. If the current segment is object code. * 2. If the system would conflict with the current name. */ set_system: proc (code); dcl code fixed bin (35); dcl tag char (7); string = substr (arg, 1, 3); if f.source_segment then do; call dfast_set_system_ (f.current_name, f.basic_system, tag, (0)); if string = "bas" | string = "dba" then do; if tag = "fortran" then code = error_name_sys; if code = 0 then do; f.basic_system = "1"b; if string = "dba" then f.dbasic = "1"b; else f.dbasic = "0"b; end; end; else if string = "for" then do; if tag = "basic" then code = error_name_sys; if code = 0 then f.basic_system, f.dbasic = "0"b; end; else code = error_unkn_sys; end; else do; /* Can't override system in object segment */ if string = "bas" & f.basic_system & ^f.dbasic then; if string = "dba" & f.basic_system & f.dbasic then; else if string = "for" then if ^f.basic_system then; else code = error_obj_nop; end; if code ^= 0 then do; if code = error_name_sys then arg = f.current_name; call dfast_error_ (code, "system", (arg)); end; return; end set_system; /* */ /* This procedure parses an input line with more than one command. The first character on the line is the delimitor. Null commands are legal. */ multi_command: proc (start); dcl start fixed bin; /* index of input of command delimitor character */ dcl command_delimitor char (1); /* command delimitor character */ dcl len fixed bin; /* length of command */ command_delimitor = substr (input, start, 1); start = start + 1; input_length = input_length - 1; /* drop the new-line character */ code = 0; do while (start <= input_length & code = 0); len = index (substr (input, start, input_length - start + 1), command_delimitor); if len = 0 then len = input_length - start +2; call command (substr (input, start, len -1), code); start = start + len; end; return; end multi_command; /* */ /* This code clears the edit info for the initialization and the scratch and new commands. */ reset_edit_info: proc; f.current_length = 0; f.alter_length = 0; f.edit_done = "0"b; f.source_segment = "1"b; return; end reset_edit_info; /* */ /* This procedure parses the arguments for the list and the punch commands. * * list * punch * * temporary segment id = alt list the alter file. * = cur list the current file. * = "" Merge the alter and current files and then list. * * line number n List the file beginning with the line number n. */ parse_list_punch: proc (line, header, punch); dcl line char (256) var; dcl header bit (1) unal; /* ON if should print header */ dcl punch bit (1) unal; /* ON if should punch; OFF if should list */ num_1 = -1; /* default is entire segment */ string = ""; /* default is merge with alter and then list */ if get_arg (line, arg) then do; string = substr (arg, 1, 3); if string = "cur" | string = "alt" then do; if get_arg (line, arg) then do; if ^line_number (arg, num_1) then code = error_unknown_arg; end; end; else do; string = ""; if ^line_number (arg, num_1) then code = error_unknown_arg; end; end; if code = 0 then call dfast_list_ (edit_info_ptr, (string), num_1, header, punch, code); else do; if punch then string = "punch"; else string = "list"; call dfast_error_ (code, (string), (arg)); end; return; end parse_list_punch; /* */ bye_request: proc; if f.edit_done | f.alter_length > 0 then do; call get_user_response ("0"b, "editing will be lost if you quit. Do you want to quit ? ", arg); do while ("1"b); if arg = "yes" | arg = "YES" then goto RETURN; if arg = "no" | arg = "NO" then return; call get_user_response ("1"b, "answer 'yes' or 'no': ", arg); end; end; goto RETURN; end bye_request; /* */ /* This procedure sets up the PI handler and gets two scratch buffers in the process directory. */ initial: proc; dcl ptr_array (2) ptr based; code = 0; edit_info_ptr = addr (f); f.home_dir = arg_home_dir; f.current_ptr = null; call get_temp_segments_ (dfast_name, addr (f.current_ptr) -> ptr_array, code); if code ^= 0 then call dfast_error_ (code, dfast_name, "current_segment"); f.max_seg_size = sys_info$max_seg_size; f.current_name = "no name"; f.basic_system = "1"b; f.brief_mode, f.build_mode = "0"b; call reset_edit_info; fast_related_data_$in_fast_or_dfast = "1"b; /* switches for BASIC */ fast_related_data_$in_dfast = "1"b; ready = "1"b; return; end initial; /* */ any_other_handler: proc (mcptr, cond_name, wcptr, info_ptr, cont); dcl mcptr ptr, cond_name char (*), wcptr ptr, info_ptr ptr, cont bit (1) aligned; dcl area area (300); dcl (i, l) fixed bin; dcl NEW_LINE char (1) init (" "); dcl message_len fixed bin (21); dcl message char (message_len) based (message_ptr); dcl message_ptr ptr; dcl condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr); if cond_name = "command_error" | cond_name = "command_question" | cond_name = "string_size" then return; call condition_interpreter_ (addr (area), message_ptr, message_len, 1, mcptr, cond_name, wcptr, info_ptr); if cond_name = "command_abort_" then goto READY; if message_len > 0 then do; /* * This code modifies the error message to remove the shriek name and the phrase "(in process dir)" * * Error: ... condition by !BBBJFbDjnMccfW.temp.0310$main_|50 (line 20) (in process dir) * * Error: ... condition by main_|50 (line 20) */ if substr (message, 2, 6) = "Error:" then do; l = index (substr (message, 2), NEW_LINE); if l > 0 then do; i = index (substr (message, 2, l), "by !"); if i > 0 then do; i = i + 4; if substr (message, i+15, 5) = ".temp" & substr (message, i + 25, 1) = "$" then do; substr (message, i) = substr (message, i+26, message_len - i -26+1); message_len = message_len - 26; i = index (substr (message, 1, l+1), "(in process dir)"); if i > 0 then do; substr (message, i) = substr (message, i+16); message_len = message_len - 16; end; end; end; end; end; call iox_$put_chars (iox_$user_output, message_ptr, message_len, code); end; if cond_name = "finish" then return; goto READY; end any_other_handler; end dfast_;  dfast_command_processor_.pl1 11/05/82 1316.6rew 11/04/82 1644.1 95697 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_command_processor_: proc (edit_info_ptr, name, arg_line, code); /* * This procedure is given a command name and a command line. If the command is one of the Multics commands * allowed, a descriptor list is filled in and the command is called. * * Special casing is done for: * * catalog This is mapped into a call to "list" and the error message is changed to use "catalog" * * dprint If the -map options is dprinted, the uppercase segment name.map is created and dprinted. */ /* parameters */ dcl edit_info_ptr ptr; dcl name char (*); /* command name */ dcl arg_line char (*); /* user's command line */ dcl code fixed bin (35); /* error code */ /* automatic */ dcl seg_ptr ptr; /* pointer to original segment for dprint_map problem */ dcl (start, num_chars) fixed bin; /* start and number of characters in argument */ dcl line_length fixed bin; /* number of characters in line */ dcl i fixed bin; dcl command_index fixed bin; /* index to procedure ptr */ dcl delete_orig_segment bit (1); dcl arg_length (10) fixed bin; /* temporarily holds argument lengths */ dcl 1 descriptors (10) aligned based (addr (al.pointers)), 2 desc_pointers bit (18) unal, 2 pad_pointers bit (18) unal, 2 flag bit (1) unal, 2 type bit (6) unal, 2 packed bit (1) unal, 2 ndims bit (4) unal, 2 size bit (24) unal; dcl 1 al aligned, 2 dum_ptr ptr, 2 num_args fixed bin (16) unaligned, 2 tag bit (19) initial ("0000000000000000100"b) unaligned, 2 ndescs fixed bin (16) unaligned, 2 pad bit (19) unaligned, 2 pointers (20) ptr; dcl (addr, hbound, length, mod, null, rel, search, substr, verify) builtin; dcl (bin, bit, divide, index, reverse, unspec) builtin; dcl dprint_change bit (1); dcl line char (256); dcl skip bit (1); dcl command_error condition; /* internal static */ dcl white_space char (2) int static options (constant) init (" "); /* TAB BLANK */ dcl command_names (14) char (15) int static options (constant) init ("catalog", "cat", "dprint", "dp", "set_tty", "stty", "delete_acl", "da", "set_acl", "sa", "list_acl", "la", "dpunch", "dpn"); /* based */ dcl proc_ptr (14) ptr based (addr (entry_value (1))); /* external */ dcl cu_$gen_call entry (ptr, ptr); dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl entry_value (7) entry init (list, dprint, set_tty, delete_acl, set_acl, list_acl, dpunch); dcl (list, dprint, set_tty, delete_acl, set_acl, list_acl, dpunch) entry; %include dfast_error_codes; code = 0; unspec (al) = "0"b; command_index = 0; do i = 1 to hbound (command_names, 1) while (command_index = 0); if name = command_names (i) then command_index = i - mod (i+1, 2); end; if command_index > 0 then do; num_args = 0; line = arg_line; line_length = length (arg_line); delete_orig_segment = "0"b; if command_names (command_index) = "dprint" then call dprint_map; start = 1; do while (get_arg (start, num_chars) & code = 0); if num_args < 10 then do; num_args = num_args + 1; al.pointers (num_args) = addr (substr (line, start, 1)); arg_length (num_args) = num_chars; start = start + num_chars; end; else code = error_max_args; end; if code = 0 then do; al.tag = "0000000000000000100"b; al.ndescs = num_args; do i = 1 to num_args; desc_pointers (i+num_args) = rel (addr (descriptors (i+num_args).flag)); descriptors (i+num_args).flag = "1"b; descriptors (i+num_args).size = bit (bin (arg_length (i), 24)); descriptors (i+num_args).type = bit (bin (21, 6)); descriptors (i+num_args).packed = "1"b; end; if command_names (command_index) = "catalog" then on command_error call reformat; if command_names (command_index) = "dprint" then on command_error delete_orig_segment = "0"b; call cu_$gen_call (proc_ptr (command_index), addr (al.num_args)); end; end; else do; code = error_bad_req; call dfast_error_ (code, "", name); return; end; if code ^= 0 & command_names (command_index) ^= "dprint" then call dfast_error_ (code, name, ""); if delete_orig_segment then do; if code = 0 then call hcs_$delentry_seg (seg_ptr, code); end; RETURN: return; /* */ /* This procedure gets the index of the next argument on the line. * * "1"b the argument was found * "0"b no arguments remain on the line */ get_arg: proc (start, num_chars) returns (bit (1)); dcl start fixed bin; /* index on line of start of argument */ dcl num_chars fixed bin; /* number of characters */ dcl i fixed bin; if start <= line_length then do; i = verify (substr (line, start, line_length - start + 1), white_space); if i > 0 then do; start = start + i -1; num_chars = search (substr (line, start, line_length - start + 1), white_space) -1; if num_chars = -1 then num_chars = line_length - start + 1; return ("1"b); end; start = line_length + 1; num_chars = 0; end; return ("0"b); end get_arg; /* */ /* This procedure reformats an error message for LIST so that FAST users think they are using a command called CATALOG */ reformat: proc; dcl i fixed bin; dcl acode fixed bin (35); dcl length builtin; dcl 1 cond_info aligned, %include cond_info; dcl 1 info_structure aligned based (infoptr), %include cond_info_structure; 2 name_ptr ptr, 2 name_lth fixed bin, 2 err_mess_ptr ptr, 2 err_mess_lth fixed bin, 2 max_err_mess_lth fixed bin, 2 print_sw bit (1); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); cond_info.version = 1; call find_condition_info_ (null, addr (cond_info), acode); i = index (info_string, ":"); info_string = "catalog" || substr (info_string, i); err_mess_lth = length (info_string); err_mess_ptr = addr (substr (info_string, 1, 1)); end reformat; /* */ /* * If dprint is called with the -map option, the command line is reformated. The new line * has these changes: * * seg_name seg_name.map * -map "" * "" "-dl" * * The original segment is copied and converted into an uppercase segment is the user's home directory. * If the user requested deletion of the original segment, the segment is deleted after the dprint * request is made. (If dprint calls com_err_ then the segment is not deleted.) */ dprint_map: proc; /* automatic */ dcl temp_ptr ptr; /* pointer to copy of segment */ dcl seg_length fixed bin (21); /* no. of characters in original segment */ dcl pathname char (168) var; dcl directory char (168); dcl entry_name char (32); dcl bit_count fixed bin (24); dcl arg char (158) var; dcl new_line char (256); dcl new_line_length fixed bin ; dcl i fixed bin; dcl num_print fixed bin; dcl (translate, substr, index) builtin; /* constants */ dcl RW_access fixed bin (5) int static options (constant) init (01010b) options (constant); dcl UPPERCASE char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") options (constant); dcl LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz") options (constant); dcl options (8) char (10) init ("-copy", "-cp", "-queue", "-q", "-header", "-he", "-destination", "-ds"); /* external */ dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl error_table_$entlong ext static fixed bin (35); /* based */ dcl seg_string char (seg_length) based; dcl 1 f aligned based like dfast_edit_info based (edit_info_ptr); %include dfast_edit_info; /* */ num_print = 0; i = index (line, "-map"); if i > 0 then do; new_line_length = 0; start = 1; skip = "0"b; do while (code = 0 & get_arg (start, num_chars)); arg = substr (line, start, num_chars); if substr (arg, 1, 1) ^= "-" then do; if ^skip then do; if num_print = 0 then do; if substr (arg, 1, 1) = ">" then pathname = arg; else pathname = f.home_dir || ">" || arg; i = index (reverse (pathname), ">"); directory = substr (pathname, 1, length (pathname) -i); if i <= 29 then do; entry_name = substr (pathname, length (pathname) -i + 2, i-1); call hcs_$initiate_count (directory, entry_name, "", bit_count, 0, seg_ptr, code); if seg_ptr ^= null then do; call hcs_$make_seg ((f.home_dir), substr (entry_name, 1, i -1) || ".map", "", RW_access, temp_ptr, code); if temp_ptr ^= null then do; code = 0; seg_length = divide (bit_count, 9, 17, 0); temp_ptr -> seg_string = translate (seg_ptr -> seg_string, UPPERCASE, LOWERCASE); substr (new_line, new_line_length + 1, num_chars + 5) = arg || ".map "; new_line_length = new_line_length + num_chars + 5; call hcs_$set_bc_seg (temp_ptr, bit_count, code); num_print = num_print + 1; end; call hcs_$terminate_noname (temp_ptr, (0)); end; end; else code = error_table_$entlong; end; else code = error_dprint_map; end; else do; substr (new_line, new_line_length + 1, num_chars + 1) = arg || " "; new_line_length = new_line_length + num_chars + 1; skip = "0"b; end; end; else do; if arg = "-dl" | arg = "-delete" then delete_orig_segment = "1"b; else if arg ^= "-map" then do; substr (new_line, new_line_length + 1, num_chars + 1) = arg || " "; new_line_length = new_line_length + num_chars + 1; skip = "0"b; do i = 1 to 8; if arg = rtrim(options (i)) then skip = "1"b; end; end; end; start = start + num_chars; if code ^= 0 then call dfast_error_ (code, "dprint", (pathname)); end; if code = 0 then do; line_length = new_line_length + 4; line = "-dl " || new_line; end; end; return; end dprint_map; end dfast_command_processor_;  dfast_compile_.pl1 08/06/87 1149.6r w 08/06/87 1047.0 40446 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dfast_compile_: proc (edit_info_ptr, code); /* coded 12/75 by S. E. Barr */ /* modified 12/76 by M. Weaver to use version 2 compiler_source_info structure */ /* Modified 28 Feb 1980 by C R Davis for new fort_options include file. */ /* This procedure executes COMPILE command for Fortran and Basic. * * 1. If the following conditions are met, the segment is compiled: * a. The source_segment flag is on. * b. The edit_done flag is off. * * 2. If the compilation is successful, these changes are made: * a. The current_segment is replaced with the object code. * b. The current_name is set: * 1) Multics convention: If the source name has a language tag, then * the object name drops the language tag. ("test.basic" becomes "test") * 2) If the source name did not have a language suffix, the name is set to "object". * ("test" becomes "object") */ dcl edit_info_ptr ptr; dcl code fixed bin (35); /* automatic */ dcl 1 fort_opt aligned like fortran_options; dcl i fixed bin; dcl object_length fixed bin (21); dcl temp_ptr ptr; dcl (addr, fixed, length, null, substr, unspec) builtin; /* constant */ /* external */ dcl basic_$compile entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl fort_$compile entry (ptr, ptr, fixed bin (21), ptr, fixed bin (35)); dcl basic_$precision_length fixed bin ext ; dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); /* based */ dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info; dcl 1 c aligned like compiler_source_info; dcl 1 b aligned like branch_status; /* */ %include dfast_edit_info; %include dfast_error_codes; %include compiler_source_info; %include fort_options; %include branch_status; /* */ if ^f.source_segment then code = error_obj_nop; else do; if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code = 0 then do; if f.edit_done then code = error_sav_cur; else do; call hcs_$status_long ((f.source_directory), (f.source_entryname), 1, addr (b), null, code); if code = 0 then do; call hcs_$truncate_seg (f.alter_ptr, 0, code); if code = 0 then do; c.version = compiler_source_info_version_2; c.input_pointer = f.current_ptr; c.input_lng = f.current_length; c.dirname = f.source_directory; c.segname = f.source_entryname; c.given_ename = f.source_entryname; c.date_time_modified = fixed (b.date_time_modified || (16) "0"b, 71); c.unique_id = b.unique_id; if f.basic_system then do; if f.dbasic then basic_$precision_length = 2; else basic_$precision_length = 1; call basic_$compile (addr (c), f.alter_ptr, object_length, code); call switch_buffers (".basic"); end; else do; unspec (fort_opt) = dfast_mask; call fort_$compile (addr (c), f.alter_ptr, object_length, addr( fort_opt), code); call switch_buffers (".fortran"); end; end; end; end; end; end; if code ^= 0 then call dfast_error_ (code, "compile", (f.current_name)); return; /* */ switch_buffers: proc (language); dcl language char (*); dcl len fixed bin; /* length of language */ if code = 0 then do; temp_ptr = f.alter_ptr; f.alter_ptr = f.current_ptr; f.current_ptr = temp_ptr; len = length (language); i = length (f.current_name); f.current_name = "object"; if i >= len + 1 then do; if substr (c.segname, i-len+1,len) = language then f.current_name = substr (c.segname, 1, i-len); end; f.current_length = object_length * 4; f.source_segment = "0"b; end; return; end switch_buffers; end dfast_compile_;  dfast_directory_.pl1 11/05/82 1316.6rew 11/04/82 1552.2 77526 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_directory_: proc (action, arg_pathname, edit_info_ptr, copy_info_ptr, code); /* This procedure is used to read and write the current segment and to delete segments. * * (1) read Read into the current segment. If successful, it sets: * * basic_system ON Basic source or object code. * OFF Fortran source or object code. * (not set) Could not tell type of segment or segment was neither * Fortran nor Basic. * * source_segment ON Segment is not an object segment. * OFF Segment is an object segment. * * current_length Number of characters in new current segment. * * current_name Set to the entry name. If pathname contained an absolute pathname * on entry, current_name will contain just the entry name on exit. * * (2) save Store only if the segment does not exist. * * (3) replace Store only if the segment does exist. * * (4) delete Delete the segment. * * (5) copy Add the segment onto the end of a segment supplied with the copy_info structure * * (6) truncate Truncate the segment. (scratch request) * */ /* parameters */ dcl action fixed bin; /* requested action: save, old etc. */ dcl arg_pathname char (*); /* pathname */ dcl edit_info_ptr ptr; /* ptr to dfast_edit_info structure */ dcl copy_info_ptr ptr; /* ptr to copy_info structure (for COPY request only) */ dcl code fixed bin (35); /* automatic */ dcl line char (256) var; /* TEST */ dcl bit_count fixed bin (24); /* length of segment */ dcl i fixed bin (35); dcl directory_name char (168); dcl access fixed bin (5); dcl entry_name char (32); dcl seg_ptr ptr; /* ptr. to segment in directory */ dcl system bit (1) unal; dcl system_name char (7); dcl pathname char (256) var; /* complete pathname */ dcl program_header_pt ptr; /* ONLY to prevent warn. (%include basic_program_header) */ dcl message char (256) var; dcl (addr, divide, index, length, null, reverse, substr) builtin; /* external */ dcl iox_$user_output ptr ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$segknown fixed bin (35) ext; dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); dcl ioa_$ioa_switch entry options (variable); dcl com_err_$convert_status_code_ entry (fixed bin (35), char (*) aligned, char (*) aligned); dcl object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)); /* constants */ dcl READ fixed bin int static init (1) options (constant); dcl SAVE fixed bin int static init (2) options (constant); dcl REPLACE fixed bin int static init (3) options (constant); dcl DELETE fixed bin int static init (4) options (constant); dcl COPY fixed bin int static init (5) options (constant); dcl TRUNCATE fixed bin int static init (6) options (constant); dcl MERGE fixed bin int static init (9) options (constant); dcl RW_access fixed bin (5) int static init (01010b) options (constant); dcl REW_access fixed bin (5) int static init (01110b) options (constant); dcl request_id (6) char (7) int static init ("old", "save", "replace", "unsave", "edit", "scratch") options (constant); /* based */ dcl cur_seg char (f.current_length) based; dcl string char (f.max_seg_size) based; /* based */ dcl 1 oi like object_info aligned; dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info; dcl 1 copy_info aligned based (copy_info_ptr), 2 copy_ptr ptr, /* ptr to base of target segment */ 2 old_length fixed bin (21), /* length of segment before the copy */ 2 new_length fixed bin (21); /* length of segment after the copy */ /* include files */ %include dfast_error_codes; %include basic_program_header; %include dfast_edit_info; %include object_info; /* */ seg_ptr = null; if substr (arg_pathname, 1, 1) = ">" then pathname = arg_pathname; else pathname = f.home_dir || ">" || arg_pathname; i = length (pathname) - index (reverse (pathname), ">"); directory_name = substr (pathname, 1, i); message = pathname; entry_name = substr (pathname, i + 2); if action ^= SAVE then do; /* SAVE requires hcs_$make_seg */ call hcs_$initiate_count (directory_name, entry_name, "", bit_count, 0, seg_ptr, code); if code = error_table_$segknown then code = 0; end; if code = 0 then do; if action = READ then do; /* If the segment is object, the f.source_segment and f.basic_system can be set with assurance. If the segment is not object, it is assumed to be a source segment. */ oi.version_number = 2; call object_info_$display (seg_ptr, bit_count, addr (oi), code); if code = 0 then do; if oi.compiler = "basic" then do; system = "1"b; /* version is -1 if the language is dbasic (extended precision basic) */ if oi.textp -> basic_program_header.version_number = -1 then f.dbasic = "1"b; end; else if oi.compiler = "fortran2" then system = "0"b; else do; code = error_unkn_sys; message = oi.compiler; end; if code = 0 then do; if system ^= f.basic_system then do; system_name = oi.compiler; /* 'fortran2' gets shortened to 'fortran' */ call ioa_$ioa_switch (iox_$user_output, "system changed to ^a", system_name); f.basic_system = system; end; f.source_segment = "0"b; end; end; else do; code = 0; f.source_segment = "1"b; end; if code = 0 then do; i = divide (bit_count, 9, 17, 0); if i > f.max_seg_size then code = error_max_size; else do; f.current_length = i; f.current_ptr -> cur_seg = seg_ptr -> cur_seg; i = index (entry_name, " "); /* ignore trailing blanks */ f.current_name = substr (entry_name, 1, i -1); f.alter_length = 0; /* ignore previous edit */ f.edit_done = "0"b; end; end; end; else if action = DELETE then do; call hcs_$delentry_seg (seg_ptr, code); seg_ptr = null; end; else if action = TRUNCATE then do; call hcs_$truncate_seg (seg_ptr, 0, code); if code = 0 then call hcs_$set_bc_seg (seg_ptr, 0, code); end; else if action = COPY then do; i = divide (bit_count, 9, 17, 0); if i + copy_info.old_length > f.max_seg_size then code = error_max_size; else do; substr (copy_info.copy_ptr -> string, copy_info.old_length +1, i) = substr (seg_ptr -> string, 1, i); copy_info.new_length = copy_info.old_length +i; end; end; else do; if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code = 0 then do; if action = SAVE then do; if f.source_segment then access = RW_access; else access = REW_access; call hcs_$make_seg (directory_name, entry_name, "", access, seg_ptr, code); if code = error_table_$segknown then code = error_name_dup; end; if code = 0 then do; seg_ptr -> cur_seg = f.current_ptr -> cur_seg; bit_count = f.current_length * 9; call hcs_$set_bc_seg (seg_ptr, bit_count, code); if code = 0 then call hcs_$truncate_seg (seg_ptr, divide (f.current_length + 3, 4, 18), code); end; end; end; end; if code ^= 0 then do; if code = error_table_$noentry then code = error_not_saved; i = index (directory_name, " "); if i = 0 then i = length (directory_name) +1; call dfast_error_ (code, request_id (action), (message)); end; /* This code keps track of the pathname of the last OLD, SAVE, REPLACE for use with COMPILE command */ else if action = READ | action = SAVE | action = REPLACE then do; f.source_directory = directory_name; f.source_entryname = entry_name; end; if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, i); return; end dfast_directory_;  dfast_edit_.pl1 11/05/82 1316.6rew 11/04/82 1552.3 53460 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_edit_: proc (request, arg_string, edit_info_ptr, code); /* This procedure handles all the command level edit functions. It uses these values for request: * * (1) append Append the alter segment onto the end of the current segment (no sort) * (2) sort Merge the alter and current segment and sort. * (3) list List the alter or current segments, or merge and then list * (4) list (no header) Same as list, except the header is not printed. * (5) build Add the string to the current segment. * (6) alter Add the string to the alter segment. * (7) length Merge the temporary segments and print the length. * (9) merge Merge current and alter segments. */ dcl request fixed bin; dcl arg_string char (*); dcl edit_info_ptr ptr; /* ptr to FAST data base */ dcl code fixed bin (35); /* error code */ dcl len fixed bin (21); dcl buffer char (max_seg_size) based; /* for moving segments */ dcl s char (1); /* for length message */ dcl (divide, length, substr) builtin; /* constants */ dcl edit_name (9) char (6) int static options (constant) init ( "append", "sort", "list", "list", "build", "alter", "length", "edit", "merge"); dcl APPEND fixed bin int static options (constant) init (1); dcl SORT fixed bin int static options (constant) init (2); dcl LIST fixed bin int static options (constant) init (3); dcl LISTNH fixed bin int static options (constant) init (4); dcl BUILD fixed bin int static options (constant) init (5); dcl ALTER fixed bin int static options (constant) init (6); dcl LENGTH fixed bin int static options (constant) init (7); dcl MERGE fixed bin int static options (constant) init (9); /* external */ dcl iox_$user_output ptr ext static; dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl dfast_header_ entry (char (*), char (*)); dcl message_ entry (fixed bin (35), char (*), char (*)); dcl ioa_ entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); %include dfast_edit_info; %include dfast_error_codes; /* */ if ^source_segment & request ^= LENGTH then code = error_obj_nop; else do; /* append: The alter segment is appended to the end of the current segment. No editing is done. */ if request = APPEND then do; if alter_length = 0 then code = error_alt_empty; else do; len = current_length + alter_length; if len > max_seg_size then code = error_max_size; else do; substr (current_ptr -> buffer, current_length + 1, alter_length) = alter_ptr -> buffer; current_length = len; alter_length = 0; edit_done = "1"b; end; end; end; else if request = SORT then do; call dfast_merge_ ("1"b, edit_info_ptr, code); end; /* list: If no segment is specified, then the current and alter segment are merged and the resultant current segment is listed. If a line number was given, the segment is listed beginning with the first line equal or greater than that line. */ else if request = LIST | request = LISTNH then do; if arg_string = "alt" then do; if alter_length = 0 then code = error_alt_empty; else do; if request = LIST then call dfast_header_ ("alter", ""); call iox_$put_chars (iox_$user_output, alter_ptr, alter_length, code); end; end; else do; if arg_string ^= "cur" then do; if alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code ^= 0 then return; end; if current_length = 0 then code = error_cur_empty; else do; if request = LIST then call dfast_header_ ((current_name), ""); call iox_$put_chars (iox_$user_output, current_ptr, current_length, code); end; end; end; /* build: The line is appended to the current segment. No editing is done. */ else if request = BUILD then do; len = length (arg_string); if len + current_length > max_seg_size then do; build_mode = "0"b; code = error_max_size; end; else do; substr (current_ptr -> buffer, current_length + 1, len) = arg_string; current_length = current_length + len; edit_done = "1"b; end; end; /* alter: the line is appended to the alter file. No editing is done. */ else if request = ALTER then do; len = length (arg_string); if alter_length + len > max_seg_size then code = error_max_size; else do; substr (alter_ptr -> buffer, alter_length + 1, len) = arg_string; alter_length = alter_length + len; end; end; /* length: If the alter segment is not empty, the current and alter segments are merged. The length of the resultent segment is printed. If the segments can't be merged, an error message is printed and an error return is made. */ else if request = LENGTH then do; if alter_length > 0 then do; call dfast_merge_ ("0"b, edit_info_ptr, code); if code ^= 0 then return; end; if current_length = 0 then s = "s"; else if current_length <= 4096 then s = ""; /* no. of characters in one record */ else s = "s"; call ioa_ ("""^a"" length = ^d words (^d record^a)", current_name, divide (current_length, 4, 17), divide (current_length + 4095, 4096, 17, 0), s); end; else if request = MERGE then do; if alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); end; end; if code ^= 0 then call dfast_error_ (code, edit_name (request), (current_name)); return; end dfast_edit_;  dfast_explain_.pl1 11/05/82 1316.6rew 11/04/82 1552.3 25191 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* * This procedure prints out the explain segments for dfast. * The default is to print all info segments in short form. If the key word * is -long then arguments following are printed in long form. * * The info segments are stored in a special directory with these conventions: * topic.info The short info segment about topic * topic_l.info The long info segment about topic * edit_topic.info The short info segment about the topic request that is part of edit. * (line was: edit explain topic ) * edit_topic_l.info The long info segment about the topic request that is part of edit. */ dfast_explain_: proc (line, caller, code); /* parameters */ dcl line char (*) var; /* user input line */ dcl caller char (*); /* calling program */ dcl code fixed bin (35); /* FAST or Multics code */ dcl directory char (18) int static options (constant) init (">doc>ss>dfast"); dcl topic_length fixed bin (24); dcl topic_ptr ptr; dcl arg char (256) var; dcl num_topics fixed bin; /* topics requested */ dcl prefix char (5) var; dcl suffix char (7); /* ".info" for short "_l.info" for long */ dcl (divide, null) builtin; /* external */ dcl iox_$user_output ptr ext; dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl dfast_get_arg_ entry (char (*) var, char (*) var) returns (bit (1)); dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); %include dfast_error_codes; /* */ if caller = "edit" then prefix = "edit_"; else prefix = ""; suffix = ".info"; num_topics = 0; do while (dfast_get_arg_ (line, arg)); if arg = "-long" then suffix = "_l.info"; else do; call print ((arg)); num_topics = num_topics + 1; end; end; if num_topics = 0 then call print (caller); code = 0; return; print: proc (topic); dcl topic char (*); call hcs_$initiate_count (directory, prefix || topic || suffix, "", topic_length, 0, topic_ptr, code); if topic_ptr ^= null then do; topic_length = divide (topic_length, 9, 17, 0); call iox_$put_chars (iox_$user_output, topic_ptr, (topic_length), code); call hcs_$terminate_noname (topic_ptr, code); end; else call dfast_error_ (error_no_expl, caller, topic); return; end print; end dfast_explain_;  dfast_get_arg_.pl1 11/05/82 1316.6rew 11/04/82 1552.4 16785 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_get_arg_: proc (line, argument) returns (bit (1)); /* This procedure is used to find the next argument on the line. It expects the form: * * [blank | tab] [argument] [blank | tab | comma | semi-colon] * * Any of the fields may be null. If no argument and no delimitor is found, then the procedure returns "0"b. * Otherwise "1"b is returned. */ dcl argument char (256) var; /* next argument (output) */ dcl line char (256) var; /* input buffer */ dcl line_length fixed bin; /* length of line on input */ dcl argument_length fixed bin; /* length of argument */ dcl start fixed bin; /* index in line of start of argument */ dcl (length, search, substr, verify) builtin; /* constants */ dcl white_space char (2) int static options (constant) init (" "); /* */ dcl arg_delimit char (4) int static options (constant) init (" ,;"); /* <,> <;> */ line_length = length (line); if line_length > 0 then do; start = verify (line, white_space); if start > 0 then do; argument_length = search (substr (line, start), arg_delimit); if argument_length = 0 then argument_length = line_length - start + 1; else argument_length = argument_length - 1; argument = substr (line, start, argument_length); start = start + argument_length + 1; /* move beyond the argument delimitor */ if start > line_length then line = ""; else line = substr (line, start, line_length - start + 1); return ("1"b); end; end; return ("0"b); end dfast_get_arg_;  dfast_header_.pl1 11/05/82 1316.6rew 11/04/82 1552.4 8064 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_header_: proc (message_1, message_2); dcl message_1 char (*); dcl message_2 char (*); dcl date_number fixed bin (71); /* clock time */ dcl date_string char (24); /* time in English */ dcl iox_$user_output ptr ext; dcl ioa_$ioa_switch entry options (variable); dcl clock_ entry returns (fixed bin (71)); dcl date_time_ entry (fixed bin (71), char (*)); date_number = clock_ (); call date_time_ (date_number, date_string); call ioa_$ioa_switch (iox_$user_output, "^/^a ^a ^a ^/", message_1, message_2, date_string); return; end dfast_header_;  dfast_line_edit_.pl1 11/05/82 1316.6rew 11/04/82 1552.4 415386 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dfast_line_edit_: proc (line, arg_edit_info_ptr, sort, code); dcl line char (256) var; /* input line with edit request */ dcl arg_edit_info_ptr ptr; /* ptr to edit_info structure */ dcl sort bit (1) unal; /* ON for edit; OFF for editns */ dcl code fixed bin (35); /* fast error code */ /* automatic */ dcl edit_info_ptr ptr; /* ptr to edit_info structure */ dcl start_index fixed bin (21); /* index in the line table "t" to first number in block */ dcl num_1 fixed bin (21); dcl num_2 fixed bin (21); dcl end_index fixed bin (21); /* index in the line table "t" to last number in block */ dcl line_start fixed bin (21); dcl line_end fixed bin (21); dcl num_3 fixed bin (21); dcl t_index fixed bin (21); /* index into line table */ dcl seq_number fixed bin (21); /* sequence number for move, sequence, and resequence commands */ dcl line_number fixed bin (21); dcl string char (10); dcl line_length fixed bin (21); /* length of the line */ dcl last_index fixed bin (21); dcl block_length fixed bin (21); /* number of characters in the block */ dcl block_start fixed bin (21); dcl block_end fixed bin (21); dcl basic_resq_tbl_ptr ptr ; dcl temp_ptr ptr; dcl cur_ptr ptr; dcl cur_length fixed bin (21); dcl request char (3); /* EDIT request */ dcl arg char (256) var; /* argument for dfast_get_arg_ */ dcl num_pic pic "zzzzz9"; dcl temp_length fixed bin (21); dcl (i, j) fixed bin (21); dcl k fixed bin (21); /* temporary used in request routines: list, move, etc. */ dcl print_message bit (1) unal; /* ON if the error message should be printed */ dcl increment fixed bin (21); dcl old_string char (256) var; dcl new_string char (256) var; dcl length_old_string fixed bin (21); dcl length_new_string fixed bin (21); dcl check bit (1); /* ON To prevent substitution of line number */ dcl replace_OK bit (1); /* ON if replace is allowed; OFF if replace would change the line number */ dcl 1 block (16), 2 start fixed bin (21), 2 end fixed bin (21); dcl 1 seq (16), 2 number fixed bin (21), 2 incr fixed bin (21); dcl num_blocks fixed bin (21); dcl 1 copy_info aligned, 2 copy_ptr ptr, /* ptr to base of target segment */ 2 old_length fixed bin (21), /* length of segment before the copy */ 2 new_length fixed bin (21); /* length of segment after the copy */ dcl cleanup condition; /* constants */ dcl max_digits_line_num fixed bin int static options (constant) init (5); /* must match number_pic */ dcl number_pic pic "99999"; /* used to convert number strings to fixed binary */ dcl new_line char (1) int static options (constant) init (" "); dcl white_space char (2) int static options (constant) init (" "); /* tab & blank */ dcl arg_delimiter char (4) int static options (constant) init (" ,;"); /* tab & blank & comma & semi-colon */ dcl digit char (10) int static options (constant) init ("0123456789"); dcl blank char (1) int static options (constant) init (" "); dcl COPY fixed bin int static options (constant) init (5); dcl REPLACE fixed bin int static options (constant) init (0); /* replace: simple replace */ dcl PREFIX fixed bin int static options (constant) init (1); /* replace: prefix request */ dcl SUFFIX fixed bin int static options (constant) init (2); /* replace: suffix request */ /* based */ dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info; dcl temp_seg char (f.max_seg_size) based (temp_ptr); dcl cur_seg char (cur_length) based (cur_ptr); dcl 1 basic_resq_tbl aligned based (basic_resq_tbl_ptr), 2 num_lines fixed bin (21), 2 t (2) aligned, 3 old_number fixed bin (17) unal, 3 new_number fixed bin (17) unal; dcl based_arr (1) ptr based; dcl (addr, divide, index, length, null, ptr, reverse, search, substr, translate, verify) builtin; /* external */ dcl iox_$user_output ptr ext; dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl ioa_$rsnnl entry options (variable); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl dfast_explain_ entry (char (*) var, char (*), fixed bin (35)); dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_get_arg_ entry (char (256) var, char (256) var) returns (bit (1) unal); dcl dfast_basic_resequence_ entry (fixed bin (21), ptr, char (*), bit (1), ptr, fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* include files */ %include dfast_error_codes; %include dfast_edit_info; /* */ edit_info_ptr = arg_edit_info_ptr; print_message = "1"b; basic_resq_tbl_ptr = null; if dfast_get_arg_ (line, arg) then do; request = arg; request = translate (request, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code = 0 then do; cur_ptr = f.current_ptr; cur_length = f.current_length; if request = "loc" then call locate; else if request = "lis" then call list; else if request = "exp" then call dfast_explain_ (line, "edit", code); else do; temp_length = 0; temp_ptr = f.alter_ptr; on cleanup begin; if basic_resq_tbl_ptr ^= null then call free_buffers; end; if request = "joi" then call join ("0"b); else if request = "mer" then call merge; else if request = "app" then call append; else if cur_length > 0 then do; /* following request edit current segment */ if request = "ins" then call insert; else if request = "rep" then call replace (REPLACE); else if request = "pre" then call replace (PREFIX); else if request = "suf" then call replace (SUFFIX); else if request = "des" then call desequence; else if request = "del" then call delete; else if request = "ext" then call extract; else if request = "mov" then call move; else if request = "res" then call resequence; else if request = "seq" then call sequence; else if request = "str" then call string_request; else code = error_unknown_arg; if code = 0 then f.edit_done = "1"b; end; else code = error_cur_empty; end; end; end; else do; code = error_request_miss; arg = ""; end; if code ^= 0 then if print_message then do; if code = error_no_num then arg = ""; call dfast_error_ (code, "edit", (arg)); end; if basic_resq_tbl_ptr ^= null then call free_buffers; return; /* */ free_buffers: proc; dcl acode fixed bin (35); if basic_resq_tbl_ptr ^= null then call release_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, acode); if acode ^= 0 then call dfast_error_ (acode, "edit", "resequence_table"); return; end free_buffers; /* */ /* * This procedure deletes lines from the current segment. The current segment is copied in portions (excluding * the line blocks) into a temporary segment. * * delete [] * * code = 0 Lines were deleted. * code ^= 0 Error code from parse_block_spec * * In case of error, the current segment is not changed. */ delete: proc; call parse_line_list; if code = 0 then do; if num_blocks > 0 then do; last_index = 0; do k = 1 to num_blocks ; call copy_block (last_index + 1, block (k).start - 1); last_index = block (k).end; end; if code = 0 then do; call copy_block (last_index + 1, f.current_length); call switch_buffers; end; end; end; else code = error_no_num; return; end delete; /* */ /* * This procedure extracts lines from the current segment. The lines to be extracted are copied into a temporary * buffer which becomes the current buffer if there are no errors. * * extract [] * * code = 0 Lines were extracted. * code = error_no_num No lines were requested. * code ^= 0 Error code from parse_block_spec * * */ extract: proc; call parse_line_list; if code ^= 0 then return; if num_blocks > 0 then do; do k = 1 to num_blocks; call copy_block ((block (k).start), (block (k).end)); if code ^= 0 then return; end; call switch_buffers; end; else code = error_line_miss; return; end extract; /* */ /* * This procedure lists the lines requested. * * list [] * * code = 0 Lines were printed * code ^= 0 Error code from parse_block_spec * * Lines will be listed until the line list is exhausted or until the first error. * */ list: proc; if cur_length > 0 then do; call parse_line_list; if code ^= 0 then return; if num_blocks = 0 then do; num_blocks = 1; block (1).start = 1; block (1).end = cur_length; end; do k = 1 to num_blocks; call iox_$put_chars (iox_$user_output, addr (substr (cur_seg, block (k).start, 1)), block (k).end - block (k).start + 1, code); call iox_$put_chars (iox_$user_output, addr (new_line), 1, code); end; end; else code = error_cur_empty; return; end list; /* */ /* * This procedure parses a list of segment pathnames and appends the segments onto the end of the current segment. */ join: proc (fill_block_table); dcl fill_block_table bit (1) unal; /* ON if should fill in block structure */ copy_info.copy_ptr = temp_ptr; copy_info.old_length = 0; num_blocks = 0; do while (copy_seg ()); if fill_block_table then do; if num_blocks < 16 then do; num_blocks = num_blocks + 1; block (num_blocks).start = copy_info.old_length + 1; block (num_blocks).end = copy_info.new_length; end; else do; code = error_max_lines; return; end; end; copy_info.old_length = copy_info.new_length; end; if code = 0 then do; temp_length = copy_info.old_length; call switch_buffers; end; return; end join; /* */ /* * The append command reads one or more segments and resequences them. * * append seg_1 [, seg_2>] . . . */ append: proc; call join (f.basic_system); if code = 0 then do; temp_length = 0; seq_number = 100; increment = 10; cur_ptr = f.current_ptr; /* re-initialize, since JOIN called switched buffers */ temp_ptr = f.alter_ptr; cur_length = f.current_length; if ^f.basic_system then do; call renumber (1, cur_length, seq_number, increment); if code = 0 then call switch_buffers; end; else do; call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code); if code = 0 then do; do i = 1 to num_blocks while (code = 0); num_lines = 0; call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, block (i).start, block (i).end, seq_number, increment); if code = 0 then call copy_resq ("1"b, block (i).start, block (i).end); end; if code = 0 then call switch_buffers; end; end; end; return; end append; /* */ /* This procedure merges one or more segments. The segments are copied into a tempory buffer and then sorted using the edit rules of dfast_merge_. */ merge: proc; call join ("0"b); if code = 0 then call dfast_merge_ ("1"b, edit_info_ptr, code); return; end merge; /* */ /* This procedure copies all the segments into the current segment. It then copies and renumbers the entire segment. * * insert seg_name [;seg_name, line_number] */ insert: proc; dcl index_arr (16) fixed bin (21); dcl second_tbl_ptr ptr; dcl k fixed bin (21); dcl 1 second_tbl aligned based (second_tbl_ptr) like basic_resq_tbl; call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code); seq_number = 100; increment = 10; num_blocks = 0; basic_resq_tbl.num_lines = 0; last_index = 0; copy_info.copy_ptr = cur_ptr; copy_info.old_length = 0; if copy_seg () then do; cur_length, copy_info.old_length = copy_info.new_length; do while (copy_seg () & code = 0); if num_blocks < 16 then do; num_blocks = num_blocks + 1; if find_line ((0), index_arr (num_blocks)) then do; if index_arr (num_blocks) >= last_index then do; block (num_blocks).start = copy_info.old_length + 1; block (num_blocks).end = copy_info.new_length; copy_info.old_length = copy_info.new_length; if f.basic_system then do; call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, last_index + 1, index_arr (num_blocks), seq_number, increment); seq (num_blocks).number = seq_number; i = block (num_blocks).start; do while (i <= block (num_blocks).end); j = index (substr (cur_seg, i, block (num_blocks).end - i + 1), new_line); if j > 0 then do; seq_number = seq_number + increment; i = i + j; end; else i = block (num_blocks).end + 1; end; end; last_index = index_arr (num_blocks); end; else code = error_line_order; end; end; else code = error_max_lines; end; if num_blocks = 0 then code = error_request_miss; end; else code = error_request_miss; if code ^= 0 then return; if f.basic_system then call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, last_index + 1, cur_length, seq_number, increment); k = cur_length; cur_length = block (num_blocks).end; last_index = 0; /* If the system is not basic the segment is just copied and renumbered */ if ^f.basic_system then do; do i = 1 to num_blocks while (code = 0); call renumber (last_index + 1, index_arr (i), seq_number, increment); call renumber (block (i).start, block (i).end, seq_number, increment); last_index = index_arr (i); end; call renumber (last_index + 1, k, seq_number, increment); if code = 0 then call switch_buffers; return; end; second_tbl_ptr = addr (basic_resq_tbl_ptr -> basic_resq_tbl.t (basic_resq_tbl.num_lines + 1).old_number); second_tbl.num_lines = 0; do i = 1 to num_blocks while (code = 0); if last_index < index_arr (i) then call copy_resq ("1"b, last_index + 1, index_arr (i)); last_index = index_arr (i); second_tbl.num_lines = 0; call fill_basic_tbl (second_tbl_ptr, "0"b, block (i).start, block (i).end, seq (i).number, increment); call dfast_basic_resequence_ (f.max_seg_size, second_tbl_ptr, substr (cur_seg, block (i).start, block (i).end - block (i).start + 1), "1"b, temp_ptr, temp_length, code); end; if code = 0 then do; if last_index < k then call copy_resq ("1"b, last_index + 1, k); if code = 0 then call switch_buffers; end; return; end insert; /* */ /* This procedure moves one block of lines to a position following a given line number * * move num_1 - num_2, num_3 * * If line_num is not present, the block is moved to a position following the logical spot for line_num. * The block that was moved is resequence with an initial value of line_num + 1 and an increment of 1. * Lines following the block are resequenced if the block renumbering caused duplicate line numbers. * * code = 0 successful * line_num is within the range of the block. * = error_block_spec the block contains no numbers */ move: proc; if parse_block_spec (1, start_index, end_index) then do; if find_line (line_start, line_end) then do; seq_number = num_3 +1; if f.basic_system then call basic_move; else do; if num_3 < num_1 then do; call copy_block (1, line_end); call renumber (start_index, end_index, seq_number, 1); call renumber_if_necessary (line_end + 1, start_index -1, seq_number); call renumber_if_necessary (end_index +1, cur_length, seq_number); end; else if num_2 < num_3 then do; call copy_block (1, start_index -1); call copy_block (end_index + 1, line_end); if end_index > start_index then call renumber (start_index, end_index, seq_number, 1); call renumber_if_necessary (line_end + 1, cur_length, seq_number); end; else code = error_block_spec; end; if code = 0 then call switch_buffers; end; else code = error_no_num; end; else code = error_request_miss; return; end move; /* */ /* * This procedure resequences the file and edits the source code to reflect the new numbers. * There are two types of editing done. * "0"b the line keeps its line number, but line references are changed. * "1"b both the line and any line references are changed. */ basic_move: proc; call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code); if code ^= 0 then return; num_lines = 0; call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, start_index, end_index, seq_number, 1); if num_3 < num_1 then do; call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, line_end +1, start_index -1, seq_number, 1); call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, end_index + 1, cur_length, seq_number, 1); if sort then do; call copy_resq ("0"b, 1, line_end); call copy_resq ("1"b, start_index, end_index); call copy_resq ("1"b, line_end + 1, start_index -1); call copy_resq ("1"b, end_index +1, cur_length); end; else call copy_resq ("1"b, 1, cur_length); end; else if num_2 < num_3 then do; call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, line_end + 1, cur_length, seq_number, 1); if sort then do; call copy_resq ("0"b, 1, start_index -1); call copy_resq ("0"b, end_index + 1, line_end); if end_index > start_index then call copy_resq ("1"b, start_index, end_index); call copy_resq ("1"b, line_end + 1, cur_length); end; else call copy_resq ("1"b, 1, cur_length); end; else code = error_block_spec; return; end basic_move; /* */ /* * This procedure calls dfast_basic_resequence_. It operates in two ways. * * "1"b Both the line number and any line references are changed. * "0"b Just the line references are changed. */ copy_resq: proc (resequence_lines, start, end); dcl resequence_lines bit (1); dcl start fixed bin (21); dcl end fixed bin (21); call dfast_basic_resequence_ (f.max_seg_size, basic_resq_tbl_ptr, substr (cur_seg, start, end - start + 1), resequence_lines, temp_ptr, temp_length, code); return; end copy_resq; /* */ /* This procedure prints all lines that contain the given string. * * locate /old_string/ [] * * (Any character except blank or tab may be used as a delimiter.) * * code = 0 At least one string found. * = error_no_string String was not found. * = error_no_nl Segment does not end in a new_line. (presumably not source) */ locate: proc; dcl string_found bit (1) unal; /* ON if string was found at least once */ if cur_length > 0 then do; if parse_string_args ("1"b) then do; string_found = "0"b; do k = 1 to num_blocks; start_index = block (k).start; block_length = block (k).end - block (k).start + 1; do while (block_length > 0 & code = 0); i = index (substr (cur_seg, start_index, block_length), old_string); if i > 0 then do; j = index (reverse (substr (cur_seg, start_index, i)), new_line); if j > 0 then do; block_length = block_length +j -i -1; start_index = start_index +i -j +1; end; j = index (substr (cur_seg, start_index, block_length), new_line); if j > 0 then do; call iox_$put_chars (iox_$user_output, addr (substr (cur_seg, start_index, 1)), j, code); start_index = start_index + j; block_length = block_length - j; string_found = "1"b; end; else code = error_no_nl; end; else block_length = 0; end; end; if code = 0 then if ^string_found then code = error_no_string; end; end; else code = error_cur_empty; return; end locate; /* */ /* * This procedure replaces old_string with new_string for a given block of lines. * The line numbers can not be changed. * * replace /// [] (REPLACE) * * prefix /// [] (PREFIX) * * suffix /// [] (SUFFIX) * * (Any character except blank or tab may be used as a delimiter) */ replace: proc (replace_type); dcl replace_type fixed bin; if parse_string_args ("0"b) then do; if replace_type ^= REPLACE then do; length_new_string = length_new_string + length_old_string; if length_new_string <= 256 then do; if replace_type = PREFIX then new_string = new_string || old_string; else new_string = old_string || new_string; end; else do; code = error_string_size; return; end; end; /* Search through blocks of lines and replace the string. The new code is stored in temp_seg */ last_index = 0; do k = 1 to num_blocks; start_index = block (k).start; block_length = block (k).end - block (k).start; do while (block_length > 0); i = index (substr (cur_seg, start_index, block_length), old_string) -1; if i > - 1 then do; /* This check is done if old_string begins with a digit. It searches back for the first non-digit. * It sets replace_OK = 1, if the replacement would not change a line number. * * j = 0 A line number at the start of a block. * j > 0 & character = new_line The first non-digit is new_line. * j > 0 & character ^= new_line A string inside a line. */ if check then do; j = verify (reverse (substr (cur_seg, 1, start_index + i -1)), digit); if j > 0 then do; if substr (cur_seg, start_index + i - j, 1) = new_line then replace_OK = "0"b; else replace_OK = "1"b; end; else replace_OK = "0"b; end; if replace_OK then do; i = start_index + i - 1; call copy_block (last_index + 1, i); substr (temp_seg, temp_length +1, length_new_string) = new_string; temp_length = temp_length + length_new_string; last_index = i + length_old_string; block_length = block_length - last_index + start_index - 1; start_index = last_index + 1; end; else do; replace_OK = "1"b; start_index = start_index + i + length_old_string; block_length = block_length - i - length_old_string + 1; end; end; else block_length = 0; end; end; if last_index ^= 0 then do; call copy_block (last_index + 1, cur_length); call switch_buffers; end; else do; code = error_no_string; arg = old_string; end; end; return; end replace; /* */ /* * This procedure parses the argument list for LOCATE, REPLACE, PREFIX, SUFFIX * * /old_string/new_string/ line_list * * If line_list is missing, LOCATE uses the entire text. The line_list must be present for * REPLACE, PREFIX and SUFFIX. These global variables are set: * * old_string * old_string_length * new_string * new_string_length * num_blocks * block (1, num_block) */ parse_string_args: proc (one_string_sw) returns (bit (1)); dcl one_string_sw bit (1) unal; /* ON if only one string is expected -- LOCATE */ dcl (i, j) fixed bin; dcl delimiter char (1); i = verify (line, white_space); if i > 0 then do; delimiter = substr (line, i, 1); arg = delimiter; j = index (substr (line, i + 1), delimiter); if j > 1 then do; old_string = substr (line, i +1, j - 1); arg = old_string; /* for error message */ length_old_string = j -1; i = i + j + 1; if one_string_sw then line = substr (line, i); else do; j = index (substr (line, i), delimiter); if j > 0 then do; new_string = substr (line, i, j-1); length_new_string = j -1; line = substr (line, i +j); end; else code = error_delimiter_miss; end; end; else if j = 1 then code = error_syntax_string; else code = error_delimiter_miss; end; else do; code = error_delimiter_miss; arg = ""; end; if code = 0 then do; call parse_line_list; if code = 0 then do; if index (digit, substr (old_string, 1, 1)) ^= 0 then check = "1"b; else if index (digit, substr (new_string, 1, 1)) ^= 0 then check = "1"b; else check = "0"b; replace_OK = "1"b; if num_blocks > 0 then return ("1"b); else if request = "loc" then do; num_blocks = 1; block (1).start = 1; block (1).end = cur_length; return ("1"b); end; else code = error_no_num; end; end; return ("0"b); end parse_string_args; /* */ /* * This procedure removes a number followed by a blank on each line. If there is no number present, the * line is copied as is. If there is no blank following the number, just the number is removed. * * desequence * */ desequence: proc; start_index = 1; do while (start_index <= cur_length & code = 0); i = verify (substr (cur_seg, start_index), digit) -1; if i > -1 then do; if i > 0 then if substr (cur_seg, start_index + i, 1) = blank then i = i + 1; start_index = start_index + i; j = index (substr (cur_seg, start_index), new_line); if j > 0 then do; call copy_block (start_index, start_index + j -1); start_index = start_index + j; end; else code = error_no_nl; end; else code = error_no_nl; end; if code = 0 then call switch_buffers; return; end desequence; /* */ /* * This procedure adds a sequence number and one blank to each line. It uses new_number for the first line * and adds increment to get the next line number. The default is to start with 100 and increment * by 10. * * sequence new_number, increment * */ sequence: proc; seq_number = 100; increment = 10; if parse_number (seq_number) then if parse_number (increment) then; if code = 0 then do; if cur_length > 0 then do; start_index = 1; do while (start_index <= cur_length); i = index (substr (cur_seg, start_index), new_line); if i > 0 then do; call ioa_$rsnnl ("^d ", string, j, seq_number); if temp_length + j + i <= f.max_seg_size then do; substr (temp_seg, temp_length + 1, j) = string; temp_length = temp_length + j; substr (temp_seg, temp_length + 1, i) = substr (cur_seg, start_index, i); temp_length = temp_length + i; start_index = start_index + i; seq_number = seq_number + increment; end; else do; code = error_max_size; return; end; end; else code = error_no_nl; end; if code = 0 then call switch_buffers; end; else code = error_cur_empty; end; return; end sequence; /* */ /* This procedure has an optional argument list: * * resequence [] [,] [,] * * new number Line number to use for the resequencing. * line_number Line at which to begin resequencing. * increment Increment added each time to new_number. * */ resequence: proc; call resequence_args; last_index = 0; if f.basic_system then do; call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code); if code ^= 0 then return; num_lines = 0; do k = 1 to num_blocks; call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, block (k).start, block (k).end, seq (k).number, seq (k).incr); end; do k = 1 to num_blocks while (code = 0); call copy_resq ("0"b, last_index + 1, block (k).start -1); call copy_resq ("1"b, block (k).start, block (k).end); last_index = block (k).end; end; if code = 0 then call copy_resq ("0"b, last_index + 1, cur_length); end; else do; do k = 1 to num_blocks while (code = 0); if block (k).start > last_index then do; call copy_block (last_index + 1, block (k).start -1); call renumber (block (k).start, block (k).end, seq (k).number, seq (k).incr); last_index = block (k).end; end; else code = error_line_order; end; if code = 0 then call copy_block (last_index + 1, cur_length); end; if code = 0 then do; call switch_buffers; if sort then call dfast_merge_ ("1"b, edit_info_ptr, code); end; return; end resequence; /* */ /* This procedure parses the user's input line for a resequence spceifcation. It returns "1"b if some of the block specification was found and returns "0"b if the argument list is exhausted. If errors occur code is set and "0"b is returned. */ resequence_args: proc (); num_blocks = 0; do while (code = 0); if parse_number (seq_number) then do; if get_numbers (num_1, num_2) then do; if get_equal_lower_line (1, num_1, block_start, block_end) then do; if block_start = 0 then block_start = 1; if num_1 = num_2 then block_end = cur_length; else if ^get_equal_lower_line (1, num_2, block_start, block_end) then code = error_line_miss; if ^parse_number (increment) then increment = 10; end; else code = error_line_miss; end; else do; if num_blocks = 0 then block_start = 1; else block_start = block_end + 1; block_end = cur_length; increment = 10; end; end; else do; if num_blocks > 0 then return; block_start = 1; block_end = cur_length; seq_number = 100; increment = 10; end; num_blocks = num_blocks + 1; if num_blocks <= 16 then do; block (num_blocks).start = block_start; block (num_blocks).end = block_end; seq (num_blocks).number = seq_number; seq (num_blocks).incr = increment; end; end; return; end resequence_args; /* */ /* * This request converts the segment into fixed record format. * * string */ string_request: proc; dcl bit_count fixed bin (24); dcl directory char (168) ; dcl directory_length fixed bin; dcl entry_name char (32) ; dcl iocb_ptr ptr; /* ptr to iocb in creating blocked file */ dcl record_length fixed bin (21); /* length of records in new file */ dcl cleanup condition; dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); arg = ""; if parse_number (record_length) then do; if record_length ^= 0 then do; call hcs_$fs_get_path_name (temp_ptr, directory, directory_length, entry_name, code); if code = 0 then do; call hcs_$set_bc_seg (temp_ptr, 0, code); if code ^= 0 then call dfast_error_ (code, "string",""); num_pic = record_length; iocb_ptr = null; on cleanup call cleanup_iocb (iocb_ptr); call iox_$attach_ioname ("string", iocb_ptr, "vfile_ " || substr (directory, 1, directory_length) || ">" || entry_name || " -blocked " || num_pic || " -ssf", code); if code = 0 then do; call iox_$open (iocb_ptr, 5, "0"b, code); start_index = 1; do while (start_index <= cur_length & code = 0); i = index (substr (cur_seg, start_index), new_line) -1; if i >= 0 then do; if i <= record_length then do; call iox_$write_record (iocb_ptr, addr (substr (cur_seg, start_index,1)), i, code); start_index = start_index + i +1; end; else do; code = error_size_fixed_record; num_pic = i; arg = num_pic; end; end; else code = error_no_nl; end; call cleanup_iocb (iocb_ptr); if code = 0 then do; call hcs_$status_mins (temp_ptr, 0, bit_count, code); temp_length = divide (bit_count + 8, 9, 21, 0); end; end; end; end; else code = error_bad_rec_len; end; else code = error_bad_rec_len; if code = 0 then call switch_buffers; return; end string_request; cleanup_iocb: proc (iocb_ptr); dcl iocb_ptr ptr; dcl code fixed bin (35); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); %include iocb; /* */ code = 0; if iocb_ptr ^= null then do; if iocb_ptr -> iocb.open_descrip_ptr ^= null then call iox_$close (iocb_ptr, code); if code = 0 then do; call iox_$detach_iocb (iocb_ptr, code); call iox_$destroy_iocb (iocb_ptr, code); end; end; if code ^= 0 then call dfast_error_ (code, "string",""); return; end cleanup_iocb; /* */ /* This procedure copies a block of characters from the current segment into the temporary segment. If the procedure is called with end_index > start_index no coping is done. */ copy_block: proc (start_index, end_index); dcl start_index fixed bin (21); dcl end_index fixed bin (21); dcl block_length fixed bin (21); if start_index <= end_index then do; block_length = end_index - start_index + 1; if temp_length + i <= f.max_seg_size then do; substr (temp_seg, temp_length + 1, block_length) = substr (cur_seg, start_index, block_length); temp_length = temp_length + block_length; end; else code = error_max_size; end; return; end copy_block; /* */ /* This procedure renumbers a block of lines and copies the lines into the temporary segment. */ renumber: proc (start_index, end_index, new_number, increment); dcl start_index fixed bin (21); dcl end_index fixed bin (21); dcl new_number fixed bin (21); dcl increment fixed bin (21); dcl (i, j) fixed bin (21); t_index = start_index; do while (t_index <= end_index); line_length = index (substr (cur_seg, t_index, end_index - t_index + 1), new_line); if line_length > 0 then do; i = verify (substr (cur_seg, t_index, line_length), digit); call ioa_$rsnnl ("^d", string, j, new_number); line_length = line_length - i + 1; substr (temp_seg, temp_length + 1, j) = string; temp_length = temp_length + j; substr (temp_seg, temp_length + 1, line_length) = substr (cur_seg, t_index + i -1, line_length); temp_length = temp_length + line_length; new_number = new_number + increment; t_index = t_index + line_length + i; end; end; return; end renumber; /* */ renumber_if_necessary: proc (start_index, end_index, new_number); dcl start_index fixed bin (21); dcl end_index fixed bin (21); dcl new_number fixed bin (21); t_index = start_index; do while (t_index <= end_index); i = verify (substr (cur_seg, t_index, end_index - t_index + 1), digit); if i > 1 then do; num_1 = cv_dec_check_ (substr (cur_seg, t_index, i-1), code); if code = 0 then do; line_length = index (substr (cur_seg, t_index, end_index - t_index + 1), new_line); if num_1 < new_number then call renumber (t_index, line_length, new_number, 1); else do; call copy_block (t_index, end_index); return; end; t_index = t_index + line_length; end; end; end; return; end renumber_if_necessary; /* */ /* This procedure switches the pointers so that the temporary buffer becomes the current segment */ switch_buffers: proc; f.current_ptr = temp_ptr; f.current_length = temp_length; f.alter_ptr = cur_ptr; return; end switch_buffers; /* */ /* * The procedure parses the line for a line number or block specification. * There are two forms: * * 1. One line number: [] * block_start, block_end = the index in the line. * * 2. Block specification: [ - ] * * block_start The index of the line OR the next higher line that is <= the block_end. * block_end The index of the end of the line OR the next lower line that is >= block_start. * * code = 0 The line index was found. * = error_line_miss The line could not be found. * = error_bad_line Format error in line specification. */ parse_block_spec: proc (search_start, block_start, block_end) returns (bit (1)); dcl search_start fixed bin (21); dcl block_start fixed bin (21); dcl block_end fixed bin (21); dcl line_start fixed bin (21); /* beginning of line being looked at */ dcl num_chars fixed bin (21); /* num characters in line */ arg = line; if ^parse_two_numbers (num_1, num_2) then return ("0"b); line_start = search_start; do while (line_start <= cur_length); call get_line_number (line_start, num_chars, line_number); if num_1 <= line_number then do; block_start = line_start; block_end = line_start + num_chars -1; if num_1 = num_2 then do; if num_1 = line_number then return ("1"b); else code = error_line_miss; end; if line_number <= num_2 then do; if get_equal_lower_line (block_end + 1, num_2, (0), block_end) then return ("1"b); if code = 0 then return ("1"b); end; else code = error_line_miss; return ("0"b); end; line_start = line_start + num_chars; end; if code = 0 then code = error_line_miss; return ("0"b); end parse_block_spec; /* */ parse_two_numbers: proc (num_1, num_2) returns (bit (1) unal); dcl num_1 fixed bin (21); dcl num_2 fixed bin (21); if parse_number (num_1) then do; line_start = verify (line, white_space); if line_start > 0 then do; if substr (line, line_start, 1) = "-" then do; if line_start < length (line) then do; line = substr (line, line_start + 1); if parse_number (num_2) then do; if num_1 > num_2 then code = error_block_spec; end; else code = error_block_spec; end; else code = error_block_spec; end; else num_2 = num_1; end; else num_2 = num_1; end; else return ("0"b); if code = 0 then return ("1"b); end parse_two_numbers; /* */ get_equal_lower_line: proc (search_start, num, line_start, line_end) returns (bit (1) unal); dcl search_start fixed bin (21); dcl num fixed bin (21); dcl line_start fixed bin (21); dcl line_end fixed bin (21); i = search_start; do while (i <= cur_length); call get_line_number (i, j, line_number); if code = 0 then do; if line_number > num then do; if i = search_start then return ("0"b); line_start, line_end = i -1; return ("1"b); end; else if line_number = num then do; line_start = i; line_end = i + j -1; return ("1"b); end; i = i + j; end; else return ("0"b); end; line_start, line_end = cur_length; return ("1"b); end get_equal_lower_line; /* */ /* * This procedure parses the input line for a line number. It returns the indices of the start and end of * of the line. * * 1. The line exists: * line_start index of start of the line. * line_end index of end of the line. * * 2. The line does not exits: * line_start the index of the end of the line which would logically preceed the * missing line. * line_end = line_start */ find_line: proc (line_start, line_end) returns (bit (1)); dcl line_start fixed bin (21); dcl line_end fixed bin (21); if parse_number (num_3) then do; if get_equal_lower_line (1, num_3, line_start, line_end) then return ("1"b); else if code = 0 then do; line_start, line_end = 0; return ("1"b); end; end; else if code = 0 then code = error_request_miss; return ("0"b); end find_line; /* */ /* After the first number is found, a search is made for a minus sign preceeded by blanks or tabs. * * 1. Minus sign is found: The next item must be a valid number or an error code is returned. * * 2. Minus sign is not found: The first number is returned. */ get_numbers: proc (num_1, num_2) returns (bit (1)); dcl num_1 fixed bin (21); dcl num_2 fixed bin (21); /* Save the current argument for an error message */ i = search (line, ",;"); if i = 0 then i = length (line); arg = substr (line, 1, i); if parse_number (num_1) then do; num_2 = num_1; i = verify (line, white_space); if i = 0 then return ("1"b); if substr (line, i, 1) ^= "-" then return ("1"b); if length (line) > i then do; line = substr (line, i+1); if parse_number (num_2) then return ("1"b); end; else code = error_bad_line; end; return ("0"b); end get_numbers; /* */ /* This procedure parses a line in the current segment and returns its line number. * code = 0 Line begins with a positive or 0 number. * no_nl Segment does not end with a new_line. * bad_sort Line has no number, editing can't continue. */ get_line_number: proc (start, num_chars, line_number); /* parameters */ dcl start fixed bin (21); dcl num_chars fixed bin (21); dcl line_number fixed bin (21); num_chars = verify (substr (cur_seg, start), digit) - 1; if num_chars > 0 then do; if num_chars <= max_digits_line_num then do; number_pic = 0; substr (number_pic, max_digits_line_num - num_chars + 1, num_chars) = substr (cur_seg, start, num_chars); line_number = number_pic; end; else do; code = error_max_line_number; arg = substr (cur_seg, start, num_chars); end; end; else code = error_bad_sort; num_chars = index (substr (cur_seg, start), new_line); if num_chars = 0 then code = error_no_nl; return; end get_line_number; /* */ /* This procedure parses the line for a number of the form: * [blank]... [] */ parse_number: proc (num) returns (bit (1)); dcl num fixed bin (21); dcl (start, num_chars) fixed bin (21); dcl num_string char (10); start = verify (line, white_space); if start > 0 then do; num_chars = verify (substr (line, start), digit); if num_chars = 0 then num_chars = length (line) - start +1; else num_chars = num_chars -1; if num_chars > 0 then do; if num_chars <= max_digits_line_num then do; num_string = substr (line, start, num_chars); number_pic = 0; substr (number_pic, max_digits_line_num - num_chars + 1, num_chars) = substr (line, start, num_chars); num = number_pic; start = num_chars + start; if start <= length (line) then do; num_chars = verify (substr (line, start), arg_delimiter); if num_chars > 0 then start = start+num_chars-1; end; line = substr (line, start); return ("1"b); end; else code = error_max_line_number; end; else code = error_bad_line; end; return ("0"b); end parse_number; /* */ /* This procedure parses the user input line for a pathname and copies the segment onto the end of the current segment. */ copy_seg: proc () returns (bit (1)); if dfast_get_arg_ (line, arg) then do; call dfast_directory_ (COPY, (arg), edit_info_ptr, addr (copy_info), code); if code = 0 then return ("1"b); print_message = "0"b; end; return ("0"b); end copy_seg; /* */ parse_line_list: proc; dcl search_start fixed bin (21); /* index in cur_seg to begin search */ dcl last_num fixed bin (21); /* highest number so far in the line list */ num_blocks = 0; search_start = 1; last_num = -1; do while (parse_block_spec (search_start, block_start, block_end)); if num_blocks < 16 then do; if num_1 > last_num then do; num_blocks = num_blocks + 1; block (num_blocks).start = block_start; block (num_blocks).end = block_end; end; else code = error_line_order; end; else code = error_max_lines; if code ^= 0 then return; search_start = block_end + 1; last_num = num_2; end; if code = error_line_miss then if last_num > num_1 then code = error_line_order; return; end parse_line_list; /* */ fill_basic_tbl: proc (table_ptr, conditional, start, end, seq_number, increment); dcl table_ptr ptr; /* ptr to structure to be filled in */ dcl conditional bit (1); /* ON set entry only if number < seq_number */ dcl start fixed bin (21); /* index on current_segment of start of block being checked */ dcl end fixed bin (21); /* index on current_segment of end of block */ dcl seq_number fixed bin (21); /* new sequence number to use */ dcl increment fixed bin (21); /* increment for sequence number */ dcl index fixed bin (21); dcl 1 tbl aligned based (table_ptr) like basic_resq_tbl; index = start; do while (index < end & code = 0); call get_line_number (index, j, line_number); if conditional then if line_number >= seq_number then return; num_lines = num_lines + 1; t (num_lines).old_number = line_number; t (num_lines).new_number = seq_number; seq_number = seq_number + increment; index = index + j; end; return; end fill_basic_tbl; end dfast_line_edit_;  dfast_list_.pl1 11/05/82 1316.6rew 11/04/82 1659.2 48690 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_list_: proc (arg_edit_info_ptr, temp_seg_id, line_number, header, punch, code); /* This procedure lists or punches the current or the alter segment. * * temp_seg_id = alt List the alter segment. * = cur List the current segment. * = "" Merge the alter and current segments and then list the current segment. * * line_number = -1 List the entire segment. * = n List the segment beginning with line "n". If "n" is greater than the highest * line number, then the last line will be listed. * * code = bad_sort The current segment is out of order so that the merge can't be completed. * = alt_empty The alter segment is empty. * = cur_empty The current segment is empty. */ /* parameters */ dcl arg_edit_info_ptr ptr; /* ptr. to dfast_edit_info_ */ dcl temp_seg_id char (*); /* temporary seg. to list: alt, cur, "" */ dcl line_number fixed bin (21); /* line at which to begin printing */ dcl header bit (1) unal; /* ON if header should be printed. */ /* automatic */ dcl edit_info_ptr ptr; /* ptr to dfast_edit_info */ dcl start fixed bin (21); /* character index at which to begin printing */ dcl name char (32); /* name for error message OR name for header */ dcl punch bit (1) unal; /* ON if the output should be punched. */ dcl code fixed bin (35); /* Multics OR fast error code */ dcl old_modes char (132); /* old modes for restore */ /* external */ dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_header_ entry (char (*), char (*)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (21)); dcl iox_$user_output ptr ext static; /* constants */ dcl punch_header char (16) int static options (constant) init (""); /* CTRL-R (15) \177 */ dcl punch_trailer char (17) int static options (constant) init (""); /* CTRL-S (15) \177 CTRL-T */ dcl new_line char (1) int static options (constant) init (" "); dcl digit char (10) int static options (constant) init ("0123456789"); /* based */ dcl 1 f aligned like dfast_edit_info based (edit_info_ptr); dcl (addr, index, length, substr, reverse) builtin; %include dfast_edit_info; %include dfast_error_codes; /* */ edit_info_ptr = arg_edit_info_ptr; if f.source_segment then do; if temp_seg_id = "alt" then do; name = "alter"; if f.alter_length > 0 then call list (f.alter_ptr, f.alter_length); else code = error_alt_empty; end; else do; if temp_seg_id ^= "cur" then do; if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code ^= 0 then return; name = f.current_name; end; else name = "current"; if f.current_length > 0 then call list (f.current_ptr, f.current_length); else code = error_cur_empty; end; end; else code = error_obj_nop; if code ^= 0 then do; if punch then name = "punch"; else name = "list"; call dfast_error_ (code, name, ""); end; return; /* */ list: proc (temp_ptr, temp_length); /* parameters */ dcl temp_ptr ptr; /* ptr. to segment to list */ dcl temp_length fixed bin (21); /* number of characters in segment */ dcl temp_seg char (temp_length) based (temp_ptr); if line_number < 0 then start = 1; else do; call find_line (temp_ptr, temp_length, start, code); if code ^= 0 then return; end; if punch then call output_special_chars (punch_header); else if header then call dfast_header_ (name, ""); call iox_$put_chars (iox_$user_output, addr (substr (temp_seg, start, 1)), temp_length - start + 1, code); if punch then call output_special_chars (punch_trailer); return; end list; find_line: proc (temp_ptr, temp_length, start, code); dcl temp_ptr ptr; dcl temp_length fixed bin (21); dcl start fixed bin (21); dcl code fixed bin (35); dcl (i, j) fixed bin (21); dcl temp_seg char (temp_length) based (temp_ptr); start = 1; do while (start <= temp_length & code = 0); i = verify (substr (temp_seg, start), digit); if i > 1 then do; j = cv_dec_check_ (substr (temp_seg, start, i), code); if code = 0 then if j >= line_number then return; else; else code = error_bad_sort; end; i = index (substr (temp_seg, start), new_line); if i > 0 then start = start + i; else code = error_no_nl; end; if code = 0 then start = start - i; return; end find_line; /* */ output_special_chars: proc (string); dcl string char (*); dcl acode fixed bin (35); old_modes = ""; call iox_$modes (iox_$user_output, "rawo", old_modes, acode); call iox_$put_chars (iox_$user_output, addr (string), length (string), acode); call iox_$modes (iox_$user_output, old_modes, "", code); return; end output_special_chars; end dfast_list_;  dfast_merge_.pl1 01/19/88 1507.0rew 01/19/88 1459.5 67671 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806), audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015): - Declare "table_ptr pointer" as a result of changing the include file named dfast_line_table.incl.pl1. See that include file for more details. - Remove alter_ptr, dfast_err_, new_line, and white_space from the source since they are not referenced anywhere within the source. - Declare "addr" and "ptr" as builtin type since they are referenced, but they are not defined anywhere with the source. END HISTORY COMMENTS */ dfast_merge_: proc (force_sort, arg_edit_info_ptr, code); /* This procedure merges the current and alter segments. An ordered segment follows these conventions: * * * 1. All lines begin with a positive number. * 2. All lines end with the new_line character. * 3. There is only one line for a given number. * 4. Lines are stored with line numbers in accending order. * * There are two ways to call the procedure: * * 1. Convert the segment to ordered form (convert = "1"b). A code of zero is returned in * all cases, since the procedure forces an ordered segment. * * a. Illegal lines (lines that do not begin with a positive number or don't end with a new_line * character) are deleted. * * b. In the case of lines with the same line number, the line furthest from the beginning of the * segment is kept. The other lines with that number are deleted. * * c. Lines are sorted so that their line numbers are in accending order. * * 2. Do not convert the segment to ordered form (convert = "0"b). If the segment * is not ordered, an error message is printed giving the line that caused the error and an * error code is returned. The segment is not changed. * * code = 0 The segment is ordered. * = error_bad_sort At least one line is out of order. * = error_no_nl The segment does not end in a new_line. * = error_bad_line An illegal number (negative or too large) was found on the line. * = error_no_num A line without a number was found. * * * The scratch buffers used: * * alter_ptr ptr to the alter segment * temp_ptr ptr to the new current segment * cur_table_ptr ptr to the table of line information for the current segment * alt_table_ptr ptr to the table of line information for the alter segment * */ /* parameters */ dcl force_sort bit (1) unal; dcl arg_edit_info_ptr ptr; dcl code fixed bin (35); dcl clean_up condition; dcl edit_info_ptr ptr; dcl dfast_get_table_ entry (bit (1) unal, ptr, fixed bin (21), ptr, fixed bin (35)); dcl free_table_buffers bit (1) unal; /* ON if should free; OFF if buffers in alter segment */ dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl i fixed bin (35); dcl one_ptr (1) ptr based; /* overlay to use get_temp_segments_ */ dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl save_ptr ptr; dcl table_ptr ptr; dcl string char (f.max_seg_size) based; dcl three_ptr (3) ptr based; /* overlay to use get_temp_segments_ */ dcl temp char (f.max_seg_size) based (temp_ptr); dcl temp_length fixed bin (21); dcl (cur_index, alt_index) fixed bin (21); dcl 1 pointers aligned, /* A structure is used for get_temp_segments_ convience */ 2 temp_ptr ptr, 2 alt_table_ptr ptr, 2 cur_table_ptr ptr; %include dfast_error_codes; /* based */ dcl 1 c aligned based (cur_table_ptr) like dfast_line_table; dcl 1 a aligned based (alt_table_ptr) like dfast_line_table; dcl (addr, divide, null, ptr, substr) builtin; dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info; %include dfast_edit_info; %include dfast_line_table; /* */ edit_info_ptr = arg_edit_info_ptr; temp_ptr, alt_table_ptr, cur_table_ptr = null; free_table_buffers = "0"b; on clean_up call free_buffers; /* If the alter and current segments are small, the tables are put at the end of the alter segment. */ if f.current_length + f.alter_length < divide (f.max_seg_size, 4, 35) then do; i = divide (f.alter_length + 3, 4, 35, 0) +1; alt_table_ptr = ptr (f.alter_ptr, i); call dfast_get_table_ ("1"b, f.alter_ptr, f.alter_length, alt_table_ptr, 0); i = i + a.table_length *3 +2; cur_table_ptr = ptr (f.alter_ptr, i); call get_temp_segments_ ("fast", addr (temp_ptr) -> one_ptr, code); end; else do; call get_temp_segments_ ("fast", addr (temp_ptr) -> three_ptr, code); if code = 0 then free_table_buffers = "1"b; end; if code = 0 then do; call dfast_get_table_ (force_sort, f.current_ptr, f.current_length, cur_table_ptr, code); if code = 0 then do; cur_index = 1; alt_index = 1; temp_length = 0; do while (cur_index <= c.table_length & alt_index <= a.table_length & code = 0); if c.line (cur_index).number < a.line (alt_index).number then do; call move (f.current_ptr, c.line (cur_index).start, c.line (cur_index).num_chars, code); cur_index = cur_index + 1; end; else do; call move (f.alter_ptr, a.line (alt_index).start, a.line (alt_index).num_chars, code); if c.line (cur_index).number = a.line (alt_index).number then cur_index = cur_index + 1; alt_index = alt_index + 1; end; end; do while (alt_index <= a.table_length & code = 0); call move (f.alter_ptr, a.line (alt_index).start, a.line (alt_index).num_chars, code); alt_index = alt_index + 1; end; do while (cur_index <= c.table_length & code = 0); call move (f.current_ptr, c.line (cur_index).start, c.line (cur_index).num_chars, code); cur_index = cur_index + 1; end; if code = 0 then do; f.current_length = temp_length; f.alter_length = 0; f.edit_done = "1"b; save_ptr = f.current_ptr; revert clean_up; f.current_ptr = temp_ptr; temp_ptr = save_ptr; end; end; end; if temp_ptr ^= null then call free_buffers; return; /* */ move: proc (seg_ptr, start, num_chars, code); dcl seg_ptr ptr; /* ptr to segment to move from */ dcl start fixed bin (21); /* first character in segment to be moved */ dcl num_chars fixed bin (21); /* number of characters to move */ dcl code fixed bin (35); if temp_length + num_chars > f.max_seg_size then code = error_max_size; else do; substr (temp, temp_length + 1, num_chars) = substr (seg_ptr -> string, start, num_chars); temp_length = temp_length + num_chars; end; return; end move; free_buffers: proc; dcl code fixed bin (35); if free_table_buffers then call release_temp_segments_ ("fast", addr (temp_ptr) -> three_ptr, code); else if temp_ptr ^= null then call release_temp_segments_ ("fast", addr (temp_ptr) -> one_ptr, code); return; end free_buffers; end dfast_merge_;  dfast_process_overseer_.pl1 07/13/88 1248.5r w 07/13/88 0935.7 33885 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Pedigree unknown. */ /* Modified 1984-08-24 BIM for pit instead of pitmsg. */ dfast_process_overseer_: proc; /* automatic */ dcl bit_count fixed bin (24); /* bit count of message of the day */ dcl code fixed bin (35); dcl home_dir_string char (168); /* home directory for dfast_ */ dcl i fixed bin; dcl junk fixed bin (6); /* unlooked at info for iox_$control */ dcl logout_arg char (5); /* -hold or "" output from dfast_ */ dcl mothd_ptr ptr; /* ptr to message of the day */ dcl person_id_string char (28); /* person_id for dfast_ */ dcl pp ptr; /* pointer to pit */ dcl project_id_string char (28); /* project_id for dfast_ */ dcl 1 search_rules aligned, 2 number fixed bin init (4), 2 names (4) char (168) aligned init ("initiated_segments", ">unb", ">sss", ">sl1"); dcl tty_string char (6); /* ttynnn for dfast_ */ dcl (length, verify, reverse, null, index, substr) builtin; /* external */ dcl condition_ entry (char (*) aligned, entry); dcl com_err_ entry options (variable); dcl dfast_ entry (char (*), char (*), char (*), char (*), char (*)); dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$initiate_search_rules entry (ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl iox_$attach_iocb entry (ptr, char (*), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$user_io ptr ext; dcl iox_$user_output ptr ext; dcl logout entry options (variable); dcl standard_default_handler_ entry (); dcl terminate_process_ ext entry (char (*), ptr); /* */ %include user_attributes; %include pit; /* */ /* set arguments for dfast_ */ call hcs_$make_seg ("", "pit", "", 01000b, pp, code); tty_string = pp -> pit.tty; i = length (pp -> pit.homedir) + 1 - verify (reverse (pp -> pit.homedir), " "); home_dir_string = pp -> pit.homedir; person_id_string = pp -> pit.login_name; project_id_string = pp -> pit.project; /* print message of the day, if the user didn't login with -brief option */ if ^pp -> pit.at.brief then do; call hcs_$initiate_count (">system_control_1", "message_of_the_day", "", bit_count, 1, mothd_ptr, code); if mothd_ptr ^= null then do; call iox_$put_chars (iox_$user_output, mothd_ptr, divide (bit_count, 9, 21, 0), code); call hcs_$terminate_noname (mothd_ptr, code); end; end; call condition_ ("any_other", standard_default_handler_); call hcs_$terminate_noname (pp, code); call hcs_$initiate_search_rules (addr(search_rules), code); if code ^= 0 then call com_err_ (code, "fast", "Can't set search rules"); call iox_$control (iox_$user_io, "quit_enable", addr(junk), code); call dfast_ (person_id_string, substr (home_dir_string, 1, i), project_id_string, tty_string, logout_arg); if logout_arg = "-hold" then call logout (logout_arg); else call logout; return; end dfast_process_overseer_;  dfast_run_.pl1 11/05/82 1316.6rew 11/04/82 1552.6 20520 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_run_: proc (edit_info_ptr, code); /* * This procedure execute the run command. The alter and current segments are merged before the run unit manager * is called. */ /* parameters */ dcl edit_info_ptr ptr; dcl code fixed bin (35); /* automatic */ dcl directory_name char (168); dcl directory_name_length fixed bin; /* number non-blank characters in directory name */ dcl entry_name char (32); dcl compiler_name char (8) aligned; /* "basic" or "fortran" */ dcl substr builtin; /* constant */ /* based */ dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info; /* external */ dcl basic_$precision_length ext fixed bin; dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl dfast_run_unit_manager_ entry (char (8) aligned, ptr, fixed bin (24), char (168) aligned, bit (1) aligned, fixed bin (35)); /* */ %include dfast_edit_info; %include dfast_error_codes; /* */ if f.source_segment then if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code); if code = 0 then do; if f.basic_system then do; if f.dbasic then do; compiler_name = "dbasic"; basic_$precision_length = 2; end; else do; compiler_name = "basic"; basic_$precision_length = 1; end; end; else compiler_name = "fortran"; if f.current_length ^= 0 then do; call hcs_$fs_get_path_name (f.current_ptr, directory_name, directory_name_length, entry_name, code); if code = 0 then do; call dfast_run_unit_manager_ (compiler_name, f.current_ptr, f.current_length * 9, substr (directory_name, 1, directory_name_length) || entry_name, "0"b, code); end; end; else code = error_cur_empty; end; if code ^= 0 then call dfast_error_ (code, "run", (f.current_name)); return; end dfast_run_;  dfast_run_unit_manager_.pl1 08/06/87 1149.6r w 08/06/87 1047.1 341694 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dfast_run_unit_manager_: proc (a_system, a_program_ptr, a_program_lng, a_main_name, a_debug_sw, a_code); /* coded by M. Weaver 12/75 */ /* modified 12/76 by M. Weaver to use version 2 compiler_source_info structure */ /* Modified 28 Feb 1980 by C R Davis for new fort_options include file. */ /* This program implements the DTSS-compatible FAST susbsystem. It finds all libraries, compiles all source, sets up a name table, does the linking, executes the program and terminates all segments used just by the run unit. */ /* arguments */ dcl a_system char (8) aligned; /* system name */ dcl a_program_ptr ptr; /* ptr to main program for run unit */ dcl a_program_lng fixed bin (24); /* bit count of input segment */ dcl a_main_name char (168) aligned; /* pathname of main program (used as library name) */ dcl a_debug_sw bit (1) aligned; /* "1"b->in debug mode (i.e. generate symbol table) */ dcl a_code fixed bin (35); /* returned status code */ /* pointers */ dcl arg_ptr ptr; /* ptr to arglist */ dcl mainp ptr; /* ptr to main entry point */ dcl ftn_io_p ptr; /* points to fortran io_vector */ dcl cur_lib_node_p ptr; /* points to library node currently being examined */ dcl last_lib_node_p ptr; /* points to most recent lib node entry */ dcl scratch_ptr ptr; /* points to beginning of scratch seg */ dcl cur_free_p ptr; /* points to first free word in scratch segment */ dcl blank_common_ptr ptr; /* points to blank common (in scratch seg) */ dcl object_ptr ptr; /* ptr to object segment compiled by run unit */ dcl cp ptr; /* used when looping through lib list */ dcl segptr ptr; dcl rnt_p ptr static; /* ptr to beginning of run unit's rnt */ dcl rp ptr; /* ptr to currently examined rnt node */ dcl program_ptr ptr; /* ptr to current file */ dcl array_p ptr; /* ptr to based_array used by temp seg manager */ dcl source_info_pt ptr; /* ptr to source info structure used by compilers */ dcl new_obj_symbol_p ptr; /* for snapping ftn *symbol links */ dcl ep ptr; dcl based_ptr ptr based; /* for copying pointers */ /* fixed bin */ dcl max_severity fixed bin; /* max severity of errors encountered */ dcl nfiles fixed bin; /* number of files being chained */ dcl scratch_lng fixed bin (19); /* max length of scratch seg */ dcl ru_area_size fixed bin (18); /* max length of space used by rum itself */ dcl code fixed bin (35); dcl nleft fixed bin (26); dcl (i, j) fixed bin; dcl k fixed bin (18); dcl based_fixed fixed bin (35) based; dcl program_lng fixed bin (24); /* bit count of input seg */ /* bit strings */ dcl debug_sw bit (1) aligned; /* "1"b->in debug mode */ dcl terminating bit (1) aligned; /* "1"b->in process of terminating run unit */ dcl compiler_invoked bit (1) aligned; /* "1"b->run unit has invoked compiler */ dcl have_chained bit (1) aligned; /* "1"b->main program was chained to */ dcl is_main bit (1) aligned; /* "1"b->are processing the main program */ dcl save_main bit (1) aligned; /* "1"b->are compiling main program */ dcl (mask, oldmask) bit (36) aligned; /* ips masks */ /* character strings */ dcl temp_dir char (168); /* used by expand_pathname_ */ dcl main_name char (168) aligned; /* "library" name of main program */ dcl temp_ent char (32); /* used by expand_pathname_ */ dcl system char (8) aligned; /* name of current system */ dcl interrupt_names char (32) aligned; /* for create_ips_mask_ */ /* external variables */ dcl (error_table_$not_done, error_table_$name_not_found) ext fixed bin (35); dcl fast_related_data_$fortran_io_initiated bit (1) aligned ext; dcl fast_related_data_$chaining bit (1) aligned ext; dcl fast_related_data_$fortran_buffer_p ptr ext; dcl fast_related_data_$basic_area_p ptr ext; dcl fast_related_data_$terminate_run entry ext variable; /* external entries */ dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl cu_$gen_call entry (ptr, ptr); dcl fortran_io_$close_file entry (fixed bin, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl area_ entry (fixed bin (26), ptr); dcl decode_definition_$full entry (ptr, ptr, ptr) returns (bit (1) aligned); dcl basic_$run_unit_compiler entry (ptr, ptr, fixed bin, bit (1) aligned, entry, entry, fixed bin (35)); dcl fort_$compile_run entry (ptr, ptr, fixed bin, ptr, entry, entry, fixed bin (35)); dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned); dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); /* builtins */ dcl (addr, addrel, baseno, baseptr, bit, bin, fixed, divide) builtin; dcl (max, mod, null, ptr, rel, reverse, size, substr, unspec, verify) builtin; dcl cleanup condition; dcl fault_tag_3 condition; /* arrays */ dcl based_array (1) ptr based (array_p); /* alias for use by get/release temp segs */ /* structures */ dcl 1 ext_template aligned based, /* holds link info */ 2 type fixed bin, /* link type */ 2 section char (8) aligned, 2 ename char (32) varying, /* entry name of link target */ 2 init_info_p ptr; /* ptr to init info for common */ dcl 1 arglist aligned, /* for passing file ptrs to basic */ 2 argcnt fixed bin (17) unaligned, /* 2 * number of args */ 2 alcode fixed bin (17) unaligned init (4), /* no display ptr */ 2 descnt fixed bin (17) unaligned, /* 2 * number of descriptors */ 2 mbz fixed bin (17) unaligned init (0), 2 argpts (16) ptr, 2 argdescs (16) ptr; dcl 1 dd aligned, /* structure filled in by full entry */ 2 next_def ptr, /* ptr to next definition in list */ 2 last_def ptr, /* ptr to previous definition in list */ 2 block_ptr ptr, /* ptr to either defblock or segname block */ 2 section char (4) aligned, /* "text", "link", "symb" or "segn" */ 2 offset fixed bin, /* offset within class (if ^= "segn") */ 2 entrypoint fixed bin, /* value of entrypoint in text if ^= 0 */ 2 symbol char (256) aligned, /* the symbolic name of the definition */ 2 symbol_lng fixed bin, /* the actual length of symbol */ 2 flags, /* same flags as in std def */ 3 a_new_format bit (1) unaligned, /* def is in new format */ 3 a_ignore bit (1) unaligned, /* linker should ignore this def */ 3 a_entrypoint bit (1) unaligned, /* def is for entrypoint */ 3 a_retain bit (1) unaligned, 3 a_arg_count bit (1) unaligned, /* there is an arg count for entry */ 3 a_descr_sw bit (1) unaligned, /* there are valid descriptors for entry */ 3 a_main bit (1) unaligned, /* this is a main entry point */ 3 unused bit (11) unaligned, 2 n_args fixed bin, /* # of args entry expects */ 2 descr_ptr ptr; /* ptr to array of rel ptrs to descriptors for entry */ dcl 1 io_vector (99) aligned based (ftn_io_p), 2 ip ptr unaligned, /* points to file's iocb */ 2 modes bit (36) aligned; dcl 1 lib_list_node aligned based (cur_lib_node_p), 2 forward_thread bit (18) unaligned, /* offset of next node */ 2 backward_thread bit (18) unaligned, /* offset of last node */ 2 info aligned, /* info to determine how to terminate */ 3 source bit (1) unal, /* "1"b->source segment */ 3 has_lote bit (1) unal, /* "1"b->linkage section allocated before run unit entered */ 3 already_known bit (1) unal, /* "1"b->segment was initiated before run unit */ 3 terminate bit (1) unal, /* "1"b->terminate before leaving run unit */ 3 pad bit (32) unal, 2 segname char (168) aligned, /* pathname of library */ 2 segp ptr, /* points to library */ 2 ftn_ls_p ptr, /* ^null->points to fortran seg linkage section */ 2 ftn_symbol_p ptr, /* ^null->points to fortran seg symbol section */ 2 segbc fixed bin (24); /* bit count of library */ dcl 1 rnt_node aligned based (rp), /* node in reference name table */ 2 entryp ptr, /* ptr to entry in program */ 2 threads aligned, 3 next_node bit (18) unaligned, /* offset of next node */ 3 pad bit (18) unaligned, 2 nchars fixed bin, /* number of characters in name */ 2 name char (32) aligned; /* entrypoint name */ dcl 1 oi aligned like object_info; %include object_info; %include branch_status; dcl 1 source_info aligned based (source_info_pt) like compiler_source_info; %include compiler_source_info; %include linkdcl; %include lot; %include stack_header; /* copy arguments */ system = a_system; program_ptr = a_program_ptr; program_lng = a_program_lng; main_name = a_main_name; debug_sw = a_debug_sw; a_code = 0; /* initialize automatic variables */ arg_ptr = null; ftn_io_p = null; cur_lib_node_p = null; last_lib_node_p = null; scratch_ptr = null; blank_common_ptr = null; object_ptr = null; rnt_p = null; max_severity = 0; nfiles = 0; terminating = "0"b; compiler_invoked = "0"b; have_chained = "0"b; fast_related_data_$terminate_run = terminate_run_entry; fast_related_data_$fortran_io_initiated = "0"b; /* runtime must reinitialize io buffer area */ array_p = addr (scratch_ptr); call get_temp_segments_ ("dfast_run_unit_manager_", based_array, code); call hcs_$get_max_length_seg (scratch_ptr, scratch_lng, code); ru_area_size = scratch_lng - 300; /* save some room for lang area */ cur_free_p = scratch_ptr; have_chained = "0"b; sb = ptr (addr (lotp), 0); /* get ptr to stack header */ lotp = sb -> stack_header.lot_ptr; isotp = sb -> stack_header.isot_ptr; on cleanup begin; /* get ips mask now for later use */ interrupt_names = "-all"; call create_ips_mask_ (addr (interrupt_names), 1, mask); fast_related_data_$chaining = "0"b; call terminate_run_unit_; array_p = addr (scratch_ptr); call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code); end; call set_up_run_unit_; /* . if a_file_info_p ^= null then call set_up_files_; /* called for execute command */ join: if max_severity > 2 then do; a_code = error_table_$not_done; go to terminate; end; call find_entry_ ("main_", mainp, code); /* if main_ename is ever given, check for it only in main program */ if code ^= 0 then do; /* abort run unit */ call ioa_ ("Main entry point not found."); go to terminate; end; on fault_tag_3 call fault_tag_3_handler; /* if debug_sw then call probe$init_run (mainp); */ /* set bit count so can obtain statement map if error; need only for object but doesn't hurt source */ call hcs_$set_bc_seg (program_ptr, program_lng, code); call cu_$gen_call (mainp, arg_ptr); terminate: fast_related_data_$chaining = "0"b; /* be sur all files are closed */ call terminate_run_unit_; array_p = addr (scratch_ptr); call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code); main_return: return; perform_chain: call chain_; /* terminate old and set up neew run unit */ go to join; /* now treat like ordinary run unit */ /* end of main program */ terminate_run_unit_: proc; if terminating then return; /* don't risk loop */ terminating = "1"b; call hcs_$set_bc_seg (program_ptr, 0, code); /* terminate all segs and clean up LOT */ cp = last_lib_node_p; /* lib list is also master list */ if cp ^= null then do; do while (rel (cp)); segptr = cp -> lib_list_node.segp; if ^(cp -> lib_list_node.info.has_lote | cp -> lib_list_node.info.source) & (segptr ^= null) then do; k = fixed (baseno (segptr), 18); lotp -> lot.lp (k), isotp -> isot.isp (k) = baseptr (0); end; if cp -> lib_list_node.info.terminate /* don't terminate first main seg */ then call hcs_$terminate_noname (segptr, code); cp = ptr (cp, cp -> lib_list_node.backward_thread); end; end; /* terminate object segment */ if object_ptr ^= null then do; k = fixed (baseno (object_ptr), 18); lotp -> lot.lp (k), isotp -> isot.isp (k) = baseptr (0); call hcs_$set_bc_seg (object_ptr, 0, code); array_p = addr (object_ptr); call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code); end; /* close all fortran files */ if system = "fortran" then if ftn_io_p ^= null then call fortran_io_$close_file (-1, code); /* if necessary, close files not found during normal termination mechanisms */ /* if ^fast_related_data_$chaining /* either in cleanup handler or at end */ /* then call clean_up_files; */ terminating = "0"b; return; end; /* terminate_run_unit_ */ dfast_add_to_lib_list_: proc (a_pname, al_code); dcl a_pname char (*); dcl pname char (168); dcl libp ptr; dcl libbc fixed bin (24); dcl al_code fixed bin (35); pname = a_pname; /* see if this name is already on the list; this may save an initiate call */ cp = last_lib_node_p; do while (rel (cp)); if cp -> lib_list_node.segname = pname then go to already_on; cp = ptr (cp, cp -> lib_list_node.backward_thread); end; /* get pointer to segment */ call expand_pathname_ (pname, temp_dir, temp_ent, al_code); if al_code ^= 0 then return; on cleanup begin; /* be sure ips mask gets reset */ if substr (oldmask, 36, 1) then do; /* between calls to set and reset ips mask */ mask = oldmask; call hcs_$reset_ips_mask (mask, oldmask); end; end; interrupt_names = "-all"; call create_ips_mask_ (addr (interrupt_names), 1, mask); call hcs_$set_ips_mask (mask, oldmask); /* bit 36 of oldmask will be "1"b */ call hcs_$initiate_count (temp_dir, temp_ent, "", libbc, 0, libp, al_code); if libp = null then goto unmask; /* see if this segment is already on the list */ cp = last_lib_node_p; do while (rel (cp)); if cp -> lib_list_node.segp = libp then do; call hcs_$terminate_noname (libp, code); go to already_on; end; cp = ptr (cp, cp -> lib_list_node.backward_thread); end; /* allocate new node and fill in */ call allocate_ (size (lib_list_node), cp); last_lib_node_p -> lib_list_node.forward_thread = rel (cp); cp -> lib_list_node.backward_thread = rel (last_lib_node_p); cp -> lib_list_node.forward_thread = "0"b; addr (cp -> lib_list_node.info) -> based_fixed = 0; if code ^= 0 then cp -> lib_list_node.info.already_known = "1"b; /* initiated before; may have valid lot entry */ cp -> lib_list_node.info.terminate = "1"b; /* we initiated; we must terminate */ cp -> lib_list_node.segname = pname; cp -> lib_list_node.segp = libp; cp -> lib_list_node.ftn_ls_p = null; cp -> lib_list_node.ftn_symbol_p = null; cp -> lib_list_node.segbc = libbc; last_lib_node_p = cp; already_on: al_code = 0; unmask: mask = oldmask; /* use oldmask to bracket ips calls */ call hcs_$reset_ips_mask (mask, oldmask); return; end; /* dfast_add_to_lib_list_ */ init_lib_list_: proc; /* allocate dummy node to make process_lib_list_ cleaner */ call allocate_ (size (lib_list_node), cur_lib_node_p); cur_lib_node_p -> lib_list_node.backward_thread = "0"b; cur_lib_node_p -> lib_list_node.segp = null; cur_lib_node_p -> lib_list_node.segname = ""; cur_lib_node_p -> lib_list_node.ftn_ls_p = null; cur_lib_node_p -> lib_list_node.ftn_symbol_p = null; addr (cur_lib_node_p -> lib_list_node.info) -> based_fixed = 0; /* allocate and initialize real first node */ call allocate_ (size (lib_list_node), cp); cp -> lib_list_node.backward_thread = rel (cur_lib_node_p); cp -> lib_list_node.forward_thread = "0"b; addr (cp -> lib_list_node.info) -> based_fixed = 0; if have_chained then cp -> lib_list_node.info.terminate = "1"b; cp -> lib_list_node.segname = main_name; cp -> lib_list_node.segp = program_ptr; cp -> lib_list_node.ftn_ls_p = null; cp -> lib_list_node.ftn_symbol_p = null; cp -> lib_list_node.segbc = program_lng; last_lib_node_p = cp; cur_lib_node_p -> lib_list_node.forward_thread = rel (cp); is_main = "1"b; /* start out processing main program */ return; end; chain_: proc; /* this is just a place holder */ return; end; set_up_run_unit_: proc; dcl (blank_length, nblocks) fixed bin; dcl (lsp, common_p) ptr; dcl link_list (200) ptr aligned based; dcl 1 common_list (100) aligned, 2 name char (32) aligned, /* name of labelled common block */ 2 block_p ptr, 2 block_len fixed bin; dcl 1 ignore_source_info aligned like compiler_source_info; dcl 1 ext aligned like ext_template; /* holds link info */ dcl 1 init_info aligned based, 2 length fixed bin, 2 icode fixed bin, 2 template (0 refer (init_info.length)) bit (36) aligned; dcl init_template (j) bit (36) aligned based; call init_lib_list_; compiler_invoked = "0"b; /* compile all source and build table of object entries */ call process_lib_list_ (addr (ignore_source_info)); if max_severity > 2 then return; /* first release treats namedups as error */ /* process links */ if system = "fortran" then do; blank_length = 0; nblocks = 0; cp = last_lib_node_p; if cp ^= null then do while (rel (cp)); call snap_ftn_links (cp -> lib_list_node.ftn_ls_p, "1"b); cp = ptr (cp, cp -> lib_list_node.backward_thread); end; if object_ptr ^= null then do; /* snap links in object just compiled */ lsp = lot.lp (fixed (baseno (object_ptr), 18)); /* get ptr to object's ls */ call snap_ftn_links (lsp, "0"b); end; if max_severity > 2 then return; call allocate_ (blank_length, blank_common_ptr); /* allocate blank common in scratch seg */ call allocate_ (size (io_vector), ftn_io_p); fast_related_data_$fortran_buffer_p = ftn_io_p; end; else do; /* basic */ /* be sure area begins on even word boundary */ if mod (fixed (rel (cur_free_p), 18), 2) = 1 then cur_free_p = addrel (cur_free_p, 1); nleft = scratch_lng - fixed (rel (cur_free_p), 18); /* find # of words left in scratch seg */ call area_ (nleft, cur_free_p); fast_related_data_$basic_area_p = cur_free_p; end; return; snap_ftn_links: proc (lp, old_object); dcl nlinks fixed bin; /* number of links in linkage section */ dcl first_link_offset fixed bin (18); dcl dl_code fixed bin (35); dcl (lp, link_ptr, link_list_ptr) ptr; dcl old_object bit (1) aligned; dcl length builtin; if lp = null then return; first_link_offset = fixed (lp -> header.stats.begin_links, 18); link_list_ptr = addrel (lp, first_link_offset); nlinks = divide (fixed (lp -> header.stats.block_length, 18) - first_link_offset + 1, 2, 17, 0); do i = 1 to nlinks; link_ptr = addr (link_list_ptr -> link_list (i)); call decode_ftn_link_ (link_ptr, addr (ext), "1"b, dl_code); if dl_code ^= 0 then do; /* illegal link */ if dl_code = 1 then ; /* not a ft2 link */ else link_ptr -> link.ft2 = "100111"b; /* get ft3 if reference */ end; else if ext.type = 5 & ext.section = "*system" then do; /* common */ if ext.ename = "blnk*com" then do; blank_length = max (blank_length, ext.init_info_p -> init_info.length); /* keep track of max blank common length */ link_ptr -> based_ptr = addr (blank_common_ptr); /* snap link indirect thru blank_common_ptr */ link_ptr -> link.modifier = "010000"b; /* make pointer indirect */ end; else do; /* labelled common */ call find_common_block_; if code = 0 then link_ptr -> based_ptr = common_p; /* snap link */ end; end; else if (ext.type = 1) & (ext.section = "*symbol") then do; if old_object then link_ptr -> based_ptr = cp -> lib_list_node.ftn_symbol_p; else link_ptr -> based_ptr = new_obj_symbol_p; end; else do; /* ordinary link */ call find_entry_ ((ext.ename), ep, code); if code ^= 0 then do; call error (2, "Unable to satisfy reference to ^a because it is not in a library.", substr (ext.ename, 1, length (ename))); link_ptr -> link.ft2 = "100111"b; /* make fault tag 3 and continue */ end; else link_ptr -> based_ptr = ep; /* snap link */ end; end; return; find_common_block_: proc; /* this procedure finds or allocates common blocks */ /* global varaibles: init_info_p, . ename, . common_p, . code, . common_list. */ dcl i fixed bin; code = 0; do i = 1 to nblocks; /* see if block is already allocated */ if ext.ename = common_list (i).name then do; /* found match */ if common_list (i).block_len = ext.init_info_p -> init_info.length then do; common_p = common_list (i).block_p; /* use allocated block */ if ext.init_info_p -> init_info.icode = 3 then do; /* but initialize now */ j = ext.init_info_p -> init_info.length; common_p -> init_template = ext.init_info_p -> init_info.template; end; end; else do; call error (3, "Different lengths specified for common block ^a", substr (ext.ename, 1, length (ext.ename))); code = 1; end; return; end; end; /* no match; allocate new block in scratch seg */ nblocks = nblocks + 1; common_list (i).name = ext.ename; j, common_list (i).block_len = init_info_p -> init_info.length; call allocate_ (j, common_p); common_list (i).block_p = common_p; if ext.init_info_p -> init_info.icode = 3 then common_p -> init_template = ext.init_info_p -> init_info.template; return; end; /* find_common_blocks_ */ end; /* snap_ftn_links */ end; /* set_up_run_unit_ */ decode_ftn_link_: proc (linkp, extp, linking, dcode); /* This procedure returns information about legal fortran links only. Do not distinguish types of errors except for missing fault tag 2. */ /* This is outside set_up_run_unit_ so fault tag 3 handler can call it */ dcl (linkp, extp) ptr; dcl linking bit (1) aligned; dcl dcode fixed bin (35); dcl (head_pointer, def_pointer, exp_pointer, type_pointer, ext_pointer) ptr; dcl (ntype, section_id) fixed bin (18); dcl name_length fixed bin; dcl 1 ext aligned based, /* holds link info */ 2 type fixed bin, /* link type */ 2 section char (8) aligned, 2 ename, 3 nchars fixed bin, 3 string char (32), 2 init_info_p ptr; /* ptr to init info for common */ dcode = 1; if linking then if linkp -> link.ft2 ^= "100110"b then return; /* must have fault tag 2 */ dcode = 2; head_pointer = addrel (linkp, linkp -> link.head_ptr); def_pointer = head_pointer -> header.def_ptr; exp_pointer = addrel (def_pointer, linkp -> link.exp_ptr); if exp_pointer -> exp_word.exp then return; /* must have 0 expression */ type_pointer = addrel (def_pointer, exp_pointer -> exp_word.type_ptr); ext_pointer = addrel (def_pointer, type_pointer -> type_pair.ext_ptr); section_id = bin (type_pointer -> type_pair.seg_ptr, 18); extp -> ext.type, ntype = bin (type_pointer -> type_pair.type, 18); if (ntype = 4) | (ntype = 5) then do; name_length = bin (ext_pointer -> name.nchars, 9); if name_length > 32 then return; /* name too long */ extp -> ext.ename.nchars = name_length; substr (extp -> ext.ename.string, 1, name_length) = substr (ext_pointer -> name.char_string, 1, name_length); if ntype = 4 then do; if type_pointer -> type_pair.seg_ptr ^= type_pointer -> type_pair.ext_ptr then return; /* don't allow $ names in DFAST */ extp -> ext.section = " "; extp -> ext.init_info_p = null; end; else do; /* ntype = 5 */ if section_id ^= 5 /* *system */ then return; extp -> ext.section = "*system"; if type_pointer -> type_pair.trap_ptr = "0"b then return; /* must have init info */ extp -> ext.init_info_p = addrel (def_pointer, type_pointer -> type_pair.trap_ptr); end; end; else if ntype = 1 then do; if section_id ^= 2 then return; /* must be *symbol|0 */ extp -> ext.section = "*symbol"; extp -> ext.ename.nchars = 0; extp -> ext.init_info_p = null; end; else return; /* not a legal fortran type */ dcode = 0; return; end; /* decode_ftn_link_ */ find_entry_: proc (entname, entp, ecode); /* this procedure returns a ptr to the entrypoint corresponding to a given name */ dcl entname char (32); dcl entp ptr; dcl ename_length fixed bin; dcl ecode fixed bin (35); ename_length = 33 - verify (reverse (entname), " "); rp = rnt_p; do while (rel (rp)); if ename_length = rnt_node.nchars then if entname = rnt_node.name then do; /* found match */ entp = rnt_node.entryp; ecode = 0; return; end; rp = ptr (rp, rnt_node.next_node); end; ecode = error_table_$name_not_found; return; end; /* find_entry_ */ find_entry_value: entry (a_entname, a_entp, a_ecode); /* This entry is called by basic_find_proc_ */ dcl a_entname char (32); dcl a_entp ptr; dcl a_ecode fixed bin (35); call find_entry_ (a_entname, a_entp, a_ecode); return; process_object_: proc (old_object, has_lot_entry); dcl (listptr, namep, linkage_section_p, program_header_pt) ptr; dcl (namel, link_lng) fixed bin; dcl old_object bit (1) aligned; /* "1"b->object segment is in hierarchy */ dcl has_lot_entry bit (1) unal; dcl based_name char (namel) based (namep); dcl based_name_aligned char (namel) based (namep) aligned; dcl 1 saved_lib_list aligned based, /* list found in object's text */ 2 nlibs fixed bin, 2 names (0 refer (nlibs)) aligned, 3 offset bit (18) unaligned, 3 length fixed bin (17) unaligned; dcl ls (link_lng) fixed bin (35) based; dcl al_code fixed bin (35); %include basic_program_header; /* don't mix basic and fortran programs */ if oi.compiler = "fortran2" then if system ^= "fortran" then go to wrong_sys; if oi.compiler = "basic" then do; /* be sure precision matches */ if system = "fortran" then go to wrong_sys; if oi.textp -> basic_program_header.version_number = -1 then do; /* double precision program */ if system ^= "dbasic" then go to wrong_sys; end; else if system = "dbasic" then do; /* single precision program */ wrong_sys: call error (3, "Program ^a belongs to another system.", cur_lib_node_p -> lib_list_node.segname); return; end; end; dd.next_def = oi.defp; /* initialize for loop */ do while (^(decode_definition_$full (dd.next_def, addr (dd), addr (oi)))); if dd.symbol = "library_list_" then do; listptr = addrel (oi.textp, dd.offset); do i = 1 to listptr -> saved_lib_list.nlibs; namep = addrel (oi.textp, listptr -> saved_lib_list.names (i).offset); namel = listptr -> saved_lib_list.names (i).length; call dfast_add_to_lib_list_ (based_name, al_code); if code ^= 0 then call error (3, "Library ^a could not be processed.", based_name_aligned); end; end; else if dd.section = "text" then call add_to_known_names; end; /* allocate linkage */ if has_lot_entry then return; if old_object then do; /* must copy linkage section */ link_lng = oi.llng; call allocate_ (link_lng, linkage_section_p); linkage_section_p -> ls = oi.linkp -> ls; if system = "fortran" then do; /* need to keep pointers for snapping links */ cur_lib_node_p -> lib_list_node.ftn_ls_p = linkage_section_p; /* set ptrs to linkage sections to be prelinked */ cur_lib_node_p -> lib_list_node.ftn_symbol_p = oi.symbp; end; else cur_lib_node_p -> lib_list_node.ftn_ls_p, cur_lib_node_p -> lib_list_node.ftn_symbol_p = null; end; else do; /* there's no lib_list_node for new object */ linkage_section_p = oi.linkp; /* don't copy temp linkage section */ new_obj_symbol_p = oi.symbp; end; /* update LOT, ISOT */ k = fixed (baseno (oi.textp), 18); lotp -> lot.lp (k) = linkage_section_p; /* /*isotp->isot.isp(k)=linkage_section_p; */ /* fill in linkage section header */ linkage_section_p -> header.def_ptr = oi.defp; linkage_section_p -> header.symbol_ptr = oi.symbp; linkage_section_p -> header.original_linkage_ptr = oi.linkp; linkage_section_p -> header.stats.segment_number = bit (k, 18); linkage_section_p -> header.stats.static_length = bit (bin (oi.ilng, 18), 18); return; add_to_known_names: proc; /* this procedure fills in the rnt */ /* global variables: rnt_p, ename, def_ptr, have_main; */ dcl ename_used char (32) var; dcl ename_length fixed bin; dcl saved_rp ptr; /* copy name to be added */ /* if it's the main entry point, use main__ so we can find it easily later */ /* . if dd.flags.a_main then do; . if have_main then do; /* don't allow 2 main entry points ! . call error (3, "Library ^a has a main entry point.", cur_lib_node_p -> lib_list_node.segname); . return; . end; . ename_used = "main__"; . ename_length = length (ename_used); . have_main = "1"b; . end; */ ename_length = dd.symbol_lng; ename_used = substr (dd.symbol, 1, dd.symbol_lng); if ename_used = "main_" then do; if ^is_main then do; call error (3, "Library ^a has a main entry point.", cur_lib_node_p -> lib_list_node.segname); return; end; end; if rnt_p = null then do; /* rnt does not exist yet */ call fill_in_rnt_node; rnt_node.next_node = "0"b; rnt_p = rp; return; end; rp = rnt_p; do while (rel (rp)); if ename_length = rnt_node.nchars then if ename_used = rnt_node.name then do; call error (2, "Duplicate subroutine name ^a.", rnt_node.name); return; end; saved_rp = rp; /* save for filling in thread */ rp = ptr (rp, rnt_node.next_node); end; /* add name to rnt */ call fill_in_rnt_node; saved_rp -> rnt_node.next_node = rel (rp); /* thread new node to rest of list */ return; fill_in_rnt_node: proc; call allocate_ (size (rnt_node), rp); rnt_node.entryp = addrel (oi.textp, dd.offset); rnt_node.pad = "0"b; rnt_node.nchars = ename_length; rnt_node.name = ename_used; return; end; /* fill_in_rnt_node */ end; /* add_to_known_names_ */ end; /* process_object_ */ process_lib_list_: proc (source_info_pointer); dcl source_info_pointer ptr; dcl fixed_lote fixed bin (35); dcl object_len fixed bin (24); dcl object_length fixed bin; dcl 1 fort_options aligned like fortran_options; %include fort_options; source_info_pt = source_info_pointer; /* find all library segments */ do while (cur_lib_node_p -> lib_list_node.forward_thread); cur_lib_node_p = ptr (cur_lib_node_p, lib_list_node.forward_thread); oi.version_number = object_info_version_2; call object_info_$display (lib_list_node.segp, lib_list_node.segbc, addr (oi), code); if code = 0 then do; /* object */ fixed_lote = addr (lotp -> lot.lp (fixed (baseno (oi.textp), 18))) -> based_fixed; if (fixed_lote > 0) & (lib_list_node.info.already_known) then cur_lib_node_p -> lib_list_node.info.has_lote = "1"b; call process_object_ ("1"b, cur_lib_node_p -> lib_list_node.info.has_lote); /* find defs, copy linkage */ is_main = "0"b; end; else do; /* source; must compile */ /* set up source info */ source_info.version = compiler_source_info_version_2; source_info.input_pointer = cur_lib_node_p -> lib_list_node.segp; source_info.input_lng = divide (cur_lib_node_p -> lib_list_node.segbc+8, 9, 17, 0); call expand_pathname_ ((cur_lib_node_p -> lib_list_node.segname), temp_dir, temp_ent, code); source_info.given_ename = substr (temp_ent, 1, 33 - verify (reverse (temp_ent), " ")); call hcs_$status_long (temp_dir, temp_ent, 1, addr (branch_status), null, code); /* ignore any error--not likely and doesn't matter */ source_info.date_time_modified = fixed (branch_status.date_time_modified || (16)"0"b, 71); source_info.unique_id = branch_status.unique_id; call hcs_$fs_get_path_name (source_info.input_pointer, temp_dir, i, temp_ent, code); source_info.dirname = substr (temp_dir, 1, i); source_info.segname = substr (temp_ent, 1, 33 - verify (reverse (temp_ent), " ")); if compiler_invoked then return; /* here at most once per run unit */ array_p = addr (object_ptr); call get_temp_segments_ ("dfast_run_unit_manager_", based_array, code); if code ^= 0 then do; call error (4, "Unable to obtain segment for compiled code.", " "); go to main_return; end; save_main = is_main; /* note if compiling maan */ is_main = "0"b; /* turn off for any libraries found */ compiler_invoked = "1"b; if system = "fortran" then do; unspec (fort_options) = dfast_mask; call fort_$compile_run ( source_info_pointer, object_ptr, object_length, addr (fort_options), dfast_get_next_source_seg_, dfast_add_to_lib_list_, code); end; else call basic_$run_unit_compiler ( /* assume basic */ source_info_pointer, object_ptr, object_length, debug_sw, dfast_get_next_source_seg_, dfast_add_to_lib_list_, code); if code ^= 0 then do; call error (3, "errors in source. Program could not be run.", " "); return; end; object_len = object_length * 36; /* convert to bit count */ call hcs_$set_bc_seg (object_ptr, object_len, code); call object_info_$display (object_ptr, object_len, addr (oi), code); is_main = save_main; if code ^= 0 then call error (3, "Errors in source. Program could not be run.", " "); else call process_object_ ("0"b, "0"b); /* find defs; don't copy linkage */ return; end; end; /* found all libraries; tell compiler to finish object */ if compiler_invoked then source_info.input_pointer = null; return; end; dfast_get_next_source_seg_: proc (source_info_pointer); dcl source_info_pointer ptr; call process_lib_list_ (source_info_pointer); return; end; /* dfast_get_next_source_seg_ */ allocate_: proc (nwords, newptr); /* this routine allocates spece in the scratch segment; it is used when the run unit is being set up */ dcl nwords fixed bin; dcl newptr ptr; /* always allocate on even word boundary */ if mod (fixed (rel (cur_free_p), 18), 2) = 1 then cur_free_p = addrel (cur_free_p, 1); newptr = cur_free_p; cur_free_p = addrel (cur_free_p, nwords); if fixed (rel (cur_free_p), 18) > ru_area_size then do; call error (4, "Attempt to overflow run unit scratch area.", " "); go to main_return; /* abort completely; can't continue at all */ end; return; end; /* allocate_ */ error: proc (severity, control_string, arg_string); dcl severity fixed bin; dcl (control_string, arg_string) char (*) aligned; max_severity = max (max_severity, severity); call ioa_ (control_string, arg_string); return; end; /* error */ terminate_run_entry: proc; goto terminate; end; /* terminate_run_entry */ fault_tag_3_handler: proc; /* fortran links which could not be snapped are converted to fault tag 3's */ dcl link_ptr ptr; dcl dl_code fixed bin (35); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl 1 ext aligned like ext_template; dcl 1 cond_info aligned, %include cond_info; %include mc; cond_info.version = 1; call find_condition_info_ (null, addr (cond_info), dl_code); if dl_code ^= 0 then goto continue_ft3; scup = addr (cond_info.mcptr -> mc.scu (0)); link_ptr = ptr (baseptr (fixed (fixed (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ca); call decode_ftn_link_ (link_ptr, addr (ext), "0"b, dl_code); if dl_code = 0 then call ioa_ ("Attempt to reference missing subprogram ^a.^/Program aborted.", ext.ename); else if dl_code = 2 then call ioa_ ( "Attempt to reference through invalid link.^/FORTRAN compiler error. Program aborted."); else do; /* at this writing no other codes are returned, but... */ continue_ft3: call continue_to_signal_ (code); return; end; goto terminate; end; /* fault_tag_3_handler */ end;  dfast_set_system_.pl1 11/05/82 1316.6rew 11/04/82 1552.7 17829 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_set_system_: proc (name, basic_system, tag, code); /* This procedure parses the name and sets basic_system if there is an appropriate language suffix. If basic_system is changed, a warning message is printed. _s_u_f_f_i_x _c_o_d_e _b_a_s_i_c___s_y_s_t_e_m .basic 0 "1"b .fortran 0 "0"b neither no_suffix not changed */ dcl name char (256) var; /* name to be parsed for language suffix */ dcl basic_system bit (1) unal; /* ON if basic; OFF if fortran */ dcl tag char (*); dcl code fixed bin (35); /* fast error code */ dcl len fixed bin; /* length of the object name */ dcl (length, substr, reverse) builtin; dcl iox_$user_output ptr ext static; dcl ioa_$ioa_switch entry options (variable); %include dfast_error_codes; /* */ tag = ""; if substr (reverse (name), 1, 6) = reverse (".basic") then do; len = length (name) - 6; if len > 0 then do; if ^basic_system then call message; tag = "basic"; return; end; end; else if substr (reverse (name), 1, 8) = reverse (".fortran") then do; len = length (name) - 7; if len > 0 then do; if basic_system then call message; tag = "fortran"; return; end; end; code = error_no_suffix; return; /* */ /* This procedure changes the system and prints a warning message. */ message: proc; dcl system_name char (7); basic_system = ^basic_system; if basic_system then system_name = "basic"; else system_name = "fortran"; call ioa_$ioa_switch (iox_$user_output, "system changed to ^a", system_name); return; end message; end dfast_set_system_;  dfast_terminal_control_.pl1 11/05/82 1316.6rew 11/04/82 1552.7 18576 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dfast_terminal_control_: proc (request, terminal_type, arg_edit_info_ptr, code); /* This procedure changes the input/output mode of the terminal: * * (1) fullduplex * (2) halfduplex * (3) uppercase * (4) lowercase * (5) tape not implemented * (6) keyboard not implemented * (7) direct not implemented * (8) terminal type not implemented */ dcl request fixed bin; /* number indicating request */ dcl terminal_type char (*); /* terminal type to use */ dcl arg_edit_info_ptr ptr; /* pointer to edit_info_structure */ dcl code fixed bin (35); /* FAST or Multics error code */ dcl iox_$user_io ptr ext static; dcl iox_$user_output ptr ext static; dcl iox_$user_input ptr ext static; dcl old_modes char (132); /* save old modes for restore */ dcl string char (100) var based; dcl dfast_error_ entry (fixed bin (35), char (*), char (*)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl set_tty entry options (variable); dcl (addr, null, substr)builtin; /* constants */ dcl modes (4) char (18) int static options (constant) init ( "fulldpx,echoplex", "^fulldpx,^echoplex", "capo,edited", "^capo,^edited"); dcl CAPS fixed bin int static options (constant) init (3); /* change to caps for output */ dcl DIRECT fixed bin int static options (constant) init (7); dcl TYPE fixed bin int static options (constant) init (8); /* based */ %include dfast_error_codes; /* */ if request <= 4 then do; call iox_$modes (iox_$user_io, (modes (request)), old_modes, code); if code ^= 0 then call dfast_error_ (code, "modes", ""); end; return; end dfast_terminal_control_; 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