compile_gct.pl1                 11/18/82  1706.6rew 11/18/82  1627.7      156150



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


compile_gct: proc;

/* This routine will compile a graphic character table. */
/* Hacked out of compile_gdt on 01/19/78 by C. D. Tavares */

dcl  cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
     cu_$arg_count ext entry returns (fixed bin (35)),
     ap pointer,
     al fixed bin,
     arg based (ap) char (al),
     com_err_ ext entry options (variable),
     code fixed bin (35);

dcl  error_table_$translation_failed ext fixed bin (35),
     error_table_$inconsistent ext fixed bin (35),
     error_table_$badopt ext fixed bin (35);

dcl  expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     suffixed_name_$new_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     get_wdir_ ext entry returns (char (168)),
     dirname char (168),
     ename char (33) initial (""),
     object_ename char (32);

dcl  tssi_$get_segment entry (char (*), char (*), pointer, pointer, fixed bin (35)),
     tssi_$finish_segment ext entry (pointer, fixed bin, bit (36) aligned, pointer, fixed bin (35)),
     tssi_$clean_up_segment ext entry (pointer),
     cleanup condition;

dcl  parse_file_$parse_file_init_name ext entry (char (*), char (*), pointer, fixed bin (35)),
     parse_file_$parse_file_cur_line ext entry (fixed bin, fixed bin),
     parse_file_$parse_file_unset_break ext entry (char (*));

dcl  acl_ptr pointer initial (null),
    (null, hbound, substr, length, before, collate, divide, max, index) builtin;

dcl  outdx fixed bin,
     segp pointer,
    (i, j, k) fixed bin,
     char_number fixed bin,
     char_name char (8) varying,
     found bit (1) aligned,
     vec_sw bit (1) aligned,
     metric_char char (1),
     metric_dimensions (3) fixed bin,
     margin (2) fixed bin,
     coords (2) fixed bin;

%include gct_char_names;

dcl (cur_x, cur_y) fixed bin;

dcl 1 invis_struc aligned,
    2 (min_x, max_x, min_y, max_y) fixed bin;

dcl 1 vis_struc like invis_struc aligned;

dcl (character_name, character_type, main_proc) char (32) aligned varying initial (""),
     token char (32) aligned varying,
     explanation char (80) varying aligned initial (""),
     default_flags char (168) aligned varying initial (""),
     temp_string char (400) varying;

dcl  title_string char (100) aligned varying initial
    (""" Created by:  compile_gct, Version of 17 February 1978.
") static options (constant),

     header_string char (200) aligned varying initial
    ("	name	^a^/
	segdef	char_ptr
	segdef	character_sizes^/
	use	char_structures^/
character_sizes:
^3(	dec	^d
^)") static options (constant),

     finishing_string char (40) static options (constant) varying initial ("
	include	gct_trap_proc

	end
");


dcl (SPACE initial (" "),
     TAB initial ("	"),
     UNDERSCORE initial ("_"),
     COLON initial (":"),
     CR initial ("
"),
     BS initial (""),
     NL initial ("
")) char (1) static options (constant);

dcl  sys_info$max_seg_size ext fixed bin (35),
     max_string_size fixed bin (21) initial (sys_info$max_seg_size * 4);

dcl 1 based_char_description aligned based (cp),
    2 next_p pointer,
    2 char_number fixed bin,
    2 header aligned,
      3 (n_elements,
     width,
     left_margin,
     right_margin) fixed bin (8) unaligned,
    2 word_align aligned,
      3 move_type bit (nelem refer (based_char_description.n_elements)) unaligned,
    2 coord_pairs (nelem refer (based_char_description.n_elements)) unaligned,
      3 (x,
     y) fixed bin (8) unaligned;

dcl (cp, tp, last_p, start_p) pointer;

dcl (gct_charbits, tempbits, desirable_chars) bit (128) aligned,
     special_bits bit (128) aligned internal static options (constant) initial
    ("000000001110010000000000000000001000000000000000000000000000000000000000000000000000000000000001"b);

dcl  movetype bit (144) aligned,
     nelem fixed bin,
    (x, y) fixed bin dimension (144);

dcl (ioa_$ioa_stream, ioa_$rsnp, ioa_, ioa_$rsnpnnl) ext entry options (variable),
     pf_ptr pointer initial (null),
     pf_string char (max_string_size) aligned based (pf_ptr);

dcl  delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
    (list_switch, no_assembly) bit (1) aligned,
     alm ext entry options (variable);



	start_p = null;

	call ioa_ ("COMPILE_GCT");			/* crow */
	call cu_$arg_ptr (1, ap, al, code);		/* get name of input file */
	if code ^= 0 then do;			/* not there */
	     call com_err_ (code, "compile_gct",	/* give advice */
		"Usage is 'compile_gct segname' where segname.gct is a graphic character table.");
returner:
	     call clean_up;				/* close out output file */
	     return;
	end;

	call expand_pathname_$add_suffix (arg, "gct", dirname, ename, code);
	if code ^= 0 then call error ((arg), ""b);	/* couldn't */

	list_switch, no_assembly = ""b;

	do i = 2 to cu_$arg_count ();
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (arg, 1, 1) ^= "-" then goto badopt;
	     if arg = "-check" | arg = "-ck" then no_assembly = "1"b;
	     else if arg = "-list" | arg = "-ls" then list_switch = "1"b;
	     else do;
badopt:		call com_err_ (error_table_$badopt, "compile_gct", "");
		goto returner;
	     end;
	end;

	if list_switch & no_assembly then do;
	     call com_err_ (error_table_$inconsistent, "compile_gct", "-check, -list");
	     goto returner;
	end;

	call suffixed_name_$new_suffix (ename, "gct", "alm", object_ename, code); /* make new name */
	if code ^= 0 then call error ((object_ename), ""b);

	on cleanup call clean_up;

	call parse_file_$parse_file_init_name (dirname, ename, pf_ptr, code); /* initiate parsing program */
	if code ^= 0 then call error ((ename), ""b);

	call tssi_$get_segment (get_wdir_ (), (object_ename), segp, acl_ptr, code); /* create output segment */
	if code ^= 0 then call error ((object_ename), ""b);

	call parse_file_$parse_file_unset_break ("_-.");	/* we want "_-." to be valid in a token */

	gct_charbits = special_bits;

	metric_char = "O";				/* good default */
	metric_dimensions (*) = -1;

	outdx = 1;				/* output string index */
	call get_token;

	if token = "metric" then do;
	     call get_token;
	     metric_char = token;

	     do char_number = 1 to hbound (gct_charnames, 1) while (gct_charnames (char_number) ^= token);
	     end;

	     if char_number > hbound (gct_charnames, 1) then call error ("Unrecognized character: " || token, "1"b);

	     call get_token;
	end;

	do while (token ^= " EOF ");

	     do char_number = 1 to hbound (gct_charnames, 1) while (gct_charnames (char_number) ^= token);
	     end;

	     if char_number > hbound (gct_charnames, 1) then call error ("Unrecognized character: " || token, "1"b);

	     if substr (gct_charbits, char_number, 1) then call error ("Character already defined: " || token, "1"b);

	     substr (gct_charbits, char_number, 1) = "1"b; /* mark character as defined */

	     call get_break (COLON, crump);

	     char_name = token;
	     margin = -1;
	     nelem = 0;
	     movetype = ""b;

	     call get_token;

	     cur_x, cur_y, vis_struc, invis_struc = 0;

	     do i = 1 by 1 while (token ^= "end");
		if token = "shift" then vec_sw = "0"b;
		else if token = "vector" then do;
		     substr (movetype, i, 1) = "1"b;
		     vec_sw = "1"b;
		     call maxmin (vis_struc);
		end;
		else call error ("Neither shift nor vector:  " || token, "1"b);
		coords = getvals ();
		cur_x = cur_x + coords (1);
		cur_y = cur_y + coords (2);
		call maxmin (invis_struc);
		if vec_sw then call maxmin (vis_struc);
		if substr (movetype, 1, i) = "0"b then do; /* shifts so far, nothing visible yet */
		     vis_struc.min_x, vis_struc.max_x = cur_x;
		     vis_struc.min_y, vis_struc.max_y = cur_y;
		end;
		nelem = nelem + 1;
		x (nelem) = coords (1);
		y (nelem) = coords (2);

		call get_token;
	     end;

maxmin:	     proc (struc);

dcl 1 struc like invis_struc aligned parameter;

		if cur_x < struc.min_x then struc.min_x = cur_x;
		if cur_x > struc.max_x then struc.max_x = cur_x;
		if cur_y < struc.min_y then struc.min_y = cur_y;
		if cur_y > struc.max_y then struc.max_y = cur_y;
		return;
	     end maxmin;

	     invis_struc.min_x = max (invis_struc.min_x, 0); /* fix boundary conditions for */
	     invis_struc.max_x = min (invis_struc.max_x, cur_x); /* chars with "negative margins" */

	     if char_name = metric_char then do;
		metric_dimensions (1) = vis_struc.max_y - vis_struc.min_y;
		metric_dimensions (2) = invis_struc.max_x - invis_struc.min_x;
		metric_dimensions (3) = invis_struc.min_x - vis_struc.min_x + vis_struc.max_x - invis_struc.max_x;
						/* this is the negative of the sum of the margins */
	     end;

	     if cur_x < 0 then call ioa_ ("WARNING: Character ""^a"" has net X offset of ^d.", char_name, cur_x);
	     if cur_y ^= 0 then call ioa_ ("WARNING: Character ""^a"" has net Y offset of ^d.", char_name, cur_y);

	     allocate based_char_description;
	     based_char_description.char_number = char_number;
	     based_char_description.width = invis_struc.max_x - invis_struc.min_x;
	     based_char_description.left_margin = vis_struc.min_x - invis_struc.min_x;
	     based_char_description.right_margin = invis_struc.max_x - vis_struc.max_x;
	     based_char_description.move_type = movetype;

	     do i = 1 to nelem;
		based_char_description.x (i) = x (i);
		based_char_description.y (i) = y (i);
	     end;

	     last_p = null;
	     found = ""b;

	     do tp = start_p repeat (tp -> based_char_description.next_p)
		     while (tp ^= null & ^found);
		if tp -> based_char_description.char_number < char_number then last_p = tp;
		else found = "1"b;
	     end;

	     if last_p = null then do;
		cp -> based_char_description.next_p = start_p;
		start_p = cp;
	     end;
	     else do;
		cp -> based_char_description.next_p = last_p -> based_char_description.next_p;
		last_p -> based_char_description.next_p = cp;
	     end;


	     call get_token;
	end;

	if metric_dimensions (1) = -1 then call error ("Metric character not found: " || metric_char, ""b);

	desirable_chars = ""b;
	substr (desirable_chars, 33, 126 - 33 + 1) = copy ("1"b, 128);
	tempbits = ^gct_charbits & desirable_chars;
	if tempbits then do;
	     temp_string = "";
	     do while (tempbits);
		i = index (tempbits, "1"b);
		if length (temp_string) ^= 0 then temp_string = temp_string || ", ";
		temp_string = temp_string || gct_charnames (i);
		substr (tempbits, i, 1) = "0"b;
	     end;

	     call ioa_ ("Warning:  Definitions were not found for the following characters:");
	     call ioa_ (temp_string);
	end;

	call put_out (title_string);

	call ioa_$rsnpnnl (header_string, temp_string, 0, before (ename, ".gct"), metric_dimensions (*));
	call put_out (temp_string);

	do cp = start_p repeat (cp -> based_char_description.next_p) while (cp ^= null);

	     call ioa_$rsnp ("^/^a:", temp_string, 0, gct_charnames (cp -> based_char_description.char_number));
	     call put_out (temp_string);

	     call ioa_$rsnp ("^-vfd^-9/^d,9/^d,9/^d,9/^d", temp_string, 0,
		cp -> based_char_description.n_elements,
		cp -> based_char_description.width,
		cp -> based_char_description.left_margin,
		cp -> based_char_description.right_margin);

	     call put_out (temp_string);

	     do i = 1 to cp -> based_char_description.n_elements by 36;
		call ioa_$rsnp ("^-oct^-^.3b", temp_string, 0, substr (cp -> based_char_description.move_type, i, 36));
		call put_out (temp_string);
	     end;

	     do i = 1 to cp -> based_char_description.n_elements by 2;
		j = i + 1;
		call ioa_$rsnpnnl ("^-vfd^-9/^d,9/^d", temp_string, 0,
		     cp -> based_char_description.x (i),
		     cp -> based_char_description.y (i));
		if j ^> cp -> based_char_description.n_elements then
		     call ioa_$rsnpnnl ("^a,9/^d,9/^d", temp_string, 0, (temp_string),
		     cp -> based_char_description.x (j),
		     cp -> based_char_description.y (j));

		k = max (divide (34 - length (temp_string), 10, 17, 0) + 1, 0);

		call ioa_$rsnpnnl ("^a^v-"" ^[vector^;shift ^] ^3d ^3d", temp_string, 0, (temp_string), k,
		     substr (cp -> based_char_description.move_type, i, 1),
		     cp -> based_char_description.x (i),
		     cp -> based_char_description.y (i));
		if j ^> cp -> based_char_description.n_elements then
		     call ioa_$rsnpnnl ("^a, ^[vector^;shift ^] ^3d ^3d", temp_string, 0, (temp_string),
		     substr (cp -> based_char_description.move_type, j, 1),
		     cp -> based_char_description.x (j),
		     cp -> based_char_description.y (j));

		temp_string = temp_string || NL;
		call put_out (temp_string);
	     end;

	     call put_out ((NL));
	end;

	do j = 0 to -1 by -1;
	     if j = 0 then tempbits = ^gct_charbits;
	     else tempbits = special_bits;

	     if tempbits then do;
		do while (tempbits);
		     i = index (tempbits, "1"b);
		     call ioa_$rsnp ("^a:^-null", temp_string, 0, gct_charnames (i));
		     call put_out (temp_string);
		     substr (tempbits, i, 1) = "0"b;
		end;

		call ioa_$rsnp ("^-vfd^-9/^d,9/0,9/0,9/0^/", temp_string, 0, j);
		call put_out (temp_string);
	     end;
	end;

	call put_out (finishing_string);

	call tssi_$finish_segment (segp, outdx * 9 - 9, "1011"b, acl_ptr, code); /* shine it up */
	acl_ptr = null;
	revert cleanup;
	if code ^= 0 then call error ((ename), ""b);	/* too bad. after all that. */

	if no_assembly then goto returner;

	if list_switch then call alm (object_ename, "-list");
	else call alm (object_ename);

	call delete_$path (get_wdir_ (), object_ename, "100111"b, "compile_gct", code);
	if code ^= 0 then call error ("Cannot delete " || object_ename, ""b);

	call clean_up;
	return;

crump:						/* here is where errors go */
	call error (explanation, "1"b);		/* confess */


clean_up:	proc;

	     if acl_ptr ^= null then call tssi_$clean_up_segment (acl_ptr);

	     do cp = start_p repeat (tp) while (cp ^= null);
		tp = cp -> based_char_description.next_p;
		free cp -> based_char_description;
	     end;

	end;


error:	proc (explanation, print_line);		/* the snitcher */

dcl  explanation char (*) varying aligned parameter,
     print_line bit (1) aligned parameter;

dcl (ci, cc) fixed bin;

	     call com_err_ (code, "compile_gct", explanation); /* report the error */

	     if print_line then do;			/* print out the source line of input file */
		call parse_file_$parse_file_cur_line (ci, cc);
		call ioa_$ioa_stream ("error_output", "^-SOURCE: ^a", substr (pf_string, ci, cc));
	     end;
	     call com_err_ (error_table_$translation_failed, "compile_gct", ""); /* one chance is all we give */
	     goto returner;
	end;


get_token: proc;					/* gets tokens from input file */

dcl  parse_file_$parse_file_ptr ext entry (pointer, fixed bin, fixed bin, fixed bin),
     tokenp pointer,
     b_token char (count) based (tokenp),
     count fixed bin,
     break fixed bin,
     eof fixed bin;

loop:
	     call parse_file_$parse_file_ptr (tokenp, count, break, eof); /* get a token */

	     if eof > 0 then token = " EOF ";

	     else do;
		token = b_token;
		if break > 0 then if token = SPACE then goto loop; /* harmless */
		     else if token = TAB then goto loop; /* harmless */
		     else if token = NL then goto loop; /* harmless */
		     else call error ("Illegal character " || token || " encountered", "1"b); /* yell */
	     end;

	     return;

get_break:     entry (char, errlab);			/* gets break tokens, goes to errlab if fails */

dcl  char char (1),
     errlab label;

bloop:
	     call parse_file_$parse_file_ptr (tokenp, count, break, eof); /* get a token */

	     if eof > 0 then call error ("Unexpected end of file encountered", ""b); /* oops */

	     if break > 0 then if b_token = SPACE then goto bloop; /* harmless */
		else if b_token = TAB then goto bloop;	/* harmless */
		else if b_token = NL then goto bloop;	/* harmless */
		else if b_token = char then return;	/* it's the one we wanted */
		else do;				/* it's not */
bad_break:
		     explanation = "Illegal token " || b_token || " found instead of expected token " || char;
		     goto errlab;			/* we don't call error, because */
						/* it may not be an error condition. */
		end;

	     else goto bad_break;			/* wasn't a break token */
	     return;


	end get_token;

getvals:	proc returns (fixed bin dimension (2));

dcl  temp (2) fixed bin,
     i fixed bin,
     cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin);

	     do i = 1 to 2;
		call get_token;
		temp (i) = cv_dec_check_ ((token), code);
		if code ^= 0 then call error ("Non numeric token in numeric position:  " || token, "1"b);
	     end;

	     return (temp);
	end getvals;

put_out:	proc (string);				/* writes string into output file */

dcl  string char (*) varying;

dcl  outstring char (65536) based (segp);

	     substr (outstring, outdx, length (string)) = string; /* copy into output file */
	     outdx = outdx + length (string);

	     return;
	end;

     end compile_gct;




		    compile_gdt.pl1                 11/18/82  1706.6rew 11/18/82  1627.8      163944



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


compile_gdt: cg: proc;

/* This routine will compile a graphic device table. */
/* Written June 30, 1973 by C. D. Tavares */
/* Last modified 03/26/75 by CDT to add open and close keywords */

dcl  cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin),
     cu_$arg_count ext entry returns (fixed bin),
     ap pointer,
     al fixed bin,
     arg based (ap) char (al),
     com_err_ ext entry options (variable),
     code fixed bin;

dcl  error_table_$translation_failed ext fixed bin (35),
     error_table_$inconsistent ext fixed bin (35),
     error_table_$badopt ext fixed bin (35);

dcl  expand_path_ ext entry (pointer, fixed bin, pointer, pointer, fixed bin),
     suffixed_name_$make ext entry (char (*), char (*), char (*), fixed bin),
     suffixed_name_$new_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin),
     get_wdir_ ext entry returns (char (168)),
     dirname char (168),
     ename char (33) initial (""),
     object_ename char (32);

dcl  tssi_$get_segment entry (char (*), char (*), pointer, pointer, fixed bin),
     tssi_$finish_segment ext entry (pointer, fixed bin, bit (36) aligned, pointer, fixed bin),
     tssi_$clean_up_segment ext entry (pointer),
     cleanup condition;

dcl  parse_file_$parse_file_init_name ext entry (char (*), char (*), pointer, fixed bin),
     parse_file_$parse_file_cur_line ext entry (fixed bin, fixed bin),
     parse_file_$parse_file_unset_break ext entry (char (*));

dcl  acl_ptr pointer initial (null),
    (null, hbound, substr, length) builtin;

dcl  outdx fixed bin,
     segp pointer,
    (i, j) fixed bin,
     semicolon char (1) static options (constant) initial (";"),
     colon char (1) static options (constant) initial (":"),
     comma char (1) static options (constant) initial (",");

%include graphic_device_table;

dcl  keywords (32 : 70) static options (constant) char (12) initial
    ("not used",
     "not used",
     "not used",
     "not used",
     "pause",
     "reference",
     "increment",
     "alter",
     "node_begin",
     "node_end",
     "control",
     "display",
     "query",
     "erase",
     "synchronize",
     "delete",
     "setposition",
     "setpoint",
     "vector",
     "shift",
     "point",
     "scaling",
     "rotation",
     "clipping",
     "intensity",
     "line_type",
     "blinking",
     "sensitivity",
     "color",
     "symbol",
     "text",
     "data",
     "input",
     "graphic_mode",
     "text_mode",
     "expansion",
     "open",
     "close",
     "modes");

dcl  major_keywords (7) char (17) static options (constant) initial
    ("Name",
     "Type",
     "Default",
     "Procedure",
     "Character_size",
     "Message_size",
     "Points_per_inch");

dcl  values (6) char (12) static options (constant) initial
    ("pass",
     "expand",
     "call",
     "ignore",
     "error",
     "flush");

dcl (device_name, device_type, main_proc) char (32) aligned varying initial (""),
     token char (32) aligned varying,
     explanation char (80) varying aligned initial (""),
     default_flags char (168) aligned varying initial (""),
     temp_string char (400) varying;

dcl  title_string char (100) aligned varying initial
    (""" Created by:  compile_gdt, Version of 22 December 1977.
") static options (constant),

     header_string char (200) aligned varying initial
    ("
	name	^a_table

	segdef	table_start

table_start:
	dec	^d		""version number
	aci	""^32a""
	aci	""^a""
	dec	^e,^e,^e	""character parameters
	dec	^d		""message size
	dec	^a		""points per inch
	bss	.pad,^d
") static options (constant),

     flag_string char (40) varying aligned static options (constant) initial
    ("	arg	^32a "" ^a"),

     transfer_header char (100) static options (constant) varying aligned initial
    ("
	entry	gdt_proc

gdt_proc:
	ldq	ap|2,*
	sbq	31,dl
	tra	*,ql
"),

     transfer_string char (40) static options (constant) varying aligned initial
    ("	tra	<^30a	""^a"),
     finishing_string char (8) static options (constant) varying initial ("
	end
"),

     NL char (1) static options (constant) initial ("
");

dcl  charsizes float bin dimension (3) initial ((3) -1),
     sys_info$max_seg_size ext fixed bin (35),
     max_string_size fixed bin (21) initial (sys_info$max_seg_size * 4),
     message_size fixed bin (21) initial (sys_info$max_seg_size * 4),
     points_per_inch float bin (63) initial (-1e0),
     ppi_string char (32);

dcl 1 effector_table (32 : hbound (keywords, 1)) aligned,
    2 flags char (168) aligned varying,
    2 proc_name char (32) aligned varying,
    2 entry_name char (32) aligned varying;

dcl (ioa_$ioa_stream, ioa_$rs, ioa_, ioa_$rsnnl) ext entry options (variable),
     pf_ptr pointer initial (null),
     pf_string char (max_string_size) aligned based (pf_ptr);

dcl  delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin),
    (list_switch, no_assembly) bit (1) aligned,
     bitstring bit (36) aligned,
     alm ext entry options (variable);

dcl  conversion condition,
    (binary, float) builtin;



	call ioa_ ("COMPILE_GDT");			/* crow */
	call cu_$arg_ptr (1, ap, al, code);		/* get name of input file */
	if code ^= 0 then do;			/* not there */
	     call com_err_ (code, "compile_gdt",	/* give advice */
		"Usage is 'compile_gdt segname' where segname.gdt is a graphic device table.");
returner:
	     call clean_up;				/* close out output file */
	     return;
	end;

	call expand_path_ (ap, al, addr (dirname), addr (ename), code); /* get full pathname of input file */
	if code ^= 0 then call error ((arg), ""b);	/* couldn't */

	call suffixed_name_$make ((ename), "gdt", ename, code);
	if code ^= 0 then call error ((ename), ""b);

	list_switch, no_assembly = ""b;

	do i = 2 to cu_$arg_count ();
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (arg, 1, 1) ^= "-" then goto badopt;
	     if arg = "-check" | arg = "-ck" then no_assembly = "1"b;
	     else if arg = "-list" | arg = "-ls" then list_switch = "1"b;
	     else do;
badopt:		call com_err_ (error_table_$badopt, "compile_gdt", "");
		goto returner;
	     end;
	end;

	if list_switch & no_assembly then do;
	     call com_err_ (error_table_$inconsistent, "compile_gdt", "-check, -list");
	     goto returner;
	end;

	call suffixed_name_$new_suffix (ename, "gdt", "alm", object_ename, code); /* make new name */
	if code ^= 0 then call error ((object_ename), ""b);

	on cleanup call clean_up;

	call parse_file_$parse_file_init_name (dirname, ename, pf_ptr, code); /* initiate parsing program */
	if code ^= 0 then call error ((ename), ""b);

	call tssi_$get_segment (get_wdir_ (), (object_ename), segp, acl_ptr, code); /* create output segment */
	if code ^= 0 then call error ((object_ename), ""b);

	call parse_file_$parse_file_unset_break ("_.");	/* we want "_." to be valid in a token */

	outdx = 1;				/* output string index */
	do while ("1"b);				/* "forever" until we encounter non-major keywords */

	     call get_token;			/* get a keyword */

	     do i = 1 to hbound (major_keywords, 1) while (major_keywords (i) ^= token); /* look it up */
	     end;

	     if i > hbound (major_keywords, 1) then goto end_major_keywords; /* not a major keyword, assume minor keyword */

	     call get_break (colon, crump);

	     goto major_label (i);			/* process individually */

major_label (1):					/* Name */
	     if length (device_name) ^= 0 then call error ("Multiple 'Name' statements encountered.", "1"b);

	     call get_token;			/* get the device name */

	     device_name = token;
	     call get_break (semicolon, crump);		/* get expected semicolon */

	     goto major_loop_end;

major_label (2):					/* Type */

	     if length (device_type) ^= 0 then call error ("Multiple 'Type' statements encountered.", "1"b);

	     call get_token;			/* get device type */

	     device_type = token;
	     call get_break (semicolon, crump);

	     goto major_loop_end;

major_label (3):					/* Default */
	     if default_flags ^= "" then call error ("Multiple 'Default' statements encountered.", "1"b);

more_defaults:
	     call get_token;			/* get a default */

	     do i = 1 to hbound (values, 1) while (values (i) ^= token); /* find it */
	     end;

	     if i > hbound (values, 1) then call error ("Unrecognized default '" || token || "'.", "1"b);

	     if token = "call" then call error ("The 'call' keyword is not allowed as a default.", "1"b);
						/* No real reason, if it is useful, we may take */
						/* this restriction out. */

	     if length (default_flags) > 0 then default_flags = default_flags || "+";
	     default_flags = default_flags || token;

	     call get_break (semicolon, more_defaults);	/* if next break not semi, assume it is comma. */
	     goto major_loop_end;

major_label (4):
	     if length (main_proc) > 0 then call error ("Multiple 'Procedure' statements encountered.", "1"b);

	     call get_token;
	     main_proc = token;			/* get procedure name */

	     call get_break (semicolon, crump);
	     goto major_loop_end;

major_label (5):
	     if charsizes (1) ^= -1 then call error ("Multiple 'Character_size' statements encountered.", "1"b);

	     on conversion call error ("Non-numeric character in Character_size specification.", "1"b);

	     do i = 1 to 3;
		call get_token;
		charsizes (i) = float (token);
		if i = 3 then call get_break (semicolon, crump);
		else call get_break (comma, crump);
	     end;

	     revert conversion;
	     goto major_loop_end;

major_label (6):
	     if message_size ^= sys_info$max_seg_size * 4
	     then call error ("Multiple 'Message_size' statements encountered.", "1"b);

	     on conversion call error ("Non-numeric character in message size specification.", "1"b);

	     call get_token;
	     message_size = binary (token);

	     call get_break (semicolon, crump);

	     revert conversion;
	     goto major_loop_end;

major_label (7):					/* points per inch */
	     if points_per_inch ^= -1 then call error ("Multiple 'Points_per_inch' statements encountered.", "1"b);

	     on conversion call error ("Non-numeric character in Points_per_inch statement.", "1"b);

	     call get_token;
	     points_per_inch = float (token);

	     call get_break (semicolon, crump);

	     revert conversion;
	     goto major_loop_end;

major_loop_end:
	end;

end_major_keywords:
	if length (device_name) = 0 then call error ("Graphic device table contains no 'Name' statement.", ""b);

	if length (device_type) = 0 then call error ("Graphic device table contains no 'Type' statement.", ""b);

	if length (main_proc) = 0 then main_proc = device_name || "_util_"; /* again no real reason -- */
						/* a really intelligent graphics processor needs no */
						/* supporting procedure! */

	if charsizes (1) = -1 then call ioa_ ("Warning:  no 'Character_size' statement encountered.");
	if points_per_inch = -1 then call ioa_ ("Warning:  no 'Points_per_inch' statement encountered.");

/* Begin to create source segment for ALM assembler. */

	call put_out ((title_string), length (title_string));

	call ioa_$rsnnl ("^e", ppi_string, 0, points_per_inch);
	ppi_string = translate (ppi_string, "d", "e");	/* make exponent signify "double precision" */

	call ioa_$rs (header_string, temp_string, i, device_name, gdt_version_2,
	     device_name, substr (device_type, 1, 4), charsizes (1), charsizes (2), charsizes (3),
	     message_size, ppi_string, hbound (null -> graphic_device_table.pad, 1));
						/* if I don't put null there, compiler says */
						/* gdt_pointer referenced & unset! */
						/* output happy header */
	call put_out (temp_string, i);

	do i = 1 to hbound (values, 1);
	     bitstring = ""b;
	     if i > 1 then substr (bitstring, 17+i, 1) = "1"b;
	     j = binary (bitstring, 35);
	     call ioa_$rs ("^w", temp_string, 0, j);
	     call ioa_$rs ("	bool	^a,^a", temp_string, j, values (i), substr (temp_string, 7, 6));
	     call put_out (temp_string, j);
	end;

	call put_out ((NL), 1);

	effector_table (*).flags = default_flags;	/* set up defaults for all effectors */
	effector_table (*).proc_name = "graphic_dim_";	/* default is error */
	effector_table (*).entry_name = "no_entry";	/* error entry */

	do while ("1"b);				/* again "forever" until we see "end" */

	     if token = "end" then do;		/* finish up parse */
		call get_break (semicolon, crump);	/* a parting check on the poor user */
		goto output_info;
	     end;

	     do i = 32 to hbound (keywords, 1) while (keywords (i) ^= token); /* find the token */
	     end;

	     if i > hbound (keywords, 1) then call error ("Unrecognized keyword '" || token || "'.", "1"b);

	     call get_break (colon, crump);

	     effector_table (i).flags = "";		/* erase defaults, use only ones specified */
more_values:
	     call get_token;			/* get an action for this effector */

	     do j = 1 to hbound (values, 1) while (values (j) ^= token); /* look it up */
	     end;

	     if j > hbound (values, 1) then call error ("Unrecognized value '" || token || "'.", "1"b);

	     if length (effector_table (i).flags) > 0 then
		effector_table (i).flags = effector_table (i).flags || "+";
	     effector_table.flags (i) = effector_table.flags (i) || token;

	     if token = "call" then do;		/* one more token expected before comma or semi */
		call get_token;
		effector_table (i).proc_name = main_proc; /* construct auxiliary procedure name */
		effector_table (i).entry_name = token;
	     end;

	     call get_break (semicolon, more_values);	/* if not semi, assume comma */
	     call get_token;			/* prepare for next looparound */

	end;

output_info:
	do i = 32 to hbound (keywords, 1);		/* output all effectors in ALM */
	     if length (effector_table (i).flags) = 0 then effector_table (i).flags = values (1);
	     call ioa_$rs (flag_string, temp_string, j, effector_table (i).flags, keywords (i));
						/* format one flag indicator block */
	     call put_out (temp_string, j);		/* put it out */
	end;

	call ioa_$rs (transfer_header, temp_string, j);
	call put_out (temp_string, j);

	do i = 32 to hbound (keywords, 1);
	     call ioa_$rs (transfer_string, temp_string, j,
		effector_table (i).proc_name || ">|[" || effector_table (i).entry_name || "]", keywords (i));
						/* format one instruction in transfer vector */
	     call put_out (temp_string, j);
	end;

	call put_out (finishing_string, length (finishing_string)); /* cap it off */

	call tssi_$finish_segment (segp, outdx * 9 - 9, "1011"b, acl_ptr, code); /* shine it up */
	revert cleanup;
	if code ^= 0 then call error ((ename), ""b);	/* too bad. after all that. */

	if no_assembly then return;

	if list_switch then call alm (object_ename, "-list");
	else call alm (object_ename);

	call delete_$path (get_wdir_ (), object_ename, "100111"b, "compile_gdt", code);
	if code ^= 0 then call error ("Cannot delete " || object_ename, ""b);

	return;

crump:						/* here is where errors go */
	call error (explanation, "1"b);		/* confess */


clean_up:	proc;

	     if acl_ptr ^= null then call tssi_$clean_up_segment (acl_ptr);

	end;


error:	proc (explanation, print_line);		/* the snitcher */

dcl  explanation char (*) varying aligned parameter,
     print_line bit (1) aligned parameter;

dcl (ci, cc) fixed bin;

	     call com_err_ (code, "compile_gdt", explanation); /* report the error */

	     if print_line then do;			/* print out the source line of input file */
		call parse_file_$parse_file_cur_line (ci, cc);
		call ioa_$ioa_stream ("error_output", "^-SOURCE:  ^a", substr (pf_string, ci, cc));
	     end;
	     call com_err_ (error_table_$translation_failed, "compile_gdt", ""); /* one chance is all we give */
	     goto returner;
	end;


get_token: proc;					/* gets tokens from input file */

dcl  parse_file_$parse_file_ptr ext entry (pointer, fixed bin, fixed bin, fixed bin),
     tokenp pointer,
     b_token char (count) based (tokenp),
     count fixed bin,
     break fixed bin,
     eof fixed bin;

dcl (space initial (" "),
     tab initial ("	"),
     nl initial ("
")) char (1) aligned static options (constant);

loop:
	     call parse_file_$parse_file_ptr (tokenp, count, break, eof); /* get a token */

	     token = b_token;

	     if eof > 0 then call error ("Unexpected end of file encountered", ""b); /* oops */

	     if break > 0 then if token = space then goto loop; /* harmless */
		else if token = tab then goto loop;	/* harmless */
		else if token = nl then goto loop;	/* harmless */
		else call error ("Illegal character " || token || " encountered", "1"b); /* yell */

	     return;

get_break:     entry (char, errlab);			/* gets break tokens, goes to errlab if fails */

dcl  char char (1),
     errlab label;

bloop:
	     call parse_file_$parse_file_ptr (tokenp, count, break, eof); /* get a token */

	     if eof > 0 then call error ("Unexpected end of file encountered", ""b); /* oops */

	     if break > 0 then if b_token = space then goto bloop; /* harmless */
		else if b_token = tab then goto bloop;	/* harmless */
		else if b_token = nl then goto bloop;	/* harmless */
		else if b_token = char then return;	/* it's the one we wanted */
		else do;				/* it's not */
bad_break:
		     explanation = "Illegal token " || b_token || " found instead of expected token " || char;
		     goto errlab;			/* we don't call error, because */
						/* it may not be an error condition. */
		end;

	     else goto bad_break;			/* wasn't a break token */

	end;

put_out:	proc (string, string_len);			/* writes string into output file */

dcl  string char (*) varying,
     string_len fixed bin;

dcl  outstring char (65536) based (segp);

	     substr (outstring, outdx, string_len) = string; /* copy into output file */
	     outdx = outdx + string_len;

	     return;
	end;

     end;




		    gf_int_.pl1                     11/18/82  1706.6rew 11/18/82  1627.7       38862



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


gf_int_attach: proc (iocb_ptr, option_array, com_err_sw, code);

/* IOX version of gf_int_ IO module.
   This IO module is a "wrapper" for the gr_print_ subroutine.  It can be used to
   catch graphic code written down some switch.  It causes an "english" interpretation of
   the graphic code contents to be printed out to user_output.
   Converted to IOX 03/31/75 by C. D. Tavares */

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

dcl (error_table_$invalid_device,
     error_table_$not_detached,
     error_table_$bad_mode,
     error_table_$noarg) fixed bin (35) external;

%include iocbv;

dcl 1 switch_data_block aligned based (iocb.attach_descrip_ptr),
    2 attach_description char (64) varying,
    2 open_description char (64) varying;

dcl  get_system_free_area_ ext entry returns (ptr),
     free_ptr pointer static initial (null),
     sys_area area based (free_ptr);

dcl  com_err_ ext entry options (variable),
     explanation char (64);

dcl (null, length, substr, addr, hbound, char) builtin;

	if iocb.attach_descrip_ptr ^= null then do;	/* switch already attached */
	     code = error_table_$not_detached;		/* complain */
	     explanation = "";
	     goto attach_error;
	end;

	if hbound (option_array, 1) ^= 1 then do;
	     code = error_table_$noarg;
	     explanation = "Wanted 1 arg, got " || char (hbound (option_array, 1));
	     goto attach_error;
	end;

	if option_array (1) ^= "user_output" then do;
	     code = error_table_$invalid_device;
	     explanation = "This module restricted to use over user_output.";
	     goto attach_error;
	end;

	if free_ptr = null then free_ptr = get_system_free_area_ ();

	allocate switch_data_block in (sys_area) set (iocb.attach_descrip_ptr);

	switch_data_block.attach_description = "gf_int_ " || option_array (1);
	iocb.open = gf_int_open;
	iocb.detach_iocb = gf_int_detach;

	call iox_$propagate (iocb_ptr);

	return;

attach_error:
	if com_err_sw then call com_err_ (code, "gf_int_", explanation);
	return;

gf_int_open: entry (iocb_ptr, mode, append, code);

dcl  mode fixed bin parameter,
     append bit (1) aligned parameter;

%include iox_modes;

dcl  iox_$propagate ext entry (pointer);

	if mode ^= Stream_output then do;
	     code = error_table_$bad_mode;
	     return;
	end;

	actual_iocb_ptr -> iocb.put_chars = gf_int_write;

	open_description = "stream_output";
	iocb.open_descrip_ptr = addr (open_description);

	iocb.close = gf_int_close;

	call iox_$propagate (actual_iocb_ptr);
	code = 0;
	return;

gf_int_close: entry (iocb_ptr, code);

	actual_iocb_ptr -> iocb.open = gf_int_open;
	actual_iocb_ptr -> iocb.detach_iocb = gf_int_detach;
	actual_iocb_ptr -> iocb.open_descrip_ptr = null;

	call iox_$propagate (actual_iocb_ptr);
	code = 0;
	return;


gf_int_detach: entry (iocb_ptr, code);

	free iocb.attach_descrip_ptr -> switch_data_block in (sys_area);
	iocb.attach_descrip_ptr = null;

	call iox_$propagate (iocb_ptr);

	code = 0;
	return;

gf_int_write: entry (iocb_ptr, wksp, nelem, code);

dcl  nelem fixed bin (21) parameter,
     wksp pointer parameter;

dcl  charstring char (nelem) based (wksp),
     gr_print_ external entry (char (*));

	call gr_print_ (charstring);
	code = 0;
	return;

gf_int_module: entry (aa, ab, ac, ad, stat, ae);

dcl (aa, ab, ac, ad, ae) fixed bin,
     stat bit (72) aligned;

dcl  error_table_$not_attached ext bit (36) aligned static;

	call com_err_ (0, "gf_int_", "This I/O module is now an iox_-type module.
     Use iox_$attach and iox_$open, or io attach and io open.");

	stat = error_table_$not_attached;
	substr (stat, 54, 1) = "1"b;			/* transaction aborted */
	substr (stat, 52, 1) = "1"b;			/* detached */
	return;

     end gf_int_attach;




		    gr_print_.pl1                   11/18/82  1706.6rew 11/18/82  1625.3       78849



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

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

gr_print_: proc (charstring);

/* Written long, long ago, in a galaxy far, far away, by C. D. Tavares */
/* Last modified 08/29/80 by CDT to un-reverse blinking and sensitivity */

dcl  charstring char (*) parameter;

dcl  len fixed bin;

%include graphic_code_dcl;

dcl (i, j) fixed bin,
     prefix_length fixed bin initial (0),
    (index, length, substr, string, abs) builtin,
     ch char (1) aligned,
     ioa_$nnl ext entry options (variable),
     ioa_ ext entry options (variable);

dcl (xyz (3), float_array (6)) float bin,
     node fixed bin (18),
     just_ended bit (1) aligned,
     fixed_array (3) fixed bin,
     temp char (16) aligned,
     off_on (0:1) char (4) aligned initial ("off ", "on  ") static,
     Query_type (3) char (8) aligned static initial ("where", "which", "what"),
     Alignments (9) char (16) static initial
    ("upper left",
     "upper center",
     "upper right",
     "left",
     "center",
     "right",
     "lower left",
     "lower center",
     "lower right"),
     Graphic_names (5) char (12) static initial
    ("setposition", "setpoint", "vector", "shift", "point"),
     Input_device (0:63) static char (12) initial
    ("processor", "keyboard", "mouse", "joystick", "pen/tablet",
     "lightpen", "trackball", (56) (1) "undefined", "any device"),
     Line_Types (0 : 4) char (12) aligned static initial ("solid", "dashed", "dotted", "dash-dotted", "long-dashed");

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

dcl  charstring_array (len) char (1) unaligned based (addr (charstring));


	len = length (charstring);

	call ioa_ ("");
	just_ended = "1"b;

	do i = 1 by 1 while (i <= len);

	     ch = substr (charstring, i, 1);
	     j = index (string (Graphic_Code_Structure.Dynamic_and_structural_effectors), ch);
	     if j > 0 then goto Dyn_Struc (j);

	     j = index (string (Graphic_Code_Structure.Graphic_effectors), ch);
	     if j > 0 then do;
		call get_xyz;
		call ioa_ ("^vx^12a ^9.3f ^9.3f ^9.3f", prefix_length, Graphic_names (j), xyz (1), xyz (2), xyz (3));
		goto loopend;
	     end;

	     j = index (string (Graphic_Code_Structure.Mapping_effectors), ch);
	     if j > 0 then goto Mapping (j);

	     j = index (string (Graphic_Code_Structure.Mode_effectors), ch);
	     if j > 0 then goto Mode (j);

	     j = index (string (Graphic_Code_Structure.Special_effectors), ch);
	     if j > 0 then goto Special (j);

	     call ioa_ ("^vxNON-GRAPHIC: ^a", prefix_length, ch);
	     goto loopend;


Dyn_Struc (1): call ioa_ ("pause");
	     goto loopend;

Dyn_Struc (2): call ioa_ ("reference ^o", get_uid ());
	     goto loopend;

Dyn_Struc (3): node = get_uid ();
	     call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 1, fixed_array);
	     call graphic_code_util_$decode_scl (addr (charstring_array (i + 3)), 1, float_array);
	     i = i + 5;
	     call ioa_$nnl ("increment  ^o  ^d times, ^8.4f second delay^/	by: ", node, fixed_array (1), float_array (1));
	     goto loopend;

Dyn_Struc (4): node = get_uid ();
	     call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 1, fixed_array);
	     i = i + 2;
	     call ioa_ ("alter  ^o element ^d to ^o", node, fixed_array (1), get_uid ());
	     goto loopend;

Dyn_Struc (5): i = i + 1;
	     if substr (charstring, i, 1) = List_char then temp = "list";
	     else temp = "array";
	     if just_ended then call ioa_ ("^vxnode_begin ^5a ^o", prefix_length, temp, get_uid ());
	     else call ioa_ ("^/^vxnode_begin ^5a ^o", prefix_length, temp, get_uid ());
	     prefix_length = prefix_length + 5;
	     goto loopend;

Dyn_Struc (6): prefix_length = max (0, prefix_length - 5);
	     call ioa_ ("^vxnode_end^/", prefix_length);
	     just_ended = "1"b;
	     goto loopend_no_reset;

Dyn_Struc (7): call ioa_ ("^vxcontrol ^o", prefix_length, get_uid ());
	     goto loopend;

Dyn_Struc (8): call ioa_ ("display  ^o", get_uid ());
	     goto loopend;

Dyn_Struc (9): call graphic_code_util_$decode_spi (addr (charstring_array (i + 1)), 2, fixed_array);
	     i = i + 2;
	     call ioa_ ("query  ^a from ^a", Query_type (fixed_array (1)), Input_device (fixed_array (2)));
	     goto loopend;

Dyn_Struc (10): call ioa_ ("erase");
	     goto loopend;

Dyn_Struc (11): call ioa_ ("synchronize");
	     goto loopend;

Dyn_Struc (12): call ioa_ ("delete ^o", get_uid ());
	     goto loopend;


Mapping (1):   call get_xyz;
	     call ioa_ ("^vxscaling   ^9.3f ^9.3f ^9.3f", prefix_length, xyz (1), xyz (2), xyz (3));
	     goto loopend;

Mapping (2):   call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 3, fixed_array);
	     call ioa_ ("^vxrotation  ^3d ^3d ^3d", prefix_length, fixed_array (1), fixed_array (2), fixed_array (3));
	     i = i + 6;
	     goto loopend;

Mapping (3):   call graphic_code_util_$decode_scl (addr (charstring_array (i + 1)), 6, float_array);
	     call ioa_ ("^vxclipping  ^9.3f ^9.3f (x)^/^vx^10x^9.3f ^9.3f (y)^/^vx^10x^9.3f ^9.3f (z)",
		prefix_length, float_array (1), float_array (2), prefix_length, float_array (3), float_array (4),
		prefix_length, float_array (5), float_array (6));

	     i = i + 12;
	     goto loopend;


Mode (1):	     call ioa_ ("^vxintensity ^d", prefix_length, get_spi ());
	     goto loopend;

Mode (2):	     call ioa_ ("^vxline_type ^a", prefix_length, Line_Types (get_spi ()));
	     goto loopend;

Mode (3):	     call ioa_ ("^vxsensitivity ^a", prefix_length, off_on (get_spi ()));
	     goto loopend;

Mode (4):	     call ioa_ ("^vxblinking ^a", prefix_length, off_on (get_spi ()));
	     goto loopend;

Mode (5):	     call graphic_code_util_$decode_spi (addr (charstring_array (i + 1)), 3, fixed_array);
	     i = i + 3;
	     call ioa_ ("^vxcolor   ^d red  ^d green  ^d blue",
		prefix_length, fixed_array (1), fixed_array (2), fixed_array (3));
	     goto loopend;


Special (1):   call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 1, fixed_array);
	     i = i + 2;
	     call ioa_ ("^vxsymbol  ""^a""", prefix_length, substr (charstring, i+1, fixed_array (1)));
	     i = i + fixed_array (1);
	     goto loopend;

Special (2):   call graphic_code_util_$decode_spi (addr (charstring_array (i + 1)), 1, fixed_array);
	     temp = Alignments (fixed_array (1));
	     i = i + 1;
	     call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 1, fixed_array);
	     i = i + 2;
	     call ioa_ ("^vxtext  (by ^a) ""^a""", prefix_length, temp, substr (charstring, i+1, fixed_array (1)));
	     i = i + fixed_array (1);
	     goto loopend;

Special (3):   call graphic_code_util_$decode_dpi (addr (charstring_array (i + 1)), 1, fixed_array);
	     i = i + 2;
	     call ioa_ ("^vxdatablock", prefix_length);
	     i = i + divide (fixed_array (1) + 5, 6, 17, 0);
	     goto loopend;


loopend:
	     just_ended = ""b;

loopend_no_reset:
	end;

	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

get_uid:	proc returns (fixed bin (18));

dcl  uid fixed bin (18) dimension (1);

	     call graphic_code_util_$decode_uid (addr (charstring_array (i + 1)), 1, uid);
	     i = i + 3;
	     return (uid (1));
	end get_uid;

get_xyz:	proc;

dcl  k fixed bin;

	     call graphic_code_util_$decode_scl (addr (charstring_array (i + 1)), 3, xyz);
	     i = i + 9;

	     do k = 1 to 3;
		if abs (xyz (k)) <= 1e-6 then xyz (k) = 0e0;
	     end;

	     return;
	end get_xyz;

get_spi:	proc returns (fixed bin);

dcl  spi fixed bin dimension (1);

	     call graphic_code_util_$decode_spi (addr (charstring_array (i + 1)), 1, spi);
	     i = i + 1;
	     return (spi (1));
	end get_spi;

     end gr_print_;







		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved