ge_eval_.pl1 11/18/82 1708.6rew 11/18/82 1626.8 359136 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ge_eval_: proc; return; /* Semantic analyzer for graphic_editor. */ /* Written 1/10/75 by C. D. Tavares */ /* Modified 08/14/75 by CDT to check for too many simple indirects in reference, e.g. "foo......" where there are too many periods, and to strip quotes from datablocks. */ /* Modified 08/28/75 by CDT to call initialize_ptrs from perform_recursion. Local ptrs were becoming invalid when recursive sons grew (therefore moved) some tables. */ /* Modified 10/15/75 by CDT to use new-type dispatch vector in system symbol structure and to use "effective_level" to implement new parsing rules for when a expression is terminated */ /* Modified 04/22/76 by CDT to fix minor +/-1 bug in loop causing OOBs with new areas */ /* Modified 06/25/76 by CDT to add system macros feature (circles, arcs...) and to add parenthesized macro argument feature to normal user macros. */ /* Modified 08/30/76 by CDT to fix several problem bugs in regular expression parsing, as far as what assignments to a Q.E. meant */ /* Modified 10/29/76 by CDT not to reject tokens of type "Number" as text strings. */ /* Last modified 08/29/80 by CDT to fix defaults for scaling when no args given */ tuple_evaluator: entry (environment_ptr, code); dcl environment_ptr pointer parameter, code fixed bin (35) parameter; dcl sysprint stream; dcl temp_p pointer; code = 0; call tuple_evaluator_recur (environment_ptr, 0, code); call check_for_undefineds (environment_ptr, code); /* This call is directed to the internal block because all the based variables are declared in the internal block. */ return; tuple_evaluator_recur: proc (environment_ptr, recursion_level, code) recursive; dcl code fixed bin (35) parameter, recursion_level fixed bin parameter; dcl ge_parse_$get_token ext entry (char (*) varying, fixed bin, fixed bin), ge_parse_$backup ext entry, ge_parse_$push_macro ext entry (pointer, fixed bin, pointer); dcl effective_level fixed bin; dcl token char (200) varying, (i, j, k) fixed bin, token_type fixed bin; dcl based_name char (32) based (name_ptr) varying, name_ptr pointer; dcl ioa_$rsnnl ext entry options (variable); %include ge_environment; %include ge_data_structures; %include ge_token_types; call initialize_ptrs; cur_elements = 0; code = 0; effective_level = recursion_level + stack.level; /* now ge_parse_$get_token will require */ /* a semicolon if we are recursing (meaning that */ /* some parens are open) or if the stack is being */ /* actively used (assignments pending, etc.) */ do while ("1"b); /* forever, until some termination condition */ /* allows us to return */ call ge_parse_$get_token (token, token_type, effective_level); if token_type = Break then if token = "(" then do; call perform_recursion; call ge_parse_$get_token (token, token_type, effective_level); if token ^= ")" then call generate_error ("""^a"" where "")"" expected.", token); tuple_p = stack (level).tuple_ptr; do i = 1 to tuple.n_elements; assembly_tuple.element (cur_elements + i) = tuple.element (i); end; cur_elements = cur_elements + i - 1; free stack (level).tuple_ptr -> tuple in (my_area); stack.level = stack.level - 1; effective_level = effective_level - 1; end; else call generate_error ("""^a"" where symbol name expected.", token); else if token_type = Name then do; cur_elements = cur_elements + 1; call get_values; end; else call generate_error ("Misplaced ""^a"".", token); call ge_parse_$get_token (token, token_type, effective_level); if token_type ^= Break then call generate_error ("""^a"" where separator expected.", token); if token = "," then; /* do nothing; we will loop again */ else if token = "=" then do; call push_tuple; call perform_recursion; call perform_assignment; return; end; else if token = ";" then do; call ge_parse_$backup; call push_tuple; return; end; else if token = ")" then do; if recursion_level = 0 then call generate_error ("Too many ""^a""'s.", token); call push_tuple; call ge_parse_$backup; return; end; else call generate_error ("Bad separator ""^a"".", token); end; push_tuple: proc; stack.level = stack.level + 1; effective_level = effective_level + 1; if stack.level > stack.cur_max_frames then do; temp_p = stack_p; max_frames = cur_max_frames + 50; allocate stack in (my_area); do k = 1 to temp_p -> stack.level; stack_p -> stack.tuple_ptr (k) = temp_p -> stack.tuple_ptr (k); end; stack_p -> stack.level = temp_p -> stack.level; environment.stack_p = stack_p; free stack_p -> stack in (my_area); end; allocate tuple in (my_area); do i = 1 to cur_elements; tuple.element (i) = assembly_tuple.element (i); end; stack (level).tuple_ptr = tuple_p; end push_tuple; perform_recursion: proc; /* This internal subroutine saves assembly_tuple in myarea and then calls tuple_evaluator_recur. The reason this is necessary is that assembly_tuple is too big to be automatic; it causes stack overflows. This works well and prevents overflows. */ dcl i fixed bin, save_at_ptr pointer; allocate tuple in (my_area) set (save_at_ptr); do i = 1 to cur_elements; save_at_ptr -> tuple.element (i) = assembly_tuple.element (i); end; call tuple_evaluator_recur (environment_ptr, recursion_level + 1, code); if code ^= 0 then goto return_hard; effective_level = recursion_level + stack.level; /* reset this, stack may have changed */ call initialize_ptrs; /* some tables may have been grown, therefore moved */ do i = 1 to cur_elements; assembly_tuple.element (i) = save_at_ptr -> tuple.element (i); end; free save_at_ptr -> tuple in (my_area); return; end perform_recursion; get_values: proc; dcl (i, j, first, last, n, eff_type) fixed bin, element_list (4094) fixed bin (18), cv_dec_ ext entry (char (*)) returns (fixed bin), cv_float_ ext entry (char (*), fixed bin) returns (float bin), coords (3) float bin; dcl hold_name char (32) varying; dcl 1 element like tuple.element based (element_ptr), element_ptr pointer initial (addr (assembly_tuple.element (cur_elements))); assembly_tuple (cur_elements).name = token; name_ptr = addr (assembly_tuple (cur_elements).name); offset = Undefined; if substr (token, 1, 1) = """" then do; /* implicit text */ call ge_parse_$backup; token = "text"; end; if substr (token, 1, 1) = "#" then do; /* node constant */ based_name = token; rvalue = cv_dec_ (substr (token, 2)); call graphic_manipulator_$examine_type (rvalue, ""b, 0, code); if code ^= 0 then call generate_error ("Node constant ""^a"".", based_name); end; else do; /* must be symbol */ do j = 2 to 1 by -1; do k = 1 to n_system_symbols; if token = system_symbols (k, j) then do; lvalue, table_idx = Illegal; eff_type = system_symbol_vector (k); goto generate_element (eff_type); end; end; end; do j = 2 to 1 by -1; do k = 1 to n_system_macros; if token = system_macros (k, j) then do; lvalue, table_idx = Illegal; eff_type = system_macro_vector (k); goto generate_sysmacro (eff_type); end; end; end; do j = 1 to n_macros; if macro.name (j) = token then do; call setup_macro (j); call ge_parse_$get_token (token, token_type, effective_level); call get_values; return; end; end; lvalue = Undefined; type = Symbol; do i = 1 to n_symbols while (token ^= symbol (i).name); end; if i > n_symbols then rvalue, table_idx = Undefined; else do; rvalue = symbol (i).node_value; table_idx = i; end; end; call ge_parse_$get_token (token, token_type, effective_level); if token = "." then if rvalue = Undefined then call generate_error ("""^a"" undefined.", based_name); else table_idx = Illegal; /* forget the table, we're gonna go a-qualifyin'. */ /* MAIN QUALIFIED EXPRESSION PARSING LOOP */ do while (token = "."); based_name = based_name || "."; if type ^= Symbol then if lvalue = Undefined then /* at the end of the line already */ no_such_level: call generate_error ("No such level of qualification: ""^a"".", based_name); if type = Symbol then call indirect_thru_symbol; else call get_to_contents; if code ^= 0 then goto no_such_level; call ge_parse_$get_token (token, token_type, effective_level); if token = "." then; /* will catch "." next time; just reiterate thru loop */ else if token = ";" then; /* ignore; we'll drop out of the loop */ else if (token_type ^= Number & token ^= "*") then; /* ignore it; we'll drop out of the loop */ else do; if token_type = Number then do; first, last = cv_dec_ ((token)); call ge_parse_$get_token (token, token_type, effective_level); if token = ":" then do; call ge_parse_$get_token (token, token_type, effective_level); if token_type ^= Number then if token ^= "*" then call generate_error ("Bad qualifier ""^a"".", based_name); if token_type = Number then last = cv_dec_ ((token)); else last = -1; call ge_parse_$get_token (token, token_type, effective_level); end; end; else do; first = 1; last = -1; call ge_parse_$get_token (token, token_type, effective_level); end; code = 0; if type ^= Array then do while (code = 0); call indirect_thru_symbol; end; if type ^= Array then call generate_error ("""^a"" is not an array.", based_name); call graphic_manipulator_$examine_list (rvalue, element_list, n, code); if code ^= 0 then internal_error: call generate_error ("Internal error on ""^a"".", based_name); if last > n then call generate_error ("No such element in ""^a"".", based_name); if last = -1 then last = n; lvalue = rvalue; /* remember what list we were */ hold_name = based_name; do i = 0 to last - first; j = cur_elements + i; if i > 0 then assembly_tuple.element (j) = assembly_tuple.element (cur_elements); assembly_tuple (j).offset = first + i; assembly_tuple (j).rvalue = element_list (first + i); call ioa_$rsnnl ("^a^d", assembly_tuple (j).name, 0, hold_name, first + i); assembly_tuple (j).type = Illegal; /* usefulness of "type" of an array element is highly questionable. */ end; if last - first > 0 then if token = "." then call generate_error ("Expansion qualifier not last in ""^a"".", based_name); else cur_elements = cur_elements + i - 1; end; end; if rvalue = Undefined then if token_type ^= Break then call generate_error ("""^a"" undefined.", based_name); call ge_parse_$backup; return; /* ------------------------- */ indirect_thru_symbol: proc; dcl temp_node fixed bin (18); call graphic_manipulator_$examine_symbol (rvalue, temp_node, 0, "", code); if code = 0 then rvalue = temp_node; else return; get_to_contents: entry; lvalue, offset = Undefined; call graphic_manipulator_$examine_type (rvalue, ""b, type, code); if type = List then type = Array; /* We trigger on array only; both act alike. */ else if type = Symbol then lvalue = rvalue; return; end indirect_thru_symbol; /* ------------------------- */ /* ------------------------- */ setup_macro: proc (which); dcl which fixed bin, macro_nodes (21) fixed bin (18), string char (200), temp_node fixed bin (18), n_chars fixed bin; dcl leading_sign char (1) varying; dcl paren_level fixed bin; call graphic_manipulator_$examine_symbol (macro.node_value (which), temp_node, 0, "", code); if code ^= 0 then macro_error: call generate_error ("While attempting to use macro ""^a"".", macro.name (which)); call graphic_manipulator_$examine_list (temp_node, macro_nodes, n_macro_args, code); if code ^= 0 then goto macro_error; n_macro_args = n_macro_args - 1; allocate macro_info in (my_area) set (macro_info_p); macro_bits_l = size (based_macro_arg) * 36; do i = 1 to n_macro_args; macro_bits_p = addr (macro_info_p -> macro_info.argument (i)); call graphic_manipulator_$examine_data (macro_nodes (i), 0, based_macro_bits, code); if code ^= 0 then goto macro_error; call ge_parse_$get_token (token, token_type, effective_level); if token = "(" then do; /* parenthesized macro argument */ macro_info_p -> macro_info.replacement (i) = ""; paren_level = 1; do while (paren_level > 0); call ge_parse_$get_token (token, token_type, effective_level); if token = "(" then paren_level = paren_level + 1; else if token = ")" then paren_level = paren_level - 1; else if token = ";" then do; free macro_info_p -> macro_info in (my_area); call generate_error ("Unbalanced parentheses in macro argument.", ""); end; if length (macro_info_p -> macro_info.replacement (i)) > 0 then macro_info_p -> macro_info.replacement (i) = macro_info_p -> macro_info.replacement (i) || " "; if paren_level > 0 then macro_info_p -> macro_info.replacement (i) = macro_info_p -> macro_info.replacement (i) || token; end; end; else do; leading_sign = ""; do while (token_type = Break); /* snarf all leading signs */ if token = "+" then; /* nothing */ else if token = "-" then if leading_sign = "-" then leading_sign = "+"; else leading_sign = "-"; else do; free macro_info_p -> macro_info in (my_area); call generate_error ("""^a"" instead of macro argument.", token); end; call ge_parse_$get_token (token, token_type, effective_level); end; if leading_sign ^= "" then if token_type ^= Number then call generate_error ("Arithmetic signs encountered before ""^a"".", token); macro_info_p -> macro_info.replacement (i) = leading_sign || token; end; end; call ge_parse_$get_token (token, token_type, effective_level); if token_type ^= Break then call generate_error ("Too many arguments to macro ""^a"".", macro.name (which)); call ge_parse_$backup; macro_bits_p = addr (macro_def); macro_bits_l = size (macro_def) * 36; call graphic_manipulator_$examine_data (macro_nodes (n_macro_args + 1), 0, based_macro_bits, code); if code ^= 0 then goto macro_error; string = macro_def; n_chars = length (macro_def); call ge_parse_$push_macro (addr (string), n_chars, macro_info_p); return; end setup_macro; /* ------------------------- */ generate_element (1): generate_element (2): generate_element (3): generate_element (4): generate_element (5): /* all positional elements */ coords = 0; code = 0; do i = 1 to 3 while (code = 0); call get_float_number (coords (i), code); end; type = eff_type - 1; rvalue = graphic_manipulator_$create_position (type, coords (1), coords (2), coords (3), code); if code ^= 0 then goto internal_error; return; /* ------------------------- */ get_float_number: proc (num, code); dcl num float bin, i fixed bin, code fixed bin (35); i = 1; code = 0; call ge_parse_$get_token (token, token_type, effective_level); do while (token_type = Break); if token = "+" then; /* do nothing */ else if token = "-" then i = i * -1; /* reverse final sign */ else goto unknown_sign; call ge_parse_$get_token (token, token_type, effective_level); end; if token_type ^= Number then do; unknown_sign: call ge_parse_$backup; /* leave for next chump */ code = -1; return; end; num = cv_float_ ((token), 0) * i; return; end get_float_number; /* ------------------------- */ generate_element (6): /* the null element */ rvalue = 0; type = Null; return; generate_element (7): /* text string */ dcl alignment fixed bin, text_string char (200) varying; dcl alignment_abbrevs (9) char (12) varying initial ("ul", "uc", "ur", "l", "c", "r", "ll", "lc", "lr"); call read_text_element (text_string, alignment); /* ------------------------- */ read_text_element: proc (text_string, alignment); /* This internal subr reads the arguments to the text element and assembles them into something meaningful. */ dcl (text_string char (*) varying, alignment fixed bin) parameter; alignment = Undefined; call ge_parse_$get_token (text_string, token_type, effective_level); if token_type = Break then call generate_error ("""^a"" not a text string.", text_string); if substr (text_string, 1, 1) = """" /* it is quoted */ then text_string = substr (text_string, 2, length (text_string) - 2); /* strip quote marks */ call ge_parse_$get_token (token, token_type, effective_level); if token_type = Break then do; /* oops, no alignment given */ call ge_parse_$backup; /* didn't want it */ alignment = 1; /* default */ end; else if token_type = Number then alignment = cv_dec_ ((token)); /* got a number */ else if token_type = Name /* convert name to number */ then do j = 1 to hbound (Text_alignments, 1); if (alignment_abbrevs (j) = token | Text_alignments (j) = token) then do; alignment = j; i = 0; j = hbound (Text_alignments, 1) + 1; end; end; if (alignment < lbound (alignment_abbrevs, 1) | alignment > hbound (alignment_abbrevs, 1)) /* out of bounds */ then alignment = Undefined; if alignment = Undefined then call generate_error ("""^a"" not a valid text alignment.", token); return; end read_text_element; /* ------------------------- */ rvalue = graphic_manipulator_$create_text (alignment, length (text_string), (text_string), code); if code ^= 0 then goto internal_error; type = Text; return; generate_element (8): /* array */ call make_list_or_array (Array); return; generate_element (9): /* list */ call make_list_or_array (List); return; /* ---------------------------- */ make_list_or_array: proc (whatever); dcl whatever fixed bin; call ge_parse_$get_token (token, token_type, effective_level); if token ^= "(" then call generate_error ("""^a"" instead of ""("" after array/list.", token); call perform_recursion; call ge_parse_$get_token (token, token_type, effective_level); if token ^= ")" then call generate_error ("""^a"" instead of "")"" after array/list.", token); call scan_for_undefineds (stack (level).tuple_ptr); if whatever = List then rvalue = graphic_manipulator_$create_list (stack (level).tuple_ptr -> tuple.rvalue (*), stack (level).tuple_ptr -> tuple.n_elements, code); else rvalue = graphic_manipulator_$create_array (stack (level).tuple_ptr -> tuple.rvalue (*), stack (level).tuple_ptr -> tuple.n_elements, code); if code ^= 0 then call generate_error ("Internal error making explicit list/array.", ""); free stack (level).tuple_ptr -> tuple in (my_area); stack.level = stack.level - 1; effective_level = effective_level - 1; type = whatever; return; end make_list_or_array; /* ---------------------------- */ generate_element (10): /* intensity */ dcl intensity fixed bin; intensity = 7; call ge_parse_$get_token (token, token_type, effective_level); if token_type = Number then do; intensity = cv_dec_ ((token)); if intensity < 0 then goto bad_intensity; if intensity > 7 then goto bad_intensity; end; else if token = "off" then intensity = 0; else if token = "full" then intensity = 7; else if token = "on" then intensity = 7; else do; /* wasn't any */ bad_intensity: if token_type ^= Break then call generate_error ("Bad intensity level ""^a"".", token); call ge_parse_$backup; return; end; rvalue = graphic_manipulator_$create_mode (Intensity, intensity, code); if code ^= 0 then goto internal_error; type = Intensity; return; generate_element (11): /* linetype */ dcl linetype fixed bin; linetype = -1; call ge_parse_$get_token (token, token_type, effective_level); if token_type = Number then do; linetype = cv_dec_ ((token)); if linetype < lbound (Linetype_names, 1) then goto bad_linetype; if linetype > hbound (Linetype_names, 1) then goto bad_linetype; end; else do i = lbound (Linetype_names, 1) to hbound (Linetype_names, 1); if Linetype_names (i) = token then do; linetype = i; i = hbound (Linetype_names, 1); end; end; if linetype = -1 then do; bad_linetype: if token_type ^= Break then call generate_error ("Bad linetype ""^a"".", token); call ge_parse_$backup; linetype = 0; end; rvalue = graphic_manipulator_$create_mode (Linetype, linetype, code); if code ^= 0 then goto internal_error; type = Linetype; return; generate_element (12): /* blink */ dcl blink fixed bin; blink = -1; call ge_parse_$get_token (token, token_type, effective_level); if token_type = Number then do; blink = cv_dec_ ((token)); if blink < 0 then goto bad_blink; if blink > 1 then goto bad_blink; end; else if token = "off" then blink = 0; else if token = "on" then blink = 1; else do i = 1 to hbound (Blink_names, 1); if Blink_names (i) = token then do; blink = i; i = hbound (Blink_names, 1); end; end; if blink = -1 then do; bad_blink: if token_type ^= Break then call generate_error ("Bad blink type ""^a"".", token); call ge_parse_$backup; blink = 1; end; rvalue = graphic_manipulator_$create_mode (Blink, blink, code); if code ^= 0 then goto internal_error; type = Blink; return; generate_element (13): /* sensitivity */ dcl sensitivity fixed bin; sensitivity = -1; call ge_parse_$get_token (token, token_type, effective_level); if token_type = Number then do; sensitivity = cv_dec_ ((token)); if sensitivity < 0 then goto bad_sensitivity; if sensitivity > 1 then goto bad_sensitivity; end; else if token = "on" then sensitivity = 1; else if token = "off" then sensitivity = 0; else do i = 1 to hbound (Sensitivity_names, 1); if Sensitivity_names (i) = token then do; sensitivity = i; i = hbound (Sensitivity_names, 1); end; end; if sensitivity = -1 then do; bad_sensitivity: if token_type ^= Break then call generate_error ("Bad sensitivity type ""^a"".", token); call ge_parse_$backup; sensitivity = 1; end; rvalue = graphic_manipulator_$create_mode (Sensitivity, sensitivity, code); if code ^= 0 then goto internal_error; type = Sensitivity; return; generate_element (14): /* rotation */ dcl angles (3) float bin; code, angles = 0; do i = 1 to 3 while (code = 0); call get_float_number (angles (i), code); end; rvalue = graphic_manipulator_$create_rotation (angles (1), angles (2), angles (3), code); if code ^= 0 then goto internal_error; type = Rotation; return; generate_element (15): /* scaling */ dcl scales (3) float bin; code = 0; scales = 1; do i = 1 to 3 while (code = 0); call get_float_number (scales (i), code); end; rvalue = graphic_manipulator_$create_scale (scales (1), scales (2), scales (3), code); if code ^= 0 then goto internal_error; type = Scaling; return; generate_element (16): /* datablock */ call ge_parse_$get_token (token, token_type, effective_level); if token_type = Break then call generate_error ("Break ""^a"" instead of datablock contents.", token); if substr (token, 1, 1) = """" /* was a quoted string */ then token = substr (token, 2, length (token) - 2); /* strip quotes */ macro_bits_p = addr (token); macro_bits_l = length (token) * 9 + 36; /* save length word and meaningful part */ rvalue = graphic_manipulator_$create_data (macro_bits_l, based_macro_bits, code); if code ^= 0 then goto internal_error; type = Datablock; return; generate_element (17): /* color */ dcl colors (3) fixed bin, which_color fixed bin, color_value fixed bin; dcl (red initial (1), green initial (2), blue initial (3)) fixed bin static options (constant); colors = 0; do i = 1 to 3; /* allow for 3 color specifications */ color_value = 63; /* set to default */ call ge_parse_$get_token (token, token_type, effective_level); if token_type = Break then do; if i = 1 then colors = 16; /* no color specified, use default */ goto end_color_loop; end; if token = "red" then which_color = red; else if token = "blue" then which_color = blue; else if token = "green" then which_color = green; else call generate_error ("""^a"" not a defined color.", token); call ge_parse_$get_token (token, token_type, effective_level); if token_type = Break then i = 3; else if token_type = Name /* another color spec? */ then if i < 3 /* there can still be one more */ then call ge_parse_$backup; /* save it for later */ else call generate_error ("Misplaced token ""^a"".", token); /* couldn't have been four color specs */ else if token_type = Number then do; color_value = cv_dec_ ((token)); if color_value < 0 then bad_color: call generate_error ("Bad color specification ""^a"".", token); if color_value > 63 then goto bad_color; end; else goto bad_color; colors (which_color) = color_value; end; end_color_loop: if token_type = Break then call ge_parse_$backup; rvalue = graphic_manipulator_$create_color (colors (1), colors (2), colors (3), code); if code ^= 0 then goto internal_error; type = Color; return; generate_sysmacro (3): /* circle builtin */ dcl sysmacro_value fixed bin (18); coords = 0; code = 0; do i = 1 to 2 while (code = 0); call get_float_number (coords (i), code); end; sysmacro_value = graphic_macros_$circle (coords (1), coords (2), code); if code ^= 0 then goto internal_error; rvalue = make_sysmacro_array (sysmacro_value, "circle", "", 0, 0, coords, 2, ""); return; /* --------------- */ make_sysmacro_array: proc (value, name, text_string, alignment, n_text_args, numeric_args, n_numeric_args, table_name) returns (fixed bin (18)); dcl (value fixed bin (18), name char (12), text_string char (*) varying, alignment fixed bin, n_text_args fixed bin, numeric_args (*) float bin, n_numeric_args fixed bin, table_name char (32)) parameter; dcl sysmacro_data_string char (128) varying, sysmacro_data_string_len fixed bin, (sysmacro_subarray (2), sysmacro_value, return_val) fixed bin (18); dcl unique_chars_ ext entry (bit (*)) returns (char (15)); if n_text_args ^= 0 then call ioa_$rsnnl ("^a ^a ^a^[ ^f^2s^; ^f ^f^s^] ^a", sysmacro_data_string, sysmacro_data_string_len, name, text_string, Text_alignments (alignment), n_numeric_args, numeric_args, table_name); else call ioa_$rsnnl ("^a^v( ^f^)", sysmacro_data_string, sysmacro_data_string_len, name, n_numeric_args, numeric_args); sysmacro_subarray (1) = graphic_manipulator_$create_data (length (unspec (addr (sysmacro_data_string) -> based_varying_string)), unspec (addr (sysmacro_data_string) -> based_varying_string), code); if code ^= 0 then goto internal_error; sysmacro_subarray (2) = value; sysmacro_value = graphic_manipulator_$create_array (sysmacro_subarray, 2, code); if code ^= 0 then goto internal_error; return_val = graphic_manipulator_$assign_name ("!sysmacro." || unique_chars_ (""b), sysmacro_value, code); if code ^= 0 then goto internal_error; return (return_val); end make_sysmacro_array; /* --------------- */ generate_sysmacro (2): /* box builtin */ coords = 0; do i = 1 to 2 while (code = 0); call get_float_number (coords (i), code); end; if code ^= 0 then call generate_error ("Not enough arguments to ""box"".", ""); sysmacro_value = graphic_macros_$box (coords (1), coords (2), code); if code ^= 0 then goto internal_error; rvalue = make_sysmacro_array (sysmacro_value, "box", "", 0, 0, coords, 2, ""); return; generate_sysmacro (1): /* arc builtin */ coords = 0; do i = 1 to 3 while (code = 0); call get_float_number (coords (i), code); end; if code ^= 0 then call generate_error ("Not enough arguments to ""arc"".", ""); sysmacro_value = graphic_macros_$arc (coords (1), coords (2), coords (3) /* really the fraction */, code); if code ^= 0 then goto internal_error; rvalue = make_sysmacro_array (sysmacro_value, "arc", "", 0, 0, coords, 3, ""); return; generate_sysmacro (4): /* ellipse builtin */ dcl ellipse_data (5) float bin; ellipse_data (*) = 0; do i = 1 to 5 while (code = 0); call get_float_number (ellipse_data (i), code); end; if i < 4 then call generate_error ("Not enough arguments to ""ellipse"".", ""); if code ^= 0 then ellipse_data (5) = 1; /* whole ellipse */ sysmacro_value = graphic_macros_$ellipse (ellipse_data (1), ellipse_data (2), ellipse_data (3), fixed (ellipse_data (4)), ellipse_data (5), code); if code ^= 0 then goto internal_error; rvalue = make_sysmacro_array (sysmacro_value, "ellipse", "", 0, 0, ellipse_data, 5, ""); return; generate_sysmacro (5): /* polygon builtin */ coords = 0; do i = 1 to 3 while (code = 0); call get_float_number (coords (i), code); end; if code ^= 0 then call generate_error ("Not enough arguments to ""polygon"".", ""); sysmacro_value = graphic_macros_$polygon (coords (1), coords (2), fixed (coords (3)), code); if code ^= 0 then goto internal_error; rvalue = make_sysmacro_array (sysmacro_value, "polygon", "", 0, 0, coords, 3, ""); return; generate_sysmacro (6): /* varying_text */ dcl default_text_size (3) float bin static options (constant) initial (18.380e0, 20e0, 0e0), temp_dirname char (168); call read_text_element (text_string, alignment); coords (*) = default_text_size (*); do i = 1 to 2 while (code = 0); call get_float_number (coords (i), code); end; if code ^= 0 then if i = 3 then coords (2) = coords (1); /* gave width only */ temp_dirname = ""; call ge_parse_$get_token (token, token_type, effective_level); if token_type ^= Name then do; call ge_parse_$backup; if environment.cur_char_table.ename ^= environment.default_char_table.ename then do; token = environment.default_char_table.ename; temp_dirname = environment.default_char_table.dirname; token_type = Name; end; end; if token_type = Name then do; /* a graphic char table was specified */ if environment.cur_char_table.ename ^= token then do; call graphic_chars_$set_table (temp_dirname, (token), code); if code ^= 0 then call generate_error ("Undefined character table ""^a"".", token); call graphic_chars_$get_table (environment.cur_char_table.dirname, environment.cur_char_table.ename); end; end; sysmacro_value = graphic_chars_ ((text_string), alignment, coords (1), coords (2), code); if code ^= 0 then goto internal_error; /* now double all quotes so replay description looks right. */ do i = 1 by 1 while (i < length (text_string)); if substr (text_string, i, 1) = """" then do; text_string = substr (text_string, 1, i) || """" || substr (text_string, i+1); i = i + 1; end; end; text_string = """" || text_string || """"; rvalue = make_sysmacro_array (sysmacro_value, "varying_text", text_string, alignment, 2, coords, 2, environment.cur_char_table.ename); return; end get_values; perform_assignment: proc; dcl j fixed bin; dcl (to_ptr, from_ptr) pointer; dcl symbol_name char (32), symbol_len fixed bin; from_ptr = stack (level).tuple_ptr; to_ptr = stack (level-1).tuple_ptr; if debugsw then do; put list ("Beginning assignment;") skip; put list ("From "); put list /* data */ (from_ptr -> tuple) skip (2); put list ("To "); put list /* data */ (to_ptr -> tuple) skip (4); end; if from_ptr -> tuple.n_elements = 1 then if to_ptr -> tuple.n_elements > 1 then do; cur_elements = to_ptr -> tuple.n_elements; allocate tuple in (my_area); do i = 1 to cur_elements; tuple_p -> tuple.element (i) = from_ptr -> tuple.element (1); end; free from_ptr -> tuple in (my_area); from_ptr, stack (level).tuple_ptr = tuple_p; end; else; else if from_ptr -> tuple.n_elements > 1 then if to_ptr -> tuple.n_elements = 1 then do; call scan_for_undefineds (from_ptr); cur_elements = 1; allocate tuple in (my_area); tuple_p -> tuple (1).rvalue = graphic_manipulator_$create_array (from_ptr -> tuple.rvalue (*), from_ptr -> tuple.n_elements, code); if code ^= 0 then call generate_error ("Internal error generating implicit array.", ""); tuple_p -> tuple (1).type = Array; free from_ptr -> tuple in (my_area); from_ptr, stack (level).tuple_ptr = tuple_p; end; else; if from_ptr -> tuple.n_elements ^= to_ptr -> tuple.n_elements then call generate_error ("Wrong number of elements assigned to ""^a"".", based_name); do i = 1 to from_ptr -> tuple.n_elements; name_ptr = addr (to_ptr -> tuple.name (i)); if from_ptr -> tuple.rvalue (i) = Undefined then call generate_error ("""^a"" undefined.", from_ptr -> tuple.name (i)); if to_ptr -> tuple.lvalue (i) = Illegal then call generate_error ("""^a"" may not be assigned to.", based_name); if to_ptr -> tuple.offset (i) ^= Undefined then do; j = graphic_manipulator_$replace_element (to_ptr -> tuple.lvalue (i), to_ptr -> tuple.offset (i), from_ptr -> tuple.rvalue (i), code); if code ^= 0 then call generate_error ("Assigning to ""^a"".", based_name); to_ptr -> tuple.rvalue (i) = from_ptr -> tuple.rvalue (i); to_ptr -> tuple.offset (i) = Undefined; end; else if to_ptr -> tuple.type (i) = Symbol then do; if from_ptr -> tuple.type (i) = Symbol then if from_ptr -> tuple.rvalue (i) = to_ptr -> tuple.rvalue (i) then call generate_error ("Recursive assignment of ""^a"".", based_name); if to_ptr -> tuple.lvalue (i) = Undefined then do; symbol_name = to_ptr -> tuple.name (i); symbol_len = length (to_ptr -> tuple.name (i)); end; else do; /* this is a symbol, but gotten to via a qualified exprn. */ /* therefore, tuple.name (i) contains a Q.E., NOT the */ /* real name of the symbol. So we determine it. */ call graphic_manipulator_$examine_symbol (to_ptr -> tuple.lvalue (i), 0, symbol_len, symbol_name, code); if code ^= 0 then call generate_error ("Internal error getting true name for ""^a"".", to_ptr -> tuple.name (i)); do j = 1 to n_symbols while (symbol_name ^= symbol (j).name); end; if j > n_symbols then call generate_error ("Internal error: symbol ""^a"" not found.", (symbol_name)); to_ptr -> tuple.table_idx (i) = j; end; to_ptr -> tuple.rvalue (i) = graphic_manipulator_$assign_name (substr (symbol_name, 1, symbol_len), from_ptr -> tuple (i).rvalue, code); if code ^= 0 then call generate_error ("Assigning to symbol ""^a"".", based_name); end; else do; /* terminal items, or whole arrays */ call graphic_manipulator_$replace_node (to_ptr -> tuple.rvalue (i), from_ptr -> tuple.rvalue (i), code); if code ^= 0 then call generate_error ("Replacing node ""^a"".", based_name); end; /* No need to assign to rvalues or lvalues */ if to_ptr -> tuple.table_idx (i) = Undefined then do; to_ptr -> tuple.table_idx (i), j, n_symbols = n_symbols + 1; if j > cur_max_symbols then do; temp_p = sym_p; /* prepare to extend symbol area */ max_symbols = cur_max_symbols + 50; allocate symbols in (my_area); do k = 1 to temp_p -> n_symbols - 1; sym_p -> symbol (k) = temp_p -> symbol (k); end; sym_p -> n_symbols = temp_p -> n_symbols; environment.sym_p = sym_p; free temp_p -> symbols in (my_area); end; symbol (j).name = to_ptr -> tuple.name (i); end; else j = to_ptr -> tuple.table_idx (i); if j ^= Illegal then symbol (j).node_value = to_ptr -> tuple.rvalue (i); end; if debugsw then do; put list ("Becomes "); put list /* data */ (to_ptr -> tuple); put skip (6); end; free from_ptr -> tuple in (my_area); stack.level = stack.level - 1; effective_level = effective_level - 1; return; end perform_assignment; scan_for_undefineds: proc (tup_ptr); /* This internal procedure scans a tuple to see if any of its elements are undefined. If they are, it generates an error. It is used in various places just before making arrays or lists out of things, to make sure the data is good. */ dcl tup_ptr pointer; dcl i fixed bin; do i = 1 to tup_ptr -> tuple.n_elements; if tup_ptr -> tuple.element (i).rvalue = Undefined then call generate_error ("""^a"" undefined.", tup_ptr -> tuple.element (i).name); end; return; end scan_for_undefineds; generate_error: proc (reason, offender); dcl reason char (*) parameter, offender char (*) varying parameter; if code = 0 then code = -1; call ioa_$rsnnl (reason, environment.error_message, 0, offender); goto return_hard; end generate_error; check_for_undefineds: entry (environment_ptr, code); dcl internal_stack_inconsistent condition; call initialize_ptrs; if stack.level ^= 1 then signal internal_stack_inconsistent; call scan_for_undefineds (stack.tuple_ptr (1)); return; end tuple_evaluator_recur; return_hard: return; %include ge_macro_info; %include gm_entry_dcls; %include gmc_entry_dcls; %include gch_entry_dcls; %include graphic_etypes; %include graphic_enames; flip: entry; dcl debugsw bit (1) aligned static initial (""b); debugsw = ^debugsw; return; end ge_eval_;  ge_interpret_.pl1 11/18/82 1708.6rew 11/18/82 1626.8 151569 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ge_interpret_: proc; return; /* This module implements the "show" and "replay" commands of the graphic_editor. */ /* Written c. Feb 1, 1975 by C. D. Tavares */ /* Modified 08/08/75 by CDT to handle "replay sym1, sym2, ... symn" correctly, i.e. with semicolons after EACH symbol, and not to replay already-replayed subsymbols in this case. */ /* Modified 08/14/75 by CDT to replay quotes arond datablocks correctly. */ /* Modified 08/15/75 by CDT to write around hairy PL/I bug which was causing recursions to lose totally. */ /* Modified 08/28/75 by CDT to put out tabs wherever possible, to save storage space and to chop off trailing zeroes in replays */ /* Last modified 06/25/76 to support system macro feature */ replay: entry (environment_ptr, code); %include ge_environment; %include ge_data_structures; dcl code fixed bin (35); dcl sysprint stream; dcl db_sw bit (1) aligned static initial ("0"b); dcl string char (200), n_chars fixed bin, alignment fixed bin; dcl number_spaces fixed bin static initial (2); /* indentation spaces per level */ dcl (plural, paren) char (1), article char (2); dcl (i, j) fixed bin, (com_err_$suppress_name, ioa_, ioa_$nnl) ext entry options (variable); dcl 1 found_symbols aligned based (fs_ptr), 2 n_found_symbols fixed bin, 2 cur_max_found_symbols fixed bin, 2 name (max_found_symbols refer (cur_max_found_symbols)) char (32) varying; dcl fs_ptr pointer, old_p pointer, max_found_symbols fixed bin; dcl 1 fake_element_array (1) like tuple.element based aligned; call initialize_ptrs; tuple_p = stack (1).tuple_ptr; max_found_symbols = 50; allocate found_symbols in (my_area); n_found_symbols = 0; do i = 1 to tuple.n_elements; if index (tuple.name (i), ".") > 0 then call com_err_$suppress_name (0, "ge_interpret_", """^a"" may not be replayed.", tuple.name (i)); else do; do j = 1 to n_found_symbols while (found_symbols.name (j) ^= tuple.name (i)); end; /* check to see if already put out as sublist */ if j > n_found_symbols then call replay_recur (addr (tuple.element (i)) -> fake_element_array, 0, "1"b); /* fake it, otherwise PL/I builds structure descriptor */ /* instead of array of structures descriptor! */ end; end; call ioa_ (""); /* put out last null line */ free fs_ptr -> found_symbols in (my_area); return; show: entry (environment_ptr, code); call initialize_ptrs; tuple_p = stack (1).tuple_ptr; call replay_recur (tuple.element (*), 0, ""b); return; /* -------------------------------------------------- */ replay_recur: proc (x_element, level, is_replay) recursive; dcl 1 x_element like tuple.element aligned parameter dimension (*); dcl level fixed bin parameter, is_replay bit (1) aligned parameter; dcl i fixed bin, indentation fixed bin, limit fixed bin; if ^is_replay then if db_sw then do; call ioa_$nnl ("|LEVEL ^d->", level); put list ("Showing: "); put skip; put list /* data */ (x_element); put skip; end; limit = hbound (x_element, 1); if db_sw then call ioa_$nnl ("|^d ELEMS AT LEVEL ^d->", limit, level); indentation = level * number_spaces; do i = lbound (x_element, 1) to limit; call replay_element (x_element (i), level, is_replay); if i = limit then if level = 0 then call ioa_ (";"); else; else call ioa_$nnl (",^/^v-^vx", divide (indentation, 10, 17, 0), mod (indentation, 10)); end; if db_sw then call ioa_$nnl ("<-LEVEL ^d|", level); return; /* -------------------------------------------------- */ replay_element: proc (element_arg, level, is_replay); dcl 1 element_arg like tuple.element aligned parameter, level fixed bin parameter, is_replay bit (1) aligned parameter; dcl i fixed bin, mappings (6) float bin, mappings_len fixed bin, (red, green, blue) fixed bin, (x, y, z) float bin, ioa_string char (20) varying, mode fixed bin, mode_string char (32), sub_value fixed bin (18), nc fixed bin, symbol_name char (168) varying, new_indentation fixed bin, array (4095) fixed bin (18), array_len fixed bin; dcl 1 local_tuple like tuple aligned based (local_tuple_p); /* can't use declaration of tuple in outer block for this purpose because of arcane PL/I compiler bug; tries to share descriptor instances during recursion! */ dcl local_tuple_p pointer; call graphic_manipulator_$examine_type (element_arg.rvalue, ""b, element_arg.type, code); if code ^= 0 then call crump (is_replay); goto describe_type (element_arg.type); describe_type (-2): /* illegal node */ call crump (is_replay); describe_type (-1): /* null node */ if is_replay then call ioa_$nnl ("null"); else call ioa_$nnl ("^a is null", element_arg.name); return; describe_type (0): describe_type (1): describe_type (2): describe_type (3): describe_type (4): /* all positionals */ call graphic_manipulator_$examine_position (element_arg.rvalue, 0, x, y, z, code); if code ^= 0 then call crump (is_replay); if is_replay then do; if z = 0 /* save output space by killing trailing zeroes */ then if y = 0 then if x = 0 then ioa_string = "^a"; else ioa_string = "^a ^f"; else ioa_string = "^a ^f ^f"; else ioa_string = "^a ^f ^f ^f"; call ioa_$nnl (ioa_string, Element_names (element_arg.type), x, y, z); end; else do; if z = 0 /* save output space by killing trailing zeroes */ then if y = 0 then if x = 0 then ioa_string = "^a is ^a"; else ioa_string = "^a is ^a ^f"; else ioa_string = "^a is ^a ^f ^f"; else ioa_string = "^a is ^a ^f ^f ^f"; call ioa_$nnl ("^a is ^a ^f ^f ^f", element_arg.name, Element_names (element_arg.type), x, y, z); end; return; describe_type (8): /* scaling */ describe_type (9): /* rotation */ call graphic_manipulator_$examine_mapping (element_arg.rvalue, 0, mappings, mappings_len, code); if code ^= 0 then call crump (is_replay); if is_replay then call ioa_$nnl ("^a ^f ^f ^f", Element_names (element_arg.type), mappings (1), mappings (2), mappings (3)); else call ioa_$nnl ("^a is ^a ^f ^f ^f", element_arg.name, Element_names (element_arg.type), mappings (1), mappings (2), mappings (3)); return; describe_type (16): describe_type (17): describe_type (18): describe_type (19): /* all modes except color */ call graphic_manipulator_$examine_mode (element_arg.rvalue, 0, mode, code); if code ^= 0 then call crump (is_replay); if element_arg.type = 16 then mode_string = Intensity_names (mode); else if element_arg.type = 17 then mode_string = Linetype_names (mode); else if element_arg.type = 18 then mode_string = Sensitivity_names (mode); else mode_string = Blink_names (mode); if is_replay then call ioa_$nnl ("^a ^a", Element_names (element_arg.type), mode_string); else call ioa_$nnl ("^a is ^a ^a", element_arg.name, Element_names (element_arg.type), mode_string); return; describe_type (20): /* color */ call graphic_manipulator_$examine_color (element_arg.rvalue, red, green, blue, code); if code ^= 0 then call crump (is_replay); if is_replay then call ioa_$nnl ("color red ^d green ^d blue ^d", red, green, blue); else call ioa_$nnl ("^a is color red ^d green ^d blue ^d", element_arg.name, red, green, blue); return; describe_type (24): /* symbol */ dcl based_databit_string bit (size (symbol_name) * 36) based; call graphic_manipulator_$examine_symbol (element_arg.rvalue, sub_value, nc, string, code); if code ^= 0 then call crump (is_replay); symbol_name = substr (string, 1, nc); if substr (symbol_name, 1, 10) = "!sysmacro." then do; /* system macro, fake it */ call graphic_manipulator_$examine_list (sub_value, array, array_len, code); if code ^= 0 then call crump (is_replay); call graphic_manipulator_$examine_data (array (1), 0, addr (symbol_name) -> based_databit_string, code); if code ^= 0 then call crump (is_replay); if is_replay then call ioa_$nnl ("^a", symbol_name); else call ioa_$nnl ("^a is system macro ""^a""", element_arg.name, symbol_name); return; end; if ^is_replay then do; call ioa_$nnl ("^a is symbol ""^a""", element_arg.name, symbol_name); return; end; do i = 1 to n_found_symbols while (found_symbols.name (i) ^= symbol_name); end; if i <= n_found_symbols then do; /* already know this one */ call ioa_$nnl ("^a", symbol_name); return; end; cur_elements = 1; allocate local_tuple in (my_area); local_tuple.rvalue (1) = sub_value; local_tuple.name (1) = "???"; if level = 0 then paren = ""; else paren = "("; call ioa_$nnl ("^/^v-^vx^a^a = ", divide (indentation, 10, 17, 0), mod (indentation, 10), paren, symbol_name); if db_sw then call ioa_$nnl ("|SYMBOL RECURSION - ONE ELEMENT"); call replay_recur (local_tuple.element (*), level+1, is_replay); if level > 0 then call ioa_$nnl (")"); n_found_symbols = n_found_symbols + 1; if n_found_symbols > cur_max_found_symbols then do; old_p = fs_ptr; max_found_symbols = cur_max_found_symbols + 50; allocate found_symbols in (my_area); do i = 1 to old_p -> n_found_symbols - 1; fs_ptr -> found_symbols.name (i) = old_p -> found_symbols.name (i); end; fs_ptr -> n_found_symbols = old_p -> n_found_symbols; free old_p -> found_symbols in (my_area); end; found_symbols.name (n_found_symbols) = symbol_name; free local_tuple in (my_area); return; describe_type (25): /* text */ call graphic_manipulator_$examine_text (element_arg.rvalue, alignment, n_chars, string, code); if code ^= 0 then call crump (is_replay); if is_replay then do; /* double all the quotes */ do i = 1 by 1 while (i <= n_chars); if substr (string, i, 1) = """" then do; string = substr (string, 1, i) || """" || substr (string, i+1); i = i + 1; n_chars = n_chars + 1; end; end; call ioa_$nnl ("text ""^a"" ^a", substr (string, 1, n_chars), Text_alignments (alignment)); end; else call ioa_$nnl ("^a is text ""^a"" ^a", element_arg.name, substr (string, 1, n_chars), Text_alignments (alignment)); return; describe_type (26): /* datablock */ dcl data_string char (200) varying, based_macro_bits bit (macro_bits_l) based (macro_bits_p), macro_bits_p pointer, macro_bits_l fixed bin; macro_bits_p = addr (data_string); macro_bits_l = size (data_string) * 36; call graphic_manipulator_$examine_data (element_arg.rvalue, 0, based_macro_bits, code); if code ^= 0 then call crump (is_replay); if (length (data_string) > (size (data_string) - 1) * 4 | length (data_string) < 0) then /* not a good varying string */ data_string = "!uninterpretable!"; /* datablock probably created by some other program */ if is_replay then do; /* double all the quotes */ do i = 1 by 1 while (i <= length (data_string)); if substr (data_string, i, 1) = """" then do; data_string = substr (data_string, 1, i) || """" || substr (data_string, i+1); i = i + 1; end; end; call ioa_$nnl ("^a ""^a""", Element_names (element_arg.type), data_string); end; else call ioa_$nnl ("^a is ^a ""^a""", element_arg.name, Element_names (element_arg.type), data_string); return; describe_type (32): describe_type (33): /* list & array */ call graphic_manipulator_$examine_list (element_arg.rvalue, array, array_len, code); if code ^= 0 then call crump (is_replay); if ^is_replay then do; if array_len > 0 then plural = "s"; else plural = ""; if element_arg.type = Array then article = "an"; else article = "a"; call ioa_$nnl ("^a is ^a ^a of ^d element^a", element_arg.name, article, Element_names (element_arg.type), array_len, plural); return; end; cur_elements = array_len; allocate local_tuple in (my_area); do i = 1 to array_len; local_tuple.rvalue (i) = array (i); end; local_tuple.name (*) = "???"; new_indentation = indentation + number_spaces - 1; call ioa_$nnl ("^a^/^v-^vx(", Element_names (element_arg.type), divide (new_indentation, 10, 17, 0), mod (new_indentation, 10)); if db_sw then call ioa_$nnl ("|ARRAY RECURSION - ^d ELEMENTS", local_tuple.n_elements); call replay_recur (local_tuple.element (*), level + 1, is_replay); call ioa_$nnl (")"); free local_tuple in (my_area); return; end replay_element; end replay_recur; crump: proc (is_replay); dcl is_replay bit (1) aligned parameter; if code = 0 then code = -1; if is_replay then environment.error_message = "While replaying."; else environment.error_message = "While showing."; goto returner; end; returner: return; replay_macro: entry (environment_ptr, code); call macro_common ("1"b); call ioa_ (""); return; show_macro: entry (environment_ptr, code); call macro_common (""b); call ioa_ (""); return; /* ------------------------- */ macro_common: proc (is_replay); dcl is_replay bit (1) aligned parameter; %include ge_token_types; dcl ge_parse_$get_token ext entry (char (*) varying, fixed bin, fixed bin), ge_parse_$backup ext entry; dcl token char (32) varying, token_type fixed bin; dcl com_err_$suppress_name ext entry options (variable); dcl size builtin; dcl array (21) fixed bin (18), array_len fixed bin; dcl (ioa_, ioa_$nnl) ext entry options (variable); %include ge_macro_info; dcl temp_node fixed bin (18); call initialize_ptrs; call ge_parse_$get_token (token, token_type, stack.level); if token = ";" then call generate_error ("No arguments to macro replay/show.", ""); do while ("1"b); if token_type ^= Name then call generate_error ("Misplaced ""^a"".", token); do i = 1 to n_macros while (macro.name (i) ^= token); end; if i > n_macros then call com_err_$suppress_name (0, "ge_interpret_", "^/Macro ""^a"" not found.", token); else do; call graphic_manipulator_$examine_symbol (macro.node_value (i), temp_node, 0, "", code); if code ^= 0 then call crump (is_replay); call graphic_manipulator_$examine_list (temp_node, array, array_len, code); if code ^= 0 then call crump (is_replay); n_macro_args = array_len - 1; allocate macro_info in (my_area) set (macro_info_p); macro_bits_l = size (based_macro_arg) * 36; do i = 1 to n_macro_args; macro_bits_p = addr (macro_info_p -> macro_info.argument (i)); call graphic_manipulator_$examine_data (array (i), 0, based_macro_bits, code); if code ^= 0 then call crump (is_replay); end; macro_bits_p = addr (macro_def); macro_bits_l = size (macro_def) * 36; call graphic_manipulator_$examine_data (array (array_len), 0, based_macro_bits, code); if code ^= 0 then call crump (is_replay); if is_replay then do; call ioa_$nnl ("^/macro ^a", token); do i = 1 to array_len- 1; call ioa_$nnl (" ^a", macro_info_p -> macro_info.argument (i)); end; call ioa_ (" = ^a;", macro_def); end; else do; if array_len = 2 then plural = ""; else plural = "s"; call ioa_ ("^a is macro of ^d argument^a:", token, array_len - 1, plural); do i = 1 to array_len - 1; call ioa_ ("Arg ^d: ^a", i, macro_info_p -> macro_info.argument (i)); end; call ioa_ ("Definition: ^a;", macro_def); end; free macro_info_p -> macro_info in (my_area); end; call ge_parse_$get_token (token, token_type, stack.level); if token = ";" then return; end; end macro_common; generate_error: proc (string, offender); dcl string char (*) parameter, offender char (*) varying parameter; dcl ioa_$rsnnl ext entry options (variable); if code = 0 then code = -1; call ioa_$rsnnl (string, environment.error_message, 0, offender); goto returner; end generate_error; %include gm_entry_dcls; %include graphic_etypes; %include graphic_enames; flip: entry; db_sw = ^db_sw; return; end;  ge_parse_.pl1 11/18/82 1708.6rew 11/18/82 1626.8 145737 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ge_parse_: proc; /* A parser for command lines to graphic_editor. Written 12/16/74 by C. D. Tavares. */ /* Modified 08/14/75 by CDT to be clever in a different way about fake_area; optimizer was generating insane "ic*" modifiers!! */ /* Modified 10/20/75 by CDT to make newlines not be read as semicolons if last character on input line was a comma. */ /* Last modified 05/25/76 by CDT to make macro replacements get pushed instead of returned, so one-to-many replacements would work (parenthesized macro args), and to correct problems with termination/non-termination of segments from which parse input strings are read. */ return; init: entry; dcl 1 in_use aligned static, 2 stringp pointer initial (null), /* pointer to string to be parsed */ 2 string_len fixed bin (21) initial (0), /* length of string to be parsed */ 2 cur_char fixed bin (21) initial (1), /* position at which to begin next parse */ 2 backup_sw bit (1) aligned initial (""b), /* return old token, not new one */ 2 spaces_found bit (1) aligned initial (""b), /* last character was a separator */ 2 already_got_rest bit (1) aligned initial (""b), /* can't get rest_of_line twice */ 2 terminate_when_done bit (1) aligned initial (""b), /* terminate (read) segment when done with it */ 2 info_ptr pointer initial (null), /* pointer to macro args initial (null), if any */ 2 previous_type fixed bin, /* type of previous token */ 2 previous_token char (200) varying initial (""); /* previous token itself */ dcl level fixed bin initial (0) static; dcl (Dont_terminate initial ("0"b), Do_terminate initial ("1"b)) bit (1) static options (constant); dcl 1 stack (0:20) static aligned, 2 stringp pointer, /* pointer to string to be parsed */ 2 string_len fixed bin (21), /* length of string to be parsed */ 2 cur_char fixed bin (21), /* position at which to begin next parse */ 2 backup_sw bit (1) aligned, /* return old token, not new one */ 2 spaces_found bit (1) aligned, /* last character was a separator */ 2 already_got_rest bit (1) aligned, /* can't get rest_of_line twice */ 2 terminate_when_done bit (1) aligned, /* terminate (read) segment when done with it */ 2 info_ptr pointer, /* pointer to macro args initial (null), if any */ 2 previous_type fixed bin, /* type of previous token */ 2 previous_token char (200) varying; /* previous token itself */ do level = 0 to 20; /* initialize the array stack (0:20) */ stack (level) = in_use; end; level = 0; /*do housekeeping and set back to 0*/ do level = level to 1 by -1; /* terminate leftover pointers if any */ if stack (level).terminate_when_done then call hcs_$terminate_noname (stack (level).stringp, code); else if stack (level).info_ptr ^= null then free stack (level).info_ptr -> macro_info in (fake_area); end; in_use.stringp = null; in_use.string_len = 0; in_use.cur_char = 1; in_use.backup_sw, in_use.already_got_rest = ""b; in_use.info_ptr = null; in_use.previous_token = ""; in_use.terminate_when_done = ""b; level = 0; return; push_string: entry (stringp_arg, string_len_arg); /* gives parser a string to parse */ dcl stringp_arg pointer parameter, string_len_arg fixed bin (21) parameter; call common_push (stringp_arg, string_len_arg, null, Dont_terminate); common_push: proc (stringp_arg, string_len_arg, info_ptr, terminate_switch); dcl stringp_arg pointer parameter, string_len_arg fixed bin (21) parameter, info_ptr pointer parameter, terminate_switch bit (1) parameter; level = max (0, level); in_use.already_got_rest = ""b; stack (level) = in_use; level = level + 1; if level > hbound (stack, 1) then signal subscriptrange; in_use.stringp = stringp_arg; /* copy args into static */ in_use.string_len = string_len_arg; in_use.cur_char = 1; /* initialize other important variables */ in_use.info_ptr = info_ptr; in_use.already_got_rest, in_use.backup_sw = ""b; in_use.terminate_when_done = terminate_switch; stack (level) = in_use; return; end common_push; return; push_string_and_terminate: entry (stringp_arg, string_len_arg); call common_push (stringp_arg, string_len_arg, null, Do_terminate); return; push_macro: entry (stringp_arg, string_len_arg, info_ptr_arg); dcl info_ptr_arg pointer; %include ge_macro_info; dcl fake_area area based (fake_area_p), fake_area_p pointer; call common_push (stringp_arg, string_len_arg, info_ptr_arg, Dont_terminate); return; get_token: entry (token, type, ignore_nl); /* returns next token and type */ dcl token char (*) varying parameter, /* token to be returned */ type fixed bin parameter, /* type of returned token */ ignore_nl fixed bin parameter; %include ge_token_types; dcl (null, substr, index, search, verify) builtin; dcl subscriptrange condition; dcl NL char (1) static initial (" "); dcl (i, j) fixed bin (21); /* hack variables */ dcl octal_sw bit (1) aligned, ioa_$rsnnl ext entry options (variable), cv_oct_ ext entry (char (*)) returns (fixed bin); dcl junk float bin, code fixed bin (35); dcl com_err_ ext entry options (variable), cv_float_ ext entry (char (*), fixed bin (35)) returns (float bin), ioa_ ext entry options (variable); dcl based_string char (1044480) based (in_use.stringp), /* two templates for overlaying token */ based_string_array (1044480) char (1) unaligned based (in_use.stringp); dcl terminators char (2) aligned static initial ("; "), /* semi and NL can terminate lines */ separator_table char (2) initial (" ") static, /* tab and space can separate tokens */ alphanumeric_table char (63) static initial /* these chars only may comprise single names */ ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_"), numeric_table char (11) static initial ("1234567890."); dcl iox_$get_line ext entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$user_input ext pointer, buffer char (200) aligned static, nelemt fixed bin (21); dcl hcs_$terminate_noname ext entry (pointer, fixed bin (35)); dcl temp_bit bit (1) aligned; dcl template_string char (template_len) based (template_ptr), /* more overlays */ template_ptr pointer, template_len fixed bin (21); if in_use.backup_sw then do; /* wants last token over again */ is_backup: token = in_use.previous_token; /* use previous token */ type = in_use.previous_type; in_use.backup_sw = ""b; return; end; in_use.backup_sw = ""b; /* kill indicator */ in_use.already_got_rest = ""b; if level = 0 then if in_use.stringp = null then do; /* no string ever been given */ read_another_line: buffer = ""; call iox_$get_line (iox_$user_input, addr (buffer), length (buffer), nelemt, code); if code ^= 0 then do; call com_err_ (code, "ge_parse_$get_token", "Attempting command read."); token = "***ERROR ON READ****"; return; end; in_use.cur_char = 1; in_use.stringp = addr (buffer); in_use.string_len = nelemt; level = 0; end; get_another_token: if in_use.cur_char > in_use.string_len then do; /* all done string */ pop_stack: if level = 0 then goto read_another_line; level = level - 1; in_use = stack (level); fake_area_p = null (); /* just so as not to generate a link */ /* to free_. Nobody really uses this anyway! */ if stack (level+1).info_ptr ^= null then free stack (level+1).info_ptr -> macro_info in (fake_area); /* keeps link to free_ from being generated */ else do; if stack (level+1).terminate_when_done then call hcs_$terminate_noname (stack (level+1).stringp, 0); if level = 0 then if in_use.cur_char >= in_use.string_len then call ioa_ ("Edit."); end; if in_use.backup_sw then goto is_backup; goto get_another_token; end; type = Name; /* assume next token will be name */ temp_bit = in_use.spaces_found; /* save this info */ call strip_blanks; /* otherwise leading blanks on new lines fail */ in_use.spaces_found = in_use.spaces_found | temp_bit; /* if spaces found after last or before this */ call setup_template; /* lay template over current position */ /* find next character which can not be part of a token. This is the next break character. */ /* set i to that char - 1, i.e. i = length of next good token. */ if in_use.spaces_found then do; /* Next token may be true float number */ if based_string_array (in_use.cur_char) = "." /* want to scan for numbers, but not a leading DP */ then j = 1; /* search for numbers from next char, not this one */ else j = 0; /* else try from first char */ if index ("1234567890", based_string_array (in_use.cur_char + j)) > 0 then do; /* got a number */ i = verify (template_string, numeric_table) - 1; /* search for end of it */ type = Number; /* for now, anyway */ end; end; if type = Name then i = verify (template_string, alphanumeric_table) - 1; /* assume we have non-number */ if i = -1 then i = template_len; /* rest of string */ else if i = 0 then do; /* first char was a break, return that char instead */ i = 1; type = Break; end; token = substr (based_string, in_use.cur_char, i); /* send it upstairs */ /* Of course, something made up of "+-." and digits may not be a true number! On the other hand, something which was not preceded by a space (which is a necessary condition for being a float number in GE) may by an integer numeric qualifier. So we prepare to see what the token REALLY is. */ if type = Break then code = 1; /* no chance! */ else junk = cv_float_ ((token), code); /* see what cv_float_ thinks of it */ if (code ^= 0 & type = Number) then type = Name; /* was illegally constructed for a number */ else if (code = 0 & type = Name) then type = Number; /* was really an integer */ if token = NL then if (ignore_nl ^= 0 | (in_use.previous_token = ",")) then do; in_use.cur_char = in_use.cur_char + 1; call strip_blanks; goto get_another_token; end; else token = ";"; if i = 1 then do; /* may be a special break char/sequence, check */ if based_string_array (in_use.cur_char) = ";" then if based_string_array (in_use.cur_char+1) = NL /* no reason to ever return the NL then */ then in_use.cur_char = in_use.cur_char + 1; /* skip NL */ else; /* nugatory */ else if based_string_array (in_use.cur_char) = """" then do; /* oh oh, quoted string */ type = Name; in_use.cur_char = in_use.cur_char + 1; /* prepare to search */ more_charstring: call setup_template; j = index (template_string, """"); /* find next occurrence of quote */ if j = 0 then j = template_len; /* no matching quote, use rest of string */ token = token || substr (template_string, 1, j); /* conc rest of found string */ in_use.cur_char = in_use.cur_char + j - 1; /* set to what's done, is bumped by 1 later */ if in_use.cur_char > in_use.string_len then goto exit_block; /* ran out of parsables */ if based_string_array (in_use.cur_char+1) = """" then do; /* oops, last quote was part of double quote */ in_use.cur_char = in_use.cur_char + 2; /* jump to next piece to be searched */ goto more_charstring; /* not concatenating, by the way, that other quote */ end; end; else if based_string_array (in_use.cur_char) = "/" then if based_string_array (in_use.cur_char+1) = "*" then do; /* is comment */ j = index (template_string, "*/"); /* find closing of comment */ if j = 0 then j = template_len - 1; /* no closing, use rest of string */ in_use.cur_char = in_use.cur_char + j + 2; goto get_another_token; /* ignore the comment */ end; else; else if based_string_array (in_use.cur_char) = "#" then do; type = Name; call setup_template; if based_string_array (in_use.cur_char+1) = "o" then do; octal_sw = "1"b; in_use.cur_char = in_use.cur_char + 1; end; else octal_sw = ""b; in_use.cur_char = in_use.cur_char + 1; call setup_template; if octal_sw then j = verify (template_string, "01234567") -1; else j = verify (template_string, "0123456789") - 1; if j = -1 then j = template_len; token = substr (based_string, in_use.cur_char, j); in_use.cur_char = in_use.cur_char + j - 1; /* will be bumped by 1 later */ if octal_sw then do; j = cv_oct_ ((token)); call ioa_$rsnnl ("^d", token, 0, j); end; token = "#" || token; end; exit_block: end; in_use.cur_char = in_use.cur_char + i; /* go to next char to be looked at */ call strip_blanks; strip_blanks: proc; call setup_template; /* prepare to search */ in_use.spaces_found = "1"b; i = verify (template_string, separator_table) - 1; /* skip all the blanks and tabs */ if i = -1 then i = template_len; if i > 0 then in_use.cur_char = in_use.cur_char + i; /* if there were any */ else if token = "-" | token = "+" then in_use.spaces_found = "1"b; else if token ^= ";" then in_use.spaces_found = ""b; end strip_blanks; in_use.previous_token = token; in_use.previous_type = type; if in_use.info_ptr = null then return; /* no macro substitution to do */ if type = Break then return; /* Macro substitution is done here. */ do i = 1 to in_use.info_ptr -> macro_info.n_args while (token ^= in_use.info_ptr -> macro_info.argument (i)); end; if i > in_use.info_ptr -> macro_info.n_args then return; /* no match */ call common_push (addr (addr (in_use.info_ptr -> macro_info.replacement (i)) -> based_varying_string.string), length (in_use.info_ptr -> macro_info.replacement (i)), null, Dont_terminate); /* we push it, because parenthesized macro args can contain more than one token */ in_use.spaces_found, stack (level).spaces_found = "1"b; /* in case next thing is a float number, we can't substitute for part of pathnames. */ goto get_another_token; backup: entry; /* to make us reuse last token */ in_use.backup_sw = "1"b; /* say we want to reuse previous token */ return; peek_rest_of_line: entry (token); /* lookahead entry */ dcl peek_entry bit (1) aligned initial (""b); peek_entry = "1"b; get_rest_of_line: entry (token); /* so spaces, tabs, etc. remain significant */ if in_use.stringp = null then do; /* no string set yet */ rest_null: token = ""; return; end; if in_use.cur_char > in_use.string_len then goto rest_null; if in_use.already_got_rest then goto rest_null; call setup_template; /* prepare to search */ i = search (template_string, terminators); /* find first NL or semi */ if i = 0 then i = 1; token = substr (based_string, in_use.cur_char, i-1); /* return string up to that point */ if peek_entry then return; in_use.already_got_rest = "1"b; in_use.backup_sw = ""b; in_use.cur_char = in_use.cur_char + i; call strip_blanks; return; flush_rest_of_line: entry; in_use.cur_char = in_use.string_len + 1; /* force EOF */ in_use.backup_sw = ""b; in_use.already_got_rest = ""b; return; setup_template: proc; /* to set up based search string */ template_len = in_use.string_len - in_use.cur_char + 1; /* length of entire string remaining */ template_len = max (template_len, 0); template_ptr = addr (based_string_array (in_use.cur_char)); /* pointer to unused portion of string */ return; end setup_template; end ge_parse_;  graphics_editor.pl1 03/28/83 1519.6rew 03/28/83 1359.1 355905 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ graphics_editor: graphic_editor: ge: proc; /* This procedure is an interactive editor which allows a user to construct, edit, modify, store, retrieve, and display graphic entities. Written about January 1975 by C. D. Tavares Modified 07/14/75 by CDT to make put and get behave better. Modified 08/08/75 by CDT to insert a return so that "remove" wouldn't run into "macro", to make explicit allocations into implicits, to add "replay -all". Modified 10/15/75 by CDT to add star processing to list command, make quit command check for anything else on command line, to presort commands and system symbols, and to make remove try to remove macros if it doesn't find a symbol of that name. Modified 06/25/76 by CDT to add system macros (circle, arc...) Modified 12/78 by CDT to add varying_text and vtext_type. Modified 08/20/79 by CDT to add "." request. Modified December 1982 by C. Hornig to add "increment" and "synchronize" requests. */ dcl fatal bit (1) aligned; /* if on, we will exit on any error */ dcl p pointer; /* Commands and system symbols should always be kept in alphabetical order in the following structures. This makes the job of the list command much easier. */ /* NOTE: The structuring of commands, system symbols, symbols, and macros are EXACTLY THE SAME as far as structuring of each element (1 or 2 varying strings interspersed with fixed bin). This correspondence should not be changed without the changer taking a hard look at list_proc (internam proc) which treats them all largely the same. */ dcl 1 command_list aligned static options (constant), 2 n_commands fixed bin initial (21), 2 each_command (21) aligned, 3 commands (2) char (32) varying initial ( /* index vector */ "alter", "al", /* 1 19 */ "display", "di", /* 2 1 */ "execute", "exec", /* 3 3 */ "get", "get", /* 4 10 */ "help", "?", /* 5 16 */ "increment", "inc", /* 6 20 */ "input", "input", /* 7 13 */ "list", "ls", /* 8 2 */ "macro", "macro", /* 9 7 */ "put", "put", /* 10 11 */ "quit", "q", /* 11 14 */ "read", "read", /* 12 12 */ "remove", "remove", /* 13 6 */ "replay", "replay", /* 14 5 */ "restart", "restart", /* 15 15 */ "save", "save", /* 16 9 */ "show", "show", /* 17 4 */ "synchronize", "sync", /* 18 21 */ "use", "use", /* 19 8 */ "vtext_type", "vtype", /* 20 17 */ ".", "."), /* 21 18 */ 3 command_vector fixed bin initial (19, 1, 3, 10, 16, 20, 13, 2, 7, 11, 14, 12, 6, 5, 15, 9, 4, 21, 8, 17, 18); dcl 1 system_symbol_list aligned static options (constant), 2 n_system_symbols fixed bin initial (17), 2 each_system_symbol (17) aligned, 3 system_symbols (2) char (32) varying initial ( /* index vector */ "array", "array", /* 1 8 */ "blink", "blk", /* 2 12 */ "color", "color", /* 3 17 */ "datablock", "data", /* 4 16 */ "intensity", "int", /* 5 10 */ "linetype", "lin", /* 6 11 */ "list", "list", /* 7 9 */ "null", "null", /* 8 6 */ "point", "pnt", /* 9 5 */ "rotation", "rot", /* 10 14 */ "scaling", "scl", /* 11 15 */ "sensitivity", "sns", /* 12 13 */ "setpoint", "spt", /* 13 2 */ "setposition", "sps", /* 14 1 */ "shift", "sft", /* 15 4 */ "text", "text", /* 16 7 */ "vector", "vec"), /* 17 3 */ 3 system_symbol_vector fixed bin initial (8, 12, 17, 16, 10, 11, 9, 6, 5, 14, 15, 13, 2, 1, 4, 7, 3); dcl 1 system_macro_list aligned static options (constant), 2 n_system_macros fixed bin initial (6), 2 each_system_macro (6) aligned, 3 system_macros (2) char (32) varying initial ( /* index vector */ "arc", "arc", /* 1 1 */ "box", "box", /* 2 2 */ "circle", "crc", /* 3 3 */ "ellipse", "ellipse", /* 4 4 */ "polygon", "polygon", /* 5 5 */ "varying_text", "vtext"), /* 6 6 */ 3 system_macro_vector fixed bin initial (1, 2, 3, 4, 5, 6); dcl char_count fixed bin (21), input_ptr pointer; dcl input_dir char (168), input_entry char (32), temp_string char (168), prog_dir char (168), prog_ent char (32), me_bc fixed bin (24), me_ptr pointer, library_description char (64), my_date_time char (24), mode fixed bin; dcl 1 search_libraries (2) static options (constant), 2 dir char (168) initial (">unbundled", ">exl>graphics_system"), 2 description char (64) initial ("Installed", "Experimental"); dcl (ioa_, com_err_, com_err_$suppress_name) ext entry options (variable); dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (35), fixed bin, pointer, fixed bin (35)), hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)), hcs_$terminate_noname ext entry (pointer, fixed bin (35)), hcs_$fs_get_path_name ext entry (pointer, char (*), fixed bin, char (*), fixed bin (35)), hcs_$status_mins ext entry (pointer, fixed bin, fixed bin (24), fixed bin (35)), hcs_$fs_get_mode ext entry (pointer, fixed bin, fixed bin (35)), date_time_ ext entry (fixed bin (71), char (*)), object_info_$display ext entry (pointer, fixed bin (24), pointer, fixed bin (35)); dcl error_table_$moderr ext fixed bin (35); dcl 1 definitive_environment aligned, 2 stack_p pointer, 2 command_p pointer, 2 system_symbol_p pointer, 2 system_macro_p pointer, 2 sym_p pointer, 2 mac_p pointer, 2 areap pointer, 2 at_ptr pointer, 2 error_message char (100) varying, 2 external_char_table aligned, 3 dirname char (168) unaligned, 3 ename char (32) unaligned, 2 default_char_table aligned like external_char_table, 2 cur_char_table aligned like external_char_table; dcl environment_ptr pointer; dcl (i, file_count) fixed bin, bc fixed bin (35); dcl (program_interrupt, cleanup) condition; dcl expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35)), expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl cu_$arg_count ext entry (fixed bin), cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)), ap pointer, al fixed bin, arg based (ap) char (al), code fixed bin (35); dcl get_temp_segment_ ext entry (char (*), pointer, fixed bin (35)), release_temp_segment_ ext entry (char (*), pointer, fixed bin (35)), get_pdir_ ext entry returns (char (168)), area_ ext entry (fixed bin (35), pointer); dcl token char (200) varying, /* active token from command line */ input_line char (200) varying, /* for peek_rest_of_line */ (addr, baseno, baseptr, before, codeptr, dim, hbound, index, length, null, search, size, substr, verify) builtin, (ge_parse_$push_string, ge_parse_$push_string_and_terminate) ext entry (pointer, fixed bin (21)), ge_parse_$init ext entry, ge_parse_$get_rest_of_line ext entry (char (*) varying), ge_parse_$peek_rest_of_line ext entry (char (*) varying), ge_parse_$get_token ext entry (char (*) varying, fixed bin, fixed bin), type fixed bin, ge_parse_$backup ext entry; dcl default_pgs_dir char (168) initial (""), default_pgs_entry char (32) initial (""); %include ge_data_structures; %include ge_token_types; %include gch_entry_dcls; %include object_info; dcl 1 oi like object_info aligned automatic; fatal = "1"b; /* any errors now, we will exit */ call get_temp_segment_ ("graphics_editor", areap, code); if areap = null then call crump (code, "While creating temp seg."); call area_ (261120, areap); call ge_parse_$init; call cu_$arg_count (file_count); /* get number of input files to parse */ if file_count > 0 then do i = file_count to 1 by -1; /* push the files */ call cu_$arg_ptr (i, ap, al, code); /* get arg */ call expand_pathname_$add_suffix (arg, "ge", input_dir, input_entry, code); /* make abs. pathname */ if code ^= 0 then call crump (code, arg); /* oops */ call hcs_$initiate_count (input_dir, input_entry, "", bc, 0, input_ptr, code); if input_ptr = null then call crump (code, "^a>^a"); char_count = bc / 9; call hcs_$fs_get_mode (input_ptr, mode, code); if code ^= 0 then call crump (code, "^a>^a"); if mode < 1000b then call crump (error_table_$moderr, "^a>^a"); call ge_parse_$push_string_and_terminate (input_ptr, char_count); end; else call ge_parse_$push_string (null, 0); /* force it to say "Edit." */ call graphic_manipulator_$init (code); if code ^= 0 then call crump (code, "Initializing working graphic segment."); call graphic_chars_$init; call graphic_chars_$get_table (external_char_table.dirname, external_char_table.ename); default_char_table = external_char_table; cur_char_table = external_char_table; environment_ptr = addr (definitive_environment); max_macros = 10; allocate macros in (my_area); max_symbols = 50; allocate symbols in (my_area); cur_elements = 4093; allocate assembly_tuple in (my_area); max_frames = 50; allocate stack in (my_area); stack.level = 0; system_symbol_p = addr (system_symbol_list); system_macro_p = addr (system_macro_list); command_p = addr (command_list); on program_interrupt begin; call ge_parse_$init; /* clean out pending file reads */ call ge_parse_$push_string (null, 0); /* Force it to say "Edit." */ goto listener_loop; end; on cleanup call cleanerup; fatal = ""b; listener_loop: do while ("1"b); /* forever */ do stack.level = stack.level to 1 by -1; free stack (level).tuple_ptr -> tuple in (my_area); end; code = 0; call comline_eval; /* evaluate command line */ end; returner: call cleanerup; return; cleanerup: proc; call release_temp_segment_ ("graphics_editor", areap, code); call graphic_chars_$set_table (external_char_table.dirname, external_char_table.ename, code); end cleanerup; comline_eval: proc; dcl (i, j) fixed bin; dcl ge_eval_$tuple_evaluator ext entry (pointer, fixed bin (35)), ge_interpret_$show ext entry (pointer, fixed bin (35)), ge_interpret_$replay ext entry (pointer, fixed bin (35)); call ge_parse_$get_token (token, type, stack.level); /* test to see if this is a command */ if token = ";" then return; do j = 2 to 1 by -1; /* short name more probable match */ do i = 1 to n_commands; if token = commands (i, j) then goto command_label (command_vector (i)); end; end; /* it is not a command; must be an assignment */ call ge_parse_$backup; call ge_parse_$peek_rest_of_line (input_line); if index (input_line, "=") = 0 then call crump (code, "Not a command."); call ge_eval_$tuple_evaluator (environment_ptr, code); if code ^= 0 then call complain; return; /* dispatch table for commands */ command_label (1): /* display */ call ge_eval_$tuple_evaluator (environment_ptr, code); if code ^= 0 then call complain; tuple_p = stack.tuple_ptr (1); do i = 1 to tuple.n_elements; if i = 1 then call graphic_compiler_$display (tuple.rvalue (1), code); else call graphic_compiler_$display_append (tuple.rvalue (i), code); if code ^= 0 then call crump (code, "While displaying."); end; return; command_label (2): /* list */ dcl (commands_bit, symbols_bit, system_symbols_bit, macros_bit, default_bit) bit (1) aligned; dcl arg_array (50) char (32), arg_matched (50) bit (1), arg_count fixed bin; dcl max_list_length fixed bin; dcl check_star_name_$entry ext entry (char (*), fixed bin (35)), match_star_name_ ext entry (char (*) aligned, char (*), fixed bin (35)); dcl k fixed bin; arg_count = 0; /* initialize random variables */ commands_bit, symbols_bit, macros_bit, system_symbols_bit = ""b; call ge_parse_$get_rest_of_line (input_line); /* parse the arguments as a big chunk */ do while (input_line ^= ""); /* knock off tokens using space and tab as only separators */ i = verify (input_line, " "); /* strip tabs and spaces */ if i > 0 then input_line = substr (input_line, i); i = search (input_line, " ;"); /* search for next tab, space, or semi */ if i > 0 then do; /* get one token */ token = substr (input_line, 1, i-1); input_line = substr (input_line, i+1); end; else do; /* rest of line is one token */ token = input_line; input_line = ""; end; if token = ";" then; /* ignore and loop again */ else if token = "-all" | token = "-a" then commands_bit, symbols_bit, macros_bit, system_symbols_bit = "1"b; else if token = "-symbols" | token = "-sym" then symbols_bit = "1"b; else if token = "-system" | token = "-sys" then system_symbols_bit = "1"b; else if token = "-commands" | token = "-com" then commands_bit = "1"b; else if token = "-macros" | token = "-mc" then macros_bit = "1"b; else if substr (token, 1, 1) = "-" /* some unknown option */ then call crump (0, "Bad option to list: " || token); /* if we are here, it is a "starname". */ else do; arg_count = arg_count + 1; if arg_count > hbound (arg_array, 1) then call crump (0, "Too many arguments to list command."); arg_array (arg_count) = token; call check_star_name_$entry (arg_array (arg_count), code); /* is star syntax ok? */ if code > 3 then call crump (code, arg_array (arg_count)); /* no */ end; end; default_bit = ^ (commands_bit | symbols_bit | system_symbols_bit | macros_bit); /* on IFF no options explicitly specified */ if arg_count = 0 then do; arg_array (1) = "**"; /* use default of "everything" */ arg_count = 1; end; if commands_bit then call list_proc ("command", addr (commands (1, 1)), dim (commands, 1), 2, ""b, ""b, ""b); if system_symbols_bit then do; call list_proc ("system symbol", addr (system_symbols (1, 1)), dim (system_symbols, 1), 2, ""b, ""b, ""b); call list_proc ("system macro", addr (system_macros (1, 1)), dim (system_macros, 1), 2, ""b, ""b, ""b); end; if (symbols_bit | default_bit) then call list_proc ("symbol", addr (symbol (1)), n_symbols, 1, "1"b, "1"b, "0"b); if (macros_bit | default_bit) then call list_proc ("macro", addr (macro (1)), n_macros, 1, "1"b, "1"b, default_bit); call ioa_ (""); return; list_proc: procedure (item_name, item_ptr, n_items, n_subitems, sort_necessary, print_pgs, ignore_nomatch); dcl (item_name char (*), item_ptr pointer, (n_items, n_subitems) fixed bin, (sort_necessary, print_pgs, ignore_nomatch) bit (1) aligned) parameter; dcl 1 based_item aligned based (item_ptr), 2 xxx (n_items), 3 string (n_subitems) char (32) varying, 3 pad fixed bin; dcl suffix char (1); dcl based_chitem char (32) varying based, based_charray (2) char (32) varying based; dcl sort_items_$varying_char ext entry (pointer); dcl 1 sort_structure aligned, 2 useful_names fixed bin (24), 2 sort_ptrs (n_items) pointer unaligned; /* This list procedure acts in what looks like an inefficient way. It runs down the symbols to be listed and checks ALL the starnames against EACH ONE, continuing even after a match is found. This is done because we want to keep a record of which starnames have been satisfied and which haven't. This way, if a symbol satisfies more than one starname, both starnames earn brownie points for winning. */ useful_names = 0; /* to start out */ arg_matched = ""b; do i = 1 to n_items; /* search down table to match names */ found = ""b; do j = 1 to arg_count; /* match each name against ALL starnames */ do k = 1 to n_subitems; /* catches aliases of sys. symbs. and commands */ call match_star_name_ ((based_item.string (i, k)), arg_array (j), code); if code = 0 then do; /* it matched! */ arg_matched (j) = "1"b; /* give this starname an OK */ if ^found then do; /* add name to the list to be sorted */ found = "1"b; useful_names = useful_names + 1; sort_ptrs (useful_names) = addr (based_item.string (i, 1)); end; end; end; end; end; if useful_names = 0 /* nothing at all matched */ then if ^ignore_nomatch then call ioa_ ("^/No ^as selected.", item_name); else; /* do nothing; we were in default case, and looking for macros. */ else do; if useful_names = 1 then suffix = ""; else suffix = "s"; if print_pgs & (substr (default_pgs_dir, 1, 4) ^= "") then call ioa_ ("^/^d ^a^a in ^a.pgs:^/", useful_names, item_name, suffix, before (default_pgs_entry, ".pgs")); else call ioa_ ("^/^d ^a^a:^/", useful_names, item_name, suffix); if sort_necessary /* if not presorted list */ then call sort_items_$varying_char (addr (sort_structure)); found = ""b; do j = 1 to arg_count; /* print out starnames that didn't match anything */ if ^arg_matched (j) then do; call com_err_$suppress_name (0, "graphics_editor", "(^a not found)", arg_array (j)); found = "1"b; end; end; if found then call com_err_$suppress_name (0, "graphics_editor", " "); /* only way to get a blank line out of it! */ do i = 1 to useful_names; /* list them */ if n_subitems = 2 then do; if sort_ptrs (i) -> based_charray (1) ^= sort_ptrs (i) -> based_charray (2) then call ioa_ ("^5x^14a (^a)", sort_ptrs (i) -> based_charray (1), sort_ptrs (i) -> based_charray (2)); else call ioa_ ("^5x^14a", sort_ptrs (i) -> based_charray (1)); end; else call ioa_ ("^5x^a", sort_ptrs (i) -> based_chitem); end; end; return; end list_proc; command_label (3): /* exec */ dcl cu_$cp ext entry (pointer, fixed bin, fixed bin), varying_command_line char (132) varying; call ge_parse_$get_rest_of_line (varying_command_line); begin; dcl command_line char (length (varying_command_line)) aligned; command_line = varying_command_line; call cu_$cp (addr (command_line), length (varying_command_line), 0); end; call ge_parse_$push_string (null, 0); /* get an "Edit" to appear when all done */ return; command_label (4): /* show */ call ge_eval_$tuple_evaluator (environment_ptr, code); if code ^= 0 then call complain; call ge_interpret_$show (environment_ptr, code); if code ^= 0 then call complain; return; command_label (5): /* replay */ call ge_parse_$peek_rest_of_line (input_line); if input_line = "-all" | input_line = "-a" /* dump ALL symbols */ then begin; dcl v_all_names varying char (n_symbols * 34 + 2); dcl all_names char (n_symbols * 34 + 2); call ge_parse_$get_rest_of_line (""); /* flush it without flushing EVERYTHING */ v_all_names = ""; do i = 1 to n_symbols; v_all_names = v_all_names || symbols.name (i) || ", "; /* build line */ end; if length (v_all_names) = 0 then call crump (0, "No defined symbols exist."); else all_names = substr (v_all_names, 1, length (v_all_names) - 2) || ";"; call ge_parse_$push_string (addr (all_names), length (all_names)); call ge_eval_$tuple_evaluator (environment_ptr, code); /* This done inside block so that storage for the */ /* just-pushed string is still valid during evaluation */ end; else call ge_eval_$tuple_evaluator (environment_ptr, code); if code ^= 0 then call complain; call ge_interpret_$replay (environment_ptr, code); if code ^= 0 then call complain; return; command_label (6): /* remove */ dcl found bit (1) aligned; found = ""b; call ge_parse_$get_token (token, type, stack.level); if token = ";" then call crump (0, "No arguments to remove."); do while (token ^= ";"); found = ""b; do i = 1 to n_symbols while (^found); if symbol (i).name = token then do; do j = i to n_symbols - 1; symbol (j) = symbol (j+1); end; n_symbols = n_symbols - 1; call graphic_manipulator_$remove_symbol ((token), code); if code ^= 0 then call com_err_$suppress_name (code, "graphics_editor", token); found = "1"b; end; end; if ^found then do i = 1 to n_macros while (^found); if macro (i).name = token then do; do j = i to n_macros - 1; macro (j) = macro (j+1); end; n_macros = n_macros - 1; call graphic_manipulator_$remove_symbol ("!macro_" || token, code); if code ^= 0 then call com_err_$suppress_name (code, "graphics_editor", token); found = "1"b; end; end; if ^found then call com_err_$suppress_name (0, "graphics_editor", """^a"" not found.", token); call ge_parse_$get_token (token, type, stack.level); end; return; command_label (7): /* macro */ dcl macro_name char (32), arg_node (21) fixed bin (18), macro_node fixed bin (18), macro_arg (20) char (32) varying; dcl temp_p pointer; dcl (ge_interpret_$show_macro, ge_interpret_$replay_macro) ext entry (pointer, fixed bin (35)); %include ge_macro_info; call ge_parse_$get_token (token, type, stack.level); if token = "show" then do; call ge_interpret_$show_macro (environment_ptr, code); if code ^= 0 then call complain; return; end; if token = "replay" then do; call ge_interpret_$replay_macro (environment_ptr, code); if code ^= 0 then call complain; return; end; /* If we are here, this is a macro assignment. */ do i = 1 to n_system_symbols while (token ^= system_symbols (i, 1) & token ^= system_symbols (i, 2)); end; if i <= n_system_symbols then call crump (0, token || " is a system symbol."); do i = 1 to n_system_macros while (token ^= system_macros (i, 1) & token ^= system_macros (i, 2)); end; if i <= n_system_macros then call crump (0, token || " is a system macro."); do i = 1 to n_symbols while (token ^= symbol.name (i)); end; if i <= n_symbols then call crump (0, token || " has been previously defined as a symbol."); macro_name = token; call ge_parse_$get_token (token, type, stack.level); do i = 1 to 20 while (type = Name); macro_arg (i) = token; call ge_parse_$get_token (token, type, stack.level); end; if i > 20 then call crump (0, "Too many args to macro " || macro_name); if token ^= "=" then call crump (0, token || " encountered instead of ""="" in macro " || macro_name); n_macro_args = i - 1; macro_bits_l = size (macro_arg (1)) * 36; do i = 1 to n_macro_args; macro_bits_p = addr (macro_arg (i)); arg_node (i) = graphic_manipulator_$create_data (macro_bits_l, based_macro_bits, code); if code ^= 0 then internal_macro_error: call crump (code, "While assembling macro."); end; call ge_parse_$get_rest_of_line (macro_def); macro_bits_p = addr (macro_def); macro_bits_l = size (macro_def) * 36; arg_node (i) = graphic_manipulator_$create_data (macro_bits_l, based_macro_bits, code); if code ^= 0 then goto internal_macro_error; do i = 1 to n_macros while (macro.name (i) ^= macro_name); end; if i > n_macros then n_macros = i; if n_macros > cur_max_macros then do; max_macros = cur_max_macros + 30; temp_p = mac_p; allocate macros in (my_area); do j = 1 to temp_p -> n_macros - 1; mac_p -> macros.macro (j) = temp_p -> macros.macro (j); end; mac_p -> n_macros = temp_p -> n_macros; free temp_p -> macros in (my_area); end; macro.name (i) = macro_name; macro_name = "!macro_" || macro_name; macro_node = graphic_manipulator_$create_array (arg_node, n_macro_args + 1, code); if code ^= 0 then goto internal_macro_error; macro.node_value (i) = graphic_manipulator_$assign_name (macro_name, macro_node, code); if code ^= 0 then goto internal_macro_error; return; command_label (8): /* use */ dcl node_array (1000) fixed bin (18), varying_pathname char (168) varying; call get_save_use_path ("use."); /* ---------------------------------- */ get_save_use_path: proc (myname); dcl myname char (*); call ge_parse_$get_rest_of_line (varying_pathname); temp_string = varying_pathname; if temp_string = "" then if default_pgs_dir = "" then call crump (0, "No file name supplied for " || myname); else return; /* use defaults we already have */ call expand_pathname_ (temp_string, default_pgs_dir, default_pgs_entry, code); if code ^= 0 then do; default_pgs_dir, default_pgs_entry = ""; call crump (code, temp_string); end; return; end get_save_use_path; /* ---------------------------------- */ call graphic_manipulator_$use_file (default_pgs_dir, default_pgs_entry, code); if code ^= 0 then do; default_pgs_dir, default_pgs_entry = ""; call crump (code, "Attempting to use PGS."); end; n_symbols = 0; call pick_up_symbols; /* ---------------------------------- */ pick_up_symbols: proc; dcl (i, j, k) fixed bin; call graphic_manipulator_$examine_symtab (node_array, i, code); if code ^= 0 then call crump (code, "Examining symbol table"); if i + 30 > cur_max_symbols then do; free sym_p -> symbols in (my_area); max_symbols = i + 50; allocate symbols in (my_area); end; if i + 20 > cur_max_macros then do; free mac_p -> macros in (my_area); max_macros = i + 30; allocate macros in (my_area); end; n_symbols, n_macros = 0; do k = 1 to i; call graphic_manipulator_$examine_symbol (node_array (k), 0, j, temp_string, code); if code ^= 0 then call crump (code, "While examining some symbol"); if substr (temp_string, 1, 7) = "!macro_" then do; n_macros = n_macros + 1; macro (n_macros).name = substr (temp_string, 8, j-7); macro (n_macros).node_value = node_array (k); end; else if substr (temp_string, 1, 10) = "!sysmacro." then; /* do nothing, system macro */ else do; n_symbols = n_symbols + 1; symbols.node_value (n_symbols) = node_array (k); symbols.name (n_symbols) = substr (temp_string, 1, j); end; end; end pick_up_symbols; /* ---------------------------------- */ return; command_label (9): /* save */ call get_save_use_path ("save."); call graphic_manipulator_$save_file (default_pgs_dir, default_pgs_entry, code); if code ^= 0 then do; default_pgs_dir, default_pgs_entry = ""; call crump (code, "Saving into PGS."); end; return; command_label (10): /* get */ dcl merge_code fixed bin, error_table_$noentry ext fixed bin (35); dcl put_and_get_dirname char (168), put_and_get_entryname char (32); call parse_get_put_options ("get."); /* ---------------------------------- */ parse_get_put_options: proc (myname); dcl varying_pname char (168) varying, error_table_$badopt ext fixed bin (35), myname char (*) parameter; merge_code = On_dup_error; put_and_get_dirname = default_pgs_dir; /* set up put/get PGS defaults */ put_and_get_entryname = default_pgs_entry; do i = 1 to 2; call ge_parse_$get_token (token, type, stack.level); if token = "-" then do; /* is an option */ call ge_parse_$get_token (token, type, stack.level); if token = "safe" then merge_code = On_dup_error; else if token = "force" then merge_code = On_dup_source; else if token = "replace_only" then merge_code = On_dup_target_then_nulls; else if token = "rpo" then merge_code = On_dup_target_then_nulls; else if token = "replace_all" then merge_code = On_dup_target_then_source; else if token = "rpa" then merge_code = On_dup_target_then_source; else call crump (error_table_$badopt, "-" || token); end; else if substr (token, 1, 1) = "(" then do; /* is a pathname */ varying_pname = ""; call ge_parse_$get_token (token, type, stack.level); do while (token ^= ")"); varying_pname = varying_pname || token; call ge_parse_$get_token (token, type, stack.level); end; call expand_pathname_ (substr (varying_pname, 1), put_and_get_dirname, put_and_get_entryname, code); if code ^= 0 then call crump (code, (varying_pname)); end; else do; call ge_parse_$backup; /* must have been a symbol */ i = 3; /* kill looping */ end; end; return; end parse_get_put_options; /* ---------------------------------- */ call ge_parse_$get_token (token, type, stack.level); if token = ";" then call crump (0, "No symbols to get."); do while (token ^= ";"); found = ""b; do i = 1 to 2 while (^found); /* try symbol first, then as macro */ call graphic_manipulator_$get_struc (put_and_get_dirname, put_and_get_entryname, (token), merge_code, code); if code = 0 then found = "1"b; /* found symbol */ else if code = error_table_$noentry then call crump (code, "Segment " || put_and_get_entryname); else if code = graphic_error_table_$lsm_sym_search then token = "!macro_" || token; /* add the macro prefix, try again */ else call crump (code, "Getting symbol """ || token || """."); end; if ^found then call com_err_$suppress_name (code, "graphics_editor", "Getting symbol ""^a"".", substr (token, 15)); call ge_parse_$get_token (token, type, stack.level); end; call pick_up_symbols; return; command_label (11): /* put */ dcl graphic_error_table_$lsm_sym_search fixed bin (35) external; call parse_get_put_options ("put."); call ge_parse_$get_token (token, type, stack.level); if token = ";" then call crump (0, "No symbols to put."); do while (token ^= ";"); found = ""b; do i = 1 to 2 while (^found); /* try symbol first, then as macro */ call graphic_manipulator_$put_struc (put_and_get_dirname, put_and_get_entryname, (token), merge_code, code); if code = 0 then found = "1"b; else if code = graphic_error_table_$lsm_sym_search then token = "!macro_" || token; /* Add the macro prefix, try again */ else call crump (code, "Putting symbol """ || token || """."); end; if ^found then call com_err_$suppress_name (code, "graphics_editor", "Putting symbol ""^a"".", substr (token, 15)); call ge_parse_$get_token (token, type, stack.level); end; return; command_label (13): /* input */ dcl device_type fixed bin, input_node fixed bin (18); device_type = Any_device; call ge_parse_$get_token (token, type, stack.level); if token = ";" then call crump (0, "No arguments to input."); do while (token ^= ";"); if token = "(" then do; /* parse device name */ call ge_parse_$get_token (token, type, stack.level); if type ^= Name then not_an_input_device: call crump (0, "Not an input device name: " || token); if token = "undefined" /* joker */ then goto not_an_input_device; do device_type = 1 to 63 while (Input_device_names (device_type) ^= token); end; if device_type > 63 then goto not_an_input_device; call ge_parse_$get_token (token, type, stack.level); if token ^= ")" then call crump (0, "No "")"" before " || token); call ge_parse_$get_token (token, type, stack.level); end; else if type = Name then do while (type = Name); input_node = graphic_operator_$what (device_type, 0, code); if code ^= 0 then call com_err_$suppress_name (code, "graphics_editor", "Input for ^a", token); else do; input_node = graphic_manipulator_$assign_name ((token), (input_node), code); if code ^= 0 then call crump (code, "Internal error creating " || token); do i = 1 to n_symbols while (symbol (i).name ^= token); end; if i > n_symbols then n_symbols = i; if i > cur_max_symbols then do; temp_p = sym_p; /* prepare to extend symbol area */ max_symbols = cur_max_symbols + 50; allocate symbols in (my_area); do j = 1 to temp_p -> n_symbols; sym_p -> symbol (j) = temp_p -> symbol (j); end; sym_p -> n_symbols = temp_p -> n_symbols; free temp_p -> symbols in (my_area); end; symbol (i).name = token; symbol (i).node_value = input_node; end; call ge_parse_$get_token (token, type, stack.level); end; else call crump (0, "Misplaced token: " || token); end; return; command_label (12): /* read */ call ge_parse_$get_rest_of_line (varying_pathname); temp_string = varying_pathname; if temp_string = "" then call crump (0, "No file name supplied for read."); call expand_pathname_$add_suffix (temp_string, "ge", input_dir, input_entry, code); if code ^= 0 then call crump (code, temp_string); call hcs_$initiate_count (input_dir, input_entry, "", bc, 0, input_ptr, code); if input_ptr = null then call crump (code, "^a>^a"); char_count = bc / 9; call hcs_$fs_get_mode (input_ptr, mode, code); if code ^= 0 then call crump (code, "^a>^a"); if mode < 1000b then call crump (error_table_$moderr, "^a>^a"); call ge_parse_$push_string_and_terminate (input_ptr, char_count); return; command_label (14): /* quit */ call ge_parse_$get_token (token, type, stack.level); if token ^= ";" then call crump (0, "Text follows ""quit"" request; request ignored."); goto returner; command_label (15): /* restart */ call ge_parse_$init; /* clear out any old reads or input lines */ call ge_parse_$push_string (null, 0); /* force it to say "Edit." */ default_pgs_dir, default_pgs_entry = ""; n_macros, n_symbols = 0; call graphic_manipulator_$init (code); if code ^= 0 then call crump (code, "While re-initializing."); call graphic_chars_$init; call graphic_chars_$set_table (external_char_table.dirname, external_char_table.ename, code); if code ^= 0 then call crump (code, "Resetting the default graphic char table."); default_char_table = external_char_table; cur_char_table = external_char_table; return; command_label (16): /* help */ call ioa_ ("Available commands may be listed with ""list -commands"". Available graphic entities may be listed with ""list -all"". See the description of graphics_editor in the Graphic Reference Manual, or type ""exec help graphics_editor"".^/"); /* That's what the GRM is for. */ return; command_label (17): /* vtext_type */ call ge_parse_$get_rest_of_line (varying_pathname); temp_string = varying_pathname; if temp_string = "" then do; call ioa_ ("Current graphic character table is ^a.", default_char_table.ename); return; end; if search (temp_string, "<>") > 0 then do; call expand_pathname_ (temp_string, input_dir, input_entry, code); if code ^= 0 then call crump (code, temp_string); end; else do; input_dir = ""; input_entry = temp_string; end; call graphic_chars_$set_table (input_dir, input_entry, code); if code ^= 0 then call crump (code, input_entry); call graphic_chars_$get_table (cur_char_table.dirname, cur_char_table.ename); default_char_table = cur_char_table; return; command_label (18): /* "." */ me_ptr = baseptr (baseno (codeptr (command_label (18)))); /* get pointer to base of my own segment */ library_description = ""; do i = 1 to dim (search_libraries, 1) while (library_description = ""); call hcs_$initiate (search_libraries (i).dir, "graphics_editor", "", 0, 0, p, code); if p ^= null then do; if p = me_ptr then library_description = search_libraries.description (i); call hcs_$terminate_noname (p, 0); end; end; if library_description = "" then do; call hcs_$fs_get_path_name (me_ptr, prog_dir, 0, prog_ent, code); if code ^= 0 then call crump (code, "Determining pathname of this version of graphics_editor."); call ioa_ ("graphics_editor; ^a>^a (private version)", prog_dir, prog_ent); end; else do; oi.version_number = object_info_version_2; call hcs_$status_mins (me_ptr, 0, me_bc, code); if code = 0 then call object_info_$display (me_ptr, me_bc, addr (oi), code); if code ^= 0 then call crump (code, "Determining version of graphics_editor."); call date_time_ (oi.compile_time, my_date_time); call ioa_ ("graphics_editor; ^a version of ^a.", library_description, my_date_time); end; return; command_label(19): /* "alter" */ call crump (0, "alter not implemented."); command_label(20): /* "increment" */ begin; dcl inc_rv fixed bin (18); dcl inc_ct fixed bin; dcl incr_int float bin; call ge_parse_$get_token(token, type, stack.level); if type ^= Number then call crump(0, "Repetition count missing."); inc_ct = fixed(token); call ge_parse_$get_token(token, type, stack.level); if type ^= Number then call crump(0, "Repetition delay missing."); incr_int = float(token); call ge_eval_$tuple_evaluator(environment_ptr, code); if code ^= 0 then call complain; call graphic_operator_$increment(stack.tuple_ptr(1) -> tuple.rvalue(1), inc_ct, incr_int, stack.tuple_ptr(1) -> tuple.rvalue (2), code); if code ^= 0 then call crump(code, "While incrementing."); end; return; command_label(21): /* "synchronize" */ call graphic_operator_$synchronize(code); if code ^= 0 then call crump(code, "While synchronizing."); return; end comline_eval; crump: proc (err_code, reason); /* to bleep; perchance to scream. */ dcl err_code fixed bin (35), reason char (*); dcl ge_parse_$flush_rest_of_line ext entry; if fatal then do; call com_err_ (err_code, "graphics_editor", reason, input_dir, input_entry); goto returner; /* Wave bye-bye */ end; call ge_parse_$flush_rest_of_line; call com_err_$suppress_name (err_code, "graphics_editor", reason, input_dir, input_entry); goto listener_loop; /* try it all over again */ complain: entry; if code = -1 then code = 0; call com_err_$suppress_name (code, "graphics_editor", "^a", definitive_environment.error_message); call ge_parse_$flush_rest_of_line; goto listener_loop; end crump; %include gm_entry_dcls; %include gc_entry_dcls; %include go_entry_dcls; %include graphic_etypes; %include graphic_enames; end graphics_editor; 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