



		    create_data_segment.pl1         05/18/90  1156.2rew 05/18/90  1154.7       88569



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





/****^  HISTORY COMMENTS:
  1) change(90-04-23,Huen), approve(90-04-23,MCR8156), audit(90-04-27,Gray),
     install(90-05-17,MR12.4-1009):
     lang_11: Use cv_entry to find the segment so that cds will work even when
     the working dir is not in the search rules.
  2) change(90-05-18,Huen), approve(90-05-18,MCR8156), audit(90-05-18,Gray),
     install(90-05-18,MR12.4-1010):
     Post bug fix (lang_11) : to avoid passing an entryname to pathname_ that
     exceeds 32 characters.
                                                   END HISTORY COMMENTS */



/* This program is a command interface to the create_data_segment_ subroutine.
   It creates a link in the process directory named <unique_name>.pl1 to the
   segment <source_name>.cds in the working directory and calls the PL/I
   compiler to compile the program.  The compiler is invoked with the -table
   control argument.  If the -list create_data_segment control argument is
   specified, the name <unique_name>.list (same <unique_name> as above) is
   added to the entry <source_name>.list so the listing segment is created
   appropriately, and the compiler is invoked with the -map control argument.

   The format of a CDS source segment is a PL/I program with a call to the
   create_data_segment_ subroutine.  The name given to the create_data_segment
   command is the entry point used to call the program.  The argument passed
   to create_data_segment_ internally as the name of the segment to be created
   should be this same name to preserve Multics conventions on names of
   created object segments.

   Initial coding: 11/20/75 by S. Webber
   Bug with ".cds" names fixed 07/30/76 by B. Greenberg
   MCR 3343 -- Error message bug fixed 19 July 1978 by M. Davidoff.
   Modified 27 February 1981 by M. N. Davidoff to fix bug in which random
	names are added to the working directory if -list is not specified.
*/
/* format: style2 */
create_data_segment:
cds:
     procedure options (variable);

/* automatic */

	dcl     arg_count		 fixed bin;
	dcl     argument_no		 fixed bin;
	dcl     1 ca		 aligned,
		2 list		 bit (1);
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     list_ca		 char (8);
	dcl     listp		 ptr;
	dcl     pdir		 char (168);
	dcl     seg_ptr		 ptr;
	dcl     source		 char (32);
	dcl     source_cds		 char (32);
	dcl     source_dir		 char (168);
	dcl     source_list		 char (32);
	dcl     tc		 fixed bin (21);
	dcl     tp		 ptr;
	dcl     unique		 char (15);
	dcl     unique_list		 char (32);
	dcl     unique_pl1		 char (32);
	dcl     wdir		 char (168);

/* based */

	dcl     targ		 char (tc) based (tp);

/* builtin */

	dcl     (addr, after, divide, index, null, reverse, rtrim, substr)
				 builtin;

/* condition */

	dcl     cleanup		 condition;

/* internal static */

	dcl     command		 char (19) internal static options (constant) initial ("create_data_segment");
	dcl     NP		 char (1) internal static options (constant) initial ("");

/* external static */

	dcl     error_table_$badopt	 fixed bin (35) external static;
	dcl     pl1_severity_	 fixed bin (35) external static;

/* entry */

	dcl     com_err_		 entry options (variable);
	dcl     com_err_$suppress_name entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry);
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     form_link_info_	 entry (ptr, fixed bin (35));
	dcl     get_pdir_		 entry returns (char (168));
	dcl     get_wdir_		 entry returns (char (168));
	dcl     hcs_$append_link	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     ioa_$nnl		 entry options (variable);
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     pl1		 entry options (variable);
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

%include terminate_file;

/* program */

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, command);
		return;
	     end;

	argument_no = 0;
	ca = ""b;
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, tp, tc, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", i);
		     return;
		end;

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

	     else if index (targ, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", targ);
		     return;
		end;

	     else do;
		     argument_no = argument_no + 1;

		     if argument_no = 1
		     then do;
			     call expand_pathname_$add_suffix (targ, "cds", source_dir, source_cds, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, command, "^a", targ);
				     return;
				end;
			end;
		end;
	end;

	if argument_no ^= 1
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a path {-control_args}", command);
		return;
	     end;

	source = reverse (after (reverse (source_cds), reverse (".cds")));
	source_list = rtrim (source) || ".list";

	unique = unique_chars_ (""b);
	unique_pl1 = unique || ".pl1";
	unique_list = unique || ".list";

	listp, seg_ptr = null;
	wdir = get_wdir_ ();
	pdir = get_pdir_ ();

	on cleanup call clean_up_segs;

/* Make sure the source segment is there. */

	call hcs_$initiate (source_dir, source_cds, "", 0, 1, seg_ptr, code);
	if seg_ptr = null
	then do;
		call com_err_ (code, command, "^a^[>^]^a", source_dir, source_dir ^= ">", source_cds);
		return;
	     end;

	call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, code);

	call translate_cds_source_segment;
	call clean_up_segs;

	return;

translate_cds_source_segment:
     procedure;

/* Link to source program */

	call hcs_$append_link (pdir, unique_pl1, rtrim (source_dir) || ">" || source_cds, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Appending link ^a^[>^]^a to ^a^[>^]^a.", pdir, pdir ^= ">", unique_pl1,
		     source_dir, source_dir ^= ">", source_cds);
		return;
	     end;

	if ca.list
	then do;
		call hcs_$chname_file (wdir, source_list, "", unique_list, code);
		list_ca = "-map";
	     end;
	else list_ca = "-table";

	call ioa_$nnl ("CDS - ");
	call pl1 (rtrim (pdir) || ">" || unique, "-table", list_ca);

	if pl1_severity_ > 2
	then call com_err_ (0, command, "PL/I errors occured.");

	else begin;
		dcl     entry_var		 entry variable;
		entry_var = cv_entry_ ((pathname_ (wdir, unique) || "$" || source), null, code);
		if code ^= 0
		then do;
			call com_err_ (code, command, "^a$^a", unique, source);
			return;
		     end;

		call entry_var;
	     end;

	if ca.list
	then begin;
		dcl     bc		 fixed bin (24);
		dcl     1 fli_args		 aligned,
			2 obj_ptr		 ptr,
			2 list_ptr	 ptr,
			2 list_bc		 fixed bin (24),
			2 hd_sw		 bit (1) unaligned,
			2 ln_sw		 bit (1) unaligned,
			2 et_sw		 bit (1) unaligned,
			2 lk_sw		 bit (1) unaligned,
			2 lg_sw		 bit (1) unaligned;

		dcl     listing_file	 char (divide (bc, 9, 21)) based (listp);

		call hcs_$initiate_count (wdir, unique_list, "", bc, 1, listp, code);
		if listp = null
		then do;
			call com_err_ (code, command, "^a^[>^]^a", wdir, wdir ^= ">", unique_list);
			return;
		     end;

		bc = bc + 9;
		substr (listing_file, divide (bc, 9, 21), 1) = NP;

		call hcs_$initiate (wdir, source, "", 0, 1, seg_ptr, code);
		if seg_ptr = null
		then do;
			call com_err_ (code, command, "^a^[>^]^a", wdir, wdir ^= ">", source);
			call com_err_ (0, command, "Check arguments to the call of create_data_segment_ in ^a.",
			     source_cds);
			return;
		     end;

		fli_args.obj_ptr = seg_ptr;
		fli_args.list_ptr = listp;
		fli_args.list_bc = bc;
		fli_args.hd_sw = "1"b;
		fli_args.ln_sw = "1"b;
		fli_args.et_sw = "1"b;
		fli_args.lk_sw = "1"b;
		fli_args.lg_sw = "0"b;

		call form_link_info_ (addr (fli_args), code);
		if code ^= 0
		then do;
			call com_err_ (code, command, "Getting link information for ^a^[>^]^a.", wdir, wdir ^= ">",
			     source);
			return;
		     end;

		call terminate_file_ (listp, fli_args.list_bc, TERM_FILE_TRUNC_BC_TERM, code);
	     end;
     end translate_cds_source_segment;

clean_up_segs:
     procedure;

	call hcs_$delentry_file (pdir, unique_pl1, code);
	call hcs_$delentry_file (wdir, unique, code);

	call hcs_$chname_file (wdir, unique_list, unique_list, source_list, code);
	if code ^= 0
	then call hcs_$chname_file (wdir, unique_list, unique_list, "", code);

	call terminate_file_ (listp, 0, TERM_FILE_TERM, code);
	call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, code);
     end clean_up_segs;

     end create_data_segment;




		    create_data_segment_.pl1        05/17/90  1515.5rew 05/17/90  1511.5      207927



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




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-09-04,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to fix definition threading to not thread definition header into
     backward definition thread and overwrite msf_map_relp value in def header.
  2) change(90-04-23,Huen), approve(90-04-23,MCR8166), audit(90-04-27,Gray),
     install(90-05-17,MR12.4-1009):
     lang_13: Warn users if a level 2 element which is not aligned on a word
     boundary is used.
                                                   END HISTORY COMMENTS */


/* create_data_segment_: A standard object segment generator which uses
   runtime pl1 structure definitions as templates for defining data segment
   segdefs.

   Oct. 15, 1975 by Bernard S. Greenberg.
   Even source map bug, random pad words fixed 7/30/76 by BSG
   Runtime symbol simple bit treated properly -- 12/16/76 BSG
   improved searching for block using return ptr -- 11/07/78 JRDavis
   Fixed bug in creating data segments without text sections -- 2 Oct 1980 Chris Jones
   Fixed bug in call to stu_$decode_runtime_value -- 8 October 1980 M. N. Davidoff
   Changed to use date_time_$format -- 06/19/84 J A Falksen
*/
/* format: style2 */
create_data_segment_:
     procedure (infoptr, rcode);

	dcl     rcode		 fixed bin (35);
	dcl     myname		 char (32) internal static options (constant) init ("create_data_segment_");
	dcl     (infop, infoptr)	 ptr;
	dcl     stucode		 fixed bin;
	dcl     (slen, tlen, llen)	 fixed bin (19);
	dcl     movdef		 bit (1) aligned;
	dcl     (hp, smp, osmp, osymp, defp, class3ptr)
				 ptr;
	dcl     (
	        DEF		 init (1),
	        DEFR		 init (2),
	        LNKR		 init (3),
	        SYMR		 init (4),
	        TXTR		 init (5)
	        )			 fixed bin internal static options (constant);

	dcl     scrps		 (5) ptr;
	dcl     1 relinfo		 aligned based,
		2 decl_version	 fixed bin,
		2 n_bits		 fixed bin;

	dcl     1 rloc		 aligned based (rlocp),
		2 words		 (0:9999) unal,
		  3 (l, r)	 bit (18);

	dcl     1 vrloc		 aligned based (ptr (rlocp, next)) like rloc;
	dcl     rp		 ptr,
	        b18u		 bit (18) unaligned based;

	dcl     (putp, rlocp)	 ptr;
	dcl     1 acc		 aligned based,
		2 acc1		 unal,
		  3 acclen	 fixed bin (8) unal,
		  3 accstr	 char (4 refer (acc.acclen)) unal;
	dcl     (tptr, sptr, lptr)	 ptr;
	dcl     error_table_$translation_failed
				 external fixed bin (35);
	dcl     tssi_$get_segment	 entry (char (*), char (*), ptr, ptr, fixed bin (35));
	dcl     get_temp_segments_	 entry (char (*), (*) ptr, fixed bin (35));
	dcl     release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
	dcl     get_wdir_		 entry returns (char (168));
	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35));
	dcl     check_star_name_$entry entry (char (*), fixed bin (35));
	dcl     tssi_$finish_segment	 entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
	dcl     (now, dtmc)		 fixed bin (71);
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	dcl     1 oi		 like object_info aligned;
	dcl     strptr		 ptr;
	dcl     i			 fixed bin;
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     tssi_$clean_up_segment entry (ptr);
	dcl     cleanup		 condition;

	dcl     sgp		 ptr,
	        aclip		 ptr;
	dcl     dhp		 ptr;
	dcl     (opp, smrcp)	 ptr;
	dcl     copy		 (copylen) bit (36) aligned based;
	dcl     copylen		 fixed bin (19);
	dcl     wordl		 fixed bin;
	dcl     n			 fixed bin;
	dcl     bc		 fixed bin (24);
	dcl     get_group_id_	 entry returns (char (32));
	dcl     prevdef		 ptr;
	dcl     pv		 ptr;
	dcl     next		 fixed bin (18);
	dcl     ojnxt		 fixed bin (18);
	dcl     zeroword		 fixed bin (18);
	dcl     bword		 bit (36) based;
	dcl     strcopy		 char (copylen) based;
	dcl     strcopy1		 char (strcopy1l) based (strc1p);
	dcl     strc1p		 ptr;
	dcl     strcopy1l		 fixed bin;
	dcl     oname		 char (32);

	dcl     stu_$get_runtime_block entry (ptr, ptr, ptr, fixed bin (18));
	dcl     (header_ptr, block_ptr)
				 ptr;
	dcl     (tnode, lnode, snode)	 ptr;
	dcl     cp		 ptr;
	dcl     code		 fixed bin (35);
	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);

	dcl     com_err_		 entry options (variable);
	dcl     stu_$find_runtime_symbol
				 entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr);
	dcl     stu_$decode_runtime_value
				 entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin)
				 returns (fixed bin (35));
	dcl     (addr, addrel, bin, bit, clock, codeptr, divide, fixed, length, mod, null, ptr, rel, rtrim, size,
	        stackframeptr, substr, unspec)
				 builtin;
	dcl     (lsize, sysize, tsize, dsize, ssize)
				 fixed bin (18);
	dcl     (srel, lrel, drel, syrel)
				 fixed bin (18);

%include cds_args;
%include stack_frame;
%include definition;
%include segname_def;
%include source_map;
%include relbts;
%include object_info;
%include object_map;
%include linkdcl;
%include std_symbol_header;
%include runtime_symbol;

/* Check information supplied by caller.  Locate necessary runtime symbol nodes. */

	infop = infoptr;
	rcode = 0;

	do sp = stackframeptr () -> stack_frame.prev_sp repeat sp -> stack_frame.prev_sp
	     while (sp -> stack_frame_flags.support);
	end;
	cp = sp -> stack_frame.return_ptr;

	call stu_$get_runtime_block (sp, header_ptr, block_ptr, bin (rel (cp), 18));
	if header_ptr = null
	then do;
		call com_err_ (0, myname, "Cannot get symbol table header.");
tranfai:
		rcode = error_table_$translation_failed;
		return;
	     end;

	movdef = infop -> cds_args.defs_in_link;	/* copy bit */
	oname = infop -> cds_args.seg_name;

	if infop -> cds_args.have_text
	then do;
		tptr = infop -> cds_args.sections (1).p;
		tlen = infop -> cds_args.sections (1).len;
		tnode = find_runtime_symbol_node ("text", infop -> cds_args.sections (1).struct_name);
	     end;
	else tnode = null;

	if infop -> cds_args.have_static & infop -> cds_args.separate_static
	then do;
		sptr = infop -> cds_args.sections (2).p;
		slen = infop -> cds_args.sections (2).len;
		snode = find_runtime_symbol_node ("static", infop -> cds_args.sections (2).struct_name);
	     end;
	else snode = null;

	if infop -> cds_args.have_static & ^infop -> cds_args.separate_static
	then do;
		lptr = infop -> cds_args.sections (2).p;
		llen = infop -> cds_args.sections (2).len;
		lnode = find_runtime_symbol_node ("linkage", infop -> cds_args.sections (2).struct_name);
	     end;
	else lnode = null;

/* Check legitimacy of all star names */

	do i = 1 to infop -> cds_args.num_exclude_names;
	     call check_star_name_$entry (infop -> cds_args.exclude_array_ptr -> exclude_names (i), code);
	     if code < 0 | 2 < code
	     then do;
		     call com_err_ (code, myname, "^a", infop -> cds_args.exclude_array_ptr -> exclude_names (i));
		     go to tranfai;
		end;
	end;

/* All parameter checks have been passed.  Now actually generate the object segment. */

	scrps (*) = null;
	aclip = null;
	on cleanup call clupper;

clupper:
     proc;
	call release_temp_segments_ (myname, scrps, code);
	if aclip ^= null
	then call tssi_$clean_up_segment (aclip);
     end clupper;

	call get_temp_segments_ (myname, scrps, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, "Getting temporary segments.");
hell:
		call clupper;
		goto tranfai;
	     end;

	call tssi_$get_segment (get_wdir_ (), oname, sgp, aclip, code);
	if sgp = null
	then do;
		call com_err_ (code, myname, "^a", oname);
		goto hell;
	     end;

/* build definitions */

	rlocp = scrps (DEFR);			/* defreloc */
	putp = scrps (DEF);				/* definitions */
	dhp = putp;
	next = 0;
	putp -> definition.new = "1"b;

	putp -> definition.ignore, putp -> definition.new = "1"b;

	rp = ptr (rlocp, next);
	rp -> definition.forward, rp -> definition.backward = rc_dp;
	vrloc (1).l, vrloc (1).r = rc_a;

	prevdef = putp;
	next = next + 2;

/* allocate the zeroword */

	putp = ptr (putp, next);

	putp -> bword = "0"b;
	vrloc (0).r, vrloc (0).l = rc_a;
	zeroword = next;

	next = next + 1;

/* put out segname */

	putp = ptr (putp, next);
	prevdef -> definition.forward = rel (putp);
	putp -> segname_def.backward = bit (bin (zeroword, 18), 18);
	putp -> segname_def.next = bit (zeroword, 18);
	prevdef = putp;
	defp = putp;
	rp = ptr (rlocp, next);
	rp -> segname_def.forward, rp -> segname_def.backward, rp -> segname_def.symbol, rp -> segname_def.defblock =
	     rc_dp;
	rp -> segname_def.next = rc_dp;
	addr (rp -> segname_def.flags) -> b18u = rc_a;

	defp -> segname_def.new = "1"b;
	defp -> segname_def.class = "011"b;
	next = next + size (segname_def);

	strptr = alloc_acc (rtrim (oname));
	defp -> definition.symbol = rel (strptr);
	class3ptr = defp;

/* define symbol_table */

	defp = putp;
	prevdef -> segname_def.defblock = rel (defp);
	prevdef -> segname_def.forward = rel (defp);
	defp -> definition.backward = rel (prevdef);
	prevdef = defp;
	defp -> definition.value = "000000000000000000"b;
	defp -> definition.class = "010"b;		/* symbol */
	defp -> definition.new = "1"b;
	defp -> definition.segname = rel (class3ptr);
	rp = ptr (rlocp, next);
	next = next + size (definition);
	defp -> definition.symbol = rel (alloc_acc ("symbol_table"));
	rp -> definition.forward, rp -> definition.backward, rp -> definition.segname, rp -> definition.symbol = rc_dp;
	rp -> definition.value = rc_s;
	addr (rp -> definition.flags) -> b18u = rc_a;

/* put out text definitions */

	if tnode = null
	then tlen, tsize = 0;
	else do;
		tsize = tlen + mod (tlen, 2);
		call generate_definitions (tnode, tptr, rc_t, 0);
	     end;

/* put out link definitions */

	if lnode = null
	then llen, lsize = 0;
	else do;
		lsize = llen + mod (llen, 2);
		call generate_definitions (lnode, lptr, rc_lp18, 1);
	     end;

/* put out static definitions */

	if snode = null
	then slen, ssize = 0;
	else do;
		ssize = slen + mod (slen, 2);
		call generate_definitions (snode, sptr, rc_is18, 4);
	     end;

	dsize = next + mod (next, 2);
	prevdef -> definition.forward = bit (zeroword, 18);

generate_definitions:
     proc (nptr, struc_ptr, gen_reloc, gen_class);
	dcl     nptr		 ptr;
	dcl     struc_ptr		 ptr;
	dcl     gen_reloc		 bit (18);
	dcl     gen_class		 fixed bin (3);

	dcl     v2		 fixed bin (35);
	dcl     point		 ptr;
	dcl     mod_tst		 (0:7) fixed bin internal static options (constant)
				 init (1, 36, 4, 2, 1, 36, 4, 8);


	do point = nptr repeat addrel (point, point -> runtime_symbol.brother);
	     code = 1;
	     do i = 1 to infop -> cds_args.num_exclude_names while (code ^= 0);
		call match_star_name_ (addrel (point, point -> runtime_symbol.name) -> acc.accstr,
		     infop -> cds_args.exclude_array_ptr -> exclude_names (i), code);
	     end;

	     if code ^= 0
	     then do;
		     if point -> runtime_symbol.bits.simple
		     then stucode, v2 = 0;
		     else do;
			     v2 = stu_$decode_runtime_value (point -> runtime_symbol.offset, block_ptr, sp, null,
				null, struc_ptr, stucode);
			     if stucode ^= 0
			     then do;
				     call com_err_ (0, myname, "stu_$decode_runtime_value complains ^d on ^a",
					stucode, addrel (point, point -> runtime_symbol.name) -> acc.accstr);
				     go to hell;
				end;
			     if mod (v2, mod_tst (fixed (point -> runtime_symbol.units))) ^= 0
			     then do;
				     call com_err_ (0, myname,
					"A level 2 element, ^a, is not word aligned and cannot be turned into an entrypoint.",
					addrel (point, point -> runtime_symbol.name) -> acc.accstr);
				     go to skip_def;
				end;
			end;

		     if gen_class = 1
		     then v2 = v2 + size (virgin_linkage_header);

		     putp = ptr (putp, next);
		     defp = putp;
		     defp -> definition.class = bit (bin (gen_class, 3), 3);
		     defp -> definition.segname = rel (class3ptr);
		     defp -> definition.value = bit (bin (v2, 18), 18);
		     defp -> definition.new = "1"b;
		     rp = ptr (rlocp, next);
		     rp -> definition.forward, rp -> definition.backward, rp -> definition.symbol = rc_dp;
		     addr (rp -> definition.flags) -> b18u = rc_a;
		     rp -> definition.value = gen_reloc;

		     next = next + size (definition);
		     defp -> definition.symbol =
			rel (alloc_acc (addrel (point, point -> runtime_symbol.name) -> acc.accstr));
		     prevdef -> definition.forward = rel (defp);
		     defp -> definition.backward = rel (prevdef);
		     prevdef = defp;
skip_def:
		end;

	     if point -> runtime_symbol.brother = "0"b
	     then return;
	end;
     end generate_definitions;

/* acc generator, which admittedly does some useless work */

alloc_acc:
     proc (cstr) returns (ptr);

	dcl     cstr		 char (*);

	putp = ptr (putp, next);			/* update ptr */
	wordl = divide (length (cstr), 4, 17, 0) + 1;
	do i = 1 to wordl;
	     vrloc (i - 1).r, vrloc (i - 1).l = rc_a;
	end;
	putp -> acc.acclen = length (cstr);
	putp -> acc.accstr = cstr;
	next = next + wordl;
	opp = putp;
	putp = ptr (putp, next);
	return (opp);
     end alloc_acc;

/* cons some junk together */

	ojnxt = 0;
	putp = ptr (sgp, ojnxt);

	if tsize > 0
	then do;
		copylen = tlen;
		putp -> copy = tptr -> copy;
		ojnxt = ojnxt + tsize;
	     end;

	if movdef
	then drel = 0;
	else do;					/* put defs in normal place */
		drel = ojnxt;
		copylen = dsize;
		putp = ptr (putp, ojnxt);
		putp -> copy = scrps (DEF) -> copy;
		ojnxt = ojnxt + dsize;
	     end;

/* Generate separate static */

	srel = ojnxt;
	if ssize > 0
	then do;
		copylen = slen;
		putp = ptr (putp, ojnxt);
		putp -> copy = sptr -> copy;
		ojnxt = ojnxt + ssize;
	     end;

	rlocp = scrps (LNKR);
	rp = rlocp;
	next = 0;

	putp = ptr (sgp, ojnxt);
	lrel = bin (rel (putp), 18);
	hp = putp;
	unspec (putp -> virgin_linkage_header) = "0"b;
	putp -> virgin_linkage_header.def_offset = bit (drel, 18);
	putp -> virgin_linkage_header.link_begin = bit (bin (lsize + size (virgin_linkage_header), 18), 18);
	putp -> virgin_linkage_header.linkage_section_lng = putp -> virgin_linkage_header.link_begin;

	next = next + size (virgin_linkage_header);
	putp = addrel (putp, size (virgin_linkage_header));

	if lsize > 0
	then do;
		copylen = llen;
		putp -> copy = lptr -> copy;
		next = next + lsize;
	     end;
	ojnxt = ojnxt + next;
	if movdef
	then do;					/* Throw defs into link-resident static */
		hp -> virgin_linkage_header.defs_in_link = "010000"b;
		hp -> virgin_linkage_header.def_offset = bit (bin (next, 18), 18);
		drel = ojnxt;
		copylen = dsize;
		putp = ptr (putp, ojnxt);
		putp -> copy = scrps (DEF) -> copy;
		hp -> virgin_linkage_header.linkage_section_lng =
		     bit (bin (bin (hp -> virgin_linkage_header.linkage_section_lng, 18) + dsize, 18), 18);
		ojnxt = ojnxt + dsize;
		next = next + dsize;
	     end;
	lsize = lsize + size (virgin_linkage_header);
	do i = 0 to next - 1;			/* link relocs */
	     rloc (i).r, rloc (i).l = rc_a;
	end;
	rp -> virgin_linkage_header.def_offset = rc_dp;
	rp -> virgin_linkage_header.link_begin = rc_lp18;

/* Create symbol section */

	syrel = ojnxt;
	putp = ptr (sgp, ojnxt);
	rlocp = scrps (SYMR);

	next = 0;
	dtmc, now = clock ();
	pv = ptr (codeptr (create_data_segment_), 0);

	call hcs_$status_mins (pv, 0, bc, code);
	if code = 0
	then do;
		oi.version_number = object_info_version_2;
		call object_info_$brief (pv, bc, addr (oi), code);
		if code = 0
		then dtmc = oi.symbp -> std_symbol_header.object_created;
	     end;

	hp = putp;
	hp -> std_symbol_header.dcl_version = 1;
	hp -> std_symbol_header.identifier = "symbol_t";
	hp -> std_symbol_header.gen_number = 1;
	hp -> std_symbol_header.gen_created = dtmc;
	hp -> std_symbol_header.object_created = now;
	hp -> std_symbol_header.generator = "cds";
	next = size (std_symbol_header);
	putp = addrel (hp, next);
	call putstr ("create_data_segment_, Version II of "
	     || date_time_$format ("^dn, ^mn ^dm, ^9999yc", dtmc, "", ""), hp -> std_symbol_header.gen_version,
	     rlocp -> std_symbol_header.gen_version);
	call putstr (rtrim (get_group_id_ ()), hp -> std_symbol_header.userid, rlocp -> std_symbol_header.userid);

putstr:
     proc (str, struc, rstruc);

	dcl     1 struc		 unaligned,
		2 (of, sz)	 bit (18);
	dcl     1 rstruc		 unaligned,
		2 (rof, rsz)	 bit (18);
	dcl     str		 char (*);

	sz = bit (bin (length (str), 18), 18);
	wordl = divide (length (str) + 3, 4, 17, 0);
	rof, rsz = rc_a;				/* I take no responsibility for this lie */
	copylen = length (str);
	putp = addrel (hp, next);
	of = bit (bin (bin (rel (putp), 18) - bin (rel (hp), 18), 18), 18);
	putp -> strcopy = str;
	next = next + wordl;
	putp = addrel (hp, next);
     end putstr;

/* copy other guy's source map */

	cp = ptr (cp, 0);
	call hcs_$status_mins (cp, 0, bc, code);
	if code = 0
	then do;
		oi.version_number = object_info_version_2;
		call object_info_$brief (cp, bc, addr (oi), code);
	     end;

	osymp = oi.symbp;
	osmp = addrel (osymp, osymp -> std_symbol_header.source_map);
	next = next + mod (next, 2);			/* source map gotta be even */
	hp -> std_symbol_header.source_map = bit (bin (next, 18), 18);
	putp = addrel (hp, next);
	smp = putp;
	smp -> source_map.version = osmp -> source_map.version;
	smp -> source_map.number = osmp -> source_map.number;
	smrcp = ptr (rlocp, next);
	n = smp -> source_map.number;
	next = size (smp -> source_map) + next;
	putp = addrel (hp, next);
	do i = 1 to smp -> source_map.number;
	     strc1p = addrel (osymp, osmp -> source_map.offset (i));
	     strcopy1l = bin (osmp -> source_map.size (i), 18);
	     call putstr (strcopy1, smp -> source_map.pathname (i), smrcp -> source_map.pathname (i));
	     smp -> source_map.dtm (i) = osmp -> source_map.dtm (i);
	     smp -> source_map.uid (i) = osmp -> source_map.uid (i);
	end;

/* generate symbol section relocation */

	rp = scrps (SYMR);
	rp -> std_symbol_header.source_map, rp -> std_symbol_header.area_pointer, rp -> std_symbol_header.rel_text,
	     rp -> std_symbol_header.rel_def, rp -> std_symbol_header.rel_symbol, rp -> std_symbol_header.rel_link =
	     rc_s;

	hp -> std_symbol_header.maxi_truncate, hp -> std_symbol_header.mini_truncate = bit (bin (next, 18), 18);
	hp -> std_symbol_header.text_boundary, hp -> std_symbol_header.stat_boundary = bit (bin (2, 18), 18);
	putp = addrel (hp, next);
	if ^movdef
	then do;
		call relbits (hp -> std_symbol_header.rel_text, tsize, scrps (TXTR));
		call relbits (hp -> std_symbol_header.rel_def, dsize, scrps (DEFR));
		call relbits (hp -> std_symbol_header.rel_link, lsize, scrps (LNKR));
		call relbits (hp -> std_symbol_header.rel_symbol, (next), scrps (SYMR));
	     end;
	sysize = next;
	ojnxt = ojnxt + next;

/* generate the object_map */

	putp = ptr (sgp, ojnxt);
	unspec (putp -> object_map) = "0"b;
	putp -> object_map.decl_vers = object_map_version_2;
	putp -> object_map.identifier = "obj_map";
	putp -> object_map.text_length = bit (bin (tsize, 18), 18);
	putp -> object_map.definition_offset = bit (bin (drel, 18), 18);
	putp -> object_map.definition_length = bit (bin (dsize, 18), 18);
	putp -> object_map.linkage_offset = bit (bin (lrel, 18), 18);
	if movdef
	then putp -> object_map.linkage_length = bit (bin (lsize + dsize, 18), 18);
	else putp -> object_map.linkage_length = bit (bin (lsize, 18), 18);
	if ssize > 0
	then do;
		putp -> object_map.static_offset = bit (bin (srel, 18), 18);
		putp -> object_map.static_length = bit (bin (ssize, 18), 18);
		putp -> object_map.separate_static = "1"b;
	     end;
	else do;
		putp -> object_map.static_offset = bit (bin (lrel + size (virgin_linkage_header), 18), 18);
		putp -> object_map.static_length = bit (bin (lsize - size (virgin_linkage_header), 18), 18);
	     end;
	putp -> object_map.symbol_offset = bit (bin (syrel, 18), 18);
	putp -> object_map.symbol_length = bit (bin (sysize, 18), 18);
	putp -> object_map.break_map_offset, putp -> object_map.break_map_length = "0"b;
	putp -> object_map.standard = "1"b;
	putp -> object_map.relocatable = ^movdef;
	putp = addrel (putp, size (object_map));
	next = bin (rel (putp), 18);
	putp -> map_ptr = bit (bin (next - size (object_map), 18), 18);
	next = next + 1;
	call tssi_$finish_segment (sgp, 36 * next, "1"b, aclip, code);
	aclip = null;
	if code ^= 0
	then call com_err_ (code, myname, "Finishing up segment.");

	call clupper;

	return;

find_runtime_symbol_node:
     procedure (section, structure_name) returns (ptr);

	dcl     section		 char (*);	/* (Input) */
	dcl     structure_name	 char (*) aligned;	/* (Input) */

	dcl     node		 ptr;

	dcl     stufail		 (-5:-1) char (32) internal static options (constant)
				 initial ("Symbol reference is ambiguous", "No declaration found",
				 "Name too long", "More than 64 structure levels", "Block pointer is null");

	node = stu_$find_runtime_symbol (block_ptr, rtrim (structure_name), null, stucode);
	if stucode < 0
	then do;
		call com_err_ (0, myname, "^a for ^a section structure ^a", stufail (stucode), section,
		     structure_name);
		goto tranfai;
	     end;

	if node -> runtime_symbol.son = ""b
	then do;
		call com_err_ (0, myname, "Symbol ^a for ^a section is not a structure.", structure_name, section);
		goto tranfai;
	     end;

	if node -> runtime_symbol.ndims ^= ""b
	then do;
		call com_err_ (0, myname, "Symbol ^a for ^a section is an array.", structure_name, section);
		goto tranfai;
	     end;

	return (addrel (node, node -> runtime_symbol.son));
     end find_runtime_symbol_node;

/* The great relocation hacker */

relbits:
     proc (relans, words, rptr);
	dcl     rhp		 ptr;
	dcl     relans		 bit (18) unal,
	        words		 fixed bin (18),
	        rptr		 ptr;
	dcl     bitstr		 bit (1000000) based (putp) aligned;
	dcl     bitpos		 fixed bin init (1);

	putp -> relinfo.decl_version = 2;
	rhp = putp;
	next = next + size (relinfo);
	putp = addrel (hp, next);

	do i = 0 to words - 1;
	     call irloc (rptr -> rloc (i).l);
	     call irloc (rptr -> rloc (i).r);
	end;

irloc:
     proc (rfld);
	dcl     rfld		 bit (18) unaligned;
	if rfld = "0"b
	then do;
		substr (bitstr, bitpos, 1) = "0"b;
		bitpos = bitpos + 1;
	     end;
	else do;
		substr (bitstr, bitpos, 5) = substr (rfld, 14, 5);
		bitpos = bitpos + 5;
	     end;
     end irloc;

	rhp -> relinfo.n_bits = bitpos - 1;
	bitpos = bitpos + mod (bitpos, 36);
	bitpos = divide (bitpos, 36, 18, 0);
	next = next + bitpos;
	relans = bit (bin (bin (rel (rhp), 18) - bin (rel (hp), 18), 18), 18);
	putp = addrel (putp, bitpos);
     end relbits;

     end create_data_segment_;




		    extract_message_doc.pl1         11/15/82  1845.8rew 11/15/82  1516.1       37737



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


extract_message_doc: proc;

/* EXTRACT_MESSAGE_DOC - Find error message documentation in source program comment.

   THVV 4/77 */

dcl  i fixed bin;
dcl  ap ptr, al fixed bin, bchr char (al) based (ap) unal;
dcl  me char (19) static options (constant) init ("extract_message_doc");
dcl  segp ptr;
dcl  scc fixed bin (21);
dcl  iocbp ptr;
dcl  bitc fixed bin (24);
dcl  ec fixed bin (35);
dcl  dn char (168);
dcl  en char (32);
dcl  target char (168);
dcl  acptr ptr;
dcl  acsw bit (1) init ("0"b);
dcl  bfsw bit (1) init ("0"b);

dcl  extract_msg_doc_ entry (char (*), ptr, fixed bin (21), ptr, fixed bin (35));

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2),
     ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5),
     ptr, fixed bin (35));
dcl  archive_util_$first_disected entry (ptr, ptr, char (32), fixed bin (24), fixed bin (35));
dcl  archive_util_$disected_element entry (ptr, ptr, char (32), fixed bin (24), fixed bin (35));

dcl  error_table_$badopt fixed bin (35) ext;

dcl (divide, index, length, null, rtrim, substr, verify) builtin;
dcl  cleanup condition;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er1:	     call com_err_ (ec, me, "");
	     return;
	end;
	call expand_pathname_ (bchr, dn, en, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, me, "^a", bchr);
	     return;
	end;
	call hcs_$initiate_count (dn, en, "", bitc, 1, segp, ec);
	if segp = null then do;
er:	     call com_err_ (ec, me, "^a>^a", dn, en);
	     return;
	end;
	if index (en, ".archive") ^= 0 then do;
	     acsw = "1"b;
	     acptr = segp;
	     call archive_util_$first_disected (acptr, segp, en, bitc, ec);
	     if ec ^= 0 then go to er;
	end;
	scc = divide (bitc, 9, 17, 0);

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then go to er1;
	call absolute_pathname_ (bchr, target, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "^a", bchr);
	     go to exit;
	end;
	call iox_$attach_ioname (unique_chars_ ("0"b), iocbp,
	     "vfile_ " || target || " -extend", ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, me, "Attaching to ^a", target);
	     go to exit;
	end;
	call iox_$open (iocbp, 2, "1"b, ec);

	call cu_$arg_ptr (3, ap, al, ec);
	if ec = 0 then
	     if bchr = "-brief" | bchr = "-bf" then bfsw = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, me, "^a", bchr);
		go to wump;
	     end;

	on cleanup begin;
	     call iox_$close (iocbp, 0);
	     call iox_$detach_iocb (iocbp, 0);
	end;

nxac:	call extract_msg_doc_ (en, segp, scc, iocbp, ec);
	if ec = 1
	then if bfsw then;
	     else call com_err_ (0, me, "Documentation missing in ^a", en);
	else if ec ^= 0 then call com_err_ (ec, me, "Error extracting documentation from ^a", en);
	if acsw then do;
	     call archive_util_$disected_element (acptr, segp, en, bitc, ec);
	     if ec = 0 then do;
		scc = divide (bitc, 9, 17, 0);
		go to nxac;
	     end;
	end;

wump:	call iox_$close (iocbp, ec);
	call iox_$detach_iocb (iocbp, ec);
exit:	call hcs_$terminate_noname (segp, ec);

     end extract_message_doc;




		    extract_msg_doc_.pl1            05/22/86  1422.5rew 05/22/86  1419.2       57969



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




/****^  HISTORY COMMENTS:
  1) change(86-05-22,Martinson), approve(86-05-22,MCR7412),
     audit(86-05-22,GJohnson), install(86-05-22,MR12.0-1060):
     Improve error message searching and fix bugs in search hueristics.
                                                   END HISTORY COMMENTS */


extract_msg_doc_: proc (segname, segp, lth, iocbp, ec);

/* This procedure extracts message documentation coded in a conventional way
   out of the source of a program. The extracted information is marked for
   sorting and editing and appended to an output file.

   THVV 3/77
   Improved by R. Holmstedt 9/82 to find more error messages.
*/

dcl  segname char (*),				/* Parameters. Name of segment being scanned */
     segp ptr,					/* Ptr to input */
     lth fixed bin (21),				/* Lth of input */
     iocbp ptr,					/* Ptr to output */
     ec fixed bin (35);				/* status code */

/* ec = 1 means no documentation but has call to a logging subroutine
   ec = 2 means has BEGIN but no end
   ec = 3 means has BEGIN - END but no Message:
   any other ec came from vfile_
   */

dcl  START char (28) static options (constant) init ("BEGIN MESSAGE DOCUMENTATION
");
dcl  END char (25) static options (constant) init ("END MESSAGE DOCUMENTATION");
dcl  NL char (1) static options (constant) init ("
");
dcl  NLNL char (2) static options (constant) init ("

");
dcl  NL_QUOTE_NL_QUOTE char (4) static options (constant) init ("
""
""");
dcl  MSG char (9) static options (constant) init ("Message:
");

dcl (beginning_of_documentation, doc_block_size, cur_msg_index, errmess_lth) fixed bin (21);
dcl (pfx_lth, msg_block_start, msg_block_lth) fixed bin (21);
dcl  pfx char (32) var;				/* Chars to discard at begin of each line */

dcl  segment char (lth) based (segp);			/* Input */

dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

dcl (addr, index, length, reverse, substr, verify) builtin;

	ec = 1;
	beginning_of_documentation = index (segment, START);   /* Scan for BEGIN */
	if beginning_of_documentation = 0 then do;
	     call check_calls;			/* Check if any logging */
	     return;				/* Error 1 no message documentation or Error 0 no */
	     end;					/* message documentation because no logging calls */
	ec = 2;					/* Check Error 2 - Message block has not end      */
	beginning_of_documentation = beginning_of_documentation + length (START);
	doc_block_size = index (substr (segment, beginning_of_documentation), END);	/* Find END. */
	if doc_block_size = 0 then return;
	ec = 3;

	cur_msg_index = index (substr (segment, beginning_of_documentation, doc_block_size), MSG);     /* Find header */
	if cur_msg_index = 0 then do;
	     call check_calls;			/* Check if any logging */
	     return;				/* Error 3, empty message block or Error 0, empty message */
	     end;					/* block because no logging calls	        */
	ec = 0;					/* All is well			        */
	msg_block_start = beginning_of_documentation+cur_msg_index-1;
	pfx_lth = index (reverse (substr (segment, 1, msg_block_start-1)), NL)-1;
	pfx = substr (segment, msg_block_start-pfx_lth, pfx_lth);

	do while (cur_msg_index < doc_block_size);
	     cur_msg_index = cur_msg_index + length (MSG);
	     msg_block_start = beginning_of_documentation+cur_msg_index-1;
	     msg_block_lth = index (substr (segment, msg_block_start, doc_block_size-cur_msg_index+1), MSG)-1;
	     if msg_block_lth <= 0 then msg_block_lth = doc_block_size-cur_msg_index;
	     errmess_lth = index (substr (segment, msg_block_start, msg_block_lth-1), NLNL); /* Standard end of message PL/I source */
	     if errmess_lth = 0 then
	     errmess_lth = index (substr (segment, msg_block_start, msg_block_lth-1), NL_QUOTE_NL_QUOTE);	/* Standard end of message ALM source */
	     if errmess_lth > 0 then do;
		call putc ("[");
		call iox_$put_chars (iocbp, addr (segname), length (rtrim (segname)), 0);
		call putc ("]");
		call putc (" ");
		call move_lines (msg_block_start, errmess_lth);
		call putc ("~");
		call putc (NL);
		call move_lines (msg_block_start+errmess_lth+2-1, msg_block_lth+1-errmess_lth-2);
		call putc ("!");
		call putc (NL);
	     end;
	     cur_msg_index = cur_msg_index + msg_block_lth;
	end;
	return;

check_calls: proc;
	     if index (segment, "call syserr") ^= 0 then return;
	     if index (segment, "call	syserr") ^= 0 then return;	/* callTAB... */
	     if index (segment, "call sys_log_") ^= 0 then return;
	     if index (segment, "call	sys_log_") ^= 0 then return;	/* callTAB... */
	     if index (segment, "call admin_gate_$syserr") ^= 0 then return;
	     if index (segment, "call	admin_gate_$syserr") ^= 0 then return;	/* callTAB... */
	     if index (segment, "call salv_err_msg") ^= 0 then return;
	     if index (segment, "call	salv_err_msg") ^= 0 then return;   /* callTAB... */
	     if index (segment, "call hphcs_$syserr") ^= 0 then return;
	     if index (segment, "call	hphcs_$syserr") ^= 0 then return;  /* callTAB... */
	     ec = 0;				/* Not an error, no logging calls */
             end check_calls;
	
move_lines: proc (a_beg, a_nleft);

dcl (a_beg, a_nleft) fixed bin (21);
dcl (beg, nleft, llth, trim_lth, tpx, nls) fixed bin (21);

	     beg = a_beg;
	     nleft = a_nleft;
	     nls = 0;
	     do while (nleft > 0);
		llth = index (substr (segment, beg, nleft), NL);
		if llth = 0 then llth = nleft+1;
		tpx = min (llth-1, pfx_lth);		/* Discard the "prefix" */
		if substr (segment, beg, tpx) ^= pfx	/* .. which we noted before the first "Message:" */
		then tpx = 0;
		if llth-tpx > 1 then
		     do while (nls > 0);
		     call putc (NL);
		     nls = nls - 1;
		end;
		call iox_$put_chars (iocbp, addr (substr (segment, beg+tpx, 1)), llth-tpx-1, 0);
		nls = nls + 1;
		beg = beg + llth;
		nleft = nleft - llth;
	     end;

	end move_lines;


putc:	proc (c);

dcl  c char (1);

	     call iox_$put_chars (iocbp, addr (c), 1, 0);

	end putc;

     end extract_msg_doc_;




		    gate_sw.pl1                     11/15/82  1845.8rew 11/15/82  1515.4       88506



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


gate_sw: proc (name, switch) ;
dcl  name char (*), switch char (*) ;

/* created by A Kobziar to allow the dynamic switching of a gate to one that has calls to user
   proceedures  rather than  system proceedures, for the purpose of testing the user enviroment.
   USAGE:	call gate_sw(name,function);

   1. name char(*)		path name of the gate segment, to be found using standard search rules.

   2. function char(*)	specification of which function to be performed from the following options:

   "sim_init"	this will initialize the user's gate, make the system's gate known by the
   name "real_(name of gate)", and set switch to make calls to user's proceedures.

   "sim"		this will set the switch in the user's gate to make calls to user proceedures.

   "real"		this will set the switch in the user's gate to make calls to system proceedures.

   "revert"		this will terminate the user's gate and initiate system's gate with "(gate's name)".
   This allows the return to system enviroment without doing a new_proc.

   The old gate is made known to the process by the refname "real_|name|.
   Switching back and forth is permitted. */

/* NOTES:
   1. "sim_init" must be the first function executed if the user wants to replace a system gate.
   Otherwize  the "sim" and "real" functions can be used for a private switchable gate.
   2. any number of switchable gates can coexist.
   3. Works because kst is hashed with gate name and ring no.
   */

dcl (save_p, p, gate_ptr, pnamep, dirp, gatedirp, enamep, refp) ptr ;
dcl (hcs_sw, reset_sw) bit (1) aligned;
dcl (pnamel, len) fixed bin ;
dcl  code fixed bin (35);
dcl (dirname, gatedir) char (168), (refname, ename) char (32) ;
dcl  schar char (4) ;
dcl  whoami char (8) aligned ;
dcl (addr, length, null) builtin;

dcl 1 ret_struc aligned,
    2 num fixed bin,
    2 names (22) char (168) aligned ;

dcl 1 lib_sr_struc aligned,
    2 num fixed bin,
    2 name char (168) aligned ;

/* the following ext entry names, except for hcs_, cannot be used as name of user's gate */
dcl  hcs_$get_search_rules ext entry (ptr) ;
dcl  hcs_$initiate_search_rules ext entry (ptr, fixed bin(35)) ;
dcl (hcs_$make_ptr, real_hcs_$make_ptr) ext entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl (hcs_$initiate, real_hcs_$initiate) ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl (hcs_$terminate_name, real_hcs_$terminate_name) ext entry (char (*), fixed bin (35));
dcl  term_$nomakeunknown ext entry (ptr, fixed bin(35)) ;
dcl (cu_$ptr_call, com_err_) ext entry options (variable);
dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin(35)) ;
dcl (hcs_$fs_get_path_name, real_hcs_$fs_get_path_name) ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl (hcs_$fs_get_seg_ptr, real_hcs_$fs_get_seg_ptr) ext entry (char(*), ptr, fixed bin (35));
dcl (error_table_$segknown, error_table_$name_not_found) ext fixed bin (35);


	hcs_sw, reset_sw = "0"b ;			/* initialize for gate name not hcs_ */
	whoami = "gate_sw" ;


	pnamep = addr (name) ;
	pnamel = length (name) ;			/* set up for expand path */
	dirp = addr (dirname) ;
	enamep = addr (ename) ;
	refp = addr (refname) ;
	gatedirp = addr (gatedir) ;

	call expand_path_ (pnamep, pnamel, dirp, enamep, code) ;
	if code ^= 0 then do ;
	     call com_err_ (code, whoami, "Expand_path err on ^a", name) ;
	     return ;
	end ;

	if ename = "hcs_" then hcs_sw = "1"b ;		/* gate is hcs_ */

	if switch = "sim_init" then do ;
	     refname = "real_"||ename ;		/* name original gate real_|name| */
	     save_p = addr (ret_struc) ;
	     p = addr (lib_sr_struc) ;
	     lib_sr_struc.num = 1 ;
	     lib_sr_struc.name = "system_libraries" ;

/* must get the pathname of the real gate, which may not be known to process */
	     call hcs_$get_search_rules (save_p) ;	/* pick up user's search rules for safekeeping */

	     call hcs_$initiate_search_rules (p, code) ;	/* search only the sys libraries */
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Setting search rule error") ;
		reset_sw = "1"b;
		goto sr_rl;			/* restor user's search rules */
	     end ;

	     call hcs_$make_ptr (null, ename, "", gate_ptr, code) ; /* get ptr to real gate */
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Err on init of real gate ^a", ename) ;
		reset_sw = "1"b;
		goto sr_rl;
	     end ;

	     call hcs_$fs_get_path_name (gate_ptr, gatedir, len, ename, code); /* get name of real gate */
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Cannot get real gate pathname, ^a", ename) ;
		reset_sw = "1"b;
		goto sr_rl;
	     end ;

	     call hcs_$initiate (gatedir, ename, refname, 0, 1, gate_ptr, code) ; /* add refname real_(name) to old gate */
	     if code ^= error_table_$segknown then
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to add refname ^a to ^a", refname, ename) ;
		reset_sw = "1"b;
		goto sr_rl;
	     end ;

sr_rl:	     call hcs_$initiate_search_rules (save_p, code) ; /* reset user's search rules */
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to reset user's search rules") ;
	     end ;
	     if reset_sw then return ;		/* errors above - quit */

	     call term_$nomakeunknown (enamep, code) ;	/* unlinking references to old gate (name) */
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Err on term of ^a", ename) ;
		return ;
	     end ;

	     if hcs_sw then call real_hcs_$terminate_name (ename, code) ; /* removing reference (name) from old gate */
	     else call hcs_$terminate_name (ename, code) ;

	     if code ^= 0 then if code ^= error_table_$name_not_found then do;
		call com_err_ (code, whoami, "Unable to remove refname ^a", ename) ;
		return ;
	     end ;


/* now must initiate user's gate */
	     if hcs_sw then call real_hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ;
	     else call hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to initiate new gate ^a", ename) ;
reset:		
						/* must now init the old gate */
		if hcs_sw then call real_hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ;
		else call hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ;
		if code ^= 0 then do ;
		     call com_err_ (code, whoami, "Unable to reinit real_^a with name", ename);
		     return ;
		end;
		call com_err_ (0, whoami, "Real gate reestablished") ;
		return ;
	     end ;

	     schar = "sim" ;
						/* get entry ptr to switch in the user's gate */
setsym:	     if hcs_sw then call real_hcs_$make_ptr (p, ename, schar, gate_ptr, code) ;
	     else call hcs_$make_ptr (p, ename, schar, gate_ptr, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to find entry real in ^a", name) ;
		goto reset ;
	     end ;

	     call cu_$ptr_call (gate_ptr) ;		/* set switch in user's gate for function schar */

	     return ;
	end;

/* the next call must be performed for all other functions */
/* get a pointer to user's gate */
	if hcs_sw then call real_hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ; /* get ptr to user's gate */
	else call hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ;
	if code ^= error_table_$segknown then
	if code ^= 0 then do ;
	     call com_err_ (code, whoami, "Unable to get ptr to ^a", ename) ;
	     return ;
	end ;

	if switch = "sim" then do ;
	     schar = "sim" ;
	     goto setsym ;
	end ;

	if switch = "real" then do ;
	     schar = "real" ;
	     goto setsym ;
	end ;

	if switch = "revert" then do ;		/* want to reestablish old gate */
						/* p pts to user's gate ename in dir dirname */

	     refname = "real_"||ename ;
	     if hcs_sw then call real_hcs_$fs_get_seg_ptr (refname, save_p, code) ; /* pick up ptr to old gate */
	     else call hcs_$fs_get_seg_ptr (refname, save_p, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to get ptr to ^a", refname) ;
		return ;
	     end ;

	     if hcs_sw then call real_hcs_$fs_get_path_name (save_p, gatedir, len, ename, code) ;
	     else call hcs_$fs_get_path_name (save_p, gatedir, len, ename, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to get pathname ^p", save_p) ;
		return ;
	     end ;



	     if hcs_sw then call real_hcs_$terminate_name (ename, code) ; /* terminating user's gate */
	     else call hcs_$terminate_name (ename, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to terminate gate ^a", ename) ;
		return ;
	     end ;

/* must initiate the system gate with refname of |ename| */

	     if hcs_sw then call real_hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ;
	     else call hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ;
	     if code ^= error_table_$segknown then
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Initiate err on ^a", ename) ;
		return ;
	     end ;
						/* now will remove name "real_|ename| from sys gate */
	     call hcs_$terminate_name (refname, code) ;
	     if code ^= 0 then do ;
		call com_err_ (code, whoami, "Unable to term name ^a on sys gate", refname) ;
		return ;
	     end ;

	     return ;

	end;

	call com_err_ (0, whoami, "Unable to recognize switch setting desired,please consult documentation for correct name") ;
	return ;
     end gate_sw ;




		    reduction_compiler.pl1          11/01/84  0827.8rew 11/01/84  0825.4       90549




/* ***************************************************************
   *						     *
   *						     *
   * Copyright (c) 1975 by Massachusetts Institute of Technology *
   *						     *
   *						     *
   *************************************************************** */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Status									*/
	/*									*/
	/* 1) Modified:  February, 1981 by G. C. Dixon					*/
	/*    a) Add the -trace ctl_arg to invoke the internal tracing facility provided by the	*/
	/*       SEMANTIC_ANALYSIS routine.  When a translator is compiled with  -trace, a	*/
	/*       special trace routine is invoked each time a reduction is matched.  This	*/
	/*       routine prints the matching reduction (as it appears in the .rd source),	*/
	/*       followed by the tokens which matched the reduction.			*/
	/*    b) Upgrade code to 1981 coding standards.					*/
	/* 2) Modified:  July 24, 1983 by G. C. Dixon					*/
	/*    a) Change long name from reduction_compiler to reductions.  Name		*/
	/*       reduction_compiler will be retained for compatibility but will be undocumented.	*/
	/*    b) Make rdc invoke the pl1 command to compile the generated source, iff the rdc	*/
	/*       translation was successful.						*/
	/*    c) Make rdc set a severity variable accessible by the severity AF to indicate the	*/
	/*       results of both the rdc and pl1 translations.				*/
	/* 3) Modified:  Sep 10, 1984 by G. C. Dixon to change name in error messages from	*/
	/*    reduction_compiler to reductions.  This was left out of change 2 above.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

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


reduction_compiler:
reductions:
rdc:	procedure;

     dcl						/* 	automatic variables			*/
	Iarg			fixed bin,
	Larg			fixed bin,	/* length of our input argument.		*/
	Lobject			fixed bin(21),	/* length of output object segment (in chars).	*/
	Lsource			fixed bin(21),	/* length of input source segment (in chars).	*/
	Nargs			fixed bin,	/* number of input arguments.			*/
	Parea			ptr,		/* ptr to our temporary allocation segment.	*/
	Pacl_obj			ptr,		/* ptr to object seg's acl-info structure.	*/
	Parg			ptr,		/* ptr to our input argument.			*/
	Pobject			ptr,		/* ptr to object segment we're creating.	*/
	Psource			ptr,		/* ptr to input source segment.		*/
	1 Scontrol		aligned,
	 (2 long			bit(1),
	  2 brief			bit(1),
	  2 trace			bit(1),
	  2 trace_on_by_default	bit(1),
	  2 pad			bit(32)) unal,	/* reduction_compiler_ control switches.	*/
	bc_source			fixed bin(24),	/* bit count of source segment.		*/
	cleanup			condition,
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168),	/* dir part of source segment's path name.	*/
	ent_source		char(32),		/* ent part of source segment's path name.	*/
	ent_object		char(32),		/* ent part of object segment's path name.	*/
	pl1_args			char(300) varying;	/* Args to be passed to pl1 compiler.		*/

     dcl						/*	based variables			*/
	arg			char(Larg) based (Parg);
						/* our input argument.			*/

     dcl						/*	builtin functions			*/
         (addr, divide, index, length, max, null, string, substr)
				builtin;


     dcl						/*	entries and functions		*/
	com_err_			entry options (variable),
	cu_$arg_count		entry (fixed bin, fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$cp			entry (ptr, fixed bin(21), fixed bin(35)),
	expand_pathname_$add_suffix	entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	get_wdir_			entry returns (char(168) aligned),
	hcs_$initiate_count		entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr,
				     fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	hcs_$truncate_seg		entry (ptr, fixed bin, fixed bin(35)),
	ioa_$nnl			entry options(variable),
	pathname_			entry (char(*), char(*)) returns(char(168)),
	reduction_compiler_		entry (ptr, fixed bin(21), ptr, ptr, fixed bin(21), char(32), bit(*),
				     fixed bin(35), fixed bin(35)),
	requote_string_		entry (char(*)) returns(char(*)),
	suffixed_name_$new_suffix	entry (char(*), char(*), char(*), char(32), fixed bin(35)),
	translator_temp_$get_segment	entry (char(*) aligned, ptr, fixed bin(35)),
	translator_temp_$release_all_segments
				entry (ptr, fixed bin(35)),
	tssi_$clean_up_segment	entry (ptr),
	tssi_$finish_segment	entry (ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)),
	tssi_$get_segment		entry (char(*), char(*), ptr, ptr, fixed bin(35));

     dcl						/*	static variables			*/
         (error_table_$mdc_path_dup_args,
	error_table_$no_makeknown,
	error_table_$noentry,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static,
	pl1_severity_		fixed bin(35) ext static init(0),
	proc			char(10) aligned int static init ("reductions"),
	reductions_severity_	fixed bin(35) ext static init(0),
	sys_info$max_seg_size	fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call cu_$arg_count (Nargs, code);		/* if we have less than one arg, complain.	*/
	if code ^= 0 then go to NOT_AF;
	if Nargs < 1 then go to WNOA;
	string(Scontrol) = "0"b;
	ent_source = "";
	pl1_args = "";
do Iarg = 1 to Nargs;
	   call cu_$arg_ptr (Iarg, Parg, Larg, code);
	   if arg = "-lg" | arg = "-long" then
	      Scontrol.long = "1"b;
	   else if arg = "-bf" | arg = "-brief" then
	      Scontrol.brief = "1"b;
	   else if arg = "-trace" then do;
	      Scontrol.trace = "1"b;
	      Scontrol.trace_on_by_default = "1"b;
	      if Iarg < Nargs then do;
	         Iarg = Iarg + 1;
	         call cu_$arg_ptr (Iarg, Parg, Larg, code);
	         if arg = "on" then;
	         else if arg = "off" then
		  Scontrol.trace_on_by_default = "0"b;
	         else
		  Iarg = Iarg - 1;
	         end;
	      end;
	   else if arg = "-no_trace" then
	      Scontrol.trace = "0"b;

	   else if index(arg,"-") ^= 1 then do;
	      if ent_source ^= "" then go to DUP_PATH;
	      call expand_pathname_$add_suffix (arg, "rd", dir, ent_source, code);
	      if code ^= 0 then go to BAD_PATH;
	      call suffixed_name_$new_suffix (ent_source, "rd", "pl1", ent_object, code);
	      if code ^= 0 then go to BAD_SOURCE;
	      end;

	   else do;				/* A pl1 option?  Let pl1 diagnose it.		*/
	      if arg = "-prefix" & Iarg < Nargs then do;
	         Iarg = Iarg + 1;
	         call cu_$arg_ptr (Iarg, Parg, Larg, code);
	         pl1_args = pl1_args || " ";
	         pl1_args = pl1_args || "-prefix";
	         pl1_args = pl1_args || " ";
	         pl1_args = pl1_args || requote_string_(arg);
	         end;
	      else do;
	         pl1_args = pl1_args || " ";
	         pl1_args = pl1_args || arg;
	         end;
	      end;
	   end;
	Parea = null;
	Psource = null;
	Pobject = null;				/* initialize ptrs used by cleanup on-unit.	*/
	on cleanup call cleaner;			/* cleanup when required.			*/


	call hcs_$initiate_count (dir, ent_source, "", bc_source, 0, Psource, code);
	if Psource = null then go to BAD_SOURCE;	/* initiate source segment.			*/
	Lsource = divide (bc_source, 9, 35, 0);		/* convert bit count to character count.	*/

	call translator_temp_$get_segment (proc, Parea, code);
	if Parea = null then go to BAD_AREA;
	dir = get_wdir_();				/* put object segment in working directory.	*/
	call tssi_$get_segment (dir, ent_object, Pobject, Pacl_obj, code);
	if code ^= 0 then go to BAD_OBJECT;		/* get ptr to object segment we're creating.	*/
	Lobject = sys_info$max_seg_size * 4;
	call ioa_$nnl ("RDC - ");
	call reduction_compiler_ (Psource, Lsource, Parea, Pobject, Lobject,
	   ent_source, string(Scontrol), reductions_severity_, code);
	if Lobject = 0 then				/* create object segment.  If 0 length, ERROR.	*/
	   call hcs_$truncate_seg (Pobject, 0, 0);
	call tssi_$finish_segment (Pobject, Lobject * 9, "1000"b, Pacl_obj, 0);
						/* finish up the object segment.		*/
	Pobject = null;				/* cleanup now.				*/
	call cleaner;
	if code ^= 0 then go to ERROR;

	pl1_args = "[where pl1]$pl1 " || pathname_ (dir, ent_object) || pl1_args;
	call cu_$cp (addr(substr(pl1_args,1)), length(pl1_args), code);
	reductions_severity_ = max(reductions_severity_, pl1_severity_);
	return;

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


cleaner:	proc;					/* cleanup procedure.			*/

     dcl	code			fixed bin(35);	/* It has its own status code.		*/

	if Psource ^= null then
	   call hcs_$terminate_noname (Psource, code);
	if Parea ^= null then
	   call translator_temp_$release_all_segments (Parea, code);
	if Pobject ^= null then
	   call tssi_$clean_up_segment (Pacl_obj);

	end cleaner;

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

DUP_PATH:	call com_err_ (error_table_$mdc_path_dup_args, proc, "^a
Only one pathname may be given.", arg);
	return;

NOT_AF:   call com_err_ (code, proc);
	return;

WNOA:	call com_err_ (error_table_$wrong_no_of_args, proc,
	   "^/Calling  sequence:^-reductions pathname {-ctl_args}
control_arg is:^--long, -lg^/^2--brief,-bf^/^2--trace {on|off}^/^2--no_trace, -ntrace");
	return;

BAD_PATH:	call com_err_ (code, proc, " ^a", arg);
	return;

BAD_SOURCE:
	if code = error_table_$no_makeknown then code = error_table_$noentry;
	call com_err_ (code, proc, " ^a^[>^]^a", dir, dir^=">", ent_source);
	return;

BAD_AREA:	call com_err_ (code, proc, "^/While creating a temporary segment in the process directory.");
	call cleaner;
	return;

BAD_OBJECT:
	call com_err_ (code, proc, "^/While creating the object segment^/(^a^[>^]^a).", dir, dir^=">", ent_object);
	call cleaner;
	return;

ERROR:	call com_err_ (code, proc, "^/No object segment will be generated.");
	return;

	end reduction_compiler;




		    reduction_compiler_.rd          03/17/86  1520.8rew 03/17/86  1438.6      671418



/* ***************************************************************
   *                                                             *
   * Copyright (c) 1986 by Massachusetts Institute of Technology *
   *                                                             *
   * Copyright (c) 1975 by Massachusetts Institute of Technology *
   *                                                             *
   *************************************************************** */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  reduction_compiler_							*/
	/*									*/
	/*      This procedure is the subroutine interface for the reduction_compiler.  It	*/
	/* accepts as input a set of reductions, a temporary segment for use in allocations	*/
	/* of a temporary nature, and a pointer to and maximum length of the object segment to	*/
	/* be generated.  It returns the actual length of the compiled object segment.		*/
	/*      The reductions to be compiled have been pre-processed by the lex_string_	*/
	/* subroutine, and are represented by a chain of input tokens.			*/
	/*      This subroutine is, itself, driven by a set of reductions which were compiled	*/
	/* by a bootstrapped version of the reduction_compiler.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* HISTORY COMMENTS:
  1) change(74-04-05,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 1.0--
      Created the reduction_compiler (rdc) command.
  2) change(74-05-06,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 1.1--
      Fixed bugs in initial version.
  3) change(74-05-17,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 1.2--
      Changed the following rdc constructs:
       a) STACK-POP  ==>  STACK_POP
       b) (PL/I-stmt)  ==>  [PL/I-stmt]  for semantic statements.
  4) change(75-01-30,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 1.3--
      Make relative syntax functions quick PL/I blocks by converting array of
      entries into relative syntax functions into a label transfer vector into
      calls to the relative syntax functions.
  5) change(75-02-03,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.0--
      a) code generated for LEX converted to calls to a subroutine LEX(n).
      b) new DELETE and DELETE_STMT built-in action routines added.
      c) new INCLUDE attribute added to force inclusion of include segments.
      d) code for PUSH DOWN LANGUAGE added but not documented.
      e) allocate statements changed to calls to translator_temp_$allocate.
     
  6) change(75-04-28,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.1--
      a) put a space after all tokens in semantic statement brackets ([]),
         except <quoted-string> tokens, and the following paired token
         sequences:
                                   < =
                                   > =
                                   ^ =
                                   ^ >
                                   ^ <
                                   - >
      b) In order to implement this change, four new break characters were
         added: - ^ = ;
      c) Commenting delimiters were added:  \" begins a comment, which ends
         with a newline character.
  7) change(81-02-16,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.2--
      a) INCLUDE LEX stmt added, because of
      b) code added to detect only use of LEX (rather than LEX(N)).
         If only LEX used, then the LEX subroutine is NOT included in
         SEMANTIC_ANALYSIS by default.
      c) Many data structures declared options(constant)
      d) VT now acccpted in .rd segments as a whitespace character
      e) <no-token> in a PUSH DOWN LANGUAGE checks to see if token on top of
         push down stack is the final input token (ie, all tokens are on the
         stack or have been deleted.
      f) Add code to support rdc's -trace control argument.
  8) change(83-07-23,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.3--
      a) Place sequence numbers in unlabeled reductions appearing in the .pl1
         and .list segments.  The same numbers are placed in the reductions
         printed during tracing.
      b) Changed implementation of -trace to avoid temporary copying of
         reduction source.  Instead, reduction source is extracted from the
         stmt descriptors.
  9) change(84-09-08,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.4--
      a) Allow ERROR (named_constant) in addition to ERROR (decimal_integer)
      b) Use perprocess date_time format for date put in header comment of
         translator.
 10) change(85-10-21,GDixon), approve(86-02-06,MCR7339),
     audit(86-02-19,Wallman), install(86-02-19,MR12.0-1022):
     Version 2.5--
      Upgrade the severity of several error messages to severity 3, because
      these messages describe conditions which are likely to make PL/I
      compilation fail.  Severity 3 errors prevent the PL/I compiler from
      being invoked. (phx19850)
                                                   END HISTORY COMMENTS */



/*++
MAX_DEPTH 20 \

BEGIN	/ <no-token>			/ 			ERROR(1)		/ stop	\
	/ <any-token>			/ reductions_init				/ attributes \

attributes
	\" 1) parse and process the reduction attributes.  If present, these must precede any
	\"    reduction statements.
	/ BEGIN 				/ 		[Psave = Pthis_token]	/ pass1	 \
	/ MAX_DEPTH <decimal-integer> "\"	/ LEX set_depth     LEX(2)			/ attributes \
	/ PUSH DOWN LANGUAGE "\"		/ LEX(4)            [S_PDL = "1"b]		/ attributes \
	/ INCLUDE DELETE "\"		/ LEX(3)            [Sinclude_DELETE = "1"b]	/ attributes \
	/ INCLUDE DELETE_STMT "\"		/ LEX(3)            [Sinclude_DELETE_STMT = "1"b]	/ attributes \
	/ INCLUDE ERROR "\"			/ LEX(3)            [Sinclude_ERROR  = "1"b]	/ attributes \
	/ INCLUDE NEXT_STMT "\"		/ LEX(3)            [Sinclude_NEXT_STMT = "1"b]	/ attributes \
	/ INCLUDE LEX "\"			/ LEX(3)		[Sinclude_LEX = "1"b]	/ attributes \
	/ INCLUDE				/ 			ERROR(19)	NEXT_STMT	/ attributes \
	/ <no-token>			/ 			ERROR(1)		/ stop	\
	/ <any-token>			/ 			ERROR(2)	NEXT_STMT	/ attributes \

pass1	\" 1) create a symbol table giving name and reduction number for all reduction labels.
	\" 2) count the tokens in the syntax specification field to get an estimate of the amount
	\"    of temporary storage rdc will need to hold the syntax specifications.
set_label	/ /_				/ count_reduction   LEX			/ count	\
	/ <name>				/ set_label         LEX			/ set_label \
	/ "\"				/ 			ERROR(22)	LEX	/ set_label \
	/ <no-token>			/ reductions_begin  [Pthis_token = Psave]	/ pass2	 \
	/ <any-token>			/ 			ERROR(3)	LEX	/ set_label \

count	/ <quoted-string>			/ count_token(1)    LEX(1)			/ count	\
	/ /_ <BS> _			/ count_token(1)    LEX(3)			/ count	\
	/ /_				/ 		NEXT_STMT			/ set_label \
	/ <any-token>			/ count_token(1)    LEX			/ count	\
	/ <no-token>			/ 			ERROR(5)		/ stop	\

pass2	\" Process the reduction statements, as follows:
	\" 1) skip over any labels on the reduction statement.
	\" 2) compile the syntax specifications by storing them in rdc's temporary syntax table.
	\" 3) compile the action specifications by outputting calls to built-in action routines and
	\"    semantic subroutines, and by outputting semantic statements.
	\" 4) compile the next reduction field by outputting code to transfer to the appropriate reduction.
label
skip_label
	/ /_				/ reduction_begin	LEX			/ first_token \
	/ <name>	 			/		LEX			/ skip_label \
	/ "\"				/		LEX			/ skip_label \
	/ <any-token>			/		LEX			/ skip_label \
	/ <no-token>			/ 					/ stop	\

first_token
	/ <PUSH_DOWN_LANGUAGE>		/					/ token1	\
	\" For a non-PUSH DOWN LANGUAGE, <no-token> followed by any syntax specification is in error
	\" because tokens are checked from left to right;  for a PUSH DOWN LANGUAGE, <no-token> has
	\" meaning as the first or last specification in a reduction.  As the first spec, it identifies
	\" the bottom of the push-down stack.  As the last spec, it identifies when the list of input tokens
	\" has run out.
	/				/					/ tokens	\

token1	/ <quoted-string>			/ 					/ tokens	\
	/ <_ no - token >_ <any-token>		/ compile_token(1)  LEX(5)			/ tokens	\

tokens	/ <quoted-string>			/ compile_token(0)	LEX			/ tokens	\
	/ /_ <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ /_				/ 	    	LEX       action_begin	/ action	\
	/ < <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ > <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ [ <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ ] <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ ( <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ ) <BS> _			/ compile_token(0)	LEX(3)			/ tokens	\
	/ <_ no - token >_ /_			/ compile_token(1) 	LEX(6)    action_begin	/ action	\
	/ <_ no - token >_ <any-token>		/		LEX(5)    ERROR(14)		/ error_in_red \
	/ <_ any - token >_			/ compile_token(2)	LEX(5)			/ tokens	\
	/ <_ name >_			/ compile_token(3)	LEX(3)			/ tokens	\
	/ <_ decimal - integer >_		/ compile_token(4)	LEX(5)			/ tokens	\
	/ <_ BS >_				/ compile_token(5)	LEX(3)			/ tokens	\
	/ <_ quoted - string >_		/ compile_token(6)	LEX(5)			/ tokens	\
	/ <_ <name> >_			/ LEX
					  compile_token(7) 	LEX(2)			/ tokens	\
	/ "\"				/ 	  	LEX       ERROR(22)		/ label	\
	/ <any-token>			/ compile_token(0)	LEX			/ tokens	\
	/ <no-token>			/ 		          ERROR(5)		/ stop	\

action	/ /_				/ 		   LEX			/ next_red \
	/ LEX (   <decimal-integer> )		/ set_action_with_args LEX(2) PUSH(last_paren)
					  [Sinclude_LEX = "1"b]			/ args	\
	/ LEX ( - <decimal-integer> )		/ set_action_with_args LEX(2) PUSH(last_paren)
					  [Sinclude_LEX = "1"b]			/ args	\
	/ LEX ( + <decimal-integer> )		/ set_action_with_args LEX(2) PUSH(last_paren)
					  [Sinclude_LEX = "1"b]			/ args	\
	/ LEX (				/ 			ERROR(19)		/ error_in_red \
	/ LEX				/ rtn(1)		   LEX			/ action	\
	/ NEXT_STMT (			/ 			ERROR(19)		/ error_in_red \
	/ NEXT_STMT			/ set_action	   LEX
					  [Sinclude_NEXT_STMT = "1"b]			/ action	\
	/ POP (				/ 			ERROR(19)		/ error_in_red \
	/ POP				/ rtn(2)		   LEX			/ action	\
	/ PUSH ( <name> ) 			/ LEX(2) rtn(3)	   LEX(2)			/ action	\
	/ PUSH				/ 			ERROR(19)		/ error_in_red \
	/ DELETE				/					/ DELETE	\
	\" Remove tests for all of the DELETE cases from main stream of reductions to a subroutine.
	/ DELETE_STMT (			/ 			ERROR(19)		/ error_in_red \
	/ DELETE_STMT			/ set_action 	   LEX
					  [Sinclude_DELETE_STMT = "1"b] 		/ action	\
	/ ERROR ( <decimal-integer> )		/ set_action_with_args LEX(2)
					  [Sinclude_ERROR = "1"b] 	PUSH(last_paren)	/ args	\
	/ ERROR (				/ set_action_with_args LEX(2)
					  [Sinclude_ERROR = "1"b] 	PUSH(last_paren)	/ args	\
	\" The preceding reduction allows the builtin ERROR routine to accept
	\" a named constant instead of a decimal integer.
	/ [				/ output((6)"	" || (4)" ")
					 		   LEX			/ stmt	\
	/ ]				/ 			ERROR(21)	LEX	/ action	\
	/ (				/ 			ERROR(21)	LEX	/ action	\
	/ )				/ 			ERROR(21)	LEX	/ action	\
	/ <quoted-string>			/ 			ERROR(23)		/ error_in_red \
	/ "\"				/ 			ERROR(22)		/ error_in_red \
	/ <any-token> (			/ set_action_with_args LEX(2) PUSH(last_paren)	/ args	\
	/ <any-token>			/ set_action 	   LEX			/ action	\
	/ <no-token>			/ 			ERROR(5)		/ stop	\

error_in_red
	/ 				/ [obj_red.Ilast(Nobj_red) = 0]
					  reduction_end 	   NEXT_STMT		/ label	\

DELETE	/ DELETE (   <decimal-integer> ,   <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE (   <decimal-integer> , - <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE (   <decimal-integer> , + <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE ( - <decimal-integer> ,   <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE ( - <decimal-integer> , - <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE ( - <decimal-integer> , + <decimal-integer> ) 	/			/ DELETE_2 \
	/ DELETE ( + <decimal-integer> ,   <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE ( + <decimal-integer> , - <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE ( + <decimal-integer> , + <decimal-integer> )	/			/ DELETE_2 \
	/ DELETE (   <decimal-integer> )			/			/ DELETE_1 \
	/ DELETE ( - <decimal-integer> )			/			/ DELETE_1 \
	/ DELETE ( + <decimal-integer> )			/			/ DELETE_1 \

	/ DELETE (			/ 			ERROR(19)		/ error_in_red \
	/ DELETE				/ set_action_with_args LEX	output(" 0, 0 )")
					  [Sinclude_DELETE = "1"b]			/ last_paren\
	\" The only way to reach the next reduction is by branch.  All possible cases of DELETE
	\" have been handled above, including illegal ones.

DELETE_1	/				/ set_action_with_args LEX(2)
					  [Sinclude_DELETE = "1"b]			/	\
	/ <any-token> <decimal-integer>	/ output(" ") output(token_value) 	LEX
						    output(token_value) 	LEX(-1)
					  output(",")		PUSH(last_paren)	/ args	\
	/	    <decimal-integer>	/ output(" ") output(token_value)
					  output(",")		PUSH(last_paren)	/ args	\

DELETE_2	/				/ set_action_with_args LEX(2)	PUSH(last_paren)
					  [Sinclude_DELETE = "1"b]			/ args	\

stmt	\" Process the contents of semantic statements.  Special attention is given when generating
	\" PL/I code for the statements to the following cases:
	\" 1) No space is placed between the last token of a semantic statement and its
	\"    ending semi-colon statement delimiter.
	\" 2) No space is placed between an argument in a subprogram call and any comma delimiter
	\"    which may follow it.
	\" 3) No space is placed between a quoted string and any b, b1, b2, b3 or b4
	\"    token which follows it in order to handle bit string constants (eg "101"b)
	\" 4) No space is placed between any of the following pairs of characters which
	\"    have a special meaning in the PL/I language:  ->  >=  <=  ^=  ^>  ^<
	\" 5) No space is placed between any minus sign (-) and the token which follows, in
	\"    order to handle signed numeric constants.
	\" 6) Semantic statements appearing in the same pair of brackets in an action specification
	\"    are placed on different lines in the generated code (as if they had appeared in
	\"    separate brackets).
	/ <quoted-string> b			/					/ bit_constant  \
	/ <quoted-string> b1		/					/ bit_constant  \
	/ <quoted-string> b2		/					/ bit_constant  \
	/ <quoted-string> b3		/					/ bit_constant  \
	/ <quoted-string> b4		/					/ bit_constant  \
	/ <quoted-string>			/ output(" ") output_quote(token_value) LEX	/	\
	/ (				/ output(" ") output("(") PUSH(stmt)    LEX	/ args	\
	/ ]				/				LEX	/ last_paren \
	/ ;				/ output (";" || NL || (6)"	" || (4)" ")
					  				LEX	/ stmt	\
	/ "\"				/ 			ERROR(24)		/ error_in_red \
	/				/ PUSH(stmt) PUSH(stmt1)			/ special_chars \
	\" Always branch to special subroutine to check for paired character sequences.
	\" This subroutine returns to the 1st PUSHed label if a paired character sequence
	\" is found, and to the second PUSHed label if no paired sequence is found.
stmt1	/				/ 				POP	/	\
	/ <any-token>			/ output(" ") output(token_value) 	LEX	/ stmt	\
	/ <no-token>			/ 			ERROR(5)		/ stop	\

bit_constant
	/ 				/ output(" ") output_quote(token_value) LEX
					  	    output(token_value)       LEX	/ stmt	\


args	\" This reduction subroutine processed the arguments in calls to semantic subroutines, and
	\" the parenthesized expression or sub-program arguments in semantic statements.  It handles
	\" the special cases described above under "stmt".  Nested parentheses are handled to a
	\" depth of about 17.  It returns to the last PUSHed reduction label.
	/ <quoted-string> (			/ 					/ quoted_arg \
	/ <quoted-string> "\"		/ 					/ quoted_arg \
	/ <quoted-string> )			/ 					/ quoted_arg \
	/ <quoted-string> <any-token>		/ output(" ") output_quote(token_value) LEX
					  	    output(token_value) 	LEX	/ args	\
quoted_arg
	/ <quoted-string>			/ output(" ") output_quote(token_value) LEX	/	\
	/ (				/ output(" ") output("(") PUSH(args)	LEX	/ args	\
	/ )				/ output(" ") output(")") 		LEX	/ STACK_POP \
	/ ;				/ 			ERROR(24)		/ error_in_red \
	/ "\"				/ 			ERROR(24)		/ error_in_red \
	/				/ PUSH(args) PUSH(args1)			/ special_chars \
	\" Always branch to special subroutine to check for paired character sequences.
	\" This subroutine returns to the 1st PUSHed label if a paired character sequence
	\" is found, and to the second PUSHed label if no paired sequence is found.
args1	/				/ 				POP	/	\
	/ ,				/ 	    output(token_value) 	LEX	/ args	\
	/ <any-token>			/ output(" ") output(token_value) 	LEX	/ args	\
	/ <no-token>			/ 			ERROR(5)		/ stop	\

last_paren/				/ output(";") output(NL)			/ action	\

special_chars
	\" Special reduction subroutine to check for paired character sequences in action specifications.
	\" Calling sequence is:    /	/ PUSH(label1) PUSH(label2)	/ special_chars \
	\"		 label2/  / POP			/	\
	\" This subroutine returns through the first PUSHed reduction label if a paired sequence
	\" is found, and through the second PUSHed label if none if found.
	/ < =				/					/ spec_found \
	/ > =				/					/ spec_found \
	/ ^ =				/					/ spec_found \
	/ ^ >				/					/ spec_found \
	/ ^ <				/					/ spec_found \
	/ - >				/					/ spec_found \
	/ - <any-token>			/					/ spec_found \
	/ + <any-token>			/					/ spec_found\
	/				/					/ STACK_POP \

spec_found
	/				/ output(" ") output(token_value) 	LEX
						    output(token_value)	LEX POP	/ STACK_POP \

next_red	\" The final group of reductions identifies and compiles code for the various next
	\" reduction fields of a reduction statement.
	/ "\"				/ next_reduction	    reduction_end 	LEX	/ label	\
	/ RETURN "\"			/ terminal_reduction    reduction_end 	LEX(2)	/ label	\
	/ STACK "\"			/ stacked_reduction     reduction_end 	LEX(2)	/ label	\
	/ STACK_POP "\"			/ stacked_reduction_pop reduction_end 	LEX(2)	/ label	\
	/ <name> "\"			/ specified_label       reduction_end 	LEX(2)	/ label	\
	/ <name>				/ specified_label       reduction_end 
					  			ERROR(16)	NEXT_STMT	/ label	\
	/ <any-token> "\"			/ next_reduction        reduction_end
					  			ERROR(4)	NEXT_STMT	/ label	\
	/ <any-token>			/ next_reduction        reduction_end 
					  			ERROR(15)	NEXT_STMT	/ label	\
	/ <no-token>			/ 			ERROR(5)		/ stop	\

stop	/ <no-token>			/ reductions_end				/ RETURN	\
	/ <any-token>			/ reductions_end		ERROR(6)		/ RETURN	\
											++*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


reduction_compiler_:
	proc    (Psource, Lsource, Psegment, APobj, ALobj, Aname_source, Scontrol, Mseverity, Acode);

     dcl	Psource			ptr,		/* ptr to reduction source segment. (In)	*/
	Lsource			fixed bin(21),	/* length of reduction source segment (in chars).	*/
						/* (Input)				*/
	Psegment			ptr,		/* ptr to a segment in which allocations	*/
						/* may be performed.  The segment must be a temp	*/
						/* segment provided by translator_temp_. (In)	*/
	APobj			ptr,		/* ptr to words of the object segment. (In)	*/
	ALobj			fixed bin(21),	/* maximum number of characters allowed in object	*/
						/* segment. (In)				*/
						/* number of words in constructed object segment.	*/
						/* (Out)					*/
	Aname_source		char(32),		/* entry name of input source segment. (In)	*/
	Scontrol			bit(*),		/* error format control bits. (In)		*/
	Mseverity			fixed bin(35),	/* severity of highest-severity error encountered	*/
						/* during the compilation. (Out)		*/
	Acode			fixed bin(35);	/* error code. (Out)			*/

     dcl						/*	automatic variables			*/
         (Ired_start, Ired_end)	fixed bin(21),	/* index into source of start/end of reductions.	*/
	Llongest_red		fixed bin,	/* length (in chars) of longest reduction.	*/
	Lobj			fixed bin(21),	/* length (in chars) of unused part of object	*/
						/* segment being created.			*/
	Lobj_part			fixed bin(21) init (0),
						/* length of a subset of the object segment.	*/
	Lobj_spaces		fixed bin,	/* number of spaces to be output into object seg.	*/
	Lobj_string		fixed bin,	/* maximum length of the string containing the	*/
						/* stored object token values.		*/
	Lobj_string_part		fixed bin(21),	/* length of a particular token value within the	*/
						/* string of all object token values.		*/
	Ltemp			fixed bin(21),	/* length of temporary character string.	*/
	Ltemp_obj			fixed bin(21),	/* length of temp copy of object segment contents.*/
	Mstack_depth		fixed bin,	/* user-specified maximum depth of the 		*/
						/* next-reduction-label stack.		*/
	Nchar			pic "----9" aligned,/* convert fixed bin integers to 4-char numbers.	*/
	Nobj_red			fixed bin,	/* index of the object reduction being compiled.	*/
	Nobj_token		fixed bin,	/* index of the object token being compiled.	*/
	Nobj_token_fcn		fixed bin,	/* index of the object token function being	*/
						/* compiled.				*/
	Nreductions		fixed bin,	/* number of reductions which can be stored in	*/
						/* object reduction storage structure.		*/
	Ntokens			fixed bin,	/* number of token requirements which can be 	*/
						/* stored in object token storage structure.	*/
	Osc_start			fixed bin(21),	/* char offset of start of source to be output.	*/
	Pobj			ptr,		/* ptr to unused part of object segment.	*/
	Pobj_red			ptr,		/* ptr to temp. storage structure for object	*/
						/* reductions.				*/
	Pobj_spaces		ptr,		/* ptr to adjustable-length string  of spaces.	*/
	Pobj_string		ptr,		/* ptr to temp. storage string for object token	*/
						/* values.				*/
	Pobj_string_part		ptr,		/* ptr to a particular token value within the	*/
						/* string of all object token values.		*/
	Pobj_token		ptr,		/* ptr to temp. storage structure for object	*/
						/* token requirements.			*/
	Pobj_token_quoted		ptr,		/* ptr to temp. storage for bits which are on if	*/
						/* object token was in quotes when input.	*/
	Psave			ptr,		/* ptr used in saving/restoring value of	*/
						/* Pthis_token between pass1 and pass2.		*/
	Ptemp			ptr,		/* ptr to temporary character string.		*/
	Ptemp_obj			ptr,		/* ptr to temp copy of object segment contents.	*/
	S_PDL			bit(1) aligned,	/* on if to be in 'PUSH DOWN LANGUAGE' mode.	*/
	S_TRACE			bit(1) aligned,	/* on if tracing code is to be generated.	*/
	S_TRACE_ON		bit(1) aligned,	/* on if tracing to be on initially.		*/
	Sinclude_DELETE		bit(1) aligned,	/* on if DELETE proc to be included in object seg.*/
	Sinclude_DELETE_STMT	bit(1) aligned,	/* on if DELETE_STMT proc to be included in obj.	*/
	Sinclude_ERROR		bit(1) aligned,	/* on if ERROR proc to be include in object seg.	*/
	Sinclude_NEXT_STMT		bit(1) aligned,	/* on if NEXT_STMT proc to be included.		*/
	Sinclude_LEX		bit(1) aligned,	/* on if LEX proc to be included.		*/
	Sinclude_STACK		bit(1) aligned,	/* on if STACK procs to be included in obj seg.	*/
	Soptimize_possible		bit(1) aligned,	/* on if optimization of object token storage	*/
						/* allocation is possible for the tokens assoc.	*/
						/* with the reduction being compiled.		*/
	code			fixed bin(35),	/* a status code.				*/
	date			char(53),		/* a date/time string.			*/
	form			fixed bin,	/* form of an object token.			*/
	i			fixed bin,	/* an integer temporary.			*/
	j			fixed bin,	/* an integer temporary.			*/
	name_source		char(32),		/* name of source segment, without its suffix.	*/
	1 obj_label		aligned,		/* temp storage for labels on object reductions.	*/
	  2 N			fixed bin,	/* number of labels currently defined.		*/
	  2 set (1000),				/* space for up to 1000 labels.		*/
	    3 name		char(32) aligned,	/* name of label.				*/
	    3 reduction_no		fixed bin,	/* number of reduction labelled by this label.	*/
	1 obj_token_fcn		aligned,		/* temp storage for relative token requirement	*/
						/* functions.				*/
	  2 N			fixed bin,	/* number of object token requirements defined.	*/
	  2 name (100)		char(32) varying,	/* name of token requirement.			*/
	type			fixed bin;	/* type of an object token.			*/


     dcl						/*	builtin functions			*/
         (addcharno, addr, addrel, bit, char, charno, dimension, divide,
	fixed, index, length, log, ltrim, max, min, null, rtrim,
	size, string, substr, verify)
				builtin;

     dcl						/*	entries				*/
	clock_			entry returns (fixed bin(71)),
	date_time_$format		entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
	lex_error_		entry options (variable),
	lex_string_$lex		entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*) aligned,
				       char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned, char(*) varying aligned, char(*) varying aligned,
				       char(*) varying aligned, char(*) varying aligned,
				       ptr, ptr, fixed bin(35)),
	lex_string_$init_lex_delims	entry (char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned, bit(*) aligned, char(*) varying aligned, 
				       char(*) varying aligned, char(*) varying aligned,
				       char(*) varying aligned),
	suffixed_name_$new_suffix	entry (char(*), char(*), char(*), char(32), fixed bin(35)),
	translator_temp_$allocate	entry (ptr, fixed bin) returns (ptr);

     dcl	NL			char(1) defined (NP) position (2);

     dcl						/*	based variables			*/
	obj			char(Lobj) aligned based (Pobj),
						/* object segment being created.		*/
	1 obj_red			aligned based (Pobj_red),
						/* temp storage for object reductions, prior	*/
						/* to outputting them into the object segment.	*/
	  2 N			fixed bin,	/* number of reductions currently defined.	*/
	  2 M			fixed bin,	/* maximum number which may be defined.		*/
	  2 token_reqd (Nreductions refer (obj_red.M)),
	    3 Ifirst		fixed bin(17) unal,	/* index of 1st and last token requirements	*/
	    3 Ilast		fixed bin(17) unal,	/* associated with this reduction.		*/

	obj_spaces		char(Lobj_spaces) based (Pobj_spaces),
						/* overlay for a number of spaces used to 	*/
						/* right-adjust an output line.		*/
	obj_string		char(Lobj_string) varying aligned based (Pobj_string),
						/* temp storage for object token values.	*/
	obj_string_part		char(Lobj_string_part) based (Pobj_string_part),
						/* overlay for a particular token value within	*/
						/* the string of all object token values.	*/
	obj_token_quoted (Ntokens)	bit(1) unaligned based (Pobj_token_quoted),
						/* on if object token was enclosed in quotes.	*/
	1 obj_token		aligned based (Pobj_token),
						/* temp storage for object token requirements,	*/
						/* prior to outputting them into the object seg.	*/
	  2 N			fixed bin,	/* number of tokens currently defined.		*/
	  2 M			fixed bin,	/* maximum number which may be defined.		*/
	  2 token (Ntokens refer (obj_token.M)),
	    3 form		fixed bin(17) unal,	/* form of the object token:			*/
						/*  -1 = relative token requirement function;	*/
						/*       type = index of the particular token	*/
						/*	      function in the token_fcn array.	*/
						/*   0 = built-in token requirement function;	*/
						/*       type = as defined below.		*/
						/*  >0 = absolute token requirement:		*/
						/*       form = index(token_strings,token_req);	*/
						/*       type = length(token_req);		*/
	    3 type		fixed bin(17) unal,	/* type of the built-in token requirement	*/
						/* function:				*/
						/*   1 = compile test to see if input token 	*/
						/*       chain is exhausted (<no-token>).	*/
						/*   2 = compile test for any token value	*/
						/*       (<any-token>).			*/
						/*   3 = compile test for a PL/I identifier	*/
						/*       (<name>) of 32 or fewer characters.	*/
						/*   4 = compile test for token which is a	*/
						/*       <decimal-integer>.			*/
						/*   5 = compile test for token which is a single	*/
						/*       backspace character (<BS>).		*/
						/*   6 = compile test for a token which is a	*/
						/*       <quoted-string>.			*/
	source			char(Lsource) based(Psource),
						/* overlay for reduction source segment.	*/
	temp			char(Ltemp) based (Ptemp),
						/* overlay for part of object segment contents	*/
						/* just generated.				*/
	temp_obj			char(Ltemp_obj) based (Ptemp_obj);
						/* temporary copy of object segment contents.	*/

     dcl						/*	static variables			*/
	HT			char(1) int static options(constant) init("	"),
	HT_SP			char(2) int static options(constant) init("	 "),
	Mreductions		fixed bin int static options(constant) init (9999),
	MMstack_depth		fixed bin int static options(constant) init (9999),
	Mtokens			fixed bin int static options(constant) init (9999),
	NP			char(2) int static options(constant) init ("
"),						/* <NP><NL>				*/
	Sinitialization_reqd	bit(1) aligned int static init ("1"b),
	breaks			char(19) varying aligned int static options(constant) init (" 	
/\<>[]()-^=;,"),					/* BS SP HT NL / \ < > [ ] ( ) - ^ = ; , VT NP	*/
	1 error_control_table (26)	aligned internal static options(constant),
						/* reduction compiler error message text and 	*/
						/* action specifications.			*/
	  /* 1     2     3     4     5     6     7     8     9    10    11    12    13    14    15	*/
	  /*16    17    18    19    20    21    22    23    24    25    26    27    28    29    30	*/
	  2 severity		fixed bin(17) unaligned init (
	     3,    2,    2,    3,    3,    2,    4,    4,    4,    4,    3,    4,    3,    2,    3,
	     3,    4,    2,    3,    4,    3,    3,    3,    3,    3,    3),
						/* severity of each error.			*/
	  2 Soutput_stmt		bit(1) unaligned init (
	    "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b,
	    "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b),
						/* on if "current" statement should be output	*/
						/* with the error message.			*/
	  2 message		char(252) varying init (
	  /*  1 */
"The reduction source segment does not contain any valid reductions.",
	  /*  2 */
"The statement is not a valid attribute declaration or
reduction.  (Remember, the label of the first reduction must
be 'BEGIN'.)",
	  /*  3 */
"Label '^a' is invalid.  The label has been ignored.",
	  /*  4 */
"Label '^a' in the next-reduction field of the
reduction statement is invalid.  The label has been ignored.",
	  /*  5 */
"Unexpected end encountered.  The reduction source segment ends
with an incomplete reduction.",
	  /*  6 */
"Unexpected statement encountered when the end of the reduction
source segment was expected.",
	  /*  7 */
"Compiler restriction:  the reduction source segment contains
more than ^d labels.  Label '^a'
and all labels which follow it have been ignored.",
	  /*  8 */
"Compiler restriction:  the reduction source segment contains
more than ^d reductions.  The reduction on line ^d,
and those which follow it, could not be compiled.",
	  /*  9 */
"Compiler restriction:  the reduction source segment contains
more than ^d tokens.  Token '^a'
could not be compiled.",
	  /* 10 */
"Compiler restriction:  the reduction source segment contains
too many different tokens.  Because more than ^d token value
characters have been defined, token '^a'
could not be compiled.",
	  /* 11 */
"Label '^a' is undefined.  The reference to this label
could not be resolved.",
	  /* 12 */
"The reduction source segment is too large to compile, causing
the object segment to overflow.",
	  /* 13 */
"Label '^a' has been multiply-defined.",
	  /* 14 */
"Token requirement '^a' appears in a reduction
after a <no-token> token requirement.  This combination of
requirements could never be satisfied.  Therefore, the reduction
will be ignored.",
	  /* 15 */
"Label '^a' in the next-reduction field
of a reduction is invalid.  In addition, the next-reduction field
contains more than one label.  This is not allowed.",
	  /* 16 */
"The next-reduction field of a reduction contains more than one label.
This is not allowed.",
	  /* 17 */
"Compiler restriction:  the reduction source segment contains
more than ^d token requirement functions.
Function '<^a>' could not be compiled.",
	  /* 18 */
"Compiler restriction:  the number specified in a 'MAX_DEPTH'
attribute declaration is out of bounds.  The allowable range is:
^2-0 < MAX_DEPTH < ^d
A maximum depth of ^d will be assumed.",
	  /* 19 */
"The '^a' built-in action routine has been used improperly
in a reduction.",
	  /* 20 */
"In attempting to compile the reduction on line ^d,
the estimated number of reductions (^d) was exceeded.
The reduction on line ^d, and those which follow it,
could not be compiled.",
	  /* 21 */
"Unexpected '^a' in the action field of the reduction statement.",
	  /* 22 */
"One or more fields are missing from a reduction.  All of the
reduction fields (label, syntax, action, & next-label field)
must be supplied.",
	  /* 23 */
"A quoted string appears as the name of a semantic subroutine
in the action field.  This is not permitted.  The reduction
has been ignored.",
	  /* 24 */
"A right parenthesis ()) is missing from the action field of
a reduction.",
	  /* 25 */
"The reduction segment ends with an incomplete reduction.",
            /* 26 */
"The reduction delimiters in the reduction segment were not
found or were positioned improperly."),
						/* text of the error message.			*/
	  2 brief_message		char(64) varying init (
	  /*  1 */
"No reductions.",
	  /*  2 */
"Invalid statement.",
	  /*  3 */
"Invalid label '^a' ignored.",
	  /*  4 */
"Invalid label '^a' ignored.",
	  /*  5 */
"Reductions are incomplete.",
	  /*  6 */
"Unexpected statement after end of reductions.",
	  /*  7 */
"Restriction: >^d labels.  '^a' ignored.",
	  /*  8 */
"Restriction: >^d reductions.  Line ^d ignored.",
	  /*  9 */
"Restriction: >^d tokens.  '^a' ignored.",
	  /* 10 */
"Restriction: >^d token characters.  '^a' ignored.",
	  /* 11 */
"Label '^a' undefined.",
	  /* 12 */
"Object segment overflow.",
	  /* 13 */
"Label '^a' multiply-defined.",
	  /* 14 */
"'^a' appears after <no-token>.",
	  /* 15 */
"Label '^a' invalid & >1 next-reduction labels.",
	  /* 16 */
">1 label in next-reduction field.",
	  /* 17 */
"Restriction: >^d token requirement functions.  '<^a>' ignored.",
	  /* 18 */
"Restriction:  0 < MAX_DEPTH < ^d.  ^d assumed.",
	  /* 19 */
"'^a' built-in used improperly.",
	  /* 20 */
"#_reductions > ^s^d estimate.",
	  /* 21 */
"Unexpected '^a' ignored.",
	  /* 22 */
"Incomplete reduction.",
	  /* 23 */
"Quoted subroutine name.",
	  /* 24 */
"')' missing from action field.",
	  /* 25 */
"Reductions incomplete.",
	  /* 26 */
"Bad reduction delimiters."),
	ignored_breaks		char(5) varying aligned int static options(constant) init (" 	
"),					/* SP HT NL VT NP					*/
         (error_table_$fatal_error,
	error_table_$improper_data_format)
				fixed bin(35) ext static,
	lex_control_chars		char(128) varying aligned int static,
	lex_delims		char(128) varying aligned int static,
	nl			char(1) aligned int static options(constant) init ("
"),
	spaces			char(120) aligned int static options(constant) init ((120)" ");

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


	Acode = 0;				/* initialize error code.			*/
	SERROR_CONTROL = Scontrol;
	S_TRACE = substr(bit(Scontrol,36),3,1);
	if S_TRACE then S_TRACE_ON = substr(bit(Scontrol,36),4,1);
	else S_TRACE_ON = "0"b;
	TRACING = S_TRACE;
	Pobj_spaces = addr(spaces);
	Pstmt, Pthis_token = null;			/* start out with no input tokens.		*/
	Ired_start = index(source,"/*++");		/* find reductions in reduction source segment.	*/
	Ired_end = index(source,"++*/");
	if (Ired_start = 0) | (Ired_end = 0) | (Ired_start+4 >= Ired_end-1) then do;
	     call ERROR(26);
	     Acode = error_table_$improper_data_format;
	     go to RETURN;
	     end;
	Ired_start = Ired_start + 4;			/* skip over delimiters.			*/
	Ired_end = Ired_end - 1;
	if Sinitialization_reqd then do;		/* initialize static variables.		*/
	   call lex_string_$init_lex_delims ("""", """", "\""", nl, "\", "10"b,
		breaks, ignored_breaks, lex_delims, lex_control_chars);
	     Sinitialization_reqd = "0"b;
	     end;
	call lex_string_$lex (Psource, Ired_end-Ired_start+1, Ired_start-1, Psegment, "1"b,
	   """", """", "\""", nl, "\", breaks, ignored_breaks,
	     lex_delims, lex_control_chars, null, Ptoken, code);
	if code ^= 0 then				/* lex source segment into tokens.		*/
	     call ERROR(25);
	if Ptoken = null then do;
	     Acode = code;
	     go to RETURN;
	     end;
	Pthis_token = Ptoken;
	call SEMANTIC_ANALYSIS;			/* perform semantic analysis of tokens.		*/
RETURN:	Mseverity = MERROR_SEVERITY;
	if Mseverity > 2 then do;			/* Fatal error?  Return nothing.		*/
	     ALobj = 0;
	     if Acode = 0 then
		Acode = error_table_$fatal_error;
	     end;
	return;					/* All done!				*/

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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* RELATIVE SYNTAX FUNCTIONS							*/
	/*									*/
	/*      The relative syntax functions below are invoked to compare the input tokens	*/
	/* with specifications built into the function.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


PUSH_DOWN_LANGUAGE:	procedure returns (bit(1) aligned);	/* returns "1"b if a 'PUSH DOWN LANGUAGE' is being*/
						/* compiled.				*/

	return (S_PDL);

	end PUSH_DOWN_LANGUAGE;

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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ACTION ROUTINES:								*/
	/*									*/
	/*      The action routines below are invoked at various stages of the compilation	*/
	/* process to impart semantic meaning to the series of tokens which have passed the	*/
	/* syntactic analysis tests of the input reductions.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


action_begin:	procedure;			/* invoked when beginning to compile the actions	*/
						/* associated with a particular reduction.	*/

	call output ("
RD_ACTION(");					/* output label array constant identifying rtn.	*/
	call output_number (Nobj_red);
	call output ("):					/* /					*/
");
	end action_begin;

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


compile_token:	procedure (type);			/* invoked to compile a syntax specification for	*/
						/* the reduction being parsed.		*/

     dcl	type			fixed bin;	/* type of specification to be compiled. (In)	*/
						/*   0 = compile absolute token requirement whose	*/
						/*       value is the character string value of	*/
						/*       the "current" token.			*/
						/*   1 = compile test to see if input token 	*/
						/*       chain is exhausted (<no-token>).	*/
						/*   2 = compile test for any token value	*/
						/*       (<any-token>).			*/
						/*   3 = compile test for a PL/I identifier	*/
						/*       (<name>) of 32 or fewer characters.	*/
						/*   4 = compile test for token which is a	*/
						/*       <decimal-integer>.			*/
						/*   5 = compile test for token which is a single	*/
						/*       backspace character (<BS>).		*/
						/*   6 = compile test for token which is a	*/
						/*       <quoted-string>.			*/
						/*   7 = compile relative token requirement fcn.	*/

	Nobj_token = obj_token.N + 1;			/* increment count of object tokens.		*/
	if Nobj_token > obj_token.M then do;		/* make sure we don't overflow obj token table.	*/
	     call lex_error_ (9, SERROR_PRINTED(9), (error_control_table(9).severity), MERROR_SEVERITY,
			  addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(9).message),
			  (error_control_table(9).brief_message), obj_token.M, token_value);
	     go to RETURN;
	     end;
	obj_token.N = Nobj_token;			/* append token to obj token array, and to list 	*/
	obj_red.Ilast (Nobj_red) 			/* of object tokens related to reduction being	*/
	     = obj_red.Ilast (Nobj_red) + 1;		/* parsed.				*/
	go to comp (type);				/* compile the appropriate type of token.	*/

comp(0):	i = index (obj_string, token_value);		/* see if current token exists in string	*/
						/* of previously-defined token values.		*/
	if i > 0 then do;				/* if so, use previously-defined string.	*/
	     obj_token.form (Nobj_token) = i;
	     obj_token.type (Nobj_token) = token.Lvalue;
	     obj_token_quoted (Nobj_token) = token.S.quoted_string;
	     end;
	else do;					/* if not found, add it to obj token string	*/
						/* values.				*/
	     Soptimize_possible = "0"b;		/* optimization of obj token storage requirements	*/
						/* no longer possible for this reduction.	*/
	     if token.Lvalue + length (obj_string) > Lobj_string then do;
		call lex_error_ (10, SERROR_PRINTED(10), (error_control_table(10).severity), MERROR_SEVERITY,
			       addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(10).message),
			       (error_control_table(10).brief_message), Lobj_string, token_value);
		go to RETURN;			/* complain if token too big for object string.	*/
		end;
	     else do;
		obj_token.form (Nobj_token) = length (obj_string) + 1;
		obj_token.type (Nobj_token) = token.Lvalue;
		obj_token_quoted (Nobj_token) = token.S.quoted_string;
		obj_string = obj_string || token_value;
		end;
	     end;
	return;
comp(1):
comp(2):
comp(3):
comp(4):
comp(5):
comp(6):	obj_token.form (Nobj_token) = 0;		/* indicate built-in nature of object token.	*/
	obj_token.type (Nobj_token) = type;		/* set appropriate object token type.		*/
	return;

comp(7):	obj_token.form (Nobj_token) = -1;
	do Nobj_token_fcn = 1 to obj_token_fcn.N while (obj_token_fcn.name(Nobj_token_fcn) ^= token_value);
	     end;					/* see if it was previously defined.		*/
	if Nobj_token_fcn <= obj_token_fcn.N then do;	/* yes, it was.				*/
	     obj_token.type (Nobj_token) = Nobj_token_fcn;
	     return;
	     end;

	if Nobj_token_fcn > dimension (obj_token_fcn.name, 1) then do;
	     call lex_error_ (17, SERROR_PRINTED(17), (error_control_table(17).severity), MERROR_SEVERITY,
			  addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(17).message),
			  (error_control_table(17).brief_message), dimension(obj_token_fcn.name,1), token_value);
						/* complain if no more room to define functions.	*/
	     go to RETURN;
	     end;
	obj_token.type(Nobj_token) = Nobj_token_fcn;
	obj_token_fcn.N = Nobj_token_fcn;
	obj_token_fcn.name(Nobj_token_fcn) = token_value;

	end compile_token;

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


count_reduction:	proc;				/* invoked during pass 1 to count the number of	*/
						/* reductions and tokens being compiled.	*/

	Nreductions = Nreductions + 1;		/* count reduction being parsed.		*/
	if Nreductions > Mreductions then do;		/* check for too many reductions.		*/
	     Nreductions = Mreductions;
	     Ptoken = Pthis_token;
	     Pstmt = token.Pstmt;
	     call lex_error_ (8, SERROR_PRINTED(8), (error_control_table(8).severity), MERROR_SEVERITY,
			  addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(8).message),
			  (error_control_table(8).brief_message), Mreductions, fixed (stmt.line_no,35));
	     go to RETURN;
	     end;
	Pstmt = token.Pstmt;
	Llongest_red = min (254, max(Llongest_red, length(stmt_value)));
	return;

count_token:	entry (N);

     dcl	N			fixed bin;	/* number of tokens to be counted. (In)		*/

	Ntokens = min (Mtokens, Ntokens + 1);		/* By counting every token requirement of each	*/
						/* reduction, we get an upper limit on the number	*/
						/* of object tokens.			*/
	do i = 1 to N;				/* in each reduction, count length of every token	*/
	     Lobj_string = min (Mtokens, Lobj_string + token.Lvalue);
	     Ptoken = token.Pnext;			/* to get upper limit on length of string in which*/
	     end;					/* tokens will be stored by compiler.	*/

	end count_reduction;

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


label_value:	procedure (label_sought)		/* invoked to obtain the reduction number which	*/
		returns	(fixed bin(17));		/* is the value of a given reduction label.	*/

     dcl	label_sought		char(*),		/* name of label whose value is sought. (In)	*/
	i			fixed bin;	/* do group index.				*/

	do i = 1 to obj_label.N while (obj_label.name(i) ^= label_sought);
	     end;					/* search for the sought label in list of defined	*/
						/* labels.				*/
	if i > obj_label.N then do;			/* if label not found in list, complain.	*/
	     call ERROR(11);
	     return(1);				/* return value for first reduction.		*/
	     end;
	else					/* if label found, return its value.		*/
	     return (obj_label.reduction_no(i));

	end label_value;

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


next_reduction:	procedure;			/* invoked to compile the next-reduction field of	*/
						/* a reduction where no label is specified.  This	*/
						/* means "proceed with the next reduction".	*/

	call output ("	go to RD_NEXT_REDUCTION;			/* /	\				*/
");

	end next_reduction;

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


number:	procedure (no, statement) returns (char(*));	/* Procedure to put a sequence number at the 	*/
						/* beginning of each reduction (in label field).	*/
     dcl	no			fixed bin,
	statement			char(*);

     dcl	Isearch			fixed bin,
	number			char(4) varying;

	number = ltrim(char(no));
	if substr(ltrim(statement, HT_SP), 1, 1) = "/" then do;
						/* Don't put in a sequence number if a label	*/
						/* is already present.			*/
	     if substr(statement,1,1) = HT then
		return (number || statement);
	     if substr(statement,1,length(number)) = "" then
		return (number || substr(statement, length(number)+1));
	     if substr(statement,1,1) = "/" then
		return(statement);
	     end;

	Isearch = verify(statement, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789");
	Isearch = (Isearch-1) + verify(substr(statement,Isearch), HT_SP);
	if substr(statement,Isearch,1) = NL then do;	/* Look for label on line by itself, with next	*/
						/*   line starting with whitespace.		*/
	     Isearch = Isearch + 1;
	     if substr(statement,Isearch,1) = HT then	/*   line begins with HT.			*/
		return (substr(statement,1,Isearch-1) || number ||
		     substr(statement,Isearch));
	     if substr(statement,Isearch,length(number)) = "" then
		return (substr(statement,1,Isearch-1) || number ||
		     substr(statement,Isearch+length(number)));
	     end;
	return (statement);

	end number;

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


output:	procedure	(chars);				/* invoked to write a character string into the	*/
						/* object segment.				*/

     dcl	chars			char(*);		/* the character string to be written. (In)	*/

	if length (chars) > Lobj then do;		/* make sure character string will fit.		*/
	     call ERROR(12);
	     go to RETURN;				/* give up completely.  This error is very fatal.	*/
	     end;
	substr (obj, 1, length(chars)) = chars;
	Pobj = addr (substr (obj, length(chars)+1));
	Lobj = Lobj - length(chars);
	Lobj_part = Lobj_part + length(chars);

	end output;

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



output_quote:	procedure (chars);			/* invoked to write a character string into the	*/
						/* object segment, handling the doubling of quotes*/
						/* if necessary.				*/

     dcl	chars			char(*);		/* the character string (possibly containing	*/
						/* quotes which must be doubled) to be output.	*/
     dcl	Iquote			fixed bin(21),	/* index into part of character string.		*/
	Lpart			fixed bin(21),	/* length of part of character string.		*/
	Ppart			ptr,		/* ptr to part of character string.		*/
	up_to_quote		char(Iquote) based (Ppart),
						/* part of part up to the next quote.		*/
	part			char(Lpart) based (Ppart);
						/* part of character string.			*/

	call output ("""");
	Ppart = addr(chars);
	Lpart = length(chars);
	Iquote = index(part, """");
	do while (Iquote > 0);
	     call output (up_to_quote);
	     call output ("""");
	     Ppart = addr(substr(part,Iquote+1));
	     Lpart = Lpart - Iquote;
	     Iquote = index(part, """");
	     end;
	if Lpart > 0 then call output (part);
	call output ("""");

	end output_quote;


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


output_number:	procedure (number);			/* invoked to convert a number to a character	*/
						/* string, strip off leading blanks, and output	*/
						/* the result.				*/

     dcl	number			fixed bin,	/* number to be output. (In)			*/
	ltrim			builtin;

	Nchar = number;				/* convert number to a character string.	*/
	call output (ltrim(Nchar));

	end output_number;

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


output_source:
     	procedure (Ostart, Iend);

     dcl	Ostart			fixed bin(21),
	Iend			fixed bin(21);

     dcl	Lsource_part		fixed bin(21),
	Psource_part		ptr,
	source_part		char(Lsource_part) based(Psource_part);

	Psource_part = addcharno(addr(source), Ostart);
	Lsource_part = Iend - Ostart;
	call output (source_part);

	end output_source;

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


output_var:	procedure (chars);			/* invoked to write a varying character string	*/
						/* into the output segment.			*/

     dcl	chars			char(*) varying aligned;
						/* the character string to be written. (In)	*/

	if length (chars) > Lobj then do;		/* make sure character string will fit.		*/
	     call ERROR(12);
	     go to RETURN;
	     end;
	else do;
	     substr (obj, 1, length(chars)) = chars;
	     Pobj = addr (substr (obj, length(chars)+1));
	     Lobj = Lobj - length(chars);
	     Lobj_part = Lobj_part + length(chars);
	     end;

	end output_var;

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


reduction_begin:	procedure;			/* invoked to begin parsing a reduction.	*/

	Nobj_red = obj_red.N + 1;			/* address the next object reduction.		*/
	if Nobj_red > obj_red.M then do;		/* if there is none, complain.		*/
	     Pstmt = token.Pstmt;
	     call lex_error_ (20, SERROR_PRINTED(20), (error_control_table(20).severity), MERROR_SEVERITY,
			  Pstmt, Ptoken, SERROR_CONTROL, (error_control_table(20).message),
			  (error_control_table(20).brief_message), fixed(stmt.line_no,35), obj_red.M,
			  fixed(stmt.line_no,35));
	     go to RETURN;
	     end;

	obj_red.Ifirst (Nobj_red) = obj_token.N + 1;	/* initiate indices of first/last token req'mts	*/
	obj_red.Ilast (Nobj_red) = obj_token.N;		/* to reflect no token requirements (so far).	*/
	Soptimize_possible = "1"b;			/* indicate optimization of token requirements is	*/
						/* possible (so far).			*/
	end reduction_begin;

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


reduction_end:	procedure;			/* invoke to end parsing of a reduction.	*/

	obj_red.N = Nobj_red;			/* Formally add the completed reduction to the	*/
						/* object reduction array.			*/
	if Soptimize_possible then;			/* All end work involves optimization of token	*/
	else					/* requirement storage.  If optimization not	*/
	     return;				/* possible, quit while we're ahead.		*/
	if obj_red.Ifirst (Nobj_red) > obj_red.Ilast (Nobj_red) then
	     return;				/* same if no token requirements associated with	*/
						/* the reduction.				*/
	form = obj_token.form (obj_red.Ifirst(Nobj_red));	/* for efficiency, save value of first token 	*/
	type = obj_token.type (obj_red.Ifirst(Nobj_red));	/* requirement associated with reduction.	*/
	do i = 1 to obj_red.Ifirst(Nobj_red) - 1;	/* search through previously-defined token	*/
	     if obj_token.form(i) = form then		/* requirements for a series which match those	*/
	     if obj_token.type(i) = type then do;	/* associated with reduction.			*/
		do j = 1 to obj_red.Ilast(Nobj_red) - obj_red.Ifirst(Nobj_red);
		     if obj_token.form(i+j) = obj_token.form(obj_red.Ifirst(Nobj_red)+j) then
			if obj_token.type(i+j) = obj_token.type(obj_red.Ifirst(Nobj_red)+j) then;
			else
			     go to no_match;
		     else
			go to no_match;
		     end;
		j = j - 1;			/* make j = do-group end limit above.		*/
		obj_token.N = max(obj_red.Ifirst(Nobj_red)-1, i+j);
		obj_red.Ifirst (Nobj_red) = i;	/* if search succeeds, use previously-defined	*/
		obj_red.Ilast (Nobj_red) = i + j;	/* tokens in this reduction.			*/
		return;
no_match:		end;
	     end;

	end reduction_end;

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


reductions_begin:	procedure;			/* invoked before parsing the first reduction to	*/
						/* temporary storage for object reductions, object*/
						/* tokens, and object token strings.		*/
						/* Also initialize object segment and maximum	*/
						/* severity value.				*/
	Pobj_red = translator_temp_$allocate (Psegment, size(obj_red));
	obj_red.M = Nreductions;
	Pobj_token = translator_temp_$allocate (Psegment, size(obj_token));
	obj_token.M = Ntokens;
	Pobj_token_quoted = translator_temp_$allocate (Psegment, size(obj_token_quoted));
	Pobj_string = translator_temp_$allocate (Psegment, size(obj_string));
	if S_TRACE then
	     Llongest_red = min(254, Llongest_red + log(Nreductions));
	obj_red.N = 0;
	obj_token.N = 0;
	string (obj_token_quoted) = "0"b;
	obj_token_fcn.N = 0;
	Pobj = APobj;
	Lobj = ALobj;

	end reductions_begin;

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


reductions_end:	procedure;			/* invoked after all reductions have been parsed,	*/
						/* and after action routine calls have been	*/
						/* output.				*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) Store maximum severity as an output value.  If it is greater than 2, return with	*/
	/*    an empty object segment as output.					*/
	/* 2) Otherwise:								*/
	/*    a) copy the action routine calls which have already been output into temporary	*/
	/*       storage.								*/
	/*    b) re-initialize the output object segment to zero length.			*/
	/*    c) output declarations for the object reduction and token structures.		*/
	/*    d) re-output the copied action routine calls.				*/
	/*    e) output an end statement.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if MERROR_SEVERITY > 2 then
	     go to RETURN;
	if obj_red.N = 0 then do;			/* if there is no output, give up.		*/
	     call ERROR(1);
	     go to RETURN;
	     end;
	Ptemp = APobj;				/* copy contents of object segment output so far	*/
	Ltemp = ALobj - Lobj;			/* to temp storage so we can reuse		*/
	Ltemp_obj = Ltemp;				/* space at head of object segment.		*/
	Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj));
	temp_obj = temp;
	Pobj = APobj;
	Lobj = ALobj;

	call output(NP);				/* output start of SEMANTIC_ANALYSIS subroutine.	*/
	if S_TRACE_ON then
	     call output ("
     dcl	TRACING			bit(1) aligned int static init(""1""b);
");
	else call output ("
     dcl	TRACING			bit(1) aligned int static init(""0""b);
");
	call output ("

%include rdc_start_;
");

	call output (NP);				/* output the reduction label stack.		*/
	if S_PDL then
	     call output ("     dcl	DIRECTION			fixed bin init(-1);	/* direction in which tokens compared.		*/
");
	else call output ("     dcl	DIRECTION			fixed bin init(+1);	/* direction in which tokens compared.		*/
");
	if Sinclude_STACK then do;
	     call output ("     dcl	STACK (");
	     call output_number (Mstack_depth);
	     call output (")   		fixed bin,	/* reduction label stack.			*/
	STACK_DEPTH		fixed bin init (0);	/* index into STACK.			*/
");
	     end;

						/* output declaration for object reductions.	*/
	call output ("

     dcl	1 REDUCTION (");
	call output_number (obj_red.N);
	call output (")		unaligned based (addr (REDUCTIONS)),
						/* object reductions.			*/
	  2 TOKEN_REQD,
");
	call output ("	    3 IFIRST		fixed bin(17),	/* index of first required token.		*/
	    3 ILAST		fixed bin(17),	/* index of last required token.		*/

	REDUCTIONS  (");
	call output_number (obj_red.N + obj_red.N);
	call output (")		fixed bin(17) unaligned internal static options(constant) initial (
");

	do i = 1 to obj_red.N;
	     call output ("	     ");
	     if S_PDL then Nchar = obj_red.Ilast (i);
		    else Nchar = obj_red.Ifirst(i);
	     call output ((Nchar));
	     call output (", ");
	     if S_PDL then Nchar = obj_red.Ifirst(i);
		    else Nchar = obj_red.Ilast (i);
	     call output ((Nchar));
	     if i = obj_red.N then
		call output (");	/* ");
	     else
		call output (",	/* ");
	     Nchar = i;
	     call output ((Nchar));
	     call output ("/  ");
	     Lobj_part = 41;
	     do j = obj_red.Ifirst(i) to obj_red.Ilast(i);
		if obj_token.form(j) > 0 then do;
		     Pobj_string_part = addr(substr(obj_string, obj_token.form(j)));
		     Lobj_string_part = obj_token.type(j);
		     if obj_token_quoted(j) then
			call output_quote (obj_string_part);
		     else call output (obj_string_part);
		     call output (" ");
		     end;
		else if obj_token.form(j) = 0 then do;
		     go to comment (obj_token.type(j));

comment(1):	     call output ("<no-token> ");
		     go to end_comment;
comment(2):	     call output ("<any-token> ");
		     go to end_comment;
comment(3):	     call output ("<name> ");
		     go to end_comment;
comment(4):	     call output ("<decimal-integer> ");
		     go to end_comment;
comment(5):	     call output ("<BS> ");
		     go to end_comment;
comment(6):	     call output ("<quoted-string> ");
end_comment:	     end;
		else do;
		     call output ("<");
		     call output_var (obj_token_fcn.name(obj_token.type(j)));
		     call output ("> ");
		     end;
		end;
	     Lobj_spaces = max(0, 110-Lobj_part);
	     call output (obj_spaces);
	     call output ("*/
");
	     end;

	call output (NP);				/* output declaration for object tokens.	*/
	call output ("     dcl	1 TOKEN_REQUIREMENT (");
	call output_number (obj_token.N);
	call output (")	unaligned based (addr (TOKEN_REQUIREMENTS)),
						/* object token requirements.			*/
	  2 FORM			fixed bin(17),	/* form of the token requirement:		*/");
	call output ("
						/*  -1 = relative token requirement function;	*/
						/*       TYPE = index of the particular token	*/
						/*	      function in the token_fcn array.	*/
						/*   0 = built-in token requirement function;	*/");
	call output ("
						/*       TYPE = as defined below.		*/
						/*  >0 = absolute token requirement:		*/
						/*       FORM = index(TOKEN_STRINGS,TOKEN_REQD);	*/
						/*       TYPE = length(TOKEN_REQD);		*/");
	call output ("
	  2 TYPE			fixed bin(17) unal,	/* type of the built-in token requirement	*/
						/* function:				*/
						/*   1 = compile test to see if input token 	*/");
	call output ("
						/*       chain is exhausted (<no-token>).	*/
						/*   2 = compile test for any token value	*/
						/*       (<any-token>).			*/");
	call output ("
						/*   3 = compile test for a PL/I identifier	*/
						/*       (<name>) of 32 or fewer characters.	*/
						/*   4 = compile test for token which is a	*/
						/*       <decimal-integer>.			*/");
	call output ("
						/*   5 = compile test for token which is a single	*/
						/*       backspace character (<BS>).		*/
						/*   6 = compile test for a token which is a	*/
						/*       <quoted-string>.			*/");
	call output ("

	TOKEN_REQUIREMENTS  (");
	call output_number (obj_token.N + obj_token.N);
	call output (")	fixed bin(17) unaligned internal static options(constant) initial (");
	do i = 1 to obj_token.N;
	     call output ("
	     ");
	     do i = i to min (obj_token.N, i + 6);
		Nchar = obj_token.form(i);
		call output ((Nchar));
		call output (",");
		Nchar = obj_token.type(i);
		call output ((Nchar));
		if i = obj_token.N then
		     call output (");
");
		else
		     call output (",   ");
		end;
	     i = i - 1;
	     end;

	i = length (obj_string);			/* output declaration for object token values.	*/
	call output ("

     dcl	TOKEN_STRINGS		char(");
	call output_number (i);
	call output (") aligned based (addr (TOKEN_STRING_ARRAYS)),
						/* object token values.			*/
");
	i = divide (length(obj_string),100,17,0) + 1;	/* compute number of 100-char substrings.	*/
	call output ("	TOKEN_STRING_ARRAYS (");
	call output_number (i);
	call output (")	char(100) aligned internal static options(constant) initial (
");
	Lobj_string_part = 100;
	do i = 0 to i-2;
	     call output ("	     """);
	     Pobj_string_part = addr (substr (obj_string, i*100+1));
	     call output (obj_string_part);
	     call output (""",
");
	     end;
	call output ("	     """);
	Pobj_string_part = addr (substr (obj_string, i*100+1));
	Lobj_string_part = length(obj_string) - i*100;
	call output (obj_string_part);
	call output (""");
");

	call output (NP);				/* output include statement for end semant.	*/
	call output ("	%include rdc_end_;
");
	if obj_token_fcn.N > 0 then do;		/* output relative syntax function calls, if any. */
	     call output ("
	     else do;				/* relative syntax function.			*/
		go to RD_TOKEN_FCN(TOKEN_REQD.TYPE);
");
	     do i = 1 to obj_token_fcn.N;
		call output ("
RD_TOKEN_FCN(");	call output_number(i);
		call output("):	STOKEN_FCN = ");
		call output_var (obj_token_fcn.name(i));
		call output ("();
		go to RD_TEST_RESULT;");
		end;
	     call output ("

RD_TEST_RESULT:	if STOKEN_FCN then go to RD_MATCH;
		else go to RD_NEXT_REDUCTION;
		end;
");
	     end;

	if S_PDL then
	     call output ("
RD_MATCH:	     Ptoken = token.Plast;
RD_MATCH_NO_TOKEN:
	     end;
	Ptoken = Pthis_token;
");
	else call output ("
RD_MATCH:      Ptoken = token.Pnext;
RD_MATCH_NO_TOKEN:
	     end;
	Ptoken = Pthis_token;
");
	if S_TRACE then do;
	     call output ("
	if TRACING then do;
	     call PRINT_REDUCTION(NRED);
	     call PRINT_TOKENS (DIRECTION, (RED.TOKEN_REQD.IFIRST), (RED.TOKEN_REQD.ILAST));
	     end;
");
	     end;
	call output ("	go to RD_ACTION(NRED);
");

	if Sinclude_STACK then do;			/* include the label stack functions.		*/
	     call output (NP);
	     call output ("	%include rdc_stack_fcns_;
");
	     end;

	call output (NP);				/* output action routine calls saved previously.	*/
	call output (temp_obj);
	if S_TRACE then do;
	     call output (NP);
	     call output ("%include rdc_tracing_fcns_;
");
	     end;
	call output ("

	end SEMANTIC_ANALYSIS;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
");

	call output (NP);				/* define the PUSH DOWN LANGUAGE switch and	*/
						/*   include the LEX subroutine in object seg.	*/
	if S_PDL then
	     call output ("     dcl	SPDL			bit(1) aligned init (""1""b);
						/* on: This compiler parses a PUSH DOWN LANGUAGE.	*/

");	else
	     call output ("     dcl	SPDL			bit(1) aligned init (""0""b);
						/* off: This compiler parses a non-PUSH DOWN	*/
						/*      LANGUAGE.				*/
");
	if Sinclude_LEX then
	     call output ("	%include rdc_lex_;
");
	if Sinclude_DELETE then do;			/* include the DELETE subroutine.		*/
	     call output (NP);
	     call output ("	%include rdc_delete_;
");	     end;
	if Sinclude_DELETE_STMT then do;		/* include the DELETE_STMT subroutine.		*/
	     call output (NP);
	     call output ("	%include rdc_delete_stmt_;
");	     end;
	if Sinclude_ERROR then do;			/* output include statement for ERROR message proc*/
	     call output (NP);
	     call output ("	%include rdc_error_;
");
	     end;

	if Sinclude_NEXT_STMT then do;		/* output NEXT_STMT proc.			*/
	     call output (NP);
	     call output ("	%include rdc_next_stmt_;
");
	     end;

	if S_TRACE then do;
	     call output (NP);
	     call output ("     dcl	RED_TEXT (");
	     call output_number (Nreductions);
	     call output (")		char (");
	     call output_number (Llongest_red);
	     Llongest_red = Llongest_red - log(Nreductions);
						/* leave room for reduction number.		*/
	     call output (") varying int static options(constant) init (
");
	     Pstmt = Psave -> token.Pstmt;
	     call output_quote (number(1, substr(stmt_value,1,min(length(stmt_value), Llongest_red))));
	     do i = 2 to Nreductions;
		call output (",
");
		Pstmt = stmt.Pnext;
		call output_quote (number(i, substr(stmt_value,1,min(length(stmt_value), Llongest_red))));
		end;
	     call output (");
");
	     end;

	Ptemp = APobj;				/* again, copy what we've generated in obj seg	*/
	Ltemp = ALobj - Lobj;			/* so we can reuse beginning.			*/
	Ltemp_obj = Ltemp;
	Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj));
	temp_obj = temp;

	Pobj = APobj;				/* output segment header for object segment.	*/
	Lobj = ALobj;
	call output ("

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* COMPILED OUTPUT OF SEGMENT  ");
	call output (Aname_source);
	call output ("	*/
	/* Compiled by:  reduction_compiler, Version 2.5 of Oct 21, 1985      */
	/* Compiled on:  ");
	date = date_time_$format ("date_time", clock_(), "", "");
	call output (date);
	call output ("*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
");
	call output(NP);

	Pstmt = Psave -> token.Pstmt;			/* copy source into object segment.		*/
	Osc_start = 0;				/*   each reduction is written separately so it	*/
	do i = 1 to Nreductions;			/*   can be numbered for ease of debugging.	*/
	     call output_source (Osc_start, charno(addr(stmt_value)));
	     call output (number(i, stmt_value));
	     Osc_start = charno(addr(stmt_value)) + length(stmt_value);
	     Pstmt = stmt.Pnext;
	     end;
	call output_source (Osc_start, length(source));

	call output(temp_obj);			/* output object previously generated & saved.	*/
						/* output final end statement for translator.	*/
	call suffixed_name_$new_suffix (Aname_source, "rd", "", name_source, code);
	call output ("
	end ");
	call output (rtrim(name_source));
	call output (";
");
	ALobj = ALobj - Lobj;			/* adjust length of object seg returned to caller.*/

	end reductions_end;

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


reductions_init:	procedure;			/* invoked before pass1 of parse to		*/
						/* initialize maximum stack depth, reduction and	*/
						/* token counters, & maximum object string length.*/
						/* Set switch to suppress inclusion of ERROR proc */
						/* unless is it actually referenced.  Do same for	*/
						/* reduction STACK fcns, NEXT_STMT proc, and	*/
						/* DELETE procs. Default to ^'PUSH DOWN LANGUAGE'.*/
	Mstack_depth = 10;				/* maximum stack depth is 10, by default.	*/
	Nreductions = 0;
	Ntokens = 0;
	Llongest_red = 0;
	Lobj_string = 0;
	obj_label.N = 0;
	S_PDL = "0"b;
	Sinclude_DELETE = "0"b;
	Sinclude_DELETE_STMT = "0"b;
	Sinclude_ERROR = "0"b;
	Sinclude_NEXT_STMT = "0"b;
	Sinclude_LEX = "0"b;
	Sinclude_STACK = "0"b;

	end reductions_init;

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


rtn:	procedure (type);				/* invoked to compile one of the pre-defined	*/
						/* (pre-, mid-, or post-) actions.		*/

     dcl	type			fixed bin;	/* type of action to be compiled.		*/
						/*   1 = LEX				*/
						/*   2 = POP				*/
						/*   3 = PUSH(<label>)			*/

	go to RTN(type);

RTN(1):	if S_PDL then do;
	     call output ("	call					     LEX(1);
");
	     Sinclude_LEX = "1"b;
	     end;
	else
	     call output ("	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
");	return;

RTN(2):	call output ("	STACK_DEPTH = max(STACK_DEPTH-1,0);		/*   POP					*/
");	Sinclude_STACK = "1"b;
	return;

RTN(3):	call output ("	call PUSH(");
	call output_number (label_value(token_value));
	call output (");				/*   PUSH(");
	Lobj_part = 70;
	call output (token_value);
	call output (")");
	Lobj_spaces = 110 - Lobj_part;
	call output (obj_spaces);
	call output ("*/
");	Sinclude_STACK = "1"b;
	return;

	end rtn;

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


set_action:	procedure;			/* invoked to compile a call to an action routine.*/

	call output ("	call					     ");
	call output (token_value);
	call output ("();
");

	end set_action;

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


set_action_with_args:	procedure;		/* invoked to compile a call to an action routine	*/
						/* that requires input arguments.		*/

	call output ("	call 					     ");
	call output (token_value);
	call output (" (");

	end set_action_with_args;

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


set_depth:	procedure;			/* invoked to set the maximum allowable depth of	*/
						/* the reduction stack.			*/

	Mstack_depth = token.Nvalue;
	if Mstack_depth <= 0 | Mstack_depth > MMstack_depth then do;
	     call lex_error_ (18, SERROR_PRINTED(18), (error_control_table(18).severity), MERROR_SEVERITY,
			  addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(18).message),
			  (error_control_table(18).brief_message), MMstack_depth, MMstack_depth);
	     Mstack_depth = MMstack_depth;
	     return;
	     end;

	end set_depth;

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


set_label:	procedure;			/* invoked to store an association between a	*/
						/* the label of a reduction and the number of the	*/
						/* reduction into the object label store.	*/

     dcl	N			fixed bin(17);	/* number of labels stored in object label array.	*/

	do N = 1 to obj_label.N while (obj_label.name(N) ^= token_value);
	     end;					/* see if label is already defined.		*/
	if N <= obj_label.N then do;			/* it is! Complain.				*/
	     call ERROR(13);
	     return;
	     end;
	if N > dimension (obj_label.set, 1) then do;
	     call lex_error_ (7, SERROR_PRINTED(7), (error_control_table(7).severity), MERROR_SEVERITY,
			  addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(7).message),
			  (error_control_table(7).brief_message), dimension(obj_label.set,1), token_value);
	     go to RETURN;
	     end;
	obj_label.N = N;
	obj_label.name(N) = token_value;
	obj_label.reduction_no(N) = Nreductions + 1;

	end set_label;

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


specified_label:	procedure;			/* invoked to compile the next-reduction field of	*/
						/* a reduction where a label was specified.  This	*/
						/* means "proceed with the reduction whose label	*/
						/* was specified".				*/

	call output ("	NRED = ");
	call output_number (label_value(token_value));
	call output (";
	go to RD_TEST_REDUCTION;			/* / ");
	Lobj_part = 0;
	call output (token_value);
	call output (" \");
	Lobj_spaces = max (0, 34 - Lobj_part);
	call output (obj_spaces);
	call output ("		*/
");

	end specified_label;

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


stacked_reduction:	procedure;			/* invoked to compile the next-reduction field of	*/
						/* a reduction where STACK is specified.  This	*/
						/* means "proced with the reduction whose label	*/
						/* is on the top of the reduction stack".	*/

	call output ("	go to RD_STACK;				/* / STACK	\			*/
");
	Sinclude_STACK = "1"b;

	end stacked_reduction;

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


stacked_reduction_pop:	procedure;		/* invoked to compile the next-reduction field of	*/
						/* a reduction where STACK_POP is specified. 	*/
						/* This means "proceed with the reduction whose	*/
						/* label is on the top of the reduction stack,	*/
						/* and pop the stack".			*/

	call output ("	go to RD_STACK_POP;				/* / STACK_POP	\			*/
");
	Sinclude_STACK = "1"b;

	end stacked_reduction_pop;

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


terminal_reduction:	procedure;			/* invoked to compile the next-reduction field of	*/
						/* a reduction where RETURN is specified.  This 	*/
						/* means "compilation is complete; return to the	*/
						/* caller of the compiler".			*/

	call output ("	return;					/* / RETURN	\			*/
");
	end terminal_reduction;

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







		    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
