



		    pl1_macro.pl1                   10/09/89  0906.2rew 10/09/89  0900.0      181485



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




/****^  HISTORY COMMENTS:
  1) change(89-10-02,Blackmore), approve(89-10-02,MCR8138), audit(89-10-03,Vu),
     install(89-10-09,MR12.3-1087):
     Make consistent with 'pl1_macro_lex_' in use of 'translator_temp_' for
     area management.
                                                   END HISTORY COMMENTS */


/* format: style2 */
pl1_macro:
pmac:
     procedure;

/* Free standing command to macro_process a pl1 segment:
  1. Usual command line scan.
  2. set up temp_seg_3 for call to pl1_lex_
  3. ...
  4. Produce an XREF listing, if requested.
  5. Clean-up pl1_macro.
  6. Produce the output segment.
  7. Usual cleanup.

   Written 30 Nov 79 by Marshall Presser 
   Modified: The first half of 1981, ending July 28, to make it work and for auditing, MEP
*/

/* automatic */

	declare arg_count		 fixed binary;
	declare arg_length		 fixed binary (21);
	declare arg_ptr		 pointer;
	declare argument_no		 fixed binary;
	declare argx		 fixed binary;
	declare bit_count		 fixed binary (24);
	declare 1 ca,
		2 list		 bit (1),
		2 pd		 bit (1),
		2 print		 bit (1),
		2 target		 bit (1),
		2 version		 bit (1);
	declare call_length		 fixed binary (21);
	declare call_ptr		 pointer;
	declare cannon_name		 char (32);
	declare clargx		 fixed binary;
	declare code		 fixed binary (35);
	declare data_type		 fixed binary (8) unsigned;
	declare in_dname		 char (168);
	declare in_ename		 char (32);
	declare in_seg_ptr		 pointer;
	declare in_seg_length	 fixed binary (21);
	declare language_suffix	 char (16) varying;
	declare n_chars_left	 fixed binary (2);
	declare n_words		 fixed binary (19);
	declare needs_cleanup	 bit (1);
	declare num_of_clargs	 fixed binary (17);
	declare num_of_params	 fixed binary (17);

	declare out_dname		 char (168);
	declare out_ename		 char (32);
	declare out_seg_ptr		 pointer;
	declare out_seg_length	 fixed binary (21);
	declare output_length	 fixed binary (21);
	declare output_ptr		 pointer;
	declare real_seg_name	 character (32) varying;
	declare source_length	 fixed binary (21);
	declare source_ptr		 pointer;
	declare target_length	 fixed binary (21);
	declare target_ptr		 pointer;
	declare target_value	 fixed binary (17);
	declare temp_target		 char (32);
	declare trans_temp_ptr	 pointer;

/* based */

	declare arg_string		 char (arg_length) based (arg_ptr);
	declare call_string		 char (call_length) based (call_ptr);
	declare in_seg		 char (in_seg_length) based (in_seg_ptr);
	declare out_seg		 char (out_seg_length) based (out_seg_ptr);
	declare result_string	 char (output_length) based (output_ptr);
	declare target_string	 char (target_length) based (target_ptr);


/* builtin */

	declare (addr, baseno, divide, index, low, length, mod, null, reverse, rtrim, search, string, substr, verify)
				 builtin;

/* condition */

	declare cleanup		 condition;

/* internal static */

	declare MINUS_SIGN		 char (1) internal static options (constant) initial ("-");
	declare suffix		 char (4) internal static options (constant) initial ("pmac");

/* external static */

	declare (
	        error_table_$badopt,
	        error_table_$inconsistent,
	        error_table_$noarg
	        )			 fixed binary (35) external static;
	declare iox_$user_output	 pointer external static;

/* entry */

	declare com_err_		 entry options (variable);
	declare com_err_$suppress_name entry options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
	declare cu_$cp		 entry (pointer, fixed binary (21), fixed binary (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed binary (35));
	declare expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare get_pdir_		 entry returns (char (168));
	declare get_system_free_area_	 entry () returns (pointer);
	declare get_temp_segments_	 entry (char (*), (*) pointer, fixed binary (35));
	declare hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2),
				 pointer, fixed binary (35));
	declare hcs_$make_seg	 entry (char (*), char (*), char (*), fixed binary (5), pointer,
				 fixed binary (35));
	declare hcs_$set_bc_seg	 entry (pointer, fixed binary (24), fixed binary (35));
	declare hcs_$terminate_noname	 entry (pointer, fixed binary (35));
	declare hcs_$truncate_seg	 entry (pointer, fixed binary (19), fixed binary (35));
	declare ioa_		 entry options (variable);
	declare iox_$put_chars	 entry (pointer, pointer, fixed binary (21), fixed binary (35));
	declare pathname_		 entry (char (*), char (*)) returns (char (168));
	declare release_temp_segments_ entry (char (*), (*) pointer, fixed binary (35));
	declare translator_temp_$get_segment
				 entry (char (*), ptr, fixed bin (35));
	declare translator_temp_$release_all_segments
				 entry (ptr, fixed bin (35));

%include pl1_macro_lex_dcls;

/* program */

	source_ptr = null;
	output_ptr = null;
	temp_segs (*) = null;
	trans_temp_ptr = null;
	call_ptr = null;
	call_length = 0;
	pl1_macro_severity_ = 5;
	string (ca) = ""b;
	ca.version = "1"b;
	needs_cleanup = "0"b;
	num_of_clargs = 0;
	num_of_params = 0;

	on cleanup call macro_cleanup;

	call translator_temp_$get_segment (command, trans_temp_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Getting area segment in process directory.");
		call macro_cleanup;
		return;
	     end;
	call get_temp_segments_ (command, temp_segs (*), code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Getting temporary segments in process directory.");
		call macro_cleanup;
		return;
	     end;

	output_ptr = temp_segs (2);

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, command);
		return;
	     end;
	argument_no = 0;
	do argx = 1 to arg_count;
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     call macro_cleanup;
		     return;
		end;

	     if arg_string = ""
	     then ;

	     else if arg_string = "-print" | arg_string = "-pr"
	     then ca.print = "1"b;

	     else if arg_string = "-process_dir" | arg_string = "-pd"
	     then ca.pd = "1"b;

	     else if arg_string = "-version" | arg_string = "-ver"
	     then ca.version = "1"b;

	     else if arg_string = "-no_version" | arg_string = "-nver"
	     then ca.version = "0"b;

	     else if arg_string = "-list" | arg_string = "-ls"
	     then ca.list = "1"b;

	     else if arg_string = "-target" | arg_string = "-tgt"
	     then do;
		     ca.target = "1"b;
		     argx = argx + 1;
		     if argx > arg_count
		     then do;
			     call com_err_ (error_table_$noarg, command, "Missing target string after -target.");
			     call macro_cleanup;
			     return;
			end;

		     call cu_$arg_ptr (argx, target_ptr, target_length, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, command, "Argument ^d.", argx);
			     call macro_cleanup;
			     return;
			end;
		     else do;
			     temp_target = target_string;
			     call system_type_ (temp_target, cannon_name, target_value, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, command, "Invalid target string: ^a", target_string);
				     call macro_cleanup;
				     return;
				end;
			     else do;
				     temp_seg_3.target_value = target_value;
				end;
			end;

		end;
	     else if arg_string = "-call"
	     then do;
		     argx = argx + 1;
		     if argx > arg_count
		     then do;
			     call com_err_ (error_table_$noarg, command, "Missing call string after -call.");
			     call macro_cleanup;
			     return;
			end;

		     call cu_$arg_ptr (argx, call_ptr, call_length, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, command, "Argument ^d.", argx);
			     call macro_cleanup;
			     return;
			end;

		end;

	     else if arg_string = "-parameter" | arg_string = "-pm"
	     then do;
		     argx = argx + 1;
		     num_of_params = num_of_params + 1;
		     if num_of_params >= 65
		     then do;
			     call com_err_ (0, command, "No more than 64 parameters permitted.");
			     call macro_cleanup;
			     return;
			end;

		     if argx + 1 > arg_count
		     then do;
			     call com_err_ (error_table_$noarg, command, "Missing arguments after -pm.");
			     call macro_cleanup;
			     return;
			end;
		     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, command, "Argument ^d.", argx);
			     call macro_cleanup;
			     return;
			end;
		     else do;
			     data_type = get_data_type (arg_string);
			     if data_type ^= identifier
			     then do;
				     call com_err_ (0, command,
					"The first arg in a parameter pair must be an identifier: ^a",
					arg_string);
				     call macro_cleanup;
				     return;
				end;
			     else do;
				     temp_seg_3.cl_params (num_of_params).name.string_size = arg_length;
				     temp_seg_3.cl_params (num_of_params).name.string_ptr = arg_ptr;
				end;
			     argx = argx + 1;
			     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, command, "argument ^d.", argx);
				     call macro_cleanup;
				     return;
				end;

			     data_type = get_data_type (arg_string);
			     if data_type = no_token
			     then do;
				     call com_err_ (0, command, "Wrong data type in command line arg: ^a",
					arg_string);
				     call macro_cleanup;
				     return;
				end;
			     else do;
				     temp_seg_3.cl_params (num_of_params).value.string_ptr = arg_ptr;
				     temp_seg_3.cl_params (num_of_params).value.string_size = arg_length;
				     temp_seg_3.cl_params (num_of_params).value.type = data_type;
				     temp_seg_3.cl_params (num_of_params).value.created = "0"b;
				end;
			end;

		end;

	     else if arg_string = "-arguments" | arg_string = "-ag"
	     then do;
		     argx = argx + 1;
		     if argx > arg_count
		     then do;
			     call com_err_ (error_table_$noarg, command, "Missing arguments after -ag.");
			     call macro_cleanup;
			     return;
			end;
		     num_of_clargs = arg_count - argx + 1;
		     do clargx = 1 to num_of_clargs;
			call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
			if code ^= 0
			then do;
				call com_err_ (code, command, "Argument ^d.", argx);
				call macro_cleanup;
				return;
			     end;
			else do;
				temp_seg_3.cl_args (clargx).string_ptr = arg_ptr;
				temp_seg_3.cl_args (clargx).string_size = arg_length;
			     end;

			argx = argx + 1;
			if argx >= 65
			then do;
				call com_err_ (0, command, "No more than 64 cl_args permitted.");
				call macro_cleanup;
				return;
			     end;
		     end;
		end;
	     else if index (arg_string, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", arg_string);
		     call macro_cleanup;
		     return;
		end;

	     else do;
		     argument_no = argument_no + 1;

		     if argument_no = 1
		     then do;
			     in_seg_ptr = arg_ptr;
			     in_seg_length = arg_length;
			end;

		     else if argument_no = 2
		     then do;
			     out_seg_ptr = arg_ptr;
			     out_seg_length = arg_length;
			end;
		end;
	end;

	if argument_no = 0 | argument_no > 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a in_path {out_path} {-control_args}", command);
		call macro_cleanup;
		return;
	     end;

	if ca.pd & argument_no > 1
	then do;
		call com_err_ (error_table_$inconsistent, command,
		     "The -pd control argument is incompatible with an output path name.");
		call macro_cleanup;
		return;
	     end;

	if ca.print & argument_no > 1
	then do;
		call com_err_ (error_table_$inconsistent, command,
		     "The -pr control argument is incompatible with an output path name.");
		call macro_cleanup;
		return;
	     end;

	if ca.print & ca.pd
	then do;
		call com_err_ (error_table_$inconsistent, command,
		     "The -pr and -pd control arguments are incompatible.");
		call macro_cleanup;
		return;
	     end;

	call get_input_segment (code);
	if code ^= 0
	then do;
		call macro_cleanup;
		return;
	     end;

	if ca.list
	then call ioa_ ("List not yet implemented.");

	if ^ca.print
	then do;
		if argument_no = 1			/* Should we use default output ? */
		then do;
			if ca.pd
			then out_dname = get_pdir_ ();
			else out_dname = in_dname;
			out_ename = real_seg_name;
		     end;
		else do;				/* second pathname given */
			call expand_pathname_ (out_seg, out_dname, out_ename, code);
			if code ^= 0
			then do;
				call com_err_ (code, command, "^a", out_seg);
				call macro_cleanup;
				return;
			     end;
		     end;

		call hcs_$make_seg (out_dname, out_ename, "", 1010b, output_ptr, code);
		if output_ptr = null
		then do;
			call com_err_ (code, command, "^a", pathname_ (out_dname, out_ename));
			call macro_cleanup;
			return;
		     end;
		if baseno (output_ptr) = baseno (source_ptr)
						/* same source as output not on */
		then do;
			call com_err_ (0, command,
			     "The source segment and the output segment are the same.  No output produced.");
			call macro_cleanup;
			return;
		     end;
	     end;

	temp_seg_3.source_ptr = source_ptr;
	temp_seg_3.source_length = source_length;
	temp_seg_3.output_length = 4 * sys_info$max_seg_size;
	temp_seg_3.flags.list = ca.list;
	temp_seg_3.area_ptr = trans_temp_ptr;
	temp_seg_3.number_of_clargs = num_of_clargs;
	temp_seg_3.number_of_params = num_of_params;
	temp_seg_3.constant_base = null ();
	temp_seg_3.variable_base = null ();

	if ^ca.target
	then temp_seg_3.target_value = none;

	if ^valid_penultimate_suffix (language_suffix)
	then call com_err_ (0, command, "Warning: ^a an unrecognized penultimate suffix.  PL/I lex rules used.",
		language_suffix);


	if ca.version
	then call ioa_ ("^a ^a", command, macro_version);

	pl1_macro_severity_ = 0;
	needs_cleanup = "1"b;
	call pl1_macro_lex_ (temp_segs, code);
	needs_cleanup = "0"b;

	if code ^= 0
	then call com_err_ (0, command, "Errors in macro processing; output segment may be suspect.");

/* Copy the macro processed program over to the output segment */

	output_length = temp_seg_3.output_length;

	if ca.print
	then do;
		call iox_$put_chars (iox_$user_output, temp_segs (2), output_length, code);
		if code ^= 0
		then do;
			call com_err_ (code, command);
			call macro_cleanup;
			return;
		     end;
	     end;

	else do;

		substr (result_string, 1, output_length) = substr (temp_segs (2) -> output_string, 1, output_length);

		n_chars_left = mod (4 - output_length, 4);
		substr (result_string, output_length + 1, n_chars_left) = low (n_chars_left);

		n_words = divide (output_length + 3, 4, 19);

		call hcs_$truncate_seg (output_ptr, n_words, code);
		if code ^= 0
		then do;
			pl1_macro_severity_ = 5;
			call com_err_ (code, command, "Unable to truncate ^a to ^d words.",
			     pathname_ (out_dname, out_ename), n_words);
		     end;

		bit_count = 9 * output_length;

		call hcs_$set_bc_seg (output_ptr, bit_count, code);
		if code ^= 0
		then do;
			pl1_macro_severity_ = 5;
			call com_err_ (code, command, "Unable to set bit count of ^a to ^d.",
			     pathname_ (out_dname, out_ename), bit_count);
		     end;
	     end;

	if call_ptr ^= null & pl1_macro_severity_ <= 1
	then begin;
		declare command_line	 character (call_length + 169);
		command_line = call_string || " " || pathname_ (out_dname, out_ename);
		call cu_$cp (addr (command_line), length (command_line), code);
	     end;

	call macro_cleanup;
	return;

get_data_type:
     procedure (chars) returns (fixed binary (8) unsigned);

	declare chars		 character (*);
	declare ch_len		 fixed binary (24);

/* scan the character string:
	if all digits , then data_type = dec_integer
	else if begins and end with a QUOTE, then char_string
	else if begins with a QUOTE and ends with QUOTE b and everythin inbetween is 1 or o then bit_string
	else if begins with an alphabertic and others are identifier chars, then identifier
	else invalid data type */

	ch_len = length (chars);
	if ch_len = 0
	then return (no_token);

	if verify (chars, numerals) = 0
	then return (dec_integer);

	else if substr (chars, 1, 1) = QUOTE
	then do;
		if ch_len = 1
		then return (no_token);

		else if substr (chars, ch_len, 1) = QUOTE
		then return (char_string);

		else if substr (chars, ch_len, 1) = "b" & ch_len > 2 & substr (chars, ch_len - 1, 1) = QUOTE
		     & verify (substr (chars, 2, ch_len - 3), zero_one) = 0
		then return (bit_string);

		else return (no_token);
	     end;

	else if search (chars, alphabetics) = 1 & verify (chars, identifier_chars) = 0
	then return (identifier);

	else if substr (chars, 1, 1) = MINUS_SIGN
	then do;
		if ch_len = 1
		then return (no_token);

		else if verify (substr (chars, 2), numerals) = 0
		then return (dec_integer);

		else return (no_token);
	     end;

	else return (no_token);

     end get_data_type;

get_input_segment:
     procedure (code);

	declare code		 fixed binary (35); /* (Output) standard status code */

	call expand_pathname_$add_suffix (in_seg, suffix, in_dname, in_ename, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "^a", in_seg);
		return;
	     end;

/* trim off the ".macro" to get the segments REAL name. */

	real_seg_name = substr (in_ename, 1, length (rtrim (in_ename)) - length (suffix) - 1);
	if number_of_components (real_seg_name) > 1
	then language_suffix = get_last_component (real_seg_name);
	else language_suffix = "";

	call hcs_$initiate_count (in_dname, in_ename, "", bit_count, 0, source_ptr, code);
	if source_ptr ^= null
	then do;
		code = 0;
		source_length = divide (bit_count + 8, 9, 21);
		return;
	     end;
	else do;
		call com_err_ (code, command, "^a", pathname_ (in_dname, in_ename));
		return;
	     end;
	return;
     end get_input_segment;

number_of_components:
     procedure (seg_name) returns (fixed binary);
	declare seg_name		 character (*) varying;
	declare (indx, count, nex)	 fixed binary;

	count = 0;
	indx = 1;
	do while (indx < length (seg_name));
	     nex = search (substr (seg_name, indx), ".");
	     if nex = 0
	     then nex = length (seg_name);
	     indx = indx + nex;
	     count = count + 1;

	end;
	return (count);
     end number_of_components;

get_last_component:
     procedure (seg_name) returns (character (*) varying);
	declare seg_name		 char (*) varying;
	declare indx		 fixed binary;

	indx = search (reverse (seg_name), ".");
	return (substr (seg_name, length (seg_name) - indx + 2));

     end get_last_component;

valid_penultimate_suffix:
     procedure (suffix_chars) returns (bit (1) aligned);
	declare suffix_chars	 char (*) varying;

	return (suffix_chars = "pl1" | suffix_chars = "cds" | suffix_chars = "rd");

     end valid_penultimate_suffix;

/* Release temporary storage and terminate segments. */

macro_cleanup:
     procedure;

	if source_ptr ^= null
	then do;
		call hcs_$terminate_noname (source_ptr, code);
		source_ptr = null;
	     end;

	if (output_ptr ^= temp_segs (2) & output_ptr ^= null)
	then do;
		call hcs_$terminate_noname (output_ptr, code);
		output_ptr = null;
	     end;

	if needs_cleanup
	then call pl1_macro_lex_$cleanup (temp_segs);

	if temp_segs (1) ^= null
	then call release_temp_segments_ (command, temp_segs (*), code);
	temp_segs (*) = null;

	call translator_temp_$release_all_segments (trans_temp_ptr, code);
	trans_temp_ptr = null;

     end macro_cleanup;

     end pl1_macro;




		    pl1_macro_error_.pl1            12/01/87  1559.5r w 12/01/87  1554.3       23616



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


/* format: style2 */
pl1_macro_error_:
     procedure (P_error_severity, P_error_string, P_source_ptr, P_source_index, P_source_length);

	declare P_error_severity	 fixed binary (35); /* (Input) error_severity of the error */
	declare P_error_string	 char (*);	/* (Input) error message */
	declare P_source_ptr	 pointer;		/* (Input) pointer to  the source */
	declare P_source_index	 fixed binary (21); /* INPUT: char index where error occured */
	declare P_source_length	fixed binary (21); /* INPUT: length in chars of source segment */
/* automatic */

	declare line_length		 fixed binary (21);
	declare line_number		 fixed binary (21);
	declare line_start		 fixed binary (21);

	declare loop		 bit (1);		/* based */

	declare source_string	 char (P_source_length) based (P_source_ptr);

/* builtin */

	declare index		 builtin;
	declare length		 builtin;
	declare max		 builtin;
	declare null		 builtin;
	declare substr		 builtin;

/* internal static */

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

/* entry */

	declare ioa_		 entry options (variable);

%include pl1_macro_lex_dcls;

/* program */

	pl1_macro_severity_ = max (P_error_severity, pl1_macro_severity_);

	line_number = 0;

/* find the line in the source, if there is one */

	if P_source_ptr ^= null ()
	then do;

		line_start = 1;
		line_length = 0;

		loop = "1"b;
		do while (loop);
		     line_number = line_number + 1;
		     line_start = line_start + line_length;
		     line_length = index (substr (source_string, line_start), NL);

		     loop = line_start + line_length <= P_source_index & line_length > 0;

		     if line_length = 0
		     then line_length = length (substr (source_string, line_start)) + 1;
		end;
	     end;

/* Print the error message. */

	call ioa_ ("^/^[WARNING^s^;SEVERITY ^d ERROR^]^[^s^; ON LINE ^d^]", P_error_severity = 1, P_error_severity,
	     line_number = 0, line_number);

	if P_error_string ^= ""
	then call ioa_ ("^a", P_error_string);

	if line_number > 0
	then call ioa_ ("SOURCE:^-^a", substr (source_string, line_start, line_length - 1));
     end pl1_macro_error_;




		    pl1_macro_lex_.pl1              10/09/89  0906.2rew 10/09/89  0900.0      717282



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




/****^  HISTORY COMMENTS:
  1) change(87-05-06,Huen), approve(87-05-06,MCR7675), audit(87-05-11,RWaters),
     install(87-12-01,MR12.2-1005):
     Fix PL/1 bug 2163 : Speeding up the macro processing.
                                                   END HISTORY COMMENTS */


/* format: style2 */
/* This is the lexical analysis program for the pl1_macro command.
   The primary responsibilities of this program are:
	1.  Break the source program into tokens.
	2.  Perform whatever substitution need be done at stand_alone time.
	3.  Create the output segment.

   Written 771105 by PG; from "lex" in the Multics PL/I compiler.
   Modified 771226 by PG to save comments and vertical white space as token trailers.
   Modified November 1978 by Monte Davidoff.
   Stolen and modified Nov 21 80 by Marshall Presser
   Modified May 1987 by Susanna Huen.
*/
pl1_macro_lex_:
     procedure (P_temp_segs, code);

	declare P_temp_segs		 (*) pointer;	/* INPUT: temporary segment pointers */
	declare code		 fixed binary (35); /* OUTPUT: status code */

/* automatic */

	declare FALSE_token		 fixed binary;	/* index of a "0"b token */
	declare TRUE_token		 fixed binary;	/* index of a "1"b token */
	declare action_index	 fixed binary;	/* index of action to execute */
	declare alias_id		 fixed binary;	/* for replacement tokens, the token to which it resolves */
	declare current_char	 char (1);	/* character that stopped the scan, char we are checking */
	declare error_message	 char (256) varying;/* used as a temp to avoid stack extension in call */
	declare file_number		 fixed binary (8);	/* file number of seg were lexing */
	declare first_result	 fixed binary;	/* first replacement token in expansion */
	declare i			 fixed binary;
	declare last_result		 fixed binary;	/* last token in expansion of macro */
	declare last_token		 fixed binary;	/* last token in macro consturct being interpreted */
	declare line_number		 fixed binary (14); /* line in source from which were lexing */
	declare loop		 bit (1) aligned;	/* loop control variable */
	declare macro_depth		 fixed binary;	/* depth of macro stack */
	declare macro_ptr		 pointer;		/* -> macro_stack for current source_segment */
	declare nested_if_level	 fixed binary;	/* number of %if's on the stack */
	declare next_char_to_print	 fixed binary (21); /* next char to print from current source */
	declare next_free_token	 fixed binary;	/* when finishing macro, where to plunk results */
	declare number_of_clargs	 fixed binary;	/* number of command line args */
	declare number_of_params	 fixed binary;	/* number of command line parameters */
	declare output_index	 fixed binary (21); /* current length (and index) of computed output */
	declare output_length	 fixed binary (21); /* length of output segment */
	declare pct_type		 fixed binary (5) unsigned;
	declare reinterpret		 bit (1);		/* macro needs reintretreting of result */
	declare replacement_token_index
				 fixed binary;	/* next free token for replacment identifiers */
	declare result_first	 fixed binary;	/* first token of result of parsing macros */
	declare scan_index		 fixed binary (21); /* index (relative to source_index) of forward scan */
	declare source_index	 fixed binary (21); /* index into current source segment */
	declare source_length	 fixed binary (21); /* length (in characters) of current source segment */
	declare source_number	 fixed binary;	/* number of source segments scanned */
	declare source_ptr		 pointer;		/* pointer to base of source segment */
	declare source_type		 fixed binary (35); /* type of input being scanned */
	declare string_length	 fixed binary (21); /* number of characters in dequoted string */
	declare target_error	 bit (1);		/* "1"b iff %target  used without -target control arg */
	declare target_value	 fixed binary (17); /* value of %target to use */
	declare temp_token		 char (256) var;	/* used as a temp to avoid stack extension in call */
	declare terminator_type	 fixed binary;	/* how macro construct is terminated */
	declare token_index		 fixed binary;	/* index into current macro_construct */
	declare token_length	 fixed binary (21); /* length of token in characters */
	declare token_ptr		 pointer;		/* pointer to char string of token */
	declare token_start		 fixed binary (21); /* index of first character of current token */
	declare token_type		 fixed binary (8) unsigned;
						/* type of current token */
	declare tokenx		 fixed binary;	/* index into token */
	declare var_id		 pointer;		/* id of variable, used in altering properties */
	declare var_name		 char (256) varying;/* name of variable */
	declare var_type		 fixed binary;	/* type of statement in which variable declared */

/*format: off */
	declare tentative_token_type	 (0:128) fixed binary (8) unsigned
 initial (
				(9) invalid_char,	/* 000-010	ctl chars	*/
				 no_token,	/* 011		HT	*/
				 (3) nl_vt_np_token,/* 012-014	NL VT NP	*/
				 (19) invalid_char, /* 015-037	ctl chars	*/
				 no_token,	/* 040		SP	*/
				 invalid_char,	/* 041		!	*/
				 char_string,	/* 042		"	*/
				 (2) invalid_char,	/* 043-044	# $	*/
				 percent,		/* 045		%	*/
				 and,		/* 046		&	*/
				 invalid_char,	/* 047		'	*/
				 left_parn,	/* 050		(	*/
				 right_parn,	/* 051		)	*/
				 asterisk,	/* 052		*	*/
				 plus,		/* 053		+	*/
				 comma,		/* 054		,	*/
				 minus,		/* 055		-	*/
				 period,		/* 056		.	*/
				 slash,		/* 057		/	*/
				 (10) dec_integer,	/* 060-071	0 - 9	*/
				 colon,		/* 072		:	*/
				 semi_colon,	/* 073		;	*/
				 lt,		/* 074		<	*/
				 assignment,	/* 075		=	*/
				 gt,		/* 076		>	*/
				 (2) invalid_char,	/* 077-100	? @	*/
				 (26) identifier,	/* 101-132	A - Z	*/
				 (3) invalid_char,	/* 133-135	[ \ ]	*/
				 not,		/* 136		^	*/
				 (2) invalid_char,	/* 137-140	_ `	*/
				 (26) identifier,	/* 141-172	a - z	*/
				 invalid_char,	/* 173		{	*/
				 or,		/* 174		|	*/
				 (3) invalid_char,	/* 175-177	} ~ PAD	*/
				 invalid_char);	/* >177		non-ASCII	*/
/* format: on */
						/* Pushdown stack for nested include files and macros */

	declare 1 file_macro_stack	 (0:64) aligned based (temp_seg_3.file_stack_ptr),
		2 source_type	 fixed binary (35), /* either macro or source */
		2 file		 aligned,
		  3 source_ptr	 ptr,		/* ptr to base of source segment */
		  3 source_index	 fixed bin (21),	/* index (in chars) of lexical scan */
		  3 source_length	 fixed bin (21),	/* length (in chars) of source segment */
		  3 line_number	 fixed bin (14),	/* line number in source segment */
		  3 file_number	 fixed bin (8),	/* file number of source segment */
		  3 macro_ptr	 pointer,		/* -> macro_stack for this source seg */
		  3 macro_depth	 fixed binary,	/* depth of macro_stack */
		  3 nested_if_level	 fixed binary,	/* nesting level of %if's */
		  3 next_char_to_print
				 fixed binary (21), /* index of next character to print */
		2 macro		 aligned,
		  3 token_index	 fixed binary,	/* index (by token number) of in scan */
		  3 last_token	 fixed binary,	/* position (in tokens) of last token */
		  3 first_result	 fixed binary,	/* first token in result string */
		  3 last_result	 fixed binary,	/* last token in result */
		  3 last_printed	 fixed binary;	/* when applicable, last char printed */

	declare 1 macro_stack	 (64) aligned based (macro_ptr),
						/* per source seg stack */
		2 type		 fixed binary,	/* kind of token string */
		2 token_index	 fixed binary,	/* first token in string */
		2 last_token	 fixed binary,	/* last token in string */
		2 first_result	 fixed binary,	/* first token in result string */
		2 last_result	 fixed binary,	/* last token in result */
		2 else_seen	 bit (1);		/* for if-types, if an %else has been seen */

dcl pl1_macro_hash_table_ptr ptr;

declare	1 hash_table_structure	aligned based (pl1_macro_hash_table_ptr),
	2 hash_table (0:630)	ptr unaligned;

/* based */

	declare based_chars		 char (256) based;
	declare source_string	 char (source_length) based (source_ptr);
	declare source_string_array	 (source_length) char (1) based (source_ptr);
	declare token_string	 char (token (token_index).string_size) based (token (token_index).string_ptr);

/* builtin */

	declare (addr, bin, binary, bit, char, fixed, divide, hbound, index, lbound, length, ltrim, max, min, null,
	        rank, rtrim, substr, unspec, verify)
				 builtin;

/* entry */
	declare char_offset_	 entry (pointer) returns (fixed binary (21));
	declare find_include_file_$initiate_count
				 entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
	declare com_err_		 entry () options (variable);
	declare hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	declare ioa_		 entry () options (variable);
						/* external static */
	declare error_table_$translation_failed
				 fixed bin (35) ext static;

/* internal static */
/* format: off */
	declare action_table	 (0:128) fixed binary internal static options (constant) 
initial ( 
			 	 (9) 9,		/* 000-010	ctl chars */
				 1,		/* 011		HT	*/
				 18,		/* 012		NL	*/
				 (2) 8,		/* 013-014	VT NP	*/
				 (19) 9,		/* 015-037	ctl chars	*/
				 1,		/* 040		SP	*/
				 9,		/* 041		!	*/
				 2,		/* 042		"	*/
				 9,		/* 043		#	*/
				 9,		/* 044		$	*/
				 16,		/* 045		%	*/
				 4,		/* 046		&	*/
				 9,		/* 047		'	*/
				 (2) 4,		/* 050-051	( )	*/
				 10,		/* 052		*	*/
				 (2) 4,		/* 053-054	+ ,	*/
				 11,		/* 055		-	*/
				 6,		/* 056		.	*/
				 5,		/* 057		/	*/
				 (10) 7,		/* 060-071	0 - 9	*/
				 4,		/* 072	: 	*/
				 17,		/* 073	;	*/
				 12,		/* 074		<	*/
				 4,		/* 075		=	*/
				 13,		/* 076		>	*/
				 (2) 9,		/* 077-100	? @	*/
				 (26) 3,		/* 101-132	A - Z	*/
				 (3) 9,		/* 133-135	[ \ ]	*/
				 14,		/* 136		^	*/
				 (2) 9,		/* 137-140	_ `	*/
				 (26) 3,		/* 141-172	a - z	*/
				 9,		/* 173		{	*/
				 15,		/* 174		|	*/
				 (3) 9,		/* 175-177	} ~ PAD	*/
				 9);		/* >177		non-ASCII	*/
/* format: on */

	declare digits		 char (10) internal static options (constant) initial ("0123456789");
	declare identifier_characters	 char (64) internal static options (constant)
				 initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");

	declare source_list_length	 fixed binary internal static options (constant) initial (255);
	declare ASCII_SEGMENT	 fixed binary internal static options (constant) initial (1);
	declare MACRO_CONSTRUCT	 fixed binary internal static options (constant) initial (2);
	declare FALSE		 bit (1) aligned internal static options (constant) initial ("0"b);
	declare TRUE		 bit (1) aligned internal static options (constant) initial ("1"b);
	declare HT_SP		 char (2) internal static options (constant) initial ("	 ");
	declare VT_NP		 char (3) internal static options (constant) initial ("");

%include pl1_macro_lex_dcls;

/* program */

	code = 0;
 	temp_segs (*) = P_temp_segs (*);
	output_index = 0;
	tokenx = 0;
	replacement_token_index = hbound (token, 1);
	source_number = 0;
	temp_seg_3.source_depth = -1;
	file_number = 0;
	line_number = 1;
	target_error = FALSE;
	target_value = temp_seg_3.target_value;
	output_length = temp_seg_3.output_length;

/* Entry to initialize the hash table used by create_token.  Note that the
   length of the hash table must be a prime number */

	pl1_macro_hash_table_ptr = allocate (temp_seg_3.area_ptr, size (hash_table_structure));
	hash_table (*) = null;

	temp_seg_3.file_stack_ptr = allocate (temp_seg_3.area_ptr, size (file_macro_stack));
	number_of_params = temp_seg_3.number_of_params;
	number_of_clargs = temp_seg_3.number_of_clargs;

/* set up replacment tokens for the command line parameters */

	do i = 1 to number_of_params;
	     var_name =
		substr (temp_seg_3.cl_params.name (i).string_ptr -> based_chars, 1,
		temp_seg_3.cl_params.name (i).string_size);

	     call lookup (var_name, alias_id, var_type, var_id);

	     token_type = temp_seg_3.cl_params.value (i).type;
	     temp_token =
		substr (temp_seg_3.cl_params.value (i).string_ptr -> based_chars, 1,
		temp_seg_3.cl_params (i).value.string_size);

	     if token_type = identifier
	     then token_index = create_identifier_token (rtrim (temp_token));

	     else if token_type = char_string
	     then token_index = create_char_token (rtrim (temp_token));

	     else if token_type = bit_string
	     then token_index =
		     create_bit_token (
		     bit (
		     dequote_string_ (
		     substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1,
		     temp_seg_3.cl_args (i).string_size - 1))));

	     else if token_type = dec_integer
	     then token_index = create_arith_token (bin (temp_token, 71));

	     else call print_error$null (2, "Undefined token type for argument " || ltrim (char (i)));

	     if alias_id = none
	     then call create_variable (var_name, token_index, parameter_var);
	     else call reset_variable_alias (var_id, token_index);
	end /* do loop */;

/* set up the two logical tokens useful in if's */

	TRUE_token = create_bit_token ("1"b);
	FALSE_token = create_bit_token ("0"b);

/* set up is finished - enter the source segment */

	call enter_source_segment (temp_seg_3.source_ptr, temp_seg_3.source_length, (file_number));

	do while (temp_seg_3.source_depth >= 0);	/* for source, include files and macros */
	     goto source_start (source_type);

source_start (1):					/* ASCII segments */
	     do while (source_index <= source_length);

/* determine from 1st char, what sort of token  this can be and go there */

		current_char = substr (source_string, source_index, 1);
		token_start = source_index;
		source_index = source_index + 1;
		token_type = tentative_token_type (min (rank (current_char), hbound (tentative_token_type, 1)));
		pct_type = none;
		action_index = action_table (min (rank (current_char), hbound (action_table, 1)));
		goto action (action_index);

action (1):					/* Scan white space */
		scan_index = verify (substr (source_string, source_index), HT_SP) - 1;
		if scan_index < 0
		then source_index = source_length + 1;
		else source_index = source_index + scan_index;

		token_type = white_space_token;
		call make_token;
		goto END_ACTION;

action (2):					/* Scan string: current_char = '"' */
		string_length = 0;			/* count of number of characters in reduced string */

		loop = TRUE;
		do while (loop);
		     scan_index = index (substr (source_string, source_index), """");
		     if scan_index = 0
		     then do;
			     call print_error (3, "Missing double quote after string constant.", token_start);

			     source_index = source_length + 1;
			     string_length = string_length + (source_length - token_start + 1);
			     goto end_of_source_reached;
			end;

		     source_index = source_index + scan_index;
		     string_length = string_length + scan_index - 1;

		     if source_index > source_length	/* not an error */
		     then goto end_of_source_reached;

		     loop = substr (source_string, source_index, 1) = """";
		     if loop
		     then do;
			     source_index = source_index + 1;
			     string_length = string_length + 1;
			end;
		end;

		if substr (source_string, source_index, 1) = "b"
		then do;
			token_type = bit_string;
			source_index = source_index + 1;

			if source_index <= source_length
			then if index ("1234", substr (source_string, source_index, 1)) > 0
			     then source_index = source_index + 1;
		     end;

		if token_type = char_string
		then do;
			if string_length > max_char_string_constant
			then call print_error (2, "Character-string constant too long.", token_start);

/* here we will insert code to count new_lines in the char_string */

		     end;

		else if string_length > max_bit_string_constant
		then call print_error (2, "Bit-string constant too long.", token_start);

		call make_token;
		goto check_syntax_after_constant;

action (3):					/* Scan identifers */
		scan_index = verify (substr (source_string, source_index), identifier_characters);
		if scan_index = 0
		then scan_index = source_length - source_index + 2;
		source_index = source_index + scan_index - 1;

/* look up this token - and make a token setting replace_by by its alias or none.
   if within a macro construct, make a replacment-token, else simply put
   out the replacement- chars */

		temp_token = substr (source_string, token_start, source_index - token_start);
		call lookup (temp_token, alias_id, var_type, var_id);

		call make_token;
		token (tokenx).replace_by = alias_id;

/* if we're not in the middle of a macro construct and there has been replacement activity
   then it's a convenient time to update the output   */

		if alias_id ^= none & macro_depth = 0
		then do;
			call output_chars$from_source (next_char_to_print, source_index - scan_index - 1);
			call output_chars$token (alias_id);
			next_char_to_print = source_index;
		     end;

		goto END_ACTION;

action (4):					/* Single character tokens */
		call make_token;
		if macro_depth > 0			/* check if in a macro construct */
		then if token_type = right_parn & macro_stack (macro_depth).type = paren_macro
		     then do;
			     macro_stack (macro_depth).last_token = tokenx;
			     call save_environment;
			     call enter_macro_source;
			     goto source_start (MACRO_CONSTRUCT);
			end;

		goto END_ACTION;

action (5):					/* Separate / and /* */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) ^= "*"
		then do;
			call make_token;
			goto END_ACTION;
		     end;

		token_type = comment_token;
		source_index = source_index + 1;

		scan_index = index (substr (source_string, source_index), "*/");
		if scan_index = 0
		then do;
			call print_error (3, "Missing ""*/"" at end of comment.", token_start);

			source_index = source_length + 1;
			goto end_of_source_reached_but_no_pending_token;
		     end;

/* here we will insert code to count the number of new_lines in a comment */

		source_index = source_index + scan_index + 1;

/* we only need to make comment tokens within a macro cosntruct- outside we get them for nothing as loose text */

		if macro_depth > 0
		then call make_token;
		goto END_ACTION;

action (6):					/* Separate . and numbers: current_char = "." */
		if source_index > source_length
		then goto end_of_source_reached;

		if index (digits, substr (source_string, source_index, 1)) = 0
		then do;
			call make_token;
			goto END_ACTION;
		     end;

		token_type = fixed_dec;
		call scan_past_digits;
		goto scan_exponent;

action (7):					/* Scan numbers and isubs: current char = <digit> */
		if source_index > source_length
		then goto end_of_source_reached;

		call scan_past_digits;

		if substr (source_string, source_index, 1) = "."
		then do;
			token_type = fixed_dec;
			source_index = source_index + 1;
			call scan_past_digits;
		     end;
		else if source_index + 2 <= source_length
		then if substr (source_string, source_index, 3) = "sub"
		     then do;
			     source_index = source_index + 3;
			     token_type = isub;
			     call make_token;
			     goto END_ACTION;
			end;

scan_exponent:
		token_length = source_index - token_start;
						/* remember length of mantissa for later error check */

		if substr (source_string, source_index, 1) = "e" | substr (source_string, source_index, 1) = "f"
		then do;
			if substr (source_string, source_index, 1) = "e"
			then token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & is_float_constant);

			token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant);
			source_index = source_index + 1;

			if source_index > source_length
			then do;
				call print_error (3, "Missing exponent in arithmetic constant.", token_start);
				goto end_of_source_reached;
			     end;

			if substr (source_string, source_index, 1) = "+"
			     | substr (source_string, source_index, 1) = "-"
			then do;
				source_index = source_index + 1;

				if source_index > source_length
				then do;
					call print_error (3, "Missing exponent in arithmetic constant.",
					     token_start);
					goto end_of_source_reached;
				     end;
			     end;

			call scan_past_digits;
		     end;

		if substr (source_string, source_index, 1) = "b"
						/* binary constant */
		then do;
			token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_decimal_constant);
			source_index = source_index + 1;

			if verify (substr (source_string, token_start, token_length), ".01") > 0
			then call print_error (2, "Non-binary digit in binary constant.", token_start);
		     end;

		if source_index <= source_length
		then if substr (source_string, source_index, 1) = "p"
		     then do;			/* default suppression indicator */
			     token_type =
				bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant);
			     source_index = source_index + 1;
			end;

		if source_index <= source_length
		then if substr (source_string, source_index, 1) = "i"
		     then do;			/* imaginary constant */
			     token_type =
				bit_to_arithmetic (arithmetic_to_bit (token_type) | is_imaginary_constant);
			     source_index = source_index + 1;
			end;

		call make_token;

/* Now make sure the syntax after the constant is correct. */

check_syntax_after_constant:
		if source_index > source_length
		then goto end_of_source_reached;

		current_char = substr (source_string, source_index, 1);
		action_index = action_table (min (rank (current_char), hbound (action_table, 1)));

		if action_index = 2 | action_index = 3 | action_index = 7
						/* double quote, identifier or arithmetic constant */
		then call print_error (2, "Invalid syntax after constant.", source_index);

		goto END_ACTION;

action (8):					/* Scan VT NP */
		scan_index = verify (substr (source_string, source_index), VT_NP) - 1;
		if scan_index < 0
		then source_index = source_length + 1;
		else source_index = source_index + scan_index;
		token_type = white_space_token;
		call make_token;

		goto END_ACTION;

action (9):					/* Invalid characters */
		if rank (current_char) < 32 | 128 <= rank (current_char)
		then call print_error (2, "Invalid character. """ || char (bit (rank (current_char))) || """b",
			source_index - 1);

		else if current_char = "_" | current_char = "$"
		then call print_error (2, """" || current_char || """ may not start an identifier.", source_index - 1)
			;

		else call print_error (2, "Invalid character. """ || current_char || """", source_index - 1);

		call make_token;
		goto END_ACTION;

action (10):					/* Separate * and ** */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = "*"
		then do;
			source_index = source_index + 1;
			token_type = expon;
		     end;

		call make_token;
		goto END_ACTION;

action (11):					/* Separate - and -> */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = ">"
		then do;
			source_index = source_index + 1;
			token_type = arrow;
		     end;

		call make_token;
		goto END_ACTION;

action (12):					/* Separate < and <= */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = "="
		then do;
			source_index = source_index + 1;
			token_type = le;
		     end;

		call make_token;
		goto END_ACTION;

action (13):					/* Separate > and >= */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = "="
		then do;
			source_index = source_index + 1;
			token_type = ge;
		     end;

		call make_token;
		goto END_ACTION;

action (14):					/* Separate ^ and ^= and ^< and ^> */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = "="
		then do;
			source_index = source_index + 1;
			token_type = ne;
		     end;

		else if substr (source_string, source_index, 1) = "<"
		then do;
			source_index = source_index + 1;
			token_type = nlt;
		     end;

		else if substr (source_string, source_index, 1) = ">"
		then do;
			source_index = source_index + 1;
			token_type = ngt;
		     end;

		call make_token;
		goto END_ACTION;

action (15):					/* Separate | and || */
		if source_index > source_length
		then goto end_of_source_reached;

		if substr (source_string, source_index, 1) = "|"
		then do;
			source_index = source_index + 1;
			token_type = cat;
		     end;

		call make_token;
		goto END_ACTION;

action (16):					/* percent seen */
						/* if not in the middle of a % statement, print out all the stuff to here */
		if macro_depth = 0
		then do;
			call output_chars$from_source (next_char_to_print, source_index - 2);
			next_char_to_print = source_index - 1;
		     end;

/* % is not really a token, see what follows is correct keyword */

		if index (alphabetics, substr (source_string, source_index, 1)) = 0
		then do;
			call print_error (3, "Illegal character following ""%"".", token_start);
			source_index = source_index + 1;
			goto END_ACTION;
		     end;

/* for this identifier, see it is legitimate */

		scan_index = verify (substr (source_string, source_index), identifier_characters);
		if scan_index = 0
		then scan_index = source_length - source_index + 1;
		temp_token = substr (source_string, source_index, scan_index - 1);
		call validate_pct_token (temp_token, pct_type, terminator_type);

		source_index = source_index + scan_index - 1;

		goto percent_action (pct_type);

percent_action (0):					/* invalid identifier */
		call print_error (3, "Invalid keyword: " || temp_token || " following ""%"".", token_start);
		goto END_ACTION;

percent_action (1):					/* default */
percent_action (2):					/* page */
percent_action (3):					/* skip */
percent_action (4):					/* replace */
percent_action (5):					/* error */
percent_action (6):					/* isdef */
percent_action (7):					/* target */
percent_action (8):					/* isarg */
percent_action (14):				/* INCLUDE */
percent_action (15):				/* include */
percent_action (16):				/* print */
percent_action (17):				/* warn */
percent_action (18):				/* abort */
percent_action (19):				/* set */
		call make_token;
		call bump_macro_stack (tokenx, terminator_type);
		goto END_ACTION;

percent_action (9):					/* if */
		call make_token;
		call bump_macro_stack (tokenx, if_macro);
		nested_if_level = nested_if_level + 1;
		goto END_ACTION;

percent_action (10):				/* then */
percent_action (11):				/* else */
percent_action (12):				/* elseif */
						/* this is valid iff we are within an if statement - exact syntax later */
		if macro_depth > 0
		then do;
			if macro_stack (macro_depth).type ^= if_macro
			then call print_error (3, "Unexpected keyword: " || temp_token || " following %.",
				token_start);
			else do;
				call make_token;
				if macro_stack (macro_depth).else_seen
				then do;
					call print_error (3,
					     "A %" || temp_token || " has followed an %else at the same level.",
					     token_start);
					call clear_macro_frame;
				     end;
				macro_stack (macro_depth).else_seen = (token_type = pct_else);
			     end;
		     end;
		else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start);
		goto END_ACTION;

percent_action (13):				/* endif */
		if macro_depth > 0
		then do;
			if macro_stack (macro_depth).type ^= if_macro
			then call print_error (3, "Unexpected keyword: " || temp_token || " following %.",
				token_start);
			else do;
				call make_token;
				macro_stack (macro_depth).last_token = tokenx;
				nested_if_level = nested_if_level - 1;
				if nested_if_level = 0
				then do;
					call save_environment;
					call enter_macro_source;
					goto source_start (MACRO_CONSTRUCT);
				     end;
				else macro_depth = macro_depth - 1;
			     end;
		     end;
		else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start);

		goto END_ACTION;

action (17):					/* semicolon */
		call make_token;
		if macro_depth > 0			/* check if this terminates a macro construct */
		then if macro_stack (macro_depth).type = semicolon_macro
		     then do;
			     if nested_if_level = 0	/* a semicolon macro not embedded */
			     then do;
				     macro_stack (macro_depth).last_token = tokenx;
				     call save_environment;
				     call enter_macro_source;
				     goto source_start (MACRO_CONSTRUCT);
				end;
			     else macro_depth = macro_depth - 1;
						/* terminate it -parsed in %if later */
			end;

		goto END_ACTION;

action (18):					/* NL */
		line_number = line_number + 1;
		token_type = white_space_token;
		call make_token;

		goto END_ACTION;

END_ACTION:					/* with case statements, we wouldn't need this */
	     end /* source segment while loop */;

/* control transfers here whenever the lex reaches the end of the current source segment. */

end_of_source_reached:
	     call make_token;

end_of_source_reached_but_no_pending_token:
	     if tokenx >= hbound (token, 1)
	     then call print_error (4, "Too many tokens.", source_length);

/* output all the remaining characters in the segment */

	     call output_chars$from_source (next_char_to_print, source_length);
	     goto check_depth;

source_start (2):					/* tokens, not chars are being interpreted */
	     token_index = token_index - 1;		/* decrement so get_next_token works */
	     do while (token_index < last_token);

		call get_next_token$retain_white_space;

		if pct_type = none			/* not a pct token */
		then do;
			call make_replacement_token (token_index);
			goto END_CASE;
		     end;
		else goto parser (pct_type);

parser (1):					/* default */
		call parse_default;
		goto END_CASE;
parser (2):					/* page */
		call parse_page;
		goto END_CASE;
parser (3):					/* skip */
		call parse_skip;
		goto END_CASE;
parser (4):					/* replace */
		call parse_replace;
		goto END_CASE;
parser (5):					/* error */
		call parse_error;
		goto END_CASE;
parser (6):					/* isdef */
		call parse_isdef;
		goto END_CASE;
parser (7):					/* target */
		call parse_target;
		goto END_CASE;
parser (8):					/* isarg */
		call parse_isarg;
		goto END_CASE;
parser (9):					/* if */
		call parse_if;
		goto END_CASE;
parser (10):					/* then */
parser (11):					/* else */
parser (12):					/* elseif */
parser (13):					/* endif */
		call print_error (3, "Unexpected keyword.", token_start);
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
parser (14):					/* INCLUDE */
		call parse_INCLUDE;
		goto END_CASE;
parser (15):					/* include */
		call parse_include;
		goto END_CASE;
parser (16):					/* print */
		call parse_print;
		goto END_CASE;
parser (17):					/* warn */
		call parse_warn;
		goto END_CASE;
parser (18):					/* abort */
		call parse_abort;
		goto END_CASE;
parser (19):
		call parse_set;
		goto END_CASE;

END_CASE:
	     end /* while loop */;

	     last_result = tokenx;
	     call finish_up_macro;
	     goto check_depth;

PARSE_ERROR:
	     call clear_macro_frame;
	     goto check_depth;

/* having finished a source or macro, anything left on stack ? */

check_depth:
	     call enter_previous_source;

	end /* source_depth loop */;

/* having finished all sources or error of severity 4 */

unrecoverable_error:
	temp_seg_3.output_length = max (output_index, 0);
	call check_defaults;
	call macro_lex_cleanup;
	if code ^= 0 | target_error
	then code = error_table_$translation_failed;

	return;

pl1_macro_lex_$cleanup:
     entry (P_temp_segs);

	temp_segs (*) = P_temp_segs (*);
	call macro_lex_cleanup;
	return;

macro_lex_cleanup:
     procedure;

/* terminate all include files. All other storage cleanup is now done by
   throwing away the allocation segments in pl1_macro by
   translator_temp_$release_all_segments */

	declare i			 fixed binary;

	do i = 1 to temp_seg_3.source_depth;
	     if file_macro_stack (i).source_type = ASCII_SEGMENT
	     then do;
		     call hcs_$terminate_noname (file_macro_stack (i).file.source_ptr, code);
		end;
	end;
	return;
     end macro_lex_cleanup;

%include pl1_macro_token_procs;

/* Scan sequences of <digits>

   Convention:
	source_index	Entry: on character after digit
			Exit: on stopping break
*/
scan_past_digits:
     procedure;

	scan_index = verify (substr (source_string, source_index), digits);
	if scan_index = 0
	then do;
		source_index = source_length + 1;
		goto end_of_source_reached;
	     end;

	source_index = source_index + scan_index - 1;
     end scan_past_digits;

arithmetic_to_bit:
     procedure (type) returns (bit (4) aligned);
	declare type		 fixed binary (8) unsigned;
						/* INPUT: arithmetic token type */
	return (bit (binary (type - min_arithmetic_token, 4), 4));
     end arithmetic_to_bit;

bit_to_arithmetic:
     procedure (bit_encoding) returns (fixed binary (8) unsigned);
	declare bit_encoding	 bit (4) aligned;	/* INPUT: arithmetic toke type bit string encoding */
	return (binary (bit_encoding, 4) + min_arithmetic_token);
     end bit_to_arithmetic;

validate_pct_token:
     procedure (identifier, pct_type, term_type);

/* a procedure to determine if the identifier following the % is valid and which token it represents */

	declare identifier		 char (*) var;	/* INPUT: char string following the % */
	declare pct_type		 fixed binary (5) unsigned;
						/* OUTPUT: index of valid keyword */
	declare term_type		 fixed binary;	/* OUTPUT: terminator of this macro construct */

	declare indx		 fixed binary;

	pct_type = none;
	term_type = none;

	do indx = lbound (pct_keywords, 1) to hbound (pct_keywords, 1) while (pct_type = none);
	     if identifier = pct_keywords (indx).name
	     then do;
		     pct_type = pct_keywords (indx).m_index;
		     term_type = pct_keywords (indx).terminator;
		end;
	end /* do loop */;

/* if the identifier is not recognized, pct_type is set to none */

     end validate_pct_token;

check_defaults:
     procedure;

/* a procedure to insure that all params have been declared in a %default statement */

	declare a_ptr		 pointer;

	a_ptr = temp_seg_3.variable_base;
	do while (a_ptr ^= null);
	     if a_ptr -> variable.variable_type = parameter_var
	     then call print_error$null (2, "The parameter " || a_ptr -> variable.name || " has no default value.");
	     a_ptr = a_ptr -> variable.next;
	end;

     end check_defaults;

set_default_flag:
     procedure (var_id);

	declare var_id		 pointer;		/* INPUT: id of variable returned by lookup */

	var_id -> variable.variable_type = default_var;

     end set_default_flag;

reset_variable_alias:
     procedure (var_id, alias_id);

	declare var_id		 pointer;		/* INPUT: id of var as returned by lookup */
	declare alias_id		 fixed binary;	/* INPUT: index of token with new replacement value */

	var_id -> variable.alias_id = alias_id;

     end reset_variable_alias;

output_chars:
     procedure (charsz);

	declare charsz		 character (*) /* INPUT: chars to be output */;
	declare bump		 fixed binary (21);

	bump = length (charsz);
	call test_length;
	substr (output_string, output_index + 1, bump) = charsz;
	goto bump_length;

output_chars$token:
     entry (token_id);

	declare token_id		 fixed binary;	/*INPUT: index of token in its array */
	declare based_token_string	 char (token (real_token).string_size) based (token (real_token).string_ptr);
	declare real_token		 fixed binary;

	if token (token_id).replace_by = none
	then real_token = token_id;
	else real_token = token (token_id).replace_by;

	bump = token (real_token).string_size;
	call test_length;
	substr (output_string, output_index + 1, bump) = based_token_string;
	goto bump_length;

output_chars$based:
     entry (ch_ptr, num_of_chars);

	declare ch_ptr		 pointer /* INPUT: pointer to a based string */;
	declare num_of_chars	 fixed binary (21) /* INPUT: lenght of above */;
	declare based_output_string	 character (num_of_chars) based (ch_ptr);
	bump = num_of_chars;
	call test_length;
	substr (output_string, output_index + 1, bump) = based_output_string;
	goto bump_length;


output_chars$from_source:
     entry (from_char, to_char);

	declare from_char		 fixed binary (21) /* INPUT: index in source indicating start */;
	declare to_char		 fixed binary (21); /*INPUT: indicating end */
	bump = to_char - from_char + 1;
	call test_length;
	substr (output_string, output_index + 1, bump) = substr (source_string, from_char, bump);
	goto bump_length;

bump_length:
	output_index = output_index + bump;
	return;

test_length:
     procedure;

	if output_index + bump > output_length
	then call print_error (4, "Output segment overflow", source_index);

     end test_length;

     end output_chars;

enter_source_segment:
     procedure (bv_source_ptr, bv_source_length, bv_file_number);

/* Internal procedure to set some global variables each time a new source segment is entered */

/* parameters */

	declare (
	        bv_source_ptr	 ptr,		/* ptr to base of source segment */
	        bv_source_length	 fixed bin (21),	/* length in chars of source segment */
	        bv_file_number	 fixed bin (8)	/* number of new source file */
	        )			 parameter;

	source_type = ASCII_SEGMENT;
	source_ptr = bv_source_ptr;
	source_length = bv_source_length;
	source_index = 1;
	token_start = 1;
	line_number = 1;
	next_char_to_print = 1;
	temp_seg_3.source_depth = temp_seg_3.source_depth + 1;
	source_number = source_number + 1;
	macro_ptr = allocate (temp_seg_3.area_ptr, size (macro_stack));
	macro_depth = 0;
	nested_if_level = 0;

     end enter_source_segment;

enter_macro_source:
     procedure;

/* by analogy to enter_source_segment, to set global variables when entering a macro string for the 1st time */

	source_type = MACRO_CONSTRUCT;
	token_index = macro_stack (macro_depth).token_index;
	last_token = macro_stack (macro_depth).last_token;
	next_free_token = token_index - 1;
	first_result = tokenx + 1;
	last_result = tokenx;
	reinterpret = FALSE;
	temp_seg_3.source_depth = temp_seg_3.source_depth + 1;

     end enter_macro_source;

save_environment:
     procedure;

/* when we are about to leave an environment prematurely, i.e. before  the last character or token is seen,
   save our location so we can pop back in */

	if temp_seg_3.source_depth > hbound (file_macro_stack, 1)
	then call print_error (4, "Include files and macros nested too deeply.", token_start);

	if source_type = ASCII_SEGMENT
	then do;
		file_macro_stack (temp_seg_3.source_depth).source_type = ASCII_SEGMENT;
		file_macro_stack (temp_seg_3.source_depth).file.source_ptr = source_ptr;
		file_macro_stack (temp_seg_3.source_depth).file.source_index = source_index;
		file_macro_stack (temp_seg_3.source_depth).file.source_length = source_length;
		file_macro_stack (temp_seg_3.source_depth).file.line_number = line_number;
		file_macro_stack (temp_seg_3.source_depth).file.file_number = file_number;
		file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print = source_index;
		file_macro_stack (temp_seg_3.source_depth).file.macro_depth = macro_depth - 1;
		file_macro_stack (temp_seg_3.source_depth).file.macro_ptr = macro_ptr;
		file_macro_stack (temp_seg_3.source_depth).file.nested_if_level = nested_if_level;
		unspec (file_macro_stack (temp_seg_3.source_depth).macro) = ""b;
	     end;
	else do;
		file_macro_stack (temp_seg_3.source_depth).source_type = MACRO_CONSTRUCT;
		file_macro_stack (temp_seg_3.source_depth).macro.token_index = token_index;
		file_macro_stack (temp_seg_3.source_depth).macro.last_token = last_token;
		file_macro_stack (temp_seg_3.source_depth).macro.first_result = first_result;
		file_macro_stack (temp_seg_3.source_depth).macro.last_result = last_result;
		unspec (file_macro_stack (temp_seg_3.source_depth).file) = ""b;
	     end;
	return;
     end save_environment;

enter_previous_source:
     procedure;

/* when we have finished processing an include file or macro, this pops us back */
	if source_type ^= ASCII_SEGMENT
	then if reinterpret
	then goto reinterpret_this_macro;

	temp_seg_3.source_depth = temp_seg_3.source_depth - 1;
	if temp_seg_3.source_depth < 0
	then return;

	source_type = file_macro_stack (temp_seg_3.source_depth).source_type;
	if source_type = ASCII_SEGMENT		/* popping to primary or include file */
	then do;
		source_ptr = file_macro_stack (temp_seg_3.source_depth).file.source_ptr;
		source_index = file_macro_stack (temp_seg_3.source_depth).file.source_index;
		source_length = file_macro_stack (temp_seg_3.source_depth).file.source_length;
		line_number = file_macro_stack (temp_seg_3.source_depth).file.line_number;
		file_number = file_macro_stack (temp_seg_3.source_depth).file.file_number;
		next_char_to_print = file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print;
		macro_ptr = file_macro_stack (temp_seg_3.source_depth).file.macro_ptr;
		macro_depth = file_macro_stack (temp_seg_3.source_depth).file.macro_depth;
		nested_if_level = file_macro_stack (temp_seg_3.source_depth).file.nested_if_level;
	     end;

	else do;					/* previous was a macro */
reinterpret_this_macro:
		token_index = file_macro_stack (temp_seg_3.source_depth).macro.token_index;
		last_token = file_macro_stack (temp_seg_3.source_depth).macro.last_token;
		first_result = file_macro_stack (temp_seg_3.source_depth).macro.first_result;
		last_result = file_macro_stack (temp_seg_3.source_depth).macro.last_result;
		reinterpret = FALSE;
	     end;
	return;

     end enter_previous_source;

/* Centralize lex error reporting. */

print_error:
     procedure (severity, error_string, error_index);

	declare severity		 fixed binary (35); /* (Input) severity of error */
	declare error_string	 char (*);	/* (Input) error message */
	declare error_index		 fixed binary (21); /* (Input) index into source where error occured */

	call pl1_macro_error_ (severity, error_string, source_ptr, source_index, source_length);
	goto print_error_common;

print_error$null:
     entry (severity, error_string);
	call pl1_macro_error_ (severity, error_string, null, 0, 0);
	goto print_error_common;

print_error_common:
	if severity >= 4
	then goto unrecoverable_error;
     end print_error;

parse_if:
     procedure;

	declare logical_expected	 bit (1);
	declare conditional_true	 bit (1);

/* syntax: %if <expression> %then <tokens>
	 [%elseif <expression> %then <tokens>]...
	 [%else <tokens>] %endif		*/

	call get_next_token;
	logical_expected = TRUE;
	do while (logical_expected & token_index < last_token);

/* first evaluate the conditional after the %if or %elseif */

	     call parse_expression (result_first, code);

	     if code ^= 0
	     then goto PARSE_ERROR;

/* the expression  must resolve to a bit_string constant */

	     if token (result_first).type ^= bit_string
	     then do;
		     call print_error (2, "Wrong data type in %if", token_start);
		     code = SEMANTIC_ERROR;
		     goto PARSE_ERROR;
		end;

	     conditional_true = (bit_value (result_first) ^= ""b);

/* next token had better be a %then */

	     if token_type = white_space_token
	     then call get_next_token;
	     if token (token_index).pct_type ^= pct_then
	     then do;
		     call print_error (3, "Missing keyword: %then", token_start);
		     code = SYNTAX_ERROR;
		     goto PARSE_ERROR;
		end;

	     if conditional_true
	     then do;

/* get the tokens till the %elseif, %else, or %endif at the same level
   skip the rest of the   %if construct */

		     call get_this_clause;
		     logical_expected = FALSE;
		end;

	     else do;

/* conditional is false - skip then-clause 
   if terminating keyword an %else, get the tokens -  elseif it is %elseif, goto top of loop
   elseif it is an %endif, stop - else an error  */

		     call skip_this_clause;
		     if pct_type = pct_endif
		     then logical_expected = FALSE;

		     else if pct_type = pct_else
		     then do;
			     call get_this_clause;
			     logical_expected = FALSE;
			end;

		     else if pct_type ^= pct_elseif
		     then do;
			     call print_error (3, "Illegal syntax in a %if.", token_start);
			     code = SYNTAX_ERROR;
			     goto PARSE_ERROR;
			end;

		     else call get_next_token;
		end /* conditional false */;
	end /* while loop */;

/* if loop terminated without and %endif, an error has ooccurred */

	if pct_type ^= pct_endif
	then do;
		call print_error (3, "Missing %endif.", token_start);
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
	     end;
	return;

skip_this_clause:
     procedure;

	declare action_type		 fixed binary;
	declare if_level		 fixed binary;
	declare terminating_keyword	 bit (1) aligned;
	declare GET_THIS_CLAUSE	 fixed binary internal static options (constant) initial (1);
	declare SKIP_THIS_CLAUSE	 fixed binary internal static options (constant) initial (2);
	declare SKIP_THE_REST	 fixed binary internal static options (constant) initial (3);

	action_type = SKIP_THIS_CLAUSE;
	goto common_skip;

get_this_clause:
     entry;
	action_type = GET_THIS_CLAUSE;
	goto common_skip;

common_skip:					/* quit when at the same if_level after finding a relevant keyword and 

   if skipping then clauses, stop on else at same level */
	if_level = 1;
	do while (if_level > 0 & token_index <= last_token);

	     call get_next_token$retain_white_space;

	     terminating_keyword = if_level = 1 & (pct_type = pct_elseif | pct_type = pct_else | pct_type = pct_endif);
	     if pct_type = pct_if
	     then if_level = if_level + 1;

	     else if pct_type = pct_endif
	     then if_level = if_level - 1;

	     goto what_next (action_type);

what_next (1):					/* GET_THIS_CLAUSE: when getting a THEN or ELSE clause, we've reached the end when we find a terminating keyword
   at the inital if level.  if not at the end, make a replacement token. */
	     if terminating_keyword
	     then action_type = SKIP_THE_REST;
	     else call make_replacement_token (token_index);
	     goto end_of_loop;

what_next (2):					/* SKIP THIS CLAUSE: skip over all the tokens until we come to a terminating_keyword at the initial if-level */
	     if terminating_keyword
	     then return;
	     else goto end_of_loop;

what_next (3):					/* SKIP_THE_REST: skip over all tokens till the if-level is back to ZERO */
	     goto end_of_loop;

end_of_loop:
	end /* while loop */;

     end skip_this_clause;

     end parse_if;

parse_target:
     procedure;

	declare alias		 fixed binary;
	declare cannon_name		 char (32);
	declare entry_type		 fixed binary;
	declare error_seen		 bit (1);
	declare not_found		 bit (1) aligned;
	declare result_token	 fixed binary;
	declare saved_token_start	 fixed binary (21);
	declare t_code		 fixed binary (35);
	declare t_value		 fixed binary (17);
	declare target_string	 char (256);
	declare var_id		 pointer;

	entry_type = pct_target;

/* if %target used and no -target control arg, set the default and set as error */

	if target_value = none
	then do;
		target_error = TRUE;
		target_value = L68_SYSTEM;
		call print_error (2, "%target used without use of -target control arg. L68 assumed.", token_start);
	     end;

	goto common_parse;

parse_isarg:
     entry;

	entry_type = pct_isarg;
	goto common_parse;

parse_isdef:
     entry;

	entry_type = pct_isdef;
	goto common_parse;

common_parse:
	error_seen = FALSE;
	saved_token_start = token_start;

	if token_index < last_token
	then call get_next_token;
	else do;
		call print_error (3, "Incomplete macro statement", saved_token_start);
		goto TARGET_ERROR;
	     end;

	if token_type ^= left_parn
	then do;
		call print_error (3, "Missing left_parentheis in macro-builtin", saved_token_start);
		error_seen = TRUE;
	     end;

	if token_index < last_token
	then call get_next_token;
	else do;
		call print_error (3, "Incomplete macro statement", saved_token_start);
		goto TARGET_ERROR;
	     end;

	target_string = substr (token_ptr -> based_chars, 1, token_length);

	if entry_type = pct_target
	then do;
		call system_type_ (target_string, cannon_name, t_value, t_code);
		if t_value = target_value
		then result_token = TRUE_token;
		else result_token = FALSE_token;
	     end;
	else if entry_type = pct_isarg
	then do;

/* because the command line processor passes any char string as an arg, and the macro only looks at pl1 tokens, for 
   "wierd" arguments, i.e. non-pl1 tokens, users must quote them to get recognized by the lexer, otherwise, the
   raw character string itself suffices, IF it is a SINGLE pl1 token.
   The curious code below occurs because dequote_string_ and system_type_ want char (*), but we would much rather 
   use varying character strings, to kill the terminal blanks.
*/

		if token_type = char_string
		then target_string = dequote_string_ (rtrim (target_string));

		not_found = TRUE;
		do i = 1 to number_of_clargs while (not_found);
		     not_found =
			(target_string
			^=
			substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1,
			temp_seg_3.cl_args (i).string_size));
		end;

		if not_found
		then result_token = FALSE_token;
		else result_token = TRUE_token;
	     end;
	else do;					/* isdef */
		call lookup ((target_string), alias, var_type, var_id);
		if alias = none
		then result_token = FALSE_token;
		else result_token = TRUE_token;
	     end;

	if token_index < last_token
	then call get_next_token;
	else do;
		call print_error (3, "Incomplete macro statement", saved_token_start);
		goto TARGET_ERROR;
	     end;

	if token_type ^= right_parn
	then do;
		error_seen = TRUE;
		call print_error (3, "Incomplete macro statement", saved_token_start);
	     end;

	if error_seen
	then do;
TARGET_ERROR:
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
	     end;
	else call make_replacement_token (result_token);

     end parse_target;

parse_replace:
     procedure;

	declare alias		 fixed binary;
	declare entry_name		 char (8) varying;
	declare equals		 fixed binary;
	declare previous_var_type	 fixed binary;
	declare t_type		 fixed binary;
	declare var_id		 pointer;
	declare var_name		 character (256) varying;
	declare var_type		 fixed binary;

/* format: off */
	declare 1 magic_words (4) aligned structure internal static options (constant),
		2 statement_type character (9) varying 
initial (
	     "replace",	 "default",     "set",     "parameter"),

		2 preposition character (2) 
initial (
	     "by",	"to",	     "to",        "..");
/* format: on */

/* syntax : %replace <identifier> by <expression>; 
	  %default <identifier> to <expression>;
	  %set <identifier> to <expression>;
*/

	var_type = replace_var;
	goto common_parse;

parse_default:
     entry;

	var_type = default_var;
	goto common_parse;

parse_set:
     entry;

	var_type = set_var;
	goto common_parse;

common_parse:
	entry_name = magic_words (var_type).statement_type;

	call get_next_token;

	if token_type ^= identifier
	then do;
		call print_error (3, "The subject of a %" || entry_name || " must be an identifier.", token_start);
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
	     end;

	var_name = token_string;
	call lookup (var_name, alias, previous_var_type, var_id);

	call get_next_token;
	if token_string ^= magic_words (var_type).preposition
	then do;
		call print_error (3, "Illegal syntax in a %" || entry_name, token_start);
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
	     end;

	call get_next_token;
	call parse_expression (result_first, code);
	if code ^= 0
	then goto PARSE_ERROR;

/* this token must be copied, for in deeply nested macros, its token number is reusaed */

	result_first = copy_token (result_first);

	if token_type = white_space_token
	then call get_next_token;
	if token_type ^= semi_colon
	then do;
		call print_error (3, "A %" || entry_name || " statement must end with a semicolon.", token_start);
		code = SYNTAX_ERROR;
		goto PARSE_ERROR;
	     end;

	if alias = none				/* not previously defined */
	then call create_variable (var_name, result_first, var_type);

	else if var_type ^= previous_var_type		/* already declared in a different mode */
	then do;

/* OKAY to appear in a different mode if previous was a parameter and this is its default statement */

		if previous_var_type = parameter_var & var_type = default_var
		then call set_default_flag (var_id);
		else call print_error (3,
			"The variable " || var_name || " may not appear in a %" || entry_name
			|| " after appearing in a %" || magic_words (previous_var_type).statement_type, token_start)
			;
	     end;

	else do;					/* previously declared in the same mode */
		t_type = op_mix (alias, result_first) /*  check for same data type and equal value */;

/* the old and new values must alwasy have the same data type, and if default or replace, the same value */

		if t_type = 0			/* different types */
		then do;

test_redefine (0):					/* different  types */
			call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start);
			code = SEMANTIC_ERROR;
			goto PARSE_ERROR;
		     end;

		equals = fixed (eq);

		if var_type = set_var
		then do;
			call reset_variable_alias (var_id, result_first);
			return;
		     end;
		else goto test_redefine (t_type);

test_redefine (1):					/* dec_integer */
		if ^compare_numbers (equals, alias, result_first)
						/* redefined to a different integer */
		then do;
			call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start);
			code = SEMANTIC_ERROR;
			goto PARSE_ERROR;
		     end;
		return;

test_redefine (2):					/* bit_string */
		if ^compare_bit_strings (equals, alias, result_first)
		then do;
			call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start);
			code = SEMANTIC_ERROR;
			goto PARSE_ERROR;
		     end;
		return;

test_redefine (3):					/* char_string */
		if ^compare_chars (equals, alias, result_first)
		then do;
			call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start);
			code = SEMANTIC_ERROR;
			goto PARSE_ERROR;
		     end;
		return;

test_redefine (4):					/*  identifier */
		if ^same_identifier (alias, result_first)
		then do;
			call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start);
			code = SEMANTIC_ERROR;
			goto PARSE_ERROR;
		     end;
		return;
	     end;


copy_token:
     procedure (original_token) returns (fixed binary);
	declare original_token	 fixed binary /* token to be copied */;

	if replacement_token_index <= tokenx
	then call print_error$null (4, "Too many tokens.");

	token (replacement_token_index) = token (original_token);
	token (replacement_token_index).created = TRUE;
	replacement_token_index = replacement_token_index - 1;
	return (replacement_token_index + 1);

     end copy_token;

%include pl1_macro_compare_procs;
%include pl1_macro_dtype_procs;

     end parse_replace;

parse_page:
     procedure;

/*  syntax: %page [(<dec_integer>)];  also for skip 
    handled by compiler, just diagnose and parrot back in stand alone */

	declare entry_type		 character (4);
	declare saved_token_index	 fixed binary;

	entry_type = "page";
	goto page_skip;

parse_skip:
     entry;

	entry_type = "skip";
	goto page_skip;

page_skip:
	saved_token_index = token_index;
	code = 0;

	call get_next_token;

	if token_type ^= semi_colon
	then do;
		if token_type ^= left_parn
		then code = SYNTAX_ERROR;

		call get_next_token;
		if token_type ^= dec_integer
		then code = SYNTAX_ERROR;

		call get_next_token;
		if token_type ^= right_parn
		then code = SYNTAX_ERROR;

		call get_next_token;
		if token_type ^= semi_colon
		then code = SYNTAX_ERROR;
	     end;

	if code ^= 0
	then do;
		call print_error (3, "Illegal syntax in %" || entry_type, token_start);
		goto PARSE_ERROR;
	     end;
	else do i = saved_token_index to token_index;
		call make_replacement_token (i);
	     end;

	return;
     end parse_page;

parse_include:
     procedure;

	declare saved_token_index	 fixed binary;
	declare saved_token_start	 fixed binary (21);
	declare entry_name		 char (7);
	declare include_file_name	 char (32) varying;
	declare include_file_length	 fixed binary (21);
	declare include_file_ptr	 pointer;
	declare i			 fixed binary;
	declare bitcount		 fixed binary (24);

	entry_name = "include";
	goto INCLUDE_COMMON;

parse_INCLUDE:
     entry;

	entry_name = "INCLUDE";
	goto INCLUDE_COMMON;

INCLUDE_COMMON:
	saved_token_index = token_index;
	saved_token_start = token_start;
	code = 0;

	call get_next_token;

	if token_type = identifier
	then include_file_name = token_string;
	else if token_type = char_string
	then include_file_name = dequote_string_ (token_string);
	else code = SYNTAX_ERROR;

	call get_next_token;
	if token_type ^= semi_colon
	then code = SYNTAX_ERROR;

	if code ^= 0
	then do;
		error_message = "Invalid syntax in %" || entry_name;
		call print_error (3, (error_message), saved_token_start);
		goto PARSE_ERROR;
	     end;
	else if entry_name = "include"
	then do i = saved_token_index to token_index;
		call make_replacement_token (i);
	     end;

	else do;					/* INCLUDE */
		if length (include_file_name) > 24
		then do;
			call print_error (3, "Include file name too long.", saved_token_start);
			code = STORAGE_SYSTEM_ERROR;
			goto PARSE_ERROR;
		     end;

		if file_number > source_list_length
		then do;
			call print_error (3, "Too many include files.", saved_token_start);
			code = IMPLEMENTATION_RESTRICTION;
			goto PARSE_ERROR;
		     end;

		if temp_seg_3.source_depth > hbound (file_macro_stack, 1)
		then do;
			call print_error (3, "Include files and macros nested too deeply.", saved_token_start);
			code = IMPLEMENTATION_RESTRICTION;
			goto PARSE_ERROR;
		     end;

		include_file_name = include_file_name || ".incl.pl1";
		call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount,
		     include_file_ptr, code);

		if include_file_ptr = null ()
		then do;
			error_message = "Include file: " || include_file_name || " not found.";
			call print_error (3, (error_message), saved_token_start);
			code = STORAGE_SYSTEM_ERROR;
			goto PARSE_ERROR;
		     end;
		else if code ^= 0
		then call com_err_ (code, command, "^a", include_file_name);
		call save_environment;
		file_number = file_number + 1;
		include_file_length = divide (bitcount + 8, 9, 24, 0);
		call enter_source_segment (include_file_ptr, include_file_length, file_number);
		goto source_start (ASCII_SEGMENT);

	     end;

	return;
     end parse_include;

parse_error:
     procedure;

	declare entry_type		 fixed binary (5) unsigned;
	declare error_level		 fixed binary (35);
	declare error_seen		 bit (1) aligned;
	declare error_message_token	 fixed binary;
	declare saved_token_start	 fixed binary (21);

	entry_type = pct_error;
	error_level = 3;
	goto message_common;

parse_warn:
     entry;
	entry_type = pct_warn;
	error_level = 1;
	goto message_common;

parse_abort:
     entry;
	entry_type = pct_abort;
	error_level = 4;
	goto message_common;

parse_print:
     entry;
	entry_type = pct_print;
	error_level = 0;
	goto message_common;

message_common:
	error_seen = FALSE;
	saved_token_start = token_start;

	if token_index < last_token
	then call get_next_token;
	else do;
		call print_error (3, "Incomplete macro statement", saved_token_start);
		goto message_error;
	     end;

	call parse_expression (error_message_token, code);
	if code ^= 0
	then goto message_error;

	if token (error_message_token).type ^= char_string
	then do;
		call print_error (3, "Macro user messages must be character strings", saved_token_start);
		goto message_error;
	     end;

	if token_type = white_space_token
	then call get_next_token;

	if token_type ^= semi_colon
	then do;
		call print_error (3, "Macro user messages must end in a semicolon", saved_token_start);
		goto message_error;
	     end;

	if entry_type = pct_print
	then call ioa_ (char_value (error_message_token));
	else call print_error$null (error_level, char_value (error_message_token));
	return;

message_error:
	code = SYNTAX_ERROR;
	goto PARSE_ERROR;

     end parse_error;

%include pl1_macro_next_token;

create_char_token:
     procedure (char_value) returns (fixed binary);
	declare char_value		 char (*);	/* INPUT: the name of the identifier */
	declare t_ptr		 pointer;
	declare t_type		 fixed binary (8) unsigned;
	declare chars		 char (256) varying;

	t_type = char_string;
	chars = char_value;
	goto create_common;

create_identifier_token:
     entry (char_value) returns (fixed binary);
	t_type = identifier;
	chars = requote_string_ (char_value);
	goto create_common;

create_bit_token:
     entry (b_value) returns (fixed binary);
	declare b_value		 bit (*);
	t_type = bit_string;
	chars = QUOTE || char (b_value) || QUOTE || "b" /* give it pl1 representation */;
	goto create_common;

create_arith_token:
     entry (a_value) returns (fixed binary);
	declare a_value		 fixed binary (71);
	t_type = dec_integer;
	chars = ltrim (char (a_value));
	goto create_common;

create_common:
	constant_length = length (chars);
	if t_type = char_string & constant_length > max_char_string_constant
	then do;
		call print_error$null (2, "Character-string constant too long.");
		return (none);
	     end;
	else if t_type = bit_string & constant_length > max_bit_string_constant
	then do;
		call print_error$null (2, "Bit-string constant too long.");
		return (none);
	     end;
	else if t_type = identifier & constant_length > max_identifier_length
	then do;
		call print_error$null (2, "Identifier too long.");
		return (none);
	     end;
	if replacement_token_index <= tokenx
	then do;
		call print_error$null (4, "Too many tokens.");
		return (none);
	     end;

	t_ptr = allocate (temp_seg_3.area_ptr, size (constant));
	t_ptr -> constant.next = temp_seg_3.constant_base;
	token (replacement_token_index).string_size, t_ptr -> constant.string_length = constant_length;
	token (replacement_token_index).type = t_type;
	t_ptr -> string_value = chars;
	token (replacement_token_index).string_ptr = addr (t_ptr -> constant.string_value);
	token (replacement_token_index).created = TRUE;
	token (replacement_token_index).pct_type = none;
	token (replacement_token_index).replace_by = none;
	replacement_token_index = replacement_token_index - 1;
	temp_seg_3.constant_base = t_ptr;
	return (replacement_token_index + 1);

     end create_char_token;

%include pl1_macro_value_procs;

parse_expression:
     procedure (result_token, code);

	declare result_token	 fixed binary;	/* OUTPUT: index of token in which result is placed */
	declare code		 fixed binary (35); /* OUTPUT: status code */

	declare stack_index		 fixed binary;	/* top of stack */
	declare opindex		 fixed binary;	/* location of operator in op_table */
	declare (operand1, operand2)	 fixed binary;	/* token offsets of the two operands */
	declare result		 fixed binary;	/* token offset of result */
	declare stack		 (0:64) fixed binary;

/* format: off */
	declare precedence		 (0:24) fixed binary (15) internal static options (constant) 
initial (
				 (5) 0,		/* illegal */
				 5,		/* +, plus */
				 5,		/* -, minus */
				 6,		/* *, asterisk */
				 6,		/* /, slash */
				 7,		/* **, expon */
				 7,		/* ^, not */
				 2,		/* &, and */
				 1,		/* |, or */
				 4,		/* ||, cat */
				 3,		/* =, eq	*/
				 3,		/* ^=, ne */
				 3,		/* <, lt */
				 3,		/* >, gt */
				 3,		/* <=, le */
				 3,		/* >=, ge */
				 3,		/* ^>, ngt */
				 3,		/* ^<, nlt */
				 7,		/* +, unary plus */
				 7,		/* -, unary minus */
				 3);		/* =, assignment */
/* format: on */

	stack_index = 0;
	stack (0) = primitive ();

FETCHOP:
CHECKOP:
	if token_type = white_space_token
	then call get_next_token;
	if (token_type <= max_delimiter_token) & (token_type >= min_delimiter_token) & (token_type <= assignment)
	then do;					/* i.e. relational and arith operator */

		if token_type = not			/* unary operators handled by primitive */
		then do;
			call print_error (3, "Invalid syntax in expression", source_index);
			goto EXP_PARSE_FAIL;
		     end;

		if stack_index ^= 0			/* check precedence is not first operator */
		then do;
			opindex = token (stack (stack_index - 1)).type;
			if precedence (opindex) >= precedence (token_type)
			then goto UNSTACK;
		     end;

STACKOP:
		stack_index = stack_index + 1;
		stack (stack_index) = token_index;
		stack_index = stack_index + 1;
		call get_next_token;
		if token_index > last_token
		then do;
			call print_error (3, "Invalid syntax in expression.", source_index);
			goto EXP_PARSE_FAIL;
		     end;
		stack (stack_index) = primitive ();
		goto FETCHOP;

	     end;

	if stack_index = 0
	then goto SUCCESS;
	opindex = token (stack (stack_index - 1)).type;

UNSTACK:
	operand1 = stack (stack_index - 2);
	operand2 = stack (stack_index);

	result = evaluate (opindex, operand1, operand2);

	if result = none
	then do;
		call print_error (3, "Semantically incorrect expression.", source_index);
		goto EXP_PARSE_FAIL;
	     end;

POP:
	stack_index = stack_index - 2;
	stack (stack_index) = result;

	goto CHECKOP;

EXP_PARSE_FAIL:
	result_token = none;
	code = -1;
	return;

SUCCESS:
	result_token = stack (0);
	code = 0;
	return;

primitive:
     procedure returns (fixed binary);

/* calling conventions: token_index points to the current token, token_type been set properly.
   on return token_index will point the the next token (possibly white space) in the input sequence */


	declare next_tk		 fixed binary;	/* value of token returned by recursive calls */
	declare saved_token_index	 fixed binary;	/* index of token at entry */

	saved_token_index = token_index;

	if token_type = plus			/* unary plus */
	then do;
		call get_next_token;
		next_tk = primitive ();

		if token (next_tk).type = dec_integer
		then return (next_tk);
		else do;
			call print_error (3, "Invalid syntax in expression.", source_index);
			goto PRIMITIVE_FAIL;
		     end;
	     end;

	else if token_type = minus			/*unary minus */
	then do;
		call get_next_token;
		next_tk = primitive ();

		if token (next_tk).type = dec_integer
		then return (create_arith_token (-arith_value (next_tk)));
		else do;
			call print_error (3, "Invalid syntax in expression.", source_index);
			goto PRIMITIVE_FAIL;
		     end;
	     end;

	else if token_type = not
	then do;
		call get_next_token;
		next_tk = primitive ();

		if token (next_tk).type = bit_string
		then return (create_bit_token (^bit_value (next_tk)));
		else do;
			call print_error (3, "Invalid syntax in expression.", source_index);
			goto PRIMITIVE_FAIL;
		     end;
	     end;

	else if token_type = left_parn
	then do;
		call get_next_token;
		call parse_expression (result, code);

		if code ^= 0
		then goto PRIMITIVE_FAIL;
		if token_type = white_space_token
		then call get_next_token;
		if token_type ^= right_parn
		then do;
			call print_error (3, "Invalid syntax in expression.", source_index);
			goto PRIMITIVE_FAIL;
		     end;
		else do;
			call get_next_token$retain_white_space;
			return (result);
		     end;
	     end;

	else if (token_type <= max_constant_token & token_type >= min_constant_token) | (token_type = identifier)
	then do;
		if token_type = identifier & token (saved_token_index).replace_by ^= none
		then saved_token_index = token (saved_token_index).replace_by;
		call get_next_token$retain_white_space;
		return (saved_token_index);
	     end;

	else do;
		code = -1;
		call print_error (3, "Invalid syntax in expression.", source_index);
		return (none);
	     end;

PRIMITIVE_FAIL:
	goto EXP_PARSE_FAIL;
     end primitive;

%include pl1_macro_next_token;

evaluate:
     procedure (P_operation, P_op1, P_op2) returns (fixed binary);

	declare P_operation		 fixed binary;	/* INPUT: arithemtic or logicl op */
	declare (P_op1, P_op2)	 fixed binary;	/* INPUT: the operands */

/* given an op_code and two operands, return the index of the token
node created with the result stored there */

	declare (fixedoverflow, overflow, zerodivide, underflow, error, stringrange)
				 condition;
	declare (op1, op2, operation)	 fixed binary;
	declare temp_chars		 character (256);

	op1 = P_op1;
	op2 = P_op2;
	operation = P_operation;

	on fixedoverflow goto FIXEDOVERFLOW;
	on overflow goto OVERFLOW;
	on zerodivide goto ZERODIVIDE;
	on underflow goto UNDERFLOW;
	on error goto ERROR;
	on stringrange goto STRINGRANGE;

	if operation < lbound (eval_action, 1) | operation > hbound (eval_action, 1)
	then do;
		call print_error (3, "Illegal operator in expression.", source_index);
		return (none);
	     end;
	goto eval_action (operation);

eval_action (0):					/* illegal  op */
eval_action (1):
eval_action (2):
eval_action (3):
eval_action (4):
eval_action (10):					/*  unary not */
eval_action (22):					/* unary plus */
eval_action (23):					/* unary minus */
	call print_error (3, "Illegal operator in expression.", source_index);
	return (none);

eval_action (5):					/* plus */
	if both_arithmetic (op1, op2)
	then return (create_arith_token (arith_value (op1) + arith_value (op2)));
	else do;
		call eval_err ("+");
		return (none);
	     end;
eval_action (6):					/* minus */
	if both_arithmetic (op1, op2)
	then return (create_arith_token (arith_value (op1) - arith_value (op2)));
	else do;
		call eval_err ("-");
		return (none);
	     end;
eval_action (7):					/* times */
	if both_arithmetic (op1, op2)
	then return (create_arith_token (arith_value (op1) * arith_value (op2)));
	else do;
		call eval_err ("*");
		return (none);
	     end;

eval_action (8):					/* divide */
	if both_arithmetic (op1, op2)
	then return (create_arith_token (arith_value (op1) / arith_value (op2)));
	else do;
		call eval_err ("/");
		return (none);
	     end;
eval_action (9):					/* expon */
	if both_arithmetic (op1, op2)
	then return (create_arith_token (arith_value (op1) ** arith_value (op2)));
	else do;
		call eval_err ("**");
		return (none);
	     end;

eval_action (11):					/* & (and) */
	if both_bit_string (op1, op2)
	then return (create_bit_token (bit_value (op1) & bit_value (op2)));
	else do;
		call eval_err ("&");
		return (none);
	     end;

eval_action (12):					/* | (or) */
	if both_bit_string (op1, op2)
	then return (create_bit_token (bit_value (op1) | bit_value (op2)));
	else do;
		call eval_err ("|");
		return (none);
	     end;
eval_action (13):					/* || (concat)*/
	if both_char_string (op1, op2)
	then do;
		temp_chars = requote_string_ (char_value (op1) || char_value (op2));
		return (create_char_token (rtrim (temp_chars)));
	     end;
	else do;
		call eval_err ("||");
		return (none);
	     end;

eval_action (14):					/* = (equals relation ) */
eval_action (15):					/*  ^= (not_equal) */
eval_action (16):					/* < (less than) */
eval_action (17):					/* > (greater than) */
eval_action (18):					/* <= (lessthan or equal to ) */
eval_action (19):					/* >= (greater than or equal to */
eval_action (20):					/* ^> (ngt) */
eval_action (21):					/* ^< (nlt) */
eval_action (24):					/* assignment = */
	goto operand_types (op_mix (op1, op2));

operand_types (0):					/* operands of different types */
	call print_error (3, "Different data types in a relational expression.", source_index);
	return (none);
operand_types (1):					/* both arithmetic */
	if compare_numbers (operation, op1, op2)
	then return (TRUE_token);
	else return (FALSE_token);

operand_types (2):					/* both bit_string */
	if compare_bit_strings (operation, op1, op2)
	then return (TRUE_token);
	else return (FALSE_token);

operand_types (3):					/* both character */
	if compare_chars (operation, op1, op2)
	then return (TRUE_token);
	else return (FALSE_token);

operand_types (4):					/* both identifier */
	if operation = eq | operation = assignment
	then do;
		 if same_identifier (op1, op2)
		 then return (TRUE_token);
		 else return (FALSE_token);
	     end;
	else if operation = ne
	then do;
		if same_identifier (op1, op2)
		then return (FALSE_token);
		else return (TRUE_token);
	     end;
	else do;
		call eval_err ("current");
		return (none);
	     end;

FIXEDOVERFLOW:
	call print_error$null (2, "Fixedoverflow condition: result undefined");
	return (none);

OVERFLOW:
	call print_error$null (2, "Overflow condition: result undefined");
	return (none);

ZERODIVIDE:
	call print_error$null (2, "Zerodivide condition: result undefined");
	return (none);

UNDERFLOW:
	call print_error$null (2, "Underflow condition: result undefined");
	return (none);

ERROR:
	call print_error$null (2, "Error condition: result undefined");
	return (none);

STRINGRANGE:
	call print_error$null (2, "Stringrange condition: result undefined");
	return (none);

eval_err:
     procedure (message_chars);
	declare message_chars	 char (*);
	error_message = "Illegal data types for the " || message_chars || " operation.";
	call print_error (3, (error_message), source_index);
     end eval_err;

%include pl1_macro_dtype_procs;

%include pl1_macro_compare_procs;

     end evaluate;

     end parse_expression;

bump_macro_stack:
     procedure (start_tk, variety);
	declare start_tk		 fixed binary /* INPUT: first token in macro */;
	declare variety		 fixed binary /* INPUT: macro_type */;

	if macro_depth > hbound (macro_stack, 1)
	then call print_error (4, "Macros nested too deeply.", char_offset_ ((token (start_tk).string_ptr)));

	macro_depth = macro_depth + 1;
	macro_stack (macro_depth).type = variety;
	macro_stack (macro_depth).token_index = start_tk;
	macro_stack (macro_depth).last_token = 0;
	macro_stack (macro_depth).first_result = none;
	macro_stack (macro_depth).last_result = none;
	macro_stack (macro_depth).else_seen = FALSE;

     end bump_macro_stack;

clear_macro_frame:
     procedure;

	tokenx = macro_stack (macro_depth).token_index;
	macro_depth = 0;

     end clear_macro_frame;

finish_up_macro:
     procedure;

	declare tokn		 fixed binary;

/* thread in replacement strings fro this macro - i.e. replace the tokens for the macro by the tokens it generates */

	tokenx = next_free_token;
	reinterpret = FALSE;

	do tokn = first_result to last_result while (tokn ^= none);
	     call make_replacement_token (tokn);
	     reinterpret = reinterpret | needs_reinterpretation (tokn);
	end;

	if reinterpret
	then do;

/* what is now the first-result becomes the first_token in the string to reinterpret, similarly for last_token and last_result.
   so, set first_result above the minimal value of last result. */

		file_macro_stack (temp_seg_3.source_depth).token_index = first_result;
		file_macro_stack (temp_seg_3.source_depth).last_token = last_result;
		file_macro_stack (temp_seg_3.source_depth).first_result = tokenx + 1;
		file_macro_stack (temp_seg_3.source_depth).last_result = tokenx;
		return;
	     end;

	else if macro_depth = 1			/* not imbedded */
	then do;
		call print_token_string (first_result, last_result);
	     end;
	macro_depth = macro_depth - 1;
	return;

     end finish_up_macro;

print_token_string:
     procedure (first, last);

	declare (first, last)	 fixed binary /* first and last token to print */;
	declare ix		 fixed binary;

	do ix = first to last while (ix ^= none);
	     call output_chars$token (ix);
	end;

     end print_token_string;

needs_reinterpretation:
     procedure (tknx) returns (bit (1));

	declare tknx		 fixed binary /* INPUT: index of token */;
	declare t_type		 fixed binary (5) unsigned;

/* may need reinterpretation if a pct token but not skip page and include in stand alone mode */

	t_type = token (tknx).pct_type;
	if t_type = none
	then return (FALSE);
	else if t_type = pct_skip | t_type = pct_page | t_type = pct_include
	then return (FALSE);
	else return (TRUE);

     end needs_reinterpretation;
%page;
create_variable:
     procedure (var_name, alias_token, var_type);
	declare var_name		 char (*) var;	/* INPUT: name of var to be created */
	declare alias_token		 fixed binary;	/* INPUT: index of token of variable's alias */
	declare var_type		 fixed binary;	/* INPUT: mode of declaration */
						/* OUTPUT: type of statement in which variable declared */

	declare v_ptr		 pointer;

/* assumed that the caller has checked that this variable name is not duplicated - use lookup for this.
   create a variable node for this var_name and stuff in the node the name,
   the token to which it refers and then chain it on the list */

/* automatic */

declare	(hash_index, i, n, n_chars, n_words) fixed bin,
	mod_2_sum bit (36) aligned,
	four_chars char (4) aligned,
	protected bit (18) aligned,
	(old_q, q, p, variable_string_ptr) ptr;

/* based */

declare	variable_array_overlay (64) char (4) based (variable_string_ptr),
	variable_overlay char (n) based (variable_string_ptr);

/* builtins */

declare	(addr, binary, bool, dim, divide, length, mod, null, substr, unspec) builtin;

/* program */

	variable_string_ptr = addr (substr (var_name, 1));

	n = length (var_name);
	n_words = divide (n, 4, 21, 0);
	n_chars = n - n_words * 4;
	mod_2_sum = ""b;

	do i = 1 to n_words;
	     four_chars = variable_array_overlay (i);
	     mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
	end;

	if n_chars ^= 0
	then do;
		four_chars = substr (variable_array_overlay (i), 1, n_chars);
		mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
	     end;

	hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1));
	old_q = null;

	do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null);
	     if n < q -> variable.name_length
	     then go to insert_variable;

	     if variable_overlay = q -> variable.name
		then do;
		return;
	     end;
	     old_q = q;
	end;

insert_variable:
	variable_name_length = length (var_name);
	v_ptr = allocate (temp_seg_3.area_ptr, size (variable));

	v_ptr -> variable.name_length = variable_name_length;
	v_ptr -> variable.name = var_name;
	v_ptr -> variable.alias_id = alias_token;
	v_ptr -> variable.variable_type = var_type;
	v_ptr -> variable.nextv = q;
	v_ptr -> variable.next = temp_seg_3.variable_base;
	temp_seg_3.variable_base = v_ptr;

	if old_q = null
	then hash_table (hash_index) = v_ptr;
	else old_q -> variable.nextv = v_ptr;
	return;
%page;
lookup:
     entry (var_name, alias, var_type, var_id);

	declare alias		 fixed binary;	/* OUTPUT: index of alias token, if any */
	declare var_id		 pointer;		/* OUTPUT: id of var, used in altering properties of variable */

/* given an identifier name, determine if it has been defined - 
   if so, return as its alias, the index of token to which it evaluates
   else return none 

   var_id and var_type are only meaningful if alias ^= none.
   possible values for var_type are:
   default_var, replace_var, parameter_var, and set_var.
*/

	alias, var_type = none;
	var_id = null;

	variable_string_ptr = addr (substr (var_name, 1));

	n = length (var_name);
	n_words = divide (n, 4, 21, 0);
	n_chars = n - n_words * 4;
	mod_2_sum = ""b;

	do i = 1 to n_words;
	     four_chars = variable_array_overlay (i);
	     mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
	end;

	if n_chars ^= 0
	then do;
		four_chars = substr (variable_array_overlay (i), 1, n_chars);
		mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
	     end;

	hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1));
	old_q = null;

	do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null);
	     if variable_overlay = q -> variable.name
		then do;
		     alias = q -> variable.alias_id;
		     var_type = q -> variable.variable_type;
		     var_id = q;
		end;
	end;
	if var_name = "set_opt" | var_name = "symbol_update_at" then do;
	     return;
	end;
	return;
     end create_variable;
%include translator_temp_alloc;
     end pl1_macro_lex_;





		    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
