


		    PNOTICE_graphics.alm            04/07/83  0954.4r w 04/07/83  0954.4        2853


	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"W1GRFM0A2000"
	aci	"W2GRFM0A2000"
	aci	"W3GRFM0A2000"
	end
   



		    calcomp_compatible_subrs_.pl1   11/18/82  1706.7rew 11/18/82  1625.3      296109


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

calcomp_compatible_subrs_: ccs_: proc;

	return;

/* calcomp_compatible_subrs_ has the same entries and calling sequences as routines
   written by CalComp for other machines.  It uses the Multics Graphics System
   to perform much the same actions as the original calls performed. */
/* Note that we do our own scaling as opposed to having the graphic system
   do it for us.  The combination of a large screen_size_factor and a small
   user-supplied movement or height factor works, just as long as the user-supplied
   movement or height factor is not too small to be represented in
   6 fractional bits of precision, which is all Graphics Code allows.  Too many
   things were being pure lost due to this screen_size hackery. */
/* Written 10/24/74 by C. D. Tavares */
/* Modified 03/03/75 by CDT to use multilevel list strategy, for users with LONG calling patterns
   for creating BIG pictures. */
/* Modified 04/15/75 by CDT to fix undersized allocation, and make the allocation a call to
   cu_$grow_stack_frame instead. */
/* Modified 10/20/75 by CDT to rename calcomp_compatible_subrs_.pgs to ccs_special_symbols_.pgs */
/* Modified 04/12/77 by CDT to fix entrypoint symbol from "remembering" old symbol nodes without
   regard to whether the size was the same or not */
/* Modified 03/26/80 by CDT to fix bug whereby origin was not getting reset if
   the pen happened to already be there-- also changed com_err_ calls to sub_err_ */
/* Last modified 02/25/81 by Steve Carlock to use a "new" chaining method which */
/* eliminates the need to remember active modes from one sublist to another */
%page;
%include gm_entry_dcls;
%page;
%include gc_entry_dcls;
%page;
%include graphic_etypes;
%page;
plots:	entry;					/* initializes the world */

dcl 1 static_info aligned static,			/* current positions, scalings, etc. */
    2 cur_position (2) float bin initial (0, 0),
    2 cur_factors (2) float bin initial (1, 1),
    2 rel_positions (2) float bin initial (0, 0),
    2 cur_offsets (2) float bin initial (0, 0),
    2 cur_offs_factors (2) float bin initial (1, 1),
    2 cumulative_rels (2) float bin initial (0, 0),
    2 last_string_ended (2) float bin initial (0, 0),
    2 last_height float bin initial (1),
    2 screen_size_factor float bin initial (1),
    2 current_sublist fixed bin (18),
    2 display_list fixed bin (18),
    2 named_display_list fixed bin (18),
    2 initialized bit (1) aligned initial (""b);

dcl 1 based_static_info aligned based (addr (static_info)),
    2 (cur_x, cur_y) float bin,
    2 (x_factor, y_factor) float bin,
    2 (x_rel, y_rel) float bin,
    2 (x_offset, y_offset) float bin,
    2 (x_offs_factor, y_offs_factor) float bin,
    2 (cumulative_x_rel, cumulative_y_rel) float bin,
    2 (x_string_ended, y_string_ended) float bin;

dcl  pgs_ptr pointer,
     cur_color (3) fixed bin,
     first_time bit (1) aligned static initial ("1"b),
     hcs_$make_ptr ext entry (pointer, char (*), char (*), pointer, fixed bin (35)),
     hcs_$fs_get_path_name ext entry (pointer, char (*), fixed bin, char (*), fixed bin (35));

dcl  temp (100) fixed bin (18),			/* node temps */
     node_fake (1) fixed bin (18),
    (i, j) fixed bin,				/* temps */
     node fixed bin (18);

dcl  graphic_chars_$init ext entry;

	saved_special_symbols, cur_position, cur_offsets, last_string_ended,
	     saved_special_symbol_heights = 0;		/* initialize everything */
	cur_factors, cur_offs_factors, last_height = 1;
	cur_color (*) = 63;

	call graphic_manipulator_$init (code);		/* create/reinit WGS */
	if code ^= 0 then				/* oops */
init_err:	     call sub_err_ (code, "calcomp_compatible_subrs_$plots", "s", null, 0, "Initializing display list.");

	call graphic_chars_$init;			/* clear the char memory */

	node = graphic_manipulator_$create_position (Setposition, -512, -512, 0, code); /* initial origin */
	if code ^= 0 then goto init_err;

	node_fake = node;				/* %&$!#@! compiler simfaults on ((node)) in its place */
	current_sublist = graphic_manipulator_$create_array (node_fake, 1, code);
	if code ^= 0 then goto init_err;

	display_list = current_sublist;		/* the main honcho */

	named_display_list = graphic_manipulator_$assign_name ("ccs_display_list_", display_list, code);
						/* just to keep things clean */
	if code ^= 0 then goto init_err;

	initialized = "1"b;

	return;

%page;
plot:	entry (abs_x, abs_y, indicator);		/* draws a line at a time */

dcl  indicator fixed bin parameter,
    (abs_x, abs_y) float bin parameter;

dcl  switch fixed bin,
     sub_err_ ext entry options (variable),
     error_table_$badcall ext fixed bin (35),
     abs builtin,
     code fixed bin (35),
     movement fixed bin;

	call check_init;				/* have we been plotsed? */

%skip(5);

check_init: proc;					/* to check that calls occur in correct order */

	     if ^initialized then
		call sub_err_ (error_table_$out_of_sequence, "calcomp_compatible_subrs_", "s", null, 0,
		"A call to calcomp_compatible_subrs_$plots must be made before any further work is allowed.");

	end check_init;

%skip(5);

	call internal_plot (abs_x, abs_y, indicator, "calcomp_compatible_subrs_$plot"); /* pass buck */

%skip(5);

internal_plot: proc (abs_x, abs_y, indicator, whoami);

dcl (abs_x, abs_y) float bin,
     indicator fixed bin,
     whoami char (*);

dcl  rel_motion (2) float bin;

	     rel_motion (1) = abs_x - cur_x;
	     rel_motion (2) = abs_y - cur_y;

	     if indicator < 0 then cur_position = 0;	/* reset origin-- we never reference these */
	     else do;				/* after this point anyhow */
		cur_x = abs_x;			/* note we got where we were going */
		cur_y = abs_y;			/* this may throw us off if we DO get some error */
	     end;					/* later while creating or inserting the new element */

	     switch = abs (indicator);		/* switchon switch */

	     if switch > 30 then goto close_picture;

	     i = mod (switch, 10);			/* see what the magic digit is */

	     if i > 3 then goto indicator_out_of_bounds;
	     if i < 2 then goto indicator_out_of_bounds;

	     if rel_motion (1) = 0 then if rel_motion (2) = 0 then return; /* no-op */

	     goto plot_label (switch);

plot_label (2):
plot_label (22):
	     movement = Vector;
	     goto plot_common;

plot_label (3):
plot_label (23):
	     movement = Shift;
	     goto plot_common;

plot_label (12):
	     movement = Vector;
	     goto apply_offsets;

plot_label (13):
	     movement = Shift;
apply_offsets:
	     rel_motion = (rel_motion - cur_offsets) / cur_offs_factors;
plot_common:
	     node = graphic_manipulator_$create_position
		(movement, rel_motion (1) * screen_size_factor, rel_motion (2) * screen_size_factor, 0, code);
	     if code ^= 0 then do;			/* zounds. */
		call sub_err_ (code, whoami, "h", null, 0, "Creating ^[vector^;shift^].", (movement = Vector));
		goto error_return;
	     end;

	     call append_element (node, code);		/* tack it on */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Appending ^[vector^;shift^] to display list.", (movement = Vector));
		goto error_return;
	     end;

	     return;

indicator_out_of_bounds:				/* foo on you */
	     call sub_err_ (error_table_$badcall, whoami, "h", null, 0, "Indicator ^d not recognized.", indicator);
	     goto error_return;

close_picture:
	     call graphic_compiler_$display (named_display_list, code); /* push it out */
	     if code ^= 0 then do;			/* shucks */
		call sub_err_ (code, whoami, "h", null, 0, "Attempting to display and close completed picture.");
		goto error_return;
	     end;

	     initialized = ""b;			/* better call plots next thing */
	     return;

	end internal_plot;
%page;
append_element: proc (item, code);


dcl  item fixed bin (18),
     code fixed bin (35);

dcl  temp fixed bin (18);
dcl  fudge (2) fixed bin (18);

dcl  graphic_error_table_$lsm_blk_len ext fixed bin (35);

	     call graphic_manipulator_$add_element (current_sublist, -1, item, code);
	     if code ^= graphic_error_table_$lsm_blk_len then return; /* it worked or was error we can't fix. */

	     fudge (1) = 0;				/* save a spot for the last element on the current sublist */
	     fudge (2) = item;

	     temp = graphic_manipulator_$create_array (fudge, 2, code); /* create the "new" current sublist */

	     if code ^= 0 then return;

/* now chain the new list onto the end of the old list.  By doing things this
   way, we do not have to worry about copying active modes from list to list.
   */

	     fudge (1) = graphic_manipulator_$replace_element (current_sublist, -1, temp, code);

	     if (code ^= 0)
	     then return;

	     current_sublist = temp;			/* the new list is now the current list */

/* save the item we took out of the old list in the proper position in the new
   list */

	     temp = graphic_manipulator_$replace_element (current_sublist, 1, fudge (1), code);

	     return;				/* with whatever code resulted. */

	end append_element;

%skip(5);
error_return: return;
%page;
factor:	entry (scaling);				/* user's own scaling factor */

dcl  scaling float bin parameter;
dcl  whoami char (64);

	whoami = "calcomp_compatible_subrs_$factor";

	call check_init;

	cur_factors = scaling;			/* simple? */
	goto append_scales;

dfact:	entry (x_scaling, y_scaling);			/* to set two factors */

dcl (x_scaling,
     y_scaling) float bin parameter;

	whoami = "calcomp_compatible_subrs_$dfact";

	call check_init;

	x_factor = x_scaling;			/* also simple */
	y_factor = y_scaling;

append_scales:
	node = graphic_manipulator_$create_scale (x_factor, y_factor, 1, code); /* make scaling element */
	if code ^= 0 then do;
	     call sub_err_ (code, whoami, "h", null, 0, "Attempting to create scale factor.");
	     return;
	end;

	call append_element (node, code);		/* tack it on */
	if code ^= 0 then call sub_err_ (code, whoami, "h", null, 0, "Appending scale factor to display list.");

	return;

%page;
where:	entry (x_position, y_position, scaling);	/* to find out where we are, and scales */

dcl (x_position,
     y_position) float bin parameter;

	call check_init;

	x_position = cur_x;				/* simple. */
	y_position = cur_y;

	if x_factor = y_factor then scaling = x_factor;	/* this is the way it should be */

	else do;					/* poor loser. */
	     call sub_err_ (error_table_$badcall, "calcomp_compatible_subrs_$where", "h", null, 0,
		"Type ""start"" to return the larger scale factor."); /* whatever help it is. */
	     scaling = max (x_factor, y_factor);	/* they better not be negative. */
	end;

	return;
%skip(5);
dwhr:	entry (x_position, y_position, x_scaling, y_scaling);

	call check_init;

	x_position = cur_x;				/* as simple. */
	y_position = cur_y;
	x_scaling = x_factor;
	y_scaling = y_factor;
	return;
%page;
offset:	entry (x_zero, x_scaling, y_zero, y_scaling);	/* for arcane hackers */

dcl (x_zero,
     y_zero) float bin parameter;

	call check_init;

	x_offset = x_zero;
	y_offset = y_zero;				/* copy them all in */
	x_offs_factor = x_scaling;
	y_offs_factor = y_scaling;

	return;
%page;
wofst:	entry (x_zero, x_scaling, y_zero, y_scaling);	/* for absent-minded arcane hackers */

	call check_init;

	x_zero = x_offset;				/* copy them back out  */
	y_zero = y_offset;
	x_scaling = x_offs_factor;
	y_scaling = y_offs_factor;
	return;
%page;
newpen:	entry (color);				/* for color hackery */

dcl  color fixed bin parameter;

dcl  red_color fixed bin defined (cur_color (3));
dcl  green_color fixed bin defined (cur_color (2));
dcl  blue_color fixed bin defined (cur_color (1));

/* we assume pens are 1 = blue; 2 = green; 3 = red. */

	call check_init;

	if color < 1 then goto bad_color;
	if color > 3 then goto bad_color;

	cur_color (*) = 0;
	cur_color (color) = 63;			/* full intensity */

	node = graphic_manipulator_$create_color (red_color, green_color, blue_color, code);
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$newpen", "h", null, 0, "While creating color element.");
	     return;
	end;

	call append_element (node, code);		/* tack it on */
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$newpen", "h", null, 0, "While appending color element to display list.");
	     return;
	end;

	return;

bad_color: call sub_err_ (error_table_$badcall, "calcomp_compatible_subrs_$newpen", "h", null, 0,
	     "Pen number ^d unrecognized.", color);
	return;
%page;
set_dimension: entry (screen_size);			/* for immigrants */

dcl  screen_size float bin parameter;
dcl  error_table_$out_of_sequence ext fixed bin (35);

	screen_size_factor = 1024/screen_size;		/* that's it */
	return;
%skip(5);
symbol:	entry (abs_x, abs_y, height, string, angle, string_len); /* for strings and funnies */

dcl (height,
     angle) float bin parameter,
     string char (*) parameter,
     string_len fixed bin parameter;

dcl (x_string_ended_temp, y_string_ended_temp) float bin;

dcl  graphic_chars_$long_tb ext entry
    (char (*), fixed bin, float bin, float bin, float bin, float bin, fixed bin (35)) returns (fixed bin (18)),
     graphic_chars_ ext entry (char (*), fixed bin, float bin, float bin, fixed bin (35)) returns (fixed bin (18));

dcl  fixed_bin_based fixed bin based;

dcl (real_x, real_y, real_height) float bin;

dcl  symbol_name char (32),
     ioa_$rsnnl ext entry options (variable);

dcl  dirname char (168) static initial (""),
     ename char (32) static initial ("ccs_special_symbols_.pgs");

dcl  saved_special_symbols (2, 0:199) static fixed bin (18) initial ((400)0),
						/* first is scaled node, second is unscaled */
     saved_special_symbol_heights (0:199) static float bin initial ((200) 0e0);
						/* so we don't seek symbols more than once per invocation */

	call check_init;

	call internal_symbol (abs_x, abs_y, height, string, angle, string_len, "calcomp_compatible_subrs_$symbol");

	return;
%page;
internal_symbol: proc (abs_x, abs_y, height, string, angle, string_len, whoami);

dcl (abs_x, abs_y) float bin,
    (height, angle) float bin,
     string char (*),
     string_len fixed bin,
    (save_cur_x, save_cur_y) float bin,
     whoami char (*);

	     if abs_x = 999 then do;			/* wants it started where last left off */
		save_cur_x = cur_x;
		real_x = cur_x + x_string_ended;
	     end;
	     else do;				/* gave an explicit location */
		save_cur_x, real_x = abs_x;
		x_string_ended = 0;
	     end;

	     if abs_y = 999 then do;			/* check same cruft for y */
		save_cur_y = cur_y;
		real_y = cur_y + y_string_ended;
	     end;
	     else do;
		save_cur_y, real_y = abs_y;
		y_string_ended = 0;
	     end;

	     if string_len = -2 then call internal_plot (real_x, real_y, 2, whoami);
						/* wants to go there trailing ink */
	     else call internal_plot (real_x, real_y, 3, whoami); /* will go quietly, officer */

	     if height = 999 then real_height = last_height;
	     else real_height, last_height = height;

	     if string_len <= 0			/* isn't a string, it's a symbol number */
	     then call get_special_symbol (addr (string) -> fixed_bin_based, temp (2), real_height, whoami);

	     else do;				/* was really a string */
		temp (2) = graphic_chars_$long_tb (substr (string, 1, string_len), Lower_left,
		     real_height * screen_size_factor, real_height * screen_size_factor,
		     x_string_ended_temp, y_string_ended_temp, code); /* make it into vectors */
		if code ^= 0 then do;
		     call sub_err_ (code, whoami, "h", null, 0, "Creating vectors from ^a.", substr (string, 1, string_len));
		     goto error_return;
		end;

		x_string_ended_temp = x_string_ended_temp / screen_size_factor; /* un-scale our indicators */
		y_string_ended_temp = y_string_ended_temp / screen_size_factor;

		x_string_ended = x_string_ended + cosd (angle) * x_string_ended_temp /* do rotation */
		     - sind (angle) * y_string_ended_temp; /* to keep track of where */
		y_string_ended = y_string_ended + sind (angle) * x_string_ended_temp /* we left off */
		     + cosd (angle) * y_string_ended_temp; /* so we can go back */
	     end;

	     temp (1) = graphic_manipulator_$create_rotation (0, 0, angle, code); /* rotate it */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Creating angle element.");
		goto error_return;
	     end;

	     node = graphic_manipulator_$create_array (temp, 2, code); /* bind them together */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Creating array from angle and string.");
		goto error_return;
	     end;

	     call append_element (node, code);		/* tack it on */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Appending symbol element to display list.");
		goto error_return;
	     end;


	     if string_len > 0 then call internal_plot (save_cur_x, save_cur_y, 3, whoami); /* go back there */

	end internal_symbol;
%page;
get_special_symbol: proc (symbol_no, return_node, real_height, whoami); /* to get funnies */

dcl  symbol_no fixed bin parameter,
     return_node fixed bin (18) parameter,
     temp (2) fixed bin (18),
     real_height float bin,
     whoami char (*) parameter;

	     if first_time then do;			/* find the calcomp symbol PGS */

		call hcs_$make_ptr (null, (ename), "", pgs_ptr, code); /* use search rules */
		if pgs_ptr = null then do;		/* can't find one */
pgs_err:		     call sub_err_ (code, "calcomp_compatible_subrs_$plots", "h", null, 0,
			"Attempting to locate ^a.^/  Please notify the system maintenance staff.", ename); /* Horrors. */
		     goto error_return;
		end;

		call hcs_$fs_get_path_name (pgs_ptr, dirname, 0, "", code); /* find out dirname */
		if code ^= 0 then goto pgs_err;

		first_time = ""b;
	     end;

	     if symbol_no < lbound (saved_special_symbols, 2) then goto sym_unknown;
	     if symbol_no > hbound (saved_special_symbols, 2) then goto sym_unknown;

	     if saved_special_symbol_heights (symbol_no) = real_height then do;
		return_node = saved_special_symbols (1, symbol_no);
		return;
	     end;

	     if saved_special_symbol_heights (symbol_no) ^= 0 then /* already have sym, but not right size */
		temp (2) = saved_special_symbols (2, symbol_no);

	     else do;				/* don't have sym, must fetch */
sym_unknown:
		call ioa_$rsnnl ("calcomp_symbol_^d", symbol_name, 0, symbol_no); /* construct name */

		call graphic_manipulator_$get_struc (dirname, ename, symbol_name, 1, code); /* get from PGS */
		if code ^= 0 then do;
		     call sub_err_ (code, whoami, "c", null, 0, "^a not found; using ""*""", symbol_name); /* hm. */
		     return_node = graphic_chars_ ("*", Center, real_height * screen_size_factor,
			real_height * screen_size_factor, code);
		     if code ^= 0 then do;
			call sub_err_ (code, whoami, "h", null, 0, "Creating vectors from ""*""");
			goto error_return;
		     end;

		     return;

		end;

		temp (2) = graphic_manipulator_$find_structure (symbol_name, 0, code); /* get desired one */
		if code ^= 0 then do;
		     call sub_err_ (code, whoami, "h", null, 0, "Locating ^a in working graphic segment.", symbol_name);
		     goto error_return;		/* something's dead wrong. */
		end;
	     end;

	     temp (1) = graphic_manipulator_$create_scale (real_height * screen_size_factor / 10,
		real_height * screen_size_factor / 10,	/* calcomp symbols are 10 X 10 */
		1, code);				/* scale to desired size */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Creating height element.");
		goto error_return;
	     end;


	     return_node = graphic_manipulator_$create_array (temp, 2, code); /* bind them together */
	     if code ^= 0 then do;
		call sub_err_ (code, whoami, "h", null, 0, "Assembling ^a", symbol_name);
		goto error_return;
	     end;

	     if symbol_no >= lbound (saved_special_symbols, 2) then
		if symbol_no <= hbound (saved_special_symbols, 2) then do;
						/* remember this symbol even if previously known, because
						   perhaps size has changed.  We always remember LAST size, banking on user
						   not "thrashing" w.r.t. different sizes for same symbol */
		     saved_special_symbol_heights (symbol_no) = real_height;
		     saved_special_symbols (1, symbol_no) = return_node;
		     saved_special_symbols (2, symbol_no) = temp (2);
		end;

	     return;

	end get_special_symbol;
%page;
number:	entry (abs_x, abs_y, height, float_num, angle, precision); /* like symbol, for float numbers */

dcl  float_num float bin parameter,
     precision fixed bin parameter;

dcl  char_number char (24),
     char_len fixed bin,
     fixed_num fixed bin;

	if precision < 0 then do;
	     if float_num > 0 then fixed_num = (float_num * 1010b ** (precision+1)) + .5e0; /* round it */
	     else fixed_num = (float_num * 1010b ** (precision+1)) - .5e0;

	     call ioa_$rsnnl ("^d", char_number, char_len, fixed_num); /* put it out as integer */
	end;

	else call ioa_$rsnnl ("^.vf", char_number, char_len, precision, float_num);
						/* ioa_ rounds these. Cute. */

	call internal_symbol (abs_x, abs_y, height, char_number, angle, char_len, "calcomp_compatible_subrs_$number");
	return;					/* not much to it */
%page;
scale:	entry (array, axis_len, n_points, step_size);	/* Picks nice scale factors for data arrays */

dcl  array float bin dimension (*) parameter,
     axis_len float bin parameter,
     n_points fixed bin parameter,
     step_size fixed bin parameter;

dcl  default_screen_size_factor static float bin initial (1);

dcl (minel, maxel) float bin,
     spread float bin,
     logno float bin,
     exponent fixed bin,
     n_tics fixed bin,
     nondimensional float bin,
    (min,
     max,
     addr,
     binary,
     fixed,
     log10,
     sign,
     cosd,
     sind,
     substr) builtin,
     compensation float bin,
     steps fixed bin,
     raw_dv float bin,
    (delta_value, first_value) float bin;

	call check_init;

/* Special hack: The original axis entry wants to plot one tic mark per inch.  Inches really
   mean nothing to us here, and inches may be equivalent to points if we are running in native mode.
   So we check for native mode and enforce our own standard; 1 inch = 100 points.  If we are not in native mode,
   then we assume the guy knows what he wants. */

	if screen_size_factor = default_screen_size_factor then n_tics = axis_len / 100; /* Ours */
	else n_tics = axis_len;			/* Theirs */

	minel, maxel = array (1);			/* have to start somewhere */

	steps = abs (step_size);			/* compute length of tread */

	do i = steps + 1 by steps to (steps * (n_points - 1)) + 1; /* clomp up array */
	     minel = min (minel, array (i));
	     maxel = max (maxel, array (i));
	end;

	spread = maxel - minel;
	if spread = 0 then if minel = 0 then do;	/* clever. all zeroes. */
		minel = -1e-2;			/* fudge */
		maxel = 1e-2;
		spread = maxel - minel;
	     end;

	     else do;				/* all constants */
		minel = .9e0 * minel;		/* center on constants */
		maxel = 1.11e0 * maxel;
		spread = maxel - minel;
	     end;

	logno = log10 (spread / n_tics);		/* normalize number */
	exponent = binary (logno);
	raw_dv = binary (10) ** exponent;

	nondimensional = (spread / n_tics) / raw_dv;

	if nondimensional < 1.1e0 then delta_value = raw_dv; /* The following cute values are CalComp defined. */

	else if nondimensional <= 2 then delta_value = 2 * raw_dv;

	else if nondimensional <= 4 then delta_value = 4 * raw_dv;

	else if nondimensional <= 5 then delta_value = 5 * raw_dv;

	else if nondimensional <= 8 then delta_value = 8 * raw_dv;

	else delta_value = raw_dv * binary (10);

	if step_size > 0 then do;			/* first = min, delta = positive */
	     if minel < 0 then compensation = -.9999999;
	     else compensation = 0;
	     first_value = fixed (binary (minel / delta_value) + compensation) * delta_value;
	end;

	else do;					/* first = max, delta = negative */
	     if maxel < 0 then compensation = 0;
	     else compensation = .9999999;
	     first_value = fixed (binary (maxel / delta_value) + compensation) * delta_value;
	     delta_value = -delta_value;
	end;

	array ((n_points) * steps + 1) = first_value;	/* plug them in */
	array ((n_points+1) * steps + 1) = delta_value;

	return;
%page;
axis:	entry (abs_x, abs_y, title, control, axis_len, angle, first_val, delta_val);

dcl  title char (*) parameter,
     control fixed bin parameter,
     first_val float bin parameter,
     delta_val float bin parameter;

dcl (adj_axis_len, x_between_tics) float bin,
    (tic_mark, a (10)) fixed bin (18),
     tic_vect float bin,
     title_len fixed bin,
     alignment fixed bin;

dcl  underflow condition;

	call check_init;

	delta_value = delta_val;
	first_value = first_val;

	call internal_plot (abs_x, abs_y, 3, "calcomp_compatible_subrs_$axis"); /* go to begin point */

	if screen_size_factor = default_screen_size_factor then do; /* Ours */
	     adj_axis_len = fixed (binary (axis_len)) / 100; /* 1 inch = 100 points */
	     x_between_tics = 100;
	end;
	else do;					/* Theirs */
	     adj_axis_len = fixed (binary (axis_len));	/* 1 inch = screen_size_factor points */
	     x_between_tics = screen_size_factor;
	end;

	tic_vect = 10 * sign (control);		/* screen_size does not matter here. 10 is invariant. */

	if control < 0 then alignment = Lower_center;	/* counterclockwise labels */
	else alignment = Upper_center;		/* clockwise labels */

	a (1) = graphic_manipulator_$create_position (Shift, 0, tic_vect, 0, code);
	if code ^= 0 then goto tic_err;

	a (2) = graphic_manipulator_$create_position (Vector, 0, tic_vect, 0, code);
	if code ^= 0 then goto tic_err;

	a (3) = graphic_manipulator_$create_position (Vector, x_between_tics, 0, 0, code);
	if code ^= 0 then goto tic_err;

	a (4) = graphic_manipulator_$create_position (Shift, 0, -2 * tic_vect, 0, code);
	if code ^= 0 then do;			/* nervous tic */
tic_err:	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating tic components.");
	     return;
	end;

	tic_mark = graphic_manipulator_$create_array (a, 4, code); /* make array */
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating array for tic_mark.");
	     return;
	end;


	temp (1) = graphic_manipulator_$create_rotation (0, 0, angle, code); /* rotate the axis */
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating axis rotation");
	     return;
	end;

	temp (2) = graphic_manipulator_$create_position (Shift, 0, -2 * tic_vect, 0, code);
						/* to start in right place */
	if code ^= 0 then goto axis_err;

	on underflow;

	do i = 1 to adj_axis_len + 1;			/* make right number of tics */
	     call ioa_$rsnnl ("^3e", char_number, j, first_value + (i-1) * delta_value);
strip_blanks:  if substr (char_number, 1, 1) = " " then do; /* ioa_ sometimes does this */
		char_number = substr (char_number, 2);
		j = j - 1;
		goto strip_blanks;
	     end;
	     temp (2*i+1) = graphic_chars_ (substr (char_number, 1, j), alignment, 10, 10, code);
	     if i <= adj_axis_len then temp (2*i+2) = tic_mark; /* don't need extra tic mark */
	end;

	revert underflow;

	i = (adj_axis_len + 1) * 2 + 1;

	temp (1+i) = a (1);				/* create last tic */
	temp (2+i) = a (2);
	temp (3+i) = graphic_manipulator_$create_position
	     (Shift, fixed (binary (-axis_len)) * screen_size_factor/2, -4 * tic_vect, 0, code);
						/* return halfway, for title */
	if code ^= 0 then goto axis_err;

	title_len = abs (control);

	temp (4+i) = graphic_chars_ (substr (title, 1, title_len), alignment, 25, 25, code);
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating vectors from title");
	     return;
	end;

	temp (5+i) = graphic_manipulator_$create_position /* return all the way */
	     (Shift, fixed (binary (-axis_len)) * screen_size_factor/2, 4*tic_vect, 0, code);
	if code ^= 0 then do;
axis_err:	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating elements of axis.");
	     return;
	end;

	node = graphic_manipulator_$create_array (temp, 5+i, code); /* put it all together */
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0, "Creating array from axis", "h", null, 0);
	     return;
	end;

	call append_element (node, code);		/* tack it on */
	if code ^= 0 then call sub_err_ (code, "calcomp_compatible_subrs_$axis", "h", null, 0,
	     "Appending axis to display list.");

	return;
%page;
line:	entry (x_array, y_array, n_points, step_size, line_type, symbol_no); /* to plot data elements */

dcl (x_array (*), y_array (*)) float bin parameter,
     symbol_no fixed bin parameter,
     line_type fixed bin parameter;

dcl (delta_value_x,
     delta_value_y,
     first_value_x,
     first_value_y,
     temp_scale) float bin;

dcl  alloc_temp (alloc_temp_length) based (atp) fixed bin (18) based,
     alloc_temp_length fixed bin,
     atp pointer initial (null);

dcl  cu_$grow_stack_frame ext entry (fixed bin, pointer, fixed bin (35));

dcl  do_symbols bit (1) aligned,
     cleanup condition,
     every_n fixed bin,
     counter fixed bin,
    (x_scale, y_scale) float bin,
    (mod, null) builtin;

	call check_init;

	first_value_x = x_array ((n_points) * step_size + 1); /* grab scaling factors off end */
	first_value_y = y_array ((n_points) * step_size + 1);

	delta_value_x = x_array ((n_points + 1) * step_size + 1);
	delta_value_y = y_array ((n_points + 1) * step_size + 1);

	if screen_size_factor = default_screen_size_factor then temp_scale = 100; /* Ours */
	else temp_scale = 1;			/* Theirs */

	x_scale = temp_scale * screen_size_factor / delta_value_x;
	y_scale = temp_scale * screen_size_factor / delta_value_y;

	do_symbols = line_type ^= 0;			/* if want symbols plotted */
	call internal_plot (0, 0, 3, "calcomp_compatible_subrs_$line"); /* get back to origin */
	if do_symbols
	then call get_special_symbol (symbol_no, node, 10/screen_size_factor, "calcomp_compatible_subrs_$line");

	every_n = abs (line_type);
	cumulative_rels = 0;

	if every_n = 0 then alloc_temp_length = n_points + 10; /* the "10" is for good luck */
	else alloc_temp_length = n_points + n_points/every_n + 10;

	call cu_$grow_stack_frame (alloc_temp_length, atp, code);
	if code ^= 0 then goto bad_line;

	x_rel = (x_array (1) - first_value_x) * x_scale;	/* compute initial shift */
	y_rel = (y_array (1) - first_value_y) * y_scale;

	alloc_temp (1) = graphic_manipulator_$create_position (Shift, x_rel, y_rel, 0, code);
	if code ^= 0 then do;
bad_line:	     call sub_err_ (code, "calcomp_compatible_subrs_$line", "h", null, 0, "Constructing elements of line array.");
	     return;
	end;

	if do_symbols then alloc_temp (2) = node;
	else alloc_temp (2) = 0;

	cumulative_rels = cumulative_rels + rel_positions; /* keep track of position */

	if line_type < 0 then movement = Shift;		/* wants no lines plotted */
	else movement = Vector;			/* wants lines plotted */
	counter = 1;				/* allow for symbol at initial point */
	j = 1;

	do i = 3 by 1 while (j <= (n_points * step_size) - 1); /* clomp up array */
	     j = j + step_size;
	     counter = counter + 1;

	     x_rel = (x_array (j) - x_array (j - step_size)) * x_scale;
	     y_rel = (y_array (j) - y_array (j - step_size)) * y_scale;

	     alloc_temp (i) = graphic_manipulator_$create_position (movement, x_rel, y_rel, 0, code);
	     if code ^= 0 then goto bad_line;

	     cumulative_rels = cumulative_rels + rel_positions;

	     if do_symbols then if mod (counter, every_n) = 0 then do; /* put out a symbol here */
		     i = i + 1;
		     alloc_temp (i) = node;
		end;
	end;

	node = graphic_manipulator_$create_array (alloc_temp, i-1, code); /* put it together */
	if code ^= 0 then do;
	     call sub_err_ (code, "calcomp_compatible_subrs_$line", "h", null, 0, "Assembling data points into array.");
	     return;
	end;

	call append_element (node, code);		/* tack it on */
	if code ^= 0 then call sub_err_ (code, "calcomp_compatible_subrs_$line", "h", null, 0,
	     "Adding line array to display list.");

	cur_position = cur_position + cumulative_rels / screen_size_factor; /* set cur pos to end of line */

	return;
     end ccs_;
   



		    graphic_chars_.pl1              11/18/82  1706.7rew 11/18/82  1625.3      147312


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_chars_: proc (instring, alignment, x_factor, y_factor, code) returns (fixed bin (18));

/* graphic_chars_ converts a character string into a list of graphic vectors
   and shifts that stroke out the desired characters.  It uses any of several
   graphic character tables, each of which describes a character set in a
   different font or alphabet. */
/* Modified 02/08/78 by CDT for new graphic character table formats, including
   variable width characters, auto canonicalization processing, and smarter
   multiple-line processing.  */
/* Modified 07/22/80 by CDT to use graphics search paths instead of linker
   search rules to find GCT's.  */
/* Modified 08/19/80 by CDT to make characters sharing same character
   position be centered in the space, not left-adjusted, remove call to
   com_err_, and remove support for obsolete version 1 character tables. */
/* Last modified 11/25/80 by CDT to fix spreads returned by $long entries */

dcl  instring char (*) parameter,			/* the string to be converted */
     alignment fixed bin parameter,			/* where to align it */
    (x_factor, y_factor) float bin parameter,
     code fixed bin (35) parameter;

%include gm_entry_dcls;

%include graphic_etypes;

%include graphic_char_dcl;

dcl (i, j) fixed bin,				/* temps */
     start fixed bin,
     line_node (122) fixed bin (18),
     line_shift_node fixed bin (18),
     node fixed bin (18);				/* temp node */

dcl  string_len fixed bin,				/* length without trailing blanks */
     line_shift float bin,
    (x_shift, y_shift) float bin;

dcl (x_rel, y_rel) fixed bin;				/* to keep track of where we ended up */

dcl  char char (1) aligned,
    (BS initial (""),				/* the special chars which graphic_char_table_ won't hack */
     CR initial (""),
     SPACE initial (" "),
     TAB initial ("	"),
     UNDERSCORE initial ("_"),
     NL initial ("
")) char (1) aligned static options (constant);

dcl  Line_space_factor float bin static options (constant) initial (1.5e0);

dcl  already_done_chars (0:127) fixed bin (18) static initial ((128) 0); /* keeps us from doing a char twice */

dcl  sub_err_ ext entry options (variable);

dcl (error_table_$bad_index,
     error_table_$unimplemented_version,
     graphic_error_table_$gct_bad_special_char) ext fixed bin (35) static;

dcl  saved_dirname char (168) static initial (""),
     saved_ename char (32) static initial ("gct_block_roman_");

dcl  motion fixed bin,
     avg_width float bin;

dcl  char_ptr (0:127) based (char_ptr_ptr) pointer,
     character_sizes (3) based (char_sizes_ptr) fixed bin;

dcl (char_ptr_ptr, char_sizes_ptr) pointer static initial (null);

dcl (x_size, y_size, x_margins) float bin static initial (0);

dcl  strip_blanks bit (1) aligned initial ("1"b);

dcl (addr, codeptr, dim, divide, float, index, length,
     max, mod, null, rank, rtrim, substr) builtin;
%page;
common:
	code = 0;
	x_rel, y_rel = 0e0;

	if char_ptr_ptr = null then do;
	     call set_table_internal (saved_dirname, saved_ename, code);
	     if code ^= 0 then return (0);
	end;

	if strip_blanks then string_len = length (rtrim (instring, " "));
	else string_len = length (instring);

	if string_len = 0 then return (0);		/* simple. */

	i = index (substr (instring, 1, string_len), NL);
	if i = 0 then node = assemble_substring (instring, string_len, x_rel, code);

	else do;
	     start = 1;
	     y_rel = -1;				/* counts one less lines than times thru loop */
	     line_shift = y_factor * Line_space_factor;
	     line_shift_node = graphic_manipulator_$create_position (Shift, 0, -line_shift, 0, code);
	     if code ^= 0 then return (0);

	     do i = 2 by 2 while (start <= string_len);
		if i+1 > dim (line_node, 1) then do;
		     code = error_table_$bad_index;
		     return (0);
		end;

		j = index (substr (instring, start, string_len - start + 1), NL) - 1;
		if j = -1 then j = string_len - start + 1;

		line_node (i) = assemble_substring (substr (instring, start, j), j, x_rel, code);
		if code ^= 0 then return (0);

		line_node (i+1) = line_shift_node;
		y_rel = y_rel + 1;
		start = start + j + 1;
	     end;

	     y_shift = divide (alignment - 1, 3, 17, 0) * y_rel * line_shift / 2e0;
	     line_node (1) = graphic_manipulator_$create_position (Shift, 0, y_shift, 0, code);
	     if code ^= 0 then return (0);
	     line_node (i-1) = graphic_manipulator_$create_position
		(Shift, 0, (y_rel * line_shift) - y_shift, 0, code);
	     if code ^= 0 then return (0);

	     node = graphic_manipulator_$create_array (line_node, i-1, code);
	     if code ^= 0 then return (0);
	end;

	if end_position_entry then do;		/* user wants end position info */
	     x_arg = x_rel * x_factor;
	     y_arg = y_rel * y_factor * Line_space_factor;
	end;

	return (node);
	
assemble_substring: proc (instring, string_len, max_column, code) returns (fixed bin (18));

dcl  instring char (*) parameter,
     string_len fixed bin parameter,
     max_column fixed bin parameter,
     code fixed bin (35) parameter;

dcl  column_widths (string_len) fixed bin,
     a (string_len+10) fixed bin (18),			/* temp nodes */
     b (200) fixed bin (18);				/* more temp nodes */

dcl  char_value fixed bin,
     x_rel_pts fixed bin,
     half_xwidth_difference float bin,
     column fixed bin,
    (i, j) fixed bin;

dcl  node fixed bin (18);

	     max_column = 0;

	     if string_len = 0 then return (0);
	     column_widths = 0;
	     column = 0;

	     do i = 1 to string_len;			/* do for every character in string */

		char_value = rank (substr (instring, i, 1)); /* get fixed bin value of char */
		if char_value = -1 then char_value = 0; /* gaack. */
		char_info_ptr = char_ptr (char_value);

		if graphic_char_structure.n_elements >= 0 then do;
		     column = column + 1;
		     if graphic_char_structure.n_elements > 0 then
			column_widths (column) = max (column_widths (column), graphic_char_structure.width);
		end;

		else do;				/* is a special char */
		     char = substr (instring, i, 1);

		     if char = BS then column = max (0, column - 1);

		     else if char = CR then column = 0;

		     else if char = SPACE | char = TAB | char = UNDERSCORE then do;
						/* we treat these as possible whitespace */
			column = column + 1;
			if column_widths (column) = 0 then
			     column_widths (column) = -x_size + x_margins;
						/* is negative because if a real char later appears in */
						/* this column, it will override this arbitrary width */
		     end;
		     else do;			/* don't know this char, must be new */
			call sub_err_ (graphic_error_table_$gct_bad_special_char,
			     "graphic_chars_", "h", null, 0,
			     "Octal value of unrecognized character is ^o.", char_value);
			a (i+2) = 0;		/* put in a nothing */
		     end;
		end;

		max_column = max (column, max_column);
	     end;

	     x_rel_pts = 0;

	     do i = 1 to string_len while (column_widths (i) ^= 0);
		if column_widths (i) < 0 then column_widths (i) = - column_widths (i);
						/* legitimize all remaining whitespace */
		x_rel_pts = x_rel_pts + column_widths (i);
	     end;


/* Now we have passed the string canonically and know how many points each character */
/* position takes (max).  Now we shoehorn the characters into their assigned space. */

	     column = 0;

	     do i = 1 to string_len;

		char_value = rank (substr (instring, i, 1)); /* get fixed bin value of char */
		if char_value = -1 then char_value = 0; /* gaack. */
		char_info_ptr = char_ptr (char_value);

		if already_done_chars (char_value) ^= 0 then do; /* we already assembled one of these */
		     column = column + 1;
		     if column_widths (column) = graphic_char_structure.width then
			a (i+2) = already_done_chars (char_value); /* put it in */
		     else do;
			half_xwidth_difference = (column_widths (column) - graphic_char_structure.width) / 2e0;
			b (1) = graphic_manipulator_$create_position (Shift,
			     half_xwidth_difference, 0, 0, code);
			if code ^= 0 then return (0);
			b (2) = already_done_chars (char_value);
			b (3) = b (1);
			a (i+2) = graphic_manipulator_$create_array (b, 3, code);
			if code ^= 0 then return (0);
		     end;
		end;

		else do;				/* make it from scratch */
		     if graphic_char_structure.n_elements < 0 then do; /* this is special char */

			char = substr (instring, i, 1); /* get it */

			if char = BS then do;	/* backspace */
			     if column = 0 then a (i+2) = 0; /* he's "up against the wall" */
			     else do;
				a (i+2) = graphic_manipulator_$create_position
				     (Shift, - column_widths (column), 0, 0, code);
				if code ^= 0 then return (0); /* go back one space */
				column = column - 1;
			     end;
			end;

			else if char = CR then do;	/* carriage return */
			     j = 0;
			     do column = column to 1 by -1;
				j = j - column_widths (column);
			     end;

			     a (i+2) = graphic_manipulator_$create_position (Shift, (j), 0, 0, code);
			     if code ^= 0 then return (0); /* go back all the way */
			end;

			else if char = SPACE | char = TAB then do;
			     column = column + 1;
			     a (i+2) = graphic_manipulator_$create_position (Shift, (column_widths (column)), 0, 0, code);
			     if code ^= 0 then return (0);
			end;

			else if char = UNDERSCORE then do;
			     column = column + 1;
			     b (1) = graphic_manipulator_$create_position (Shift, 0, -y_size * 1.125, 0, code);
			     if code ^= 0 then return (0);
			     b (2) = graphic_manipulator_$create_position (Vector, (column_widths (column)), 0, 0, code);
			     if code ^= 0 then return (0);
			     b (3) = graphic_manipulator_$create_position (Shift, 0, y_size * 1.125, 0, code);
			     if code ^= 0 then return (0);
			     a (i+2) = graphic_manipulator_$create_array (b, 3, code);
			     if code ^= 0 then return (0);
			end;
		     end;

		     else if graphic_char_structure.n_elements = 0 then a (i+2) = 0;
						/* is garbage/control char, ignore */

		     else do;			/* char is handled by table */
			coords_ptr = addr (graphic_char_structure.coords); /* use faster pointer reference */
			column = column + 1;

			if graphic_char_structure.n_elements > dim (b, 1) then do;
			     code = error_table_$bad_index;
			     return (0);
			end;

			do j = 1 to graphic_char_structure.n_elements; /* do for every vector in char */
			     if graphic_char_structure.move_type (j) then motion = Vector;
			     else motion = Shift;
			     b (j) = graphic_manipulator_$create_position
				(motion, float (graphic_char_structure.x_length (j)),
				float (graphic_char_structure.y_length (j)), 0, code);
						/* create shift or vector as ordered */
			     if code ^= 0 then return (0);
			end;

			already_done_chars (char_value), a (i+2)
			     = graphic_manipulator_$create_array (b, j-1, code);
						/* remember we did this char. */
			if code ^= 0 then return (0);
			if column_widths (column) > graphic_char_structure.width then do;
			     half_xwidth_difference = (column_widths (column) - graphic_char_structure.width) / 2e0;
			     b (1) = graphic_manipulator_$create_position (Shift,
				half_xwidth_difference, 0, 0, code);
			     if code ^= 0 then return (0);
			     b (2) = a (i+2);	/* use node just created */
			     b (3) = b (1);
			     a (i+2) = graphic_manipulator_$create_array (b, 3, code);
			     if code ^= 0 then return (0);
			end;
		     end;
		end;
	     end;

	     if mod (alignment - 1, 3) ^= 0 then
		x_shift = mod (alignment - 1, 3) * - x_rel_pts/2e0;
	     else x_shift = 0;

	     y_shift = divide (alignment - 1, 3, 17, 0) * y_size/2e0;

	     if max_column <= 0 then return (0);	/* weird, maybe just backspaces */

	     avg_width = float (x_rel_pts)/float (max_column);
	     if avg_width = 0 then return (0);		/* all control chars */

	     a (1) = graphic_manipulator_$create_scale
		(x_factor/avg_width, y_factor/y_size, 1, code); /* scale the chars */
	     if code ^= 0 then return (0);
	     a (2) = graphic_manipulator_$create_position
		(Shift, x_shift, y_shift, 0, code);	/* perform alignment */
	     if code ^= 0 then return (0);


	     a (i+2) = graphic_manipulator_$create_position (Shift, - x_rel_pts - x_shift,
		- y_shift, 0, code);
						/* shift back to starting point */
	     if code ^= 0 then return (0);

	     node = graphic_manipulator_$create_array (a, i+2, code); /* make one list from all chars */
	     if code ^= 0 then return (0);

	     return (node);

	end assemble_substring;
	
long_tb:	entry (instring, alignment, x_factor, y_factor, x_arg, y_arg, code) returns (fixed bin (18));

	strip_blanks = ""b;

long:	entry (instring, alignment, x_factor, y_factor, x_arg, y_arg, code) returns (fixed bin (18));

dcl (x_arg, y_arg) float bin parameter,			/* end positions, to be returned */
     end_position_entry bit (1) aligned initial (""b);	/* if on, were called from this entry */

	x_arg, y_arg = 0;
	end_position_entry = "1"b;
	goto common;

init:	entry;

	already_done_chars = 0;
	return;

set_table: entry (dirname, ename, code);

dcl (dirname, ename) char (*) parameter;

	call set_table_internal (dirname, ename, code);
	return;

get_table: entry (dirname, ename);

	dirname = saved_dirname;
	ename = saved_ename;
	return;


set_table_internal: proc (dirname, ename, code);

dcl (dirname, ename) char (*) parameter,
     code fixed bin (35) parameter;

dcl  term_$single_refname ext entry (char (*), fixed bin (35)),
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)),
     hcs_$fs_get_path_name ext entry (pointer, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$make_ptr ext entry (pointer, char (*), char (*), pointer, fixed bin (35));

dcl  search_paths_$find_dir ext entry (char (*), pointer, char (*), char (*), char (*), fixed bin (35));

dcl (csp, cpp) pointer;

dcl  auto_dirname char (168),
     my_own_dirname char (168) static initial ("");

dcl  error_table_$segknown ext fixed bin (35) static;


	     char_ptr_ptr, char_sizes_ptr = null;	/* if anything fails, we want next call */
						/* to refind current table from scratch */

	     call term_$single_refname (ename, 0);	/* get rid of this refname if possible */

	     if dirname ^= "" then
		auto_dirname = dirname;		/* path given, no sweat */

	     else do;
		if my_own_dirname = "" then do;	/* make referencing_dir rule work */
this_label:	     call hcs_$fs_get_path_name (codeptr (this_label),
			my_own_dirname, 0, "", code);
		     if code ^= 0 then return;
		end;

		call search_paths_$find_dir ("graphics", null,
		     ename, my_own_dirname, auto_dirname, code);
		if code ^= 0 then return;
	     end;

	     call hcs_$initiate (auto_dirname, ename, ename, 0, 0,
		null, code);
	     if code ^= 0 then if code ^= error_table_$segknown then return;
						/* want to know about name duplications if need be */

	     call hcs_$make_ptr (null, ename, "char_ptr", cpp, code);
	     if code ^= 0 then return;

	     call hcs_$make_ptr (null, ename, "character_sizes", csp, code);
	     if code ^= 0 then return;

	     if csp -> character_sizes (3) > 0 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	     saved_dirname = auto_dirname;
	     saved_ename = ename;

	     char_ptr_ptr = cpp;
	     char_sizes_ptr = csp;

	     x_size = character_sizes (2);
	     y_size = character_sizes (1);
	     x_margins = - character_sizes (3);

	     already_done_chars = 0;			/* no use keeping this after switching tables! */

	     return;
	end set_table_internal;

     end graphic_chars_;



		    graphic_code_util_.alm          11/18/82  1706.7rew 11/18/82  1625.8       47511


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

	name	graphic_code_util_

" This module performs format translations between Multics standard
" graphics code and common numeric argument formats.
"
" Written 11/15/80 by C. D. Tavares as a replacement for
" a former PL/I version that ran half as fast.

	entry	decode_spi,decode_dpi,decode_uid,decode_scl
	entry	decode_scl_nozero
	entry	encode_spi,encode_dpi,encode_uid,encode_scl
"
	include	stack_frame
"
" decode_spi: entry (arg_stringp, count, fixed_array);

decode_spi:
	tsx0	decode_setup	get args
	eax7	1		spi format is 1 char
	tsx0	decode		process it
	short_return
"
" decode_dpi: entry (arg_stringp, count, fixed_array);

decode_dpi:
	tsx0	decode_setup	get args
	eax2	0,x1		save count
	epp2	pr3|0		and array ptr
	eax7	2		dpi format is 2 chars
	tsx0	decode		process it

	lda	=o4000,dl		high order dpi bit
	lcq	=o10000,dl	loads sign bits 777777770000

dd_neg_loop:
	cana	pr2|-1,x2		is "negative" bit on
	tze	2,ic		no, skip
	orsq	pr2|-1,x2		yes, or in extended negative sign
	sblx2	1,du		are we done
	tpnz	dd_neg_loop	no, loop

	short_return
"
" decode_uid: entry (arg_stringp, count, fixed_array);

decode_uid:
	tsx0	decode_setup	get args
	eax7	3		uid format is 3 chars
	tsx0	decode		do it
	short_return
"
" decode_scl: entry (arg_stringp, count, float_array);

decode_scl:
	eax3	0		indicator
	tra	decode_scl_common

" decode_scl_nozero: entry (arg_stringp, count, fixed_array);

decode_scl_nozero:
	eax3	1		indicator

decode_scl_common:
	tsx0	decode_setup	get args
	eax2	0,x1		save count
	epp2	pr3|0		and array ptr
	eax7	3		scl format is 3 chars
	tsx0	decode		do it

ds_float_loop:	null		turn fixed (17,6) into float
	lda	pr2|-1,x2		load intermediate result word
	als	18		shift to left 18
	lrs	54		extend sign bit and occupy aq
	lde	=o202000,du	load proper exponent
	fad	=0.0,du		normalize
	tnz	ds_storit		if nonzero, store it
	cmpx3	0,du		were we called at nozero entry
	tze	ds_storit		no, store the zero
	fld	=1e-6		load small nonzero value
ds_storit:
	fst	pr2|-1,x2		store as float bin
	sblx2	1,du		are we done
	tpnz	ds_float_loop	no, loop

	short_return
"
" encode_spi: entry (fixed_array, count, arg_stringp);

encode_spi:
	tsx0	encode_setup	get args
	eax7	1		spi format is 1 char
	tsx0	encode		do it
	short_return
"
" encode_dpi: entry (fixed_array, count, arg_stringp);

encode_dpi:
	tsx0	encode_setup	get args
	eax7	2		dpi format is 2 chars
	tsx0	encode		do it
	short_return
"
" encode_uid: entry (fixed_array, count, arg_stringp);

encode_uid:
	tsx0	encode_setup	get args
	eax7	3		uid format is 3 chars
	tsx0	encode		do it
	short_return
"
" encode_scl: entry (float_array, count, arg_stringp);

encode_scl:
	tsx0	encode_setup	get args
	eax7	3		scl format is 3 chars
	eax2	0		x2 is index counter
	epp1	pr6|stack_frame.next_sp,*
	null			need a temp, this is cheap

e_scl_loop:	null		algorithm courtesy pl1 operators
	null			turns float bin into fixed (17,6)
	fld	pr3|0,x2		pick up float bin
	tmi	e_scl_neg_case	if result negative

e_scl_pos_case:
	ufa	=o176000,du	fixify by forcing exp to proper scale
	adq	2,dl		1/2 at proper scale
	qrs	2		wipe out fractional bits
	tra	e_scl_common

e_scl_neg_case:
	fneg	0		perform operation on abs value
	ufa	=o176000,du	see above
	adq	2,dl
	qrs	2
	negl	0		re-negate

e_scl_common:
	stq	pr1|0		handy temp
	mvt	(pr),(pr),fill(0)	translate it
	desc6a	pr1|0(3),3
	desc9a	pr5|0,3
	arg	trans_table

	sblx1	1,du		are we done
	tze	do_short_return	yes

	epp3	pr3|1		bump index ptr
	a9bd	pr5|0,x7		and string ptr
	tra	e_scl_loop

do_short_return:
	short_return
"
decode_setup:
	epp3	ap|6,*		get ptr to array

	lxl1	ap|4,*		get count

	epp5 	ap|2,*		get string ptr
	epp5	pr5|0,*

	tra	0,0
"
decode:	s6bd	pr3|0,x7		adjust array ptr to proper offset

d_loop:	stz	pr3|1			clear garbage in word
	mvt	(pr,rl),(pr,rl),fill(0)	decode it		
	desc9a	pr5|0,x7
	desc6a	pr3|1,x7
	arg	trans_table

	sblx1	1,du		are we done
	tze	0,0		done, return

	epp3	pr3|1		bump array ptr
	a9bd	pr5|0,x7		and char ptr
	tra	d_loop
"
encode_setup:
	epp3	ap|2,*		get ptr to array

	lxl1	ap|4,*		get count

	epp5	ap|6,*		get string ptr
	epp5	pr5|0,*

	tra	0,0
"
encode:	s6bd	pr3|0,x7		adjust array ptr to proper offset

e_loop:	mvt	(pr,rl),(pr,rl),fill(0)	encode it
	desc6a	pr3|1,x7
	desc9a	pr5|0,x7
	arg	trans_table

	sblx1	1,du		are we done
	tze	0,0		yes, return

	epp3	pr3|1		bump array ptr
	a9bd	pr5|0,x7		bump string ptr
	tra	e_loop
"
trans_table:
	oct	100101102103,104105106107,110111112113,114115116117
	oct	120121122123,124125126127,130131132133,134135136137
	oct	140141142143,144145146147,150151152153,154155156157
	oct	160161162163,164165166167,170171172173,174175176177
	oct	000001002003,004005006007,010011012013,014015016017
	oct	020021022023,024025026027,030031032033,034035036037
	oct	040041042043,044045046047,050051052053,054055056057
	oct	060061062063,064065066067,070071072073,074075076077

	end
 



		    graphic_compiler_.pl1           11/18/82  1706.7rew 11/18/82  1625.3      411021


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_compiler_: gc_: procedure; return;

/* Originally coded 7/20/73 by Lee J. Scheffler */
/* Major rewrite 07/79 by C. D. Tavares-- added internal array linearization,
   position roundoff tracking inside arrays, and premapping of objects inside
   arrays.  Also included entrypoint expand_string to replace functionality of
   make_graphic_array_. */
/* Modified 08/29/80 by CDT to fix bug where if a mode or mapping occurred
   as last element of array, gc_ locked up and looped.  Also modified it not to
   put out trailing mode/mapping revocations in a top-level array. */
/* Last modified 10/14/80 by CDT to understand about elements with trailing
   zero coordinates unstored, and to add entrypoint prune_tree. */

/* PARAMETERS */

dcl (desired_switch pointer,				/* I/O switch for output */
     display_name char (*),				/* name of graphic symbol being displayed */
     display_node fixed bin (18),			/* number of node being displayed */
     err_code fixed bin (35),				/* error code */
     number_used fixed bin (21),			/* number of input_chars used by expand_string */
     return_p pointer,				/* pointer to returned string in return_string entry point */
     return_len fixed bin (21)) parameter;		/* length of returned string */


/* AUTOMATIC */

dcl  Array_header_chars char (2) aligned,
     List_header_chars char (2) aligned,
     Null_node_chars char (5) aligned,
     abs_move_needed bit (1) aligned,
     auto_temp_seg_ptr pointer initial (null),
     char char (1),
     copy_direct bit (1) aligned,
     contents_p pointer,
     datap pointer,
     done bit (1) aligned,
     effector_char char (1),
     fixed_buffer (3) fixed bin,
     float_buffer (3) float bin,
     frame_ptr pointer,
     graphic_output pointer,
     i fixed bin,
     ini fixed bin (21) init (1),			/* index for input string */
     input_string char (*),				/* string of MSGC to expand and recompile */
     item_environment_wall bit (1) aligned,
     j fixed bin,
     max_levels fixed bin,
     must_put_out bit (1) aligned,
     n_elements fixed bin,
     node_no fixed bin (18),
     node_p pointer,
     outi fixed bin (21) init (1),			/* index for output string */
     sym_len fixed bin,
     sym_node fixed bin (18),
     sym_p pointer,
     sym_type fixed bin,
     temp_length fixed bin (21),
     temp_matrix (3, 3) float bin,
     temp_ptr pointer,
     temp_scaled (3) fixed bin (35, 6),
     type fixed bin,
     value_node fixed bin (18),
     waiting_to_make_array bit (1) aligned automatic initial (""b),
						/* informs lower levels not to waste time making graphic
						   arrays if someone above them is waiting to make one */

     wgs_p pointer;					/* pointer to the current working graphic seg */

dcl 1 control automatic,				/* central repository of operation flags */
    2 (erase,
     display,
     return_string,
     from_wgs) bit (1),
    2 output_string_ptr pointer,
    2 cur_switch pointer;

dcl 1 position automatic,
    2 absolute bit (1) aligned,
    2 desired (3) float bin,
    2 current (3) fixed bin (35, 6);


/* ENTRIES */

dcl  get_temp_segment_ ext entry (char (*), pointer, fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     hcs_$truncate_seg entry (pointer, fixed bin (18), fixed bin (35)),
     sub_err_ ext entry options (variable);


dcl (graphic_code_util_$encode_spi,
     graphic_code_util_$encode_dpi,
     graphic_code_util_$encode_uid) entry (dimension (*) fixed bin, fixed bin, pointer),
     graphic_code_util_$encode_scl entry (dimension (*) float bin, fixed bin, pointer),
    (graphic_code_util_$decode_spi,
     graphic_code_util_$decode_dpi,
     graphic_code_util_$decode_uid) entry (pointer, fixed bin, dimension (*) fixed bin),
    (graphic_code_util_$decode_scl,
     graphic_code_util_$decode_scl_nozero) entry (pointer, fixed bin, dimension (*) float bin);

dcl  graphic_element_length_ entry (char (*), fixed bin (21)) returns (fixed bin),
     graphic_manipulator_$segp entry (pointer, fixed bin (35));


/* INTERNAL STATIC */

dcl  temp_seg_ptr pointer static initial (null);		/* pointer to temp seg in which graphic string is compiled */

dcl  max_string_size fixed bin (21) static,
     sys_area_p pointer static initial (null);

dcl  tree_ptr pointer static initial (null);

dcl  scaled_zeroes (3) fixed bin (35, 6) internal static initial ((3)0.0);


/* EXTERNAL STATIC */

dcl (graphic_error_table_$no_wgs_yet,			/* No graphic structure to compile yet */
     graphic_error_table_$recursive_structure,		/* graphic structure is recursive */
     graphic_error_table_$compiler_error,		/* no comment necessary */
     graphic_error_table_$bad_node,			/* bad node type in graphic structure   */
     graphic_error_table_$not_a_structure,		/* malformed MSGC was input */
     graphic_error_table_$abs_pos_in_clipping)		/* absolute position element within clipping domain */
     fixed bin (35) external static;

dcl (error_table_$out_of_sequence,
     error_table_$smallarg) fixed bin (35) external static;

dcl  sys_info$max_seg_size fixed bin (35) external;


/* BASED */

dcl  output_string char (max_string_size) based (output_string_ptr), /* compiled string */
     output_string_array (max_string_size) char (1) unaligned based (output_string_ptr), /* overlay of output_string */
     input_string_array (max_string_size) char (1) unaligned based (addr (input_string)), /* overlay of input_string */
     char_str char (max_string_size) based,
     fixed_contents (n_elements) fixed bin based (contents_p),
     float_contents (n_elements) float bin based (contents_p),
     node_array (1) fixed bin based (addr (node_no)),	/* To get around compiler bug */
     sys_area area based (sys_area_p),
     dumaray based fixed bin dimension (1);		/* 03/21/75 since symbol table processor doesn't like
						   use of (fixed bin) in array arg position */


/* The tree is a pseudo stack used to keep track of not only the current position in the graphic tree structure
   but also the current graphic environment when making arrays out of lists. */

dcl 1 tree aligned based (tree_ptr),
    2 level fixed bin init (1),			/* Current list or array level */
    2 max_level fixed bin,
    2 node (0 : max_levels refer (max_level)),		/* Nodes in path of current compilation */
      3 trace aligned,
        4 id fixed bin (18) init (0),			/* unique id of list node at this level */
        4 idx fixed bin init (0),			/* index in this list of next level node */
        4 max_idx fixed bin init (0),			/* number of elements in this item */
        4 node_p pointer init (null),			/* pointer to node in WGS */
        4 environment_wall bit (1),			/* input array marker-- should never collapse past this level */
        4 output_array_sentinel bit (1),		/* this level marks the boundary of the output array */
        4 precollapsed bit (1),			/* the level above this has been collapsed but not popped */
      3 environment aligned,
        4 intensity fixed bin,
        4 linetype fixed bin,
        4 sensitivity fixed bin,
        4 blinking fixed bin,
        4 color (3) fixed bin,
        4 matrix (3, 3) float bin,			/* linear transformation matrix for scaling and rotation */
        4 clipping_boundaries (3, 2) float bin,		/* current boundaries of clipping effector (not used) */
        4 active aligned,
	5 (transformation, clipping) bit (1),
      3 this_level aligned,
        4 scaling (3) float bin,
        4 clipping (3, 2) float bin;

dcl 1 tree_frame aligned based (frame_ptr) like tree.node;


/* BUILTINS AND CONDITIONS */

dcl (addr, cosd, fixed, float, length, mod, null, round, rtrim, sind, string, substr, sum, unspec) builtin;

dcl (cleanup, underflow) condition;

dcl  subscriptrange condition;			/* GET RID OF THIS BEFORE INSTALLATION */
%page;
%include graphic_comp_specs;
%page;
%include graphic_etypes;
%page;
%include graphic_templates;
%page;
%include lsm_formats;
%page;
%include iox_dcls;
%page;
%include lsm_entry_dcls;
%page;
/* ------------------------------------------------------------------------- */

/* These entries display the substructure subordinate to a given node */


/* This is the normal display entry point - it erases the screen first */

display: d: entry (display_node, err_code);

	control.erase,
	     control.display = "1"b;
	control.return_string = "0"b;
	control.cur_switch = null;
	go to node_common;
%skip (2);
display_switch: d_switch: entry (display_node, err_code, desired_switch);

	control.erase,
	     control.display = "1"b;
	control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto node_common;
%skip (5);

/* These entry points do not erase the screen first */

display_append: da: entry (display_node, err_code);

	control.display = "1"b;
	control.erase,
	     control.return_string = "0"b;
	control.cur_switch = null;
	go to node_common;
%skip (2);
display_append_switch: da_switch: entry (display_node, err_code, desired_switch);

	control.display = "1"b;
	control.erase,
	     control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto node_common;
%skip (5);

/* These entry points load the substructure subordinate to a node into the
   terminal processor memory, but do not display it */

load: l:	entry (display_node, err_code);

	control.display,
	     control.erase,
	     control.return_string = "0"b;
	control.cur_switch = null;
	goto node_common;
%skip (2);
load_switch: l_switch: entry (display_node, err_code, desired_switch);

	control.display,
	     control.erase,
	     control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto node_common;
%skip (5);

/* Return the compiled string corresponding to the node */

return_string: rs: entry (display_node, return_p, return_len, err_code);
	control.display,
	     control.erase = "0"b;
	control.return_string = "1"b;
	go to node_common;
%skip (6);
node_common:					/* Common code for compilations starting with a node number */

	control.from_wgs = "1"b;
	call initialize;				/* Get ptr to current working graphic seg */

	on cleanup call cleaner_up;

	call compile_node (display_node);		/* Compile and dispatch it */

	call cleaner_up;
	return;
%page;
/* These entries display the structure subordinate to a graphic symbol, given
   its name.  See comments on above similar entrypoints for explanation.  */


display_name: dn: entry (display_name, err_code);

	control.erase,
	     control.display = "1"b;
	control.return_string = "0"b;
	control.cur_switch = null;
	go to name_common;
%skip (2);
display_name_switch: dn_switch: entry (display_name, err_code, desired_switch);

	control.erase,
	     control.display = "1"b;
	control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto name_common;
%skip (5);
display_name_append: dna: entry (display_name, err_code);

	control.display = "1"b;
	control.erase,
	     control.return_string = "0"b;
	control.cur_switch = null;
	go to name_common;
%skip (2);
display_name_append_switch: dna_switch: entry (display_name, err_code, desired_switch);

	control.display = "1"b;
	control.erase,
	     control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto name_common;
%skip (5);
load_name: ln: entry (display_name, err_code);

	control.display,
	     control.erase,
	     control.return_string = "0"b;
	control.cur_switch = null;
	goto name_common;
%skip (2);
load_name_switch: ln_switch: entry (display_name, err_code, desired_switch);

	control.display,
	     control.erase,
	     control.return_string = "0"b;
	control.cur_switch = desired_switch;
	goto name_common;
%skip (6);
name_common:					/* Common code for compilations starting with a symbol name */

	control.from_wgs = "1"b;
	call initialize;

	call lsm_sym_$symk (wgs_p, Find_symbol, display_name, sym_node, value_node, err_code);
	if err_code ^= 0 then return;

	on cleanup call cleaner_up;

	call compile_node (value_node);

	call cleaner_up;

	return;
%page;
/* This entrypoint uses a graphic structure supplied as a string of MSGC as
   opposed to a graphic structure in the WGS.  It implements the "expand"
   function found in GDT's. */

expand_string: entry (input_string, number_used, return_p, return_len, err_code);

	control.display,
	     control.erase,
	     control.from_wgs = "0"b;
	control.return_string = "1"b;
	control.cur_switch = null;

	call initialize;

	call compile_node (0);

	number_used = ini - 1;

	return;
%skip (8);

/* Arbitrary entrypoints and exitpoints */

/* Entry to return information about where in a graphic structure the last error occurred,
   without having to know the format of the tree. */

error_path: entry (top_level_node, struc_depth, index_array, err_code);

dcl (top_level_node fixed bin (18),
     struc_depth fixed bin,
     index_array fixed bin dimension (*)) parameter;

	if tree_ptr = null then do;
	     err_code = error_table_$out_of_sequence;
	     return;
	end;

	struc_depth = tree.level - 1;			/* Any leftover index on the last level is not interesting */
	top_level_node = tree.node (1).id;

	if struc_depth > dim (index_array, 1) then do;
	     err_code = error_table_$smallarg;
	     return;
	end;

	do i = 1 to struc_depth;
	     index_array (lbound (index_array, 1) + i - 1) = tree.node (i).idx;
	end;

	err_code = 0;
	return;
%skip (5);

/* Entrypoint to reset the tree to minimal size. */

prune_tree: entry (err_code);

	err_code = 0;
	if tree_ptr = null then return;

	free tree in (sys_area);
	tree_ptr = null;
	return;
%skip (5);

/* Various matrix-hacking entrypoints, since we have engulfed the old graphic_matrix_util_ within ourselves */

make_matrix: entry (arg_rots, arg_scls, arg_matrix);

dcl  arg_rots (3) fixed bin parameter,
     arg_scls (3) float bin parameter,
     arg_matrix (3, 3) float bin parameter;

	call make_matrix (arg_rots, arg_scls, arg_matrix);
	return;


multiply_3x3_x_3x3: entry (arg_lmatrix, arg_rmatrix, arg_matrix);

dcl (arg_lmatrix, arg_rmatrix) (3, 3) float bin parameter;

	call multiply_3x3_x_3x3 (arg_lmatrix, arg_rmatrix, arg_matrix);
	return;
%skip (3);
multiply_3x3_x_1x3: entry (arg_lmatrix, arg_rvector, arg_vector);

dcl (arg_rvector, arg_vector) (3) float bin parameter;

	call multiply_3x3_x_1x3 (arg_lmatrix, arg_rvector, arg_vector);
	return;
%skip (5);
sub_err_caller: proc (excuse);

dcl  excuse char (*);

	     call sub_err_ (graphic_error_table_$compiler_error, "graphic_compiler_", "h", null, "",
		"^a^/Please contact system maintenance personnel.", excuse);
	     goto non_local_return;
	end sub_err_caller;

recursive_structure:
	err_code = graphic_error_table_$recursive_structure;
	goto non_local_return;

bad_type:	err_code = graphic_error_table_$bad_node;
	goto non_local_return;

not_valid_msgc:
	err_code = graphic_error_table_$not_a_structure;
	goto non_local_return;

non_local_return:
	call cleaner_up;
	return;
%skip (5);
cleaner_up: proc;

	     if auto_temp_seg_ptr ^= null then
		call hcs_$truncate_seg (auto_temp_seg_ptr, 0, 0);
	     return;
	end cleaner_up;
%page;
compile_node: procedure (node_no_arg);

/* Internal procedure compiles the node and dispatches it */

dcl  node_no_arg fixed bin (18) parameter;


	     err_code = 0;

	     if control.return_string then output_string_ptr = return_p;
	     else output_string_ptr = auto_temp_seg_ptr;

	     List_header_chars = Node_begin_char || List_char;
	     Array_header_chars = Node_begin_char || Array_char;
	     Null_node_chars = List_header_chars || zero_node_id;

	     if control.erase then do;
		substr (output_string, 1, length (Erase_char)) = Erase_char;
		outi = length (Erase_char) + 1;	/* Compilation starts at second char */
	     end;
	     else outi = 1;
%skip (5);

/* Here begins the actual compilation of the list structure */

	     unspec (tree.node) = ""b;		/* clear out the tree */

	     tree.level = 0;

/* Initialize the base of the tree */

	     frame_ptr = addr (tree.node (0));
	     tree_frame.id,
		tree_frame.idx,
		tree_frame.max_idx = 0;
	     tree_frame.precollapsed = ""b;
	     tree_frame.environment_wall = "0"b;
	     tree_frame.environment.matrix = Identity_matrix;
	     tree_frame.environment.clipping_boundaries,
		tree_frame.this_level.clipping = Clipping_default;
	     tree_frame.this_level.scaling = Scaling_default;
	     tree_frame.environment.intensity = Intensity_default;
	     tree_frame.environment.linetype = Linetype_default;
	     tree_frame.environment.sensitivity = Sensitivity_default;
	     tree_frame.environment.color = Color_default;
	     tree_frame.active = ""b;

	     if control.from_wgs then
		node_no = node_no_arg;

	     else do;
		if substr (input_string, 1, length (List_header_chars)) = List_header_chars then
		     ini = length (List_header_chars) + 1;
		else if substr (input_string, 1, length (Array_header_chars)) = Array_header_chars then
		     ini = length (Array_header_chars) + 1;
		else goto not_valid_msgc;

		substr (output_string, outi, length (Array_header_chars)) = Array_header_chars;
		outi = outi + length (Array_header_chars);
		substr (output_string, outi, UI_arg_length) = substr (input_string, ini, UI_arg_length);
		outi = outi + UI_arg_length;

		call graphic_code_util_$decode_uid (addr (input_string_array (ini)), 1, node_array);
		ini = ini + UI_arg_length;
	     end;

	     if ^control.from_wgs then do;
		waiting_to_make_array = "1"b;
		position.current,
		     position.desired = 0;
		position.absolute = "0"b;
	     end;

	     call push_level (node_no, waiting_to_make_array);

	     tree_frame.output_array_sentinel = waiting_to_make_array;
%skip (5);

/* Walk the tree, compiling each node and keeping track of the level and environment. */

	     do while (tree.level > 0);

		node_no = tree_frame.id;

/* Trace the structure, popping old detritus as necessary, until we get to a
   new element to examine. */

		if control.from_wgs then
		     do while ((tree_frame.idx ^= 0) & (tree.level > 0)); /* find ONE node */

		     if tree_frame.idx > tree_frame.max_idx then /* we're finished with this list */
			call pop_level;

		     else do;
			node_no = tree_frame.node_p -> list_node.node (tree_frame.idx);
			call push_level (node_no, "0"b); /* we don't know if it's an array yet */
						/* but if so the proper indicator will be set later, not now */
		     end;
		end;

		else do;				/* interpreting input MSGC */
		     done = "0"b;
		     do while (^done);
			if substr (input_string, ini, length (Node_end_char)) = Node_end_char then do;
			     ini = ini + length (Node_end_char);
			     call pop_level;
			end;

			else if substr (input_string, ini, 1) = Node_begin_char then do;
			     ini = ini + length (Node_begin_char);
			     item_environment_wall = (substr (input_string, ini, 1) = Array_char);

			     ini = ini + length (List_char);
			     call graphic_code_util_$decode_uid (addr (input_string_array (ini)), 1, node_array);
			     ini = ini + UI_arg_length;

			     call push_level (node_no, item_environment_wall);
			end;

			else done = "1"b;

			if tree.level <= 0 then done = "1"b;
		     end;
		end;

		if tree.level <= 0 then goto Loop_end;	/* done, drop out of loop */

/* Now compile the new element we have just found. */

		if tree_frame.idx = 0 then tree_frame.idx = 1;
						/* even terminal elements count */

		if node_no = 0 then
		     call compile_null_element;

		else do;				/* must actually compile this node */
		     if control.from_wgs then
			call find_node (node_no, type, node_ptr, contents_p, copy_direct, n_elements);
		     else call decode_effector (ini, type, node_ptr, contents_p, copy_direct, n_elements);

		     effector_char = structural_effector_codes (type);

		     if ^waiting_to_make_array then do; /* put out list header */
			if type = Array then do;	/* this is an array itself */
			     substr (output_string, outi, length (Array_header_chars)) = Array_header_chars;
			     outi = outi + length (Array_header_chars);
			end;
			else do;
			     substr (output_string, outi, length (List_header_chars)) = List_header_chars;
			     outi = outi + length (List_header_chars);
			end;

			call graphic_code_util_$encode_uid (node_array, 1, addr (output_string_array (outi)));
			outi = outi + UI_arg_length;
		     end;


		     goto Type (type);


/* Array */

Type (33):	     if ^waiting_to_make_array then do; /* no one above me is waiting to make one */
			waiting_to_make_array,
			     tree_frame.output_array_sentinel = "1"b;
			position.current, position.desired = 0;
						/* Until seeing abs pos, we will compute using rel pos */
			position.absolute = ""b;
		     end;

		     tree_frame.environment_wall = "1"b;

/* List */

Type (32):	     tree_frame.idx = 1;		/* array drops thru here */
		     tree_frame.node_p = node_ptr;
		     tree_frame.max_idx = n_elements;

		     goto Type_end;

/* Symbol */

Type (24):	     if ^waiting_to_make_array then do;
			call find_node (node_ptr -> symbol_node.name_node, sym_type, sym_p, contents_p, copy_direct, sym_len);

			substr (output_string, outi, length (effector_char)) = effector_char;
			outi = outi + length (effector_char);

			call graphic_code_util_$encode_dpi (addr (sym_len) -> dumaray, 1,
			     addr (output_string_array (outi)));
						/* stick in char string length */
			outi = outi + DPI_arg_length;

			substr (output_string, outi, sym_len) = sym_p -> char_node.string;
			outi = outi + sym_len;
		     end;

/* Now masquerade as an unfinished array by simulating a push-pop and continuing */
		     tree_frame.max_idx = 2;		/* with 2 elements */
		     tree_frame.idx = 2;		/* and have already processed the first */
		     tree_frame.node_p = node_ptr;

		     goto Type_end;

/* Positional effectors */

Type (0):						/* setposition */
Type (1):						/* setpoint */
Type (2):						/* vector */
Type (3):						/* shift */
Type (4):						/* point */
		     if control.from_wgs then do;
			float_buffer (*) = 0e0;
			addr (float_buffer) -> float_contents (*) =
			     contents_p -> float_contents (*);
						/* copy out the data, may be "short" */
			contents_p = addr (float_buffer);
		     end;

		     if waiting_to_make_array then do;

			if tree_frame.active.transformation then
			     call multiply_3x3_x_1x3 (tree_frame.matrix, (float_buffer), float_buffer);

			if type = Setpoint then abs_move_needed = "1"b;
			else if type = Setposition then
			     if ^position.absolute then
				abs_move_needed = "1"b;
			     else abs_move_needed = ""b;
			else abs_move_needed = ""b;

			if abs_move_needed then do;

/* Check for absolute positionings within relative clippings.  No way to
   do this correctly, so complain to the user. */

			     if tree_frame.active.clipping then do;
				err_code = graphic_error_table_$abs_pos_in_clipping;
				goto non_local_return;
			     end;

			     position.absolute = "1"b; /* we know exactly where we want to go, */
			     position.current,	/* but we don't know exactly where we are NOW */
				position.desired = 0; /* so let's get to where we're going */
			     must_put_out = "1"b;	/* while we still remember how to get there */
			end;

			else if tree_frame.environment.intensity = 0 then goto invisible;
						/* no class, but efficiency critical here */
			else if type = Shift then do;
invisible:		     position.desired = position.desired + float_buffer;
			     must_put_out = ""b;	/* skip everything else you can't see */
			end;

			else must_put_out = "1"b;	/* it's visible and relevant */

			if ^must_put_out then goto Type_end;

/* Before we do anything, first get to where we should be starting from. */

			if ^abs_move_needed then call get_to_cur_pos;

/* Now keep track of where the positions will be after we actually compile the element. */

			position.desired = position.desired + float_buffer;
			float_buffer = position.desired - position.current;
			temp_scaled = round (fixed (float_buffer, 35, 8), 6);
			position.current = position.current + temp_scaled;
		     end;

		     call compile_simple_element (effector_char, type, contents_p);
		     goto Type_end;

/* Mapping Effectors */

Type (8):						/* scaling */
		     if control.from_wgs then do;
			float_buffer (*) = 1e-6;
			addr (float_buffer) -> float_contents (*) =
			     contents_p -> float_contents (*);
						/* copy out the data, may be "short" */
			contents_p = addr (float_buffer);
		     end;

		     if waiting_to_make_array then do;
			call collapse_level;

			do i = 1 to 3;
			     if float_buffer (i) = 0e0 then
				float_buffer (i) = 1e-6;
			end;

			do i = 1 to 3;
			     do j = 1 to 3;
				tree_frame.matrix (j, i) = tree_frame.matrix (j, i)
				     * float_buffer (i) / tree_frame.this_level.scaling (i);
			     end;
			end;

			tree_frame.this_level.scaling = float_buffer;

			tree_frame.active.transformation =
			     (unspec (tree_frame.environment.matrix) ^= unspec (Identity_matrix));
		     end;

		     else call compile_simple_element (effector_char, type, contents_p);
		     goto Type_end;

Type (9):						/* rotation */
		     if control.from_wgs then do;
			float_buffer (*) = 0e0;
			addr (float_buffer) -> float_contents (*) =
			     contents_p -> float_contents (*);
						/* copy out the data, may be "short" */
			contents_p = addr (float_buffer);
		     end;

		     if waiting_to_make_array then do;
			call collapse_level;

			fixed_buffer (*) = float_buffer (*);

			call make_matrix (fixed_buffer, tree_frame.this_level.scaling (*), temp_matrix (*, *));

			call multiply_3x3_x_3x3 (tree.node (tree.level - 1).matrix (*, *),
			     temp_matrix (*, *), tree_frame.matrix (*, *)); /* create new master matrix */

			tree_frame.active.transformation =
			     (unspec (tree_frame.environment.matrix) ^= unspec (Identity_matrix));
		     end;

		     else call compile_simple_element (effector_char, type, contents_p);
		     goto Type_end;

Type (10):					/* clipping */

/* WRITE THIS CODE LATER */

		     goto Type_end;


/* Modal effectors */

Type (16):					/* intensity */
		     if waiting_to_make_array then do;
			call collapse_level;
			tree_frame.environment.intensity = fixed_contents (1);
		     end;

		     if tree_frame.environment.intensity > 0 then goto mode_common;
						/* if not in array, will always be "visible" */
		     else goto Type_end;

Type (17):					/* linetype */
		     if waiting_to_make_array then do;
			call collapse_level;
			tree_frame.environment.linetype = fixed_contents (1);
		     end;

		     goto mode_common;

Type (18):					/* sensitivity */
		     if waiting_to_make_array then do;
			call collapse_level;
			tree_frame.environment.sensitivity = fixed_contents (1);
		     end;

		     goto mode_common;

Type (19):					/* blink */
		     if waiting_to_make_array then do;
			call collapse_level;
			tree_frame.environment.blinking = fixed_contents (1);
		     end;

		     goto mode_common;


Type (20):					/* color */
		     if waiting_to_make_array then do;
			call collapse_level;
			tree_frame.environment.color = fixed_contents;
		     end;

mode_common:	     call compile_simple_element (effector_char, type, contents_p);
		     goto Type_end;

/* Text */

Type (25):	     if tree_frame.environment.intensity = 0 then goto Type_end;

		     if waiting_to_make_array then call get_to_cur_pos;
		     call compile_text_element (effector_char, n_elements, contents_p, copy_direct);
		     goto Type_end;

/* Datablock */

Type (26):	     call compile_data_block (effector_char, n_elements, contents_p, copy_direct);
		     goto Type_end;

/* These labels represent node types which are undefined.  If we get here, something is wrong. */

Type (5):
Type (6):
Type (7):
Type (11):
Type (12):
Type (13):
Type (14):
Type (15):
Type (21):
Type (22):
Type (23):
Type (27):
Type (28):
Type (29):
Type (30):
Type (31):	     goto bad_type;

Type_end:
		end;
Loop_end:
	     end;

/* End the actual compilation of the list structure. */
	     if display then do;			/* If displaying... */
		substr (output_string, outi, length (Display_char)) = Display_char; /* ... then stick display command in */
		outi = outi + length (Display_char);
		node_no = node_no_arg;
		call graphic_code_util_$encode_uid (node_array, 1, addr (output_string_array (outi)));
						/* Stick in top level node # */
		outi = outi + UI_arg_length;
	     end;

	     if control.return_string then		/* If returning the compiled string... */
		return_len = outi - 1;		/* Set the length of the string */

	     else do;
write_it:		if control.cur_switch = null then control.cur_switch = graphic_output;

		call iox_$put_chars (control.cur_switch, addr (output_string), outi - 1, err_code);
						/* Write it out */
		if err_code ^= 0 then return;
	     end;

	     return;
%page;
get_to_cur_pos: proc;

dcl  float_temp (3) float bin;

		float_temp = position.desired - position.current;
		temp_scaled = round (fixed (float_temp, 35, 8), 6);

		if unspec (temp_scaled) ^= unspec (scaled_zeroes) then
		     call compile_simple_element (Shift_char, Shift, addr (float_temp));

		position.current = position.current + temp_scaled;
	     end get_to_cur_pos;
%page;
push_level:    proc (node_no, environment_wall);

dcl (node_no fixed bin (18),
     environment_wall bit (1) aligned) parameter;

		if tree.level + 1 > tree.max_level then call grow_tree;
		tree.level = tree.level + 1;
		frame_ptr = addr (tree.node (tree.level));
		tree_frame.id = node_no;
		tree_frame.idx = 0;			/* claim to be working on node itself */
		if control.from_wgs then
		     tree_frame.max_idx = 0;
		else tree_frame.max_idx = max_string_size; /* impossibly large value */
		tree_frame.environment_wall = environment_wall;
		tree_frame.node_p = null;

		tree_frame.this_level.scaling = Scaling_default;
		tree_frame.this_level.clipping = Clipping_default;

		unspec (tree_frame.environment) = unspec (tree.node (tree.level - 1).environment);

		return;
	     end push_level;
%skip (5);
pop_level:     proc;

dcl 1 prev_tree_frame like tree.node aligned based (prev_tree_framep);

dcl  prev_tree_framep pointer;

		if ^tree_frame.precollapsed then do;

		     if (waiting_to_make_array & ^tree_frame.output_array_sentinel) then do;
						/* no need to reset environment if */
						/* all done or returning into list */

			prev_tree_framep = addr (tree.node (tree.level - 1));

/* Pop out of the current graphic environment, restoring previous modes and mappings */
/* Only modes need be explicitly restored, as we hack all the mappings ourselves */

			if tree_frame.environment.intensity ^= prev_tree_frame.environment.intensity then
			     if prev_tree_frame.environment.intensity > 0 then
				call compile_simple_element (Intensity_char, Intensity,
				addr (prev_tree_frame.environment.intensity));

			if tree_frame.environment.linetype ^= prev_tree_frame.environment.linetype then
			     call compile_simple_element (Linetype_char, Linetype,
			     addr (prev_tree_frame.environment.linetype));

			if tree_frame.environment.sensitivity ^= prev_tree_frame.environment.sensitivity then
			     call compile_simple_element (Sensitivity_char, Sensitivity,
			     addr (prev_tree_frame.environment.sensitivity));

			if tree_frame.environment.blinking ^= prev_tree_frame.environment.blinking then
			     call compile_simple_element (Blinking_char, Blinking,
			     addr (prev_tree_frame.environment.blinking));

			if unspec (tree_frame.environment.color) ^= unspec (prev_tree_frame.environment.color) then
			     call compile_simple_element (Color_char, Color,
			     addr (prev_tree_frame.environment.color));
		     end;

		     tree_frame.environment_wall = ""b; /* force the collapse */
		     call collapse_level;
		end;

		tree_frame.precollapsed = ""b;	/* otherwise, mode or mapping as last element */
						/* of array "locks" this frame forever */

		if ^waiting_to_make_array then do;
		     substr (output_string, outi, 1) = Node_end_char;
		     outi = outi + length (Node_end_char);
		end;

		return;
	     end pop_level;
%skip (5);
collapse_level: proc;

		if tree.level <= 0 then
		     call sub_err_caller ("Attempt to pop past start of graphic tree.");

		if tree_frame.precollapsed then return;

		if tree_frame.environment_wall = "1"b then return;

/* Above occurs when attempt is made to collapse past a graphic array, which one shouldn't normally do.
   This will happen when expanding certain old-format MSGC where mappings could appear inside arrays. */

		if tree_frame.output_array_sentinel then do;
		     call get_to_cur_pos;		/* don't optimize trailing position changes away!! */
		     waiting_to_make_array = ""b;
		end;

		unspec (tree_frame) = ""b;		/* clear out level */

		tree.level = tree.level - 1;
		frame_ptr = addr (tree.node (tree.level));

		tree_frame.idx = tree_frame.idx + 1;
						/* move to next item in parent list */
		tree_frame.precollapsed = "1"b;

		return;
	     end collapse_level;
%page;
/* Internal procedure to check that node is in bounds, determine its graphic type and obtain its length */

find_node:     procedure (node_no, type, node_ptr, contents_p, copy_direct, n_elements);

dcl (node_no fixed bin (18),
     type fixed bin,
     n_elements fixed bin,
     copy_direct bit (1) aligned,
     node_ptr pointer,
     contents_p pointer) parameter;

dcl  lsm_type fixed bin;

		copy_direct = ""b;			/* always is for this entry */

		call lsm_$get_blk (wgs_p, node_no, lsm_type, n_elements, node_ptr, err_code);
		if err_code ^= 0 then go to non_local_return;

		if lsm_type > lsm_constants.n_types then goto bad_type;
		if lsm_type < 1 then goto bad_type;

		contents_p = addr (node_ptr -> any_node.data_space);

		goto Type (lsm_type);

Type (8):		type = List;
		return;

Type (9):		type = Array;
		return;

Type (3):						/* float */
Type (2):						/* fixed */
		type = contents_p -> effector.effector_code;
		if (type < Setposition) | (type > Color) then
		     goto bad_type;

		contents_p = addr (contents_p -> effector.data);
		n_elements = n_elements - 1;
		return;

Type (5):		type = Text;			/* char */
		return;

Type (4):		type = Datablock;			/* bit */
		contents_p = node_ptr;
		return;

Type (7):		type = Symbol;
		return;

Type (6):		goto bad_type;			/* symtab */
	     end find_node;
%page;
decode_effector: proc (ini, type, node_p, contents_p, copy_direct, n_elements);

dcl (ini fixed bin (21),
     type fixed bin,
     node_p pointer,
     contents_p pointer,
     copy_direct bit (1) aligned,
     n_elements fixed bin) parameter;

dcl  arg_type fixed bin;

dcl  fixed_contents (3) fixed bin based (contents_p),
     float_contents (3) float bin based (contents_p);

		node_p = null;			/* always is from this entry */
		copy_direct = ""b;			/* generally the case but not always */

		char = substr (input_string, ini, 1);
		ini = ini + 1;
		datap = addr (input_string_array (ini));

		type = index (string (structural_effector_codes), char) - 1;
		if type < 0 then goto not_valid_msgc;
		n_elements = no_args (type);
		arg_type = arg_types (type);
		ini = ini + n_elements * arg_lengths (arg_type);

		goto process (arg_type);

process (1): spi:	contents_p = addr (fixed_buffer);
		call graphic_code_util_$decode_spi (datap, n_elements, fixed_contents);
		return;

process (2): dpi:	contents_p = addr (float_buffer);
		call graphic_code_util_$decode_dpi (datap, n_elements, fixed_buffer);
		float_buffer (*) = fixed_buffer (*);
		return;

process (3): scl:	contents_p = addr (float_buffer);
		if type = Scaling then
		     call graphic_code_util_$decode_scl_nozero (datap, n_elements, float_contents);
		else begin;

/* forgive us this little while lie; graphic_code_util_ is written in ALM and
   couldn't care less about descriptors-- and this misdeclaration knocks 20%
   off this call, which is one of the two most heavily used in the program. */

dcl  graphic_code_util_$decode_scl entry (pointer, fixed bin, float bin dimension (3));

		     call graphic_code_util_$decode_scl (datap, n_elements, float_contents);
		end;
		return;

process (5): t: process (6): d:
		n_elements = graphic_element_length_ (input_string, ini-1) - 1;
		ini = ini + n_elements;		/* got bumped by zero above, do it right */

		if type = Symbol then contents_p = null;

		else do;				/* Text and Datablock */
		     copy_direct = "1"b;
		     contents_p = datap;
		end;

		return;

process (0): process (4):				/* illegal and uid */
		goto not_valid_msgc;

	     end decode_effector;
%page;
compile_null_element: proc;

/* compiles a null node, which is a pretty boring job. */

		if waiting_to_make_array then return;	/* no use fouling the water */
		substr (output_string, outi, length (Null_node_chars)) = Null_node_chars;
		outi = outi + length (Null_node_chars);
		return;
	     end compile_null_element;
%page;
/* Internal procedure to compile a simple node */

compile_simple_element: procedure (effector_char, node_type, contents_p);

dcl  effector_char char (1) parameter,
     node_type fixed bin parameter,
     contents_p pointer parameter;

dcl  fill_p pointer,
     arg_format fixed bin,
     fixed_contents (3) fixed bin based (contents_p),
     float_contents (3) float bin based (contents_p),
     temp_array (3) fixed bin,
    (nargs, nchars) fixed bin;


		if effector_char = Illegal_char then goto bad_type;
		substr (output_string, outi, 1) = effector_char;
		outi = outi + 1;

		fill_p = addr (output_string_array (outi));
		arg_format = arg_types (node_type);
		nargs = no_args (node_type);
		nchars = arg_lengths (arg_format) * nargs;

		go to encode (arg_format);


encode (1): spi:	call graphic_code_util_$encode_spi (fixed_contents, nargs, fill_p);
		go to encode_common;

encode (2): dpi:	temp_array = fixed (float_contents);	/* Float to fixed conversion for floating point coordinates */
		call graphic_code_util_$encode_dpi (temp_array, nargs, fill_p);
		go to encode_common;

encode (3): scl:	begin;

/* See comment at "decode (3): scl:" above. */

dcl  graphic_code_util_$encode_scl entry (float bin dimension (3), fixed bin, pointer);

		     call graphic_code_util_$encode_scl (float_contents, nargs, fill_p);
		end;
		go to encode_common;

encode (4): uid:	call graphic_code_util_$encode_uid (fixed_contents, nargs, fill_p);
		go to encode_common;

encode (5): t: encode (6): d:
		call sub_err_caller ("Attempt to encode text or datablock as simple effector.");

encode_common:	outi = outi + nchars;

		return;

	     end compile_simple_element;
%page;
/* Internal procedure to compile a text node */

compile_text_element: procedure (effector_char, count, contents_p, copy_direct);

dcl  effector_char char (1) parameter,
     count fixed bin parameter,
     contents_p pointer parameter,
     copy_direct bit (1) aligned;

dcl  fixed_array (1) fixed bin,
     to_ptr pointer,
     direct_text_copy char (count) based;

		substr (output_string, outi, 1) = effector_char;
		outi = outi + 1;

		if copy_direct then do;
		     to_ptr = addr (output_string_array (outi));
		     to_ptr -> direct_text_copy = contents_p -> direct_text_copy;
		     outi = outi + count;
		     return;
		end;

		fixed_array (1) = fixed (contents_p -> text_effector.alignment, 17);
		call graphic_code_util_$encode_spi (fixed_array, 1, addr (output_string_array (outi)));
		outi = outi + SPI_arg_length;

		fixed_array (1) = count - 1;
		call graphic_code_util_$encode_dpi (fixed_array, 1, addr (output_string_array (outi)));
						/* Stick in char string length */
		outi = outi + DPI_arg_length;


		substr (output_string, outi, count - 1) = substr (contents_p -> text_effector.text, 1, count - 1);
		outi = outi + count -1;

		return;
	     end compile_text_element;
%page;
/* Internal procedure to compile a data_block node */

compile_data_block: procedure (effector_char, count, contents_p, copy_direct);

dcl (effector_char char (1),
     count fixed bin,
     contents_p pointer,
     copy_direct bit (1) aligned) parameter;

dcl  output_string_bit_array (max_string_size) bit (9) unaligned based (output_string_ptr),
     direct_datablock_copy char (count) based,
     bit_contents bit (count) based (bcp),
     bcp pointer,
     to_ptr pointer,
     fixed_array (1) fixed bin,
     one bit (3) unaligned init ("001"b),
     i fixed bin;

		substr (output_string, outi, 1) = effector_char;
		outi = outi + 1;

		if copy_direct then do;		/* copy direct from old MSGC */
		     to_ptr = addr (output_string_array (outi));
		     to_ptr -> direct_datablock_copy = contents_p -> direct_datablock_copy;
		     outi = outi + count;
		     return;
		end;

		fixed_array (1) = count;		/* else assemble the data from the wgs */
		call graphic_code_util_$encode_dpi (fixed_array, 1, addr (output_string_array (outi)));
		outi = outi + DPI_arg_length;

		bcp = addr (contents_p -> bit_node.string);

		do i = 1 to count -6 by 6;
		     output_string_bit_array (outi) = one || substr (bit_contents, i, 6);
		     outi = outi + 1;
		end;

		output_string_bit_array (outi) = one || substr (bit_contents, i, mod (count, 6));
		outi = outi + 1;

		return;

	     end compile_data_block;

	end compile_node;
%page;
/* Internal procedure gets pointer to current working graphic seg */

initialize: procedure;

	     err_code = 0;

	     if control.from_wgs then do;
		call graphic_manipulator_$segp (wgs_p, err_code); /* Get a ptr to the w.g.s. */
		if err_code ^= 0 then go to non_local_return;
		if wgs_p = null () then do;		/* If no w.g.s. yet */
		     err_code = graphic_error_table_$no_wgs_yet;
		     go to non_local_return;
		end;
	     end;

	     else wgs_p = null;

	     if temp_seg_ptr = null then do;
		call get_temp_segment_ ("graphic_compiler_", temp_seg_ptr, err_code);
		if err_code ^= 0 then goto non_local_return;

		max_string_size = sys_info$max_seg_size * 4;
		sys_area_p = get_system_free_area_ ();
	     end;

	     if tree_ptr = null then call grow_tree;	/* initialize tree */

	     if ^control.return_string then do;
		if control.cur_switch = null then do;
		     call iox_$look_iocb ("graphic_output", graphic_output, err_code);
		     if err_code ^= 0 then goto non_local_return;
		end;

		auto_temp_seg_ptr = temp_seg_ptr;
	     end;

	     else auto_temp_seg_ptr = null;

	end initialize;
%skip (5);
grow_tree: proc;

dcl  i fixed bin,
     current_node fixed bin (18);

	     if tree_ptr ^= null then do;
		current_node = tree.node (tree.level).id;

		do i = tree.level - 1 to 1 by -1;
		     if current_node = tree.node (i).id then goto recursive_structure;
		end;

		max_levels = tree.max_level + 50;	/* increase levels by 50 */
	     end;

	     else max_levels = 10;			/* start with small tree */

	     temp_ptr = tree_ptr;

	     allocate tree in (sys_area);		/* get a bigger tree */

	     if temp_ptr ^= null then do;		/* if there is an old stack */

		unspec (tree_ptr -> tree) = unspec (temp_ptr -> tree);

		free temp_ptr -> tree in (sys_area);	/* get rid of it */

	     end;

	     tree.max_level = max_levels;

	end grow_tree;
%page;

/* Various matrix-hacking routines, stolen from the standalone graphic_matrix_util_. */

make_matrix: proc (rotations, scalings, matrix);		/* construct a graphic rotation/scaling matrix */

dcl  rotations (3) fixed bin parameter,
     scalings (3) float bin parameter,
     matrix (3, 3) float bin parameter;

dcl (sx, cx, sy, cy, sz, cz) float bin;			/* various sines and cosines */

	     cx = cosd (float (rotations (1))); sx = sind (float (rotations (1))); /* get sines and */
	     cy = cosd (float (rotations (2))); sy = sind (float (rotations (2))); /* cosines of angles */
	     cz = cosd (float (rotations (3))); sz = sind (float (rotations (3))); /* for use later on */

	     on underflow;				/* We ignore these */

/* take it on faith: this is a graphic rotation/scaling matrix */

	     matrix (1, 1) = cz * cy * scalings (1);
	     matrix (1, 2) = (-sz * cx + cz * sy * sx) * scalings (2);
	     matrix (1, 3) = (sz * sx + cx * cz * sy) * scalings (3);
	     matrix (2, 1) = cy * sz * scalings (1);
	     matrix (2, 2) = (cz * cx + sx * sy * sz) * scalings (2);
	     matrix (2, 3) = (-sx * cz + cx * sy * sz) * scalings (3);
	     matrix (3, 1) = -sy * scalings (1);
	     matrix (3, 2) = sx * cy * scalings (2);
	     matrix (3, 3) = cy * cx * scalings (3);

	     return;

multiply_3x3_x_3x3: entry (left_matrix, right_matrix, matrix); /* is a comment really necessary? */

dcl (left_matrix, right_matrix) (3, 3) float bin parameter;

dcl (i, j) fixed bin;

	     on underflow;

	     do i = 1 to 3;
		do j = 1 to 3;
		     matrix (i, j) = sum (left_matrix (i, *) * right_matrix (*, j)); /* 'cause the CRC says. */
		end;
	     end;

	     return;

multiply_3x3_x_1x3: entry (left_matrix, right_vector, vector);

dcl (right_vector, vector) (3) float bin parameter;

	     on underflow;				/* These are the bane of graphics programs */
	     do i = 1 to 3;
		vector (i) = sum (left_matrix (i, *) * right_vector); /* same principle */
	     end;

	     return;

	end make_matrix;

     end graphic_compiler_;
   



		    graphic_decompiler_.pl1         11/18/82  1706.7rew 11/18/82  1625.4      136656


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_decompiler_: proc (graphic_code, code) returns (fixed bin (18));

/* graphic_decompiler_ takes Multics Graphics Code and makes it into graphic structures. */
/* Written 3/19/75 by C. D. Tavares */
/* Last modified 03/25/80 by CDT to check for too many elements in a single list or array
   and to replace two signal statements with calls to sub_err_ */

/* -- PARAMETERS -- */

dcl  graphic_code char (*) parameter,
     code fixed bin (35) parameter;

/* -- EXTERNAL ENTRIES -- */

dcl (graphic_code_util_$decode_spi,
     graphic_code_util_$decode_dpi) ext entry (pointer, fixed bin, (*) fixed bin),
     graphic_code_util_$decode_uid ext entry (pointer, fixed bin, (*) fixed bin (18)),
     graphic_code_util_$decode_scl ext entry (pointer, fixed bin, (*) float bin);

dcl  graphic_element_length_ ext entry (char (*), fixed bin) returns (fixed bin);

dcl  sub_err_ ext entry options (variable);

/* -- EXTERNAL VARIABLES -- */

dcl (graphic_error_table_$unrecognized_effector,
     graphic_error_table_$incomplete_structure,
     graphic_error_table_$lsm_blk_len,
     graphic_error_table_$node_list_overflow,
     graphic_error_table_$impossible_effector_length,
     graphic_error_table_$not_a_structure) ext fixed bin (35);

/* -- STATIC -- */

dcl 1 node_table static aligned,
    2 number_known_nodes fixed bin initial (0),
    2 known_nodes (200) aligned,
      3 input_node fixed bin (18),
      3 wgs_node fixed bin (18);

/* -- AUTOMATIC -- */

dcl  first_element_offset fixed bin;

/* -- BUILTINS -- */

dcl (addr, divide, hbound, index, length, null, string, substr, unspec) builtin;
%page;
%include graphic_code_dcl;
%page;
%include lsm_formats;
%page;
	call graphic_manipulator_$segp (null, code);	/* see if WGS exists */
	if code ^= 0 then return (-1);		/* tsk tsk */

	if substr (graphic_code, 1, 1) ^= Node_begin_char then do; /* it must be that */
bad_struc:     code = graphic_error_table_$not_a_structure; /* complain */
error_return:  return (-1);				/* farewell */
	end;

	first_element_offset = graphic_element_length_ (graphic_code, 1);
						/* This is the char offset of the first element of any list.
						   It is used to compute whether the first element of a list
						   is another list, etc. */

	number_known_nodes = 0;			/* initialize state variables */

	return (graphic_decompiler_recur (graphic_code, 1)); /* pass it off to a friend */


graphic_decompiler_recur: proc (graphic_code, start) returns (fixed bin (18)) recursive;

/* -- PARAMETERS -- */

dcl  graphic_code char (*) parameter,
     start fixed bin parameter;

/* -- BASED VARIABLES, THEIR POINTERS, AND LENGTHS -- */

dcl  contents_len fixed bin,
     contents_ptr pointer;

dcl  char_array (0:1000) char (1) unaligned based;

/* -- AUTOMATIC -- */

dcl  finished bit (1) aligned initial (""b);

dcl  ID fixed bin;

dcl  graphic_code_index fixed bin,
     node fixed bin (18),
     element fixed bin (18),
     this_list_index fixed bin initial (0),
     fixed_array (6) fixed bin,
     float_array (3) float bin;

dcl  this_input_node fixed bin (18) initial (-1),
    (we_are_list, we_are_array) bit (1) aligned initial (""b);

dcl  i fixed bin,
     ch char (1) aligned;

dcl  this_list (lsm_constants.max_allocation) fixed bin (18);

dcl  len fixed bin;


	     do graphic_code_index = start to length (graphic_code) while (^finished);
						/* loop through whole string of MSGC */

		ch = substr (graphic_code, graphic_code_index, 1); /* get the effector character */
		contents_ptr = addr (addr (graphic_code) -> char_array (graphic_code_index));
						/* get ptr to this effectors arguments */
		contents_len = graphic_element_length_ (graphic_code, graphic_code_index) - 1;

		ID = index (string (Graphic_effectors), ch); /* see if it is a graphic effector */
		if ID > 0 then do;			/* yes it is, do: */
		     element = decompile_graphic_effector (ID); /* make a node of it */
		     goto endloop;
		end;

		ID = index (string (Dynamic_and_structural_effectors), ch); /* see if it's one of those */
		if ID > 0 then do;			/* yes it is */
		     element = decompile_structural_effector (ID); /* etc. */
		     goto endloop;
		end;

		ID = index (string (Mapping_effectors), ch); /* is it a map? */
		if ID > 0 then do;
		     element = decompile_mapping_effector (ID);
		     goto endloop;
		end;

		ID = index (string (Mode_effectors), ch); /* A mode?? */
		if ID > 0 then do;
		     element = decompile_mode_effector (ID);
		     goto endloop;
		end;

		ID = index (string (Special_effectors), ch); /* A special???? */
		if ID > 0 then do;
		     element = decompile_special_effector (ID);
		     goto endloop;
		end;

		code = graphic_error_table_$unrecognized_effector; /* Ai; no kapitsch! */
		goto error_return;

endloop:
		if element ^= -1 then do;		/* then we should add it to list */
		     this_list_index = this_list_index + 1;
		     if this_list_index > hbound (this_list, 1) then do;
			code = graphic_error_table_$lsm_blk_len;
			goto error_return;
		     end;
		     this_list (this_list_index) = element;
		end;

		graphic_code_index = graphic_code_index + contents_len; /* waddle thru string */
	     end;

	     if ^finished then do;			/* incomplete structure, guys */
		code = graphic_error_table_$incomplete_structure;
		goto error_return;
	     end;

	     if we_are_list | we_are_array then do;	/* make a list/array of us */
		if we_are_array then node = graphic_manipulator_$create_array (this_list, this_list_index, code);
		else node = graphic_manipulator_$create_list (this_list, this_list_index, code);
		if code ^= 0 then goto error_return;
	     end;

	     else do;
		if this_list_index > 1 then		/* multiple and not a list?? */
		     call sub_err_ (graphic_error_table_$impossible_effector_length, "graphic_decompiler_", "h", null, 0,
		     "A multiple element was encountered which was neither a list nor an array.");
		node = this_list (1);		/* we are a single element, flaunt it */
	     end;

	     do i = 1 to number_known_nodes while (known_nodes (i).input_node ^= this_input_node);
						/* see if anybody we already know has our node number */
	     end;

	     if i > number_known_nodes then do;		/* nope, we're safe, add us */
		if number_known_nodes + 1 > hbound (known_nodes, 1) then
		     call sub_err_ (graphic_error_table_$node_list_overflow, "graphic_decompiler_", "c", null, 0,
		     "More than ^d distinct nodes encountered.", hbound (known_nodes, 1));
						/* So far, BIG structures haven't bombed us yet */
		else do;
		     number_known_nodes = number_known_nodes + 1;
		     known_nodes (number_known_nodes).input_node = this_input_node;
		     known_nodes (number_known_nodes).wgs_node = node;
		end;
	     end;

	     else if known_nodes (i).wgs_node ^= node then do; /* i.e. don't do this for symbol nodes! */
						/* Replacements of symbols will always recur, otherwise */
		call graphic_manipulator_$replace_node (known_nodes (i).wgs_node, node, code);
						/* replace the old copy with our "new" contents */
		if code ^= 0 then goto error_return;
		known_nodes (i).wgs_node = node;	/* remember our new address */
	     end;

	     start = graphic_code_index;		/* tell possible recursive parents what we have eaten */

	     return (node);				/* present our result */


decompile_graphic_effector: proc (ID) returns (fixed bin (18));

dcl  ID fixed bin;

		if we_are_list then goto bad_struc;	/* each of us must be an island */

		call graphic_code_util_$decode_scl (contents_ptr, 3, float_array); /* get our arguments */

		node = graphic_manipulator_$create_position (ID-1, float_array (1), float_array (2),
		     float_array (3), code);		/* create the effector */
		if code ^= 0 then goto error_return;

		return (node);

	     end decompile_graphic_effector;


decompile_mode_effector: proc (ID) returns (fixed bin (18));

dcl  ID fixed bin;

		if we_are_list then goto bad_struc;	/* we must all be our own lists */

		if ID = 5 then len = 3;		/* color effector */
		else len = 1;			/* everything else */

		call graphic_code_util_$decode_spi (contents_ptr, len, fixed_array); /* get our args */

		if len ^= 3
		then node = graphic_manipulator_$create_mode (15+ID, fixed_array (1), code);
		else node = graphic_manipulator_$create_color (fixed_array (1), fixed_array (2), fixed_array (3), code);
						/* make the node */

		if code ^= 0 then goto error_return;
		return (node);

	     end decompile_mode_effector;

decompile_mapping_effector: proc (ID) returns (fixed bin (18));

dcl  ID fixed bin;

		if we_are_list then goto bad_struc;	/* see above */

		goto decompile_mapping (ID);

decompile_mapping (1):				/* scaling */
		call graphic_code_util_$decode_scl (contents_ptr, 3, float_array);

		node = graphic_manipulator_$create_scale (float_array (1), float_array (2), float_array (3), code);
		if code ^= 0 then goto error_return;

		return (node);

decompile_mapping (2):				/* rotation */
		call graphic_code_util_$decode_dpi (contents_ptr, 2, fixed_array);
		node = graphic_manipulator_$create_rotation ((fixed_array (1)), (fixed_array (2)), (fixed_array (3)), code);
		if code ^= 0 then goto error_return;

		return (node);

decompile_mapping (3):				/* clipping */
		call graphic_code_util_$decode_dpi (contents_ptr, 6, fixed_array);
		node = graphic_manipulator_$create_clip ((fixed_array (1)), (fixed_array (2)), (fixed_array (3)),
		     (fixed_array (4)), (fixed_array (5)), (fixed_array (6)), code);
		if code ^= 0 then goto error_return;

		return (node);

	     end decompile_mapping_effector;


decompile_special_effector: proc (ID) returns (fixed bin (18));

dcl  ID fixed bin;

dcl  symbol_name char (168);

dcl  i fixed bin;

dcl  temp_string bit (temp_string_len) based (p),
     p pointer,
     temp_string_len fixed bin,
     cu_$grow_stack_frame ext entry (fixed bin, pointer, fixed bin (35)),
     cu_$shrink_stack_frame ext entry (pointer, fixed bin (35));

		if we_are_list then goto bad_struc;

		goto special_effector (ID);

special_effector (1):				/* symbol */
		symbol_name = substr (graphic_code, graphic_code_index + 3, contents_len - 2);

		graphic_code_index = graphic_code_index + contents_len + 1;

		node = graphic_decompiler_recur (graphic_code, graphic_code_index);
						/* recur but remember symbol */

		node = graphic_manipulator_$assign_name (symbol_name, (node), code);
						/* now use the symbol name */
		if code ^= 0 then goto error_return;

		contents_len = -1;			/* Back up to correct for son's appetite */
		return (node);

special_effector (2):				/* text */
		call graphic_code_util_$decode_spi (contents_ptr, 1, fixed_array);
		node = graphic_manipulator_$create_text (fixed_array (1), contents_len - 3,
		     substr (graphic_code, graphic_code_index + 4, contents_len - 3), code);
		if code ^= 0 then goto error_return;

		return (node);

special_effector (3):				/* datablock */
		temp_string_len = (contents_len - 2) * 9; /* compute length of temp string */

		call cu_$grow_stack_frame (divide (temp_string_len, 36, 17), p, code);
						/* get temp storage for temp string */
		if code ^= 0 then goto error_return;

		temp_string = unspec (substr (graphic_code, graphic_code_index + 3, contents_len - 2));
						/* move it into temp storage */

		do i = 0 to contents_len - 3;		/* extract the relevant bits */
		     substr (temp_string, i*6+1, 6) = substr (temp_string, i*9+4, 6);
		end;

		temp_string_len = (contents_len - 2) * 6; /* reset the length to reflect useful contents */
		node = graphic_manipulator_$create_data (temp_string_len, temp_string, code);
		if code ^= 0 then goto error_return;

		call cu_$shrink_stack_frame (p, code);	/* free temp storage */
		if code ^= 0 then goto error_return;

		return (node);

	     end decompile_special_effector;


decompile_structural_effector: proc (ID) returns (fixed bin (18));

dcl  ID fixed bin;

dcl  uid (1) fixed bin (18);

		goto structural_effector (ID);

structural_effector (1): structural_effector (3): structural_effector (4): structural_effector (7):
structural_effector (8): structural_effector (9): structural_effector (10): structural_effector (11):
structural_effector (12):				/* dynamic effectors */
		code = graphic_error_table_$not_a_structure; /* these can't BE within a structure */
		goto error_return;

structural_effector (2):				/* reference */
		if ^we_are_list then if start + first_element_offset ^= graphic_code_index
		     then goto bad_struc;		/* i.e. we can't occur in an array. */
		we_are_list = "1"b;			/* say we are */

		call graphic_code_util_$decode_uid (contents_ptr, 1, uid); /* get the arg */

		do i = 1 to number_known_nodes while (known_nodes (i).input_node ^= uid (1));
						/* make sure we know about this node */
		end;

		if i > number_known_nodes		/* node does not exist, can't be "reference"d */
		then do;
		     code = graphic_error_table_$not_a_structure;
		     goto error_return;
		end;

		return (uid (1));			/* we're happy. */

structural_effector (5):				/* node begin */
		if graphic_code_index = start then do;	/* begins our own level list */
		     we_are_array = (substr (graphic_code, graphic_code_index + 1, 1) = Array_char);
						/* decide whether we are array or list */

		     contents_ptr = addr (contents_ptr -> char_array (1)); /* bump to point to next char */

		     call graphic_code_util_$decode_uid (contents_ptr, 1, uid); /* get our UID */
		     this_input_node = uid (1);	/* this is who we are now. */

		     return (-1);			/* means, "Don't have any contents yet" */
		end;

		else do;				/* we must recur and decompile it */
		     if ^we_are_list then if start + first_element_offset ^= graphic_code_index
			then goto bad_struc;	/* A list must contain only lists */

		     if we_are_array then goto bad_struc; /* an array cannot contain lists */

		     we_are_list = "1"b;		/* say we are now list */

		     node = graphic_decompiler_recur (graphic_code, graphic_code_index);
						/* generate a son to do work on subtree */

		     contents_len = -1;		/* adjust for son's appetite */

		     return (node);
		end;

structural_effector (6):				/* node end */
		finished = "1"b;			/* make note to create array or list */
		return (-1);

	     end decompile_structural_effector;

	end graphic_decompiler_recur;

%include gm_entry_dcls;

     end graphic_decompiler_;



		    graphic_dim_.pl1                11/18/82  1706.7rew 11/18/82  1625.4      469368


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */
graphic_dim_: proc; return;

/* This routine is a graphic device interface module.
   It handles both dynamic and static devices.		*/

/* Written on July 1, 1973 by C. D. Tavares
   Modified 08/79 by CDT to use get_temp_segments_
   Modified 04/25/80 by CDT to replace random signals with calls to sub_err_.
   Modified 08/26/80 by CDT to fix bug leaving user in rawo if GSP close entry
   did any output.  The fix was wrong, by the way, but fixed on 11/18/80.
   Last modified 11/18/80 by CDT-- totally rewritten, and two-pass MSGC parsing
   with blocked, interleaved output implemented.
*/


/* STATIC */

dcl  1 static_stuff	        static,
       2 sys_area_p	        pointer initial (null),
       2 first_dsb_ptr      pointer initial (null),
       2 stack_p	        pointer initial (null),
       2 stack_size	        fixed bin initial (0),
       2 max_string_size    fixed bin (21) fixed bin initial (0),
       2 noecho_mode        char (40)
		        initial ("^echoplex,^tabecho,^crecho,^lfecho,rawi"),
       2 rawo_mode	        char (12) initial ("rawo."),
       2 rawi_mode	        char (16) initial ("^can,^esc,^erkl");

/* we use ^can,^esc,^erkl instead of rawi because ttydim doesn't always wait
   for newlines in rawi mode also because ARPANET software doesn't honor
   rawi. */


/* BASED */

dcl  1 switch_data_block    based (sdb_ptr),
       2 target_switch_ptr  pointer,
       2 graphic	        bit (1),
       2 device_state_block_ptr
		        pointer,
       2 from_switch        char (32),
       2 n_buffers	        fixed bin,
       2 output_buffer_ptr  pointer,
       2 expansion_buffer_ptr
		        pointer,
       2 node_table_ptr     pointer,
       2 n_nodes_in_list    fixed bin,
       2 status_buffer      char (100),
       2 attach_description char (128) varying,
       2 open_description   char (64) varying,
       2 atd_len_no_gdt     fixed bin;

dcl  1 device_state_block   based (cur_dsb_ptr),
       2 in_rawo_mode       bit (1),
       2 gdt_ptr	        pointer,
       2 gdt_name	        char (32),
       2 gdt_proc	        entry (fixed bin, char (*), char (*),
		        fixed bin (21), pointer, fixed bin (35)) variable,
       2 gdt_opened	        bit (1),
       2 dynamic	        bit (1),
       2 gdt_message_size   fixed bin (21),
       2 reference_count    fixed bin,
       2 switch_name        char (32),
       2 target_ptr	        pointer,
       2 old_output_modes   char (512) initial (""),
       2 old_input_modes    char (512) initial (""),
       2 gdt_data_ptr       pointer,
       2 next_dsb_ptr       pointer;

dcl  based_buffer_ptrs      (switch_data_block.n_buffers) pointer
		        based (addr (switch_data_block.output_buffer_ptr)),
     char_array	        (static_stuff.max_string_size)
		        char (1) unaligned based,
     output_buffer	        char (max_string_size)
		        based (switch_data_block.output_buffer_ptr),
     sys_area	        area based (sys_area_p);


/* ENTRIES */

dcl  com_err_	        ext entry options (variable),
     expand_pathname_       ext entry
		        (char (*), char (*), char (*), fixed bin (35)),
     find_command_$fc_no_message
		        ext entry
		        (pointer, fixed bin, pointer, fixed bin (35)),
     get_system_free_area_  ext entry returns (pointer),
     get_temp_segments_     ext entry
		        (char (*), pointer dimension (*), fixed bin (35)),
     graphic_compiler_$expand_string
		        entry
		        (char (*), fixed bin (21), ptr, fixed bin (21),
		        fixed bin (35)),
     graphic_element_length_
		        entry
		        (char (*), fixed bin (21)) returns (fixed bin),
     graphic_terminal_status_$decode
		        ext entry (char (*), fixed bin (35)),
     hcs_$make_entry        ext entry
		        (ptr, char (*), char (*), entry, fixed bin (35)),
     ioa_$rsnnl	        ext entry options (variable),
     ipc_$mask_ev_calls     ext entry (fixed bin (35)),
     ipc_$unmask_ev_calls   ext entry (fixed bin (35)),
     release_temp_segments_ ext entry
		        (char (*), pointer dimension (*), fixed bin (35)),
     sub_err_	        ext entry options (variable);

/* EXTERNAL STATIC */

dcl  (error_table_$bad_index,
     error_table_$badopt,
     error_table_$invalid_mode,
     error_table_$long_record,
     error_table_$negative_nelem,
     error_table_$noarg,
     error_table_$not_attached,
     error_table_$not_detached,
     error_table_$unimplemented_version)
		        fixed bin (35) external static;

dcl  (graphic_error_table_$gdt_missing,
     graphic_error_table_$impossible_effector_length,
     graphic_error_table_$incomplete_structure,
     graphic_error_table_$invalid_node_no,
     graphic_error_table_$node_not_active,
     graphic_error_table_$nongraphic_switch,
     graphic_error_table_$not_a_gdt,
     graphic_error_table_$recursive_structure,
     graphic_error_table_$too_many_node_ends,
     graphic_error_table_$unimplemented_effector,
     graphic_error_table_$unrecognized_effector)
		        fixed bin (35) external static;

dcl  sys_info$max_seg_size  fixed bin (35) external static;

/* CONDITIONS */

dcl  cleanup	        condition;

/* BUILTINS */

dcl  (addr, before, binary, dim, hbound, index, length, max, min, null,
     rank, rtrim, string, substr, unspec)
		        builtin;
%page;
%include iox_dcls;
%page;
%include iocbv;
%page;
%include iox_modes;
%page;
%include graphic_device_table;
%page;
%include graphic_code_dcl;
%page;
%include io_call_info;
%page;
graphic_dim_attach: entry (iocb_ptr, option_array, com_err_sw, code);

/* PARAMETERS */

dcl  (iocb_ptr	        pointer,
     option_array	        (*) char (*) varying,
     com_err_sw	        bit (1) aligned,
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  cur_dsb_ptr	        pointer,
     found	        bit (1),
     gdt_name_copy	        char (168),
     output_buffer_outdx    fixed bin (21),
     sdb_ptr	        pointer,
     tp		        pointer;


	sdb_ptr, cur_dsb_ptr = null;

	if iocb.attach_descrip_ptr ^= null then		/* switch in use */
	     call attach_error (error_table_$not_detached);

	if static_stuff.sys_area_p = null then do;	/* initialize it */
		static_stuff.sys_area_p = get_system_free_area_ ();
		static_stuff.max_string_size = sys_info$max_seg_size * 4;
	     end;

	allocate switch_data_block in (sys_area) set (sdb_ptr);

/* Locate the switch which we will be talking to for this attachment. */

	call iox_$find_iocb ((option_array (1)),
	     switch_data_block.target_switch_ptr, code);
	if code ^= 0 then call attach_error (code);

/* Try to find the device state block, if any, already associated with our
   target switch. */

	do tp = static_stuff.first_dsb_ptr repeat (tp -> next_dsb_ptr)
	     while (tp ^= null & cur_dsb_ptr = null);

	     if tp -> device_state_block.switch_name = option_array (1) then
		cur_dsb_ptr = tp;
	end;

/* If we have found an existing dsb, then use it. */

	if cur_dsb_ptr ^= null then do;
		device_state_block.target_ptr =
		     switch_data_block.target_switch_ptr;
		device_state_block.reference_count =
		     device_state_block.reference_count + 1;
	     end;

/* If no dsb for this target switch, create one. */

	else do;
		allocate device_state_block in (sys_area);

		device_state_block.switch_name = option_array (1);
		device_state_block.gdt_ptr,
		     device_state_block.gdt_data_ptr,
		     device_state_block.next_dsb_ptr = null;
		device_state_block.gdt_name = "";
		device_state_block.gdt_proc = not_setup;
		device_state_block.gdt_opened,
		     device_state_block.dynamic,
		     device_state_block.in_rawo_mode = ""b;
		device_state_block.gdt_message_size =
		     static_stuff.max_string_size;
		device_state_block.reference_count = 1;

		if static_stuff.first_dsb_ptr = null then
		     static_stuff.first_dsb_ptr = cur_dsb_ptr;
		else tp -> device_state_block.next_dsb_ptr = cur_dsb_ptr;
	     end;

	switch_data_block.device_state_block_ptr = cur_dsb_ptr;

	switch_data_block.from_switch = iocb.name;
	switch_data_block.output_buffer_ptr,
	     switch_data_block.expansion_buffer_ptr,
	     switch_data_block.node_table_ptr = null;
	switch_data_block.n_nodes_in_list = 0;
	switch_data_block.status_buffer = "";

	if hbound (option_array, 1) < 2 then
	     switch_data_block.graphic = ""b;
	else if option_array (2) = "graphic" then
	     switch_data_block.graphic = "1"b;
	else if option_array (2) = "^graphic" then
	     switch_data_block.graphic = ""b;
	else call attach_error (error_table_$badopt);

	if switch_data_block.graphic then switch_data_block.n_buffers = 2;
	else switch_data_block.n_buffers = 1;

	call get_temp_segments_
	     (temp_seg_name ("graphic_dim_", switch_data_block.from_switch),
	     based_buffer_ptrs, code);
	if code ^= 0 then call attach_error (code);

	switch_data_block.attach_description =
	     "graphic_dim_ " || option_array (1);
	if switch_data_block.graphic then
	     attach_description = attach_description || " graphic";
	switch_data_block.atd_len_no_gdt =
	     length (switch_data_block.attach_description);

	if hbound (option_array, 1) > 2 then do;
		gdt_name_copy = option_array (3);
		call associate_gdt (gdt_name_copy, code);
		if code ^= 0 then call attach_error (code);
	     end;

	iocb.attach_descrip_ptr = addr (attach_description);
	iocb.attach_data_ptr = sdb_ptr;

	iocb.open = graphic_dim_open;
	iocb.detach_iocb = graphic_dim_detach;

	code = 0;

	call iox_$propagate (iocb_ptr);

	return;
%skip (3);
attach_error: proc (code);

dcl  code		        fixed bin (35) parameter;

	if com_err_sw then call com_err_ (code, "graphic_dim_", "");

	if sdb_ptr ^= null then do;
		if cur_dsb_ptr ^= null then
		     if device_state_block.reference_count = 1 then
			call free_dsb (cur_dsb_ptr);
		if switch_data_block.output_buffer_ptr ^= null then
		     call release_temp_segments_
			(temp_seg_name ("graphic_dim_",
			switch_data_block.from_switch),
			based_buffer_ptrs, 0);
		free switch_data_block in (sys_area);
	     end;
	goto attach_error_return;
     end attach_error;

attach_error_return:
	return;
%skip (3);
temp_seg_name: proc (prefix, suffix) returns (char (32));

dcl  (prefix, suffix)       char (*) parameter,
     char32	        char (32) varying;

	char32 = prefix;
	char32 = char32 || " ";
	char32 = char32 || suffix;
	return (char32);
     end temp_seg_name;
%skip (3);
free_dsb: proc (dsb_ptr);

/* PARAMETERS */

dcl  dsb_ptr	        pointer parameter;

/* AUTOMATIC */

dcl  found	        bit (1),
     prev_tp	        pointer,
     tp		        pointer;


	found = ""b;				/* begin to search for block */

/* is this dsb first one on the chain? */

	if dsb_ptr = static_stuff.first_dsb_ptr then do;
		found = "1"b;
		prev_tp = null;
	     end;

/* otherwise, chain down blocks until this dsb found */

	do tp = static_stuff.first_dsb_ptr
	     repeat (tp -> device_state_block.next_dsb_ptr)
	     while (tp ^= null & ^found);
	     prev_tp = tp;
	     if tp -> device_state_block.next_dsb_ptr = dsb_ptr then
		found = "1"b;
	end;

	if ^found then
	     call sub_err_ (error_table_$bad_index, "graphic_dim_", "s",
		null, 0,
		"Cannot find chain predecessor to DSB for ^a.",
		device_state_block.switch_name);	/* stop cold */

/* rechain the chain around this block */

	tp = prev_tp;

	if tp = null then
	     static_stuff.first_dsb_ptr = dsb_ptr -> next_dsb_ptr;
	else tp -> next_dsb_ptr = dsb_ptr -> next_dsb_ptr;


	free dsb_ptr -> device_state_block in (sys_area); /* wham. */

	return;

     end free_dsb;
%skip (3);
associate_gdt: proc (table_name, code);

/* PARAMETERS */

dcl  (table_name	        char (*),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  gdt_entrypoint_name    char (168),
     gdt_ptr	        pointer;

/* BASED */

dcl  1 gdt	        like graphic_device_table aligned based (gdt_ptr);


	if ^switch_data_block.graphic then do;
		code = graphic_error_table_$nongraphic_switch;
		return;
	     end;

/* Find the GDT to be used.  Get a pointer to the start of the table. */

	gdt_entrypoint_name = before (table_name, " ") || "$table_start";

	call find_command_$fc_no_message (addr (gdt_entrypoint_name),
	     length (gdt_entrypoint_name), gdt_ptr, code);
	if code ^= 0 then return;

	if gdt.version_number ^= gdt_version_2 then
	     if gdt.version_number ^= 1 then do;
		     code = error_table_$unimplemented_version;
		     return;
		end;

/* version 1 OK-- differs only in existence of "modes" call */

	if gdt.terminal_type ^= "dyna" then
	     if gdt.terminal_type ^= "stat" then do;	/* must be one! */
		     code = graphic_error_table_$not_a_gdt;
		     return;
		end;

	device_state_block.gdt_ptr = gdt_ptr;

	device_state_block.dynamic = (gdt.terminal_type = "dyna");
	device_state_block.gdt_message_size = gdt.message_size;
	call expand_pathname_
	     (table_name, "", device_state_block.gdt_name, 0);

	switch_data_block.attach_description =
	     substr (switch_data_block.attach_description, 1,
	     switch_data_block.atd_len_no_gdt)
	     || " " || device_state_block.gdt_name;

	call hcs_$make_entry (gdt_ptr, (device_state_block.gdt_name),
	     "gdt_proc", device_state_block.gdt_proc, code);
	if code ^= 0 then return;

/* open the GDT now, unless this switch is not yet opened itself. */

	if iocb.open_descrip_ptr ^= null then
	     call try_to_open_gdt (gdt_ptr, code);

	return;

     end associate_gdt;
%skip (3);
try_to_open_gdt: proc (gdt_ptr, code);

/* PARAMETERS */

dcl  (gdt_ptr	        pointer,
     code		        fixed bin (35)) parameter;

/* BASED */

dcl  1 gdt	        like graphic_device_table aligned based (gdt_ptr);


	if ^device_state_block.gdt_opened then
	     if gdt.effector_data (Open).call then do;
		     call gdt_caller
			(Open, device_state_block.switch_name, code);
		     if code ^= 0 then return;

		     call force_out_buffer ("1"b, code);
		     if code ^= 0 then return;
		end;

	device_state_block.gdt_opened = "1"b;
	return;

     end try_to_open_gdt;
%page;
not_setup: entry (a_effnum, a_instring, a_obuffer, a_nchars, a_statptr, code);

/* This entry exists for the sole purpose of returning an error code.  It is
   called only by mistake when somebody tries to call an entry in the GSP at
   a time when no GDT is yet been associated with the I/O switch. */

/* PARAMETERS */

dcl  (a_effnum	        fixed bin,
     a_instring	        char (*),
     a_obuffer	        char (*),
     a_nchars	        fixed bin (21),
     a_statptr	        pointer) parameter;

	code = graphic_error_table_$gdt_missing;
	return;
%skip (5);
no_entry: entry (a_effnum, a_instring, a_obuffer, a_nchars, a_statptr, code);

/* This entry exists because the graphic_dim_ occasionally tries to "call" an
   operator which has not been given the "call" attribute in the gdt.  (This
   is the default entry that compile_gdt places in the GDT if no call is
   specified.)  Yes, this is dirty.  However, graphic_dim_ only tries to call
   the Prepare_for_graphics and Prepare_for_text entries without actually
   checking if they are callable.  These really should have either the "call"
   or the "ignore"attribute on - others make no sense.  */

	code = 0;
	return;
%page;
graphic_dim_open: entry (iocb_ptr, open_mode, ignore, code);

/* PARAMETERS */

dcl  (open_mode	        fixed bin,
     ignore	        bit (1)) parameter;

	call setup;

	if (open_mode ^= Stream_input)
	     & (open_mode ^= Stream_output)
	     & (open_mode ^= Stream_input_output) then do;
		code = error_table_$invalid_mode;
		return;
	     end;

	if open_mode ^= Stream_input then
	     actual_iocb_ptr -> iocb.put_chars = graphic_dim_write;

	if open_mode ^= Stream_output then do;
		actual_iocb_ptr -> iocb.get_line = graphic_dim_get_line;
		if ^switch_data_block.graphic then
		     actual_iocb_ptr -> get_chars = graphic_dim_get_chars;
	     end;

	actual_iocb_ptr -> iocb.modes = graphic_dim_changemode;
	actual_iocb_ptr -> iocb.control = graphic_dim_order;
	actual_iocb_ptr -> iocb.close = graphic_dim_close;

	switch_data_block.open_description = iox_modes (open_mode);
	iocb.open_descrip_ptr = addr (open_description);

	call iox_$propagate (actual_iocb_ptr);

	if switch_data_block.graphic then
	     call try_to_open_gdt
		(switch_data_block.device_state_block_ptr ->
		device_state_block.gdt_ptr, code);

	return;
%skip (3);
setup: proc;

	sdb_ptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	cur_dsb_ptr = switch_data_block.device_state_block_ptr;
	gdt_pointer = device_state_block.gdt_ptr;
	output_buffer_outdx = 0;
	code = 0;

	return;

     end setup;
%page;
graphic_dim_close: entry (iocb_ptr, code);

	call setup;

	if switch_data_block.graphic then do;

		if device_state_block.gdt_opened then do;
			if device_state_block.in_rawo_mode then do;
				call get_to_text_mode (code);
				if code ^= 0 then return;
			     end;
			if graphic_device_table.effector_data (Close).call
			then do;
				call gdt_caller (Close,
				     device_state_block.switch_name, code);
				if code ^= 0 then return;

				call force_out_buffer ("1"b, code);
				if code ^= 0 then return;

				device_state_block.gdt_opened = ""b;
			     end;
		     end;
	     end;

	actual_iocb_ptr -> iocb.open_descrip_ptr = null;

	actual_iocb_ptr -> iocb.detach_iocb = graphic_dim_detach;
	actual_iocb_ptr -> iocb.open = graphic_dim_open;
	actual_iocb_ptr -> iocb.control = iox_$err_no_operation;

	call iox_$propagate (actual_iocb_ptr);

	code = 0;

	return;
%page;
graphic_dim_detach: entry (iocb_ptr, code);

	call setup;

	call release_temp_segments_
	     (temp_seg_name ("graphic_dim_", switch_data_block.from_switch),
	     based_buffer_ptrs, code);
	if code ^= 0 then return;

	device_state_block.reference_count =
	     device_state_block.reference_count - 1;

	if device_state_block.reference_count = 0 then
	     call free_dsb (cur_dsb_ptr);

	free switch_data_block in (sys_area);

	iocb.attach_descrip_ptr = null;

	call iox_$propagate (iocb_ptr);

	return;
%page;
graphic_dim_order: entry (iocb_ptr, request_arg, data_ptr, code);

/* PARAMETERS */

dcl  (request_arg	        char (*),
     data_ptr	        pointer) parameter;

/* AUTOMATIC */

dcl  active_fn	        bit (1),
     command_level	        bit (1),
     request	        char (168),
     table_name	        char (168);

/* BASED */

dcl  1 device_info	        aligned based (data_ptr),
       2 gdt_name	        char (32) aligned,
       2 info_gdt_ptr       pointer,
       2 device_data        like graphic_device_table.device_data aligned;

dcl  based_char_168	        char (168) based (data_ptr);


	call setup;

	if request_arg = "io_call" then do;
		io_call_infop = data_ptr;
		request = io_call_info.order_name;
		command_level = "1"b;
		active_fn = (request_arg = "io_call_af");
		if io_call_info.version ^= 1 then do;
			code = error_table_$unimplemented_version;
			request = "io_call_info structure";
		     end;
	     end;

	else do;
		request = request_arg;
		command_level, active_fn = ""b;
	     end;

	if request = "set_table" then do;
		if command_level then
		     if io_call_info.nargs < 1 then do;
			     code = 0;
			     call io_call_info.error (error_table_$noarg,
				io_call_info.caller_name,
				"Need name of GDT.");
			     return;
			end;
		     else table_name = io_call_info.args (1);
		else table_name = data_ptr -> based_char_168;

		call associate_gdt (table_name, code);

/* if woopsed, at least make the error message pretty. */
		if code ^= 0 then request = table_name;
	     end;

	else if request = "get_sdb" then do;
		if ^command_level then data_ptr = addr (switch_data_block);
		else if active_fn then
		     call ioa_$rsnnl ("^p", io_call_af_ret, 0,
			addr (switch_data_block));
		else call io_call_info.report ("^p",
			addr (switch_data_block));
	     end;

	else if request = "device_info" then do;

		if ^switch_data_block.graphic then
		     code = graphic_error_table_$nongraphic_switch;

		else if command_level then
		     if active_fn then
			io_call_af_ret = device_state_block.gdt_name;
		     else call io_call_info.report ("
GDT: ^a (^p) for ^a (^a)^/Character height: ^f, width: ^f, spacing: ^f
Message size: ^d chars^/Points per inch: ^f",
			     device_state_block.gdt_name,
			     device_state_block.gdt_ptr,
			     graphic_device_table.terminal_name,
			     graphic_device_table.terminal_type,
			     graphic_device_table.charsizes (*),
			     graphic_device_table.message_size,
			     graphic_device_table.points_per_inch);

		else do;
			device_info.gdt_name =
			     device_state_block.gdt_name;
			device_info.info_gdt_ptr =
			     device_state_block.gdt_ptr;
			unspec (device_info.device_data) =
			     unspec (graphic_device_table.device_data);
		     end;
	     end;

	else if request = "debug" then
	     rawi_mode, rawo_mode, noecho_mode = "";

	else if request = "nodebug" then do;
		rawi_mode = "^can,^esc,^erkl";
		rawo_mode = "rawo.";
		noecho_mode = "^echoplex,^tabecho,^crecho,^lfecho,rawi";
	     end;

/* If we don't recognize the control order, pass it downstream and hope. */

	else call iox_$control
		(switch_data_block.target_switch_ptr, request_arg,
		data_ptr, code);

	if code ^= 0 then
	     if command_level then do;
		     call io_call_info.error (code,
			io_call_info.caller_name, request);
		     code = 0;
		end;

	return;
%page;
graphic_dim_changemode: entry (iocb_ptr, new_modes, old_modes, code);

/* PARAMETERS */

dcl  (new_modes	        char (*),
     old_modes	        char (*)) parameter;

/* AUTOMATIC */

dcl  (i, j)	        fixed bin,
     new_modes_len	        fixed bin,
     (old_sw_modes, old_gdt_modes)
		        char (512),
     single_mode	        char (32);

	call setup;

	if device_state_block.in_rawo_mode then do;
		call get_to_text_mode (code);
		if code ^= 0 then return;
	     end;

/* If the GSP keeps modes, obtain their current state. */

	if switch_data_block.graphic then do;
		call gdt_caller (Modes, "", code);
		if code ^= 0 then return;

		old_gdt_modes =
		     substr (output_buffer, 1, output_buffer_outdx);
		output_buffer_outdx = 0;
	     end;

	else old_gdt_modes = "";

/* Now get the modes from "downstream". */

	call iox_$modes (switch_data_block.target_switch_ptr, "",
	     old_sw_modes, code);

	if code ^= 0 then
	     old_modes = old_gdt_modes;
	else if old_gdt_modes = "" then
	     old_modes = old_sw_modes;
	else call ioa_$rsnnl ("^a,^a", old_modes, 0,
		rtrim (old_sw_modes, " ."), old_gdt_modes);

/* Try simple case - see if ttydim accepts all of these new modes */

	call iox_$modes (switch_data_block.target_switch_ptr, new_modes,
	     old_sw_modes, code);
	if code ^= 0 then do;

/* Since the ttydim rejected the modes, if the switch is nongraphic or the GDT
   doesn't know or care about modes, we must give up. */

		if ^switch_data_block.graphic then return;
		if graphic_device_table.version_number < gdt_version_2 then
		     return;
		if ^graphic_device_table.effector_data (Modes).call then
		     return;

/* We have to break apart the new_modes string and feed each bite to the
   ttydim_ and to the GDT to see if it is swallowed.  If both chuck up the same
   token, we can the whole modes operation and return a bad code. */

		i = 1;
		new_modes_len = length (rtrim (new_modes));
		code = 0;

		do while (i < new_modes_len);
		     j = index (substr (new_modes, i), ",");
		     if j = 0 then
			j = length (substr (new_modes, i)) + 1;
		     single_mode =
			rtrim (substr (new_modes, i, j - 1), ". ");
		     i = i + j;

		     call iox_$modes (switch_data_block.target_switch_ptr,
			single_mode, "", code);

		     if code ^= 0 then do;

/* ttydim upchucked it, try it on GDT */

			     call gdt_caller (Modes, single_mode, code);
			     output_buffer_outdx = 0;
			     if code ^= 0 then do;

/* Both the ttydim and the GSP rejected it.  Reset everything and punt. */

				     call iox_$modes
					(switch_data_block.target_switch_ptr,
					new_modes, old_sw_modes,
					code);
				     call gdt_caller (Modes,
					old_gdt_modes, 0);
				     return;
				end;
			end;
		end;
	     end;

	return;
%page;
graphic_dim_get_chars: entry (iocb_ptr, io_buffer_ptr, io_buffer_len,
	n_chars_read, code);

/* PARAMETERS */

dcl  (io_buffer_ptr	        pointer,
     io_buffer_len	        fixed bin (21),
     n_chars_read	        fixed bin (21)) parameter;


	call setup;

/* Simple read of text from one switch to another.  This entry is not reachable
   from graphic swithes. */

	if in_rawo_mode then do;
		call get_to_text_mode (code);
		if code ^= 0 then return;
	     end;

	call iox_$get_chars (target_switch_ptr, io_buffer_ptr,
	     io_buffer_len, n_chars_read, code);
	return;
%page;
graphic_dim_get_line: entry (iocb_ptr, io_buffer_ptr, io_buffer_len,
	n_chars_read, code);

/* BASED */

dcl  io_buffer	        char (io_buffer_len) based (io_buffer_ptr);


	call setup;

	if ^switch_data_block.graphic then do;

/* Simple read of text from one switch to another-- just pass it on. */

		if in_rawo_mode then do;
			call get_to_text_mode (code);
			if code ^= 0 then return;
		     end;

		call iox_$get_line (target_switch_ptr, io_buffer_ptr,
		     io_buffer_len, n_chars_read, code);
		return;
	     end;

/* If we get here, we are doing a graphic read (graphic input). */

	n_chars_read = 0;

	if io_buffer_len < 0 then do;
		code = error_table_$negative_nelem;
		return;
	     end;

	if io_buffer_len = 0 then return;

	if graphic_device_table.effector_data (Process_input).ignore then
	     return;

	if graphic_device_table.effector_data (Process_input).error then do;
		code = graphic_error_table_$unimplemented_effector;
		return;
	     end;

	device_state_block.old_input_modes = "";

	on cleanup call reset_input;

	call ipc_$mask_ev_calls (0);

	call iox_$modes (switch_data_block.target_switch_ptr,
	     static_stuff.rawi_mode, device_state_block.old_input_modes,
	     code);

/* This call is made separately because the ARPANET rejects it */

	call iox_$modes (switch_data_block.target_switch_ptr, noecho_mode,
	     "", code);

/* If the GSP wants to handle the input, let it handle everything including
   the read (who knows what weird multi-line formats non-intelligent devices
   might use?!) */

	if graphic_device_table.effector_data (Process_input).call then do;
		call gdt_caller (Process_input,
		     device_state_block.switch_name, code);
		call reset_input;
		if code ^= 0 then return;

		if output_buffer_outdx <= io_buffer_len then
		     n_chars_read = output_buffer_outdx;
		else do;
			code = error_table_$long_record;
			n_chars_read = io_buffer_len;
		     end;

		substr (io_buffer, 1, n_chars_read) =
		     substr (output_buffer, 1, n_chars_read);

	     end;

/* Otherwise, assume the virtual terminal, and expect real MSGC from it. */

	else do;
		call iox_$get_line (switch_data_block.target_switch_ptr,
		     io_buffer_ptr, io_buffer_len, n_chars_read, code);
		call reset_input;
	     end;

	return;
%skip (3);
reset_input: proc;

	call iox_$modes (switch_data_block.target_switch_ptr,
	     device_state_block.old_input_modes, "", 0);

	return;

     end reset_input;
%page;
graphic_dim_write: entry (iocb_ptr, io_buffer_ptr, io_buffer_len, code);

/* AUTOMATIC */

dcl  n_chars_out	        fixed bin (21),
     new_nodes_idx	        fixed bin,
     new_top_idx	        fixed bin;

/* BASED */

dcl  expansion_buffer       char (max_string_size)
		        based (switch_data_block.expansion_buffer_ptr);


	call setup;

	if io_buffer_len < 0 then do;
		code = error_table_$negative_nelem;
		return;
	     end;

	if io_buffer_len = 0 then return;


	if ^switch_data_block.graphic then do;

/* This is a simple write call over a non-graphic switch. */

		if device_state_block.in_rawo_mode then do;
			call get_to_text_mode (code);
			if code ^= 0 then return;
		     end;

		substr (output_buffer, output_buffer_outdx + 1,
		     io_buffer_len) = io_buffer;
		output_buffer_outdx = output_buffer_outdx + io_buffer_len;

		call force_out_buffer (""b, code);
		return;
	     end;
%skip (4);

/* If we're here, this is a graphic write over a graphic switch */
/* First, parse, track, and otherwise massage whatever it is we have to
   write to the terminal. */


	call preexpand_graphic_code (io_buffer, expansion_buffer,
	     n_chars_out, new_nodes_idx, new_top_idx, code);

/* Mark the limits of the nodes that we're sure are good in terminal memory.
   Note that we are not sure of the ones we just added or changed until we
   actually put them out to the terminal and it accepts them as OK. */

	switch_data_block.n_nodes_in_list = new_nodes_idx - 1;

	if code ^= 0 then return;

/* The string seems fine.  Plow it out there. */
/* Mask event-calls, to prevent damn send_message from blurting in rawmode */

	on cleanup call ipc_$unmask_ev_calls (0);

	call ipc_$mask_ev_calls (code);
	if code ^= 0 then return;

	call translate_and_output_graphic_code (expansion_buffer,
	     n_chars_out, code);

	call ipc_$unmask_ev_calls (0);

	return;
%page;
/* format: ind3 */
preexpand_graphic_code: proc (instring, outstring, n_chars_out,
      first_node_this_call, node_list_top, code);

/* PARAMETERS */

dcl  (instring	        char (*),
     outstring	        char (*),
     n_chars_out	        fixed bin (21),
     first_node_this_call   fixed bin,
     node_list_top	        fixed bin,
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  already_there	        bit (1),
     based_string_length    fixed bin (21),
     based_string_ptr       pointer,
     cur_level	        fixed bin,
     dynamic	        bit (1),
     effector_char	        char (1),
     effector_length        fixed bin (21),
     expanded_indx	        fixed bin (21),
     expanded_effector_len  fixed bin (21),
     gdt_ptr	        pointer,
     i		        fixed bin (21),
     indx		        fixed bin (21),
     instring_length        fixed bin (21),
     list_level	        fixed bin,
     new_node_list_size     fixed bin,
     node_list_ptr	        pointer,
     node_uid	        char (3),
     number_output	        fixed bin (21),
     number_used	        fixed bin (21),
     outdx	        fixed bin (21),
     save_outdx	        fixed bin (21),
     save_indx	        fixed bin (21),
     temp_p	        pointer,
     validate_this_node     bit (1),
     zero_ok	        bit (1);

dcl  1 effector_data_copy   like graphic_device_table.effector_data aligned;

/* BASED AND DEFINED */

dcl  1 stack	        based (static_stuff.stack_p),
       2 stack_size	        fixed bin,
       2 frames	        (static_stuff.stack_size refer (stack.stack_size)),
         3 list_indx        fixed bin (21),
         3 list_outdx       fixed bin (21),
         3 first_owned_node fixed bin;

dcl  1 static_node_table    aligned based (node_table_ptr),
       2 node_list_size     fixed bin,
       2 node_list	        (new_node_list_size
		        refer (static_node_table.node_list_size)) char (3);

dcl  based_string	        char (based_string_length)
		        based (based_string_ptr),
     based_string_array     (based_string_length) char (1) unaligned
		        based (based_string_ptr);

dcl  outstring_char	        (length (outstring)) char (1) unaligned
		        defined (outstring);


      node_table_ptr = switch_data_block.node_table_ptr;
      gdt_ptr = device_state_block.gdt_ptr;
      gdt_pointer = null;				/* for debugging */

      dynamic = device_state_block.dynamic;
      instring_length = length (instring);
      node_list_top = switch_data_block.n_nodes_in_list;
      first_node_this_call = node_list_top + 1;
      n_chars_out, outdx, list_level = 0;

      call ipc_$unmask_ev_calls (0);

/* Scan the string.  Do pre-expansion and track levels and multiple node
   references.  Do everything before calling the GSP for code conversion. */

      do indx = 1 repeat (indx) while (indx <= instring_length);

         save_indx = indx;
         save_outdx = outdx;

         call get_effector_info (addr (instring), indx, effector_char,
	  effector_length, effector_data_copy);
%skip (2);

/* Check for special action characters */

         if effector_char = Node_begin_char then do;

	     node_uid = substr (instring, save_indx + 2, 3);

/* Check to see if we have run out of stack.  If so, grow it. */

	     if list_level + 1 > static_stuff.stack_size then do;
		 static_stuff.stack_size = static_stuff.stack_size + 50;
		 temp_p = static_stuff.stack_p;

		 allocate stack in (sys_area) set (static_stuff.stack_p);

		 if temp_p ^= null then do;

/* Copy old stack into new stack */
		       unspec (stack.frames) =
			unspec (temp_p -> stack.frames);

		       free temp_p -> stack in (sys_area);
		    end;
	        end;

	     list_level = list_level + 1;		/* bump stack */

/* If we are communicating with an intelligent, dynamic terminal, we must
   keep a list of nodes which are resident in the terminal memory.  We use
   this list to optimize the sending of shared graphic objects by replacing
   them with Reference effectors.  Note that we only do this if the referenced
   object was sent over in the same structure we are processing at the
   moment (i.e., in the same write call)-- otherwise, we assume the user is
   resending it to redefine it. */

	     if ^dynamic then
		already_there = ""b;
	     else do;
		 call add_node (node_uid, first_node_this_call,
		    node_list_top, already_there, code);
		 if code ^= 0 then return;
	        end;

	     if already_there then do;

		 if list_level = 1 then do;
		       code = graphic_error_table_$recursive_structure;
		       return;
		    end;

		 else do;
		       substr (outstring, save_outdx + 1, 1)
			= Reference_char;
		       substr (outstring, save_outdx + 2, 3) = node_uid;
		       outdx = save_outdx + 4;
		    end;

		 cur_level = list_level;

/* Now scan the input string to throw away all the contents of the item that
   was just replaced by the Reference. */

		 do i = indx + effector_length
		    repeat (i + effector_length)
		    while (list_level >= cur_level);

		    if i > instring_length then do;
			code = graphic_error_table_$incomplete_structure;
			return;
		       end;

		    effector_char = substr (instring, i, 1);
		    if effector_char = Node_begin_char then
		         list_level = list_level + 1;
		    else if effector_char = Node_end_char then
		         list_level = list_level - 1;
		    effector_length =
		       compute_effector_length (addr (instring), i, code);
		    if code ^= 0 then return;
		 end;

		 effector_char = Reference_char;
		 indx = i;
		 unspec (effector_data_copy) =
		    unspec (gdt_ptr ->
		    graphic_device_table.effector_data (Reference));
		 effector_data_copy.expand = ""b;
	        end;

	     else do;
		 stack (list_level).list_indx = save_indx;
		 stack (list_level).list_outdx = save_outdx;
		 stack (list_level).first_owned_node = node_list_top;
	        end;
	  end;

         else if effector_char = Node_end_char then do;
	     list_level = list_level - 1;

	     if list_level < 0 then do;
		 code = graphic_error_table_$too_many_node_ends;
		 return;
	        end;
	  end;

         else if dynamic then do;

/* If this is one of the dynamic effectors listed below, check to see what
   effect it will have on the nodes stored in the terminal. */

	     validate_this_node = "1"b;

	     if (effector_char = Increment_char
	        | effector_char = Alter_char
	        | effector_char = Control_char
	        | effector_char = Display_char) then
		zero_ok = ""b;
	     else if effector_char = Delete_char then zero_ok = "1"b;
	     else validate_this_node = ""b;

	     if validate_this_node then
		if ^validate_node (node_uid, node_list_top, zero_ok)
		then do;
		      code = graphic_error_table_$node_not_active;
		      return;
		   end;

	     if effector_char = Delete_char then do;
		 if node_uid = zero_node_id then do;
		       first_node_this_call = 1;
		       node_list_top = 0;
		    end;

		 else do;
		       do i = 1 to node_list_top
			while (static_node_table.node_list (i)
			^= node_uid);
		       end;

		       if i > node_list_top then do;
			   code = graphic_error_table_$node_not_active;
			   return;
			end;

		       if i < first_node_this_call then
			  first_node_this_call =
			     first_node_this_call - 1;
		       node_list_top = node_list_top - 1;

		       do i = i to node_list_top;
			static_node_table.node_list (i) =
			   static_node_table.node_list (i + 1);
		       end;
		    end;
	        end;
	  end;
%skip (2);

/* Now do expansion and error checks as specified for this effector in the
   GDT. */

         if effector_char = Node_end_char then
	    effector_data_copy.expand = "0"b;

         if effector_data_copy.expand then do;

/* we have hit an effector which the terminal cannot handle in a stacked
   fashion.  We expand the list containing it (taking care to account for the
   effector's own list level if it has one). */

	     if effector_char ^= Node_begin_char then
		list_level = max (list_level - 1, 1);

	     i = stack (list_level).list_indx;
	     outdx = stack (list_level).list_outdx;
	     node_list_top = stack (list_level).first_owned_node;

	     based_string_length = instring_length - i + 1;
	     based_string_ptr =
	        addr (addr (instring) -> based_string_array (i));

	     call graphic_compiler_$expand_string (based_string, number_used,
	        addr (outstring_char (outdx + 1)), number_output, code);

	     if code ^= 0 then return;

/* Scan the expanded string for error-producing effectors. We know that
   this array will contain no unique ID's for us to keep track of, nor will it
   contain dynamic effectors that would make us update our node list. */

	     do expanded_indx = outdx + 1
	        repeat (expanded_indx + expanded_effector_len)
	        while (expanded_indx <= outdx + number_output);

	        call get_effector_info (addr (outstring), expanded_indx, "",
		 expanded_effector_len, effector_data_copy);

	        if effector_data_copy.error then do;
		    code = graphic_error_table_$unimplemented_effector;
		    return;
		 end;
	     end;

	     indx = stack (list_level).list_indx + number_used;
	     outdx = outdx + number_output;
	     list_level = list_level - 1;
	  end;

         else if effector_data_copy.error then do;
	     code = graphic_error_table_$unimplemented_effector;
	     return;
	  end;

/* Or if there's no processing to do, just copy it into the output buffer. */

         else if effector_char ^= Reference_char then do;
	     substr (outstring, outdx + 1, effector_length) =
	        substr (instring, indx, effector_length);
	     indx = indx + effector_length;
	     outdx = outdx + effector_length;

	  end;
      end;

      if list_level > 0 then do;
	  code = graphic_error_table_$incomplete_structure;
	  return;
         end;

      n_chars_out = outdx;
      code = 0;

      return;
%page;
/* format: revert */
add_node: proc (node_uid, first_node_this_call, node_list_top, already_there,
	code);

/* This routine keeps track of the resident node list. */

/* PARAMETERS */

dcl  (node_uid	        char (3),
     first_node_this_call   fixed bin,
     node_list_top	        fixed bin,
     already_there	        bit (1),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  i		        fixed bin;


	code = 0;

	if node_table_ptr = null then call grow_node_table (100);

	do i = 1 to node_list_top
	     while (static_node_table.node_list (i) ^= node_uid);
	end;

	if i > node_list_top then do;
		if node_uid = zero_node_id then do;
			code = graphic_error_table_$invalid_node_no;

			call sub_err_ (code, "graphic_dim_",
			     "h", null, 0,
			     "Internal error while accounting for nodes in terminal memory.
Please report this occurrence to system maintenance personnel.");
			return;
		     end;

		if i > dim (static_node_table.node_list, 1) then
		     call grow_node_table (i + 99);

		static_node_table.node_list (i) = node_uid; /* add it */
		node_list_top = node_list_top + 1;
		already_there = ""b;		/* but is now! */
	     end;

	else if i < first_node_this_call then do;

/* This node is in the terminal memory, but was put there during graphic
   output previous to this call-- assume user is redefining. */

		static_node_table.node_list (node_list_top + 1) =
		     static_node_table.node_list (i);

		do i = i to node_list_top;
		     static_node_table.node_list (i) =
			static_node_table.node_list (i + 1);
		end;

		first_node_this_call = first_node_this_call - 1;
		already_there = ""b;
	     end;

	else already_there = "1"b;

	return;

     end add_node;
%page;
validate_node: proc (node_uid, node_list_top, zero_ok) returns (bit (1));

/* PARAMETERS */

dcl  (node_uid	        char (3),
     node_list_top	        fixed bin,
     zero_ok	        bit (1)) parameter;

/* AUTOMATIC */

dcl  i		        fixed bin;

	do i = 1 to node_list_top
	     while (static_node_table.node_list (i) ^= node_uid);
	end;

	if i <= node_list_top then return ("1"b);	/* it's there */
	if ((node_uid = zero_node_id) & zero_ok) then return ("1"b);
	return (""b);				/* punt */

     end validate_node;
%page;
grow_node_table: proc (new_table_size);

dcl  new_table_size	        fixed bin;

dcl  i		        fixed bin,
     temp_ptr	        pointer;


	temp_ptr = node_table_ptr;
	new_node_list_size = new_table_size;

	allocate static_node_table in (sys_area) set (node_table_ptr);

	if temp_ptr ^= null then do;
		unspec (static_node_table.node_list) =
		     unspec (temp_ptr -> static_node_table.node_list);

		free temp_ptr -> static_node_table in (sys_area);
	     end;

	return;

     end grow_node_table;
   end preexpand_graphic_code;
%page;
get_effector_info: proc (str_ptr, idx, eff_char, eff_len, eff_data);

/* PARAMETERS */

dcl  (str_ptr	        pointer,
     idx		        fixed bin (21),
     eff_char	        char (1),
     eff_len	        fixed bin (21),
     1 eff_data	        like graphic_device_table.effector_data aligned)
		        parameter;

/* BASED */

dcl  str		        char (sys_info$max_seg_size) based (str_ptr);

/* This misdeclaration is unfortunate, but it keeps get_effector_info
   from needing descriptors which is a great efficiency consideration */


	eff_char = substr (str, idx, 1);
	eff_len = compute_effector_length (str_ptr, idx, code);
	if code ^= 0 then return;

	unspec (eff_data) = unspec (gdt_ptr ->
	     graphic_device_table.effector_data (rank (eff_char)));
	return;

     end get_effector_info;
%skip (3);
compute_effector_length: proc (str_ptr, idx, code) returns (fixed bin (21));

/* PARAMETER */

dcl  (str_ptr	        pointer,
     idx		        fixed bin (21),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  effector_rank	        fixed bin,
     effector_length        fixed bin (21);

/* BASED */

dcl  str		        char (sys_info$max_seg_size) based (str_ptr);

/* See comment in get_effector_info about such misdeclarations. */


	code = 0;

	effector_rank = rank (substr (str, idx, 1));

	if effector_rank < 32 then goto unrecognized;
	if effector_rank > 63 then do;
unrecognized:	code = graphic_error_table_$unrecognized_effector;
		return (0);
	     end;

	effector_length = Graphic_Element_Lengths (effector_rank);

/* length = 0 is a special case for a variable-length effector */

	if effector_length = 0 then
	     effector_length = graphic_element_length_ (str, idx);

	if effector_length <= 0 then do;
		code = graphic_error_table_$impossible_effector_length;
		return (0);
	     end;

	return (effector_length);
     end compute_effector_length;
%page;
translate_and_output_graphic_code: proc (instring, instring_len, code);

/* PARAMETERS */

dcl  (instring	        char (*),
     instring_len	        fixed bin (21),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  1 effector_data_copy   like graphic_device_table.effector_data
		        aligned automatic;

dcl  effector_char	        char (1),
     indx		        fixed bin (21),
     effector_length        fixed bin (21),
     based_effector_ptr     pointer;

/* BASED */

dcl  based_string_array     (max_string_size) based char (1) unaligned,
     based_effector	        char (effector_length) based (based_effector_ptr);


	code = 0;

/* At this point, the expanded and massaged graphics code is in
   expansion_buffer.  Now we simply gallop down the string, calling the GSP
   entries if appropriate and generally putting out scads and scads of
   terminal-dependent graphics code. */


	if ^device_state_block.in_rawo_mode then do;
		call set_modes_rawo;

		call gdt_caller (Prepare_for_graphics,
		     (device_state_block.switch_name), code);
		if code ^= 0 then return;
	     end;


	do indx = 1 repeat (indx + effector_length)
	     while (indx <= instring_len);

	     call get_effector_info (addr (expansion_buffer), indx,
		effector_char, effector_length, effector_data_copy);

	     if effector_data_copy.flush then do;
		     call force_out_buffer ("1"b, code);
		     if code ^= 0 then return;
		end;

	     if effector_data_copy.ignore then ;	/* skip it */

	     else if effector_data_copy.call then do;

/* The GSP wants to get its hands on this one and translate it. */

		     based_effector_ptr = addr (addr (instring) ->
			based_string_array (indx));

		     call gdt_caller (rank (effector_char), based_effector,
			code);
		     if code ^= 0 then return;
		end;

	     else do;
		     substr (output_buffer, output_buffer_outdx + 1,
			effector_length) = based_effector; /* pass it on */
		     output_buffer_outdx =
			output_buffer_outdx + effector_length;
		end;
	end;

	call force_out_buffer ("1"b, code);

	return;

     end translate_and_output_graphic_code;
%page;
gdt_caller: proc (effector_no, effector, code);

/* PARAMETERS */

dcl  (effector_no	        fixed bin,
     effector	        char (*),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  number_output	        fixed bin (21),
     part_output_len        fixed bin (21),
     part_output_ptr        pointer;

/* BASED */

dcl  part_output_buffer     char (part_output_len) based (part_output_ptr);


	part_output_ptr = addr (switch_data_block.output_buffer_ptr ->
	     char_array (output_buffer_outdx + 1));
	part_output_len =
	     length (substr (output_buffer, output_buffer_outdx + 1));
	number_output, code = 0;

	call device_state_block.gdt_proc (effector_no, effector,
	     part_output_buffer, number_output,
	     device_state_block.gdt_data_ptr, code);

/* check for the obsolete error code convention from before GSP error codes. */

	if number_output < 0 then code = -number_output;

	if code ^= 0 then return;

	output_buffer_outdx = output_buffer_outdx + number_output;
	call try_buffered_output ("1"b, code);

	return;

     end gdt_caller;
%page;
try_buffered_output: proc (graphical, code);

/* This routine writes the contents of the output buffer to the terminal if
   the message size in the GDT has been attained. */

/* PARAMETERS */

dcl  (graphical	        bit (1),
     code		        fixed bin (35)) parameter;


	code = 0;

/* If we have reached the message_size threshhold, do output. */

	if output_buffer_outdx
	     >= device_state_block.gdt_message_size then
	     call force_out_buffer (graphical, code);

	return;

     end try_buffered_output;
%skip (2);
force_out_buffer: proc (graphical, code);

/* This routine pumps the output buffer out to the terminal.  It also performs
   the status requests and interpretations from intelligent graphics
   terminals.  */

/* PARAMETERS */

dcl  (graphical	        bit (1),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  buffer_ptr	        pointer,
     dynamic	        bit (1),
     message_size	        fixed bin (21),
     my_io_buffer_len       fixed bin (21),
     n_chars_read	        fixed bin (21);

	code = 0;

	if output_buffer_outdx = 0 then return;

/* get into proper mode-- raw or not-- depending on output type. */

	if (graphical & ^device_state_block.in_rawo_mode) then
	     call set_modes_rawo;

	else if (^graphical & device_state_block.in_rawo_mode) then
	     call set_modes_not_rawo;

	if graphical then do;
		message_size = device_state_block.gdt_message_size;
		dynamic = device_state_block.dynamic;
	     end;
	else do;
		message_size = static_stuff.max_string_size;
		dynamic = ""b;
	     end;

	on cleanup call cleanerup (0);

/* If we are talking to an intelligent terminal, activate the ACK strategy. */

	if dynamic then do;
		call iox_$modes (switch_data_block.target_switch_ptr,
		     rawi_mode, device_state_block.old_input_modes, code);

/* The following call is made separately because the ARPANET rejects it. */

		call iox_$modes (switch_data_block.target_switch_ptr,
		     noecho_mode, "", code);

/* We can't handle any typeahead that may be waiting now, so flush it. */

		call iox_$control (switch_data_block.target_switch_ptr,
		     "resetread", null, code);
	     end;

	buffer_ptr = switch_data_block.output_buffer_ptr;


	do while (output_buffer_outdx > 0);

	     my_io_buffer_len = min (output_buffer_outdx, message_size);
	     call iox_$put_chars (switch_data_block.target_switch_ptr,
		buffer_ptr, my_io_buffer_len, code);
	     if code ^= 0 then goto error_return;

	     output_buffer_outdx = output_buffer_outdx - my_io_buffer_len;
	     buffer_ptr =
		addr (buffer_ptr -> char_array (my_io_buffer_len + 1));

/* If doing graphics to an intelligent terminal, get an ACK from it now. */

	     if dynamic then do;
		     call iox_$put_chars
			(switch_data_block.target_switch_ptr,
			addr (request_for_status),
			length (request_for_status), code);
		     if code ^= 0 then goto error_return;

		     call iox_$get_line
			(switch_data_block.target_switch_ptr,
			addr (switch_data_block.status_buffer),
			length (switch_data_block.status_buffer),
			n_chars_read, code);
		     if code ^= 0 then goto error_return;

		     call graphic_terminal_status_$decode
			(substr (switch_data_block.status_buffer, 1,
			n_chars_read), code);
		     if code ^= 0 then goto error_return;
		end;
	end;

	call cleanerup (code);

	output_buffer_outdx = 0;
	return;

error_return:
	call cleanerup (0);
	return;
%skip (3);
cleanerup: proc (code);

dcl  code		        fixed bin (35) parameter;

	if dynamic then
	     call iox_$modes (switch_data_block.target_switch_ptr,
		device_state_block.old_input_modes, "", code);
	device_state_block.old_input_modes = "";

	return;
     end cleanerup;
     end force_out_buffer;
%skip (3);
set_modes_rawo: proc;

	call iox_$modes (switch_data_block.target_switch_ptr,
	     rawo_mode, device_state_block.old_output_modes, code);
	device_state_block.in_rawo_mode = "1"b;

	return;

     end set_modes_rawo;
%skip (3);
set_modes_not_rawo: proc;

	call iox_$modes (switch_data_block.target_switch_ptr,
	     device_state_block.old_output_modes, "", 0);

	device_state_block.old_output_modes = "";
	device_state_block.in_rawo_mode = ""b;

	return;

     end set_modes_not_rawo;
%page;
get_to_text_mode: proc (code);

/* PARAMETERS */

dcl  code		        fixed bin (35) parameter;


	call gdt_caller (Prepare_for_text, (device_state_block.switch_name),
	     code);
	if code ^= 0 then return;

	call force_out_buffer ("1"b, code);
	if code ^= 0 then return;

	call set_modes_not_rawo;

	return;

     end get_to_text_mode;

     end graphic_dim_;



		    graphic_element_length_.pl1     11/18/82  1706.7rew 11/18/82  1627.8       28899


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_element_length_: proc (string, indx) returns (fixed bin);

/* This procedure returns the length of a single graphic effector string.
   Written c. 1973 by C. D. Tavares
   Last modified 04/25/80 by CDT to replace signal statement with call to sub_err_. */

dcl  string char (*) parameter,
     indx fixed bin (21) parameter,
     len fixed bin;

%include graphic_code_dcl;

dcl  effector fixed bin,
     temp_chars char (2) aligned,
     fixed_array (1) fixed bin,
     sub_err_ ext entry options (variable),
     graphic_error_table_$unrecognized_effector ext fixed bin (35) static,
    (addr, byte, divide, hbound, lbound, null, rank, substr) builtin;

dcl  graphic_code_util_$decode_dpi ext entry (pointer, fixed bin, (*) fixed bin);
%skip (10);
	effector = rank (substr (string, indx, 1));	/* get effector value */
	if (effector < lbound (Graphic_Element_Lengths, 1)) |
	(effector > hbound (Graphic_Element_Lengths, 1)) then
	     call sub_err_ (graphic_error_table_$unrecognized_effector, "graphic_element_length_", "s", null, 0,
	     """^a"" not a valid graphic effector.", byte (effector));
						/* stops the user cold, can't return. */

	len = Graphic_Element_Lengths (effector);	/* takes care of simple cases */

	if len ^= 0 then return (len);

	goto special_effector (effector);		/* handle tough cases */

special_effector (61):				/* symbol */
special_effector (62):				/* text */
	effector = effector - 60;			/* little kludge */

	temp_chars = substr (string, indx + effector, 2); /* length of text */
	call graphic_code_util_$decode_dpi (addr (temp_chars), 1, fixed_array); /* get numeric length */

	return (fixed_array (1) + effector + 2);

special_effector (63):				/* data */
	temp_chars = substr (string, indx + 1, 2);	/* get char length */
	call graphic_code_util_$decode_dpi (addr (temp_chars), 1, fixed_array); /* get numeric length */

	len = divide (fixed_array (1) + 5, 6, 17, 0) + 3; /* length in bits -> chars */

	return (len);

     end;
 



		    graphic_error_table_.alm        11/05/86  1606.7r w 11/04/86  1039.3       44253


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

"  ******************************************************
"  *                                                    *
"  *                                                    *
"  * Copyright (c) 1972 by Massachusetts Institute of   *
"  * Technology and Honeywell Information Systems, Inc. *
"  *                                                    *
"  *                                                    *
"  ******************************************************


	include	et_macros


	et	graphic_error_table_


ec  abs_pos_in_clipping,abs_clip,
	(An absolute effector appears in an array within the scope of an extent element.)
ec  bad_align,badalign,
	(The alignment provided for a text node is undefined.)
ec  bad_device_type,badevice,
	(Graphic input device number is not defined.)
ec  bad_no_iter,bad_iter,
	(The number of iterations to be performed is negative.)
ec  bad_node,bad_node,
	(Node is not a defined graphic datum.)
ec  clipping_unimplemented,cantclip,
	(Graphic clipping is not yet implemented.)
ec  compiler_error,compiler,
	(Internal graphic compiler error.)
ec  gct_bad_special_char,gctspchr,
	(Unrecognized special format character specified in graphic character table.)
ec  gdt_missing,no_gdt,
	(Graphic device table was not specified or is internally inconsistent.)
ec  impossible_effector_length,badeffln,
	(Encountered effector has an impossible length.)
ec  incomplete_structure,<nodends,
	(Not enough node ends encountered.)
ec  inv_node_type,inv_type,
	(The graphic effector type specified is invalid for this operation.)
ec  invalid_node_no,badnode#,
	(The node value specified is not a valid node value.)
ec  list_oob,list_oob,
	(Supplied list index is outside the bounds of the list or array.)
ec  lsm_blk_len,>blksize,
	(Too many elements supplied to create a single graphic list or array.)
ec  lsm_invalid_op,lsm_Xop,
	(The directed operation is invalid.)
ec  lsm_node_ob,lsm_oob,
	(The node value supplied is out of bounds.)
ec  lsm_seg_full,lsm_full,
	(The graphic segment is full.)
ec  lsm_sym_search,nosymbol,
	(Symbol not found in symbol table.)
ec  malformed_input,malformd,
	(The graphic input received was malformed.)
ec  neg_delay,negdelay,
	(A negative delay between increments has been specified.)
ec  no_wgs_yet,no_wgs,
	(No working graphic segment exists.)
ec  node_list_overflow,>nodetbl,
	(The internal node list table has overflowed.)
ec  node_mismatch,wrongnod,
	(The node returned by the graphic terminal was not the node requested.)
ec  node_not_active,nodeinac,
	(The node is not resident in the graphic processor.)
ec  nongraphic_switch,^graphsw,
	(This operation only permitted for a graphic I/O switch.)
ec  not_a_gdt,notagdt,
	(Segment is not a graphic device table.)
ec  not_a_structure,notstruc,
	(Data is not a graphic structure.)
ec  null_replacement,replnull,
	(The null node cannot be used to replace an existing node.)
ec  recursive_structure,recursiv,
	(The specified graphic structure is recursive.)
ec  struc_duplication,strucdup,
	(A name duplication has occurred in moving a graphic structure.)
ec  term_bad_effector,Tbad_eff,
	(Terminal encountered an unimplemented graphic effector.)
ec  term_bad_err_message,Tbaderr,
	(Terminal returned a garbled error message.)
ec  term_bad_err_no,Tbaderr#,
	(Terminal returned an invalid error code.)
ec  term_bad_increment_eff,Tnoincef,
	(Terminal reported unimplemented effector in increment command.)
ec  term_bad_increment_node,Tnoincnd,
	(Terminal cannot increment requested node.)
ec  term_bad_input_device,Tbad_dev,
	(Terminal does not implement requested input device)
ec  term_bad_message,Tgarbage,
	(Terminal reported error in graphic message contents.)
ec  term_bad_parity,Txparity,
	(Terminal reported parity error in graphic message.)
ec  term_no_active_structure,Tnotactv,
	(Terminal reported that no structure was active.)
ec  term_no_room,Tno_room,
	(Terminal graphic buffer full.)
ec  term_node_not_found,Tno_node,
	(Terminal cannot locate requested node.)
ec  term_node_too_large,Tnodsize,
	(Terminal reported replacement node was too large.)
ec  term_too_many_ends,T>nodend,
	(Terminal encountered too many node ends.)
ec  term_too_many_levels,T>levels,
	(Terminal reported stack depth overflow.)
ec  too_many_node_ends,>nodends,
	(Too many node ends encountered.)
ec  unimplemented_effector,unimpeff,
	(Effector not implemented by this graphic device.)
ec  unrecognized_effector,unreceff,
	(Unrecognized graphic effector encountered.)

	end
   



		    graphic_macros_.pl1             11/18/82  1706.7rew 11/18/82  1627.8       83169


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


graphic_macros_: gmc_: proc;
	return;

/* This proc  is a catch-all in which to implement common complex
   graphic objects of general use.
   Written on and off from 11/10/74 to 05/06/76 by C. D. Tavares as the basis for a replacement
   for gui_. */

%include gm_entry_dcls;

%include graphic_etypes;

	
box:	entry (x_side, y_side, code) returns (fixed bin (18));

dcl (x_side, y_side) float bin parameter,
     code fixed bin (35) parameter;

dcl  node_array (10) fixed bin (18),
     node fixed bin (18);


	node_array (1) = graphic_manipulator_$create_position (Vector, x_side, 0, 0, code);
	node_array (2) = graphic_manipulator_$create_position (Vector, 0, y_side, 0, code);
	node_array (3) = graphic_manipulator_$create_position (Vector, -x_side, 0, 0, code);
	node_array (4) = graphic_manipulator_$create_position (Vector, 0, -y_side, 0, code);

	node = graphic_manipulator_$carray (node_array, 4, code);

	return (node);

error_return:
	return (0);


circle:	entry (x_dist, y_dist, code) returns (fixed bin (18));

/* This entrypoint draws a circle centered at (x, dist, y_dist) from your current position. */

dcl (x_dist, y_dist) float bin parameter,
     Undefined fixed bin static initial (-1);

	node = closed_curve (x_dist, y_dist, 1, Undefined, (Undefined), (Undefined), (Undefined), code);
	return (node);

arc:	entry (x_dist, y_dist, fraction, code) returns (fixed bin (18));

/* This entry is like arc, but the fraction determines how much of a circle the resultant arc is. */
/* If the fraction is negative, arc will be drawn clockwise, &vv */

dcl  fraction float bin parameter;

	node = closed_curve (x_dist, y_dist, fraction, Undefined, (Undefined), (Undefined), (Undefined), code);
	return (node);

polygon:	entry (x_dist, y_dist, n_sides, code) returns (fixed bin (18));

/* This is like circle, but there are a definite number of sides desired. */
/* If n_sides is negative the polygon will be drawn clockwise, but what of it? */

dcl  n_sides fixed bin parameter;

	node = closed_curve (x_dist, y_dist, 1, n_sides, (Undefined), (Undefined), (Undefined), code);
	return (node);

ellipse:	entry (x_dist, y_dist, eccentricity, eccentricity_angle, fraction, code) returns (fixed bin (18));

/* This entry draws an ellipse.  It assumes your current position is on the ellipse,
   the epicenter (geographical center) of the ellipse is (x_dist, y_dist) from you, the eccentricity (the major
   axis over the minor axis, not the textbook definition) is given, and the eccentricity angle is the angle
   that the major axis makes with the x axis.  The fraction is measured in RADIAL DEGREES;  therefore, with
   eccentricity angles of around 45 degrees, asking for 3/4 ellipse can get you almost the whole thing. */

dcl  eccentricity float bin parameter,
     eccentricity_angle fixed bin parameter;

dcl (sind, cosd, atand) builtin;

dcl (rotated_x, rotated_y) float bin;

dcl (a, b) float bin;


	rotated_x = - x_dist * cosd (eccentricity_angle) - y_dist * sind (eccentricity_angle);
	rotated_y = x_dist * sind (eccentricity_angle) - y_dist * cosd (eccentricity_angle);

	a = sqrt (eccentricity * eccentricity * rotated_y * rotated_y + rotated_x * rotated_x);
	b = a / eccentricity;

	node = closed_curve (x_dist, y_dist, fraction, Undefined, a, b, (eccentricity_angle), code);
	return (node);


ellipse_by_foci: entry (x_dist1, y_dist1, x_dist2, y_dist2, fraction, code) returns (fixed bin (18));

/* This also draws an ellipse, whose foci are at (x_dist1, y_dist1) and (x_dist2, y_dist2) from you. */

dcl (x_dist1, y_dist1, x_dist2, y_dist2) float bin parameter;

dcl (rad_1, rad_2,					/* radii from each focus to any pt on ellipse */
     c,						/* half distance between foci */
     epicenter_dx, epicenter_dy,			/* rel. dists to geometric ctr of ellipse */
     epiradius,					/* distance to geometric ctr of ellipse */
     temp) float bin;				/* random optimization temporary */

dcl  computed_eccentricity_angle float bin;


	rad_1 = sqrt (x_dist1 ** 2 + y_dist1 ** 2);
	rad_2 = sqrt (x_dist2 ** 2 + y_dist2 ** 2);

	c = sqrt ((x_dist2 - x_dist1) ** 2 + (y_dist2 - y_dist1) ** 2) / 2;

	epicenter_dx = (x_dist1 + x_dist2) / 2;
	epicenter_dy = (y_dist1 + y_dist2) / 2;

	epiradius = sqrt (epicenter_dx ** 2 + epicenter_dy ** 2);

	temp = x_dist2 - x_dist1;
	if temp = 0 then computed_eccentricity_angle = -90;
	else computed_eccentricity_angle = atand ((y_dist2 - y_dist1) / temp);

	a = (rad_1 + rad_2) / 2;
	b = sqrt (a * a - c * c);

	node = closed_curve (epicenter_dx, epicenter_dy, fraction, Undefined, a, b, computed_eccentricity_angle, code);
	return (node);

	
/* ----------------------------- */

closed_curve: proc (x_dist, y_dist, fraction, n_sides, a, b, eccentricity_angle, code) returns (fixed bin (18));

/* Closed curve algorithm largely courtesy Sally Duren, from old gui_. */

dcl (x_dist, y_dist, fraction) float bin parameter,
     n_sides fixed bin parameter,
    (a, b) float bin parameter,
     eccentricity_angle float bin,
     elliptical bit (1),
    (cos_theta, sin_theta) float bin,
     code fixed bin (35) parameter,
     node fixed bin (18);

dcl (radius, x, y, old_x, old_y, delta, delta_x, delta_y, avg_radius, temp_delta) float bin,
     save_dx float bin,
     save_x float bin,
     i fixed bin,
     node_array (400) fixed bin (18),
     array_ct fixed bin,
     steps fixed bin,
     acosd_ ext entry (float bin) returns (float bin),
     stretch float bin,
     target_theta float bin,
     theta float bin;

	     code = 0;

	     radius = sqrt (x_dist ** 2 + y_dist ** 2);
	     if radius = 0 then return (0);		/* sure... */

	     elliptical = a ^= Undefined;		/* a is undefined for all but ellipses */
	     stretch = a/b;				/* major axis / minor axis */
	     if stretch < 1e0 then stretch = 1e0/stretch; /* user specified eccentricity < 1e0 */

	     if n_sides = Undefined then steps = abs (fraction * ((radius / 6) + (20 * stretch)));
						/* a pretty good random function */
	     else steps = n_sides;			/* polygon case */
	     steps = min (steps, hbound (node_array, 1)); /* so we dont overstep array */
	     delta, temp_delta = fraction * 360 / steps;	/* angular increment */

	     if elliptical then do;			/* swing the curpos through -eccentricity_angle */
		old_x = -x_dist; old_y = - y_dist;
		avg_radius = (a+b)/2;		/* the average radius of the ellipse */
	     end;

	     else do;
		old_x = -x_dist;
		old_y = -y_dist;
		avg_radius = radius;
	     end;

	     theta = acosd_ (max (-1, min (1, old_x/radius))); /* current angle with x axis */
						/* acosd_ gets moby upset at the slightest bit over 1 or under -1 */
	     if y_dist > 0 then theta = 360 - theta;
	     if elliptical then theta = theta - eccentricity_angle;
	     target_theta = theta + fraction * 360;	/* final angle */

	     array_ct = 0;

	     sin_theta = sind (theta);
	     cos_theta = cosd (theta);

	     if elliptical then			/* have to fudge ahead of time */
		radius = a * b / sqrt (b * b * cos_theta * cos_theta + a * a * sin_theta * sin_theta);

	     old_x = radius * cos_theta;
	     old_y = radius * sin_theta;

	     do i = 1 to steps while (theta ^= target_theta);

		if elliptical then temp_delta = delta * avg_radius / radius;
						/* this makes the angles smaller near the points so */
						/* the curve is smoother there */
		theta = theta + temp_delta;		/* increment the angle */

		if temp_delta < 0 then theta = max (theta, target_theta); /* don't run past end */
		else theta = min (theta, target_theta);

		sin_theta = sind (theta);
		cos_theta = cosd (theta);

		if elliptical then
		     radius = a * b / sqrt (b * b * cos_theta * cos_theta + a * a * sin_theta * sin_theta);

		x = radius * cos_theta;
		y = radius * sin_theta;

		delta_x = x - old_x;		/* coords of difference vector */
		delta_y = y - old_y;

		old_x = x; old_y = y;

		if elliptical then do;
		     save_dx = delta_x;		/* rotate the difference vector thru eccentricity_angle */
		     delta_x = delta_x * cosd (eccentricity_angle) - delta_y * sind (eccentricity_angle);
		     delta_y = save_dx * sind (eccentricity_angle) + delta_y * cosd (eccentricity_angle);

		     save_x = x;			/* also the current position */
		     x = x * cosd (eccentricity_angle) - y * sind (eccentricity_angle);
		     y = save_x * sind (eccentricity_angle) + y * cosd (eccentricity_angle);
		end;

		array_ct = array_ct + 1;
		node_array (array_ct) = graphic_manipulator_$create_position (Vector, delta_x, delta_y, 0, code);
		if code ^= 0 then return (0);
	     end;

	     node = graphic_manipulator_$create_array (node_array, array_ct, code); /* list them up */
	     if code ^= 0 then return (0);

	     return (node);
	end closed_curve;

/* ----------------------------- */


     end;
   



		    graphic_manipulator_.pl1        11/18/82  1706.7rew 11/18/82  1625.4      280377


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_manipulator_: gm_: procedure; return;

/* graphic_manipulator_.pl1 - Entry points for maipulating a Multics standard
   graphic structure */

/* Originally coded 7/73 by Lee J. Scheffler */
/* Modified many times since by C. D. Tavares. */
/* Modified 08/79 by CDT as part of the general lsm_ overhaul */
/* Modified 03/25/80 by CDT to fix an unset pointer bug in ecolor. */
/* Modified 10/14/80 by CDT to inhibit storing of trailing zeroes
   for positional elements and some others, and to use gc_$prune_tree. */
/* Last modified 04/14/81 by CDT to make replace_element accept -1 index */

/* System entry points */

dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)),
     get_temp_segment_ ext entry (char (*), pointer, fixed bin (35));

/* System-wide error codes */

dcl (graphic_error_table_$no_wgs_yet,			/* no working graphic seg yet */
     graphic_error_table_$null_replacement,		/* tried to replace_node a node with the null node */
     graphic_error_table_$list_oob,			/* attempt to idx outside list */
     graphic_error_table_$bad_align,			/* bad alignment for char string */
     graphic_error_table_$inv_node_type,		/* invalid effector type for this operation */
     error_table_$smallarg)				/* caller-provided array is too small */
     fixed bin (35) external;

dcl  err_code fixed bin (35) parameter;			/* error code */


dcl (addr, dim, hbound, mod, null, substr) builtin;


/* Static variables */

dcl  wgs_p pointer static initial (null);		/* points to current WGS */


dcl (node_no, list_n, new_n, node_n, value_n, old_n, template_n) fixed bin (18); /* node #s */

dcl (etype, type) fixed bin,				/* Graphic effector codes */
     ltype fixed bin;				/* lsm_ block types */

dcl (curl, arrayl, idx) fixed bin;			/* lengths of various things */

dcl  effector_p pointer;

dcl  array (*) fixed bin (18);			/* array of node numbers for list creation and examination */

dcl (name,					/* name of a symbol */
     dname)					/* pathname of a directory */
     char (*);

%page;
%include graphic_etypes;
%page;
%include graphic_templates;
%page;
%include lsm_formats;
%page;
%include lsm_entry_dcls;
%page;
%include gc_entry_dcls;
%page;
init:	entry (err_code);

/* Create a working graphic segment */
/* THIS ENTRY MUST BE CALLED BEFORE ALL OTHER CALLS TO THIS PROGRAM */

	err_code = 0;

	if wgs_p = null then call get_wgs;
	call init_graphic_segment (wgs_p);
	call graphic_compiler_$prune_tree (err_code);	/* reset the tree to min size */
	return;
%skip (5);
get_wgs:	proc;

	     call get_temp_segment_ ("graphic_manipulator_ WGS", wgs_p, err_code);
	     if err_code ^= 0 then goto error_return;
	     return;
	end get_wgs;
%skip (5);
init_graphic_segment: proc (segp);

/* This internal procedure creates the graphic symbol table and chains it onto the root. */

dcl  segp pointer;

	     call lsm_fs_$init (segp, err_code);
	     if err_code ^= 0 then goto error_return;

	     call lsm_$make_blk (segp, segp -> lsm.root_symtab, symtab_type, 197 /* nice prime # */, null, err_code);
	     if err_code ^= 0 then goto error_return;

	     return;

	end init_graphic_segment;
%page;
segp:	entry (wgs_ptr, err_code);

/* Entry to get a pointer to current working graphic segment */

dcl  wgs_ptr pointer;

	wgs_ptr = wgs_p;				/* Return pointer to base of working graphic seg */
	if wgs_p = null () then goto no_wgs_yet;
	err_code = 0;
	return;

/* ------------------------------ */

check_wgs_init: proc;

	     err_code = 0;
	     if wgs_p = null () then goto no_wgs_yet;
	     return;

check_wgs_init_null_node: entry;

	     err_code = 0;
	     if wgs_p = null () then goto no_wgs_yet_null_node;
	     return;

	end check_wgs_init;

/* ------------------------------ */
%page;

/* STRUCTURE CREATION ENTRY POINTS */


/* --------------------------------------------------------------------------------------------------- */
/* Create a position effector */

create_position: cpos: entry (etype, x, y, z, err_code) returns (fixed bin (18));
dcl (x, y, z) float bin (27) parameter;			/* coordinates of position effector */

dcl  efficient_len fixed bin;

	if z = 0e0 then
	     if y = 0e0 then
		if x = 0e0 then efficient_len = 0;
		else efficient_len = 1;
	     else efficient_len = 2;
	else efficient_len = 3;

	call create_fl_effector (Setposition, Point, etype, efficient_len + 1);
						/* Get friend to do work */
	if efficient_len > 0 then effector_p -> position_effector.xpos = x;
	if efficient_len > 1 then effector_p -> position_effector.ypos = y;
	if efficient_len > 2 then effector_p -> position_effector.zpos = z;
	return (node_no);


/* --------------------------------------------------------------------------------------------------- */
/* Create  a mode effector */

create_mode: cmode: entry (etype, mode, err_code) returns (fixed bin (18));
dcl  mode fixed bin parameter;			/* mode value of mode effector */

	call create_fl_effector (Intensity, Color, etype, effector_length (etype));
	effector_p -> modal_effector.mode = mode;
	return (node_no);


/* --------------------------------------------------------------------------------------------------- */
/* Create scale effector */

create_scale: cscale: entry (xscale, yscale, zscale, err_code) returns (fixed bin (18));
dcl (xscale, yscale, zscale) float bin (27) parameter,	/* scale factors */
    (xa, ya, za) float bin (27);

	call create_fl_effector (Scaling, Scaling, Scaling, effector_length (Scaling));
	effector_p -> scale_effector.xscale = xscale;
	effector_p -> scale_effector.yscale = yscale;
	effector_p -> scale_effector.zscale = zscale;
	return (node_no);


/* --------------------------------------------------------------------------------------------------- */
/* Create rotation effector */

create_rotation: crot: entry (xangle, yangle, zangle, err_code) returns (fixed bin (18));
dcl (xangle, yangle, zangle) float bin (27);		/* rotations around respective axes */

	if zangle = 0e0 then
	     if yangle = 0e0 then
		if xangle = 0e0 then efficient_len = 0;
		else efficient_len = 1;
	     else efficient_len = 2;
	else efficient_len = 3;

	call create_fl_effector (Rotation, Rotation, Rotation, efficient_len + 1);

	xa = mod (xangle, 360e0);			/* Turn into positive angle < 360e0 */
	if xa < 0e0 then xa = xa + 360e0;
	ya = mod (yangle, 360e0);
	if ya < 0e0 then ya = ya + 360e0;
	za = mod (zangle, 360e0);
	if za < 0e0 then za = za + 360e0;

	if efficient_len > 0 then effector_p -> rotate_effector.xangle = xa;
	if efficient_len > 1 then effector_p -> rotate_effector.yangle = ya;
	if efficient_len > 2 then effector_p -> rotate_effector.zangle = za;

	return (node_no);


/* ---------------------------------------------------------------------------------------------------- */
/* Create a clipping effector */

create_clip: cclip: entry (xlow, xhigh, ylow, yhigh, zlow, zhigh, err_code) returns (fixed bin (18));

dcl (xlow, xhigh, ylow, yhigh, zlow, zhigh) float bin (27); /* relative coords of clipping solid */

dcl  graphic_error_table_$clipping_unimplemented ext fixed bin (35) static;

/* return "unimplimented" error code until clipping fully operational. */

	err_code = graphic_error_table_$clipping_unimplemented;
	return (0);

unreflabel:

/* The following code cannot be reached, and is here simply for historical interest.
   This is how clipping "worked" before we disabled it because it was not implemented. */

	call create_fl_effector (Clipping, Clipping, Clipping, effector_length (Clipping));
	effector_p -> clipping_effector.delta_left = xlow;
	effector_p -> clipping_effector.delta_right = xhigh;
	effector_p -> clipping_effector.delta_bottom = ylow;
	effector_p -> clipping_effector.delta_top = yhigh;
	effector_p -> clipping_effector.delta_back = zlow;
	effector_p -> clipping_effector.delta_front = zhigh;
	return (node_no);

/* --------------------------------------------------------------------------------------------------- */
/* Create a color effector */

create_color: ccolor: entry (int_red, int_green, int_blue, err_code) returns (fixed bin (18));
dcl (int_red, int_green, int_blue) fixed bin parameter;	/* intensities of primary additive colors */

	call create_fl_effector (Color, Color, Color, effector_length (Color));
	effector_p -> color_effector.red_intensity = int_red;
	effector_p -> color_effector.green_intensity = int_green;
	effector_p -> color_effector.blue_intensity = int_blue;
	return (node_no);


/* --------------------------------------------------------------------------------------------------- */
/* Utility procedure to create an effector of floating element type */
/* float_type lsm_ blocks are used to hold fixed bins as well */

create_fl_effector: procedure (emin, emax, etype, elen);

dcl (emin, etype, emax, elen) fixed bin;		/* minimum and maximum acceptable
						   effector codes */

	     call check_wgs_init_null_node;

	     if etype >= emin then if etype <= emax
		then do;				/* If type is proper for call */
		     call lsm_$make_blk (wgs_p, node_no, float_type, elen, node_ptr, err_code);
						/* Make block of necessary length */
		     if err_code ^= 0 then go to error_return_null_node;
		     effector_p = addr (node_ptr -> any_node.data_space);

		     effector_p -> effector.effector_code = etype; /* Fill in effector type */
		     return;
		end;

	     go to bad_type_null_node;

	end create_fl_effector;


/* --------------------------------------------------------------------------------------------------- */

/* Create a text (character string) block */

create_text: ctext: entry (alignment, nchars, text, err_code) returns (fixed bin (18));
dcl  alignment fixed bin,
     text char (*) unaligned;

	call check_wgs_init_null_node;
	call lsm_$make_blk (wgs_p, node_no, char_type, nchars+1, node_ptr, err_code);
						/* Extra char is for alignment */
	if err_code ^= 0 then return (0);

	effector_p = addr (node_ptr -> any_node.data_space);
	if alignment >= 1 then if alignment <= 9
	     then effector_p -> text_effector.alignment = alignment;
	     else go to bad_align;			/* If bad alignment */

	substr (effector_p -> text_effector.text, 1, nchars) = text; /* Copy text */
	return (node_no);

/* --------------------------------------------------------------------------------------------------- */

/* Create a data block (to hold user data values or terminal commands) */

create_data: cdata: entry (nbits, data, err_code) returns (fixed bin (18));
dcl  data bit (*) unaligned;				/* data block */

	call check_wgs_init_null_node;
	call lsm_$make_blk (wgs_p, node_no, bit_type, nbits, node_ptr, err_code);
	if err_code ^= 0 then return (0);

	effector_p = addr (node_ptr -> any_node.data_space);
	node_ptr -> bit_node.string = data;

	return (node_no);


/* --------------------------------------------------------------------------------------------------- */
/* Create a list (non-terminal) or array (terminal list) */

create_list: clist: entry (array, arrayl, err_code) returns (fixed bin (18));

dcl  i fixed bin,
     lb fixed bin,
     lbound builtin;

	ltype = list_type;
	go to list_common;

create_array: carray: entry (array, arrayl, err_code) returns (fixed bin (18));

	ltype = array_type;

list_common:
	call check_wgs_init_null_node;
	if arrayl < 0 then go to array_too_small_null_node;

	call lsm_$make_blk (wgs_p, node_no, ltype, arrayl, node_ptr, err_code); /* Create list/array block */
	if err_code ^= 0 then return (0);

	lb = lbound (array, 1);

	do i = 1 to arrayl;				/* fill in array elements */
	     node_ptr -> list_node.node (i) = array (lb);
	     lb = lb + 1;
	end;

	return (node_no);


/* --------------------------------------------------------------------------------------------------- */


/* Assign a name to the substructure specified by value_n */

assign_name: entry (name, value_n, err_code) returns (fixed bin (18));
dcl  sym_n fixed bin (18);				/* node # of a symbol node */

	call check_wgs_init_null_node;
	call lsm_sym_$symk (wgs_p, Create_symbol, name, sym_n, value_n, err_code);
						/* get lsm_ to make the new symbol block
						   and stick it in the symbol table */
	return (sym_n);

%page;

/* STRUCTURE MANIPULATION ENTRY POINTS */

/* --------------------------------------------------------------------------------------------------- */

/* Entry to locate a named structure */

find_structure: fstruc: entry (name, value_n, err_code) returns (fixed bin (18));

	call check_wgs_init_null_node;
	sym_n, value_n = 0;

	call lsm_sym_$symk (wgs_p, Find_symbol, name, sym_n, value_n, err_code);
						/* look, don't touch */
	return (sym_n);


/* --------------------------------------------------------------------------------------------------- */
/* Add an element in a list after the idx'th element */
/* if idx = 0 insert before first element */
/* if idx = -1 insert after last element */

add_element: entry (list_n, idx, new_n, err_code);

	call check_wgs_init;

	call find_list_to_alter (wgs_p, node_ptr, list_n, curl, idx, -1, err_code);
	if err_code ^= 0 then return;

	call lsm_$set_blk (wgs_p, list_n, ltype, curl + 1, node_ptr, err_code);
						/* Get lsm_ to increase block length */
	if err_code ^= 0 then return;

	if idx = -1 then node_ptr -> list_node.node (curl + 1) = new_n; /* If last node ... */
	else do;
	     do i = curl to idx + 1 by -1;		/* Move everything down one */
		node_ptr -> list_node.node (i+1) = node_ptr -> list_node.node (i);
	     end;

	     node_ptr -> list_node.node (idx+1) = new_n;
	end;
	return;


/* --------------------------------------------------------------------------------------------------- */

find_list_to_alter: proc (wgs_p, node_ptr, list_n, curl, idx, lowest_allowed, err_code);

dcl (wgs_p pointer,
     node_ptr pointer,
     list_n fixed bin (18),
     curl fixed bin,
     idx fixed bin,
     lowest_allowed fixed bin,
     err_code fixed bin (35)) parameter;

	     call lsm_$get_blk (wgs_p, list_n, ltype, curl, node_ptr, err_code);
	     if err_code ^= 0 then return;

	     if (ltype ^= list_type) & (ltype ^= array_type) then do;
		err_code = graphic_error_table_$inv_node_type;
		return;
	     end;

	     if ((idx < lowest_allowed) & (idx ^= -1)) | (idx > curl) then do;
		err_code = graphic_error_table_$list_oob;
		return;
	     end;

	     return;
	end find_list_to_alter;

/* --------------------------------------------------------------------------------------------------- */
/* Alter the node number of the idx'th element in a list */

replace_element: entry (list_n, idx, new_n, err_code) returns (fixed bin (18));

dcl  temp_idx fixed bin (18) automatic;

	call check_wgs_init_null_node;

	call find_list_to_alter (wgs_p, node_ptr, list_n, curl, idx, 1, err_code);
	if err_code ^= 0 then return (0);

	if idx = -1 then temp_idx = curl;
	else temp_idx = idx;

	node_no = node_ptr -> list_node.node (temp_idx);	/* Save for return */
	node_ptr -> list_node.node (temp_idx) = new_n;
	return (node_no);

/* --------------------------------------------------------------------------------------------------- */
/* Replace an entire substructure whose top node is "old_n" with new_n  */

replace_node: entry (old_n, new_n, err_code);

	call check_wgs_init;

	call replace_node (old_n, new_n, err_code);	/* use internal procedure common to me and remove_symbol */

replace_node: proc (old_node, new_node, err_code);

dcl (old_node, new_node) fixed bin (18) parameter,
     err_code fixed bin (35) parameter;

	     if new_node = 0 then do;
		err_code = graphic_error_table_$null_replacement; /* can't make nodes other than the zero node null */
		return;
	     end;

	     call lsm_$get_blk (wgs_p, old_node, 0, 0, null, err_code);
						/* check to make sure old_node is good node */
	     if err_code ^= 0 then return;

	     call lsm_$replace_blk (wgs_p, old_node, new_node, err_code);
						/* Destructively replace old block with copy */
	     return;

	end replace_node;

	return;

/* --------------------------------------------------------------------------------------------------- */


/* Delete a symbol from the symbol table. */

remove_symbol: entry (name, err_code);

	call check_wgs_init;

	call lsm_sym_$symk (wgs_p, Delete_symbol, name, 0, 0, err_code);
						/* delete the symbol from symbol table */
	return;

/* --------------------------------------------------------------------------------------------------- */

/* Replicate a substructure */

replicate: entry (template_n, err_code) returns (fixed bin (18));

	call check_wgs_init_null_node;
	call lsm_$replicate (wgs_p, template_n, new_n, err_code);
	if err_code ^= 0 then return (0);
	return (new_n);

%page;

/* STRUCTURE EXAMINATION ENTRY POINTS */


/* --------------------------------------------------------------------------------------------------- */
/* Examine type of node */

examine_type: etype: entry (node_n, t_nt, type, err_code);
dcl  t_nt bit (1) aligned;				/* ON if node being examined is non-terminal */

	call check_wgs_init;

	if node_n = 0 then do;
	     t_nt = "0"b;
	     type = -1;				/* null node */
	     err_code = 0;
	     return;
	end;

	call lsm_$get_blk (wgs_p, node_n, lsm_type, curl, node_ptr, err_code);
	if err_code ^= 0 then do;
	     type = -2;
	     return;
	end;

	if lsm_type <= char_type
	then t_nt = "0"b;				/* This is a terminal node */

	else if lsm_type = list_type | lsm_type = array_type | lsm_type = symbol_type then t_nt = "1"b;
	else do;
	     type = -2;
	     go to bad_type;
	end;

	if lsm_type = char_type then type = Text;
	else if lsm_type = bit_type then type = Datablock;
	else if lsm_type = list_type then type = List;
	else if lsm_type = array_type then type = Array;
	else if lsm_type = symbol_type then type = Symbol;
	else type = addr (node_ptr -> any_node.data_space) -> effector.effector_code;

	return;

/* ----------------------------------------------------------------------------------------------------- */

/* Examine a position node */

examine_position: epos: entry (node_n, etype, x, y, z, err_code);

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);

	x, y, z = 0e0;

	if lsm_type ^= float_type then do;
bad_etype:     etype = -2;
	     go to bad_type;
	end;

	effector_p = addr (node_ptr -> any_node.data_space);
	etype = effector_p -> position_effector.effector_code;

	if lsm_curl > 1 then x = effector_p -> position_effector.xpos;
	if lsm_curl > 2 then y = effector_p -> position_effector.ypos;
	if lsm_curl > 3 then z = effector_p -> position_effector.zpos;

	return;

/* ---------------------------------------------------------------------------------------------------- */

/* Examine a modal element */

examine_mode: emode: entry (node_n, etype, mode, err_code);

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);

	if lsm_type ^= float_type
	then go to bad_etype;			/* Mode masquerade as float for some reason(?) */

	effector_p = addr (node_ptr -> any_node.data_space);
	etype = effector_p -> modal_effector.effector_code;
	mode = effector_p -> modal_effector.mode;

	return;

/* ---------------------------------------------------------------------------------------------------- */

/* Examine a color element */

examine_color: ecolor: entry (node_n, int_red, int_green, int_blue, err_code);

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);

	effector_p = addr (node_ptr -> any_node.data_space);
	if effector_p -> effector.effector_code ^= Color
	then go to bad_etype;			/* Node being examined is not a color node */

	int_red = effector_p -> color_effector.red_intensity;
	int_green = effector_p -> color_effector.green_intensity;
	int_blue = effector_p -> color_effector.blue_intensity;

	return;

/* ---------------------------------------------------------------------------------------------------- */

/* Examine a mapping element */

examine_mapping: emap: entry (node_n, etype, farray, flen, err_code);

dcl (farray (*) float bin (27),			/* array into which go mapping values */
     flen fixed bin) parameter;			/* number of useful values in farray */

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);

	farray (*) = 0e0;

	if lsm_type ^= float_type
	then go to bad_etype;			/* All modes use floating values */

	effector_p = addr (node_ptr -> any_node.data_space);
	etype = effector_p -> effector.effector_code;
	if etype < Scaling | etype > Clipping then goto bad_etype;

	if dim (farray, 1) < lsm_curl - 1
	then go to array_too_small;			/* If user-supplied array is too small, complain */

	flen = lsm_curl - 1;

	lb = lbound (farray, 1);

	do i = 1 to flen;				/* Fill in array */
	     farray (lb) = effector_p -> floating_effector.data (i);
	     lb = lb + 1;
	end;

	return;


/* --------------------------------------------------------------------------------------------------- */
/* Examine contents of list node */

examine_list: elist: entry (node_n, array, arrayl, err_code);

dcl  lsm_type fixed bin,				/* lsm_ type code */
     lsm_curl fixed bin;				/* current length of lsm_ block */

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);
	if err_code ^= 0 then return;

	if lsm_type ^= list_type
	then if lsm_type ^= array_type
	     then do;				/* Only allow these types to be examined */
		arrayl = 0;
		go to bad_type;
	     end;

	arrayl = lsm_curl;
	call fill_array;

	return;


/* --------------------------------------------------------------------------------------------------- */

/* Internal procedure to fill array with contents of node */

fill_array: procedure;

dcl  array_max fixed bin,
     dim builtin;

	     array_max = dim (array, 1);
	     if array_max < lsm_curl then go to array_too_small;

	     lb = lbound (array, 1);

	     do i = 1 to lsm_curl;
		array (lb) = node_ptr -> list_node.node (i);
		lb = lb + 1;
	     end;

	     return;

	end;


/* --------------------------------------------------------------------------------------------------- */
/* Examine symbol table */

examine_symtab: esymtab: entry (array, arrayl, err_code);
dcl  p ptr,
     array_dim fixed bin,
     based_array (array_dim) fixed bin (18) based;

	call check_wgs_init;

	lb = lbound (array, 1);
	p = addr (array (lb));
	array_dim = hbound (array, 1) - lb + 1;		/* =_ dim (array, 1) but optimizer crumps on that */

	call lsm_sym_$sym_list (wgs_p, p -> based_array, arrayl, err_code);
	return;


/* --------------------------------------------------------------------------------------------------- */
/* Examine symbol */
examine_symbol: esymbol: entry (node_n, value_n, nchars, char_str, err_code);

	call check_wgs_init;
	call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);
	if lsm_type ^= symbol_type then do;
	     err_code = graphic_error_table_$inv_node_type;
	     return;
	end;

	value_n = node_ptr -> symbol_node.value_node;
	call lsm_$get_blk (wgs_p, (node_ptr -> symbol_node.name_node), lsm_type, nchars, node_ptr, err_code);
	char_str = node_ptr -> char_node.string;

	return;


/* ------------------------------------------------------------------------------------------------------ */


/* Examine text block */

examine_text: etext: entry (node_n, alignment, nchars, char_str, err_code);
dcl  char_str char (*),
     nchars fixed bin;

	call check_wgs_init;
	call get_special_block (char_type);
	alignment = effector_p -> text_effector.alignment;
	nchars = lsm_curl - 1;			/* First char is alignment */
	char_str = substr (effector_p -> text_effector.text, 1, nchars);
	return;


%page;

/* STRUCTURE SAVING, PERMANENT GRAPHIC SEGMENT MANIPULATION */
/* --------------------------------------------------------------------------------------------------- */

/* Examine data block */

examine_data: edata: entry (node_n, nbits, bit_str, err_code);
dcl  bit_str bit (*),
     nbits fixed bin;

	call check_wgs_init;
	call get_special_block (bit_type);
	bit_str = node_ptr -> bit_node.string;
	nbits = lsm_curl;
	return;


/* --------------------------------------------------------------------------------------------------- */

/* Internal procedure to get a text or data block */

get_special_block: procedure (spec_type);
dcl  spec_type fixed bin;
	     err_code = 0;

	     call lsm_$get_blk (wgs_p, node_n, lsm_type, lsm_curl, node_ptr, err_code);
	     if err_code ^= 0 then go to error_return;
	     effector_p = addr (node_ptr -> any_node.data_space);
	     if lsm_type ^= spec_type then go to bad_type;
	     return;
	end;


/* --------------------------------------------------------------------------------------------------- */

/* Get the graphic structure named by "name" from the p.g.s. named "dname"
   and "ename", and merge it into the current WGS. */

get_struc: entry (dname, x_ename, name, merge_code, err_code);


dcl  merge_code fixed bin parameter,			/* Determines disposition of named substructures */
     x_ename char (*) parameter,			/* ename, possibly without suffix ".pgs" */
     ename char (32);				/* with ".pgs" suffix added */

/* Values of nerge_code */
/* 0 - Copy named substructures from PGS, error on naming conflict */
/* 1 - Copy named substructures from PGS, overwrite on naming conflict */
/* 2 - Insert identically named substrcuctures  from WGS, create symbol
   with 0 value for those that dont exist in WGS */
/* 3 - same as 2, but copy symbols from PGS if they dont already exist in WGS */

	call add_pgs_suffix;
	call move_struc ("0"b);			/* If pgs does not exist, return with error */
	return;
%skip (5);
/* ------------------------------ */

add_pgs_suffix: proc;

dcl  suffixed_name_$make ext entry (char (*), char (*), char (32), fixed bin (35));

	     call suffixed_name_$make (x_ename, "pgs", ename, err_code);
	     if err_code ^= 0 then goto error_return;
	     return;

	end add_pgs_suffix;

/* ------------------------------ */


/* --------------------------------------------------------------------------------------------------- */
/* Put graphic structure "name" from wgs to pgs */

put_struc: entry (dname, x_ename, name, merge_code, err_code);

/* Values of merge_code are same as for get_struc, but interchange WGS and PGS */

	call check_wgs_init;
	call add_pgs_suffix;
	call move_struc ("1"b);
	return;


/* --------------------------------------------------------------------------------------------------- */

/* Internal procedure to move a structure between the wgs and pgs */

move_struc: procedure (put_sw);

dcl  put_sw bit (1) aligned,				/* controls direction of movement */
     pgs_p pointer;					/* pointer to permanent graphic seg */

	     err_code = 0;
	     call lsm_fs_$init_seg (pgs_p, dname, ename, Find_seg, err_code);
						/* See if pgs already exists */
	     if pgs_p = null () then
		if ^ put_sw then goto error_return;
		else do;				/* Otherwise, must create it */
		     call lsm_fs_$init_seg (pgs_p, dname, ename, Create_seg, err_code); /* Create new lsm seg */
		     if err_code ^= 0 then go to error_return;

		     call init_graphic_segment (pgs_p);
		end;

	     if put_sw then call move_it (wgs_p, pgs_p);	/* Movement from wgs to pgs */
	     else call move_it (pgs_p, wgs_p);		/* Movement is from pgs to wgs */
	     return;


/* Internal procedure to move a structure from one gm_ seg to another */
move_it:	     procedure (from_p, to_p);

dcl (from_p, to_p) pointer,				/* pointers to gm_ segs */
    (from_val_n, from_sym_n) fixed bin (18);		/* node # in from seg of node to be moved */

		err_code = 0;

		call lsm_sym_$symk (from_p, Find_symbol, name, from_sym_n, from_val_n, err_code);
						/* look, don't touch */
						/* See if symbol exists in segment from which it will be moved */
		if err_code ^= 0 then go to error_return;

		call lsm_fs_$merge_symbol (from_p, to_p, from_sym_n, "1"b, merge_code, err_code);
		if err_code ^= 0 then return;

/* if we are moving to PGS, update the bitcount. */

		if to_p = pgs_p then do;
		     call hcs_$set_bc_seg (pgs_p, pgs_p -> lsm.free * 36, err_code);
		     if err_code ^= 0 then goto error_return;
		end;

		return;
	     end move_it;
	end move_struc;


/* --------------------------------------------------------------------------------------------------- */
/* Save current wgs in pgs specified by dname, ename */

save_file: entry (dname, x_ename, err_code);

dcl  pgs_p pointer;

dcl  hcs_$terminate_noname ext entry (pointer, fixed bin (35)),
     hcs_$set_bc_seg ext entry (pointer, fixed bin (24), fixed bin (35));

	call check_wgs_init;
	call add_pgs_suffix;
	call lsm_fs_$push (wgs_p, dname, ename, err_code);
	if err_code ^= 0 then return;

/* now be nice to the user and set the bitcount of the pgs. */
	call hcs_$initiate (dname, ename, "", 0, 1, pgs_p, err_code);
	if pgs_p = null then return;

	call hcs_$set_bc_seg (pgs_p, pgs_p -> lsm.free * 36, err_code);
	if err_code ^= 0 then return;

	call hcs_$terminate_noname (pgs_p, err_code);
	return;


/* --------------------------------------------------------------------------------------------------- */
/* Use graphic structure in pgs specified by dname, ename as the wgs */

use_file:	entry (dname, x_ename, err_code);
	err_code = 0;
	call add_pgs_suffix;
	if wgs_p = null then call get_wgs;
	call lsm_fs_$init (wgs_p, err_code);		/* Reinitialize wgs */
	if err_code ^= 0 then return;

	call lsm_fs_$pull (wgs_p, dname, ename, err_code); /* Pull in graphic structure from p.g.s. */
	return;


/* --------------------------------------------------------------------------------------------------- */


error_return_null_node: return (0);			/* Error return for entries which return a node number */

error_return: return;				/* Error return for entries that do not return anything */

bad_align: err_code = graphic_error_table_$bad_align;
	return (0);

bad_type_null_node: err_code = graphic_error_table_$inv_node_type;
	return (0);

bad_type:	err_code = graphic_error_table_$inv_node_type;
	return;

no_wgs_yet: err_code = graphic_error_table_$no_wgs_yet;
	return;

no_wgs_yet_null_node: err_code = graphic_error_table_$no_wgs_yet;
	return (0);

array_too_small_null_node: err_code = error_table_$smallarg;
	return (0);

array_too_small: err_code = error_table_$smallarg;
	return;


     end graphic_manipulator_;
   



		    graphic_operator_.pl1           11/18/82  1706.7rew 11/18/82  1625.4      186228


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

graphic_operator_: go_: procedure; return;

/* Entry points allow dynamic interaction with a graphic terminal */
/* Originally coded 9/10/73 by Lee J. Scheffler */
/* Modified 08/14/79 by C. D. Tavares for version 7 lsm_ */
/* Last modified 10/14/8 by CDT to know about effectors with trailing
   zero coordinates unstored. */

/* PARAMETERS */

dcl ((list_n, new_n, node_n, incr_n) fixed bin (18),	/* Node ids */
     err_code fixed bin (35),
     desired_switch pointer,
    (immediacy_parameter, old_immediacy) bit (1) aligned,
     index fixed bin,
    (desired_i_switch, desired_o_switch) pointer,
     device fixed bin,
    (xpos, ypos, zpos) float bin,
     top_n fixed bin (18),
     path_len fixed bin,
     path_array (*) fixed bin,
     no_iter fixed bin,
     delay float bin,
     device_used fixed bin) parameter;

/* AUTOMATIC */

dcl (old_n fixed bin (18),
     return_node fixed bin (18),
     cur_input_switch pointer initial (null),
     cur_output_switch pointer initial (null),
     t_nt bit (1) aligned,				/* terminal or non-terminal node */
    (etype, incr_type) fixed bin,
     i fixed bin,
     inlen fixed bin (21),
     save_outindex fixed bin initial (outindex),
     cant_wait bit (1) initial (""b) aligned,
    (incr_p, effector_p) pointer,
     nchars fixed bin,
     lsm_type fixed bin,
     lsm_curl fixed bin,
     increment_string char (32),
     new_node fixed bin (18),
     new_type fixed bin,
     float_coords (3) float bin,
     lb fixed bin,
     path_array_ptr pointer,
     effector_type fixed bin,
     effector_len fixed bin,
     incr_len fixed bin) automatic;

/* STATIC */

dcl ((graphic_input, graphic_output) pointer initial (null),
     wgs_p pointer initial (null),
     buffer_ptr pointer initial (null),
     sys_area_p pointer initial (null),
     uninitted bit (1) aligned initial ("1"b),
     max_string_size fixed bin (21) initial (0),
     outstring char (512) unaligned,
     outindex fixed bin initial (1),
     immediacy bit (1) aligned initial ("1"b),
     saved_which_ptr pointer initial (null)) static;

/* ENTRIES */

dcl (graphic_code_util_$encode_spi,
     graphic_code_util_$encode_dpi,
     graphic_code_util_$encode_uid) entry (dimension (*) fixed bin, fixed bin, pointer),
     graphic_code_util_$encode_scl entry (dimension (*) float bin, fixed bin, pointer),
    (graphic_code_util_$decode_spi,
     graphic_code_util_$decode_dpi,
     graphic_code_util_$decode_uid) entry (pointer, fixed bin, dimension (*) fixed bin),
     graphic_code_util_$decode_scl entry (pointer, fixed bin, dimension (*) float bin),
     get_system_free_area_ ext entry returns (pointer),
     get_temp_segment_ ext entry (char (*), pointer, fixed bin (35)),
     cu_$arg_count ext entry returns (fixed bin),
     graphic_decompiler_ ext entry (char (*), fixed bin (35)) returns (fixed bin (18));

/* BASED AND DEFINED */

dcl  sys_area area based (sys_area_p),
     dum_array (1) fixed bin based,
     dum_float_array (1) float bin based,
     decompile_string char (inlen) based (buffer_ptr),
     top_n_array (1) fixed bin based (addr (top_n)),
     path_len_array (1) fixed bin based (addr (path_len)),
     based_path_array (path_len) fixed bin based,
     device_used_array (1) fixed bin based (addr (device_used));


dcl 1 saved_which aligned based (saved_which_ptr),
    2 saved_top_n fixed bin (18),
    2 saved_path_len fixed bin,
    2 saved_path_array (path_len refer (saved_path_len)) fixed bin;

dcl 1 fixed_effector aligned based,
    2 effector_code fixed bin,
    2 element (1000) fixed bin;

dcl  outstring_array (512) char (1) unaligned defined (outstring);

/* BUILTINS AND CONDITIONS */

dcl (addr, lbound, substr, null, dim) builtin;

dcl  cleanup condition;

/* EXTERNAL STATIC */

dcl (graphic_error_table_$inv_node_type,
     graphic_error_table_$malformed_input,
     graphic_error_table_$node_mismatch,
     graphic_error_table_$bad_no_iter,
     graphic_error_table_$neg_delay,
     graphic_error_table_$bad_device_type,
     error_table_$smallarg) fixed bin (35) external;

dcl  sys_info$max_seg_size ext fixed bin (35);
%page;
%include iox_dcls;
%page;
%include lsm_formats;
%page;
%include graphic_templates;
%page;
%include graphic_etypes;
%page;
%include graphic_enames;
%page;
%include graphic_comp_specs;
%page;
%include graphic_input_formats;
%page;
%include gm_entry_dcls;
%page;
%include gc_entry_dcls;
%page;
%include lsm_entry_dcls;
%page;
setup:	procedure;

/* Internal procedure to get pointer to working graphic segment */

	     call graphic_manipulator_$segp (wgs_p, err_code); /* Get ptr to current working graphic segment */
	     if err_code ^= 0 then go to non_local_return;

	     sys_area_p = get_system_free_area_ ();

	     call get_temp_segment_ ("graphic_operator_", buffer_ptr, err_code);
	     if err_code ^= 0 then goto non_local_return;

	     max_string_size = sys_info$max_seg_size * 4;

	     uninitted = ""b;

	     return;
	end setup;
%skip (2);
non_local_return:
	outindex = save_outindex;
	return;
%skip (2);
write_it_out: procedure;

/* Internal procedure to write out a dynamic effector or order */

	     err_code = 0;
	     if immediacy | cant_wait | outindex > 480 then save_outindex = 1;
	     else return;

	     on cleanup outindex, save_outindex = 1;

	     if graphic_output = null then do;
		call iox_$look_iocb ("graphic_output", graphic_output, err_code);
		if err_code ^= 0 then goto non_local_return;
	     end;

	     if cur_output_switch = null then cur_output_switch = graphic_output;

	     call iox_$put_chars (cur_output_switch, addr (outstring),
		outindex - 1, err_code);

	     if err_code ^= 0 then go to non_local_return;;

	     outindex = 1;

	     return;
	end write_it_out;
%page;
dispatch_switch: entry (err_code, desired_switch);

	cur_output_switch = desired_switch;
%skip (2);
dispatch:	entry (err_code);

	cant_wait = "1"b;
	call write_it_out;
	return;
%skip (2);
reset:	entry;

	outindex = 1;

	if saved_which_ptr ^= null then free saved_which in (sys_area);

	return;
%page;
set_immediacy: entry (immediacy_parameter, old_immediacy, err_code);

	if cu_$arg_count () = 2 then begin;		/* old style calling sequence */

declare  based_code fixed bin (35) based (addr (old_immediacy));

	     call set_immediacy (immediacy_parameter, ""b, based_code);
	     return;
	end;

	old_immediacy = immediacy;

	immediacy = immediacy_parameter;
	if immediacy then call write_it_out;

	return;
%page;
replace_element_switch: entry (list_n, index, new_n, err_code, desired_switch) returns (fixed bin (18));

	cur_output_switch = desired_switch;
%skip (2);
replace_element: entry (list_n, index, new_n, err_code) returns (fixed bin (18));

/* Replace the index'th node in "list_n" with node "new_n" */

	if uninitted then call setup;

	old_n = graphic_manipulator_$replace_element (list_n, index, new_n, err_code);
						/* Alter the list node in the working graphic seg */
	if err_code ^= 0 then return (old_n);

	outstring_array (outindex) = Alter_char;
	call graphic_code_util_$encode_uid (addr (list_n) -> dum_array, 1, addr (outstring_array (outindex + 1)));
						/* Stick in node id of list being altered */
	outindex = outindex + 1 + arg_lengths (UI);

	call graphic_code_util_$encode_dpi (addr (index) -> dum_array, 1, addr (outstring_array (outindex)));
						/* Stick in index of list element being replaced */
	outindex = outindex + arg_lengths (DPI);

	call graphic_code_util_$encode_uid (addr (new_n) -> dum_array, 1, addr (outstring_array (outindex)));
	outindex = outindex + arg_lengths (UI);

	call write_it_out;

	return (old_n);				/* Give back node # of node replaced */

/* --------------------------------------------------------------------------- */

/* Delete a node in terminal memory */

delete_switch: entry (node_n, err_code, desired_switch);

	cur_output_switch = desired_switch;

delete:	entry (node_n, err_code);

	outstring_array (outindex) = Delete_char;

simple_common:					/* Nodes with just a node # come here */
	call graphic_code_util_$encode_uid (addr (node_n) -> dum_array, 1, addr (outstring_array (outindex + 1)));
	outindex = outindex + 1 + arg_lengths (UI);

	call write_it_out;

	return;

/* --------------------------------------------------------------------- */

/* Display a node already residing in terminal memory */

display_switch: entry (node_n, err_code, desired_switch);

	cur_output_switch = desired_switch;

display:	entry (node_n, err_code);

	outstring_array (outindex) = Display_char;
	go to simple_common;

/* ----------------------------------------------------------------------- */

/* Erase a node currently being displayed */

erase_switch: entry (err_code, desired_switch);

	cur_output_switch = desired_switch;

erase:	entry (err_code);

	outstring_array (outindex) = Erase_char;
	go to simplest_common;

/* --------------------------------------------------------------------- */

/* Cause remote terminal to complete all parallel processing
   before proceeding with interpretation of the rest of the graphic output */

synchronize_switch: entry (err_code, desired_switch);

	cur_output_switch = desired_switch;

synchronize: entry (err_code);

	outstring_array (outindex) = Synchronize_char;

simplest_common:					/* Common point for all no-argument effectors */

	outindex = outindex + 1;
	call write_it_out;
	return;

/* ------------------------------------------------------------------------- */

/* Cause graphic terminal to continue display, but wait for user to
   indicate an interaction somehow */

pause_switch: entry (err_code, desired_switch);

	cur_output_switch = desired_switch;

pause:	entry (err_code);

	outstring_array (outindex) = Pause_char;
	outindex = outindex + 1;
	call write_it_out;

	return;

/* ------------------------------------------------------------------------ */

/* Increment "node_n" "no_iter" times with "delay" seconds (accurate to 1/32)
   between increments (starting with a delay, using
   node "incr_n" as a template to supply the increments */

increment_switch: entry (node_n, no_iter, delay, incr_n, err_code, desired_switch);

	cur_output_switch = desired_switch;
%skip (5);
increment: entry (node_n, no_iter, delay, incr_n, err_code);

	if uninitted then call setup;
	if no_iter <= 0 then do;			/* Obviously out of range */
	     err_code = graphic_error_table_$bad_no_iter;
	     return;
	end;

	if delay < 0e0 then do;
	     err_code = graphic_error_table_$neg_delay;
	     return;
	end;


	call graphic_manipulator_$examine_type (node_n, t_nt, etype, err_code);
	if err_code ^= 0 then return;
	if t_nt then do;				/* If a non-terminal node, cannot do increment */
inv_type:	     err_code = graphic_error_table_$inv_node_type;
	     return;
	end;
	call graphic_manipulator_$examine_type (incr_n, t_nt, incr_type, err_code);
	if err_code ^= 0 then return;
	if t_nt then go to inv_type;

	if etype ^= incr_type
	then go to inv_type;

	if etype >= Symbol
	then go to inv_type;

can_do_increment:
	call lsm_$get_blk (wgs_p, node_n, effector_type, effector_len, node_ptr, err_code);
						/* Get pointer to original node */
	effector_p = addr (node_ptr -> any_node.data_space);

	call lsm_$get_blk (wgs_p, incr_n, lsm_type, incr_len, node_ptr, err_code);
	incr_p = addr (node_ptr -> any_node.data_space);

	if incr_len > effector_len then do;		/* must grow data space of original effector */
	     call lsm_$set_blk (wgs_p, node_n, effector_type, incr_len, node_ptr, err_code);
						/* Get lsm_ to increase block length */
	     if err_code ^= 0 then return;
	     effector_p = addr (node_ptr -> any_node.data_space);
	end;

/* Perform incrementing in working graphic seg */

	if etype <= Clipping then
	     do i = 1 to incr_len - 1;		/* Floating elements */
	     effector_p -> floating_effector.data (i) =
		effector_p -> floating_effector.data (i) + incr_p -> floating_effector.data (i) * no_iter;
	end;

	else do i = 1 to incr_len - 1;		/* Fixed elements */
	     effector_p -> fixed_effector.element (i) =
		effector_p -> fixed_effector.element (i) + incr_p -> fixed_effector.element (i) * no_iter;
	end;

	outstring_array (outindex) = Increment_char;
	call graphic_code_util_$encode_uid (addr (node_n) -> dum_array, 1, addr (outstring_array (outindex + 1)));
	outindex = outindex + 1 + arg_lengths (UI);

	call graphic_code_util_$encode_dpi (addr (no_iter) -> dum_array, 1, addr (outstring_array (outindex)));
	outindex = outindex + arg_lengths (DPI);

	call graphic_code_util_$encode_scl (addr (delay) -> dum_float_array, 1, addr (outstring_array (outindex)));
	outindex = outindex + arg_lengths (SCL);


/* Get graphic_compiler_ to compile the increment node */

	call graphic_compiler_$return_string (incr_n, addr (increment_string), nchars, err_code);
	if err_code ^= 0 then return;
	nchars = nchars - 3 - arg_lengths (UI);		/* Strip off list indicator, node begin, node id, node end */
	substr (outstring, outindex, nchars) = substr (increment_string, 3 + arg_lengths (UI), nchars);
	outindex = outindex + nchars;
	call write_it_out;
	return;

/* ------------------------------------------------------------------------ */

/* Place position node "node_n" under control of terminal processor interaction with user */

control_switch: entry (node_n, err_code, desired_switch);

	cur_output_switch = desired_switch;
%skip (5);
control:	entry (node_n, err_code);

	if uninitted then call setup;

	cant_wait = "1"b;

	call graphic_manipulator_$examine_type (node_n, t_nt, etype, err_code);
	if err_code ^= 0 then return;
	if t_nt then go to inv_type;			/* only terminal nodes */

	outstring_array (outindex) = Control_char;
	call graphic_code_util_$encode_uid (addr (node_n) -> dum_array, 1, addr (outstring_array (outindex + 1)));
	outindex = outindex + 1 + arg_lengths (UI);

	call write_it_out;

	call do_actual_input;
	if err_code ^= 0 then return;

	new_node = graphic_decompiler_ (decompile_string, err_code);

	call graphic_manipulator_$examine_type (new_node, t_nt, new_type, err_code);
	if err_code ^= 0 then return;
	if t_nt then goto inv_type;
	if etype ^= new_type then do;
	     err_code = graphic_error_table_$node_mismatch;
	     return;
	end;

	call graphic_manipulator_$replace_node (node_n, new_node, err_code);

	return;

/* -------------------------------------------------------------------- */

do_actual_input: proc;

	     if graphic_input = null then do;
		call iox_$look_iocb ("graphic_input", graphic_input, err_code);
		if err_code ^= 0 then return;
	     end;

	     if cur_input_switch = null then cur_input_switch = graphic_input;

	     call iox_$get_line (cur_input_switch, buffer_ptr, max_string_size, inlen, err_code);
	     if err_code ^= 0 then return;

	     return;

	end do_actual_input;

/* -------------------------------------------------------------------- */

/* Obtain a where input from the graphic terminal */

where_switch: entry (device, xpos, ypos, zpos, err_code, desired_i_switch, desired_o_switch);

	cur_input_switch = desired_i_switch;
	cur_output_switch = desired_o_switch;

where:	entry (device, xpos, ypos, zpos, err_code);

	call query (Where_char);
	if err_code ^= 0 then return;

	if buffer_ptr -> where_format.node_begin ^= Node_begin_char then goto bad_input_format;
	if buffer_ptr -> where_format.array_indicator ^= Array_char then goto bad_input_format;
	if buffer_ptr -> where_format.mbz ^= zero_node_id then goto bad_input_format;
	if buffer_ptr -> where_format.setpos_indicator ^= Setposition_char then goto bad_input_format;
	if buffer_ptr -> where_format.node_end ^= Node_end_char then do;
bad_input_format:
	     err_code = graphic_error_table_$malformed_input;
	     return;
	end;

	call graphic_code_util_$decode_scl (addr (buffer_ptr -> where_format.xpos), 3, float_coords);
						/* Decode all the positions */
	xpos = float_coords (1);
	ypos = float_coords (2);
	zpos = float_coords (3);

	return;


/* ------------------------------------------------------------------- */

/* Obtain a which input from the graphic terminal */

which_switch: entry (device, top_n, path_len, path_array, err_code, desired_i_switch, desired_o_switch);

	cur_input_switch = desired_i_switch;
	cur_output_switch = desired_o_switch;

which:	entry (device, top_n, path_len, path_array, err_code);

	err_code = 0;

	if saved_which_ptr ^= null then do;		/* we have some old which input pending */

	     path_len = saved_path_len;		/* tell user depth of pathname */

	     if dim (path_array, 1) >= path_len then do;	/* we now have enough room */
		top_n = saved_top_n;		/* fill all the output args */
		addr (path_array) -> based_path_array = saved_path_array;
		free saved_which in (sys_area);
		saved_which_ptr = null ();
	     end;

	     else err_code = error_table_$smallarg;	/* still need more room, guy */

	     return;

	end;


	call query (Which_char);			/* get some fresh input */
	if err_code ^= 0 then return;

	if buffer_ptr -> which_format.node_begin ^= Node_begin_char then goto bad_input_format;

	call graphic_code_util_$decode_uid (addr (buffer_ptr -> which_format.node_id), 1, top_n_array);
						/* Decode root node # */

	call graphic_code_util_$decode_spi (addr (buffer_ptr -> which_format.depth), 1, path_len_array);
						/* Find out how many levels */

	if path_len <= 0 then return;			/* If no levels, return */

	if path_len > dim (path_array, 1) then do;	/* If supplied array is too small */
						/* to hold entire tree path... */
	     err_code = error_table_$smallarg;
	     allocate saved_which in (sys_area);
	     saved_top_n = top_n;
	     path_array_ptr = addr (saved_which.saved_path_array);
	     lb = 1;
	end;

	else do;
	     path_array_ptr = addr (path_array);
	     lb = lbound (path_array, 1);
	end;

	call graphic_code_util_$decode_dpi
	     (addr (buffer_ptr -> which_format.path_array), path_len, addr (path_array (lb)) -> based_path_array);
						/* Decode all the list indices */

	return;

/* ------------------------------------------------------------------ */

/* Obtain a what input from the graphic terminal */

what_switch: entry (device, device_used, err_code, desired_i_switch, desired_o_switch) returns (fixed bin (18));

	cur_input_switch = desired_i_switch;
	cur_output_switch = desired_o_switch;

what:	entry (device, device_used, err_code) returns (fixed bin (18));

	if uninitted then call setup;

	call query (What_char);
	if err_code ^= 0 then return (0);

	if buffer_ptr -> what_format.begin ^= Node_begin_char then goto bad_input_format;

	graphic_structure_len = inlen - 4;		/* subtract out node begin, device code, node end, and newline */

	call graphic_code_util_$decode_spi (addr (buffer_ptr -> what_format.device_code), 1, device_used_array);

	return_node = graphic_decompiler_ (buffer_ptr -> what_format.graphic_structure, err_code);

	return (return_node);

/* ------------------------------------------------------------------- */
/* Internal procedure to write a query effector out */

query:	procedure (query_type);

dcl  query_type char (1) aligned parameter;

	     err_code = 0;
	     if uninitted then call setup;
	     cant_wait = "1"b;
	     outstring_array (outindex) = Query_char;
	     outstring_array (outindex + 1) = query_type;

	     if device < -1 then goto no_such_device;
	     if device > 63 then goto no_such_device;

	     if substr (Input_device_names (device), 1, 8) = "undefine"
	     then do;
no_such_device:	err_code = graphic_error_table_$bad_device_type;
		go to non_local_return;
	     end;

	     call graphic_code_util_$encode_spi (addr (device) -> dum_array, 1, addr (outstring_array (outindex + 2)));
	     outindex = outindex + 2 + arg_lengths (SPI);

	     outstring_array (outindex) = Synchronize_char;
	     outindex = outindex + 1;

	     call write_it_out;

	     call do_actual_input;
	     return;
	end query;

     end graphic_operator_;



		    graphic_terminal_status_.pl1    11/18/82  1706.7rew 11/18/82  1627.9       33057


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* This program interprets error messages from intelligent graphic terminals.
   Coded about Sept 1973 by C. D. Tavares
   Last modified 2/10/75 by C. D. Tavares to make list indices DPI from SPI. */
graphic_terminal_status_: proc;
	return;

decode:	entry (instring, error_code);

dcl  instring char (*) parameter,
     error_code fixed bin parameter;

dcl  code fixed bin;

dcl  keep_instring char (100) aligned static varying,
     depth fixed bin static,
     path (25) fixed bin static,
     node fixed bin static,
     static_error_code static fixed bin,
     error_char char (1) static,
     temp_array (1) fixed bin,
     temp_string char (32);

dcl  initted bit (1) static initial (""b) aligned,
     error_list (0:64) static internal fixed bin (35) initial ((65) -1);

%include graphic_code_dcl;

	keep_instring = instring;
	depth, node = 0;
	error_char = "@";				/* no error */

	if substr (keep_instring, 1, 1) ^= Node_begin_char then do;
	     code = 64;
	     goto return_error;
	end;

	temp_string = substr (keep_instring, 2, 1);

	call graphic_code_util_$decode_spi (addr (temp_string), 1, temp_array);
	code = temp_array (1);

	if code = 0 then do;
	     if length (keep_instring) ^= 4 then code = 64;
	     else if substr (keep_instring, 3, 1) ^= Node_end_char then code = 64;
	     else return;
	end;

	error_char = substr (keep_instring, 3, 1);

	temp_string = substr (keep_instring, 4, 3);
	call graphic_code_util_$decode_uid (addr (temp_string), 1, temp_array);
	node = temp_array (1);

	temp_string = substr (keep_instring, 7, 1);
	call graphic_code_util_$decode_spi (addr (temp_string), 1, temp_array);
	depth = temp_array (1);

	temp_string = substr (keep_instring, 8, depth*2);
	call graphic_code_util_$decode_dpi (addr (temp_string), depth, path);

	if length (keep_instring) ^= 9 + depth*2 then code = 64;
	if substr (keep_instring, 8 + depth*2, 1) ^= Node_end_char then code = 64;

return_error:
	if ^initted then call initialize_error_list;

	error_code, static_error_code = error_list (code);
	return;

initialize_error_list: proc options (no_quick_blocks);

%include graphic_terminal_errors;

	     error_list = Graphic_terminal_errors;
	     initted = "1"b;
	     return;
	end;


interpret: entry (status_code, errchar, nd, dp, pth, error_code);

dcl (status_code, nd, dp, pth (*)) fixed bin parameter,
     i fixed bin,
     errchar char (1);

dcl  error_table_$smallarg ext fixed bin;

	error_code = 0;
	status_code = static_error_code;
	errchar = error_char;
	nd = node;
	dp = depth;
	if dim (pth, 1) < depth then error_code = error_table_$smallarg;
	else do i = 1 to depth;
	     pth (i) = path (i);
	end;

	return;


/* %include graphic_code_util_; */
dcl (graphic_code_util_$decode_spi,
     graphic_code_util_$decode_dpi,
     graphic_code_util_$decode_uid) ext entry (pointer, fixed bin, (*) fixed bin);

     end graphic_terminal_status_;
   



		    gui_.pl1                        11/18/82  1706.7rew 11/18/82  1625.5       76041


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

gui_: proc;
	return;

/* Written by S. Duren, circa 1971.
   Modified extensively by C. D. Tavares circa 1971/2 to rid it of
   "using and writing into other entries' parameters" bugs.
   Modified 01/21/75 by CDT to get rid of another of same type in circle generator. */
/* Modified 07/05/78 by CDT to add entrypoints without trailing underscores. */
/* Modified 09/28/78 by CDT to improve list management when many calls occur between displays */
/* Last modified 04/25/80 by CDT to replace calls to com_err_ with sub_err_ */


dcl  erase_switch bit (1) aligned initial ("1"b) static,
     master_node fixed bin (18) static,
     main_node fixed bin (18) static,
     active_node fixed bin (18) static,
     item_node fixed bin (18),
    (dx, dy) fixed bin,
     sub_err_ ext entry options (variable),
    (q, angle, delta, r) float bin,
    (sqrt, sin, cos, float, abs, length, null) builtin,
     acos_ ext entry (float bin (27)) returns (float bin (27)),
     arr (4) fixed bin (18);

dcl  graphic_operator_$delete ext entry (fixed bin (18), fixed bin (35));

%include graphic_etypes;
%include gm_entry_dcls;
%include gc_entry_dcls;

dcl (i, steps, switch)fixed bin,
    (oldx, oldy, relx, rely) float bin,
     code fixed bin (35),
     array (150) fixed bin (18),
     pi initial (3.14159265e0) float bin static,
     item_code initial (Vector) fixed bin;

dcl  saved_linetype fixed bin static;

dcl  graphic_error_table_$lsm_blk_len ext fixed bin (35) static;

ginit_: ginit: entry;

	erase_switch = "1"b;			/* subsequent calls to display will cause erase */

grmv_: grmv: entry;

	saved_linetype = Solid;

	call graphic_manipulator_$init (code);		/* create working graphic segment */
	if code ^= 0 then goto report_error;

	call graphic_operator_$delete (0, code);
	if code ^= 0 then goto report_error;

create_dummy:
	active_node = graphic_manipulator_$create_array ((0), 0, code);
	if code ^= 0 then goto report_error;
	main_node = graphic_manipulator_$create_array ((active_node), 1, code);
	if code ^= 0 then goto report_error;
	master_node = graphic_manipulator_$assign_name ("gui_display_list_", main_node, code);

check_error:
	if code = 0 then return;

report_error:
	call sub_err_ (code, "gui_", "c", null, 0, "Error in creating or appending to display list.");
	return;


gsps_: gsps: entry (x, y, z);

dcl (x, y, z) fixed bin;

	item_code = Setposition;			/* set position */
make_item:
	item_node = graphic_manipulator_$create_position (item_code, float (x), float (y), float (z), code);

check_item_error:
	if code ^= 0 then do;
	     call sub_err_ (code, "gui_", "c", null, 0, "Error in appending item to display list.");

	     return;

	end;
append_item:
	call graphic_manipulator_$add_element (active_node, -1, item_node, code);
	if code = 0 then return;

	if code ^= graphic_error_table_$lsm_blk_len then goto report_error; /* too bad */

/* we've overflowed one array, create another and forge on. */

	arr (1) = graphic_manipulator_$create_mode (Linetype, saved_linetype, code); /* remember the pending linetype in the new array */
	if code ^= 0 then goto report_error;

	arr (2) = item_node;			/* try to insert the desired item again */

	active_node = graphic_manipulator_$create_array (arr, 2, code); /* make a completely new array */
	if code ^= 0 then goto report_error;

	call graphic_manipulator_$add_element (main_node, -1, active_node, code); /* great, add it to main array */
	if code ^= 0 then goto report_error;

	return;


gspt_: gspt: entry (x, y, z);

	item_code = Setpoint;
	goto make_item;


gpnt_: gpnt: entry (x, y, z);

	item_code = Point;
	goto make_item;


gvec_: gvec: entry (x, y, z);

	item_code = Vector;
	goto make_item;


gsft_: gsft: entry (x, y, z);

	item_code = Shift;
	goto make_item;


gdot_: gdot: entry (value);

dcl  value fixed bin;

	item_node = graphic_manipulator_$create_mode (Linetype, value, code);
	saved_linetype = value;
	goto comad1;


gtxt_: gtxt: entry (cstring, alignment);

dcl  cstring char (*),
     alignment fixed bin;

	if cu_$arg_count () = 1 then al = 1;
	else al = alignment;

	len = length (cstring);

make_text:
	item_node = graphic_manipulator_$create_text (al, len, cstring, code);
	goto check_item_error;


gtxtf_: gtxtf: entry (cstring, n, alignment);

dcl (n, al, len) fixed bin;

dcl  cu_$arg_count ext entry returns (fixed bin);

	if cu_$arg_count () = 2 then al = 1;
	else al = alignment;
	len = n;
	goto make_text;


gbox_: gbox: entry (dx1, dy1);

	arr (1) = graphic_manipulator_$create_position (Vector, 0e0, float (dy1), 0e0, code);
	arr (2) = graphic_manipulator_$create_position (Vector, float (dx1), 0e0, 0e0, code);
	arr (3) = graphic_manipulator_$create_position (Vector, 0e0, float (-dy1), 0e0, code);
	arr (4) = graphic_manipulator_$create_position (Vector, float (-dx1), 0e0, 0e0, code);
	item_node = graphic_manipulator_$create_array (arr, 4, code);
comad1:	call graphic_manipulator_$add_element (active_node, -1, item_node, code);
	if code ^= 0 then goto report_error;
	return;


gcirc_: gcirc: entry (dx1, dy1);

dcl (dx1, dy1) fixed bin;
dcl (xx, yy) float bin;


	switch = 0;				/* circle needs final vector to return to starting position */
equin:	q = 2.e0;
	dx = dx1;dy = dy1;
arcin:	r = sqrt (float (dx*dx+dy*dy));
	angle = acos_ (float (-dx)/r);		/* compute angle that a line from initial point */
						/* to the center would make with the horizontal axis */
	if dy > 0 then angle = -angle;
	if switch = 1 then goto luprep;
	steps = abs ((q/2.e0)* (10.e0 + r/10.e0))+3;	/* compute no. of vectors needed to complete circle */
	delta = (q*pi)/steps;			/* compute portion of circle for ea. vector */
luprep:	oldx = -dx;oldy = -dy;relx = 0;rely = 0;
loop:	do i = 1 to steps ;
	     angle = angle+delta;

	     xx = r*cos (angle);
	     yy = r*sin (angle);

	     array (i) = graphic_manipulator_$create_position (item_code, xx - oldx, yy - oldy, 0e0, code);
						/* put a vector in the display list */
	     if code ^= 0 then do;
		call sub_err_ (code, "gui_", "c", null, 0, "Error in creating circle/polygon");
		return;
	     end;


	     relx = relx + xx - oldx;
	     rely = rely + yy - oldy;
	     oldx = xx;				/* update current position */
	     oldy = yy;

	end loop;
	if switch >= 1 then do;
	     item_node = graphic_manipulator_$create_array (array, steps, code);
	     call graphic_manipulator_$add_element (active_node, -1, item_node, code);
	     return;

	end;
finis_3d:	array (steps+1) = graphic_manipulator_$create_position (item_code, float (-relx), float (-rely), 0e0, code);
	item_node = graphic_manipulator_$create_array (array, steps+1, code);
	call graphic_manipulator_$add_element (active_node, -1, item_node, code);
	return;


garc_: garc: entry (q1, dx1, dy1);

dcl  q1 float bin;

	q = q1;dx = dx1;dy = dy1;
	switch = 2;
	goto arcin;


geqs_: geqs: entry (ns, dx1, dy1);


/* draw closed figure with ns sides whose center is dx1, */
/* dy1, from the current position. */
dcl  ns fixed bin;

	switch = 1;
	steps = ns;
	delta = 2.e0*pi/steps;
	goto equin;


gdisp_: gdisp: entry;

	if erase_switch then do;
	     call graphic_compiler_$display (master_node, code);
	end;

	else call graphic_compiler_$display_append (active_node, code);

	if code ^= 0 then goto report_error;
	erase_switch = ""b;
	active_node = graphic_manipulator_$create_array ((0), 0, code);
	if code ^= 0 then goto report_error;
	call graphic_manipulator_$add_element (main_node, -1, active_node, code);
	if code ^= 0 then goto report_error;

	return;


geras_: geras: entry;

	erase_switch = "1"b;
	return;


     end;
   



		    list_pgs_contents.pl1           11/18/82  1706.7rew 11/18/82  1625.5       97731


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

list_pgs_contents: lpc: proc;

/* This command lists the symbols resident in a permanent graphic segment
   (PGS).  Usage is explaned in the variable "explanation", which is printed
   if called with no args.  The star convention is honored both for names of
   PGS's and for symbols to be found.

   Written 10/10/75 by C. D. Tavares.
   Modified 02/08/80 by CDT to use lsm_ directly instead of using
   graphic_manipulator and thereby wiping out the WGS. */


/* AUTOMATIC */

dcl  al fixed bin,
     ap pointer,
     arg_array (32) char (32),
     arg_satisfied (32) bit (1),
     code fixed bin (35),
     dname char (168),
     each_seg fixed bin,
     elements_used fixed bin,
     ename char (32),
     error_label label local,
     fake_array (1) fixed bin (18),
     i fixed bin,
     lsm_curl fixed bin,
     lsm_type fixed bin,
     nargs fixed bin;

/* STATIC */

dcl  sys_area_p pointer static initial (null);

/* EXTERNAL STATIC */

dcl  error_table_$too_many_args ext fixed bin (35) static,
     graphic_error_table_$inv_node_type ext fixed bin (35) static;

/* CONSTANTS */

dcl  explanation char (36) static initial ("Usage: lpc pgs_path {symbol_names}.");

/* ENTRIES */

dcl (com_err_, com_err_$suppress_name) ext entry options (variable),
     check_star_name_$entry ext entry (char (*), fixed bin (35)),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
     expand_path_ ext entry (pointer, fixed bin, pointer, pointer, fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ ext entry options (variable),
     match_star_name_ ext entry (char (*), char (*), fixed bin (35)),
     sort_items_$char ext entry (pointer, fixed bin),
     suffixed_name_$make ext entry (char (*), char (*), char (32), fixed bin (35));

/* BASED */

dcl  arg based (ap) char (al),
     system_free_area area based (sys_area_p);

/* BUILTINS AND CONDITIONS */

dcl (addr, char, dim, length, null, sum) builtin;

dcl  cleanup condition;
%page;
%include lsm_entry_dcls;
%page;
%include lsm_node_types;
%page;
%include lsm_formats;
%page;
%include star_structures;
%page;
	error_label = returner;			/* tell "crump" to abort whole command if we fail now */

	call cu_$arg_ptr (1, ap, al, code);		/* get name of PGS to be inspected */
	if code ^= 0 then call crump (code, explanation); /* tell them how things are */

	call expand_path_ (ap, al, addr (dname), addr (ename), code);
	if code ^= 0 then call crump (code, arg);

	call suffixed_name_$make ((ename), "pgs", ename, code); /* make sure suffix "pgs" is included */
	if code ^= 0 then call crump (code, ename);

	call cu_$arg_count (nargs);			/* see if any other args */
	nargs = nargs - 1;				/* from now on, we use nargs only to count symbol args */

	if nargs = 0 then do;			/* no specific symbols wanted; list everything */
	     nargs = 1;
	     arg_array (1) = "**";
	end;

	else do;					/* wants only certain symbols listed */
	     if nargs > dim (arg_array, 1)
	     then call crump (error_table_$too_many_args, "Max symbol names = " || char (dim (arg_array, 1)));
						/* too many args, can't handle. */

	     do i = 1 to nargs;			/* collect as many as we can handle */
		call cu_$arg_ptr (i+1, ap, al, code);	/* get one symbol specification */
		call check_star_name_$entry (arg, code); /* is it an OK entry/star name? */
		if code > 3 then call crump (code, arg);
		arg_array (i) = arg;		/* remember it */
	     end;
	end;


	call check_star_name_$entry (ename, code);	/* was the PGS name a starname? */
	if code > 3 then call crump (code, ename);	/* yes, and an illegal one too. */

	if code = 0				/* not a star name */
	then call process_pgs (ename);		/* process one and quit */

	else do;					/* contains stars */

	     if sys_area_p = null ()			/* get an area for hcs_$star */
	     then sys_area_p = get_system_free_area_ ();

	     call hcs_$star_ (dname, ename, star_BRANCHES_ONLY, sys_area_p, star_entry_count, star_entry_ptr, star_names_ptr, code);
						/* see how many PGS's match starname */
	     if code ^= 0 then call crump (code, ename);

	     error_label = end_of_star_loop;		/* say on bomb-out, continue with next PGS */

	     do each_seg = 1 to star_entry_count;	/* do once for each match */

		call process_pgs (star_names (star_entries (each_seg).nindex)); /* process that one */

end_of_star_loop:
	     end;

	     free star_names in (system_free_area), star_entries in (system_free_area);
						/* clean up after ourselves */

	end;

returner:	return;
%page;
process_pgs: proc (ename);				/* does the job for one PGS */

dcl  ename char (32);

dcl  segptr pointer;

	     segptr = null;

	     on cleanup call hcs_$terminate_noname (segptr, 0);

	     call lsm_fs_$init_seg (segptr, dname, ename, Find_seg, code);
	     if code ^= 0 then call crump (code, "^a>^a.");

	     call lsm_sym_$sym_list (segptr, fake_array, elements_used, 0);
						/* just to see how many symbols there are */
	     if elements_used = 0 then		/* don't waste time */
		call com_err_$suppress_name (0, "list_pgs_contents", "Symbol table is empty.^/");

	     else begin;				/* allocates sufficient storage for arrays */

dcl  node_array (elements_used) fixed bin (18);

dcl 1 symbol_info (elements_used) aligned,		/* this holds our info; will be sorted */
    2 name_array char (64),				/* name of each symbol */
    2 prefix char (8);				/* "(null)" if the symbol is an empty symbol */

dcl 1 based_symbol_info like symbol_info aligned based;	/* template for one symbol */

dcl  name char (64),
     value fixed bin (18);

dcl 1 sort_structure aligned,				/* as desired by sort_items_$char */
    2 useful_elements fixed bin (24),
    2 sort_ptrs (elements_used) pointer unaligned;

dcl (i, j) fixed bin,
     found bit (1) aligned;

		call lsm_sym_$sym_list (segptr, node_array, elements_used, code);
						/* This time, do it in earnest, for the info. */
		if code ^= 0			/* really unexpected */
		then call crump (code, "Error while examining symbol table: num_syms = " || char (elements_used));

		call ioa_ ("^/^2-^a>^a^/", dname, ename); /* print out heading identifying PGS */

		do i = 1 to nargs;
		     arg_satisfied (i) = ""b;		/* say this starname hasn't been matched yet */
		end;

		useful_elements = 0;		/* count of how many satisfy starname */

		do i = 1 to elements_used;		/* loop thru elements matching starnames */

		     call lsm_$get_blk (segptr, node_array (i), lsm_type, lsm_curl, node_ptr, code);
		     if code = 0 then
			if lsm_type ^= symbol_type then
			     code = graphic_error_table_$inv_node_type;
		     if code ^= 0 then do;		/* also greatly unexpected */
			name = "";
			call com_err_ (code, "list_pgs_contents", "Examining node ^o", node_array (i));
		     end;

		     else do;
			value = node_ptr -> symbol_node.value_node;

			call lsm_$get_blk (segptr, (node_ptr -> symbol_node.name_node), 0, 0, node_ptr, code);
			name = node_ptr -> char_node.string;
		     end;

		     found = ""b;


		     do j = 1 to nargs;		/* check against ALL starnames given */

/* we don't stop matching when a match is found, because we are keeping track
   of which starnames have never had a match, so that we can put out error
   messages later about them.  Some symbols may satisfy more than one
   starname, or the user could have typed the same starname twice.  We try
   every entryname against every starname so that we know which starnames were
   never really matched.  */

			code = 0;
			if arg_array (j) ^= "**" then
			     call match_star_name_ (name, arg_array (j), code);
			if code = 0 then do;	/* it matches! */
			     arg_satisfied (j) = "1"b; /* say this arg has had at least one match */
			     if ^found then do;	/* only put symbolname into sort list once */
				found = "1"b;
				useful_elements = useful_elements + 1; /* remember it in sorting structure */
				symbol_info.name_array (useful_elements) = name;
				if value = 0 then symbol_info.prefix (useful_elements) = "(null)  ";
						/* symbol is an empty symbol */
				else symbol_info.prefix (useful_elements) = "";

				sort_ptrs (useful_elements) = addr (symbol_info.name_array (useful_elements));
						/* this way, we only sort the ones we care about */
			     end;
			end;
		     end;
		end;

		call hcs_$terminate_noname (segptr, 0); /* clean up */

		if useful_elements = 0 then do;	/* nothing matched the starnames */
		     call com_err_$suppress_name (0, "list_pgs_contents", "No symbols selected.^/");
		     return;
		end;

		found = ""b;			/* no unmatched args have been found and printed yet */

		do i = 1 to nargs;
		     if ^arg_satisfied (i) then do;
			call com_err_$suppress_name (0, "list_pgs_contents", """^a"" not found.", arg_array (i));
						/* print out the args which were never matched */
			found = "1"b;		/* say we found one */
		     end;
		end;

		if found then call com_err_$suppress_name (0, "list_pgs_contents", "	"); /* keep format neat */

		call ioa_ ("^d symbol^[s^;^]:^/", useful_elements, (useful_elements > 1)); /* say how many */

		call sort_items_$char (addr (sort_structure), length (symbol_info.name_array (1)));
						/* sort the names that matched */

		do i = 1 to useful_elements;		/* now output the sorted names */
		     call ioa_ ("^10a^a", sort_ptrs (i) -> based_symbol_info.prefix,
			sort_ptrs (i) -> based_symbol_info.name_array);
		end;
	     end;

	     call ioa_ ("");			/* be suave */
	     return;

	end process_pgs;
	
crump:	proc (code, reason);			/* the screamer */

dcl  code fixed bin (35),
     reason char (*);

	     call com_err_ (code, "list_pgs_contents", reason, dname, ename);
						/* explain the problem to the user */
	     goto error_label;			/* either abort whole command or resume with next PGS */
	end;

     end list_pgs_contents;
 



		    lsm_.pl1                        11/18/82  1706.7rew 11/18/82  1625.5       89478


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

lsm_: proc; return;

/* Written on 05/02/70 by Edwin W. Meyer, Jr. */
/* Modified for pl1 on 01/2170 by Edwin W. Meyer, Jr. */
/* modified 6/25/73 by Lee J. Scheffler for a general cleanup and for compatibility with new gm_ */
/* Modified 05/05/77 by CDT to make replace_blk refuse to replace symbols; otherwise symbol table messed its mind. */
/* Modified 07/79 by CDT for general overhaul */
/* Last modified 10/80 by CDT to make set_blk refuse to expand max-length
   blocks BEFORE indirecting through them, not after */


/* AUTOMATIC */

dcl  old_type fixed bin,
     old_data_len fixed bin,
     temp_node fixed bin (18),
     new_node_ptr pointer;

/* BUILTIN */

dcl (addr, divide, max, min, size, unspec) builtin;

/* EXTERNAL STATIC */

dcl (graphic_error_table_$lsm_node_ob,
     graphic_error_table_$bad_node,
     graphic_error_table_$inv_node_type,
     graphic_error_table_$lsm_seg_full,
     graphic_error_table_$lsm_blk_len) external fixed bin (35);

dcl  error_table_$unimplemented_version fixed bin (35) external static;

dcl  sys_info$max_seg_size fixed bin (35) external static;

/* BASED */

dcl  based_segment (0: 65000) aligned fixed bin (18) based (lsm_segptr); /* dummy declaration for pointer creation
						   and node referencing */
%page;
%include lsm_formats;
%page;
get_blk:	entry (lsm_segptr, node, type, data_len, node_ptr, err_code);

dcl (node fixed bin (18),
     type fixed bin,
     data_len fixed bin,
     err_code fixed bin (35)) parameter;

	call get_node_info (lsm_segptr, node, type, data_len, node_ptr, err_code);
	return;
%skip (5);
get_node_info: proc (lsm_segptr, node, type, data_len, node_ptr, err_code);

dcl (lsm_segptr pointer,
     node fixed bin (18),
     type fixed bin,
     data_len fixed bin,
     err_code fixed bin (35),
     node_ptr pointer) parameter;

	     type = lsm_constants.indirect_type;	/* to start loop off right */

	     do while (type = lsm_constants.indirect_type); /* until we find a non-indirect node */
		if node < size (lsm_segptr -> lsm) then
		     if (lsm_segptr -> lsm.version = LSM_version_6) & (node = 3) then;
						/* Old style segment and it's the symbol table */
		     else do;
			err_code = graphic_error_table_$lsm_node_ob; /* input block node is out of bounds */
			return;
		     end;
		if node > lsm_segptr -> lsm.free then do;
		     err_code = graphic_error_table_$lsm_node_ob;
		     return;
		end;

		node_ptr = addr (lsm_segptr -> based_segment (node)); /* get address to data block */
		type = node_ptr -> any_node.type;	/* get data type */
		data_len = node_ptr -> any_node.data_len; /* get current length of data block */
		if (type < 1) | (type > lsm_constants.n_types) then do;
		     err_code = graphic_error_table_$bad_node;
		     return;
		end;

		if type = lsm_constants.indirect_type then /* indirect type - get the true node */
		     node = node_ptr -> indirect_node.new_node;
	     end;

	     err_code = 0;
	     return;

	end get_node_info;
%page;
set_blk:	entry (lsm_segptr, node, type, data_len, node_ptr, err_code);

/* This entry resets the size of the data space in an existing block */

	if lsm_segptr -> lsm.version ^= LSM_version_7 then do;
	     err_code = error_table_$unimplemented_version;
	     return;
	end;

	call get_node_info (lsm_segptr, node, type, old_data_len, node_ptr, err_code);
	if err_code ^= 0 then return;

	if (type = symtab_type) | (type = symbol_type) then do;
	     err_code = graphic_error_table_$inv_node_type;
	     return;
	end;

	if node_ptr -> any_node.allocated_len >= cv_data_len_to_words (data_len, type) then do;
	     node_ptr -> any_node.data_len = data_len;	/* current block is of sufficient length - reset */
	     return;
	end;

/* otherwise we have to create a longer block */

	call create_new_block (lsm_segptr, temp_node, type,
	     max (min (data_len * 1.5e0 + 10, lsm_constants.max_allocation), data_len),
	     new_node_ptr, err_code);
						/* give a 50% expansion reserve but no more than max allowed */
	if err_code ^= 0 then return;

	new_node_ptr -> any_node.data_len = data_len;

	unspec (new_node_ptr -> any_node.data_space) = unspec (node_ptr -> any_node.data_space);
	node_ptr -> any_node.type = lsm_constants.indirect_type; /* set indirect block id and address into old block */
	node_ptr -> indirect_node.new_node = temp_node;
	node_ptr -> indirect_node.data_len = 1;

	node = temp_node;
	node_ptr = new_node_ptr;

	return;
%skip (3);
cv_data_len_to_words: proc (data_len, type) returns (fixed bin);

dcl  data_len fixed bin parameter,
     type fixed bin parameter;

dcl  factor fixed bin,
     result fixed bin;

	     factor = lsm_constants.data_length_factors (type);
	     if factor = 1 then
		result = max (1, data_len);
	     else result = max (1, divide (data_len + factor - 1, factor, 17, 0));

	     return (result);
	end cv_data_len_to_words;
%page;
replace_blk: entry (lsm_segptr, old_node, new_node, err_code);

/* Replaces old_node with an indirect block pointing to new_node */

dcl (old_node, new_node) fixed bin (18) parameter;

	if lsm_segptr -> lsm.version ^= LSM_version_7 then do;
	     err_code = error_table_$unimplemented_version;
	     return;
	end;

	call get_node_info (lsm_segptr, new_node, 0, 0, node_ptr, err_code);
						/* just to check its validity */
	if err_code ^= 0 then return;

	call get_node_info (lsm_segptr, old_node, old_type, 0, node_ptr, err_code);
	if err_code ^= 0 then return;

	if old_type = symbol_type then do;		/* can't change a symbol block in midstream. */
	     err_code = graphic_error_table_$inv_node_type;
	     return;
	end;

	node_ptr -> indirect_node.data_len = 2;		/* set cur length of block */
	node_ptr -> indirect_node.type = lsm_constants.indirect_type; /* make it an indirect block */
	node_ptr -> indirect_node.new_node = new_node;

	return;
%page;
make_blk:	entry (lsm_segptr, node, type, data_len, node_ptr, err_code);

	call create_new_block (lsm_segptr, node, type, data_len, node_ptr, err_code);
	return;
%skip (3);
create_new_block: proc (lsm_segptr, node, type, data_len, node_ptr, err_code);

dcl (lsm_segptr pointer,
     node fixed bin (18),
     type fixed bin,
     data_len fixed bin,
     err_code fixed bin (35),
     node_ptr pointer) parameter;

dcl  temp_allocated_len fixed bin;

	     node = 0;				/* in case an error is encountered */

	     if lsm_segptr -> lsm.version ^= LSM_version_7 then do;
		err_code = error_table_$unimplemented_version;
		return;
	     end;


	     if (type <= 0) | (type > lsm_constants.n_types) then do;
		err_code = graphic_error_table_$bad_node;
		return;
	     end;

	     node = lsm_segptr -> lsm.free;		/* get beginning of free block */
	     node_ptr = addr (lsm_segptr -> based_segment (node));

	     temp_allocated_len = cv_data_len_to_words (data_len, type);

	     if temp_allocated_len > lsm_constants.max_allocation then do; /* block length is too long */
		err_code = graphic_error_table_$lsm_blk_len;
		return;
	     end;

	     if node + temp_allocated_len > sys_info$max_seg_size then do;
		err_code = graphic_error_table_$lsm_seg_full;
		return;
	     end;

	     node_ptr -> any_node.type = type;
	     node_ptr -> any_node.allocated_len = temp_allocated_len;
	     node_ptr -> any_node.data_len = data_len;

	     lsm_segptr -> lsm.free = lsm_segptr -> lsm.free + temp_allocated_len + 1; /* update free cell */

	     return;
	end create_new_block;
%page;
replicate: entry (lsm_segptr, template_node, new_copy_node, err_code);

dcl (template_node fixed bin (18),			/* template of structure to be replicated */
     new_copy_node fixed bin (18)) parameter;		/* node id of replica */

	call rep_struc_recurse (lsm_segptr, template_node, new_copy_node, err_code);
	return;
%skip (3);
rep_struc_recurse: proc (lsm_segptr, template_node, new_copy_node, err_code);

dcl (lsm_segptr pointer,
    (template_node, new_copy_node) fixed bin (18),
     err_code fixed bin (35)) parameter;

dcl  type fixed bin,
     data_len fixed bin,
    (old_node_ptr, new_node_ptr) pointer,
     i fixed bin;

	     new_copy_node = 0;

	     if template_node = 0 then return;

	     call get_node_info (lsm_segptr, template_node, type, data_len, old_node_ptr, err_code);
	     if err_code ^= 0 then return;

	     if type = symbol_type then do;		/* Do not replicate through symbols */
		new_copy_node = template_node;
		return;
	     end;

	     call create_new_block (lsm_segptr, new_copy_node, type, data_len, new_node_ptr, err_code);
	     if err_code ^= 0 then return;

	     if type = symtab_type then do;
		err_code = graphic_error_table_$inv_node_type;
		return;
	     end;

	     else if (type = array_type) | (type = list_type) then
		do i = 1 to data_len;
		call rep_struc_recurse (lsm_segptr, old_node_ptr -> list_node.node (i),
		     new_node_ptr -> list_node.node (i), err_code);
		if err_code ^= 0 then return;
	     end;

	     else unspec (new_node_ptr -> any_node.data_space) = unspec (old_node_ptr -> any_node.data_space);
						/* simple real data type */

	     return;
	end rep_struc_recurse;

     end lsm_;
  



		    lsm_fs_.pl1                     02/16/88  1455.2r w 02/16/88  1411.9      252873


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

lsm_fs_: proc; return;

/* coded by Edwin W. Meyer, Jr. on 041069 */
/* modified on 3/29/71 by C. D. Tavares */
/* modified on 6/25/73 by Lee J. Scheffler to clean up a little.
   This program is about due for an overhaul. */
/* Modified 08/79 by CDT as part of the general lsm_ overhaul that we've been
   promising ourselves since 1973.  Some of the specific changes were: getting
   compaction to work; making the segment-to-segment structure moves compact
   the contents of the structure; and fixing the previous hashing algorithm,
   which sometimes used to depend on hashing garbage.  */
/* Modified 11/79 by CDT to make pull entry remember to bump
   length of all version 6 symbol tables down by one when copying them. */
/* Modified 01/80 by CDT to fix bug causing rejection (for node OOB)
   of almost all operations on version 6 segments where there was a symbol in
   symtab slot 0.  This word coincided with what is now lsm.component_slots. */
/* Last modified 07/21/80 by CDT to implement graphic search paths. */

dcl (from_segptr, to_segptr, temp_segptr) pointer,
    (from_segptr_arg, to_segptr_arg) pointer parameter,
    (from_node_arg, to_node_arg) fixed bin (18) parameter,
     err_code fixed bin (35);

dcl  move_array (move_len) fixed bin (35) based,
     move_len fixed bin (18);				/* for moving large blocks of words */

/* EXTERNAL STATIC */

dcl (graphic_error_table_$bad_node,
     graphic_error_table_$not_a_structure,
     graphic_error_table_$lsm_node_ob,
     graphic_error_table_$struc_duplication) fixed bin (35) external static;

dcl (error_table_$segknown,
     error_table_$unimplemented_version,
     error_table_$bad_arg) ext fixed bin (35) static;

dcl  sys_info$max_seg_size fixed bin (35) external static;

/* ENTRIES */

dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$fs_get_path_name ext entry (pointer, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (17), fixed bin (17), ptr, fixed bin (35));

dcl (get_temp_segment_, release_temp_segment_) ext entry (char (*), pointer, fixed bin (35)),
     search_paths_$find_dir ext entry (char (*), pointer, char (*), char (*), char (*), fixed bin (35)),
     sub_err_ ext entry options (variable);

/* BUILTINS AND CONDITIONS */

dcl (addr, addrel, codeptr, currentsize, divide, mod,
     null, pointer, rel, size, unspec) builtin;

dcl  cleanup condition;

/* CONSTANTS */

dcl (On_dup_error initial (0),			/* Various merge codes */
     On_dup_source initial (1),
     On_dup_target_then_nulls initial (2),
     On_dup_target_then_source initial (3)) fixed bin static options (constant);
%page;
%include lsm_entry_dcls;
%page;
%include lsm_formats;
%page;
%include sl_info;
%page;
init:	entry (lsm_segptr, err_code);

/* the entry init creates a fresh lsm segment in the process directory
   if the supplied pointer "pr" is null. If not, it assumes that "pr" is a
   valid base pointer to an lsm segment and truncates and re-initializes it */

	call init (lsm_segptr, err_code);
	return;
%skip (5);

/* ------------------------- */

init:	proc (lsm_segptr, err_code);

dcl  lsm_segptr pointer parameter,
     err_code fixed bin (35) parameter;

	     if lsm_segptr = null then do;		/* get a temp segment */
		call get_temp_segment_ ("graphic lsm_ temp", lsm_segptr, err_code);
		if err_code ^= 0 then return;
	     end;

	     call init_lsm_header (lsm_segptr, err_code);
	     return;
	end init;

/* ------------------------- */
%skip (5);

/* ------------------------- */

init_lsm_header: proc (lsm_segptr, code);

dcl  lsm_segptr pointer parameter,
     code fixed bin (35) parameter;

	     if rel (lsm_segptr) ^= ""b then do;
		err_code = error_table_$bad_arg;
		call sub_err_ (code, "lsm_", "h", null, 0,
		     "Supplied segment pointer (^p) contains nonzero offset.
Please notify graphics system maintenance personnel.",
		     lsm_segptr);
		return;
	     end;

	     lsm_segptr -> lsm.version = LSM_version_7;
	     lsm_segptr -> lsm.root_symtab = 0;
	     lsm_segptr -> lsm.lock = "0"b;
	     lsm_segptr -> lsm.component_slots = lsm_constants.initial_component_slots;
	     lsm_segptr -> lsm.components = 0;
	     lsm_segptr -> lsm.pad = -1;
	     lsm_segptr -> lsm.component_ptrs = null;

	     lsm_segptr -> lsm.free = currentsize (lsm_segptr -> lsm);

	     call hcs_$truncate_seg (lsm_segptr, lsm_segptr -> lsm.free, code); /* truncate the existing seg */
	     if code ^= 0 then return;

	     return;
	end init_lsm_header;

/* ------------------------- */
%page;
init_seg:	entry (lsm_segptr, dir_path, entry, icv_sw, err_code);

/* init_seg attempts to initiate the specified LSM segment.
   If not found and 'icv_sw' = 1, an empty LSM segment is created.
   If 'icv_sw' = 2 the segment is cleared (made empty) */

dcl  dir_path char (*),				/* directory of LSM segment */
     entry char (*),				/* entry name of LSM */
     icv_sw fixed bin (17);				/* 0 - init, 1 - create, 2 - clear */

	call init_seg (lsm_segptr, dir_path, entry, icv_sw, err_code);
	return;
%skip (5);

/* ------------------------- */

init_seg:	proc (lsm_segptr, dir_path, entry, icv_sw, err_code);

dcl (lsm_segptr pointer,
    (dir_path, entry) char (*),
     icv_sw fixed bin,
     err_code fixed bin (35)) parameter;

	     if dir_path = "" then
		call find_via_search_paths (entry, lsm_segptr, err_code);
	     else call hcs_$initiate (dir_path, entry, "", 0, 1 /* no copy */, lsm_segptr, err_code);

	     if err_code = error_table_$segknown then err_code = 0; /* innocuous */

	     if icv_sw = Find_seg then do;
		if lsm_segptr ^= null then		/* tiny gullibility checks */
		     if lsm.version ^= LSM_version_7 then
			if lsm.version ^= LSM_version_6 then
			     err_code = error_table_$unimplemented_version;
		return;				/* whether or not it worked */
	     end;

	     if err_code ^= 0 then do;
		call hcs_$make_seg (dir_path, entry, "", 1010b /* rw */, lsm_segptr, err_code);
		if err_code ^= 0 then
		     if err_code = error_table_$segknown then err_code = 0; /* innocuous */
		     else return;			/* can't do it, give up */
		call init_lsm_header (lsm_segptr, err_code);
		return;
	     end;

	     if icv_sw = Clear_seg then call init_lsm_header (lsm_segptr, err_code);
	     return;

	end init_seg;

/* ------------------------- */
%page;
free:	entry (lsm_segptr, err_code);

/* free truncates to zero the supplied segment and returns it to
   the free temporary segment list */

	call free_seg (lsm_segptr, err_code);
	return;
%skip (5);

/* ------------------------- */

free_seg:	proc (lsm_segptr, err_code);

dcl  lsm_segptr pointer parameter,
     err_code fixed bin (35) parameter;

	     call hcs_$truncate_seg (lsm_segptr, 0, err_code);
	     if err_code ^= 0 then return;		/* something funny, don't fiddle further */

	     call release_temp_segment_ ("graphic lsm_ temp", lsm_segptr, err_code);
	     if err_code ^= 0 then return;

	     lsm_segptr = null;
	     return;

	end free_seg;

/* ------------------------- */
%page;
pull:	entry (to_segptr_arg, dir_path, entry, err_code);

/* pull "pulls" into the temp segment the list structure of the lsm segment in dir_path>entry. */

dcl  temp_table_node fixed bin (18);

	to_segptr = to_segptr_arg;

	call init_seg (from_segptr, dir_path, entry, Find_seg, err_code);
	if from_segptr = null then return;		/* can't get at it, return */

	call init_lsm_header (to_segptr, err_code);	/* destroy previous contents of target seg */
	if err_code ^= 0 then return;

	if from_segptr -> lsm.version = LSM_version_7 then do;
	     move_len = from_segptr -> lsm.free;
	     unspec (to_segptr -> move_array) = unspec (from_segptr -> move_array); /* Move bunch of data */
	     err_code = 0;
	     return;
	end;

	else do;					/* pulling an old version LSM segment */
	     call lsm_sym_$find_table (from_segptr, temp_table_node, err_code);
	     if err_code ^= 0 then return;

	     call move_substruc (from_segptr, temp_table_node, to_segptr, to_segptr -> lsm.root_symtab,
		On_dup_error, err_code);
	     return;
	end;
%page;
push:	entry (from_segptr_arg, dir_path, entry, err_code);

	from_segptr = from_segptr_arg;

	call init_seg (to_segptr, dir_path, entry, Clear_seg, err_code);
	if err_code ^= 0 then return;

	call move_substruc (from_segptr, from_segptr -> lsm.root_symtab, to_segptr, to_segptr -> lsm.root_symtab,
	     On_dup_error, err_code);
	return;
%page;
compact:	entry (lsm_segptr, count, err_code);

dcl  count fixed bin (18);				/* gc threshold */

	if count > lsm_segptr -> lsm.free then do;	/* garbage collection threshold not yet reached */
	     err_code = 0;
	     return;
	end;

	temp_segptr = null;
	call init (temp_segptr, err_code);		/* Initiate a temp seg for copying */
	if err_code ^= 0 then return;
	call move_substruc (lsm_segptr, lsm_segptr -> lsm.root_symtab, temp_segptr, temp_segptr -> lsm.root_symtab,
	     On_dup_error, err_code);			/* Move the structure into the temp seg */
	if err_code ^= 0 then return;

	move_len = temp_segptr -> lsm.free;		/* Compute length of compacted version */
	lsm_segptr -> move_array = temp_segptr -> move_array; /* Copy compacted version back */

	call hcs_$truncate_seg (lsm_segptr, move_len, err_code); /* Truncate the original */
	if err_code ^= 0 then return;

	call free_seg (temp_segptr, err_code);		/* Free up the temporary */
	return;
%page;
move_struc: entry (from_segptr_arg, to_segptr_arg, from_node_arg, to_node_arg, err_code);

/* Copies list structure subsidiary to from_node in "from" segment
   into "to" segment and returns new value of root_node */

	call move_substruc (from_segptr_arg, from_node_arg, to_segptr_arg, to_node_arg, On_dup_error, err_code);
						/* Get common code to do work */
	return;
%page;
merge_symbol: entry (from_segptr_arg, to_segptr_arg, from_node_arg, merge, merge_code, err_code);

/* Copy list structure subordinate to from_node_arg and replace subordinate symbols or overwrite them */

dcl  merge bit (1) aligned,				/* ON iff merging symbol tables */
     merge_code fixed bin;

	call move_substruc (from_segptr_arg, from_node_arg, to_segptr_arg, 0, merge_code, err_code);
	return;
%page;
move_substruc: procedure (from_segptr, from_node, to_segptr, to_node, merge_code, err_code);

/* Internal procedure to move a node (and its substructure)
   from segment "from_p" to segment "to_p" */

/* Movement is done recursively on list and array type nodes, iteratively on others.

   If merge_code = On_dup_error then all subordinate named substructures are copied from the
   original into the copy, and entered into the copy symbol table.
   If a name already exists in the copy symbol table, copying is aborted, and
   and error message is returned.

   If merge_code = On_dup_source then operation is identical to 0, but symbols already in the
   copy symbol table are overwritten by identically named substructures
   from the original.

   If merge_code = On_dup_target_then_nulls, subordinate named substructures in the original are
   replaced with identically named substructures in the copy.
   If a name does not yet exist in the copy symbol table, it is created with
   a value node of 0.

   If merge_code = On_dup_target_then_source, operation is identical to 2, but when a name doesn't exist
   in the copy symbol table, the named substrucuture from the original is copied. */

dcl  from_node fixed bin (18),			/* node number in lsm_ segment pointed to by
						   "from_segptr" to be moved */
     to_node fixed bin (18),				/* node number in lsm_ segment pointed to by
						   "to_segptr" where from_node has been moved */
     from_segptr pointer,				/* pointer to lsm_segment contining structure to be moved */
     to_segptr pointer,				/* pointer to lsm_ segment into which structure is to be moved */
     merge_code fixed bin,				/* see above for description */
     err_code fixed bin (35);
						/* if on, overwrite symbols in "to" segment */
dcl 1 scratch_seg based (scratch_ptr) aligned,
    2 lsm_header (size (null -> lsm)) bit (36) aligned,
    2 old_new_table (0 : sys_info$max_seg_size - 1) fixed bin (18) unsigned unaligned,
    2 sym_list_array (divide (sys_info$max_seg_size, 2, 18, 0) - currentsize (scratch_ptr -> lsm)) fixed bin (18) aligned;

dcl  scratch_ptr pointer initial (null),
     old_copy_ptr pointer initial (null);

dcl  upgrading_version_6_seg bit (1) aligned;

dcl  old_new_tab_p pointer,				/* Points to table of old-new node correspondences */
     old_new_tab (0 : sys_info$max_seg_size - 1) fixed bin (18) unsigned unaligned based (old_new_tab_p);
						/* Table of node correspondences between old and new copies */
dcl  sym_list_array_p pointer,
     sym_list_array (divide (sys_info$max_seg_size, 2, 18, 0) - currentsize (scratch_ptr -> lsm)) fixed bin (18) based (sym_list_array_p);

dcl  hcs_$fs_get_mode ext entry (pointer, fixed bin, fixed bin (35)),
     error_table_$moderr ext fixed bin (35),
     effmode fixed bin;

/* First, check to see that we can read from the from_seg and write to the to_seg.
   This should save a lot of faults. */

	     call hcs_$fs_get_mode (from_segptr, effmode, err_code);
	     if err_code ^= 0 then return;

	     if effmode ^> 111b /* no read permission */ then do;
bad_access_mode:	err_code = error_table_$moderr;
		return;
	     end;

	     call hcs_$fs_get_mode (to_segptr, effmode, err_code);
	     if err_code ^= 0 then return;

	     if mod (effmode, 4) ^= 10b /* no write permission */ then goto bad_access_mode;

	     if to_segptr -> lsm.version ^= LSM_version_7 then do;
		err_code = error_table_$unimplemented_version;
		return;
	     end;

	     on cleanup begin;
		if scratch_ptr ^= null then call free_seg (scratch_ptr, 0);
		if old_copy_ptr ^= null then call free_seg (old_copy_ptr, 0);
	     end;

	     call init (scratch_ptr, err_code);
	     if err_code ^= 0 then return;

	     old_new_tab_p = addr (scratch_seg.old_new_table);
	     sym_list_array_p = addr (scratch_seg.sym_list_array);
						/* so as not to destroy header */

	     call init (old_copy_ptr, err_code);	/* we will store old contents in case of error */
	     move_len = from_segptr -> lsm.free;
	     unspec (old_copy_ptr -> move_array) = unspec (to_segptr -> move_array);

	     if from_segptr -> lsm.version = LSM_version_7 then
		upgrading_version_6_seg = ""b;
	     else if from_segptr -> lsm.version = LSM_version_6 then
		upgrading_version_6_seg = "1"b;
	     else do;
		err_code = error_table_$unimplemented_version;
		return;
	     end;

	     call move_substruc_recurse (from_node, to_node, "1"b, err_code); /* Get friend to do work */

	     if err_code ^= 0 then do;		/* something wrong, clean up seg like we found it */
		unspec (to_segptr -> move_array) = unspec (old_copy_ptr -> move_array);
		call hcs_$truncate_seg (to_segptr, to_segptr -> lsm.free, 0);
	     end;

	     call free_seg (scratch_ptr, 0);		/* Free up temporary segs */
	     call free_seg (old_copy_ptr, 0);
	     return;
%page;
move_substruc_recurse: procedure (from_node, to_node, top_level, err_code);

/* "from_p" and "to_p" are already assumed to point to proper lsm_ segments */

dcl  from_node fixed bin (18),			/* node number in from seg to be moved */
     to_node fixed bin (18),				/* node no. of copied node in to seg (output ) */
     top_level bit (1) aligned parameter,		/* ON if this is top level structure */
     err_code fixed bin (35) parameter;

dcl  actual_node fixed bin (18),			/* Current node being moved */
     node_ptr pointer,				/* pointer to node in lsm segment */
     cur_type fixed bin (4),				/* lsm_ type of same */
     symtab_node_no fixed bin (18);


		if from_node = 0 then do;		/* the null node, be happy about it */
		     err_code, to_node = 0;
		     return;
		end;

		call chase_indirect (from_node, actual_node, node_ptr, cur_type, err_code);
						/* Find out all about the node */
						/* and chase any indirects */
		if err_code ^= 0 then return;

		to_node = old_new_tab (actual_node);
						/* See if it has already been copied */
		if to_node ^= 0 then return;		/* already been copied, wonderful */

/* If not, we have to copy it over now. */

		if (cur_type <= bit_type) | (cur_type = char_type) then /* vanilla nodes */
		     call move_simple_node (node_ptr, actual_node, to_node);

		else if (cur_type = list_type) | (cur_type = array_type) then
		     call move_list_node (node_ptr, actual_node, to_node, err_code);

		else if cur_type = symbol_type then
		     call merge_symbol_node (node_ptr, actual_node, to_node, top_level, err_code);
						/* then move it as specified by "merge_code" */
		else if cur_type = symtab_type then do;
		     call lsm_sym_$find_table (from_segptr, symtab_node_no, err_code);
		     if err_code ^= 0 then return;

		     if (^top_level | (from_node ^= symtab_node_no)) then do;
						/* we should NEVER encounter a symtab at a lower level */
			err_code = graphic_error_table_$not_a_structure;
			return;
		     end;

		     else call move_symtab_node (node_ptr, actual_node, to_node, err_code);
		end;

		else do;
		     err_code = graphic_error_table_$bad_node;
		     return;
		end;

		if actual_node ^= from_node then
		     old_new_tab (from_node) = to_node;
		return;
%skip (5);
move_simple_node:	procedure (node_ptr, from_node, to_node);

/* This subroutine moves nodes that contain no node references */

dcl (from_node, to_node) fixed bin (18),		/* old and new node numbers */
     node_ptr ptr;					/* pointer to current node being moved */

dcl  to_p pointer;

		     to_node = to_segptr -> lsm.free;	/* Allocate new space for it */
		     to_p = addrel (to_segptr, to_node);
		     unspec (to_p -> any_node.header) = unspec (node_ptr -> any_node.header);
		     if upgrading_version_6_seg then
			to_p -> any_node.allocated_len = to_p -> any_node.allocated_len - 1;
		     unspec (to_p -> any_node.data_space) = unspec (node_ptr -> any_node.data_space);
		     to_segptr -> lsm.free = to_segptr -> lsm.free + currentsize (to_p -> any_node);
						/* Up allocation count */
		     old_new_tab (from_node) = to_node; /* Save number of new node for later references */

		     return;
		end;
%skip (5);
move_list_node:	procedure (node_ptr, from_node, to_node, err_code);

dcl  from_node fixed bin (18),			/* node being moved */
     err_code fixed bin (35),
     to_node fixed bin (18),				/* place it is moved to */
     node_ptr pointer,
     to_node_p pointer,
     elem_node fixed bin (18),
     elem_to_node fixed bin (18);

dcl  i fixed bin;					/* iteration index */

		     call move_simple_node (node_ptr, from_node, to_node); /* Get a friend to move list itself */
		     old_new_tab (from_node) = to_node;

		     to_node_p = addrel (to_segptr, to_node); /* Get pointer to request */

		     do i = 1 to node_ptr -> list_node.data_len; /* Iterate down list */

			elem_node = node_ptr -> list_node.node (i);

			if old_new_tab (elem_node) = 0 then do;
			     call chase_indirect (elem_node, actual_node, null, 0, err_code);
			     if err_code ^= 0 then return;

			     if old_new_tab (actual_node) = 0 then do;
				call move_substruc_recurse (elem_node, elem_to_node, ""b, err_code);
				if err_code ^= 0 then return;

				old_new_tab (actual_node) = elem_to_node;
			     end;
			     else old_new_tab (elem_node) = old_new_tab (actual_node);
			end;

			to_node_p -> list_node.node (i) = old_new_tab (elem_node);
		     end;

		     return;
		end;
%skip (5);
move_symtab_node:	proc (node_ptr, from_node, to_symtab_node, err_code);

/* This procedure moves the contents of a (the) symbol table from one
   LSM segment to another.  This is incidentally how compaction gets done. */

dcl (node_ptr pointer,
     from_node fixed bin (18),
     to_symtab_node fixed bin (18),
     err_code fixed bin (35)) parameter;

dcl  i fixed bin,
     array_len fixed bin,
     to_node fixed bin (18),
     new_len fixed bin,
     symbol_ptr pointer,
     actual_node fixed bin (18);

dcl  Not_top_level bit (1) aligned initial ("0"b) static options (constant);

		     new_len = node_ptr -> symtab_node.allocated_len;
		     if upgrading_version_6_seg then	/* old lengths all 1 too high */
			new_len = new_len - 1;

		     call lsm_$make_blk (to_segptr, to_symtab_node, symtab_type,
			new_len, null, err_code);
						/* Make a symbol table in the new LSM segment */
		     if err_code ^= 0 then return;

		     old_new_tab (to_symtab_node) = from_node;

		     call lsm_sym_$sym_list (from_segptr, sym_list_array, array_len, err_code);
		     if err_code ^= 0 then return;

		     do i = 1 to array_len;
			if old_new_tab (sym_list_array (i)) = 0 then do;
			     call chase_indirect (sym_list_array (i), actual_node, symbol_ptr, 0, err_code);
			     if err_code ^= 0 then return;

			     if old_new_tab (actual_node) = 0 then do;
				call merge_symbol_node (symbol_ptr, actual_node, to_node, Not_top_level, err_code);
				if err_code ^= 0 then return;

				if sym_list_array (i) ^= actual_node then
				     old_new_tab (sym_list_array (i)) = to_node;
			     end;

			     else old_new_tab (sym_list_array (i)) = old_new_tab (actual_node);
			end;
		     end;

		     return;

		end move_symtab_node;
%skip (5);
merge_symbol_node:	procedure (node_ptr, from_node, to_node, top_level, err_code);

dcl (node_ptr pointer,				/* pointer to symbol node in "from" seg */
     from_node fixed bin (18),			/* node number of same */
     to_node fixed bin (18),				/* node no of copy in "to" seg */
     top_level bit (1) aligned,			/* ON means moving top level structure */
     err_code fixed bin (35)) parameter;

dcl (to_val_n, from_val_n) fixed bin (18),		/* value node nos in "to" and "from" segs */
     to_sym_n fixed bin (18),				/* symbol node no in "to" seg */
     from_val_p pointer,
     from_val_type fixed bin (4),
     name_node_ptr pointer,
     not_in_to bit (1) aligned;			/* switch indicates that symbol is not found in "to" seg */

		     if node_ptr -> any_node.type ^= symbol_type then do;
			err_code = graphic_error_table_$bad_node;
			return;
		     end;


		     name_node_ptr = pointer (node_ptr, node_ptr -> symbol_node.name_node);

		     call lsm_sym_$symk (to_segptr, Find_symbol, name_node_ptr -> char_node.string,
			to_sym_n, to_val_n, 0);
		     not_in_to = (to_sym_n = 0);	/* ON if symbol is not in symbol table of "to" seg */

		     go to merge_symbol (merge_code);

merge_symbol (0):	     if not_in_to then
			call copy_from_symbol;
		     else do;
			err_code = graphic_error_table_$struc_duplication;
			return;
		     end;
		     goto merge_end;

merge_symbol (1):	     call copy_from_symbol;
		     goto merge_end;


merge_symbol (2):	     if top_level then
			call copy_from_symbol;	/* this is direct user request, move it whether there or not */
		     else if not_in_to then do;	/* tagalong subsymbol, create it, make it empty */
			call lsm_sym_$symk (to_segptr, Create_symbol, name_node_ptr -> char_node.string,
			     to_sym_n, to_node, err_code);
			to_node = to_sym_n;
		     end;
		     else to_node = to_sym_n;		/* else already there, mirror */
		     goto merge_end;

merge_symbol (3):	     if (top_level | not_in_to)
		     then call copy_from_symbol;
		     else to_node = to_sym_n;

merge_end:	     old_new_tab (from_node) = to_node; /* note that this node now known */
		     return;
%skip (5);
copy_from_symbol:	     procedure;

/* Utility routine to copy the value node of a symbol in the "from" segment
   into to "to" segment, and insert the symbol name and value in to "to" symbol table */

			from_val_n = node_ptr -> symbol_node.value_node; /* Get "from" value node */
			call chase_indirect (from_val_n, from_val_n, from_val_p, from_val_type, err_code);
						/* Get its type, leng, pointer to it */
			if err_code ^= 0 then return;

			to_val_n = old_new_tab (from_val_n); /* See if already copied */

			if from_val_n ^= 0 then	/* not the dummy null node */
			     if to_val_n = 0 then do; /* never previously copied */
				call move_substruc_recurse (from_val_n, to_val_n, ""b, err_code);
				if err_code ^= 0 then return;
			     end;

			call lsm_sym_$symk (to_segptr, Create_symbol, name_node_ptr -> char_node.string,
			     to_node, to_val_n, err_code);
						/* Make new or write old symbol in copy symtab */

			return;
		     end copy_from_symbol;

		end merge_symbol_node;
%skip (5);
chase_indirect:	procedure (start_node, actual_node, node_ptr, cur_type, err_code);


/* This subroutine chases down LSM indirections and returns info about the real McCoy node. */
dcl  start_node fixed bin (18),			/* Start here */
     actual_node fixed bin (18),			/* Final number of node */
						/* SHOULD THIS BE HERE ? */
     node_ptr pointer,				/* pointer to node specificstions */
     cur_type fixed bin (4),				/* type of node found */
     err_code fixed bin (35);

		     if start_node = 0 then do;
			actual_node = 0;
			node_ptr = null;
			cur_type = -1;
			return;
		     end;
		     actual_node = start_node;
		     cur_type = indirect_type;

		     do while (cur_type = indirect_type);
			call in_bounds_check (actual_node, err_code);
			if err_code ^= 0 then return;
			node_ptr = addrel (from_segptr, actual_node);
			cur_type = node_ptr -> any_node.type;
			if cur_type <= 0 | cur_type > lsm_constants.n_types
			then do;
			     err_code = graphic_error_table_$bad_node;
			     return;
			end;
			if cur_type = indirect_type then actual_node = node_ptr -> indirect_node.new_node;
		     end;

		     return;
%skip (5);
in_bounds_check:	     procedure (node_no, err_code);

dcl  node_no fixed bin (18) parameter,
     err_code fixed bin (35) parameter;

			if node_no = 0 then err_code = 0;
			else if (node_no < currentsize (from_segptr -> lsm)) then
			     if from_segptr -> lsm.version = LSM_version_6 then do;
						/* check ameliorating circumstances */
				if node_no = 3 then
				     err_code = 0;	/* symtab in version 6 segment */
				else if node_no ^< currentsize (from_segptr -> lsm)
				- from_segptr -> lsm.component_slots then
				     err_code = 0;	/* symbol in slot 0 of v6 lsm_ makes header look huge */
				else err_code = graphic_error_table_$lsm_node_ob;
			     end;
			     else err_code = graphic_error_table_$lsm_node_ob;
			else if node_no > sys_info$max_seg_size - 1 then
			     err_code = graphic_error_table_$lsm_node_ob;
			else err_code = 0;

			return;

		     end in_bounds_check;
		end chase_indirect;
	     end move_substruc_recurse;
	end move_substruc;
%page;
find_via_search_paths: proc (ename, segptr, code);

dcl  ename char (*) parameter,
     segptr pointer parameter,
     code fixed bin (35) parameter;

dcl  dname char (168);

dcl  my_own_dirname char (168) static initial ("");

	     if my_own_dirname = "" then do;
this_label:	call hcs_$fs_get_path_name (codeptr (this_label),
		     my_own_dirname, 0, "", code);
		if code ^= 0 then return;
	     end;

	     segptr = null;

	     call search_paths_$find_dir ("graphics", null, ename, my_own_dirname, dname, code);
	     if code ^= 0 then return;

	     call hcs_$initiate (dname, ename, "", 0, 1, segptr, code);
	     return;

	end find_via_search_paths;

     end lsm_fs_;
   



		    lsm_sym_.pl1                    11/18/82  1706.7rew 11/18/82  1625.7       87264


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

lsm_sym_: proc; return;

/* This procedure implements symbol table functions for the graphics system's
   structure manipulation package (lsm_). */
/* Modified 07/23/79 by CDT to add implicit location of
   symbol table.  Now only one is allowed per segment. */
/* Last modified 03/25/80 by CDT to replace internal procedure
   hash_pl1 with hash_index_, recently liberated from hardcore */

/* Arguments */

dcl (op_code fixed bin,				/* opcode to determine what to do */
     key_arg char (*),
     symbol_node_arg fixed bin (18),			/* node # of symbol node */
     value_node fixed bin (18),			/* node # of symbol value node */
     err_code fixed bin (35)) parameter;		/* standard system error code */

/* Builtins */

dcl (addr, dim, fixed, length, null, pointer, rtrim, size) builtin;

/* Automatic */

dcl (node_no,					/* used to index down a symbol table bucket list */
     table_n) fixed bin (18);				/* node # of symbol table */

dcl  type fixed bin,				/* type of node */
     key_node fixed bin (18),
     chain_word_ptr pointer,				/* used in symbol bucket list search */
     symbol_ptr pointer,
     symtab_ptr pointer,				/* pointer to start of bucket list in a symbol table node */
     i fixed bin;

/* Entries */

dcl  hash_index_ ext entry (pointer, fixed bin, fixed bin, fixed bin (18)) returns (fixed bin);

/* Based */

dcl  based_chain_word fixed bin (18) based;

/* External static */

dcl (error_table_$unimplemented_version,
     graphic_error_table_$lsm_sym_search,
     graphic_error_table_$inv_node_type,
     graphic_error_table_$lsm_invalid_op) fixed bin (35) external;
%page;
%include lsm_formats;
%page;
%include lsm_entry_dcls;
%page;
symk:	entry (lsm_segptr, op_code, key_arg, symbol_node_arg, value_node, err_code);

/* key is supplied directly as a character string */

	symbol_node_arg = 0;			/* Start off not knowing anything */
	err_code = 0;

	call find_table (lsm_segptr, table_n, err_code);
	if err_code ^= 0 then return;

	symtab_ptr = pointer (lsm_segptr, table_n);

	if symtab_ptr -> any_node.type ^= symtab_type then do; /* If node is not a symbol table... */
invalid_type:  err_code = graphic_error_table_$inv_node_type;
	     return;
	end;

	call hash_find_symbol (lsm_segptr, (symtab_ptr -> symtab_node.data_len), key_arg, symbol_ptr, node_no,
	     chain_word_ptr, op_code, err_code);
	if err_code ^= 0 then return;

/* If we get here, we know that the existence/nonexistence of the symbol is
   compatible with the operation specified by op_code */

	if op_code = Delete_symbol then do;
	     chain_word_ptr -> based_chain_word = symbol_ptr -> symbol_node.next_node;
						/* Chain around this node */
	     symbol_ptr -> indirect_node.new_node = symbol_ptr -> symbol_node.value_node;
						/* Make an indirect node so that sym and value will be "EQ" */
	     symbol_ptr -> indirect_node.data_len = 2;
	     symbol_ptr -> indirect_node.type = lsm_constants.indirect_type;
	end;

	else if symbol_ptr ^= null then do;		/* symbol was found */
	     if op_code = Create_symbol then		/* rewrite value */
		symbol_ptr -> symbol_node.value_node = value_node;
	     else value_node = symbol_ptr -> symbol_node.value_node;
						/* Find or Find_or_create; return value */
	     symbol_node_arg = node_no;
	end;

	else do;					/* symbol not found, must create it */
	     call lsm_$make_blk (lsm_segptr, key_node, char_type, length (key_arg), node_ptr, err_code);
						/* make node for name */
	     if err_code ^= 0 then return;

	     node_ptr -> char_node.string = key_arg;

	     call lsm_$make_blk (lsm_segptr, symbol_node_arg, symbol_type,
		size (symbol_ptr -> symbol_node) - size (null -> header), symbol_ptr, err_code);
	     if err_code ^= 0 then return;

	     symbol_ptr -> symbol_node.name_node = key_node;
	     symbol_ptr -> symbol_node.value_node = value_node;
	     symbol_ptr -> symbol_node.next_node = 0;

	     chain_word_ptr -> based_chain_word = symbol_node_arg; /* chain it on */
	end;

	return;
	%skip (10);
hash_find_symbol: proc (lsm_segptr, symtab_len, key_arg, symbol_ptr, node_no, chain_word_ptr, op_code, err_code);

dcl (lsm_segptr pointer,
     symtab_len fixed bin (18),
     key_arg char (*),
     symbol_ptr pointer,
     node_no fixed bin (18),
     chain_word_ptr pointer,
     op_code fixed bin,
     err_code fixed bin (35)) parameter;

dcl (first_bucket, last_bucket) fixed bin (18),
     i fixed bin (18),
     must_be_there bit (1) aligned,
     name_node_ptr pointer;

	     if lsm_segptr -> lsm.version = LSM_version_7 then
		first_bucket, last_bucket = hash_index_ (addr (key_arg), length (rtrim (key_arg)), 0, symtab_len);

	     else if lsm_segptr -> lsm.version = LSM_version_6 then do;
		first_bucket = 0;
		last_bucket = symtab_len;		/* exhaustive search */
	     end;

	     else do;
		err_code = error_table_$unimplemented_version;
		return;
	     end;

	     if (op_code < Find_symbol) | (op_code > Delete_symbol) then do;
		err_code = graphic_error_table_$lsm_invalid_op;
		return;
	     end;


	     err_code = 0;
	     must_be_there = (op_code = Delete_symbol) | (op_code = Find_symbol);

	     do i = first_bucket to last_bucket;

		chain_word_ptr = addr (symtab_ptr -> symtab_node.bucket_root (i));
		node_no = chain_word_ptr -> based_chain_word;

		do while (node_no ^= 0);
		     symbol_ptr = pointer (lsm_segptr, node_no);
		     if symbol_ptr -> symbol_node.type ^= lsm_constants.symbol_type then
			goto invalid_type;

		     name_node_ptr = pointer (lsm_segptr, symbol_ptr -> symbol_node.name_node);
		     if name_node_ptr -> char_node.string = key_arg then /* gotcha */
			return;

		     chain_word_ptr = addr (symbol_ptr -> symbol_node.next_node);
		     node_no = chain_word_ptr -> based_chain_word;
		end;
	     end;

/* Not found, sing dirge */

	     symbol_ptr = null;
	     node_no = 0;
	     if must_be_there then err_code = graphic_error_table_$lsm_sym_search;
	     return;

	end hash_find_symbol;
%page;
find_table: entry (lsm_segptr, symtab_node_no, err_code);

dcl  symtab_node_no fixed bin (18) parameter;

	call find_table (lsm_segptr, symtab_node_no, err_code);
	return;
	%skip (10);
find_table: proc (lsm_segptr, symtab_node_no, err_code);

dcl (lsm_segptr pointer,
     symtab_node_no fixed bin (18),
     err_code fixed bin (35)) parameter;

dcl  root_len fixed bin;

	     if lsm_segptr -> lsm.version = LSM_version_7 then do; /* current version, easy */
		symtab_node_no = lsm_segptr -> lsm.root_symtab;
		err_code = 0;
		return;
	     end;

	     else if lsm_segptr -> lsm.version = LSM_version_6 then do;

/* We have to find the symbol table.  The graphics system used to chain the
   root node to a list, the first element of which was the symbol table node ID
   (the second was always 0). */

		call lsm_$get_blk (lsm_segptr, lsm_segptr -> lsm.root_symtab, type, root_len, node_ptr, err_code);
		if err_code ^= 0 then return;

		if (type ^= list_type) | (root_len ^= 2) then do;
		     err_code = graphic_error_table_$inv_node_type;
		     return;
		end;

		symtab_node_no = node_ptr -> list_node.node (1);
		err_code = 0;
		return;
	     end;

	     else do;
		err_code = error_table_$unimplemented_version;
		return;
	     end;

	end find_table;
%page;
sym_list:	entry (lsm_segptr, array, array_len, err_code);

/* Entry fills "array" with numbers of nodes in symbol table */
/* If array_max is too small, err_code is returned as error_table_$smallarg */

dcl  array (*) fixed bin (18),			/* Arrayy into which list of symbol node #s will go (output) */
     array_max fixed bin,				/* length of array provided by caller */
     array_len fixed bin;				/* number of significant elements in array (output) */

dcl  error_table_$smallarg fixed bin (35) external;

	err_code = 0;
	array_max = dim (array, 1);			/* Determine dim of array provided by caller */

	call find_table (lsm_segptr, table_n, err_code);
	if err_code ^= 0 then return;

	symtab_ptr = pointer (lsm_segptr, table_n);	/* Get pointer to symbol table node */
	if fixed (symtab_ptr -> symbol_node.type, 4) ^= symtab_type /* If not a symbol table node... */
	then go to invalid_type;

	array_len = 0;
	do i = 0 to fixed (symtab_ptr -> symtab_node.data_len, 17, 0) - 1; /* Iterate over number of buckets */
	     do node_no = symtab_ptr -> symtab_node.bucket_root (i)
		     repeat pointer (lsm_segptr, node_no) -> symbol_node.next_node
		     while (node_no ^= 0);		/* Run down symbol node chain */
		array_len = array_len + 1;		/* One more symbol in array */

		if err_code ^= 0 then;		/* already know arg is short, just continue */
		else if array_len > array_max
		then err_code = error_table_$smallarg;	/* Array specified is too small to hold entire list */
		else array (array_len) = node_no;	/* Fill in next else array element */
	     end;
	end;
	return;
     end lsm_sym_;



		    plot_.pl1                       11/18/82  1706.7rew 11/18/82  1625.7      201366


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

plot_: proc (xparam, yparam, xydim, vec_sw, symbol);

/* Multics Graphics Plotting Package
   Written circa 9/12/70 by C. D. Tavares
   Modified 03/03/75 by CDT to fix numeric values: values on axes sometimes represented logs, not values.
   Modified 06/06/75 by CDT to fix bug: user-supplied scale factors for any log plotting were not being "logged" themselves.
   Modified 04/23/80 by CDT to make values on log axes appear as "e4.5" instead of "6.997524"(!)
   and to change calls to com_err_ to sub_err_.  Also added gullibility checks in user value-setting entries
   and added heuristic to force axis values that were two orders of magnitude smaller than their compatriots to zero.
   Last modified 03/29/81 by Steve Carlock to increase the number of points that can be plotted. */


dcl (xparam (*), yparam (*)) float bin,
     code fixed bin (35),
     i fixed bin,
     ioa_$rsnnl ext entry options (variable),
     sub_err_ ext entry options (variable),
    (x (xydim) based (xptr), y (xydim) based (yptr)) float bin,
    (xptr, yptr) pointer,
    (xlabel, ylabel, title) char (100) varying static initial (""),
     symbol char (1),
     error_table_$bad_arg ext fixed bin (35) static,
    (type, grid_sw) fixed bin static initial (1),
     eq_scl_sw fixed bin static initial (0),
     vec_sw fixed bin,
     xydim fixed bin;

dcl  Plot_width float bin static options (constant) initial (8e2);

dcl  cleanup condition;

dcl  jfx fixed bin,
     log10_of_base float bin static initial (1e0),
     wipe_me fixed bin static initial (1),
    (xmin, xmax, ymin, ymax) float bin static,
    (j, vtic, htic) fixed bin,
    (abspread, jfl) float bin,
    (incrx, incry) float bin static,
     compensation float bin,
    (xlines, ylines) fixed bin internal static,
    (gxincr, gyincr) float bin static,
    (abs, binary, divide, fixed, float, index, length, log10, ltrim, max, mod, null, substr) builtin;
%page;
%include graphic_etypes;
%page;
%include plot_entry_dcls;
%page;
%include gm_entry_dcls;
%page;
%include gc_entry_dcls;
%page;

dcl (g, h) (200) fixed bin (18),
     string char (40) varying;

dcl (xcoord, ycoord, oxc, oyc) float bin,
     fig fixed bin (18),
     temp_array (1) fixed bin (18),
     current_sublist fixed bin (18),
     figure fixed bin (18);

dcl  sys_area_p pointer static initial (null),
     sys_area area based (sys_area_p),
     get_system_free_area_ ext entry returns (pointer);

	default (float) binary;			/* Let me explain why I did this: */

/* If you don't do this, all the constants in the program of the form
   1e0, 2e-1, etc. are made into decimal quantities by the compiler.  This
   is not only slow, but the compiler has bugs so that it doesn't always work.  It
   produces over and underflows, illegal procedures, no execute permissions, and
   other unpalatable things.  Maintainers, just be forewarned it's there, and why. */

	call graphic_manipulator_$init (code);		/* initialize graphics */
	if code ^= 0 then goto crump;

	if sys_area_p = null then sys_area_p = get_system_free_area_ ();

	xptr, yptr = null;

	on cleanup call clean_up;

	allocate x in (sys_area), y in (sys_area);
						/* get the arrays needed in this entry */

	do i = 1 to xydim;
	     x (i) = xparam (i);
	     y (i) = yparam (i);
	end;

	if type ^= Linear_linear then do;		/* We have some logarithms to compute... */
	     if type ^= Linear_log then call make_log (x); /* must log x values */
	     if type ^= Log_linear then call make_log (y); /* must log y values */
	end;

make_log:	proc (array);

dcl  array (*) float bin parameter;

	     do i = 1 to xydim;			/* because logb(n) = loga(n)/loga(b) */
		array (i) = log10 (array (i))/log10_of_base;
	     end;
	end make_log;


	if wipe_me = 0 then fig = 0;			/* grid already out there */

	else do;					/* first plot, must figure out some stuff */

	     if have_minmaxes then do;		/* use user-supplied scaling factors */

		if mod (type, 2) = 0 then do;		/* take log of the x axis factors */
		     xmax = log10 (static_xmax) / log10_of_base;
		     xmin = log10 (static_xmin) / log10_of_base;
		end;
		else do;				/* else the x-axis is linear, just copy */
		     xmax = static_xmax;
		     xmin = static_xmin;
		end;

		if type > 2 then do;		/* take log of the y-axis */
		     ymax = log10 (static_ymax) / log10_of_base;
		     ymin = log10 (static_ymin) / log10_of_base;
		end;
		else do;				/* else the y-axis is linear, just copy */
		     ymax = static_ymax;
		     ymin = static_ymin;
		end;
	     end;

	     else do;
		xmin, xmax = x (1);			/* find max and min values by linear sort */
		ymin, ymax = y (1);

		do i = 2 to xydim;
		     if x (i) > xmax then xmax = x (i);
		     if x (i) < xmin then xmin = x (i);
		     if y (i) > ymax then ymax = y (i);
		     if y (i) < ymin then ymin = y (i);
		end;
	     end;

	     call make_grid;

	end;

/* -------------------------------------------------------------- */

make_grid: proc;

/* Puts good-looking grid into fig */

	     call scale_plot (xmax, xmin, incrx, gxincr, xlines);
	     call scale_plot (ymax, ymin, incry, gyincr, ylines);

scale_plot:    proc (maxval, minval, incrval, gincrval, nlines); /* figures out proper dimensions and tic values */

dcl (maxval, minval, incrval, gincrval) float bin parameter,
     nlines fixed bin parameter;

dcl  spread float bin,
     fixjunk fixed bin,
     floatjunk float bin;

		spread = maxval - minval;

		if spread = 0e0 then		/* flat line graph */
		     if minval = 0e0 then do;		/* at zero, yet */
			minval = -1e-2;		/* as good as anything */
			maxval = 1e-2;
			spread = 2e-2;
		     end;
		     else do;			/* flat line but not at zero */
			maxval = maxval + (0.1e0 * abs (maxval));
			minval = minval - (0.1e0 * abs (minval));
			spread = maxval - minval;
		     end;

		floatjunk = log10 (spread);		/* what power of ten are we talking about */
		if floatjunk < 0 then floatjunk = floatjunk - 1e0; /* adjust for funnies in definition of log */
		fixjunk = floatjunk;		/* discard the mantissa */
		abspread = spread / 1e1**fixjunk;	/* abspread is a "non-dimensionalized spread", guaranteed */
						/* to be: 1e0 <= abspread < 10e0 */

/* Now we figure out useful values for the tic marks.  We will increment tic marks by the following non-dimensionalized
   values only: 1, 2, 2.5, and 5.  This makes the graph more readable than if we chose to increment them by
   1.275 or something like that.  The following algorithm is guaranteed to produce a plot of 5 to 11 intervals (6 to 12 lines)
   using one of the useful interval values.  The cutoff constants in the code below are chosen from the
   maximum range of values representable on a 12-line plot at each interval value. */

		if abspread < 1.1e0 then incrval = 1.00000e1 ** (fixjunk - 1); /* use interval of 1 */
		else if abspread < 2.2e0 then incrval = 0.200000e0 * 1e1 ** fixjunk; /* use interval of 2 */
		else if abspread < 2.75 then incrval = 0.2500000e0 * 1e1 ** fixjunk; /* use interval of 2.5 */
		else if abspread < 5.5 then incrval = 0.5000000e0 * 1e1 ** fixjunk; /* use interval of 5 */
		else incrval = 1e1 ** fixjunk;	/* use interval of 1 at one higher power (10) */

		if minval < 0 then compensation = -.99999e0; /* round to next wider integer */
		else compensation = 0;

		minval = fixed (binary (minval / incrval) + compensation) * incrval;

		if maxval < 0 then compensation = 0;	/* round to next wider integer */
		else compensation = .99999e0;

		maxval = fixed (binary (maxval / incrval) + compensation) * incrval;

		nlines = (maxval - minval) / incrval + 1e-1; /* number of lines in grid */
		gincrval = Plot_width / nlines;	/* in points */

		return;

	     end scale_plot;

	     if eq_scl_sw = Equal_scaling then do;	/* user wants graph scaled equally on both axes */
		if incrx < incry then do;
		     gxincr = gyincr;
		     xlines = ylines;
		     incrx = incry;
		end;
		else do;
		     gyincr = gxincr;
		     ylines = xlines;
		     incry = incrx;
		end;
		jfl = max (xmax - xmin, ymax - ymin);
		xmin = (xmax + xmin)/2e0 - jfl/2e0;
		xmax = xmin + jfl;
		ymin = (ymax + ymin)/2e0 - jfl/2e0;
		ymax = ymin + jfl;
	     end;

/* BEGIN GRAPHIC GRID GENERATION */

	     if grid_sw = No_grid then do;		/* no grid wanted */
		fig = 0;
		return;
	     end;


	     if grid_sw = Tick_marks then do;		/* two axes with tic marks */
		g (1) = graphic_manipulator_$create_position (Shift, -5e0, 0e0, 0e0, code); /* create tic marks */
		if code ^= 0 then goto crump;
		g (2) = graphic_manipulator_$create_position (Vector, 1e1, 0e0, 0e0, code);
		if code ^= 0 then goto crump;
		g (3) = graphic_manipulator_$create_position (Shift, -5e0, 0e0, 0e0, code);
		if code ^= 0 then goto crump;
		htic = graphic_manipulator_$create_array (g, 3, code);
		if code ^= 0 then goto crump;
		g (1) = graphic_manipulator_$create_position (Shift, 0e0, -5e0, 0e0, code);
		if code ^= 0 then goto crump;
		g (2) = graphic_manipulator_$create_position (Vector, 0e0, 1e1, 0e0, code);
		if code ^= 0 then goto crump;
		g (3) = graphic_manipulator_$create_position (Shift, 0e0, -5e0, 0e0, code);
		if code ^= 0 then goto crump;
		vtic = graphic_manipulator_$create_array (g, 3, code);
		if code ^= 0 then goto crump;

		g (1) = graphic_manipulator_$create_mode (Linetype, Dashed, code);
		if code ^= 0 then goto crump;
		g (2) = graphic_manipulator_$create_position (Setposition, -35e1, -4e2, 0e0, code);
		if code ^= 0 then goto crump;

		do i = 3 to 2 * xlines + 1 by 2;	/* create two axes grid with tic marks in graphic structure */
		     g (i) = graphic_manipulator_$create_position (Vector, gxincr, 0e0, 0e0, code);
		     if code ^= 0 then goto crump;
		     g (i+1) = vtic;
		end;

		g (i) = graphic_manipulator_$create_position (Setposition, -35e1, -4e2, 0e0, code);
		if code ^= 0 then goto crump;

		do i = i + 1 to i + 2 * ylines - 1 by 2;
		     g (i) = graphic_manipulator_$create_position (Vector, 0e0, gyincr, 0e0, code);
		     if code ^= 0 then goto crump;
		     g (i+1) = htic;
		end;
	     end;

	     else do;
		if grid_sw = Solid_grid then g (1) = graphic_manipulator_$create_mode (Linetype, Solid, code); /* want solid grid */
		else g (1) = graphic_manipulator_$create_mode (Linetype, Dashed, code); /* default is dashed grid */
		if code ^= 0 then goto crump;
		g (2) = graphic_manipulator_$create_position (Setposition, -35e1, -4e2, 0e0, code);
		if code ^= 0 then goto crump;
		do i = 3 to xlines * 2 + 1 by 2;	/* draw x lines */
		     g (i) = graphic_manipulator_$create_position (Vector, 0e0, Plot_width, 0e0, code);
		     if code ^= 0 then goto crump;
		     g (i+1) = graphic_manipulator_$create_position (Setposition, float (divide (i-1, 2, 17, 0) * gxincr - 350), -4e2, 0e0, code);
		     if code ^= 0 then goto crump;
		end;
		g (i) = g (3);
		g (i+1) = g (2);
		jfx = i;
		do i = i+2 to ylines * 2 + i by 2;	/* draw y lines */
		     g (i) = graphic_manipulator_$create_position (Vector, Plot_width, 0e0, 0e0, code);
		     if code ^= 0 then goto crump;
		     g (i+1) = graphic_manipulator_$create_position (Setposition, -35e1, float (divide (i-jfx, 2, 17, 0) * gyincr - 400), 0e0, code);
		     if code ^= 0 then goto crump;
		end;
		g (i) = g (jfx + 2);
		i = i + 1;
	     end;

	     jfx = i;				/* save running position variable */
	     do i = 0 to ylines;			/* draw y coordinate values */
		jfl = ymin + i * incry;
		if abs (jfl) * 1e2 < incry then jfl = 0e0; /* anything that much less than increment gotta be zero */
		call ioa_$rsnnl ("^[^6f^;^7f^]", string, 0, (type > 2), jfl);
		if index (string, "e") > 0 then call ioa_$rsnnl ("^[^3e^;^4e^]", string, 0, (type > 2), jfl);
		string = ltrim (string);
		if substr (string, length (string), 1) = "." then
		     string = substr (string, 1, length (string) - 1);
		if type > 2 then string = "e" || string;
		g (jfx+2*i) = graphic_manipulator_$create_position (Setposition, -370, float (i*gyincr - 400), 0e0, code);
		if code ^= 0 then goto crump;
		g (jfx + 1+2*i) = graphic_manipulator_$create_text (Right, length (string), (string), code);
		if code ^= 0 then goto crump;
	     end;

	     jfx = jfx + 2 * ylines + 2;
	     do i = 0 to xlines;			/* draw x coordinate values */
		jfl = xmin + i * incrx;
		if abs (jfl) * 1e2 < incrx then jfl = 0e0; /* anything that much less than increment gotta be zero */
		call ioa_$rsnnl ("^[^6f^;^7f^]", string, 0, (mod (type, 2) = 0), jfl);
		if index (string, "e") > 0 then call ioa_$rsnnl ("^[^3e^;^4e^]", string, 0, (mod (type, 2) = 0), jfl);
		string = ltrim (string);
		if substr (string, length (string), 1) = "." then
		     string = substr (string, 1, length (string) - 1);
		if mod (type, 2) = 0 then string = "e" || string;
		if mod (i, 2) = 1
		then g (jfx+2*i) = graphic_manipulator_$create_position (Setposition, float (i*gxincr - 350), -41e1, 0e0, code);
		else g (jfx+2*i) = graphic_manipulator_$create_position (Setposition, float (i*gxincr - 350), -44e1, 0e0, code);
		if code ^= 0 then goto crump;
		g (jfx + 1+2*i) = graphic_manipulator_$create_text (Upper_center, length (string), (string), code);
		if code ^= 0 then goto crump;
	     end;

	     i = jfx + 2 * xlines + 2;		/* update running position counter */
	     g (i) = graphic_manipulator_$create_mode (Linetype, Solid, code); /* get back to solid mode wherever we are */
	     if code ^= 0 then goto crump;

	     if xlabel ^= "" then do;
		g (i+1) = graphic_manipulator_$create_position (Setposition, 50, -500, 0, code);
		if code ^= 0 then goto crump;
		g (i+2) = graphic_manipulator_$create_text (Lower_center, length (xlabel), (xlabel), code);
		if code ^= 0 then goto crump;
	     end;
	     else g (i+1), g (i+2) = 0;		/* called from FORTRAN and don't want label */
	     if ylabel ^= "" then do;
		jfx = float (length (ylabel))/2e0 * 2.5e1; /* 25 is dist, between chars */
		do j = 1 to length (ylabel);		/* make it come out vertical */
		     h (2*j-1) = graphic_manipulator_$create_position (Setposition, -51e1, float (jfx - 25*j), 0e0, code);
		     if code ^= 0 then goto crump;
		     h (2*j) = graphic_manipulator_$create_text (Upper_center, 1, substr (ylabel, j, 1), code);
		     if code ^= 0 then goto crump;
		end;
		g (i+3) = graphic_manipulator_$create_array (h, 2*j-2, code);
		if code ^= 0 then goto crump;
	     end;
	     else g (i+3) = 0;

	     if title ^= "" then do;
		h (1) = graphic_manipulator_$create_position (Setposition, 50, 450, 0, code);
		if code ^= 0 then goto crump;
		h (2) = graphic_manipulator_$create_text (Lower_center, length (title), (title), code);
		if code ^= 0 then goto crump;
		g (i+4) = graphic_manipulator_$create_array (h, 2, code);
		if code ^= 0 then goto crump;
	     end;

	     else g (i+4) = 0;


	     fig = graphic_manipulator_$create_array (g, i+4, code);
	     if code ^= 0 then goto crump;
	     return;

	end make_grid;

/* -------------------------------------------------------------- */

/* BEGIN FIGURE GENERATION */

/* initialize the list with the grid (if it exists) */

	temp_array (1) = fig;

	current_sublist = graphic_manipulator_$create_array (temp_array, 1, code);

	if (code ^= 0)
	then goto crump;

	figure = current_sublist;			/* The 'master' list */

/* plot points of figure */

	do i = 1 to xydim;

	     xcoord = fixed ((x (i)-xmin) * gxincr / incrx - 350);
	     ycoord = fixed ((y (i)-ymin) * gyincr / incry - 400);
	     if i = 1 then fig = graphic_manipulator_$create_position (Setposition, xcoord, ycoord, 0e0, code);
	     else if vec_sw < Symbols_only
	     then fig = graphic_manipulator_$create_position (Vector, xcoord - oxc, ycoord - oyc, 0, code);
	     else fig = graphic_manipulator_$create_position (Shift, xcoord - oxc, ycoord - oyc, 0e0, code); /* doesn't want connecting Vectors */
	     if code ^= 0 then goto crump;

	     call append_element (fig, code);

	     if (code ^= 0)
	     then goto crump;

	     if vec_sw >= Vectors_and_symbols then do;

		fig = graphic_manipulator_$create_text (Center, 1, symbol, code); /* wants symbol plotted in place of Point */
		if code ^= 0 then goto crump;

		call append_element (fig, code);

		if (code ^= 0)
		then goto crump;

	     end;

	     oxc = xcoord; oyc = ycoord;		/* here we go round the loop */
	end;

	figure = graphic_manipulator_$assign_name ("plot_display_list_", (figure), code);
	if code ^= 0 then goto crump;

	if wipe_me = 1 then call graphic_compiler_$display (figure, code); /* we want an erase */
	else call graphic_compiler_$display_append (figure, code); /* scribble over what's up there */
	eq_scl_sw, wipe_me = 0;			/* reset static stuff */
	have_minmaxes = ""b;
	xlabel, ylabel, title = "";
	grid_sw = 1;
	if code ^= 0 then
crump:	     call sub_err_ (code, "plot_", "h", null, 0, "Error while creating plot.");

	call clean_up;

clean_up:	proc;

	     if xptr ^= null then free x in (sys_area);
	     if yptr ^= null then free y in (sys_area);

	end clean_up;

	return;

/* The following entries are used to set certain static variables
   so that plot_ knows exactly what to do on each call.
   $scale uses common code.

   $initf is an init callable from FORTRAN. */


setup:	entry (title1, xlabel1, ylabel1, type1, base1, grid_sw1, eq_scl_sw1);

dcl  rtrim builtin;

	title = rtrim (title1);

init:	entry (xlabel1, ylabel1, type1, base1, grid_sw1, eq_scl_sw1);

dcl (xlabel1, ylabel1, title1) char (*),
    (type1, grid_sw1, eq_scl_sw1) fixed bin,
     base1 float bin;

dcl  base float bin static;

	xlabel = rtrim (xlabel1);
	ylabel = rtrim (ylabel1);
	call initialize_rest_of_stuff;
	return;

/* ---------------------------------------- */

initialize_rest_of_stuff: proc;

	     type = validate (type1, Linear_linear, Log_log, Linear_linear, "type", "linear-linear");
	     grid_sw = validate (grid_sw1, Tick_marks, No_grid, Dotted_grid, "grid_sw", "dotted grid");
	     eq_scl_sw = validate (eq_scl_sw1, Normal_scaling, Equal_scaling, Normal_scaling, "eq_scl_sw", "normal scaling");
	     wipe_me = 1;
	     have_minmaxes = ""b;
	     base = base1;
	     if base <= 0e0 then log10_of_base = 0;
	     else log10_of_base = log10 (base);

	end initialize_rest_of_stuff;

/* ---------------------------------------- */

initf:	entry (xlabel1, i1, ylabel1, j1, type1, base1, grid_sw1, eq_scl_sw1);

dcl (i1, j1) fixed bin;

	xlabel = substr (xlabel1, 1, max (0, i1));
	ylabel = substr (ylabel1, 1, max (0, j1));
	call initialize_rest_of_stuff;
	return;

/* ----------------------------------------------- */

validate:	proc (inval, minval, maxval, defaultval, item, description) returns (fixed bin);

dcl (inval, minval, maxval, defaultval) fixed bin parameter,
    (item, description) char (*) parameter;

	     if inval ^< minval then
		if inval ^> maxval then
		     return (inval);

	     call sub_err_ (error_table_$bad_arg, "plot_", "h", null, 0,
		"^a (^d) not between ^d and ^d.^/Type ""start"" for default value (^a).",
		item, inval, minval, maxval, description);
	     return (defaultval);

	end validate;

/* ----------------------------------------------- */

scale:	entry (xmin1, xmax1, ymin1, ymax1);

dcl (xmin1, xmax1, ymin1, ymax1) float bin parameter,
    (static_xmin, static_xmax, static_ymin, static_ymax) float bin static initial (0),
     have_minmaxes bit (1) aligned static initial (""b);

	if have_minmaxes then return;
	call check_range ("x", xmin1, xmax1);
	call check_range ("y", ymin1, ymax1);
	have_minmaxes = "1"b;
	static_xmin = xmin1;
	static_xmax = xmax1;
	static_ymin = ymin1;
	static_ymax = ymax1;
	return;

/* ------------------------------------------ */

check_range: proc (axisname, minval, maxval);

dcl  axisname char (1) parameter,
    (minval, maxval) float bin parameter;

	     if minval < maxval then return;

	     call sub_err_ (error_table_$bad_arg, "plot_", "h", null, 0,
		"Specified minimum value for ^a axis (^f) not less than max value (^f).^/Type ""start"" to use default scaling.",
		axisname, minval, maxval);
	     goto return_and_forget_it;

	end check_range;

return_and_forget_it: return;

/* ------------------------------------------ */
%page;
append_element: proc (item, code);

dcl  item fixed bin (18);
dcl  code fixed bin (35);

dcl  temp fixed bin (18);
dcl  fudge (2) fixed bin (18);
dcl  graphic_error_table_$lsm_blk_len fixed bin (35) static external;

	     call graphic_manipulator_$add_element (current_sublist, -1, item, code);

	     if (code ^= graphic_error_table_$lsm_blk_len) /* it worked or it */
	     then return;				/* was something we couldn't handle */

	     fudge (1) = 0;				/* leave room for what is now at */
						/* the end of the current sublist */

	     fudge (2) = item;			/* the new item goes in slot number 2 */

	     temp = graphic_manipulator_$create_array (fudge, 2, code);
						/* create the 'new' current sublist */

	     if (code ^= 0)
	     then return;				/* caller handles any errors */

	     fudge (1) = graphic_manipulator_$replace_element (current_sublist, -1, temp, code);
						/* now chain the new list onto the end of the old list. */
						/* By doing things this way,  we don't have to worry about */
						/* copying active modes from one list to another */

	     if (code ^= 0)
	     then return;

	     current_sublist = temp;			/* make the new list the current list. */

	     temp = graphic_manipulator_$replace_element (current_sublist, 1, fudge (1), code);
						/* save the old item we took */
						/* from the old list in it's proper */
						/* position */

	     return;				/* and return with whatever code resulted. */

	end append_element;

     end plot_;
  



		    setup_graphics.pl1              11/18/82  1706.7rew 11/18/82  1625.8      157095


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

setup_graphics: sg: proc;

/* This routine sets up the I/O switches for use with any terminal or offline
   graphics device. */
/* Written July 2, 1973 by C. D. Tavares */
/* Modified 07/13/77 by CDT to include -output_file and use iox_$move_attach */
/* Last modified 01/27/81 by CDT to make -offline work properly */

dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) ext entry (bit (36) aligned, bit (36) aligned),
     old_mask bit (36) aligned;

dcl  absolute_pathname_$add_suffix ext entry (char (*), char (*), char (*), fixed bin (35)),
     suffix char (32);

dcl  terminate_process_ ext entry (char (*), pointer);

dcl  iox_$attach_ioname ext entry (char (*), pointer, char (*), fixed bin (35)),
     iox_$attach_iocb ext entry (pointer, char (*), fixed bin (35)),
     iox_$find_iocb ext entry (char (*), pointer, fixed bin (35)),
     iox_$open ext entry (pointer, fixed bin, bit (1) aligned, fixed bin (35)),
     iox_$look_iocb ext entry (char (*), pointer, fixed bin (35)),
     iox_$move_attach ext entry (pointer, pointer, fixed bin (35)),
    (iox_$close, iox_$detach_iocb) ext entry (pointer, fixed bin (35)),
     iox_$modes ext entry (pointer, char (*), char (*), fixed bin (35)),
     tty_io pointer,
     iox_$user_io ext pointer;

dcl  ioa_$rsnnl ext entry options (variable);

%include iocb;

%include iox_modes;

dcl  myname char (24);

dcl  attach_description char (168) varying,
     based_atd based char (64) varying;

dcl  cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
     ap pointer,
     al fixed bin,
     arg char (al) based (ap);

dcl 1 term_info aligned,
    2 version initial (0),
    2 code fixed bin (35);

dcl  cu_$arg_count ext entry (fixed bin),
     nargs fixed bin;

dcl (com_err_, com_err_$suppress_name) ext entry options (variable);

dcl  gdt_segname char (168),
     error_table_$badopt ext fixed bin (35),
     error_table_$inconsistent ext fixed bin (35),
     error_table_$smallarg ext fixed bin (35),
     error_table_$noarg ext fixed bin (35);

dcl  initted bit (1) aligned internal static initial (""b),
     default_error_handler_$add_finish_handler ext entry (entry (), fixed bin (35));

dcl (null, substr) builtin;

dcl (i, j, this_known_switch) fixed bin;

dcl 1 known_switches (32) static,
    2 switch_name char (32),
    2 switch_ptr pointer,
    2 extra_switch_ptr pointer,
    2 is_online bit (1) aligned;

dcl  number_known_switches fixed bin static initial (0),
     prev_number_known_switches fixed bin;

dcl  using_file bit (1) aligned,
     mode_string char (256),
     file_name char (168),
     have_target bit (1) aligned,
     extra_switch char (32),
     extra_sw_ptr pointer,
     extra_attach_description char (168) varying,
     unique_chars_ ext entry (bit (*)) returns (char (15));

dcl 1 switch_arg_structure (10),
    2 from_name char (32),
    2 from_mode fixed bin;

dcl  total_switches fixed bin;

dcl  online_switch bit (1) aligned,
     revert_online_on_err bit (1) aligned initial (""b);

dcl  to_switch char (32);

	myname = "setup_graphics";

	if ^initted then do;			/* set up for automatic "rg" on process end */
	     initted = "1"b;
	     call default_error_handler_$add_finish_handler (remove_graphics, code);
	     if code ^= 0 then call com_err_ (code, "setup_graphics",
		"^/   Warning - remove_graphics must be called manually when desired. Continuing...");
	end;

	total_switches = 0;				/* initialize state variables */
	prev_number_known_switches = number_known_switches; /* for graceful unwind of attachments if err */
	online_switch = ""b;

	file_name, to_switch, gdt_segname, mode_string = "";
	have_target = ""b;
	using_file = ""b;

	call cu_$arg_count (nargs);			/* get number of arguments */

	if nargs = 0 then do;			/* poor soul needs guidance */
	     call com_err_ (error_table_$noarg, "setup_graphics", "Command syntax is:");
	     call com_err_$suppress_name (0, "setup_graphics",
		"     setup_graphics -table GDT_name [-from sw_1 [mode_1] ... sw_N [mode_N]] [-to switchname] [-online]");
	     return;
	end;

	if nargs = 1 then do;			/* the old, upwards-compatible case */
	     call cu_$arg_ptr (1, ap, al, code);	/* get the gdt name */
	     gdt_segname = arg;
	     from_name (1) = "graphic_output";		/* set defaults for from_names */
	     from_mode (1) = Stream_output;
	     from_name (2) = "graphic_input";
	     from_mode (2) = Stream_input;
	     total_switches = 2;			/* to_switch and online_switch set by default later */
	end;

	else do i = 1 to nargs;			/* process new-style args */

	     call cu_$arg_ptr (i, ap, al, code);	/* get next arg to process */

	     if arg = "-from" | arg = "-fm" then do;	/* from_name arg(s) */

		total_switches = total_switches + 1;	/* add one more switch to array */

		i = i + 1;			/* for getting next arg */
		call cu_$arg_ptr (i, ap, al, code);	/* which should be switch name */
		if code ^= 0 then call err (code, "No switch name after ""-from""."); /* tsk. */

		from_name (total_switches) = arg;	/* remember the switch name */
		from_mode (total_switches) = Stream_input_output; /* assume the dafault mode */

		call cu_$arg_ptr (i+1, ap, al, code);	/* peek to see if there is a mode argument */
		if code = 0 then if substr (arg, 1, 1) ^= "-" then do; /* yes there is */
			do j = lbound (short_iox_modes, 1) to hbound (short_iox_modes, 1) while (short_iox_modes (j) ^= arg);
						/* try to match it */
			end;

			if j > hbound (short_iox_modes, 1) then
			     do j = lbound (iox_modes, 1) to hbound (iox_modes, 1) while (iox_modes (j) ^= arg);
			end;

			if j > hbound (iox_modes, 1) then call err (0, "Unknown mode: " || arg);
						/* no match, bad mode */

			from_mode (total_switches) = j; /* did match, set it */
			i = i + 1;		/* set to skip that arg */
		     end;


	     end;

	     else if arg = "-to" | arg = "-switch" | arg = "-stream" then do; /* next arg is target switch */

		if have_target then call err (0, "Only one ""-output_file"" or ""-to"" control argument allowed.");

		i = i + 1;			/* prepare to snarf next arg */
		call cu_$arg_ptr (i, ap, al, code);
		if code ^= 0 then call err (code, "No switch name after ""-to"""); /* tsk! */

		to_switch = arg;			/* save it */
		have_target = "1"b;
	     end;

	     else if (arg = "-output_file" | arg = "-of" | arg = "-file") then do; /* user wants graphics into a file */

		if have_target then call err (0, "Only one ""-output_file"" or ""-to"" control argument allowed.");

		i = i + 1;
		call cu_$arg_ptr (i, ap, al, code);	/* get the file name */
		if code ^= 0 then call err (code, "No file name after ""-output_file""");

		file_name = arg;
		have_target = "1"b;
		using_file = "1"b;
	     end;

	     else if arg = "-table" | arg = "-tb" then do; /* GDT name specification */

		if gdt_segname ^= "" then call err (0, "The ""-table"" control arg may only be specified once.");

		i = i + 1;			/* prepare to get the name */
		call cu_$arg_ptr (i, ap, al, code);
		if code ^= 0 then call err (code, "No GDT name after ""-table"""); /* tsk!! */

		gdt_segname = arg;			/* save it */
	     end;

	     else if arg = "-online" then online_switch = "1"b;

	     else if arg = "-offline"			/* upwards-compatible, to go away */
	     then if to_switch = ""			/* no "-to" has been given */
		then do;
		     to_switch = "offline_graphics_";
		     have_target = "1"b;
		end;

		else;				/* forget it, "-offline" redundant, not worth the wrist-slap */

	     else if arg = "-modes" then do;		/* mode string for GDT or otherwise */

		if mode_string ^= "" then call err (0, "The ""-modes"" control arg may only be specified once.");

		i = i + 1;			/* prepare to get mode string */
		call cu_$arg_ptr (i, ap, al, code);
		if code ^= 0 then call err (code, "No mode string after ""-modes""."); /* Tsk! */

		mode_string = arg;
	     end;

	     else if i = 1 then gdt_segname = arg;	/* user used implied "-tb" option */

	     else call err (error_table_$badopt, arg);	/* don't want any, charlie. */

	end;

	if online_switch then do;			/* see if anyone else is online */
	     do i = 1 to number_known_switches while (is_online (i) = ""b);
	     end;

	     if i ^> number_known_switches		/* too bad, someone else is */
	     then call err (0, "Only one set of switches may be ""-online"" at a time.");
	end;

	if gdt_segname = "" then
	     if ^using_file then			/* ok to route to a file without a GDT */
		call err (0, "No graphic device table was specified.");

	if total_switches = 0 then do;
	     from_name (1) = "graphic_output";
	     from_name (2) = "graphic_input";
	     from_mode (1) = Stream_output;
	     from_mode (2) = Stream_input;
	     if using_file then total_switches = 1;	/* can't do input and output from same file! */
	     else total_switches = 2;
	end;

	if using_file then do;
	     if total_switches > 1 then call err (0, "Cannot use same file for two I/O switches.");
	     else if online_switch then call err (error_table_$inconsistent, "-output_file and -online");

	     if gdt_segname = "" then suffix = "graphics"; /* user putting MSGC into a file */
	     else suffix = gdt_segname;		/* user putting device-dependent code into a file */
	     call absolute_pathname_$add_suffix ((file_name), suffix, file_name, code);
	     if code ^= 0 then call err (code, rtrim (file_name, " ") || "." || suffix);
	end;

	if ^have_target then do;
	     call remove_graphics;
	     to_switch = "tty_i/o";
	     online_switch = "1"b;
	     have_target = "1"b;
	end;

	extra_switch = "";
	extra_sw_ptr = null;

	if using_file then do;
	     call ioa_$rsnnl ("vfile_ ^a", attach_description, 0, file_name);
	     if gdt_segname ^= "" then do;		/* has to be an extra switch in the middle */
		extra_switch = "sg." || unique_chars_ (""b);
		extra_attach_description = attach_description;
		call iox_$find_iocb (extra_switch, extra_sw_ptr, code);
		if code ^= 0 then call err (code, "Finding iocb of extra switch");
		call ioa_$rsnnl ("graphic_dim_ ^a graphic ^a", attach_description, 0, extra_switch, gdt_segname);
	     end;
	end;
	else call ioa_$rsnnl ("graphic_dim_ ^a graphic ^a", attach_description, 0, to_switch, gdt_segname);
						/* set up the master description */

	do i = 1 to total_switches;			/* process each -from switch given */

	     do this_known_switch = 1 to number_known_switches while (switch_name (this_known_switch) ^= from_name (i));
	     end;

	     if this_known_switch ^> number_known_switches then call remove_one_switch (this_known_switch, ""b);
						/* this switch already known, must be detached */

	     if this_known_switch > number_known_switches then do;
						/* switch was not known, add it to list */
		switch_ptr (number_known_switches+1) = null; /* make sure no window for attach unwinding code */
		number_known_switches = number_known_switches + 1;
		switch_name (number_known_switches) = from_name (i);
		is_online (number_known_switches) = online_switch;
		extra_switch_ptr (number_known_switches) = extra_sw_ptr;
	     end;

	     call iox_$attach_ioname (from_name (i), switch_ptr (this_known_switch), (attach_description), code);
						/* attach the switchname */
	     if code ^= 0 then call err (code, rtrim (from_name (i), " ") || " " || gdt_segname);
						/* however, we don't open the switch before all switches are attached properly. */
						/* This allows GDT open and close entries to specify some chars to be output. */
	end;

	if online_switch then do;			/* fiddle with user_i/o */
	     call iox_$find_iocb (to_switch, tty_io, code);
	     if code ^= 0 then call err (code, "Finding iocb of " || to_switch);

	     call ioa_$rsnnl ("graphic_dim_ ^a ^graphic", attach_description, 0, to_switch);

	     call hcs_$set_ips_mask (""b, old_mask);

	     call iox_$move_attach (iox_$user_io, tty_io, code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

/* now make user_i/o go thru our dim */
	     call iox_$attach_iocb (iox_$user_io, (attach_description), code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

	     call iox_$open (iox_$user_io, Stream_input_output, ""b, code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

	     call hcs_$reset_ips_mask (old_mask, ""b);
	     revert_online_on_err = "1"b;		/* hedge our bets */
	end;					/* all done hacking. */

	else if extra_switch ^= "" then do;
	     call iox_$attach_iocb (extra_sw_ptr, (extra_attach_description), code);
	     if code ^= 0 then call err (code, "Attaching extra switch");

	     call iox_$open (extra_sw_ptr, Stream_output, ""b, code);
	     if code ^= 0 then call err (code, "Opening extra switch");
	end;

	do i = 1 to total_switches;			/* now that all switches attached, open them */

	     do this_known_switch = 1 to number_known_switches while (switch_name (this_known_switch) ^= from_name (i));
	     end;

	     call iox_$open (switch_ptr (this_known_switch), from_mode (i), ""b, code);
						/* open the switch */
	     if code ^= 0 then call err (code, from_name (i));

	     if mode_string ^= "" then
		call iox_$modes (switch_ptr (this_known_switch), mode_string, "", code);
	     if code ^= 0 then call err (code, rtrim (mode_string, " ") || " for " || from_name (i));

	end;

	return;

remove_graphics: rg: entry;

dcl  were_any_online bit (1) aligned;

	myname = "remove_graphics";
	prev_number_known_switches = number_known_switches; /* so "err" doesn't try to unwind too much */

	call cu_$arg_count (nargs);
	were_any_online = are_any_online ();

	if nargs = 0 then do;
rg_all:	     do i = 1 to number_known_switches;
		call remove_one_switch (i, "1"b);
	     end;

	     number_known_switches = 0;
	end;

	else do i = 1 to nargs;

	     call cu_$arg_ptr (i, ap, al, code);

	     if nargs = 1 then do;
		if arg = "-a" | arg = "-all" then goto rg_all;
	     end;

	     do j = 1 to number_known_switches while (arg ^= switch_name (j));
	     end;

	     if j > number_known_switches then call com_err_ (0, "remove_graphics", """^a"" is not a graphic switch.",
		arg);

	     else do;
		call remove_one_switch (j, "1"b);

		do j = j to number_known_switches - 1;
		     unspec (known_switches (j)) = unspec (known_switches (j+1));
		end;

		number_known_switches = number_known_switches - 1;
	     end;

	end;

	if were_any_online ^= are_any_online () then call remove_online_switch;

remove_online_switch: proc;

	     call iox_$look_iocb ("tty_i/o", tty_io, code);
	     if code ^= 0 then call err (code, "tty_i/o");

	     call hcs_$set_ips_mask (""b, old_mask);

	     call iox_$close (iox_$user_io, code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

	     call iox_$detach_iocb (iox_$user_io, code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

	     call iox_$move_attach (tty_io, iox_$user_io, code);
	     if code ^= 0 then call terminate_process_ ("fatal_error", addr (term_info));

	     call hcs_$reset_ips_mask (old_mask, ""b);
	end remove_online_switch;

	return;

remove_one_switch: proc (which, essential);

dcl  which fixed bin parameter,
     essential bit (1) aligned parameter;		/* need we complain if it doesn't work? */

	     call iox_$close (switch_ptr (which), code);
	     if essential then if code ^= 0 then call err (code, switch_name (which));

	     call iox_$detach_iocb (switch_ptr (which), code);
	     if essential then if code ^= 0 then call err (code, switch_name (which));

	     if extra_switch_ptr (which) ^= null then do;
		call iox_$close (extra_switch_ptr (which), code);
		if essential then if code ^= 0 then call err (code, switch_name (which));

		call iox_$detach_iocb (extra_switch_ptr (which), code);
		if essential then if code ^= 0 then call err (code, switch_name (which));
	     end;
	     return;
	end remove_one_switch;

are_any_online: proc returns (bit (1) aligned);

dcl  i fixed bin;

	     do i = 1 to number_known_switches;
		if is_online (i) then return ("1"b);
	     end;

	     return (""b);

	end are_any_online;


err:	proc (code, reason);

dcl  code fixed bin (35),
     reason char (*);

dcl  i fixed bin;

	     call com_err_ (code, myname, reason);

/* try to gracefully unwind half-baked attachments */

	     do i = number_known_switches to prev_number_known_switches + 1 by -1;
		if switch_ptr (i) ^= null then call remove_one_switch (i, ""b);
	     end;

	     if revert_online_on_err then call remove_online_switch;

	     number_known_switches = prev_number_known_switches;
	     goto returner;
	end err;

returner:	return;
     end setup_graphics;


		    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