


		    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);