



		    attribute_parse.pl1             10/03/83  1725.6rew 10/03/83  1006.1      125496



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


attribute_parse:
	procedure(cblock,sp,k,in_generic);

/*	This procedure is called to parse the attributes occuring in
	declare statements, in the returns( ) entry( ) attributes,
	and in the when( ) clause of the generic( ) attribute.
	Note that this procedure must be called with k (the index into
	the token_list) pointing to the token immediately before the
	attributes (if any). When it returns, k will have been advanced
	past any|all attributes, and will be on a comma, right_paren,
	or semi_colon.   */

/* Modified 780629 by PG for unsigned */
/* Modified 780807 by PG to fix 1652 (diagnose > 127 dimensions) */
/* Modified 780824 by RAB to fix 1776 (unsigned & signed not diagnosed as nonstandard) */
/* Modified 830427 by BIM for ptr options (packed) */

/* parameters */

dcl (	cblock ptr,
	sp ptr,
	k fixed bin (15),
	in_generic bit (1) aligned) parameter;

/* automatic */

dcl	(p,q,p1,p2) ptr;
dcl	(i, letterx, ndims) fixed bin;
dcl	type  bit(9) aligned;
dcl	word char(11);
dcl	(defined_parn,first_time,star) bit(1) aligned;

/* builtins */

dcl	(binary, null, string, substr, unspec) builtin;

/* external static */

dcl	pl1_stat_$one ptr external static;
dcl	pl1_stat_$check_ansi bit(1) aligned ext static;

/* internal static */

dcl	action_index (82) fixed bin (8) unal internal static initial (
	 0, /* aligned */  2, /* area */  0, /* auto */  0, /* automatic */  4, /* based */  3, /* bin */
	 3, /* binary */  2, /* bit */  0, /* builtin */  2, /* char */  2, /* character */  3, /* complex */
	 0, /* cond */  0, /* condition */  0, /* constant */  0, /* controlled */  3, /* cplx */  0, /* ctl */
	 3, /* dec */  3, /* decimal */  8, /* def */  8, /* defined */ 16, /* dim */ 16, /* dimension */
	 0, /* direct */ 12, /* entry */ 10, /* env */ 10, /* environment */  0, /* ext */  0, /* external */
	 0, /* file */  3, /* fixed */  3, /* float */  0, /* format */ 15, /* generic */  9, /* init */
	 9, /* initial */  0, /* input */  0, /* int */  0, /* internal */ 18, /* irred */ 18, /* irreducible */
	 0, /* keyed */ 13, /* label */ 14, /* like */  0, /* local */  0, /* member */  0, /* nonvar */
	 0, /* nonvarying */  5, /* offset */ 17, /* options */  0, /* output */  0, /* parameter */  0, /* parm */
	 6, /* pic */  6, /* picture */  0, /* pointer */  7, /* pos */  7, /* position */  3, /* prec */
	 3, /* precision */  0, /* print */  0, /* ptr */  3, /* real */  0, /* record */ 18, /* red */
	 18, /* reducible */ 11, /* returns */  0, /* seql */  0, /* sequential */ 18, /* signed */  0, /* static */
	 0, /* stream */  0, /* structure */  0, /* unal */  0, /* unaligned */ 18, /* uns */ 18, /* unsigned */
	 0, /* update */  0, /* var */  0, /* variable */  0 /* varying */);

/* program */

	p = sp;			/* copy parameter into automatic */
	first_time = "1"b;
	go to next;
ck_parn:
	if t_table.type ^= right_parn then call print(11);
next:
	k=k+1;
find_type:
	if token_list(k)=null then call print(7);
	type=t_table.type;
action(0):
test:
	if (type = comma) | (type = semi_colon) | (type = right_parn)
	then do;
		sp = p;		/* assign to parameter */

		if p->symbol.varying
		then do;
			p->symbol.aligned = "1"b;
			p->symbol.unaligned = "0"b;
		end;

		return;
	     end;
	if first_time
	then do;
	     first_time = "0"b;
	     if type = left_parn then go to action(16);
	     end;
	if type ^= identifier then call print(7);
	word=t_table.string;
	letterx = binary (unspec (substr (word, 1, 1)), 9);
	do i = index_given_letter (letterx) by 1 while (keyword (i) < word);
	end;
	if keyword (i) = word
	then do;
		substr(string(p->symbol.attributes),bit_index(i),1)="1"b;
		k=k+1;
		type=t_table.type;
		go to action(action_index(i));
	     end;
	call print(7);
action(1):
	call print(8);
	return;
action(2):				/* get size of strings or areas */
	if type ^= left_parn then go to test;
	k=k+1;

	p -> symbol.dcl_size = refer_exp();
	if p -> symbol.dcl_size = null then call print(12);
	go to ck_parn;
action(3):				/* get arithmetic precision */
	if type ^= left_parn then go to test;
	p->symbol.precision = "1"b;
	k=k+1;
	if t_table.type ^= dec_integer then call print(15);
	p->symbol.c_dcl_size = token_to_binary(token_list(k));
	if p->symbol.c_dcl_size = 0
	then call print(490);
	k=k+1;
	if in_generic
	     then if t_table.type = colon
		then do;
			k = k + 1;
			if t_table.type ^= dec_integer then call print(15);
			p->symbol.pic_size = token_to_binary(token_list(k));
			k = k + 1;
		     end;
		else p->symbol.pic_size = p->symbol.c_dcl_size;
	if t_table.type = comma
		then do;
			p->symbol.scale = get_scale();
			p->symbol.fixed = "1"b;
			if in_generic
			     then if t_table.type = colon
				     then p->symbol.pic_scale = get_scale();
				     else p->symbol.pic_scale = p->symbol.scale;
		     end;
	go to ck_parn;
action(4):				/* process the based attribute */
	if type ^= left_parn then go to test;
	k=k+1;
	p -> symbol.reference -> reference.qualifier = reference_parse(k,cblock);
	if p -> symbol.reference -> reference.qualifier = null then call print(18);
	if p -> symbol.reference -> reference.qualifier -> node.type = token_node
		then call context((p -> symbol.reference -> reference.qualifier),cblock,pointer_context);
	go to ck_parn;
action(5):				/* process the offset attribute */
	if type ^= left_parn then go to test;
	k=k+1;
	p -> symbol.general = reference_parse(k,cblock);
	if p -> symbol.general = null then call print(17);
	if p->symbol.general->node.type = token_node
		then call context((p->symbol.general),cblock,area_context);
	go to ck_parn;
action(6):				/* process the picture attribute */
	if type ^= char_string then go to test;
	p->symbol.general=token_list(k);
	go to next;
action(7):				/* process the position attribute */
	if type ^= left_parn then go to test;
	k=k+1;
	p -> symbol.initial = expression_parse(k,cblock);
	if p -> symbol.initial = null then call print(26);
	go to ck_parn;
action(8):				/* process the defined attribute */
	defined_parn = "0"b;
	if type = left_parn
	then do;
		defined_parn = "1"b;
		k = k + 1;
	     end;
	p -> symbol.equivalence = reference_parse(k,cblock);
	if p -> symbol.equivalence = null then call print(24);
	if defined_parn
	then go to ck_parn;
	else go to find_type;
action(9):				/* process the initial attribute */
	if type ^= left_parn then go to test;
	if p->symbol.initial ^= null then call print(19);
	p -> symbol.initial = initial_list();
	if p -> symbol.initial = null then call print(20);
	go to find_type;

action(10):				/* environment */
	if type ^= left_parn then go to test;
	k=k+1;
	if t_table.string= "interactive"
	     then p->symbol.interactive = "1"b;
               else if t_table.string="stringvalue" then  p->symbol.stringvalue="1"b;
	     else call print(193);
	k=k+1;
	if pl1_stat_$check_ansi
	then	call parse_error(355,token_list(k-3));
	go to ck_parn;

action(11):				/* process the returns attribute */
	if type ^= left_parn then go to test;
	q=descriptor_parse(cblock,create_token(p->symbol.token->t_table.string||"[return_value]",identifier),k);
	if q ^= null
	then do;
		if q->list.element(2) ^= null then call print(22);
		p->symbol.dcl_size,q=q->list.element(1);
		q->symbol.passed_as_arg = "1"b;
	     end;
	go to ck_parn;

action(12):				/* process the entry attribute */
	if type ^= left_parn then go to test;
	p->symbol.general = descriptor_parse(cblock,create_token(p->symbol.token->t_table.string||"[param",identifier),k);
	if p -> symbol.general = null
	then do;
		/* entry() -- add wart: a zero list node to prevent defaulting */
		/* this wart will be removed by validate after defaulting is complete */

		p->symbol.general=create_list(0);
	     end;
	go to ck_parn;

action(13):				/* process the label attribute */
	if type ^= left_parn then go to test;

	call print(6);

nxt:
	k=k+1;
	if t_table.type ^= identifier then call print(21);
	k=k+1;
	if t_table.type = comma then go to nxt;
	go to ck_parn;

action(14):				/* process the like attribute	*/
	p -> symbol.general = reference_parse(k,cblock);
	if p -> symbol.general = null then call print(25);
	cblock->block.like_attribute = "1"b;
	go to find_type;
action(15):				/* process the generic attribute	*/
	if t_table.type ^= left_parn then go to test;
	q=null;
next_entry:
	k=k+1;
	p1=create_list(3);
	p1 -> list.element(1) = reference_parse(k,cblock);
	if p1 -> list.element(1) = null then call print(13);
	if t_table.string ^= "when" then call print(13);
	k=k+1;
	if t_table.type ^= left_parn then call print(13);
	p1->list.element(2)=descriptor_parse(null,null,k);
	if t_table.type ^= right_parn then call print(13);
	k=k+1;
	p1->list.element(3)=null;
	if q ^= null
		then p2 -> list.element(3) = p1;
		else q = p1;
	p2=p1;
	if t_table.type = comma then go to next_entry;
	p->symbol.general=q;
	go to ck_parn;
action(16):				/* process the dimension attribute  */
	if t_table.type ^= left_parn then go to test;
	p->symbol.dimensioned = "1"b;
	p->symbol.array=create_array();
	ndims = 0;
next_b:
	ndims = ndims + 1;
	k=k+1;
	p1 = pl1_stat_$one;
	p2 = refer_exp();
	if p2 = null then call print(9);
	if ^star
	     then if t_table.type=colon
		then do;
			k=k+1;
			p1=p2;
			p2 = refer_exp();
			if p2 = null then call print(9);
		     end;
		else;
	     else p1 = p2;

	if ndims <= max_number_of_dimensions
	then do;
		q=create_bound();
		q->bound.next=p->symbol.array->array.bounds;
		p->symbol.array->array.bounds=q;
		q->bound.lower=p1;
		q->bound.upper=p2;
	     end;
	if t_table.type=comma then go to next_b;

	if ndims > max_number_of_dimensions
	then do;
		call parse_error (372, p);
		ndims = max_number_of_dimensions;
	     end;
	p->symbol.array->array.own_number_of_dimensions = ndims;
	if t_table.type ^= right_parn then call print(10);
	go to next;

action(17):				/* options */
	if type ^= left_parn then go to test;
	k=k+1;
	if t_table.string = "variable"
	     then p->symbol.variable_arg_list = "1"b;
	     else if t_table.string = "constant"
		then p->symbol.alloc_in_text = "1"b;
	     else if t_table.string = "packed"
	          then p -> symbol.explicit_packed = "1"b;
		else call print(192);
	k=k+1;
	if pl1_stat_$check_ansi
	then	call parse_error(355,token_list(k-3));
	go to ck_parn;

action(18):				/* nonstandard attributes */
	if pl1_stat_$check_ansi
	     then call parse_error(354,token_list(k-1));
	go to test;

/* Internal procedures */

get_scale:	proc() returns(fixed bin(31));
	k = k + 1;
	p1 = expression_parse(k,cblock);
	if p1 = null then call print(15);
	if p1->node.type ^= token_node then call print(15);
	if p1->t_table.type ^= dec_integer then call print(15);
	return(token_to_binary(p1));
end get_scale;

refer_exp:
	proc() returns(ptr);

dcl	(p1,p2) ptr;

	star = "0"b;
	if t_table.type = asterisk
		then do;
			p1=token_list(k);
			star,
			p->symbol.star_extents="1"b;
			k=k+1;
			go to exit;
		     end;
	p1 = expression_parse(k,cblock);
	if p1 = null then go to fail;
	if p1->node.type = token_node
		then if p1->t_table.type ^= dec_integer
			then p->symbol.exp_extents ="1"b;
			else;
		else p->symbol.exp_extents = "1"b;
	if t_table.string ^= "refer" then go to exit;
	k=k+1;
	p->symbol.exp_extents  ,
	p->symbol.refer_extents="1"b;
	if t_table.type ^= left_parn then go to fail;
	k=k+1;
	p2=p1;
	p1=create_operator(refer,2);
	p1->operand(1) = p2;
	p1 -> operand(2) = reference_parse(k,cblock);
	if p1 -> operand(2) = null then go to fail;
	if p1->operand(2)->node.type=reference_node
	then do;
		if p1->operand(2)->reference.qualifier^=null
		then	call declare_parse$abort(138,(p1->operand(2)));
		if p1->operand(2)->reference.offset^=null
		then	call declare_parse$abort(138,(p1->operand(2)));
	end;
	if t_table.type ^= right_parn then go to fail;
	k=k+1;

exit:
	return(p1);
fail:
	return(null);
	end;

initial_list:
	proc() returns(ptr);

dcl	(ap,factor,value,p1,p2) ptr;
dcl	something_parsed bit(1) aligned;

	p2=null;
	do while("1"b);
		something_parsed = "0"b;
		k=k+1;
		if t_table.type = left_parn
			then do;
				k=k+1;
				factor = expression_parse(k,cblock);
				if factor = null then go to fail;
				if t_table.type ^= right_parn then go to fail;
				k=k+1;
				something_parsed = "1"b;
			     end;
			else factor = pl1_stat_$one;
		if t_table.type=asterisk
			then do;
				value=null;
				k=k+1;
			     end;
			else do;
				if t_table.type = left_parn
				then do;
					value = initial_list();
					if value = null then go to fail;
				     end;
				else	if something_parsed & (t_table.type = right_parn | t_table.type = comma)
					then do;
						value = factor;
						factor = pl1_stat_$one;
					     end;
					else do;
						value = expression_parse(k,cblock);
						if value = null then go to fail;
					     end;
			     end;
		p1=create_list(3);
		p1->list.element(1)=factor;
		p1->list.element(2)=value;
		p1->list.element(3)=null;
		if p2 = null
		then ap = p1;
		else p2 -> list.element(3) = p1;
		p2 = p1;
		if t_table.type = right_parn
		then do;
			k = k + 1;
			return(ap);
		     end;
		if t_table.type ^= comma then go to fail;
	end;
fail:
	return(null);
end initial_list;

print: proc(m);

dcl m fixed bin(15);

	sp = p;		/* assign to parameter */
	call declare_parse$abort(m,(p -> symbol.token));
	end print;

%include parse;

%include array;
%include block;
%include context_codes;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include pl1_attribute_table;
%include reference;
%include symbol;
%include system;
%include token_list;
%include token_types;
     end /* attribute_parse */;




		    context.pl1                     10/03/83  1725.6rew 10/03/83  1006.1       14148



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

context: proc(name,cblock,type);

dcl	(name,cblock,d,p) ptr;
dcl	(type,n) fixed bin(15);
dcl	(null,string,substr) builtin;

%include language_utility;
%include context;
%include context_codes;
%include nodes;
%include block;

			/*      */

/* this item must be an identifier			*/

	if name->node.type ^= token_node then go to exit;

	/* cblock is only null inside a generic <arg selector>.
	   No <reference>s may be contained inside an <arg selector>. */

	if cblock = null
	then do;
	     call parse_error(439,name);
	     go to exit;
	     end;

	p=cblock->block.context;
	do while(p^=null);
		if p->context.token = name then go to record;
		p=p->context.next;
	end;

	p=create_context(cblock,name);

record:
	substr(string(p->context.bits),type,1) = "1"b;

exit:
	end context;




		    data_list_parse.pl1             10/03/83  1725.6rew 10/03/83  1005.9       45351



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

data_list_parse:	proc(k_index,cur_block,arg) returns(bit(1)aligned);

dcl	k_index fixed bin(15),
	(cur_block,arg) ptr;

dcl	(addr,hbound,null) builtin;
dcl	recurse bit(1) aligned;

dcl	(do_ptr,do_ssptr,eptr,p,q,r) ptr,
	(do_sptr,errp) ptr init(null),
	arg_list(128) ptr,

	(arg_list_index,error_number,i,k,n) fixed bin(15);

%include parse;
%include operator;
%include op_codes;
%include token_list;
%include token_types;

	/*  */

	recurse="0"b;
	goto common;

dlp:	entry(k_index,cur_block,arg) returns( bit(1) aligned );
	recurse="1"b;

common:
	k=k_index;

	arg_list_index=0;

	if t_table.type^=left_parn then goto err255;

element_loop:
	k=k+1;

	eptr = expression_parse(k,cur_block);	/* may be either expression or (... do...)   */
	if eptr = null	/* not an expression: is (... do  ...) or is error256 */
	then	if t_table.type=left_parn
		then	if ^dlp(k,cur_block,eptr)
			/* must be a good INSIDE data-list: with a DO  */
			then	goto ret0;
			else	if eptr->operator.op_code=join
				then	eptr=eptr->operator.operand(1);
				else;
		else goto err256;	/* must be expression but isnt */
	else;

	arg_list_index=arg_list_index+1;
	arg_list(arg_list_index)=eptr;

	if t_table.type=comma 
	then if arg_list_index<hbound(arg_list,1)
	     then goto element_loop;
	     else goto err493;


		/*  an element must be either an EXPRESSION or a (DO-LOOP)
		   and must be followed by either a comma, a DO or a ")"  */


	q=create_operator(join,arg_list_index);

	do i=1 to arg_list_index;
		q->operator.operand(i)=arg_list(i);
	end;

		/* having put the list-elements together
		   check for DO or ")"  */

	if t_table.type=right_parn
	then if recurse then goto err275;
	else goto ret1;


	if string="do"
	then do;
		do_ptr=create_operator(do_fun,3);
		do_ptr->operator.operand(1)=q;

		k=k+1;
		r = reference_parse(k,cur_block);
		if r = null then go to err406;
		do_ptr->operator.operand(2)=r;

		if t_table.type^=assignment then goto err407;

specification_loop:
		k=k+1;
		do_ssptr=do_sptr;

		do_sptr=create_operator(do_spec,6);

		if do_ssptr=null
		then do_ptr->operator.operand(3)=do_sptr;
		else do_ssptr->operator.operand(6)=do_sptr;

		p = expression_parse(k,cur_block);
		if p = null then go to err408;
		do_sptr->operator.operand(1)=p;

to_by_loop:
		if string="to"
		then do;
			k=k+1;
			p = expression_parse(k,cur_block);
			if p = null then go to err418;

			if do_sptr->operand(2)^=null then goto err409;
			do_sptr->operand(2)=p;
		end;

		if string="by"
		then do;
			k=k+1;
			p = expression_parse(k,cur_block);
			if p = null then go to err424;

			if do_sptr->operand(3)^=null then goto err419;
			do_sptr->operand(3)=p;

			goto to_by_loop;
		end;

		if string="repeat"
		then do;
			k=k+1;
			if do_sptr->operand(2)^=null
			|  do_sptr->operand(3)^=null
			then goto err443;
			p=expression_parse(k,cur_block);
			if p=null then goto err429;
			do_sptr->operand(4)=p;
		end;


		if string="while"
		then do;
			k=k+1;
			if t_table.type^=left_parn then goto err404;

			k=k+1;
			p = expression_parse(k,cur_block);
			if p = null then go to err426;
			do_sptr->operator.operand(5)=p;

			if t_table.type^=right_parn then goto err405;
			k=k+1;
		end;

		if t_table.type=right_parn
		then do;
			q=do_ptr;
			goto ret1;
		end;

		if t_table.type=comma then goto specification_loop;
		goto err258;	/* unrecognizable element in DO group */

	end;

	goto err275;

ret1:
	arg=q;
	k_index=k+1;
	return("1"b);

err255:
	error_number=255;
	goto err_list;

err256:
	error_number=256;
	goto err_list;

err258:
	error_number=258;
	goto err_list;

err275:
	error_number=275;
	goto err_list;

err404:
	error_number=404;
	goto err;

err405:
	error_number=405;
	goto err;

err406:
	error_number=406;
	goto err;

err407:
	error_number=407;
	goto err;

err408:
	error_number=408;
	goto err;

err409:
	error_number=409;
	goto err;

err418:
	error_number=418;
	goto err;

err419:
	error_number=419;
	goto err;

err424:
	error_number=424;
	goto err;

err426:
	error_number=426;
	goto err;

err429:
	error_number=429;
	goto err;

err443:
	error_number=443;
	goto err;

err493:
	error_number=493;
	goto err;

err_list:
	errp=token_list(k);
	goto err;

err:
	call parse_error(error_number,errp);

ret0:
	arg=null;
	return("0"b);

	end data_list_parse;




		    declare_label.pl1               10/03/83  1725.6rew 10/03/83  1005.9       21438



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


declare_label:	proc(cblock,cstatement,clabel,dcltype);

	/* same in VERSION 1 and VERSION 2 */


dcl	(cblock,cstatement,clabel) ptr,
	(d,q,t) ptr,

	(n,value) fixed bin(15),

	array bit(1) aligned,
	dcltype bit(3) aligned;

dcl	(max,min,null) builtin;

%include language_utility;
%include block;
%include label;
%include list;
%include nodes;
%include reference;
%include token;
%include label_array_element;

begin:
	q=clabel;
	do while(q^=null);
		array="0"b;
		value = 0;
		t=q->list.element(2);
		if t->node.type=reference_node
		then do;
			array="1"b;
			value = token_to_binary((t->reference.offset->list.element(1)));
			t=t->reference.symbol;	/* get token pointer */
		end;
		d=t->token.declaration;
		do while(d^=null);
			if d->label.block_node = cblock & d->node.type = label_node
				then do;
					if d->label.array ^= array
					then call parse_error(31,t);

					else if ^ array
					then call parse_error(54,t);

					else do;
					     d->label.low_bound = min(value,d->label.low_bound);
					     d->label.high_bound = max(value,d->label.high_bound);
					     call push_array_element;
					     end;

					goto next_label;
				     end;
			d=d->label.multi_use;
		end;
		d=create_label(cblock,t,dcltype);

		if array
		then do;
		     d -> label.array = "1"b;
		     d -> label.low_bound, d -> label.high_bound = value;
		     call push_array_element;
		     end;
		else d -> label.statement = cstatement;

next_label:
		q=q->list.element(1);
	end;


push_array_element:	proc;

dcl	lae ptr;

	/* associate this label array element with this statement */

	lae = create_list(3);
	lae -> label_array_element.node_type = label_array_element_node;
	lae -> label_array_element.statement = cstatement;
	lae -> label_array_element.value = value;
	lae -> label_array_element.next = d -> label.statement;
	d -> label.statement = lae;

	end;


	end declare_label;




		    declare_parse.pl1               10/03/83  1725.6rew 10/03/83  1006.1       42660



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


/*
This procedure is called at entry point declare_parse to parse declare statements.
This procedure is called at entry point abort when a parse error occurs.

The entry point declare_parse is called to parse declare statements.
It merely performs initialization and calls declare_parse_factored.
Upon return, it makes sure that the last token processed was a semicolon.

The entry point abort is called when an error is detected.
It attempts to restart the parse at the first
comma after the error token not contained in parentheses.

The internal procedure declare_parse_factored does most of the work
of parsing declare statements.  It is called by declare_parse to
parse everything between the word "declare" and the semicolon.
It calls attribute_parse to process attributes, and
it calls itself recursively to process factored attribute lists
when it encounters a left parenthesis.
*/

declare_parse: proc(i,cur_block,labels); 

dcl	i fixed bin(15) parameter;
dcl	(cur_block,labels) ptr parameter;

declare	p ptr;
declare	(cblock,previous_symbol) ptr internal static;

declare	(n,j) fixed binary(15);
declare	(k,l,factored_level) fixed binary(15) static internal;

dcl	type bit(9);

dcl	pl1_stat_$cur_statement ptr ext static;
dcl	pl1_stat_$unwind label external static;


dcl	(null,addr,string) builtin;

%include parse;
%include block;
%include token_types;
%include statement_types;
%include symbol;
%include token_list;
%include token;
%include declare_type;
%include reference;


begin:
	k,l=i;		/* move the parameters into local static storage */
	cblock=cur_block;	/* to eliminate argument passing to declare_parse_factored */
			/* and so that abort can access k and l */

	if labels ^= null
		then do;
			pl1_stat_$cur_statement  ,
			p = create_statement(null_statement,cblock,labels,(cblock -> block.prefix));
			call declare_label(cblock,p,labels,by_explicit_context);
		     end;

	pl1_stat_$unwind=error_restart;
	previous_symbol = null;

error_restart:
	if t_table.type = semi_colon then return;
	factored_level = 0;		/* initial factored level is 0 */
	call declare_parse_factored;
	if t_table.type = semi_colon then return;
	call parse_error(1,null);
	return;

declare_parse$abort: entry(m,bad_node);

dcl	m fixed bin(15) parameter;
dcl	bad_node pointer;

	call parse_error(m,bad_node);
	n=0;
	j=k;
	do k=l by 1;
	type = t_table.type;
	if type=left_parn then n=n+1;
	if type=right_parn then n=n-1;
	if type=semi_colon then go to pl1_stat_$unwind;
	if type=comma then if n=0 then if k>j then go to pl1_stat_$unwind;
	end;

declare_parse_factored:	procedure;

dcl	(last_dcl,s) ptr;
dcl	(current_level,level) fixed bin(15);

	current_level = factored_level;		/* copy from static "parameter" */

do while("1"b);
	k=k+1;

	level = current_level;
	if t_table.type = dec_integer
	   then do;
	        if current_level = 0
		 then level = token_to_binary(token_list(k));
		 else call parse_error(1,null);	/* ignore level number inside factored level number */
	        k=k+1;
	        end;

	if t_table.type=left_parn
		then do;
			l=k-1;
			last_dcl = cblock->block.end_declaration;
			factored_level = level;	/* copy to static "parameter" */
			call declare_parse_factored;
			s = create_symbol(null,create_token("a factored attribute list",(identifier)),by_compiler);
			if t_table.type^=right_parn then call declare_parse$abort(3,null);
			call attribute_parse(cblock,s,k,"0"b);
			if last_dcl = null
				then last_dcl = cblock->block.declaration;
				else last_dcl = last_dcl->symbol.next;
			do last_dcl = last_dcl repeat last_dcl->symbol.next while(last_dcl^=null);
			if last_dcl->symbol.dcl_type = by_declare
				then if merge_attributes(last_dcl,s) then call parse_error(27,null);
			end;
			call free_node(s);
		     end;
		else do;
			if t_table.type ^= identifier then call declare_parse$abort(3,null);
			s = create_symbol(cblock,token_list(k),by_declare);
			string(s->symbol.source_id) = string(pl1_stat_$statement_id);
			s->symbol.level = level;
			call link_symbol(previous_symbol,s);	/* perform appropriate structure linking */
			call attribute_parse(cblock,s,k,"0"b);
		     end;
	if t_table.type ^= comma then return;
end;
end declare_parse_factored;
%include link_symbol;

end declare_parse;




		    default_parse.pl1               10/03/83  1725.6rew 10/03/83  1006.1       24831



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


default_parse: proc(k,b,labels);

dcl	(b,labels,d,s,last) ptr;
dcl	(k,n) fixed bin(15);
dcl	pl1_stat_$cur_statement ptr ext static;
dcl	pl1_stat_$unwind external label;
dcl	pl1_stat_$check_ansi bit(1) aligned ext static;
dcl	pl1_stat_$root ptr ext static;

dcl	(string,null,addr) builtin;
%include parse;
%include default;
%include symbol;
%include block;
%include token_list;
%include token_types;
%include statement_types;
%include declare_type;

	if labels ^= null
		then do;
			pl1_stat_$cur_statement,d = create_statement(null_statement,b,labels,(b->block.prefix));
			call declare_label(b,d,labels,by_explicit_context);
		     end;

	k = k+1;
	d = create_default();
	string(d->default.source_id) = string(pl1_stat_$statement_id);
	if t_table.type = left_parn
		then do;
			k=k+1;
			d -> default.predicate = expression_parse(k,b);
			if d -> default.predicate = null then go to fail;
			if t_table.type ^= right_parn  then go to fail;
		     end;
		else do;
			if t_table.type = identifier
				then do;
					if t_table.string = "system"
						then d->default.system = "1"b;
						else if t_table.string = "none"
							then d->default.no_defaults = "1"b;
							else go to fail;
					k=k+1;
					if t_table.type = semi_colon then go to done;
				     end;
			go to fail;
		     end;
	k=k+1;
	if t_table.string = "error"
		then do;
			d->default.error = "1"b;
			k=k+1;
			if t_table.type = semi_colon
				then go to done;
				else go to fail;
		     end;

/* loop to parse attribute sets */

	pl1_stat_$unwind = check_end;
	last = null;
	k=k-1;

	do while("1"b);

	s = create_symbol(null,null,by_compiler);
	call attribute_parse(b,s,k,"0"b);
	if last = null
		then d->default.symbol = s;
		else last->symbol.next = s;
	last = s;

check_end:
	if t_table.type = semi_colon then go to done;
	if t_table.type ^= comma then go to fail;
	end;

done:	/* must now link valid default node into block default chain in order */
	if b->block.end_default ^= null
		then b->block.end_default->default.next = d;
		else b->block.default = d;
	b->block.end_default = d;

	if pl1_stat_$check_ansi
	then if b ^= pl1_stat_$root -> block.son
	     then call parse_error(350,null);

	return;

fail:
	call free_node(d);
	call parse_error(48,null);
end default_parse;




		    descriptor_parse.pl1            10/03/83  1725.6rew 10/03/83  1006.1       31860



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


/*
This procedure is called to parse description lists.
Description lists occur in three contexts:
	entry(description_list)	in the entry attribute
	returns(description_list)	in the returns attribute
	when(description_list)	in the when clause of the generic attribute

Input:
	k is on the left parenthesis

Output:
	k is on the right parenthesis
	the return pointer is null if () else
	the return pointer points to the first list(2) item.
	list.element(1) points to the major symbol
	list.element(2) points to the next list(2) item or is null.
	the major symbol son pointer points to the sons or is null.
	the sons, if any, are properly linked, i.e. the father, brother, and son
	pointers are set correctly.
	The names associated with the symbols are constructed as follows:
	if token is null, a compiler generated name is used.
	if token is not null, its string concatenated with char(n),
	where n is the major symbol number, concatenated with "]" is used.
*/

descriptor_parse: proc(cblock,token,k) returns(ptr);

/* Modified 780814 by PG to work as specified for null lists */

/* parameters */

dcl	(cblock ptr,
	token ptr,
	k fixed bin (15)) parameter;

/* automatic */

declare	(name,listptr,previous_listptr,previous_descriptor,p,s)	pointer;
dcl	n fixed bin (15);
dcl	level fixed bin(8);
dcl	in_generic bit(1) aligned;

/* builtins */

dcl	null builtin;

/* include files */

%include parse;
%include symbol;
%include token_list;
%include token_types;
%include declare_type;
%include list;

/* program */

	n=0;
	k = k + 1;				/* step over left_parn */
	listptr,previous_descriptor = null;

	do while (t_table.type ^= right_parn);
	     n=n+1;
	     if t_table.type = comma			/* no attributes */
	     then call declare_parse$abort(199,null);

	     name = token;
	     in_generic = (name = null);
	     level = 0;

	     if in_generic & t_table.type = asterisk	/* no attributes for this descriptor */
	     then do;
		     s = null;
		     k = k + 1;
		end;
	     else do;
		     if t_table.type = dec_integer		/* a structure level number */
		     then do;
			     level = token_to_binary(token_list(k));
			     k=k+1;
			end;

		     if ^in_generic
		     then if substr (name -> t_table.string, name -> t_table.size, 1) ^= "]"
			then name = create_token (name -> t_table.string || bindec$vs ((n)) || "]", identifier);

		     s = create_symbol(cblock,name,by_compiler);
		     s->symbol.level = level;
		     call link_symbol(previous_descriptor,s);	/* perform appropriate structure linking */
		     k=k-1;
		     call attribute_parse(cblock,s,k,in_generic);
		end;

	     if level <= 1
	     then do;
		     p = create_list(2);
		     p->list.element(1) = s;

		     if listptr = null
		     then listptr = p;
		     else previous_listptr->list.element(2) = p;
		     previous_listptr = p;
		end;

	     if t_table.type = comma
	     then k = k + 1;
	     else if t_table.type ^= right_parn
		then call declare_parse$abort (1, null);
	end;
	return (listptr);

%include link_symbol;

     end /* descriptor_parse */;




		    do_parse.pl1                    10/03/83  1725.6rew 10/03/83  1006.1       84708



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


/* Note well:	The declarations and all statements after the label
		"get_next_statement" are copied from procedure_parse,
		and any changes made to either must be made to both.

	Written on:	22 October 1970 by Paul Green for Version II
	Modified:		9 February 1978 by Richard Barnes to fix 1699
	Modified:		21 March 1980 by M. N. Davidoff to print warnings for multiple closure end statements and
			to diagnose "do while(exp,exp);".
*/
/* format: style3 */
do_parse:
     proc (k, entry_ptr, our_conditions, father_block, his_end_ptr, our_entry_flag, our_return_flag, in_iterative_do);

dcl	(do, ref, spec)	ptr;
dcl	(p, q, entry_ptr, label_ptr, end_ptr, cur_block, father_block, his_end_ptr)
			ptr;
dcl	do_statement_node	ptr;
dcl	(k, i, type)	fixed bin (15);
dcl	(conditions, our_conditions)
			bit (12) aligned;
dcl	(our_entry_flag, entry_flag, return_flag, our_return_flag, in_iterative_do, iterative_do_entered)
			bit (1) aligned;

dcl	pl1_stat_$cur_statement
			ptr ext static;

dcl	(binary, bit, null) builtin;

dcl	action_index	(0:36) fixed bin (15) int static
			init (0, 0, 0, 1, 0, 10, 2, 10, 10, 0, 3, 0, 4, 8, 0, 10, 0, 10, 0, 5, 10, 0, 6, 10, 7, 10, 10,
			0, 0, 10, 0, 0, 0, 10, 0, 10, 9);

%include parse;
%include token_list;
%include block;
%include op_codes;
%include operator;
%include statement;
%include token;
%include block_types;
%include statement_types;
%include token_types;
%include list;
%include label;
%include reference;
%include declare_type;

/* program */

	conditions = our_conditions;
	cur_block = father_block;
	return_flag = our_return_flag;
	entry_flag = our_entry_flag;
	iterative_do_entered = in_iterative_do;

	spec = null;

	pl1_stat_$cur_statement, p,
	     do_statement_node = create_statement (do_statement, father_block, entry_ptr, conditions);
	if entry_ptr ^= null
	then call declare_label (father_block, p, entry_ptr, by_explicit_context);

	do, p -> statement.root = create_operator (do_fun, 3);
	i, k = k + 1;
	if t_table.type = semi_colon
	then goto get_next_statement;			/* this is a "do;" statement */

/* for iterative do statements we need a null statement with the same source id as the do statement preceding the do statement
   so that correct code will be generated in processing function references needing descriptors.  This fixes bug 1699. */

	p -> statement.root = null;
	p -> statement.statement_type = null_statement;
	pl1_stat_$cur_statement, p, do_statement_node = create_statement (do_statement, father_block, null, conditions);
	p -> statement.root = do;

/* each <do specification> is represented by a do_spec operator */

	spec, do -> operand (3) = create_operator (do_spec, 6);
	ref = reference_parse (k, cur_block);

	if ref = null
	then call print (406);

	if token_list (i) -> token.string = "while"
	then if t_table.type = semi_colon
	     then do;				/* this is a "do while(...)" clause */

/* pick up expression from reference node */

		     if ref -> reference.offset -> list.number ^= 1
		     then call parse_error (405, null);

		     spec -> operand (5) = ref -> reference.offset -> list.element (1);
		     ref -> reference.offset = null;	/* don't free expression */
		     call free_node (ref);
		     go to get_next_statement;
		end;
	     else if t_table.type = comma
	     then call print (406);

	do -> operand (2) = ref;

	if t_table.type ^= assignment
	then call print (407);

	k = k + 1;

spec_loop:
	spec -> operand (1) = expression_parse (k, cur_block);
	if spec -> operand (1) = null
	then call print (408);

to_by_loop:
	if t_table.string = "to"
	then do;
		k = k + 1;
		if spec -> operand (2) ^= null
		then call print (409);
		spec -> operand (2) = expression_parse (k, cur_block);
		if spec -> operand (2) = null
		then call print (418);
		iterative_do_entered = "1"b;
	     end;

	if t_table.string = "by"
	then do;
		k = k + 1;
		if spec -> operand (3) ^= null
		then call print (419);
		spec -> operand (3) = expression_parse (k, cur_block);
		if spec -> operand (3) = null
		then call print (424);
		iterative_do_entered = "1"b;
		go to to_by_loop;
	     end;

	if t_table.string = "repeat"
	then do;
		k = k + 1;
		if spec -> operand (2) ^= null | spec -> operand (3) ^= null
		then call print (433);
		spec -> operand (4) = expression_parse (k, cur_block);
		if spec -> operand (4) = null
		then call print (429);
		iterative_do_entered = "1"b;
	     end;

	if t_table.string = "while"
	then do;
		k = k + 1;
		if t_table.type ^= left_parn
		then call parse_error (404, null);
		else k = k + 1;
		spec -> operand (5) = expression_parse (k, cur_block);
		if spec -> operand (5) = null
		then call print (426);
		if t_table.type ^= right_parn
		then call parse_error (405, null);
		else k = k + 1;
	     end;

	if t_table.type = comma
	then do;
		k = k + 1;
		spec -> operand (6), spec = create_operator (do_spec, 6);
		go to spec_loop;
	     end;

	if t_table.type ^= semi_colon
	then call print (425);

get_next_statement:
	call lex;

get_statement_type:
	conditions = cur_block -> block.prefix;
	k = 1;					/* first token */
	type = statement_type (k, label_ptr, conditions);
	go to action (action_index (type));

/*	***************** Statements requiring individual parsing procedures. ******** */

action (10):					/* io statements */
	call io_statement_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag, bit (binary (type, 9, 0)));
	goto compound_parse_return;

action (1):					/* begin statement	*/
	call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_block, return_flag);
	go to compound_parse_return;

action (2):					/* declare statement */
	call declare_parse (k, cur_block, label_ptr);
	go to get_next_statement;

action (9):					/* default statement */
	call default_parse (k, cur_block, label_ptr);
	go to get_next_statement;

action (3):					/* do statement	*/
	call do_parse (k, label_ptr, conditions, cur_block, end_ptr, entry_flag, return_flag, iterative_do_entered);
	go to compound_parse_return;

action (5):					/* if statement	*/
	call if_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag);
	if end_ptr = null
	then go to get_statement_type;
	go to end_proc;

action (6):					/* on statement	*/
	call on_parse (k, label_ptr, conditions, cur_block, end_ptr);
	go to compound_parse_return;

action (7):					/* proc statement	*/
	call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, internal_procedure, "0"b);

compound_parse_return:
	if end_ptr = null
	then go to get_next_statement;
	go to end_proc;

/*	***************** Statements which may be in error. ************************** */

action (8):					/* entry statement	*/
	if iterative_do_entered | entry_flag
	then do;
		call parse_error (413 - 2 * binary (entry_flag, 1), null);
		go to get_next_statement;
	     end;

	k = k + 1;
	call process_entry (k, entry_statement, cur_block, label_ptr, conditions);
	go to get_next_statement;

/*	***************** Statements all parsed in statement_parse.******************* */


action (0):
	call statement_parse (k, label_ptr, conditions, cur_block, type);
	go to get_next_statement;

/*	***************** Statement processed in line. ******************************* */

action (4):					/* end statement	*/
	k = k + 1;
	if t_table.type = identifier
	then do;
		end_ptr = token_list (k);
		k = k + 1;
	     end;
	else end_ptr = null;
	if t_table.type ^= semi_colon
	then call parse_error (416, token_list (k));

end_proc:
	conditions = cur_block -> block.prefix;
	q = create_statement (end_statement, cur_block, null, conditions);

	if end_ptr ^= null
	then do;
		do p = entry_ptr repeat p -> list.element (1) while (p ^= null);
		     if end_ptr = p -> list.element (2)
		     then go to ck_labels;
		end;

		if type = binary (end_statement, 9)
		then call parse_error (377, null);

		call error (384, do_statement_node, null);

		his_end_ptr = end_ptr;		/* ends this block and previous blocks */
		entry_ptr = label_ptr;		/* any prefix labels get passed back up.  */
		go to finish;
	     end;

ck_labels:
	his_end_ptr = null;				/* ended this block only, even if we were given labels */
	if label_ptr ^= null
	then do;
		call declare_label (cur_block, q, label_ptr, by_explicit_context);
		q -> statement.labels = label_ptr;
	     end;

finish:						/* close the do statement with a label */
	p = create_label (cur_block, null, by_compiler);
	do -> operand (1) = p;
	p -> label.statement = q;
	ref = create_list (2);
	ref -> list.element (2) = p -> label.token;
	ref -> list.element (1) = q -> statement.labels;
	q -> statement.labels = ref;
	return;

print:
     proc (m);					/* prints error messages */

dcl	m		fixed bin (15);

	call parse_error (m, null);
	if spec ^= null
	then do;
		spec -> operand (1), spec -> operand (2), spec -> operand (3), spec -> operand (4), spec -> operand (5),
		     spec -> operand (6) = null;
	     end;
	go to get_next_statement;

     end print;

     end do_parse;




		    evaluate.pl1                    10/03/83  1725.6rew 10/03/83  1005.9       27810



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


/* Procedure to evaluate operator with constant operands.

   Preliminary version deals only with decimal integers and returns an operator
   node if other types of constants appear

   Initial Version: 16 October 1972 by BLW
	Modified:	11 December 1976 by RAB for ||	*/

evaluate:	proc(opcode,r2,r3) returns(ptr);

dcl	opcode bit(9) aligned,
	(r2,r3) ptr;

dcl	q ptr,
	ans char(12) aligned,
	(i,n,prec,prec2,prec3,v,v2,v3) fixed bin(31);

dcl	string_max fixed bin int static init(256);

dcl	(substr,length,max) builtin;

%include op_codes;
%include operator;
%include token;
%include token_types;
%include language_utility;

	if opcode = cat_string then go to concatenate;

	if opcode >= div
	then do;
make:	     q = create_operator(opcode,3);
	     q -> operand(2) = r2;
	     q -> operand(3) = r3;
	     return(q);
	     end;

	if r2 -> token.type ^= r3 -> token.type then goto make;

	if r2 -> token.type ^= dec_integer then goto make;

	if r2 -> token.loc ^= r3 -> token.loc
	then go to make;				/* require "p" flag to be same */

	prec2 = length(r2 -> token.string);
	if substr(r2 -> token.string,1,1) = "+" | substr(r2 -> token.string,1,1) = "-"
	then prec2 = prec2 - 1;
	if prec2 > 10 then goto make;		/* token_to_binary can only handle fixed bin(35)	*/

	prec3 = length(r3 -> token.string);
	if substr(r3 -> token.string,1,1) = "+" | substr(r3 -> token.string,1,1) = "-"
	then prec3 = prec3 - 1;
	if prec3 > 10 then goto make;

	v2 = token_to_binary(r2);
	v3 = token_to_binary(r3);

	if opcode = add
	then do;
	     v = v2 + v3;
	     prec = max(prec2,prec3) + 1;
	     end;
	else if opcode = sub
	     then do;
		v = v2 - v3;
		prec = max(prec2,prec3) + 1;
		end;
	     else do;
		v = v2 * v3;
		prec = prec2 + prec3 + 1;
		end;

	if prec > 10 then goto make;

	ans = bindec(v);

	do i = 1 repeat(i + 1) while(substr(ans,i,1) = " ");
	     substr(ans,i,1) = "0";
	     end;

	if substr(ans,i,1) = "-" then substr(ans,i,1) = "0";

	if v < 0
	then do;
	     substr(ans,12 - prec,1) = "-";
	     prec = prec + 1;
	     end;

	return (create_token$protected (substr (ans, 12 - prec + 1, prec), dec_integer, (r2 -> token.loc)));


concatenate:
	if r2 -> token.type ^= r3 -> token.type then goto make;

	if r2 -> token.type = char_string
	then prec2 = length(r2 -> token.string);
	else if r2 -> token.type = bit_string
	     then prec2 = length(r2 -> token.string) - 1;
	     else go to make;

	if prec2 + length(r3 -> token.string) > string_max
	     then go to make;

	return(create_token(substr(r2 -> token.string,1,prec2) || r3 -> token.string, (r2 -> token.type)));
	end;




		    expression_parse.pl1            10/03/83  1725.6rew 10/03/83  1006.2       73773



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


expression_parse:
	procedure(i,cblock) recursive returns(pointer);


/*	Parameters	*/

dcl	i		fixed bin(15),
	r		ptr,
	cblock		ptr;

dcl	(addr,binary,fixed,index,null,search,substr) builtin;


/*	Automatic stuff.	*/

dcl	(j, k, si, n)	fixed bin(15),
	(eloc,oploc)	fixed bin(15),
	ch		char(1),
	opindex		fixed bin(5),
	q		ptr,
	type		bit(9) aligned,
	(r2,r3)		ptr,
	stack(0:12)	ptr;

/*	Constants.	*/

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

dcl	op_table(0:18) bit(9) aligned internal static options(constant)
	initial(	""b,		/* illegal */
		"000010001"b,	/* +, plus */
		"000010010"b,	/* -, minus */
		"000010011"b,	/* *, asterisk */
		"000010100"b,	/* /, slash */
		"100100100"b,	/* **, expon */
		"000100100"b,	/* ^, not */
		"000100001"b,	/* &, and */
		"000100010"b,	/* |, or */
		"000100101"b,	/* ||, cat */
		"001000110"b,	/* =, eq */
		"001000111"b,	/* ^=, ne */
		"001000100"b,	/* <, lt */
		"001000101"b,	/* >, gt */
		"001001000"b,	/* <=, le */
		"001001001"b,	/* >=, ge */
		"001001000"b,	/* ^>, ngt */
		"001001001"b,	/* ^<, nlt */
		"001000110"b);	/* =, assignment ( equal relational ) */

/*	t and tlist are used to get better accessing to token_list in
	inner procedure "primitive".			*/

dcl	t		ptr internal static,
	tlist(3000)	ptr based(t);

%include parse;
%include token_list;
%include token;
%include nodes;
%include operator;
%include op_codes;
%include token_types;
/*		This procedure parses expressions using a simple operator
	precedence technique.  The syntax parsed is

		<expression> ::= <primitive> [<operator> <primitive>]...

	where the nth operator and its operands are stacked if the
	n+1st operator has higher precedence.  The primitive is parsed by
	the internal entry called "primitive".  The primitives include
	parenthesized expressions, prefix operators, and exponentiation. */

	t = pl1_stat_$token_list_ptr;
	k = i;
	si = 0;
	stack(0) = primitive(k);

fetchop:	type = t_table.type;

checkop:	if type & is_delimiter
	then if type <= assignment
	then do;

		if type = not then goto fail;

		if si ^= 0		/* If past first op then check prec. */
		then do;

			opindex = binary(substr(stack(si-1) -> token.type,5,5));
			if precedence(opindex) >=
			   precedence(fixed(substr(type,5,5),5)) then go to unstack;

		     end;

stackop:		si = si + 1;
		stack(si) = token_list(k);
		si = si + 1;
		k = k + 1;
		stack(si) = primitive(k);

		go to fetchop;

	     end;

	if si = 0 then go to succeed;

unstackop:opindex = binary(substr(stack(si-1) -> token.type,5,5));

unstack:	r2 = stack(si-2);
	r3 = stack(si);

	if opindex = 9
	then do;

	     /* attempt to optimize cat (||) */

	     if r2 -> node.type = token_node
	     then if r3 -> node.type = token_node
	     then if r2 -> token.type & r3 -> token.type & is_constant
	     then do;
		q = evaluate(op_table(9),r2,r3);
		go to pop;
		end;
	     end;

	if opindex >= 4
	then do;

	     /* operator not + - or * */

make_op:	     q = create_operator((op_table(opindex)),3);
	     q -> operator.operand(2) = r2;
	     q -> operator.operand(3) = r3;

pop:	     si = si - 2;
	     stack(si) = q;

	     go to checkop;
	     end;

	if r2 -> node.type ^= token_node then goto make_op;
	if r3 -> node.type ^= token_node then goto make_op;

	/* Check for constants on both sides of operator */

	if (r2 -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant then goto make_op;
	if r2 -> token.type >= i_fixed_bin then goto make_op;

	if (r3 -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant then goto make_op;

	if r2 -> token.loc ^= r3 -> token.loc then go to make_op;	/* require both to have same "p" attribute */

	/* Check for "complex" constant */

	if r3 -> token.type >= i_fixed_bin
	then do;
	     if opindex >= 3 then goto make_op;

	     oploc = search(substr(r3->token.string,2),"+-");	/* This block of code is to ensure	*/
	     if oploc ^= 0 then do;				/* that r3 points to an imaginary,	*/
		eloc = index(r3->token.string,"e");		/* not complex, number.		*/
		if eloc = 0 then goto make_op;
		if oploc < eloc then goto make_op;
		if search(substr(r3->token.string,eloc+2),"+-") ^= 0 then goto make_op;
		end;

	     /* form new token representing the complex constant */

	     if opindex = 1		/* addition */
	     then if substr(r3 -> token.string,1,1) = "-"
		then do;
		     j = 2;
		     ch = "-";
		     end;
		else do;
		     ch = "+";
		     if substr(r3 -> token.string,1,1) = "+" then j = 2; else j = 1;
		     end;
	     else if substr(r3 -> token.string,1,1) = "-"
		then do;
		     j = 2;
		     ch = "+";
		     end;
		else do;
		     ch = "-";
		     if substr(r3 -> token.string,1,1) = "+" then j = 2; else j = 1;
		     end;

	     q = create_token$protected (r2 -> token.string || ch || substr (r3 ->token.string, j), (r3 -> token.type), (r2 -> token.loc));
	     goto pop;
	     end;

	/* have constant operands, evalute expression if possible */

	q = evaluate((op_table(opindex)),r2,r3);
	goto pop;

fail:	r = null;
	go to ret;

succeed:	r = stack(0);
	i = k;

ret:	return(r);

/*	Primitive parses prefix expressions, exponentiation operators,
	and parenthesized expressions.		*/

primitive: proc(i) returns(ptr);

dcl	(p,q)	ptr,
	i	fixed bin(15),
	(ttype,
	  type)	bit(9) aligned;

	type = tlist(i) -> token.type;

	if type = plus
	then do;
		i = i + 1;
		p = primitive(i);
		if p -> node.type = token_node
		then do;
			ttype, type = p -> token.type;
			if (type & is_arithmetic_constant) = is_arithmetic_constant
			then	if substr(p->token.string,1,1) = "-" | substr(p->token.string,1,1) = "+"
				then q = p;
				else q = create_token$protected ("+" || p -> token.string, ttype, (p -> token.loc));
			else go to plusop;
		     end;
		else do;
plusop:
			q = create_operator((prefix_plus),2);
			q->operator.operand(2) = p;
		     end;

	     end;

	else if type = minus
	then do;

		i = i + 1;
		p = primitive(i);
		if p -> node.type = token_node
		then do;

			ttype, type = p -> token.type;

			if (type & is_arithmetic_constant) = is_arithmetic_constant
			then	if substr(p->token.string,1,1) = "-"
				then q = create_token$protected (substr (p -> token.string, 2), ttype, (p -> token.loc));
				else	if substr (p -> token.string, 1, 1) = "+"
				  	then q = create_token$protected ("-" || substr (p -> token.string, 2), ttype, (p -> token.loc));
					else q = create_token$protected ("-" || p -> token.string, ttype, (p -> token.loc));
			else go to negop;
		     end;
		else do;

negop:			q = create_operator((negate), 2);
			q -> operator.operand(2) = p;

		     end;

	     end;

	else if type = not
	then do;

		i = i + 1;
		q = create_operator((not_bits), 2);
		q -> operator.operand(2) = primitive(i);

	     end;

	else if type = left_parn
	then do;

		i = i + 1;
		q = expression_parse(i,cblock);
		if q = null then go to phail;
		if tlist(i) -> token.type ^= right_parn then go to phail;

		i = i + 1;
	     end;

	else if type & is_constant
	then do;

		q = tlist(i);
		i = i + 1;

	     end;

	else do;
		q = reference_parse(i,cblock);
		if q = null then go to phail;
	     end;

	if tlist(i) -> token.type = expon
	then do;

		i = i + 1;
		p = q;
		q = create_operator((exp), 3);
		q -> operator.operand(2) = p;
		q -> operator.operand(3) = primitive(i);

	     end;

	return(q);

phail:	go to fail;

	end primitive;
	end expression_parse;




		    format_list_parse.pl1           10/03/83  1725.6rew 10/03/83  1005.9       75051



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


format_list_parse:	proc(k,cur_block,st,format_tree) returns(bit(1)aligned);

/* Modified 770705 by PG to fix 1640 (letting "i" get thru as a valid format) */
/* Modified 770706 by PG to be a structured program */

/* parameters */

dcl (	k fixed bin (15),
	cur_block ptr,
	st ptr,
	format_tree ptr
	) parameter;

/* automatic */

dcl	(c, expr (3), item, last, lparen, p, pic_symbol, rptr) ptr,
	(i, indx, ksaved, n, pic_code, num_ops) fixed bin (15),
	formatcode bit(9) aligned,
	b_type char (1);

/* builtins */

dcl	(hbound, lbound, null, substr) builtin;

/* internal static */

dcl	format_names (17) char (6) aligned internal static initial (
	"a", "f", "e", "x", "skip", "page", "line", "col", "column", "b", "b1", "b2",
	"b3", "b4", "c", "p", "r");

/* include files */

%include parse;
%include declare_type;
%include operator;
%include op_codes;
%include picture_image;
%include reference;
%include statement;
%include token_list;
%include token;
%include token_types;
%include symbol;

/* program */

	ksaved = k;
	if t_table.type ^= left_parn
	then go to err278;

	last = null;
	k = k + 1;

next_item:
	rptr = null;
	if t_table.type = dec_integer | t_table.type = left_parn
	then do;
		if t_table.type = dec_integer
		then	rptr = token_list (k);
		else do;
			k = k + 1;
			rptr = expression_parse (k, cur_block);
			if rptr = null then go to err278;

			if t_table.type ^= right_parn then goto err278;
		     end;

		k = k + 1;

		if t_table.type =left_parn
		then	if format_list_parse (k, cur_block, (null), item)
			then do;
				lparen = create_operator (l_parn, 3);
				lparen -> operator.operand (3) = item;

				item = lparen;
				go to end_action2;
			     end;
			else goto err278;
	     end;

	if t_table.type ^= identifier
	then go to err278;

	do indx = lbound (format_names, 1) to hbound (format_names, 1) while (t_table.string ^= format_names (indx));
	end;

	if indx > hbound (format_names, 1)
	then go to err298;

	k = k + 1;
	go to action (indx);

/* Set the operator code for each format operator */

action (1):					/* a format */
	formatcode = a_format;
	go to action2 (indx);

action (2):					/* f format */
	formatcode = f_format;
	go to action2 (indx);

action (3):					/* e format */
	formatcode = e_format;
	go to action2 (indx);

action (4):					/* x format */
	formatcode = x_format;
	go to action2 (indx);

action (5):					/* skip format */
	formatcode = skip_format;
	go to action2 (indx);

action (6):					/* page format */
	formatcode = page_format;
	go to action2 (indx);

action (7):					/* line format */
	formatcode = line_format;
	go to action2 (indx);

action (8):					/* col format */
action (9):					/* column format */
	formatcode = column_format;
	go to action2 (indx);

action (10):					/* b format */
action (11):					/* b1 format */
	formatcode = b_format;
	go to action2 (indx);

action (12):					/* b2 format */
action (13):					/* b3 format */
action (14):					/* b4 format */
	formatcode = bn_format;
	go to action2 (indx);

action (15):					/* c (complex) format */
	formatcode = c_format;
	go to action2 (indx);

action (16):					/* p (picture) format */
	formatcode = picture_format;
	go to action2 (indx);

action (17):					/* r (remote) format */
	formatcode = r_format;
	go to action2 (indx);

/* Now parse the (sometimes) optional arguments to each format operator */

action2 (1):					/* a (char) format */
action2 (5):					/* skip format */
action2 (10):					/* b (bit) format */
action2 (11):					/* b1 (bit) format */
	if t_table.type = left_parn
	then go to merge_xr;

	item = create_operator (formatcode, 2);
	go to end_action2;

action2 (4):					/* x (spaces) format */
action2 (7):					/* line format */
action2 (8):					/* col format */
action2 (9):					/* column format */
action2 (17):					/* r (remote) format */
	if t_table.type ^= left_parn
	then go to err278;

merge_xr:
	k = k + 1;
	item = create_operator (formatcode, 3);
	if formatcode = r_format
	then item -> operator.operand (3) = reference_parse (k, cur_block);
	else item -> operator.operand (3) = expression_parse (k, cur_block);

	if item -> operator.operand (3) = null
	then go to err278;

	if t_table.type ^= right_parn
	then go to err278;

	k = k + 1;
	go to end_action2;

action2 (2):					/* f format */
action2 (3):					/* e format */
	if t_table.type ^= left_parn
	then go to err278;

	k = k + 1;
	expr (1) = expression_parse (k, cur_block);
	if expr (1) = null
	then go to err278;

	do n = 2 to 3 while (t_table.type = comma);
	     k = k + 1;
	     expr (n) = expression_parse (k, cur_block);
	     if expr (n) = null
	     then go to err278;
	end;
	n = n - 1;

	if t_table.type ^= right_parn
	then go to err278;

	k = k + 1;
	item = create_operator (formatcode, 2 + n);
	item -> operator.operand (3) = expr (1);

	if n > 1
	then do;
		item -> operator.operand (4) = expr (2);

		if n > 2
		then item -> operator.operand (5) = expr (3);
	     end;

	go to end_action2;

action2 (6):					/* page format */
	item = create_operator (formatcode, 2);
	go to end_action2;

action2 (15):					/* c (complex) format */
	if ^format_list_parse (k, cur_block, (null), item)
	then go to err278;

	c = create_operator (c_format, 4);
	c -> operator.operand (3) = item;

	if item -> operand (1) = null
	then c -> operator.number = 3;
	else do;
		c -> operator.operand (4) = item -> operator.operand (1);
		if c -> operator.operand (4) -> operator.operand (1) ^= null
		then go to err427;

		item -> operator.operand (1) = null;
	     end;

	item = c;

	do i = 3 to item -> operator.number;
	     if item -> operand (i) -> op_code = picture_format
	     then if item -> operand (i) -> operand (3) -> reference.symbol -> symbol.initial -> picture_image.type = 24
		then go to err170;
	end;
	go to end_action2;

action2 (12):					/* b2 format */
action2 (13):					/* b3 format */
action2 (14):					/* b4 format */
	b_type = substr (token_list (k - 1) -> token.string, 2, 1);
	if t_table.type ^= left_parn
	then num_ops = 3;
	else num_ops = 4;

	item = create_operator (formatcode, num_ops);
	item -> operator.operand (3) = create_token (b_type, dec_integer);

	if num_ops = 4
	then do;
		k = k + 1;
		item -> operand (4) = expression_parse (k, cur_block);
		if item -> operator.operand (4) = null
		then go to err278;

		if t_table.type ^= right_parn
		then go to err278;

		k = k + 1;
	     end;
	go to end_action2;

action2 (16):					/* p format */
	if t_table.type ^= char_string
	then go to err297;

	item = create_operator (formatcode, 3);
	pic_symbol = create_symbol (cur_block, null, by_compiler);
	call declare_picture (t_table.string, pic_symbol, pic_code);
	item -> operand (3) = pic_symbol -> symbol.general;
	call free_node (pic_symbol);

	if pic_code ^= 0
	then do;
		call parse_error (pic_code, token_list (k));
		go to ret0;
	     end;

	item -> operator.operand (3) -> reference.symbol -> symbol.allocate = "1"b;
	k = k + 1;

end_action2:
	if last = null
	then p = item;
	else last -> operator.operand (1) = item;

	item -> operator.operand (2) = rptr;
	last = item;

	if t_table.type = comma
	then do;
		k = k + 1;
		goto next_item;
	     end;

	if t_table.type ^= right_parn
	then go to err278;

	k = k + 1;

	if st ^= null
	then st -> statement.root = p;

	format_tree = p;

	return ("1"b);

err297:
	call parse_error (297, null);			/* Syntax error in a picture format item. */
	goto ret0;

err298:
	call parse_error (298, token_list (k));		/* Syntax error. $ is not a valid format keyword. */
	go to ret0;

err278:
	call parse_error (278, token_list (k));		/* Syntax error in a format-list */
	goto ret0;

err170:
	call parse_error (170, null);			/* A complex format item must contain e, f, or a numeric-picture */
	goto ret0;

err427:
	call parse_error (427, null);			/* Syntax error in a complex format-list */

ret0:
	k=ksaved;
	return("0"b);

     end /* format_list_parse */;




		    if_parse.pl1                    10/03/83  1725.6rew 10/03/83  1006.2      122688



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


if_parse:
     procedure (k, entry_ptr, our_conditions, father_block, his_end_ptr, our_return_flag);

/* This procedure parses if statements and else clauses.
   It always returns having called lex to look at the next statement. */

/* Original by:	J. D. Mills	4 June 1968
   to pl1:			26 July 1969
   Re-written by:	P. Green		25 October 1970 for Version II

   Modified:	29 May 1979 by R. A. Barnes to fix bug 1829 (WARNING 56 by
   	if <expr> then stop; else ...)
   Modified 790823 by PG to perform goto optimization only if -optimize was specified.
*/

/* Variables

   if		ptr to if statement.
   expr		ptr to if statement expression.
   loc		ptr to label used for jump around then body.
   location	ptr to token of loc.
   t		temporary ptr.		*/

/* builtins */

dcl	(bit, binary, null, string, substr)
			builtin;

/* automatic */

dcl	(k, then_type, type, n)
			fixed bin (15);
dcl	(t, if, do, entry_ptr, label_ptr, father_block, cblock, end_ptr, his_end_ptr, p, q, expr, loc, location)
			ptr;
dcl	(conditions, our_conditions)
			bit (12) aligned;
dcl	(our_return_flag, return_flag, else, then_goto_optimized)
			bit (1) aligned;
dcl	(bit_type, jump_if_false, jump_if_true)
			bit (9);

/* external static */

dcl	(
	pl1_stat_$cur_statement
			ptr,
	pl1_stat_$optimize	bit (1) aligned,
	pl1_stat_$profile	bit (1) aligned
	)		external static;

/* internal static */

dcl	rel_to_jump	(4:9) bit (9) internal static initial ("001011001"b,
						/* less_than	-> jump_if_ge */
			"001011000"b,		/* greater_than	-> jump_if_le */
			"001010111"b,		/* equal		-> jump_if_ne */
			"001010110"b,		/* not_equal	-> jump_if_eq */
			"001010101"b,		/* less_or_equal	-> jump_if_gt */
			"001010100"b);		/* greater_or_equal	-> jump_if_lt */

dcl	action_index	(0:36) fixed bin (15) int static
			init (0, 0, 0, 1, 0, 7, 5, 7, 7, 0, 2, 0, 5, 5, 0, 5, 0, 7, 6, 3, 7, 0, 4, 7, 5, 7, 7, 5, 0, 7,
			0, 0, 4, 7, 0, 7, 5);

/* include files */

%include parse;
%include token_list;
%include token;
%include token_types;
%include op_codes;
%include block;
%include block_types;
%include statement;
%include statement_types;
%include nodes;
%include operator;
%include list;
%include label;
%include declare_type;

/* program */

	then_goto_optimized, else = "0"b;
	end_ptr = null;
	cblock = father_block;
	return_flag = our_return_flag;
	conditions = our_conditions;

	pl1_stat_$cur_statement, if = create_statement (if_statement, cblock, entry_ptr, conditions);

	if entry_ptr ^= null
	then call declare_label (cblock, if, entry_ptr, by_explicit_context);

	k = k + 1;
	expr = expression_parse (k, cblock);

	if expr = null
	then do;
		call parse_error (432, null);
		loc = null;

		do while ("1"b);
		     if t_table.type = semi_colon
		     then do;
			     label_ptr = null;
			     type = binary (null_statement);
			     go to action (0);
			end;

		     if t_table.string = "then"
		     then do;
			     k = k + 1;
			     go to get_statement_type;
			end;
		     k = k + 1;
		end;
	     end;

	bit_type = ""b;

	if expr -> node.type = operator_node
	then bit_type = expr -> operator.op_code;

	if substr (bit_type, 1, 5) = "00100"b		/* relational class */
	then do;					/* change relational to jump op */
		jump_if_false, expr -> operator.op_code = rel_to_jump (binary (substr (bit_type, 6, 4), 4));
		jump_if_true = bit_type | "000010000"b;
	     end;
	else do;
		q = create_operator (jump_false, 2);
		q -> operator.operand (2) = expr;
		expr = q;
		jump_if_true = jump_true;
		jump_if_false = jump_false;
	     end;

	loc = create_label (cblock, null, by_compiler);	/* label is used to jump around then clause */
	expr -> operand (1) = loc;
	if -> statement.root = expr;
	location = loc -> label.token;

	if t_table.string = "then"
	then k = k + 1;
	else call parse_error (431, null);

get_statement_type:
	conditions = cblock -> block.prefix;
	then_type, type = statement_type (k, label_ptr, conditions);
	go to action (action_index (type));

/* 	***************** Statements requiring individual parsing procedures. ******** */

action (1):					/* begin statement */
	call procedure_parse (k, label_ptr, conditions, cblock, end_ptr, begin_block, return_flag);
	go to end_up;

action (2):					/* do statement    */
	call do_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag, return_flag, "0"b);
	go to end_up;

action (3):					/* if statement    */
	call if_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag);
	go to if_end_up;

action (4):					/* on statement    */
	call on_parse (k, label_ptr, conditions, cblock, end_ptr);
	go to end_up;

/*	***************** Statements in error. *************************************** */

action (5):					/* declare,end,entry,format,procedure & possibly return stmts */
	if type = binary (return_statement, 9)
	then if return_flag
	     then n = 412;
	     else go to action (0);
	else n = 430;
	call parse_error (n, null);
	go to end_up;

/* 	***************** Statements all parsed in statement_parse. ****************** */

action (0):
	call statement_parse (k, label_ptr, conditions, cblock, type);
	go to end_up;

/*	***************** Statements processed in-line ******************************* */

action (6):					/* go to statement in then clause */
	if label_ptr ^= null | conditions ^= cblock -> block.prefix | ^pl1_stat_$optimize
	then go to action (0);

	if t_table.string = "goto"
	then k = k + 1;
	else do;
		k = k + 1;

		if t_table.string ^= "to"
		then call parse_error (446, null);
		else k = k + 1;
	     end;

	if expr = null
	then expr = create_operator ((jump_if_true), 2);
	else expr -> op_code = jump_if_true;

	expr -> operand (1) = reference_parse (k, cblock);

	if expr -> operand (1) = null
	then call print (446);
	else if t_table.type ^= semi_colon
	then call parse_error (1, null);

	then_goto_optimized = "1"b;
	goto end_up;

action (7):
	call io_statement_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag, bit (binary (type, 9)));
	goto end_up;

end_up:
	if end_ptr = null
	then call lex;				/* ^=null ==> end of block */

/* If the statement following the if statement has a label on it, e.g.
   	if e1 then label: ....
   we have to insert a null statement with 0 statement id before it.  This is
   done to prevent problems if the semantic translator has to expand the
   labelled statement into several statements.  This must also
   be done if the profile option is used. */

if_end_up:
	q = if -> statement.next;
	if q ^= null
	then if q -> statement.labels ^= null | (^else & pl1_stat_$profile)
	     then do;
		     q = create_statement (null_statement, if, null, conditions);
		     string (q -> statement.source_id) = "0"b;
		end;

	if else
	then go to process_else_clause;		/* second time thru */

	if ^then_goto_optimized
	then do;

/* following code is executed after the then clause is parsed. */

		q = create_statement (null_statement, cblock, null, conditions);

/* following code sets the id of the statement holding
   the label to the id of the statement preceding it.  This is
   done so that the following statement can be expanded into several
   statements.  We can't just set id of statement to 0 because that
   fouls up the optimizer */

		string (q -> statement.source_id) = string (q -> statement.back -> statement.source_id);

		if loc ^= null
		then do;
			t, q -> statement.labels = create_list (2);
			loc -> label.statement = q;
			t -> list.element (2) = location;
		     end;
		else go to exit;
	     end;

	if end_ptr ^= null				/* unsatisfied labelled END statement */
	then go to exit;

	k = 1;
	if t_table.string ^= "else"
	then go to exit;				/* no else clause; return */

	k = k + 1;
	if t_table.type ^= left_parn
	then go to call_st1;

/*  else  (  */

	if token_list (k + 3) -> token.type ^= colon
	then go to call_st1;			/* could be assignment or condition prefix list */

/*  else  (  <anything>  )  :  */

	k = k + 1;

	if t_table.type = identifier			/* it's a CPL in an else clause */
	then do;
		k = 2;
		else = "1"b;			/* this is the case that statement type */
		go to call_st;			/* can't handle.  */
	     end;

/* it must be a label array named "else" ! */

call_st1:
	k = 1;
call_st:
	conditions = cblock -> block.prefix;
	type = statement_type (k, label_ptr, conditions);

	if type = binary (else_clause, 9)
	then do;
		if else
		then call print (150);		/* no if stmnt before else */

		else = "1"b;
		k = k + 1;
		go to call_st;
	     end;

	if ^else
	then go to exit;

/* Now that we know we have an else clause, we check the type of statement
   in it--certain combinations may be optimized slightly.	*/

	if type ^= binary (goto_statement, 9) | label_ptr ^= null | conditions ^= cblock -> block.prefix
	     | ^pl1_stat_$optimize
	then go to action (action_index (type));

	if then_goto_optimized
	then go to action (0);

	if t_table.string = "goto"
	then k = k + 1;
	else do;
		k = k + 1;

		if t_table.string ^= "to"
		then call parse_error (446, null);
		else k = k + 1;
	     end;

	expr -> operator.op_code = jump_if_false;
	expr -> operand (1) = reference_parse (k, cblock);

	if expr -> operand (1) = null
	then call print (446);
	else if t_table.type ^= semi_colon
	then call parse_error (1, null);
						/* delete null statement. */
	q -> statement.back -> statement.next = null;	/* since this is the last statement on the chain. */
	cblock -> block.end_main = q -> statement.back;	/* reset block ptr */
	loc -> label.statement = null;

	if end_ptr = null
	then call lex;

	goto exit;

/* following code is executed after the else clause is parsed. */

/* When control reaches here, the tree is as follows:

  if->      ----  if_statement
            |           |
            |           |
            |     then body
            |           |
            |           |     q->  - - - - - - go to statement
	  |	    |			|
   t->      ----> null statement		|
	              |			|
		    |			|
		    |			|
	          else body			|
		    |			|
  p->		    |    < - - - - - - - - null statement

   We must insert a goto statement after the "then" body which
   transfers control around the else body. This action is not done
   if the then body does not exist, or if it is a return statement 
   or a stop statement.  This action is also not done if the "then"
   body is a noniterative do-group whose end statement has only one
   label (which therefore must be compiler created), and which has
   a return statement, a goto statement, or a stop statement preceding
   the end statement.	*/

process_else_clause:
	t = loc -> label.statement;
	if t = null
	then go to exit;

	if (then_type = binary (return_statement, 9)) | (then_type = binary (stop_statement, 9))
	then go to exit;

	p = t -> statement.back;
	bit_type = p -> statement.statement_type;

	if (bit_type = return_statement) | (bit_type = goto_statement) | (bit_type = stop_statement)
	then go to exit;

	if then_type = binary (do_statement, 9)
	then do;
		do = if -> statement.next;
		do while (do -> statement.statement_type ^= do_statement);
						/* skip any null stmts */
		     do = do -> statement.next;	/* to get to the do stmt */
		end;
		if do -> statement.root -> operator.operand (3) = null
						/* if no do_spec operator */
		then if p -> statement.labels -> list.element (1) = null
						/* if one label */
		     then do;			/* we know p -> end stmt */
			     bit_type = p -> statement.back -> statement.statement_type;
			     if (bit_type = return_statement) | (bit_type = goto_statement)
				| (bit_type = stop_statement)
			     then go to exit;
			end;
	     end;

	if label_ptr = null & type = binary (null_statement, 9)
	then go to exit;

	q = create_statement (goto_statement, p, null, conditions);

/* we have to set the id of the goto and the null statement following
   it to be the same as the id of the last statement in the then group.
   This is necessary to prevent difficulties if the semantic translator
   has to expand the first statement of else group into several statements */

	string (t -> statement.source_id), string (q -> statement.source_id) = string (p -> statement.source_id);

	t, q -> statement.root = create_operator (jump, 1);
	q, t -> operand (1) = create_label (cblock, null, by_compiler);

/* make a label for the newly created jump operator */

	p = create_statement (null_statement, cblock, null, conditions);

/* following code sets the id of the statement holding
   the label to the id of the statement before it.  This is
   done so that the following statement can be expanded into several
   statements.  We can't just set id of statement to 0 because
   that fouls up the optimizer */

	string (p -> statement.source_id) = string (p -> statement.back -> statement.source_id);

	q -> label.statement = p;
	t, p -> statement.labels = create_list (2);	/* again, t is a temporary ptr. */
	t -> list.element (2) = q -> label.token;	/* fish out name from label node */

exit:
	entry_ptr = label_ptr;
	his_end_ptr = end_ptr;
	return;

print:
     proc (m);

dcl	m		fixed bin (15);

	call parse_error (m, null);
	if -> statement.root = null;
	if -> statement.statement_type = null_statement;

     end print;

     end /* if_parse */;




		    io_statement_parse.pl1          10/03/83  1725.6rew 10/03/83  1006.2      132741



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


io_statement_parse:	proc(k_index,entry_ptr,conditions_par,father_block_par,end_ptr_par,return_flag_par,statement_type_par);

				/*
				   forwards added as open keyword.
				   buffered,unbuffered deleted.
				*/




dcl	k_index fixed bin(15),
	statement_ptr ptr,
	father_block_par ptr,
	(stype_b9,statement_type_par) bit(9) aligned,
	(end_ptr_par,label_ptr,end_ptr,t,q,loc) ptr,
	(return_flag_par,return_flag) bit(1) aligned,
	(conditions,conditions_par) bit(12) aligned;



dcl	( addr,bit,char,fixed,hbound,null,substr ) builtin;


dcl	pl1_stat_$cur_statement ptr static ext;
dcl	pl1_stat_$check_ansi bit(1) aligned ext;
dcl	(arg,cur_block,dp,fnp,root_op,st,entry_ptr) ptr,
	(dpt,errp,locate_variable,previous_edit_ptr) ptr init(null),

	(options_allowed_index,iocode,error_number,i,k,n,open_index,operand_number) fixed bin(15),
	(data_index,operands,option_index,stype) fixed bin(15),

	get_put bit(1) aligned,
	try_else bit(1) aligned init("0"b),
	opcode bit(9) aligned,
	(fab2_bits, io_job,io_job_item,io_jobs_allowed) bit(36) aligned,

	tstring12 char(12) aligned,
	tstring char(8) aligned;


dcl	action_index(0:38) fixed bin(15) int static
	init ( 0,0,0,1,0,	7,5,7,7,0,	2,0,5,5,0,	5,0,7,6,3,
	       7,0,4,7,5,	7,7,5,0,7,	0,0,4,7,0,	7,5,5,0);

dcl	option_keyword(19) char(8) aligned int static
		init("file","string","skip","title","key",
		     "keyto","keyfrom","copy","line","linesize",
		     "set","into","ignore","from","page",
		     "pagesize","list","data","edit");


dcl	plio_options(19) fixed bin(15) int static
		init(1,2,11,36,21,
		     22,23,12,10,33,
		     24,25,26,27,9,
		     32,6,4,5);


	/* order of bits for io_job and options_allowed:

	file,stri,vary,	data,edit,list,
	get ,put, page,	line,skip,copy,
	x,   x,   x,   	read,writ,rewr,
	dele,loca,key,	kyto,kyfr,set,
	into,igno,from,	else,ref, x,
	x,   psiz,lsiz,	open,clos,title		*/


dcl	options_allowed(9) bit(36) aligned int static
		init(	"110111000011"b,
			"11011100111"b,
			"1000000000000000000011011100001"b,
			"100000000000000000000010001"b,
			"100000000000000000001000001"b,
			"100000000000000000001"b,
			"100000000000000000000011"b,
			"100000000000000000000000000000011001"b,
			"1"b   );


dcl	io_jobs_forbidden(19) bit(36) aligned int static init(

/*	 fsvdelgpplsc lurwrdlkkksiifer nploct	(see declaration of "option_keyword"
	 itaadieuaiko onereeoeyyengrle lsspli	for list down and  "order of bits
	 lrrtisttgnip claiwlcytfttnosf oiieot	for io_job and options_allowed" for
	 eiyatt  eepy kkdtrea or oome  kzznsl	list across)		*/

	"000111001111111111111111111111111111"b,	/* file */
	"000111000001"b,				/* string */
	"100111000011"b,				/* skip */
	"100000000000000000000000000000011000"b,	/* title */
	"1000000000000000000000011110001"b,		/* key */
	"1000000000000000000000011110001"b,		/* keyto */
	"1000000000000000000000010010000"b,		/* keyfrom */
	"110111001111"b,				/* copy */
	"100111001100"b,				/* line */
	"100000000000000000000000000000010001"b,	/* linesize */
	"1000000000000000000011100010001"b,		/* set */
	"1000000000000000000011000010001"b,		/* into */
	"1000000000000000000011000010001"b,		/* ignore */
	"100000000000000000001010001000"b,		/* from */
	"100111001100"b,				/* page */
	"100000000000000000000000000000001001"b,	/* pagesize */
	"111000001111"b,				/* list */
	"111000001111"b,				/* data */
	"111000001111"b	);			/* edit */




dcl	open_keyword(12) char(12) aligned int static
		init("print","input","output","update","stream",
		     "record","sequential","seql","direct","keyed",
		     "environment","env");

dcl	bit_index(12) fixed bin(15) int static
		init(5,6,7,8,9,  11,12,12,13,18  ,20,20);

dcl	label_index(19) fixed bin(15) int static
		init(1,2,2,2,2,1,2,1,2,2,1,1,2,1,3,2,4,4,4);




%include parse;
%include list;
%include block_types;
%include label;
%include block;
%include context_codes;
%include nodes;
%include declare_type;
%include operator;
%include op_codes;
%include statement;
%include statement_types;
%include symbol;
%include token_list;
%include token_types;

/* 		Build the IO statement  */


	k=k_index+1;
	stype_b9 =statement_type_par;
	cur_block=father_block_par;
	conditions=conditions_par;
	return_flag=return_flag_par;
	end_ptr_par=null;
	pl1_stat_$cur_statement,
	statement_ptr=create_statement(stype_b9,cur_block,entry_ptr,conditions);

	if stype_b9 ^= format_statement then
		if entry_ptr ^= null	/* LABEL on non-format statement */
		then call declare_label(cur_block,statement_ptr,entry_ptr,by_explicit_context);
		else;
	else	do;			/* FORMAT STATEMENT */
		t=statement_ptr->statement.labels;
		statement_ptr->statement.labels=null;
			do while (t^=null);
			q=t->list.element(2);
			if q->node.type=reference_node then call parse_error(169,null);
			else	do;
				q=create_symbol(cur_block,q,by_explicit_context);
				q->symbol.constant,
				q->symbol.format="1"b;
				q->symbol.initial=statement_ptr;
				end;
			t=t->list.element(1);
			end;

		if format_list_parse(k,cur_block,statement_ptr,fnp)
		then	if t_table.type^=semi_colon
			then	goto err428;
			else	goto ret;
		else	goto error_recover;
		end;


	if stype_b9=get_statement
	then do;
		opcode=get_file;
		operands=5;
		iocode=7;
		options_allowed_index=1;
	end;				else

	if stype_b9=put_statement
	then do;
		opcode=put_file;
		operands=5;
		iocode=8;
		options_allowed_index=2;
	end;				else /* (to make the label work)  */
comma_loop:
	if stype_b9=open_statement
	then do;
		fab2_bits="0"b;
		opcode=open_file;
		operands=6;
		iocode=34;
		options_allowed_index=8;
	end;				else

	if stype_b9=close_statement
	then do;
		opcode=close_file;
		operands=3;
		iocode=35;
		options_allowed_index=9;
	end;				else

	if stype_b9=read_statement
	then do;
		opcode=read_file;
		operands=4;
		iocode=16;
		options_allowed_index=3;
	end;				else

	if stype_b9=write_statement
	then do;
		opcode=write_file;
		operands=4;
		iocode=17;
		options_allowed_index=4;
	end;				else

	if stype_b9=rewrite_statement
	then do;
		opcode=rewrite_file;
		operands=4;
		iocode=18;
		options_allowed_index=5;
	end;				else

	if stype_b9=locate_statement
	then do;
		opcode=locate_file;
		operands=5;
		iocode=20;
		options_allowed_index=7;

		if t_table.type=identifier then
			do;
			locate_variable=token_list(k);
			k=k+1;
			end;
		else goto err257;

	end;				else

	if stype_b9=delete_statement
	then do;
		opcode=delete_file;
		operands=4;
		iocode=19;
		options_allowed_index=6;
	end;				else


	goto err288;

/* 		Set up the statement */



	statement_ptr->statement.root  ,
	root_op=create_operator(opcode,operands);



	get_put = stype_b9=get_statement | stype_b9=put_statement;
	io_job="0"b;
	substr(io_job,iocode,1)="1"b;	/* shows statement type */
	io_jobs_allowed=options_allowed(options_allowed_index);

	/*  */

options_loop:
	tstring=t_table.string;

	if t_table.type=identifier
	then 	do;
		io_job_item="0"b;
			do option_index=1 to hbound(option_keyword,1) while(tstring^=option_keyword(option_index));
			end;
		if option_index<=hbound(option_keyword,1)
		then	do;

			substr(io_job_item,plio_options(option_index),1)="1"b;
			if (io_job_item & io_jobs_allowed)="0"b then go to err239;
			if io_job_item & io_job then go to err247;
			io_job=io_job | io_job_item;

			io_jobs_allowed=io_jobs_allowed & io_jobs_forbidden(option_index);



			if option_index<3
			then	operand_number=2;		else

			if option_index<8
			then	operand_number=3;		else

			if option_index<15
			then	operand_number=1;

			else	operand_number=4;



				/*
				   THIS TABLE TO BE USED BY
				   IO-SEMANTICS !!!!!!!!!!!

				operand(1):	copy,line,linesize,set,into,ignore,from
				   operand(2):	file,string,(ref)
				   operand(3):	key,keyto,keyfrom,skip,title
				   operand(4):	pagesize,data_spec,locate's variable
				   operand(5):	fab2_bits
				   operand(last)=
				   operand(operands)=io_job OR fab2_bits
					*/

			k=k+1;
			goto option_label(label_index(option_index));
			end;


/*  OPEN STATEMENT  */
		if stype_b9 ^= open_statement then goto err288;

		tstring12=t_table.string;
		do open_index=1 to hbound(open_keyword,1) while(tstring12^=open_keyword(open_index));
		end;

		if open_index>hbound(open_keyword,1) then goto err288;

		substr(io_job_item,bit_index(open_index),1)="1"b;
		if io_job_item & fab2_bits then goto err247;
		fab2_bits = fab2_bits | io_job_item;
		k=k+1;
		if open_index=11 | open_index=12	/* environment(interactive)  */
		then	do;
			if pl1_stat_$check_ansi
			     then call parse_error(355,token_list(k-1));
			if t_table.type^=left_parn then goto err197;
			k=k+1;
			if t_table.string = "interactive" then substr(fab2_bits,14,1) = "1"b; 
				else if t_table.string = "stringvalue" then substr(fab2_bits,17,1) = "1"b; 
					else goto err197;
			k=k+1;
			if t_table.type^=right_parn then goto err197;
			k=k+1;
			end;
		goto options_loop;
		end;

/* 		Let's get out now */



	if t_table.type=semi_colon
	|  t_table.type=comma
	then	do;
exit:		if get_put
		then	if (io_job & "000111001110"b)="0"b
			then	goto err254;		/* GET and PUT requires either SKIP or LINE or PAGE or DS */

		if  root_op->operator.operand(2)=null	/* FILE or (REF) required for non-stream */
		then	do;
			if ^get_put then goto err245;
			if substr(io_job,7,1)
			then	root_op->operator.operand(2)=
				create_token("sysin",identifier);
			else	root_op->operator.operand(2)=
				create_token("sysprint",identifier);
			substr(io_job,1,1)="1"b;
			end;


		if stype_b9=write_statement & root_op->operator.operand(1)=null
		then	goto err241;


		if stype_b9=read_statement then
			do;
			if substr(io_job,24,3)="000"b then  goto err448;
					/* into, set, ignore : one must appear  */
			if substr(io_job,26,1) then if substr(io_job,21,2)^="00"b then goto err449;
					/* ignore cannot have key or keyto */
			end;

		if stype_b9=locate_statement
		then	root_op->operator.operand(4)=locate_variable;

		if substr(io_job,1,1)	/* file context */
		then	call context((root_op->operator.operand(2)),cur_block,file_name_context);
		else 	if substr(io_job,2,1)
			then	if io_job & "00000000111"b then goto err239;

		if substr(io_job,12,1)	/* copy-file */
		then	call context((root_op->operator.operand(1)),cur_block,file_name_context);

		if substr(io_job,24,1)	/* set */
		then	call context((root_op->operand(1)),cur_block,pointer_context);

		if stype_b9=open_statement
		then	root_op->operator.operand(5)=create_token(char(fab2_bits,36)||"b",bit_string);

		root_op->operator.operand(operands)=
		create_token(char(io_job,36)||"b",bit_string);

		if t_table.type=comma
		then	do;
			if stype_b9^=open_statement
			then if stype_b9^=close_statement
			      then goto err288;
	
			pl1_stat_$cur_statement,
			statement_ptr=create_statement(stype_b9,cur_block,null,conditions);
			k=k+1;
			goto comma_loop;
			end;



		go to ret;



		end;
	go to err1;	/* mysterious token */

			/*      */

option_label(1):

	if t_table.type^=left_parn
	then do;
		if option_index ^=8 /* copy */ then go to err237;
		root_op->operator.operand(1)=create_token("sysprint",identifier);
		goto options_loop;
	end;



	k=k+1;
	arg = reference_parse(k,cur_block);
	if arg = null then go to err240;

	goto attach_arg;

option_label(2):

	if t_table.type^=left_parn
	then do;
		if option_index^=3			/*   skip   */
		then goto err237;

		goto option_label(3);
	end;

	k=k+1;
	arg = expression_parse(k,cur_block);
	if arg = null then go to err290;

	goto attach_arg;

option_label(3):

ck_labels:
	if option_index=2 then		/* string option adjustments */

		do;
		if stype_b9=put_statement & root_op->operator.operand(2)->node.type=operator_node
		then goto err243;
	
		if stype_b9=get_statement
		then	root_op->operator.op_code=get_string;
		else	root_op->operator.op_code=put_string;
		end;

	goto options_loop;

			/*      */

attach_arg:
	root_op->operator.operand(operand_number)=arg;

locate_right_parn:
	if t_table.type^=right_parn then goto err238;

	k=k+1;
	goto ck_labels;

option_label(4):
	k=k-1;
	if ^get_put then goto err289;
		data_index=1+8*(option_index-17);	/* for historical reasons */

	if stype_b9=get_statement
	then	if data_index=1
		then	opcode=get_list_trans;	else

		if data_index=9
		then	opcode=get_data_trans;

		else	opcode=get_edit_trans;

	else	if data_index=1
		then	opcode=put_list_trans;	else

		if data_index=9
		then	opcode=put_data_trans;	else

		if data_index=17
		then	opcode=put_edit_trans;

		else	goto err288;

	k=k+1;

	if data_index=9 & t_table.type^=left_parn
	then do;
		root_op->operator.operand(4)=create_operator(opcode,2);
		goto options_loop;
	end;

edit_loop:
	if ^data_list_parse(k,cur_block,dp) then goto error_recover;
	if dp->operator.op_code=do_fun then goto err293;

	if data_index<17
	then do;
		dpt=create_operator(opcode,2);
		dpt->operator.operand(1)=dp;

		root_op->operator.operand(4)=dpt;
	end;
	else do;
		if ^format_list_parse(k,cur_block,(null),fnp) then goto error_recover;

		dpt=create_operator(opcode,3);
		dpt->operator.operand(1)=dp;
		dpt->operator.operand(2)=fnp;

		if previous_edit_ptr^=null
		then	previous_edit_ptr->operator.operand(3)=dpt;
		else	root_op->operator.operand(4)=dpt;

		previous_edit_ptr=dpt;
		if t_table.type=left_parn then goto edit_loop;
	end;

	goto options_loop;



			/*      */

err1:
	error_number=1;
	goto err_list;

err197:
	error_number=197;
	goto err;

err237:
	error_number=237;
	goto err_list;

err238:
	error_number=238;
	goto err_list;

err239:
	error_number=239;
	goto err;

err240:
	error_number=240;
	goto err_list;

err241:
	error_number=241;
	goto err;

err243:
	error_number=243;
	goto err;

err245:
	error_number=245;
	goto err;

err247:
	error_number=247;
	goto err;

err254:
	error_number=254;
	goto err;

err257:
	error_number=257;
	goto err;

err288:
	call parse_error(288,token_list(k));
	k=k+1;
	goto options_loop;

err289:
	error_number=289;
	goto err;

err290:
	error_number=290;
	errp=arg;
	goto err_list;

err293:
	error_number=293;
	goto err;

err428:
	error_number=428;
	errp=null;
	goto err;

err448:
	error_number=448;
	goto err;

err449:
	error_number=449;
	goto err;


err_list:
	errp=token_list(k);

err:
	call parse_error(error_number,errp);

error_recover:
	statement_ptr->statement.statement_type=null_statement;
	statement_ptr->statement.root=null;



ret:
	return;


	end io_statement_parse;




		    lex.pl1                         10/03/83  1725.6rew 10/03/83  1006.3      462159



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


/* lex is the lexical analysis program for the Multics PL/I compiler.  Its primary responsibilities are:
	1. Break the source program into tokens.
	2. Process %include statements.
	3. Generate a line-numbered source listing.
	4. Diagnose errors in lexical syntax of programs.

   lex also performs several other chores during its operation that eliminate a few of the
   vagaries of the PL/I language, thus making the job of subsequent phases simpler.  They are:
	1. Apply string repetition factors.
	2. Apply bit-string radix factors.
	3. Determine the type of numeric constants.
	4. Notice equal signs at level 0 of parenthesis.
	5. Notice colons at level 0 of parenthesis.

   The original version of lex was written by J.D.Mills, 26 March 1968.
   Totally rewritten to use EIS in April, 1977 by P. Green.
   Modified 770713 by PG to put back in checks for errors 157 and 158.
   Modified 771020 by PG to fix 1677 (compiler faults if no status permission to main source program),
	and 1668 (lex can fault if a stmt has > 3000 tokens)
   Modified 780607 by PG to fix 1738 (print one more character of source line for errors 157 and 158)
   Modified 780804 by PG to fix 1759 (not supplying substitutable argument for errors 109 and 110).
   Modified 790730 by PG to use rank builtin, to create enter_token facility, reducing number of calls
	to create_token, and to implement %page and %skip.
   Modified 7 October 1980 by M. N. Davidoff to fix 1989 (uninitialized variable can cause lex to fault
	on null statements) and to implement 1914 (call com_err_ with find_include_file_ code).
*/
/* format: style3 */
lex:
     procedure ();

/* automatic */

declare	action_index	fixed bin,		/* index of action to execute */
	bitcount		fixed bin (24),		/* bitcount of include segment */
	char_value	fixed bin (9),		/* numeric value of current character */
	code		fixed bin (35),		/* standard status code */
	current_char	char (1) aligned,		/* character that stopped the scan, char we are checking */
	depthx		fixed bin,		/* do-loop temporary */
	decimal_value	bit (9) aligned,		/* flag meaning constant is decimal, not binary */
	dx		fixed bin,		/* temporary used in radix expansion */
	error_number	fixed bin (15),		/* temp to hold error number for call to lex_error */
	error_token	ptr,			/* temp to hold token ptr for call to lex_error */
	first_bit		fixed bin,		/* temporary used in radix expansion */
	float_value	bit (9) aligned,		/* flag meaning constant is float, not fixed */
	imaginary_value	bit (9) aligned,		/* flag meaning constant is imaginary, not real */
	include_file_length fixed bin (21),		/* length, in chars, of new include file */
	include_file_name	char (32) varying,		/* name of include file */
	include_file_ptr	ptr,			/* ptr to base of include file */
	integral_value	bit (9) aligned,		/* flag meaning constant is integral, not fractional */
	k		fixed bin,		/* index into t_table */
	line_length	fixed bin (21),		/* number of chars to be printed in listing */
	listing_on	bit (1) aligned,		/* flag meaning to generate a source listing */
	max_in_chars	fixed bin,		/* max string length before radix expansion */
	n		fixed bin (21),		/* temp used when allocating a source node */
	new_file_number	fixed bin (8),		/* number of new source file */
	new_file_token_ptr	ptr,			/* ptr to token node for new include file name */
	page_macro	bit (1) aligned,		/* "1"b iff macro was %page, not %skip */
	parenthesis_level	fixed bin (21),		/* nesting depth of parenthesis in current statement */
	percent_sign_seen	bit (1) aligned,		/* a %-sign was seen during scan...ck for %include later */
	protected		bit (18) aligned,		/* "1"b iff current (constant) token is protected from default */
	radix		fixed bin,		/* radix of bit string begin expanded */
	rep_factor	fixed bin,		/* string replication factor */
	saved_token_index	fixed bin,		/* token_index at time % was seen */
	scan_index	fixed bin (21),		/* index (relative to source_index) of forward scan */
	string_max	fixed bin (21),		/* temporary used in rep_factor checking */
	string_token_start	fixed bin (21),		/* if token_start = 0, string_token_start holds offset
						   of first char of token in source seg */
	strx		fixed bin,		/* temporary used in radix expansion */
	temp_token_string	char (256) varying,		/* copy of token used by replication and radix code */
	token_index	fixed bin,		/* index of current token being created */
	token_length	fixed bin (21),		/* length of token in characters */
	token_ptr		ptr unal,			/* ptr to current delimiter token */
	token_start	fixed bin (21),		/* index of first character of current token */
	token_string	char (256) varying,		/* current token in some hairy cases */
	token_string_ptr	ptr,			/* ptr to token string, wherever it is */
	token_type	bit (9) aligned;		/* type of current token */

/* based */

declare	source_string	char (source_length) based (source_ptr),
						/* overlay of current source segment */
	token_overlay	char (token_length) based (token_string_ptr);
						/* overlay of current token */

/* builtins */

declare	(addr, addrel, binary, bit, char, copy, divide, hbound, index, lbound, length, ltrim, null, rank, rtrim, search,
	string, substr, verify)
			builtin;

/* entries */

declare	com_err_		entry options (variable);
declare	date_time_	entry (fixed bin (71), char (*));
declare	find_include_file_$initiate_count
			entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
declare	hcs_$terminate_noname
			entry (ptr, fixed bin (35));

/* external static */

declare	error_table_$noentry
			fixed bin (35) external static;
declare	(
	pl1_stat_$cur_statement
			ptr,			/* ptr to tree for current statement...cleared by lex */
	pl1_stat_$level_0_colon
			bit (1) aligned,		/* "1"b iff colon seen at level 0 of parens */
	pl1_stat_$level_0_equal
			bit (1) aligned,		/* "1"b iff equal sign seen at level 0 of parens */
	pl1_stat_$line_count
			fixed bin,		/* grand total of number of source lines processed */
	pl1_stat_$listing_on
			bit (1) aligned,		/* "1"b iff line-numbered source listing being created */
	pl1_stat_$seg_name	char (32) varying,		/* name of main source program, w/o .pl1 suffix */
	pl1_stat_$st_length fixed bin (21),		/* length of current statement */
	pl1_stat_$st_start	fixed bin (21)		/* 0-origin char offset of begining of current statement;
						   value -1 means it has never been set */
	)		external static;

/* internal static */

declare	(
	file_token_ptr	ptr,			/* ptr to token node for current file name */
	lexing_after_end_stmt
			bit (1) aligned,		/* "1"b iff main procedure has been lexed and we are
						   just scanning comments and white space */
	line_begins_in_comment
			bit (1) aligned,		/* "1"b iff source line begins inside a comment */
	line_number	fixed bin (14),		/* line number of current line in source segment */
	line_start	fixed bin (21),		/* offset of first char to be printed in listing */
	source_depth	fixed bin,		/* 0-origin nesting depth of include files */
	source_index	fixed bin (21),		/* index into current source segment */
	source_length	fixed bin (21),		/* length (in characters) of current source segment */
	source_ptr	ptr,			/* pointer to base of current source segment */
	statement_number	fixed bin (5),		/* number of statement on current line */
	suppress_line_numbers
			bit (1) aligned		/* next listing line should not have source numbers */
	)		internal static;

declare	(and_token_ptr, arrow_token_ptr, assignment_token_ptr, asterisk_token_ptr, cat_token_ptr, colon_token_ptr,
	comma_token_ptr, expon_token_ptr, ge_token_ptr, gt_token_ptr, le_token_ptr, left_parn_token_ptr, lt_token_ptr,
	minus_token_ptr, ne_token_ptr, ngt_token_ptr, nlt_token_ptr, not_token_ptr, or_token_ptr, percent_token_ptr,
	period_token_ptr, plus_token_ptr, right_parn_token_ptr, semi_colon_token_ptr, slash_token_ptr)
			ptr unaligned internal static;/* ptrs to like-named tokens */

declare	1 file_stack	(0:32) aligned internal static,
						/* Pushdown stack used to process nested include files */
	  2 source_ptr	ptr,			/* ptr to base of source segment */
	  2 file_token_ptr	ptr,			/* ptr to token node for file name */
	  2 source_index	fixed bin (21),		/* index (in chars) of lexical scan */
	  2 source_length	fixed bin (21),		/* length (in chars) of source segment */
	  2 line_number	fixed bin (14),		/* line number in source segment */
	  2 file_number	fixed bin (8);		/* file number of source segment */

declare	action_table	(0:128) fixed bin internal static
			initial (/* what action label to take given ASCII char */ (9) 9,
						/* 000-010	ctl chars */
			1,			/* 011		tab	*/
			8,			/* 012		newline	*/
			(2) 1,			/* 013-014	vt, np	*/
			(19) 9,			/* 015-037	ctl chars	*/
			1,			/* 040		sp	*/
			9,			/* 041		!	*/
			2,			/* 042		"	*/
			9,			/* 043		#	*/
			9,			/* 044		$	*/
			4,			/* 045		%	*/
			17,			/* 046		&	*/
			9,			/* 047		'	*/
			18,			/* 050		(	*/
			19,			/* 051		)	*/
			10,			/* 052		*	*/
			20,			/* 053		+	*/
			21,			/* 054		,	*/
			11,			/* 055		-	*/
			7,			/* 056		.	*/
			5,			/* 057		/	*/
			(10) 6,			/* 060-071	0 - 9	*/
			22,			/* 072		:	*/
			16,			/* 073		;	*/
			12,			/* 074		<	*/
			23,			/* 075		=	*/
			13,			/* 076		>	*/
			(2) 9,			/* 077-100	? @	*/
			(26) 3,			/* 101-132	A - Z	*/
			(3) 9,			/* 133-135	[ \ ]	*/
			14,			/* 136		^	*/
			(2) 9,			/* 137-140	_ `	*/
			(26) 3,			/* 141-172	a - z	*/
			9,			/* 173		{	*/
			15,			/* 174		|	*/
			(3) 9,			/* 175-177	{ ~ PAD	*/
			9);			/* >177		non-ASCII	*/

declare	command		char (3) internal static options (constant) initial ("pl1");
declare	(
	asterisk_or_newline char (2) initial ("*
"),
	double_quote	char (1) initial (""""),
	double_quote_or_newline
			char (2) initial ("""
"),
	HT_VT_NP_SP	char (4) initial ("	 "),
	identifier_characters
			char (64) initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"),
	newline		char (1) initial ("
"),
	newpage		char (1) initial ("")
	)		internal static;

/* include files */

%include language_utility;
%include nodes;
%include pl1_tree_areas;
%include radix_factor_constants;
%include source_list;
%include system;
%include token;
%include token_list;
%include token_types;

/* program */

/* Main entry to lex.  Convert the next source statement into tokens and return. */

	token_index = 0;
	protected = ""b;
	listing_on = pl1_stat_$listing_on;
	parenthesis_level = 0;
	pl1_stat_$level_0_colon = "0"b;
	pl1_stat_$level_0_equal = "0"b;
	percent_sign_seen = "0"b;

action (1):					/* SCAN WHITE SPACE */
	scan_index = verify (substr (source_string, source_index), HT_VT_NP_SP);

	if scan_index = 0
	then go to end_of_source_reached_but_no_pending_token;

	source_index = source_index + scan_index;
	current_char = substr (source_string, source_index - 1, 1);
	char_value = rank (current_char);

	if char_value >= hbound (action_table, 1)
	then action_index = action_table (hbound (action_table, 1));
	else action_index = action_table (char_value);

	go to action (action_index);

action (2):					/* SCAN STRING. current_char = double_quote */
	if source_index > source_length
	then do;
		call lex_error (362, file_token_ptr);	/* eof in string */
		go to end_of_source_reached_but_no_pending_token;
	     end;

	token_start = source_index;			/* skip over double_quote */
	string_token_start = source_index - 1;		/* save offset of double_quote for make_token */
	token_length = 0;
	token_type = char_string;			/* tentative */

rescan:
	scan_index = search (substr (source_string, source_index), double_quote_or_newline);

	if scan_index = 0
	then do;
		call lex_error (362, file_token_ptr);	/* eof in string */

		if token_start = 0			/* filling copy of token */
		then token_string = token_string || substr (source_string, source_index);
		else token_length = source_length - token_start + 1;

		go to end_of_source_reached;
	     end;

	if substr (source_string, source_index + scan_index - 1, 1) = newline
	then do;
		if token_start = 0
		then token_string = token_string || substr (source_string, source_index, scan_index);
		else token_length = token_length + scan_index;

		source_index = source_index + scan_index;
		call print_line;
		go to rescan;
	     end;

/* Found a matching quote. Ignore it. */

	if token_start = 0
	then token_string = token_string || substr (source_string, source_index, scan_index - 1);
	else token_length = token_length + scan_index - 1;

	source_index = source_index + scan_index;

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

	if substr (source_string, source_index, 1) = double_quote
	then do;
		if token_start > 0
		then do;				/* begin using copy, if we haven't already */
			token_string = substr (source_string, token_start, token_length);
			token_start = 0;
		     end;

		token_string = token_string || double_quote;
		source_index = source_index + 1;
		go to rescan;
	     end;
	else if substr (source_string, source_index, 1) = "b"
	then do;
		token_type = bit_string;
		source_index = source_index + 1;

		if source_index <= source_length
		then do;
			radix = index ("1234", substr (source_string, source_index, 1));

			if radix > 0
			then source_index = source_index + 1;
			else radix = 1;
		     end;
		else radix = 1;

		if token_start > 0
		then do;
			temp_token_string = substr (source_string, token_start, token_length);
			token_start = 0;
		     end;
		else temp_token_string = token_string;

/* We will now expand temp_token_string according to the specified
		        radix factor, and put the result into token_string */

		if radix = 4
		then if search (temp_token_string, capital_hex) ^= 0
		     then dx = 5;
		     else dx = 4;
		else dx = radix;

		if verify (temp_token_string, digits (dx)) ^= 0
		then do;				/* non-binary digit in bit string */
			error_token = create_token (temp_token_string || "b", bit_string);
			call lex_error (152, error_token);
			token_type = char_string;
			token_string = temp_token_string;
		     end;
		else if radix > 1
		then do;
			max_in_chars = divide (max_bit_string_constant, radix, 21, 0);
			token_string = "";

			if length (temp_token_string) > max_in_chars
			then do;			/* radix factor makes bit string too long */
				temp_token_string = substr (temp_token_string, 1, max_in_chars);
				error_token =
				     create_token ("""" || temp_token_string || """b" || substr ("1234", radix, 1),
				     no_token /* fake type - suppress quoting */);
				call lex_error (154, error_token);
						/* radix factor makes bit string too long */
			     end;

			do strx = 1 to length (temp_token_string);
			     first_bit = radix * (index (digits (dx), substr (temp_token_string, strx, 1)) - 1) + 1;
			     token_string = token_string || substr (expand_bit_chars (radix), first_bit, radix);
			end;
		     end;
		else token_string = temp_token_string;
	     end;

	if token_index >= 3				/* is there room for a replication factor? */
	then if token_list (token_index - 2) -> token.type = left_parn & token_list (token_index) -> token.type = right_parn
	     then do;
		     token_index = token_index - 3;	/* wipe out rep factor and parens */

		     if token_list (token_index + 2) -> token.type ^= dec_integer
		     then call lex_error (110, token_list (token_index + 2));
						/* rep factor is not a decimal integer */
		     else do;
			     rep_factor = token_to_binary (token_list (token_index + 2));

			     if token_start > 0
			     then do;
				     temp_token_string = substr (source_string, token_start, token_length);
				     token_start = 0;
				end;
			     else temp_token_string = token_string;

			     if token_type = bit_string
			     then string_max = max_bit_string_constant;
			     else string_max = max_char_string_constant;

			     if length (temp_token_string) * rep_factor > string_max
			     then do;
				     error_token = create_token (temp_token_string || "b", bit_string);
				     call lex_error (109, error_token);
						/* replicated string too long */
				     rep_factor = divide (string_max, length (temp_token_string), 21, 0);
				end;

			     token_string = "";
			     do strx = 1 to rep_factor;
				token_string = token_string || temp_token_string;
			     end;
			end;
		end;

	if token_type = bit_string
	then do;
		if length (token_string) > max_bit_string_constant
		then do;				/* bit string too long */
			token_string = substr (token_string, 1, max_bit_string_constant);
			error_token = create_token (token_string || "b", bit_string);
			call lex_error (100, error_token);
		     end;

		token_string = token_string || "b";
	     end;
	else if token_start > 0
	then if token_length > max_char_string_constant
	     then do;
		     token_length = max_char_string_constant;
		     error_token = create_token (substr (source_string, token_start, token_length), char_string);
		     call lex_error (100, error_token); /* char string too long */
		end;
	     else ;
	else if length (token_string) > max_char_string_constant
	then do;					/* char string too long */
		token_string = substr (token_string, 1, max_char_string_constant);
		call lex_error (100, create_token ((token_string), char_string));
	     end;

	if source_index > source_length
	then go to end_of_source_reached;

	call make_token;
	go to check_syntax_after_constant;

action (3):					/* SCAN IDENTIFIERS */
	token_type = identifier;
	token_start = source_index - 1;

	scan_index = verify (substr (source_string, source_index), identifier_characters);

	if scan_index = 0
	then do;
		source_index = source_length + 1;
		go to end_of_source_reached;
	     end;

	source_index = source_index + scan_index - 1;
	call make_token;

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

	current_char = substr (source_string, source_index, 1);
	char_value = rank (current_char);
	source_index = source_index + 1;

	if char_value >= hbound (action_table, 1)
	then action_index = action_table (hbound (action_table, 1));
	else action_index = action_table (char_value);

	if action_index = 2				/* double quote */
	then do;
		error_token = token_list (token_index);

		if error_token -> token.string ^= "p" & error_token -> token.string ^= "pic"
		     & error_token -> token.string ^= "picture"
		then call lex_error (158, error_token); /* double quote after identifier */
	     end;

	go to action (action_index);

/* SINGLE CHARACTER TOKENS */

action (4):					/* % */
	token_start = source_index - 1;
	if percent_sign_seen
	then call lex_error (125, null);		/* %sign while parsing macro */

	percent_sign_seen = "1"b;
	saved_token_index = token_index;
	call print_line_before_include;
	call enter_token (percent_token_ptr);
	go to action (1);

action (17):					/* & */
	token_start = source_index - 1;
	call enter_token (and_token_ptr);
	go to action (1);

action (18):					/* ( */
	token_start = source_index - 1;
	parenthesis_level = parenthesis_level + 1;
	call enter_token (left_parn_token_ptr);
	go to action (1);

action (19):					/* ) */
	token_start = source_index - 1;
	parenthesis_level = parenthesis_level - 1;
	call enter_token (right_parn_token_ptr);
	go to action (1);

action (20):					/* + */
	token_start = source_index - 1;
	call enter_token (plus_token_ptr);
	go to action (1);

action (21):					/* , */
	token_start = source_index - 1;
	call enter_token (comma_token_ptr);
	go to action (1);

action (22):					/* : */
	token_start = source_index - 1;
	if parenthesis_level = 0
	then pl1_stat_$level_0_colon = "1"b;

	call enter_token (colon_token_ptr);
	go to action (1);

action (23):					/* = */
	token_start = source_index - 1;
	if parenthesis_level = 0
	then pl1_stat_$level_0_equal = "1"b;

	call enter_token (assignment_token_ptr);
	go to action (1);

action (5):					/* SEPARATE / AND /* */
	token_start = source_index - 1;		/* tentative */
	token_type = slash;

	if source_index > source_length
	then go to end_of_source_reached;

	if substr (source_string, source_index, 1) ^= "*"
	then do;
		call enter_token (slash_token_ptr);
		go to action (1);
	     end;

/* Now lexing a comment */

	source_index = source_index + 1;

rescan_comment:
	scan_index = search (substr (source_string, source_index), asterisk_or_newline);
	if scan_index = 0
	then do;
		call lex_error (360, file_token_ptr);	/* eof in comment */
		go to end_of_source_reached_but_no_pending_token;
	     end;

	source_index = source_index + scan_index;

	if substr (source_string, source_index - 1, 1) = newline
	then do;
		call print_line;
		line_begins_in_comment = "1"b;
		go to rescan_comment;
	     end;

/* at this point substr (source_string, source_index - 1, 1) is an asterisk */

	if substr (source_string, source_index, 1) = "/"
	then do;
		source_index = source_index + 1;
		go to action (1);
	     end;

	go to rescan_comment;

action (6):					/* SCAN NUMBERS AND ISUBS. current char = <digit> */
	token_start = source_index - 1;
	token_type = fixed_bin;			/* set initial token_type & flags  */
	decimal_value = is_decimal_constant;		/* .. */
	imaginary_value = "0"b;			/* .. */
	float_value = "0"b;				/* .. */
	integral_value = is_integral_constant;		/* .. */

	if source_index > source_length
	then go to end_of_source_reached;

	call scan_past_digits;

	if substr (source_string, source_index, 1) = "."
	then do;
		integral_value = "0"b;

scan_fraction:
		source_index = source_index + 1;

		if source_index > source_length
		then go to end_of_source_reached;

		call scan_past_digits;
	     end;
	else if source_index + 2 <= source_length
	then if substr (source_string, source_index, 3) = "sub"
	     then do;
		     source_index = source_index + 3;
		     token_type = isub;
		     call make_token;
		     go to action (1);
		end;

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

	if (substr (source_string, source_index, 1) = "e") | (substr (source_string, source_index, 1) = "f")
	then do;
		if substr (source_string, source_index, 1) = "e"
		then float_value = is_float_constant;

		integral_value = "0"b;
		source_index = source_index + 1;

		if source_index > source_length
		then do;
			call missing_exponent;
			go to end_of_source_reached;
		     end;

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

			if source_index > source_length
			then do;
				call missing_exponent;
				go to end_of_source_reached;
			     end;
		     end;

		call scan_past_digits;
	     end;

	if substr (source_string, source_index, 1) = "b"	/* binary constant */
	then do;
		decimal_value = "0"b;
		scan_index = source_index;		/* remember position of "b" */
		source_index = source_index + 1;
	     end;

	if source_index <= source_length
	then if substr (source_string, source_index, 1) = "p"
						/* default suppression indicator */
	     then do;
		     source_index = source_index + 1;
		     protected = "1"b;
		end;

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

	if decimal_value = ""b			/* is this a binary constant ? */
	then if verify (substr (source_string, token_start, token_length), ".01") > 0
	     then do;
		     error_token =
			create_token (substr (source_string, token_start, source_index - token_start), i_float_dec);
						/* don't care about real token_type...guess safely */
		     call lex_error (153, error_token); /* non-binary digit in apparent binary constant */

/* Fix up the constant...restore the decimal attribute, and eliminate the "b" from
		        the token_string */

		     decimal_value = is_decimal_constant;
		     token_string = substr (source_string, token_start, scan_index - token_start);

		     if imaginary_value ^= ""b
		     then token_string = token_string || "i";

		     string_token_start = token_start;	/* save for make_token */
		     token_start = 0;
		end;

/* If the constant is protected (and wasn't copied by the error recovery
	   code above), then we have to copy it now in order to avoid getting
	   the "p" into the token. */

	if (protected ^= ""b) & token_start > 0
	then do;
		if imaginary_value ^= ""b
		then token_length = source_index - token_start - 2;
		else token_length = source_index - token_start - 1;

		token_string = substr (source_string, token_start, token_length);
		token_start = 0;

		if imaginary_value ^= ""b
		then token_string = token_string || "i";
	     end;

	if source_index > source_length
	then go to end_of_source_reached;

	call make_token;

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

check_syntax_after_constant:
	current_char = substr (source_string, source_index, 1);
	char_value = rank (current_char);
	source_index = source_index + 1;

	if char_value >= hbound (action_table, 1)
	then action_index = action_table (hbound (action_table, 1));
	else action_index = action_table (char_value);

	if action_index = 3 | action_index = 6 | action_index = 2
						/* alphabetics, numbers, double quote */
	then call lex_error (157, token_list (token_index));
						/* text after string */

	go to action (action_index);

action (7):					/* SEPARATE . AND NUMBERS. current_char = "." */
	token_start = source_index - 1;
	token_type = period;			/* assume for now */

	if source_index > source_length
	then go to end_of_source_reached;

	current_char = substr (source_string, source_index, 1);
						/* grab next character */
	char_value = rank (current_char);

	if char_value <= hbound (action_table, 1)
	then if action_table (char_value) = 6		/* next char is a <digit> */
	     then do;
		     token_type = fixed_bin;		/* set initial token_type & flags */
		     decimal_value = is_decimal_constant;
						/* .. */
		     imaginary_value = "0"b;		/* .. */
		     float_value = "0"b;		/* .. */
		     integral_value = "0"b;		/* .. */
		     go to scan_fraction;
		end;

	call enter_token (period_token_ptr);
	go to action (1);

action (8):					/* SCAN NEWLINE */
	call print_line;
	go to action (1);

action (9):					/* MISC ERRORS */
	if char_value < 32 | char_value >= 128
	then do;
		error_number = 159;			/* control chars & non-ASCII not allowed */
		error_token = create_token (char (bit (char_value, 9)) || "b", bit_string);
	     end;
	else if (current_char = "_") | (current_char = "$")
	then do;
		error_number = 151;			/* $ and _ may not start identifier */
		error_token = null;
	     end;
	else do;
		error_number = 363;			/* printing char ^a not allowed */
		error_token = create_token ((current_char), char_string);
	     end;

	call lex_error (error_number, error_token);
	go to action (1);

action (10):					/* SEPARATE * AND ** */
	token_start = source_index - 1;
	token_type = asterisk;
	token_ptr = asterisk_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

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

	call enter_token (token_ptr);
	go to action (1);

action (11):					/* SEPARATE - AND -> */
	token_start = source_index - 1;
	token_type = minus;
	token_ptr = minus_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

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

	call enter_token (token_ptr);
	go to action (1);

action (12):					/* SEPARATE < AND <= */
	token_start = source_index - 1;
	token_type = lt;
	token_ptr = lt_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

	if substr (source_string, source_index, 1) = "="
	then do;
		source_index = source_index + 1;
		token_ptr = le_token_ptr;
	     end;

	call enter_token (token_ptr);
	go to action (1);

action (13):					/* SEPARATE > AND >= */
	token_start = source_index - 1;
	token_type = gt;
	token_ptr = gt_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

	if substr (source_string, source_index, 1) = "="
	then do;
		source_index = source_index + 1;
		token_ptr = ge_token_ptr;
	     end;

	call enter_token (token_ptr);
	go to action (1);

action (14):					/* SEPARATE ^ AND ^= AND ^< AND ^> */
	token_start = source_index - 1;
	token_type = not;
	token_ptr = not_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

	if substr (source_string, source_index, 1) = "="
	then do;
		source_index = source_index + 1;
		token_ptr = ne_token_ptr;
	     end;
	else if substr (source_string, source_index, 1) = "<"
	then do;
		source_index = source_index + 1;
		token_ptr = nlt_token_ptr;
	     end;
	else if substr (source_string, source_index, 1) = ">"
	then do;
		source_index = source_index + 1;
		token_ptr = ngt_token_ptr;
	     end;

	call enter_token (token_ptr);
	go to action (1);

action (15):					/* SEPARATE | AND || */
	token_start = source_index - 1;
	token_type = or;
	token_ptr = or_token_ptr;

	if source_index > source_length
	then go to end_of_source_reached;

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

	call enter_token (token_ptr);
	go to action (1);

action (16):					/* SCAN SEMICOLON.  current_char = ";" */
	token_start = source_index - 1;

	if percent_sign_seen
	then do;
		percent_sign_seen = "0"b;
		listing_on = pl1_stat_$listing_on;
		line_start = source_index;
		k = saved_token_index + 1;

		if token_list (token_index) -> token.type = percent
						/* %; */
		then do;
			token_index = saved_token_index;
			go to action (1);		/* ignore it */
		     end;

		k = k + 1;

		if t_table.string = "page" | t_table.string = "skip"
		then do;
			if t_table.string = "page"
			then page_macro = "1"b;
			else page_macro = "0"b;

			if k = token_index		/* no argument */
			then n = 1;
			else do;
				k = k + 1;	/* step over keyword */

				if token_index - k + 1 < 3
						/* must be at least 3 more tokens */
				then go to error_376;
						/* a good programming lang wouldn't need this goto */

				if t_table.type ^= left_parn | token_list (k + 1) -> token.type ^= dec_integer
				     | token_list (k + 2) -> token.type ^= right_parn
				then do;
error_376:
					call lex_error (376, null);
						/* syntax error in %page macro */
					k = token_index;
						/* suppress possible error 375, below */
					n = 1;
				     end;
				else do;
					n = token_to_binary (token_list (k + 1));
					k = k + 2;
				     end;
			     end;

			if listing_on
			then if page_macro
			     then call pl1_print$non_varying (copy (newpage, n), 0);
			     else call pl1_print$non_varying (copy (newline, n), 0);

			if k ^= token_index
			then call lex_error (375, null);
						/* excess arguments ignored */

			token_index = saved_token_index;
			go to action (1);
		     end;

		if t_table.string ^= "include"
		then do;
			token_index = saved_token_index;
			call lex_error (103, null);	/* not include or page */
			go to action (1);
		     end;

		k = k + 1;

		if (t_table.type = identifier) | (t_table.type = char_string)
		then include_file_name = t_table.string;
		else do;
			token_index = saved_token_index;
			call lex_error (104, null);	/* filename not identifier or string */
			go to action (1);
		     end;

		if k ^= token_index
		then do;
			token_index = saved_token_index;
			call lex_error (441, null);	/* no semicolon */
			go to action (1);
		     end;

		token_index = saved_token_index;

		if length (include_file_name) >= 24
		then do;
			call lex_error (106, token_list (k));
						/* filename too long */
			go to action (1);
		     end;

		include_file_name = include_file_name || ".incl.pl1";
		new_file_token_ptr = create_token ((include_file_name), identifier);

		call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount,
		     include_file_ptr, code);

		if include_file_ptr = null
		then do;
			call lex_error (107, new_file_token_ptr);
						/* include file not found */

			if code ^= 0 & code ^= error_table_$noentry
			then call com_err_ (code, command, "^a", include_file_name);

			go to action (1);
		     end;
		else if code ^= 0
		then call com_err_ (code, command, "^a", include_file_name);

		if pl1_stat_$last_source = source_list_length
		then do;
			call hcs_$terminate_noname (include_file_ptr, code);
			call lex_error (129, new_file_token_ptr);
						/* too many include files */
			go to action (1);
		     end;

		if source_depth > hbound (file_stack, 1)
		then do;
			call hcs_$terminate_noname (include_file_ptr, code);
			call lex_error (112, new_file_token_ptr);
						/* nested too deep */
			go to action (1);
		     end;

		file_stack (source_depth).source_ptr = source_ptr;
		file_stack (source_depth).file_token_ptr = file_token_ptr;
		file_stack (source_depth).source_index = source_index;
		file_stack (source_depth).source_length = source_length;
		file_stack (source_depth).line_number = line_number;
		file_stack (source_depth).file_number = pl1_stat_$source_seg;

		do depthx = lbound (file_stack, 1) to source_depth;
		     if file_stack (depthx).source_ptr = include_file_ptr
		     then do;
			     call hcs_$terminate_noname (include_file_ptr, code);
			     call lex_error (108, new_file_token_ptr);
						/* infinite recursion */
			     go to action (1);
			end;
		end;

/* At this point it is OK to enter the include file */

		source_depth = source_depth + 1;
		include_file_length = divide (bitcount + 8, 9, 24, 0);
		new_file_number =
		     create_source (include_file_ptr, include_file_length, new_file_token_ptr, pl1_stat_$source_seg,
		     line_number);

		call enter_source_segment (include_file_ptr, include_file_length, new_file_token_ptr, new_file_number);
		go to action (1);
	     end;

	call emit_semicolon;

	if lexing_after_end_stmt
	then call lex_error (99, null);		/* text after end of program */

	return;

/* Control transfers here whenever the lex reaches the end of the current source segment. */

end_of_source_reached:
	call make_token;

end_of_source_reached_but_no_pending_token:
	if percent_sign_seen
	then do;
		call lex_error (71, null);		/* eof in macro */
		percent_sign_seen = "0"b;		/* ignore %include */
		token_index = saved_token_index;
	     end;

	call print_line_at_eof;

	pl1_stat_$line_count = pl1_stat_$line_count + line_number;

	if source_depth = 0				/* we are now in the outermost file */
	then do;
		if lexing_after_end_stmt
		then do;
			if token_index > 0		/* any tokens generated? */
			then call lex_error (99, null);
						/* text after eof */

			return;
		     end;

		if token_index > 0
		then do;
			call lex_error (361, null);	/* last stmt has no semicolon */
			call emit_semicolon;
			return;
		     end;

		call lex_error (101, null);		/* not enough end stmts */

		if token_index < token_list_length
		then token_index = token_index + 1;
		token_list (token_index) = create_token ("end", identifier);
						/* generate "end" */
		call emit_semicolon;		/* generate ";" */
		pl1_stat_$st_length = 0;		/* no source for this phony stmt */
		return;
	     end;

	source_depth = source_depth - 1;		/* we were in incl file...pop out */
	call enter_source_segment (file_stack (source_depth).source_ptr, file_stack (source_depth).source_length,
	     file_stack (source_depth).file_token_ptr, file_stack (source_depth).file_number);

	source_index = file_stack (source_depth).source_index;
	line_start = source_index;
	line_number = file_stack (source_depth).line_number;
	go to action (1);

/* Entry to initialize all of the static variables used by the lex and create_token.
   This entry must be called before the first call to lex itself. */

initialize_lex:
     entry (bv_source_ptr, bv_source_length);

/* parameters */

declare	(
	bv_source_ptr	ptr,
	bv_source_length	fixed bin (21)
	)		parameter;

/* program */

/* Initialize create_token, first */

	call create_token$init_hash_table;

/* Initialize static variables */

	statement_number = 1;

	suppress_line_numbers = "0"b;
	line_begins_in_comment = "0"b;
	lexing_after_end_stmt = "0"b;

/* Get static pointers to all the delimiter tokens */

	plus_token_ptr = create_token ("+", plus);
	minus_token_ptr = create_token ("-", minus);
	asterisk_token_ptr = create_token ("*", asterisk);
	slash_token_ptr = create_token ("/", slash);
	expon_token_ptr = create_token ("**", expon);
	not_token_ptr = create_token ("^", not);
	and_token_ptr = create_token ("&", and);
	or_token_ptr = create_token ("|", or);
	cat_token_ptr = create_token ("||", cat);
	ne_token_ptr = create_token ("^=", ne);
	lt_token_ptr = create_token ("<", lt);
	gt_token_ptr = create_token (">", gt);
	le_token_ptr = create_token ("<=", le);
	ge_token_ptr = create_token (">=", ge);
	ngt_token_ptr = create_token ("^>", ngt);
	nlt_token_ptr = create_token ("^<", nlt);
	assignment_token_ptr = create_token ("=", assignment);
	colon_token_ptr = create_token (":", colon);
	semi_colon_token_ptr = create_token (";", semi_colon);
	comma_token_ptr = create_token (",", comma);
	period_token_ptr = create_token (".", period);
	arrow_token_ptr = create_token ("->", arrow);
	left_parn_token_ptr = create_token ("(", left_parn);
	right_parn_token_ptr = create_token (")", right_parn);
	percent_token_ptr = create_token ("%", percent);

	source_depth = 0;
	pl1_stat_$source_seg = -1;
	pl1_stat_$last_source = -1;
	pl1_stat_$line_count = 0;

	new_file_token_ptr = create_token (pl1_stat_$seg_name || ".pl1", identifier);

/* Create a source node for the main file */

	new_file_number = create_source (bv_source_ptr, bv_source_length, new_file_token_ptr, 0, 0);

/* Enter the main source segment */

	call enter_source_segment (bv_source_ptr, bv_source_length, new_file_token_ptr, new_file_number);
	return;

/* Entry to terminate source segments. */

terminate_source:
     entry;

	do pl1_stat_$last_source = pl1_stat_$last_source to 0 by -1;
	     m = pl1_stat_$last_source;
	     call hcs_$terminate_noname ((source.seg_ptr), code);
	end;
	return;

/* Entry to write the last line and check for text after the end statement. */

write_last_line:
     entry;

declare	1 source_info	aligned,
	  2 line_id	char (9) unal,
	  2 sp1		char (2) unal,
	  2 file_id	char (3) unal,
	  2 sp2		char (4) unal,
	  2 dtm		char (16) unal,
	  2 sp3		char (2) unal,
	  2 include_name	char (32) unal,
	  2 sp4		char (2) unal,
	  2 pathname	char (168) unal;

declare	line_id		char (9) varying aligned;
declare	five_digits	picture "zzzzz";
declare	three_digits	picture "zz9";

/* internal static */

declare	header		char (93) varying aligned int static options (constant) init ("	SOURCE FILES USED IN THIS COMPILATION.

LINE      NUMBER  DATE MODIFIED     NAME			PATHNAME");

/* program */

	lexing_after_end_stmt = "1"b;
	call lex;					/* see if anything there besides white space & comments */

	listing_on = pl1_stat_$listing_on;

	if ^listing_on
	then return;

	call pl1_print$varying_nl (header);

	do m = 0 to pl1_stat_$last_source;
	     string (source_info) = "";

	     if source.file_number = ""b
	     then line_id = "";
	     else do;
		     three_digits = binary (source.file_number, 8);
						/* known to take three digits at most */
		     line_id = ltrim (three_digits) || "-";
		end;

	     five_digits = binary (source.line_number, 14);
						/* known to take five digits at most */
	     source_info.line_id = line_id || ltrim (five_digits);

	     three_digits = m;			/* known to take three digits at most */
	     source_info.file_id = three_digits;

	     call date_time_ (source.dtm, source_info.dtm);
	     source_info.include_name = source.name -> token.string;
	     source_info.pathname = source.pathname;
	     n = length (string (source_info)) - length (source_info.pathname) + source.pathlen;
	     call pl1_print$non_varying_nl (string (source_info), (n));
	end;
	return;

/* Internal procedures */

/* Internal procedure to create a source node for the new include file */

create_source:
     procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number, bv_line_number) returns (fixed bin (8));

/* parameters */

declare	(
	bv_source_ptr	ptr,			/* ptr to base of source segment */
	bv_source_length	fixed bin (21),		/* length in chars of source segment */
	bv_file_token_ptr	ptr,			/* ptr to token node of file name */
	bv_file_number	fixed bin (8),		/* number of file that contains %include stmt */
	bv_line_number	fixed bin (14)		/* number of line that contains %include stmt */
	)		parameter;

/* automatic */

declare	dname		char (168),		/* directory name of source segment */
	dtm		fixed bin (71),		/* date-time modified of source segment */
	ename		char (32),		/* real entry name of source segment */
	include_path	char (168) varying,		/* temporary */
	uid		bit (36) aligned;		/* file system unique id of segment */

/* entries */

declare	translator_info_$get_source_info
			entry (ptr, char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35));

/* external static */

declare	pl1_stat_$node_uses (18) fixed bin external static;
						/* number of nodes allocated, indexed by type */

/* program */

	call translator_info_$get_source_info (bv_source_ptr, dname, ename, dtm, uid, code);
	if code ^= 0
	then do;
		call lex_error (344, bv_file_token_ptr);
		dname = "UNKNOWN DIRECTORY NAME";
		ename = bv_file_token_ptr -> token.string;
						/* give 'em something. */
		uid = ""b;
		dtm = 0;
	     end;

	include_path = rtrim (dname) || ">" || rtrim (ename);
	n = length (include_path);

	pl1_stat_$node_uses (14) = pl1_stat_$node_uses (14) + 1;

	m, pl1_stat_$last_source = pl1_stat_$last_source + 1;
	allocate source in (tree_area) set (source_list (m));
	source.node_type = source_node;
	source.seg_ptr = bv_source_ptr;
	source.name = bv_file_token_ptr;
	source.source_length = bv_source_length;
	source.pathname = include_path;
	source.file_number = bit (bv_file_number, 8);
	source.line_number = bit (bv_line_number, 14);
	source.uid = uid;
	source.dtm = dtm;
	return (m);

     end create_source;

/* Procedure to centralize the processing performed when the semicolon is reached. */

emit_semicolon:
     procedure;

	if token_index = token_list_length
	then call lex_error (105, null);		/* too many tokens */
	else token_index = token_index + 1;

	token_list (token_index) = semi_colon_token_ptr;

	if token_index = 1				/* we have just lexed a null statement */
	then do;
		pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
		pl1_stat_$statement_id.line_number = bit (line_number, 14);
		pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
		pl1_stat_$st_start = token_start - 1;
	     end;

	statement_number = statement_number + 1;

	if statement_number >= 1f5b			/* check range of statement number */
	then do;
		call lex_error (111, null);		/* too many statements */
		statement_number = 1;
	     end;

	if pl1_stat_$st_start ^= -1			/* if st_start has been set, set st_length */
	then pl1_stat_$st_length = (source_index - 1) - pl1_stat_$st_start;
	pl1_stat_$cur_statement = null;
	return;

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

enter_source_segment:
     procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number);

/* parameters */

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

/* program */

	source_ptr = bv_source_ptr;
	source_length = bv_source_length;
	source_index = 1;
	file_token_ptr = bv_file_token_ptr;
	pl1_stat_$source_seg = bv_file_number;
	line_number = 1;
	line_start = 1;
	pl1_stat_$st_start = -1;
	pl1_stat_$st_length = 0;
	return;

     end enter_source_segment;

/* Internal procedure to centralize error reporting by the lex. */

lex_error:
     procedure (bv_error_number, bv_token_ptr);

/* parameters */

declare	(
	bv_error_number	fixed bin (15),
	bv_token_ptr	ptr
	)		parameter;

/* automatic */

declare	statement_length	fixed bin (21);		/* length (in chars) of current statement */

/* program */

	pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
	pl1_stat_$statement_id.line_number = bit (line_number, 14);
	pl1_stat_$statement_id.statement_number = bit (statement_number, 5);

	if pl1_stat_$st_start = -1			/* if st_start hasn't been set, do it now */
	then do;
		pl1_stat_$st_start = line_start - 1;	/* print one source line... */

		if source_index > source_length	/* if beyond eof, cancel stmt */
		then statement_length = 0;
		else statement_length = (source_index - 1) - pl1_stat_$st_start;
	     end;
	else statement_length = (source_index - 1) - pl1_stat_$st_start;

	call error_ (bv_error_number, pl1_stat_$statement_id, bv_token_ptr, pl1_stat_$source_seg, (pl1_stat_$st_start),
	     (statement_length), 0);			/* st_start by value because I'm lazy */
	return;

     end lex_error;

/* This procedure is called to enter a pointer to a token into the token
   list. */

enter_token:
     procedure (P_token_ptr);

/* parameters */

declare	P_token_ptr	ptr unal parameter;

/* program */

	if token_index < token_list_length
	then token_index = token_index + 1;

	token_list (token_index) = P_token_ptr;

	if token_index = 1				/* Now emitting first token of a stmt... */
	then do;
		pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
		pl1_stat_$statement_id.line_number = bit (line_number, 14);
		pl1_stat_$statement_id.statement_number = bit (statement_number, 5);

		if token_start = 0
		then pl1_stat_$st_start = string_token_start - 1;
						/* char_strings & bit_strings */
		else pl1_stat_$st_start = token_start - 1;
						/* everything else */
	     end;

	return;

     end enter_token;

/* This procedure is called to make a token. */
/* Convention:
	token_type is set to the correct type, OR is set to fixed_bin, in which case
		the variables imaginary_value, float_value, decimal_value, and integral_value are all set.
	token_start is either set to the index of the first character of the token,
		OR is zero and token_string contains the token.  If token_start is nonzero and token_type is char_string,
		token_length is also set, otherwise it isn't.
	source_index is set to the index of the first character after the token. */

make_token:
     procedure;

/* automatic */

declare	token_ptr		ptr unal;

/* program */

	if token_type = fixed_bin
	then token_type = token_type | imaginary_value | float_value | decimal_value | integral_value;

	if token_start > 0
	then do;
		token_string_ptr = addr (substr (source_string, token_start, 1));
						/* UGH */

		if token_type ^= char_string		/* token_length is OK for char_strings */
		then token_length = source_index - token_start;

		if token_length > max_identifier_length
		then do;
			token_length = max_identifier_length;
			call lex_error (100, create_token (token_overlay, (token_type)));
		     end;
	     end;
	else do;
		token_string_ptr = addrel (addr (token_string), 1);
						/* UGH */
		token_length = length (token_string);
	     end;

	token_ptr = create_token$protected (token_overlay, (token_type), protected);
						/* we pass token_type by value to get sta's, not stba's. */

	protected = ""b;

	call enter_token (token_ptr);
	return;

/* Internal procedure (quick block) version of create_token */

%include create_token;
     end create_token;

     end make_token;

/* Internal procedure to centralize error recovery from eof in numeric tokens */

missing_exponent:
     procedure;

	token_string = substr (source_string, token_start, source_index - token_start);
	token_string = token_string || "0";		/* provide an exponent */
	token_start = 0;
	call lex_error (155, create_token ((token_string), char_string));
						/* missing exponent */
	return;

     end missing_exponent;

/* This procedure handles everything that needs to be done when a newline is seen */
/* Convention: source_index must be set to the index of the character after the newline. */

print_line:
     procedure;

	line_length = source_index - line_start;

	if listing_on
	then call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
		(line_begins_in_comment));

	line_start = source_index;
	line_number = line_number + 1;

	if line_number >= 1f14b			/* check range of line number */
	then if ^lexing_after_end_stmt		/* doesn't matter if past program portion of segment */
	     then do;
		     call lex_error (46, null);	/* too many source lines */
		     line_number = 1;		/* no use counting higher...node fields aren't big enough */
		end;

	statement_number = 1;
	suppress_line_numbers = "0"b;
	line_begins_in_comment = "0"b;
	return;

     end print_line;

/* procedure to flush listing buffer of everything on last line of a segment.  There are two special cases
   to worry about: (1) the last line is empty, and (2) the last line doesn't end in a newline. */

print_line_at_eof:
     procedure;

	line_length = source_index - line_start;

	if line_length = 0
	then return;				/* nothing on last line. */

	if listing_on
	then call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
		(line_begins_in_comment));

	line_begins_in_comment = "0"b;

	if substr (source_string, source_index - 1, 1) = newline
	then do;
		suppress_line_numbers = "0"b;
		statement_number = 1;
	     end;
	else suppress_line_numbers = "1"b;

	return;

     end print_line_at_eof;

/* procedure to flush listing buffer of everything on the line before the percent sign. */

print_line_before_include:
     procedure;

	line_length = source_index - line_start - 1;	/* do not print percent sign */

	if line_length > 0
	then do;					/* if ll=0, percent sign is in column 1...nothing to print */
		if listing_on
		then call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
			(line_begins_in_comment));

		suppress_line_numbers = "1"b;		/* we are no longer at the left margin */
		line_begins_in_comment = "0"b;
	     end;

	listing_on = "0"b;				/* in case %include is > 1 line long */
	return;

     end print_line_before_include;

/* Internal procedure to scan sequences of <digits>.  */
/* Convention: source_index is on character after digit upon entry, and is on
   stopping break upon exit. */

scan_past_digits:
     procedure;

	scan_index = verify (substr (source_string, source_index), "0123456789");

	if scan_index = 0
	then do;					/* eof reached */
		source_index = source_length + 1;	/* set to pseudo-char after eof */
		go to end_of_source_reached;
	     end;
	else source_index = source_index + scan_index - 1;
	return;

     end scan_past_digits;

     end lex;




		    on_parse.pl1                    10/03/83  1725.6rew 10/03/83  1005.9       71640



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


/*	This procedure parses on statements, and on units.  If the on unit
	is an unlabeled block, a call is made to procedure_parse with the
	block_type set to "on_unit".

	Written by:	J. D. Mills, 29 May 1968
	Re-written by:	P. Green 4 December 1970, for Version II
	Modified by:	R. A. Barnes 1 November 1973 for snap & system
	Modified by:	RAB 10 February 1977 for multiple condition names
	Modified on:	21 March 1980 by M. N. Davidoff to fix 1948 in which on units consisting of begin blocks which
			are implicitly closed by an end statement with a closure label are parsed incorrectly.  This
			procedure must pass closure label information back to its caller.
*/
/* format: style3 */
on_parse:
     procedure (k, entry_ptr, our_conditions, father_block, his_end_ptr);

dcl	(j, k, type)	fixed bin (15);
dcl	(entry_ptr, father_block, his_end_ptr, end_ptr, cblock, cond_ptr, label_ptr, statement_ptr)
			ptr;
dcl	(on, p, q, r, t)	ptr;

dcl	pl1_stat_$condition_index
			fixed bin (15) ext static;
dcl	(conditions, our_conditions)
			bit (12) aligned;

dcl	action_index	(0:36) fixed bin (15) int static
			init (0, 0, 0, 1, 0, 4, 2, 4, 4, 0, 2, 2, 2, 2, 0, 2, 0, 4, 0, 2, 4, 0, 2, 4, 2, 4, 4, 2, 2, 4,
			0, 0, 3, 4, 0, 4, 2);

dcl	io_condition	(8) char (16) varying int static
			init ("undf", "undefinedfile", "endfile", "endpage", "key", "name", "record", "transmit");

dcl	(binary, bit, null) builtin;

%include parse;
%include block;
%include block_types;
%include context_codes;
%include declare_type;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include statement;
%include statement_types;
%include symbol;
%include token;
%include token_list;
%include token_types;

/* program */

	his_end_ptr = null;
	label_ptr = entry_ptr;

/* create on unit block */

	cblock = create_block (on_unit, father_block);

cond_loop:
	on = create_statement (on_statement, father_block, label_ptr, our_conditions);
						/* create on statement in outer block. */
	if label_ptr ^= null
	then do;
		call declare_label (father_block, on, label_ptr, by_explicit_context);
		label_ptr = null;
	     end;

	k = k + 1;

	if ^get_condition (cond_ptr)
	then go to error_recover;

	on -> statement.root, q = create_operator (enable_on, 3);

	if cond_ptr -> node.type = token_node
	then q -> operand (1) = cond_ptr;
	else do;
		q -> operand (2) = cond_ptr -> reference.offset -> list.element (1);
		q -> operand (1), cond_ptr = cond_ptr -> reference.symbol;
	     end;

	pl1_stat_$condition_index = pl1_stat_$condition_index + 1;
	q -> operator.operand (3) = cblock;

	if t_table.type = comma
	then go to cond_loop;

/* create entry sequence */

	q = create_statement (procedure_statement, cblock, null, (12)"0"b);
	q -> statement.root = create_operator (std_entry, 0);
	q -> statement.labels = create_list (2);
	t = create_token (cond_ptr -> token.string || "." || bindec$vs ((pl1_stat_$condition_index)), identifier);
	p = create_symbol (father_block, t, by_compiler);
	p -> symbol.entry, p -> symbol.internal, p -> symbol.constant = "1"b;
	p -> symbol.equivalence = cblock;
	p -> symbol.initial = q;
	q -> statement.labels -> list.element (2) = p -> symbol.reference;

	if t_table.string = "snap"
	then do;

/* Save k and find token following first reference-like formation.  The cases are these:

	   for j>k+1:
		on error snap(.......) :	snap - (condition prefix)
		on error snap(.......) XX	no_snap
		on error snap->......	no_snap

	   for j=k+1:
		on error snap=		no_snap
		on error snap,		no_snap
		on error snap:		no_snap - BUG moreover
		on error snap XX		snap
*/

		j = k;
		r = reference_parse (j, cblock);

		if (j <= k + 1 | token_list (j) -> token.type = colon) & token_list (j) -> token.type ^= comma
		     & token_list (j) -> token.type ^= colon & token_list (j) -> token.type ^= assignment
		then do;
			on -> statement.snap = "1"b;
			k = k + 1;
		     end;

		call free_node (r);
	     end;

	conditions = father_block -> block.prefix;	/* default conditions for imbedded statement. */
	type = statement_type (k, label_ptr, conditions);

	q -> statement.prefix, cblock -> block.prefix = conditions;
	if label_ptr ^= null
	then do;
		call parse_error (421, null);		/* no labels in on-unit. */
		label_ptr = null;
	     end;

	go to action (action_index (type));

/* ************** IO statements ************************ */

action (4):
	call io_statement_parse (k, label_ptr, conditions, cblock, end_ptr, "1"b, bit (binary (type, 9, 0)));
	goto end_up;

/*	************* Begin statement ************************************************ */

action (1):
	call procedure_parse (k, label_ptr, conditions, cblock, his_end_ptr, on_unit, "1"b /* no return statements */);
	return;

/*	************* Illegal statements ********************************************* */

action (2):
	call parse_error (423, null);			/*  illegal statement in on-unit. */
	go to end_up;

/*	************* Statements all parsed in statement_parse *********************** */

action (0):
	call statement_parse (k, label_ptr, conditions, cblock, type);
	go to end_up;

/*	************* System on-unit ************************************************* */

action (3):
	on -> statement.system = "1"b;

	if token_list (k + 1) -> token.type ^= semi_colon
	then call parse_error (422, token_list (k + 1));

end_up:
	p = create_statement (end_statement, cblock, null, conditions);
	p -> statement.root = create_operator (std_return, 0);

	return;

revert:
     entry (k, statement_ptr, father_block);

dcl	opcode		bit (9) aligned;

	on = statement_ptr;

	if statement_ptr -> statement.statement_type = revert_statement
	then opcode = revert_on;
	else opcode = signal_on;

	k = k + 1;

	if get_condition (cond_ptr)
	then do;
		on -> statement.root, q = create_operator (opcode, 2);

		if cond_ptr -> node.type = token_node
		then q -> operand (1) = cond_ptr;
		else do;
			q -> operand (1) = cond_ptr -> reference.symbol;
			q -> operand (2) = cond_ptr -> reference.offset -> list.element (1);
		     end;
	     end;
	else goto error_recover;

	return;

error_recover:
	on -> statement.root = null;
	on -> statement.statement_type = null_statement;
	return;

get_condition:
     proc (ref) returns (bit (1) aligned);

dcl	(ref, t)		ptr,
	kc		fixed binary;

	kc = k;

	if t_table.string = "cond" | t_table.string = "condition"
	then do;
		k = k + 1;
		if t_table.type = left_parn
		then do;
			if token_list (k + 1) -> token.type ^= identifier
			then goto err420;
			if token_list (k + 2) -> token.type ^= right_parn
			then goto err420;
			kc = k + 1;
			k = k + 3;
		     end;
		t, ref = token_list (kc);
	     end;
	else do;
		do j = 1 to 8 while (io_condition (j) ^= t_table.string);
		end;
		if j < 9
		then do;
			ref = reference_parse (k, father_block);
			if ref = null
			then go to err420;

			if ref -> node.type ^= reference_node
			then go to err420;

			if ref -> reference.qualifier ^= null | ref -> reference.length ^= null
			then go to err420;

			if ref -> reference.offset -> list.number ^= 1
			then go to err420;

			call context ((ref -> reference.offset -> list.element (1)), father_block, file_name_context);
			t = ref -> reference.symbol;	/* ptr to token node */
		     end;
		else do;
			t, ref = token_list (kc);
			k = k + 1;
		     end;
	     end;

	call context (t, father_block, condition_context);
	return ("1"b);

err420:
	call parse_error (420, null);
	return ("0"b);
     end get_condition;

     end on_parse;




		    parse.pl1                       10/03/83  1725.6rew 10/03/83  1006.3       22185



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


/*	Modified on:	2 October 1970 by PG for Version II.
	Modified on:	24 October 1980 by M. N. Davidoff for -prefix.
	Modified 831021 BIM to get a full symbol table by setting root -> block.get_data.
*/
/* format: style3 */
parse:
     procedure (root, source_string, prefix);

/* parameter */

dcl	root		ptr;
dcl	source_string	char (*);
dcl	1 prefix		aligned,
	  2 mask		bit (12),
	  2 conditions	bit (12);

/* automatic */

dcl	conditions	bit (12) aligned;
dcl	end_ptr		ptr;
dcl	entry_ptr		ptr;
dcl	index		fixed bin (15);
dcl	p		ptr;

/* builtin */

dcl	(addr, binary, length, null)
			builtin;

/* external static */

dcl	pl1_stat_$compiler_created_index
			fixed bin external static;
dcl	pl1_stat_$error_memory
			bit (504) aligned external static;
dcl	pl1_stat_$one	pointer external static;
dcl	pl1_stat_$util_abort
			entry variable external static;
dcl       pl1_stat_$generate_symtab bit (1) aligned external static;

%include token_types;
%include statement_types;
%include block_types;
%include block;
%include parse;

/* program */

	pl1_stat_$compiler_created_index = 0;
	pl1_stat_$error_memory = ""b;
	pl1_stat_$util_abort = parse_error;
	call error_$initialize_error;
	end_ptr = reserve$clear ();
	root, p = create_block (root_block, null);
	p -> block.get_data = pl1_stat_$generate_symtab;
	conditions = p -> block.prefix & ^prefix.mask | prefix.conditions;

	call lex$initialize_lex (addr (source_string), length (source_string));
	pl1_stat_$one = create_token ("1", dec_integer);
	call lex;

	index = 1;
	entry_ptr, end_ptr = null;

	if statement_type (index, entry_ptr, conditions) = binary (procedure_statement, 9)
	then do;
		call procedure_parse (index, entry_ptr, conditions, p, end_ptr, external_procedure, "0"b);
		if end_ptr ^= null
		then call parse_error (417, end_ptr);	/* unmatched labeled end statement */
	     end;
	else call parse_error (180, null);		/* no procedure statement */

	call lex$write_last_line;
     end parse;




		    pl1_version.cds                 10/04/83  1028.7rew 10/04/83  1024.6       38484



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


/* format: style3 */
(stringsize):
pl1_version:
     procedure;

/*     Written: 25 September 1979 by PCK to replace stand alone segment, pl1_version_ */

/* external entries */

dcl	create_data_segment_
			entry (ptr, fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	com_err_		entry options (variable);
dcl	decode_clock_value_$date_time
			entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
			fixed bin (71), fixed bin, char (3), fixed bin (35));

/* builtins */

dcl	(unspec, clock, addr, size)
			builtin;

/* internal static */

dcl	day_of_week_string	(1:7) character (9) varying int static options (constant)
			init ("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday");
dcl	month_string	(1:12) character (9) varying int static options (constant)
			init ("January", "February", "March", "April", "May", "June", "July", "August", "September",
			"October", "November", "December");
dcl	my_name		character (11) int static init ("pl1_version") options (constant);

/* conditions */

dcl	(stringsize, error) condition;

/* automatic */

/* RELEASE = "" for the >experimental_library compiler,
	 = <release_number> for the >system_standard_library compiler */

dcl	RELEASE		character (3) varying init ("28d");
dcl	(clock_reading, microsecond)
			fixed bin (71);
dcl	(month, day_of_month, year, day_of_week, hour, minute, second)
			fixed bin;
dcl	time_zone		character (3) init ("");
dcl	pl1_version_string	character (256) varying;
dcl	code		fixed bin (35);
dcl	1 cdsa		like cds_args aligned;	/* info to be passed to
				  create_data_segment_ */
dcl	1 pl1_version_struc,
	  2 pl1_version	character (256) varying,
	  2 pl1_release	character (3) varying;
dcl	year_pic		picture "9999";
dcl	day_of_month_pic	picture "zz";
dcl	hour_pic		picture "99";
dcl	minute_pic	picture "99";

/* include file */

%include cds_args;

/* on unit */

	on stringsize
	     begin;
		call com_err_ (0, my_name, "Stringsize raised.");
		signal error;
	     end;

/* program */

/* Read system clock and convert to calendar date-time */

	clock_reading = clock ();
	call decode_clock_value_$date_time (clock_reading, month, day_of_month, year, hour, minute, second, microsecond,
	     day_of_week, time_zone, code);

	if code ^= 0
	then do;
		call com_err_ (code, my_name);
		return;
	     end;

	year_pic = year;
	day_of_month_pic = day_of_month;

/* Generate a pl1_version_string appropriate for an EXL or SSS compiler */

	if RELEASE ^= ""
	then pl1_version_string =
		"Multics PL/I Compiler, Release " || RELEASE || ", of " || month_string (month) || " "
		|| ltrim (day_of_month_pic) || ", " || year_pic;
	else do;
		hour_pic = hour;
		minute_pic = minute;
		pl1_version_string =
		     "PL/I Compiler of " || day_of_week_string (day_of_week) || ", "
		     || month_string (month) || " " || ltrim (day_of_month_pic) || ", " || year_pic || " at "
		     || hour_pic || ":" || minute_pic;
	     end;

/* Let user know what version string has been generated */

	call ioa_ ("^a: pl1_version_=""^a"".", my_name, pl1_version_string);

/* Fill in pl1_version_struc with version and release info */

	unspec (pl1_version_struc) = ""b;
	pl1_version_struc.pl1_version = pl1_version_string;
	pl1_version_struc.pl1_release = RELEASE;

/* Fill in cdsa for call to create_data_segment_ */

	unspec (cdsa) = "0"b;
	cdsa.have_text = "1"b;			/* Place pl1_version info in text section */
	cdsa.sections (1).p = addr (pl1_version_struc);
	cdsa.sections (1).len = size (pl1_version_struc);
	cdsa.sections (1).struct_name = "pl1_version_struc";
	cdsa.seg_name = my_name;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0
	then call com_err_ (code, my_name, "Creating ^a data segment.", my_name);

     end pl1_version;




		    procedure_parse.pl1             10/03/83  1725.6rew 10/03/83  1005.9       76284



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


/*	This procedure parses all statements occuring in begin blocks and procedures.
	It calls itself recursively to handle nested blocks.

Note well: The declarations and all statements after the label "get_next_statement" are copied in do_parse, and any changes
	made to either must be made to both.

	written by j.d. mills on 24 may 1968
	re-written by R.A. Freiburghouse on Aug 7, 1970 for version II
	modified by R.A. Barnes Feb 13, 1977 for option on begin stmt
	Modified on: May 24 1979 by PCK to implement options(packed_decimal)
	Modified on: 18 March 1980 by M. N. Davidoff to fix bug 1825.  Procedure_parse no longer sets
		pl1_stat_$cur_statement on end statements.  This is consistent with do_parse.  If procedure_parse
		sets pl1_stat_$cur_statement on end statements, and there is a begin block in an else clause
		with a multiple closure end statement, then a call to create_statement in if_parse will fail.
	Modified on: 21 March 1980 by M. N. Davidoff to print warnings for multiple closure end statements.
*/
/* format: style3 */
procedure_parse:
     proc (k, entry_ptr, our_conditions, father_block, his_end_ptr, block_type, our_return_flag);

dcl	block_type	bit (9) aligned;
dcl	(p, q, entry_ptr, label_ptr, end_ptr, cur_block, father_block, his_end_ptr)
			ptr;
dcl	(k, type)		fixed bin (15);
dcl	(conditions, our_conditions)
			bit (12) aligned;
dcl	(begin_entered, return_flag, our_return_flag)
			bit (1) aligned;

dcl	pl1_stat_$cur_statement
			ptr ext static;
dcl	pl1_stat_$check_ansi
			bit (1) aligned ext static;
dcl	(binary, bit, null) builtin;

dcl	action_index	(0:36) fixed bin (15) int static
			init (0, 0, 0, 1, 0, 10, 2, 10, 10, 0, 3, 0, 4, 8, 0, 10, 0, 10, 0, 5, 10, 0, 6, 10, 7, 10, 10,
			8, 0, 10, 0, 0, 0, 10, 0, 10, 9);

%include parse;
%include token_list;
%include block;
%include declare_type;
%include op_codes;
%include statement;
%include token;
%include block_types;
%include statement_types;
%include token_types;
%include list;

/* program */

	return_flag = our_return_flag;
	conditions = our_conditions;

	if block_type = on_unit			/* on begin block */
	then do;
		begin_entered = "1"b;
		cur_block = father_block;
		cur_block -> block.prefix = conditions;
		call begin_parse;
	     end;

	else if block_type = begin_block
	then do;
		begin_entered = "1"b;

		pl1_stat_$cur_statement, p = create_statement (begin_statement, father_block, entry_ptr, our_conditions);
		if entry_ptr ^= null
		then call declare_label (father_block, p, entry_ptr, by_explicit_context);

		p -> statement.root, cur_block = create_block (block_type, father_block);
		cur_block -> block.prefix = conditions;

		call begin_parse;

/* to prevent a fault which might occur if the first statement in the begin block required the inserting of another statement,
   we make the first statement of the begin block be a null */

		q = create_statement (null_statement, cur_block, null, conditions);
	     end;

	else do;					/* internal or external procedure block */
		begin_entered = "0"b;
		cur_block = create_block (block_type, father_block);
		cur_block -> block.prefix = conditions;
		call process_entry (k + 1, procedure_statement, cur_block, entry_ptr, conditions);
	     end;

get_next_statement:
	call lex;					/* places current statement in token_list(3000); */

get_statement_type:
	conditions = cur_block -> block.prefix;

	k = 1;					/* first token */
	type = statement_type (k, label_ptr, conditions);
	go to action (action_index (type));

/*	***************** Statements requiring individual parsing procedures. ******** */

action (1):					/* begin statement	*/
	call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_block, return_flag);
	go to compound_parse_return;

action (10):
	call io_statement_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag, bit (binary (type, 9, 0)));
	goto compound_parse_return;


action (2):					/* declare statement */
	call declare_parse (k, cur_block, label_ptr);
	go to get_next_statement;
action (9):					/* default statement */
	call default_parse (k, cur_block, label_ptr);
	go to get_next_statement;

action (3):					/* do statement	*/
	call do_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_entered, return_flag, "0"b);
	go to compound_parse_return;

action (5):					/* if statement	*/
	call if_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag);
	if end_ptr = null
	then go to get_statement_type;		/* non-null if eof */
	go to end_proc;

action (6):					/* on statement	*/
	call on_parse (k, label_ptr, conditions, cur_block, end_ptr);
	go to compound_parse_return;

action (7):					/* proc statement	*/
	call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, internal_procedure, "0"b);

compound_parse_return:
	if end_ptr = null
	then go to get_next_statement;
	go to end_proc;

/*	***************** Statements which may be in error. ***************** */

action (8):					/* entry & return statements */
	if begin_entered
	then if type = binary (entry_statement, 9, 0)	/* entry statement */
	     then do;
		     call parse_error (411, null);	/* entry statement not allowed in begin block */
		     go to get_next_statement;
		end;
	     else if return_flag
	     then do;
		     call parse_error (412, null);	/* return statement not allowed in on-unit begin block */
		     go to get_next_statement;
		end;

	if type = binary (entry_statement, 9, 0)	/* entry statement */
	then do;
		k = k + 1;
		call process_entry (k, entry_statement, cur_block, label_ptr, conditions);
		go to get_next_statement;
	     end;

/*	***************** Statements all parsed in statement_parse.********************** */


action (0):
	call statement_parse (k, label_ptr, conditions, cur_block, type);
	go to get_next_statement;

/*	***************** Statement processed in line. ******************************* */

action (4):					/* end statement	*/
	k = k + 1;
	if t_table.type = identifier
	then do;
		end_ptr = token_list (k);		/* end <identifier>; */
		k = k + 1;
	     end;
	else end_ptr = null;
	if t_table.type ^= semi_colon
	then call parse_error (416, token_list (k));

end_proc:
	conditions = cur_block -> block.prefix;

	q = create_statement (end_statement, cur_block, null, conditions);
	q -> statement.root = create_operator (std_return, 0);

	if end_ptr ^= null				/* if "end <identifier>" closes block, */
	then do;					/* check for a match at beginning. */
		do p = entry_ptr repeat p -> list.element (1) while (p ^= null);
		     if end_ptr = p -> list.element (2)
		     then go to ck_labels;		/* match; ends us only */
		end;

		if type = binary (end_statement, 9)
		then call parse_error (377, null);

		call error (384, (cur_block -> block.main), null);

		his_end_ptr = end_ptr;		/* no match, ends this block and outer block(s), */
		entry_ptr = label_ptr;		/* any prefix labels get passed back up.  */
		return;
	     end;

ck_labels:
	his_end_ptr = null;				/* "end;" -- ends this block only, even if labels exist. */
	if label_ptr ^= null
	then do;
		call declare_label (cur_block, q, label_ptr, by_explicit_context);
		q -> statement.labels = label_ptr;
	     end;

	return;

/* parses begin stmt after "begin" */

begin_parse:
     proc;

	k = k + 1;
	if t_table.type = identifier & t_table.string = "options"
	then do;
		if pl1_stat_$check_ansi
		then call parse_error (355, token_list (k));
		k = k + 1;
		if t_table.type ^= left_parn
		then call parse_error (38, null);	/* bad syntax in options */
		else do;
			k = k + 1;
			if t_table.string = "non_quick"
			then do;
				cur_block -> block.why_nonquick.options_non_quick = "1"b;
				cur_block -> block.no_stack = "0"b;
				k = k + 1;
			     end;
			if t_table.type ^= right_parn
			then call parse_error (348, token_list (k));
						/* invalid option */
			k = k + 1;
		     end;
	     end;

	if t_table.type ^= semi_colon
	then call parse_error (410, null);		/* illegal syntax in begin block */
     end begin_parse;

     end procedure_parse;




		    process_entry.pl1               10/03/83  1725.6rew 10/03/83  1005.9       73134



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


/*	Modified on:	23 June 1975 by EEW  for new entry sequence
	Modified:	18 Feb 1977 by RAB for -check_ansi
	Modified:	30 Dec 1977 by RAB fo options(separate_static)	
	Modified: 15 Feb 1978 by PCK to implement options(main)
	Modified:	6 Apr 1978 by RAB to fix 1725
	Modified:	24 August 1978 by RAB to make check_ansi more informative
	Modified: 24 May 1979 by PCK to implement options(packed_decimal)
	Modified: 3 September 1981 by EBush for temporary extension of 
		max parameters per proceedure/entry to 512 */

process_entry: proc(k,stmnt_type,cblock,entries,conditions);

dcl	(cblock,entries,p,q,e,return,s,t) ptr;
dcl	(k,n,i) fixed bin(15);
dcl	(stmnt_type,st_type) bit(9) aligned;
dcl	(reducible,variable_arg) bit(1) aligned;
dcl	pl1_stat_$cur_statement ptr ext static;
dcl	pl1_stat_$unwind label external static;
dcl	pl1_stat_$root ptr ext static;
dcl	(pl1_stat_$check_ansi,pl1_stat_$options_packed_dec) bit(1) aligned ext static;
dcl	pl1_stat_$validate_proc ptr ext static;
dcl	cg_static_$support bit(1) aligned ext static;
dcl	cg_static_$separate_static bit(1) aligned ext static;
dcl	stack(513) ptr;
dcl	conditions bit(12) aligned;

dcl	(null,string) builtin;

%include parse;
%include token_list;
%include context_codes;
%include nodes;
%include token;
%include statement_types;
%include statement;
%include cross_reference;
%include symbol;
%include declare_type;
%include operator;
%include token_types;
%include op_codes;
%include list;
%include block;
%include block_types;






begin:
	if entries = null
	     then call parse_error(266,null);
	pl1_stat_$unwind=make_entry;			/* in case descriptor_parse finds any errors */
	reducible, variable_arg = "0"b;
	n=0;
	return=null;
	st_type = stmnt_type;
	if t_table.type ^= left_parn then go to options;
	if token_list(k+1)->token.type = right_parn
		then do;
			k=k+2;				/* this is a null arg list	*/
			go to options;
		     end;
circut:	k=k+1;
	if t_table.type ^= identifier then call print(35);
	n=n+1;
	if n>512 then call print(34);
	stack(n)=token_list(k);
	call context(stack(n),cblock,parameter_context);
	k=k+1;
	if t_table.type = comma then go to circut;
	if t_table.type ^= right_parn then call print(35);
	k=k+1;
options:
	if t_table.type = semi_colon then go to make_entry;
	if t_table.type ^= identifier then call print(36);
	if t_table.string = "returns"
		then do;
			k=k+1;
			if t_table.type ^= left_parn then call print(37);
			return = descriptor_parse(cblock,
				create_token(entries->list.element(2)->token.string||"[return value]",
						identifier),k);
			if return ^= null
			then do;
				if return->list.element(2) ^= null then call print(37);
				return = return->list.element(1);
				return->symbol.parameter = "1"b;
				n=n+1;
				stack(n) = return->symbol.token;
			     end;
			if t_table.type ^= right_parn then call print(37);
			k=k+1;
			go to options;
		     end;
	if t_table.string = "recursive" | t_table.string = "irreducible" | t_table.string = "irred"
		then do;
			if pl1_stat_$check_ansi
			then if t_table.string ^= "recursive"
			     then call print_warning(354,token_list(k));

			k=k+1;
			go to options;
		     end;
	if t_table.string = "reducible" | t_table.string = "red"
		then do;
			if pl1_stat_$check_ansi
			     then call print_warning(354,token_list(k));

			k=k+1;
			reducible="1"b;
			go to options;
		     end;
	if t_table.string = "options"
		then do;
			if pl1_stat_$check_ansi
			     then call print_warning(355,(token_list(k)));

			k=k+1;
			if t_table.type ^= left_parn then call print(38);
opt_circuit:
			k=k+1;
			if t_table.string = "validate"
				then do;
					if pl1_stat_$validate_proc ^= null then call print(39);
					k=k+1;
					if t_table.type ^= left_parn then go to bad;
					k=k+1;
					if t_table.type ^= identifier then call print(40);
					t = token_list(k);
					k=k+1;
					if t_table.type ^= right_parn then go to bad;
						s = create_symbol((pl1_stat_$root->block.son),t,by_explicit_context);
						s->symbol.cross_references = create_cross_reference();
						string(s->symbol.cross_references->cross_reference.source_id) = string(pl1_stat_$statement_id);
					s->symbol.entry,
					s->symbol.external,
					s->symbol.allocate = "1"b;
					pl1_stat_$validate_proc = s;
					k=k+1;
				     end;
			else if t_table.string = "rename"
				then do;
					if ^reserve$rename_parse(k) then go to make_entry;
				     end;
				else if t_table.string = "non_quick"
				      | t_table.string = "no_quick_blocks"
				     then do;
					cblock -> block.why_nonquick.options_non_quick = "1"b;
					cblock -> block.no_stack = "0"b;
					k = k + 1;
					end;
				     else if t_table.string = "support"
					then do;
					     cg_static_$support = "1"b;
					     k = k + 1;
					     end;
					else if t_table.string = "variable"
					     then do;
						variable_arg = "1"b;
						cblock -> block.why_nonquick.options_variable = "1"b;
						cblock -> block.no_stack = "0"b;
						k = k + 1;
						end;
					     else if t_table.string = "separate_static"
						then do;
						     cg_static_$separate_static = "1"b;
						     k = k + 1;
						     end;
						else if t_table.string = "main" | t_table.string = "packed_decimal"
						     then do;
							if stmnt_type^=procedure_statement
							     then do;
								call parse_error(368,token_list(k));
								go to make_entry;
								end;
							if cblock->block.block_type^=external_procedure
							     then do;
								call parse_error(369,token_list(k));
								go to make_entry;
								end;

							if t_table.string = "main"
							then cblock -> block.options_main = "1"b;
							else pl1_stat_$options_packed_dec = "1"b;

							k = k+1;
							end;
			if t_table.type = comma then go to opt_circuit;
			if t_table.type ^= right_parn then go to bad;
			k=k+1;
			go to options;
		     end;

bad:
	call parse_error(41,token_list(k));			/* invalid option	*/

/* create an entry statement for each entry label.  If returns(...) was given then
   each entry is a function, otherwize they are subroutines.	*/

make_entry:
	do e = entries repeat e->list.element(1) while(e^=null);
	     q=create_list(2);
	     q->list.element(2)=e->list.element(2);
	     if q->element(2)->node.type=reference_node
	     then do;
		call parse_error(270,null);
		return;
	     end;
	     pl1_stat_$cur_statement  ,
	     p=create_statement(st_type,cblock,q,conditions);
	     p->statement.root,q = create_operator(std_entry,n);
	     do i=1 to n;
		q->operand(i) = stack(i);
	     end;

/* Declare each name as an entry constant.				*/

	     q=create_symbol((cblock->block.father),(e->list.element(2)),by_explicit_context);
	     if variable_arg
	        then if return = null
		   then q -> symbol.variable_arg_list = "1"b;
		   else call parse_error(483,null);
	     if return ^= null
		then do;
			q->symbol.returns ="1"b;
			q->symbol.dcl_size = return;
			return->symbol.passed_as_arg = "1"b;
		     end;
	     q->symbol.entry,
	     q->symbol.constant="1"b;
	     if cblock->block.block_type ^= external_procedure then q->symbol.internal="1"b;
	     q->symbol.reducible=reducible;
	     q->symbol.equivalence = cblock;
	     q->symbol.initial = p;		/* set initial field to point to entry statement */
	     string(q->symbol.source_id) = string(pl1_stat_$statement_id);
	     cblock->block.number_of_entries = cblock->block.number_of_entries + 1;
	     st_type = entry_statement;
	end;

/* error message subroutine	*/

print: proc(m);

dcl	m fixed bin(15);

	call parse_error(m,null);
	go to make_entry;
	end;


print_warning: proc(m,p);

dcl	m fixed bin(15);
dcl	p ptr;

	call parse_error(m,p);

	end;


	end process_entry;




		    reference_parse.pl1             10/03/83  1725.6rew 10/03/83  1006.3       39897



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

reference_parse:
	procedure(index,cblock) returns(pointer);

/*	Re-written by:	Gabriel Chang for Version II
	Modified:		Richard A. Barnes to fix 1544
          Modified:		EBush for temporary extension of max
			args per call to 512 */

dcl	(i,j,k,m,n,index) fixed bin(15);
dcl	(arg,cblock,p,q,qual,arglist,op,sym) ptr;
dcl	s(512) ptr unaligned;
dcl	t(128) ptr unaligned;

dcl	(addr,null) builtin;

%include parse;
%include context_codes;
%include declare_type;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include symbol;
%include token;
%include token_list;
%include token_types;
			/*      */

begin:
	qual=null;
	k=index;
	if t_table.type = isub
		then do;
			index=index+1;
			return(token_list(k));
		     end;

reset:
	i,j=0;

next:
	if t_table.type ^= identifier then go to fail;
	q=token_list(k);
	k=k+1;

	if t_table.type = left_parn
		then do;
			if token_list(k+1)->t_table.type=right_parn
			then do;
				call make_reference;

				if i = 0
				then do;
					q -> reference.offset = create_list(0);
					k = k + 2;

					if t_table.type = arrow then goto test_ptr;
				end;

				goto entry_reference;
			end;

next_sub:
			k=k+1;
			i=i+1;

			if t_table.type=asterisk
			then do;
				if i > hbound(s,1)
				     then goto fail;
				s(i)=token_list(k);
				k=k+1;
			end;
			else	if ^atom() then goto fail;

			if t_table.type = comma then go to next_sub;
			if t_table.type = colon then go to next_sub;
			if t_table.type ^= right_parn then go to fail;
			k=k+1;
		     end;

	if t_table.type = period
		then do;
			k=k+1;
			j=j+1;
			if j > hbound(t,1)
			    then goto fail;
			t(j)=q;
			go to next;
		     end;

	if qual^=null | j+i ^= 0
		then call make_reference;

	if t_table.type = arrow
		then do;
test_ptr:
			k=k+1;
			qual=q;
			if q->node.type = token_node
				then if cblock^=null then call context(q,cblock,pointer_context);
			go to reset;
		     end;

entry_reference:
	do while(t_table.type=left_parn);
		i=0;

		if token_list(k+1)->t_table.type^=right_parn
		then do;
next_arg:
			k=k+1;
			i=i+1;

			if ^atom() then goto fail;

			if t_table.type=comma then goto next_arg;
			if t_table.type^=right_parn then goto fail;
		end;
		else	k=k+1;

		k=k+1;

		arglist=create_operator(std_arg_list,3);
		arglist->operand(2)=create_list(i);

		do j=1 to i;
			arglist->operand(2)->list.element(j)=s(i-j+1);
		end;

		op=create_operator(std_call,3);
		op->operand(2)=q;
		op->operand(3)=arglist;

		q=op;
	end;

	if t_table.type=arrow
	then	goto test_ptr;

ret1:
	index=k;
	return(q);

fail:
	return(null);


make_reference:	proc;

		q=create_reference(q);
		q->reference.qualifier=qual;
		if i^=0 then do;
				p=create_list(i);
				do m=1 to i;
					p->list.element(m) = s(i+1-m);
				end;
				q->reference.offset=p;
			   end;
		if j^=0 then do;
				p=create_list(j);
				do m=1 to j;
					p->list.element(m) = t(j+1-m);
				end;
				q->reference.length=p;
			     end;

		end make_reference;


atom:	proc() returns(bit(1)aligned);

dcl	save_index fixed bin(15);

	save_index=k;

	if i > hbound(s,1)
	     then goto fail;
	s(i) = expression_parse(k,cblock);
	if s(i)=null then return("0"b);

	if token_list(save_index)->token.type^=left_parn
	then;			else

	if s(i)->node.type=operator_node
	then;			else

	if s(i)->node.type=token_node
	&  s(i)->token.type^=identifier
	then;

	else do;
		sym=create_symbol(null,null,by_compiler);
		sym->symbol.temporary="1"b;

		op=create_operator(assign,2);
		op->operand(1)=sym->symbol.reference;
		op->operand(2)=s(i);

		if i > hbound(s,1)
		     then goto fail;
		s(i)=op;
	end;

	return("1"b);

	end atom;

	end reference_parse;




		    scan_token_table.pl1            10/03/83  1725.6rew 10/03/83  1006.3       18522



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


/* SCAN_TOKEN_TABLE - Program to check for duplicate declarations. */

/* Modified Dec 1978 by David Spector to fix bug 1784 */

scan_token_table:
     procedure;

/* automatic */

dcl	(p,q,q1,q2,q3) pointer;
dcl	i fixed bin;

/* builtins */

dcl	(hbound, lbound, null) builtin;

/* include files */

%include declare_type;
%include language_utility;
%include nodes;
%include pl1_token_hash_table;
%include symbol;
%include token;

/* program */

	do i = lbound (hash_table, 1) to hbound (hash_table, 1);

	     do p = hash_table (i) repeat (p -> token.next) while (p ^= null);

		do q1 = p->token.declaration repeat q1->symbol.multi_use while(q1^=null);
		     q3 = q1;
		     if q1->symbol.dcl_type = by_compiler then go to loop1;

		     do q2 = q1->symbol.multi_use repeat q2->symbol.multi_use while(q2^=null);
			if q2->symbol.dcl_type = by_compiler then go to loop2;
	
			if q1->symbol.block_node ^=
			   q2->symbol.block_node then go to loop2;
	
			if q1->node.type ^= q2->node.type		/* label node vs. symbol node */
			then do;
				if q1->node.type = symbol_node
				then q = q1;
				else q = q2;
				q3 = q;
				if q->symbol.level <= 1 then go to multi_dcl;	/* label vs. scalar or level 1 name */
				go to loop2;
			     end;
	
			if q1->symbol.father ^= q2->symbol.father then go to loop2;
			q3 = q1;
	
multi_dcl:
			if ^q3->symbol.param_desc
			then	call error_$no_text(76, q3 -> symbol.source_id, q3);
			go to next_token;
loop2:
		     end;

loop1:
		end;
	
next_token:
	     end;

	end;

	return;

     end /* scan_token_table */;




		    statement_parse.pl1             10/03/83  1725.6rew 10/03/83  1006.3       68931



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


statement_parse: proc(k,label_ptr,conditions,cblock,type);

/*	Rewritten:	28 September 1970 by P. Green for Version II 
	Modified: 15 Feb 1978 to implement options(main) and the stop statement
	Modified: 26 Dec 1979 by PCK to implement by name assignment */

dcl	(i,j,k,libe_no,n initial(0),type) fixed bin(15);
dcl	(addr,bit,fixed,null,binary) builtin;
dcl	conditions bit(12) aligned;
dcl	(p,q,r,s,cblock,label_ptr,stmnt) ptr;
dcl	stack(128) ptr;
dcl	op_code bit(9) aligned;

dcl	pl1_stat_$cur_statement ptr ext static;

dcl	action_index(0:37) fixed bin(15) int static initial(

		0,1,2,0,3,	10,0,10,10,10,	0,9,0,0,10,	10,4,10,5,0,
		10,6,0,10,0,	10,10,7,8,10,	8,11,0,10,10,	10,0,0);

%include parse;
%include block;
%include declare_type;
%include context_codes;
%include label;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include statement;
%include statement_types;
%include symbol;
%include token;
%include token_list;
%include token_types;
%include block_types;

/*	*/
begin:

make_statement:
	pl1_stat_$cur_statement  ,
	stmnt=create_statement(bit(fixed(type,9),9),cblock,label_ptr,conditions);
	if label_ptr^=null
	then	call declare_label(cblock,stmnt,label_ptr,by_explicit_context);
	label_ptr=null;
	go to action(action_index(type));

action(0):					/* unknown statement	*/
	return;	/* print(400) not needed - statement_type has already complained */

action(1):					/* allocate statement	*/
	q,stmnt->statement.root=create_operator(allot_var,2);
	k=k+1;
	if t_table.type ^= identifier then call print(454);
	q->operand(1)=token_list(k);

alloc_loop:
	k=k+1;
	if t_table.string = "set"
		then do;
			k=k+1;
			if q->operand(1)->node.type^=token_node then call print(450);
			if t_table.type ^= left_parn then call print(451);
			k=k+1;
			p = reference_parse(k,cblock);
			if p = null then call print(454);
			call context(p,cblock,pointer_context);
			r = create_reference((q->operand(1)));
			r->reference.qualifier = p;
			q->operand(1) = r;
			if t_table.type ^= right_parn then call print(454);
			go to alloc_loop;
		     end;
	if t_table.string ="in"
		then do;
			k=k+1;
			if q->operand(2) ^= null then call print(452);
			if t_table.type ^= left_parn then call print(453);
			k=k+1;
			q -> operand(2) = reference_parse(k,cblock);
			if q -> operand(2) = null then call print(454);
			call context((q->operand(2)),cblock,area_context);
			if t_table.type ^= right_parn then call print(454);
			go to alloc_loop;
		     end;
	if t_table.type = comma then go to make_statement;
	go to check_semi_colon;

action(2):					/* assignment statement	*/
	p = reference_parse(k,cblock);
	if p = null then call print(1);
	n=n+1;
	if n>128 then call print(5);
	stack(n)=p;
	if t_table.type = assignment then go to make_op;
	if t_table.type ^= comma then call print(1);
	k=k+1;
	go to action(2);

make_op:
	k=k+1;
	p = expression_parse(k,cblock);
	if p = null then call print(49);
	if t_table.type = comma then go to make_assign_by_name;
	stmnt->statement.root,q=create_operator(assign,2);
	if n=1 then do;
			q->operand(1)=stack(1);
			q->operand(2)=p;
			go to check_semi_colon;
		     end;
	if p->node.type = token_node
	then if p->token.type & is_constant
	     then do;
		s = p;
		q->operand(1) = stack(1);
		q->operand(2) = s;
		j = 2;
		go to make_assignment;
		end;

	s = create_symbol(null,null,by_compiler);
	s->symbol.temporary = "1"b;
	s = s->symbol.reference;
	s->reference.shared="0"b;
	s->reference.ref_count = n+1;
	q->operand(1) = s;
	q->operand(2) = p;
	j = 1;

make_assignment:
	do i = j to n;
	     stmnt = create_statement(assignment_statement,cblock,null,conditions);
	     stmnt->statement.root, q = create_operator(assign,2);
	     stmnt->statement.generated = "1"b;	/* to suppress the free_temps bit */
	     q->operand(1) = stack(i);
	     q->operand(2) = s;
	end;
	go to check_semi_colon;

make_assign_by_name:
	k=k+1;
	if t_table.string ^= "by"
	then call print(371);
	k=k+1;
	if t_table.string ^= "name"
	then call print(371);
	stmnt->statement.root,q=create_operator(assign_by_name,2);
	q->operand(2) = p;
	r = create_list(n);
	do i=1 to n;
	     r -> list.element(i) = stack(i);
	end;
	q->operand(1) = r;
	k=k+1;
	go to check_semi_colon;

action(3):					/* call statement	*/
	k=k+1;
	stmnt -> statement.root = reference_parse(k,cblock);
	if stmnt -> statement.root = null then call print(444);
	q = stmnt->statement.root;
	if q->node.type = token_node
	     then do;
		q = create_reference(q);
		q->reference.offset = create_list(0);
		stmnt->statement.root = q;
		end;
	     else if q->node.type = reference_node
		then if q->reference.offset = null
		     then q->reference.offset = create_list(0);
	go to check_semi_colon;

action(4):					/* free statement	*/
	k=k+1;
	q,stmnt->statement.root=create_operator(free_var,2);
	q -> operand(1) = reference_parse(k,cblock);
	if q -> operand(1) = null then call print(456);
	if t_table.string = "in"
		then do;
			k=k+1;
			if t_table.type ^= left_parn then call print(455);
			k=k+1;
			q -> operand(2) = reference_parse(k,cblock);
			if q -> operand(2) = null then call print(456);
			call context((q->operand(2)),cblock,area_context);
			if t_table.type ^= right_parn then call print(456);
			k=k+1;
		     end;
	if t_table.type = comma then go to make_statement;
	go to check_semi_colon;

action(5):					/* go to statement	*/
	if t_table.string ="goto"
	then k = k + 1;
	else do;
		k = k + 1;
		if t_table.string ^= "to" then call print(446);		/* syntax error in goto statement */
		k = k + 1;
	     end;
	q,stmnt->statement.root=create_operator(jump,1);
	q -> operand(1) = reference_parse(k,cblock);
	if q -> operand(1) = null then call print(446);
	go to check_semi_colon;

action(6):					/* null statement	*/
	if stmnt->statement.labels^=null
	then	stmnt->statement.root = create_operator(nop,0);
	go to check_semi_colon;

action(7):					/* return statement	*/
	k=k+1;
	if t_table.type = semi_colon
	     then do;
		q,stmnt->statement.root=create_operator(std_return,0);
		return;
	     end;
	if t_table.type ^= left_parn then call print(447);
	k=k+1;
	q,stmnt->statement.root=create_operator(return_value,1);
	q -> operand(1) = expression_parse(k,cblock);
	if q -> operand(1) = null then call print(447);
	if t_table.type ^= right_parn then call print(447);
	k=k+1;

check_semi_colon:
	if t_table.type^=semi_colon then call print(1);
	return;

action(8):					/* revert and signal statements */
	call on_parse$revert(k,stmnt,cblock);
	if t_table.type = comma
	then if type = fixed(revert_statement,15)	/* revert statements may mention more than one  	*/
	     then go to make_statement;		/* signal statements must have only one.	*/
	go to check_semi_colon;

action(9):					/* singleton else clause */
	call print(150);
	return;

action(10):					/* unimplemented statements */
	call print(460);
	return;

action(11):					/* stop statement */
	k=k+1;
	stmnt->statement.root=create_operator(stop,0);
	go to check_semi_colon;

print: proc(m);

dcl	m fixed bin(15);

	call parse_error(m,null);
	stmnt->statement.root=null;
	stmnt->statement.statement_type=null_statement;
	go to ret;
	end;

ret:
	end statement_parse;




		    statement_type.pl1              10/03/83  1725.6rew 10/03/83  1006.4       96777



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

statement_type:
	proc(index,label_ptr,conditions) returns(fixed bin(15));

/*	This function returns a bit string which identifies */
/*	to the caller the kind of pl/1 statement currently contained */
/*	in the token_list.						*/

/*	statement_type is called with index set such that token_list(index)	*/
/*	points to the first token of the statement to be identified.	*/
/*	this may be a label, condition prefix, etc.  index may be other than */
/*	one primarily when identifying the statement in an else clause.	*/
/*	when statement_type returns the value of index will be such that	*/
/*	token_list(index) points to the first token of the statement, i.e.	*/
/*	labels and condition prefixes will have been scanned.	*/

/*	"conditions" is a bit string set to record the settings */
/*	of the condition prefixes of the statement.			*/

/*	"label_ptr" is a pointer to the beginning of a node list containing the */
/*	labels(entry names) of the statement.				*/

/* Modified 770713 by PG to use pl1_stat_$level_0_colon flag */
/* Modified 770715 by RAB to fix bug in recognizing null stmts caused by above change */
/* Modified 15 Feb 1978 by PCK to implement the stop statement */

/* automatic */

dcl	(index,j,k,ksaved,paren_count,n) fixed bin(15);
dcl	(p,q,label_ptr) ptr;
dcl	(assumed_s_type,next_type) bit(9) aligned;
dcl	unknown_key_word char(12) aligned;
dcl	condition_value bit(1) aligned;
dcl	conditions bit(12) aligned;
dcl	unknown_condition char(16) aligned;

/* builtins */

dcl	(addr, fixed, hbound, lbound, mod, null, substr) builtin;

/* external static */

dcl	pl1_stat_$level_0_colon bit (1) aligned external static;

/* internal static */

dcl	key_word(0:33) char(12) aligned internal static
	initial (	"if",
		"go",
		"call",
		"do",
		"else",
		"dcl",
		"allocate",
		"proc",
		"return",
		"entry",
		"procedure",
		"free",
		"declare",
		"end",
		"goto",
		"get",
		"put",
		"begin",
		"on",
		"signal",
		"revert",
		"default",
		"format",
		"open",
		"close",
		"read",
		"write",
		"locate",
		"delete",
		"rewrite",
		"system",
		"dft",
		"alloc",
		"stop");

dcl	s_type(0:33) bit(9) internal static
	initial (	"000010011"b,	/* if */
		"000010010"b,	/* go to */
		"000000100"b,	/* call */
		"000001010"b,	/* do */
		"000001011"b,	/* else */
		"000000110"b,	/* dcl */
		"000000001"b,	/* allocate */
		"000011000"b,	/* proc */
		"000011011"b,	/* return */
		"000001101"b,	/* entry */
		"000011000"b,	/* procedure */
		"000010000"b,	/* free */
		"000000110"b,	/* declare */
		"000001100"b,	/* end */
		"000010010"b,	/* goto */
		"000010001"b,	/* get */
		"000011001"b,	/* put */
		"000000011"b,	/* begin */
		"000010110"b,	/* on */
		"000011110"b,	/* signal */
		"000011100"b,	/* revert */
		"000100100"b,	/* default */
		"000001111"b,	/* format */
		"000010111"b,	/* open */
		"000000101"b,	/* close */
		"000011010"b,	/* read */
		"000100011"b,	/* write */
		"000010100"b,	/* locate */
		"000001000"b,	/* delete */
		"000011101"b,	/* rewrite */
		"000100000"b,	/* system */
		"000100100"b,	/* default dft*/
		"000000001"b,	/* alloc */
		"000011111"b);	/* stop */

dcl	parn_not_allowed(0:33) bit(1) internal static aligned
	initial(	"0"b,"1"b,"1"b,"1"b,"0"b,"0"b,"1"b,"0"b,"0"b,"0"b,"0"b,
		"1"b,"0"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,
		"0"b,"0"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,"1"b,
		"0"b,"1"b,"1"b);

/* include files */

%include condition_name;
%include language_utility;
%include token_list;
%include list;
%include reference;
%include nodes;
%include token_types;
%include statement_types;

/* program */

	label_ptr = null;
	k, ksaved = index;

/*	The first construction to check for is the condition prefix list,	*/

	if ^pl1_stat_$level_0_colon			/* if statement has no colon, it can't have */
	then do;					/* prefixes or labels */

	     /* we still have to see that the stmt begins with an identifier or semi_colon */

	     if t_table.type ^= identifier
	     then if t_table.type = semi_colon
		then do;
		     index = k;
		     return(fixed(null_statement,15));
		     end;
		else call print(96,token_list(k));

	     go to not_label;
	     end;

	do while (t_table.type = left_parn);

another:
	     k = k + 1;
	     if t_table.type ^= identifier then call print(95,token_list(k));
	     if substr(t_table.string,1,2)="no"
	     then do;
		     condition_value="0"b;
		     unknown_condition=substr(t_table.string,3);
		end;
	     else do;
		     condition_value="1"b;
		     unknown_condition=t_table.string;
		end;

	     do j = lbound (condition_name, 1) to hbound (condition_name, 1) while (condition_name (j) ^= unknown_condition);
	     end;

	     if j > hbound (condition_name, 1)
	     then call print (45, token_list (k));

	     substr (conditions, mod (j, 10), 1) = condition_value;	/* j never equals 10 due to clever array */
	     k = k + 1;
	     if t_table.type = comma then go to another;
	     if t_table.type ^= right_parn then call print(43,token_list(k-1));
	     k = k + 1;
	     if t_table.type ^= colon then call print(44,null);
	     k = k + 1;
	end;

/* 	The next construct to check for is the label prefix list.	*/

check_label:
	ksaved = k;
	if t_table.type ^= identifier
		then if t_table.type = semi_colon
			then do;
				index=k;
				return(fixed(null_statement,15));
			end;
			else call print(96,token_list(k));
	q = token_list(k);
	k = k+1;
	if t_table.type = colon then go to label;
	if t_table.type ^= left_parn then go to not_label;
	k = k+1;
	n = 1;
	if t_table.type = plus
		then k = k+1;
		else if t_table.type = minus
			then do;
				n = -1;
				k = k+1;
			     end;
	if t_table.type ^= dec_integer then go to not_label;
	p = token_list(k);
	k = k+1;
	if t_table.type ^= right_parn then go to not_label;
	k = k+1;
	if t_table.type ^= colon then go to not_label;
	q = create_reference(q);
	q->reference.offset = create_list(1);
	if n = -1 then q->reference.offset->list.element(1) = create_token("-"||p->t_table.string,dec_integer);
		else q->reference.offset->list.element(1) = p;
label:
	k = k+1;
	p = create_list(2);
	p->list.element(2) = q;
	p->list.element(1) = label_ptr;
	label_ptr = p;
	go to check_label;

/*	ksaved points to the first token following the last recognized label.
	It is known to point to an identifier.	*/

not_label:
	k,index = ksaved;
	next_type=token_list(k+1)->t_table.type;
	if next_type=assignment then go to return_assignment;
	if next_type=arrow then go to return_assignment;
	if next_type=period then go to return_assignment;
	if next_type=comma then go to return_assignment;

/*	probably a key-word type statement */

	unknown_key_word=t_table.string;
	do j = 0 to hbound(key_word,1);
	if unknown_key_word=key_word(j)
	then do;
		assumed_s_type=s_type(j);
		if next_type^=left_parn then go to type_return;
		if parn_not_allowed(j) then go to return_assignment;
		go to verify_s_type;
	     end;
	end;

	go to return_assignment;

/*	when control reaches here we know that the identifier beginning */
/*	the statement is a key-word and that the token */
/*	following the identifier is a left-paren.  the following code */
/*	decides whether the statement is the assumed statement type */
/*	or the statement is an assignment statement. */

verify_s_type:
	k = k + 1;
	call skip_parens;

/*	at this point we have scanned to the right paren in this context:  */

/*		key-word(...)					*/

/*	the token following the right paren will distinguish a key word */
/*	statement from an assignment statement. 		*/

	k = k+1;
	if t_table.type=arrow then go to return_assignment;
	if t_table.type=period then go to return_assignment;
	if t_table.type = comma
	then if assumed_s_type = declare_statement
	     then if has_equal()
		then go to return_assignment;
		else go to type_return;
	     else go to return_assignment;
	if t_table.type=assignment
		then if assumed_s_type=if_statement
			then go to if_check;
			else go to return_assignment;
		else go to type_return;			/* it was key-word type after all */

/*	at this point we have scanned to the equal sign in this context:   */

/*		if( ... )=	*/

/*	the following code resolves the ambiguity of whether this is an */
/*	if statement or a subscripted assignment statement.    */

if_check:
	k = k+1;
	if t_table.type=semi_colon then go to return_assignment;
	if t_table.type=left_parn
	then do;
		paren_count=paren_count+1;
		go to if_check;
	     end;
	if t_table.type=right_parn
	then do;
		paren_count=paren_count-1;
		go to if_check;
	     end;
	if t_table.type=identifier
	then do;
		if paren_count ^= 0 then go to if_check;
		if t_table.string="then" then go to then_check;
	     end;

	go to if_check;

/*	having found a "then" at zero-reduction level we check the type */
/*	of the preceding token to distinguish the use of "then" as a */
/*	key-word to initiate a then-clause from the use of "then" as */
/*	an ordinary identifier. */

then_check:
	next_type = token_list(k-1)->t_table.type;
	if next_type=identifier then go to type_return;
	if next_type=right_parn then go to type_return;
	if next_type & is_constant then go to type_return;
	go to if_check;

return_assignment:
	assumed_s_type = assignment_statement;
type_return:
	return(fixed(assumed_s_type,15,0));


skip_parens:	proc;

	paren_count = 1;
	do while(paren_count ^= 0);
	k = k + 1;
	if t_table.type = semi_colon then call print(2,null);
	if t_table.type = left_parn then paren_count = paren_count + 1;
	if t_table.type = right_parn then paren_count = paren_count - 1;
	end;

	end;


has_equal:	proc returns(bit(1) aligned);

	do while("1"b);
	k = k + 1;
	if t_table.type = semi_colon then return("0"b);
	if t_table.type = assignment then return("1"b);
	if t_table.type = left_parn then call skip_parens;
	end;

	end;

/* subroutine to print a diagnostic and return to the caller of statement_type
   telling him that the statement is unknown.	*/

print: proc(m,t);

dcl	m fixed bin(15);
dcl	t ptr;

	call parse_error(m,t);
	assumed_s_type = unknown_statement;
	go to type_return;
	end print;

	end statement_type;




		    v2pl1.pl1                       10/15/84  1047.7rew 10/15/84  1024.0      399861



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


/*	PL/I COMMAND.

	This command has been rewritten in PL/I and observes Standard
	Service System conventions.  Modelled after the Fortran S.S.S.
	command written by John Gintell.

	Written by:	J.D.Mills
	On:		26 September 1969
	Modified on:	16 October 1969, by JDM.
	Modified on:	30 October 1969, by JDM for multiple tree segments.
	Modified on:	13 November 1969, by JDM to call hcs_ directly.
	Modified on:	1 December 1969, by JDM to treat pre-expanded source correctly.
	Modified on:	5 December 1969, by BLW to print compilation times
	Modified on:	20 December 1969, by JDM for greater speed.
	Modified on:	28 January 1970 by BLW to use cu_
	Modified on:	18 March 1970 by BLW to call optimizer
	Modified on:	15 April 1970 by BLW for table option
	Modified on:	 8 July 1970 by BLW for new expand_
	Modified on:	16 July 1970 by BLW for epilogue
	Modified on:	22 July 1970 by BLW for token_list in tree_
	Modified on:	6 August 1970 by PAG to eliminate varying strings in calls to hcs_ and
			to check length of entry name and the suffix
	Modified on:	26 August 1970 by PAG for Version II
	Modified on:	18 September 1970 by PAG to optionally call semantic_translator
	Modified on:	27 September 1970 by PG to compute percentages in $times entry
	Modified on:	11 January 1971 by BLW to remove intermediate seg creation
			and change to pl1_stat_
	Modified on:	29 January 1971 by BLW to be full PL/2 command
	Modified on:	5 February l97l by PG for lexical stuff.
	Modified on:	13 April 1971 by BLW to get ptr to error messages
	Modified on:	7 August 1971 by PG to combine context_processor into parse
	Modified on:	21 August 1971 by PG to combine lex and create_token
	Modified on:	21 October 1971 by BLW to call code_gen_
	Modified on:	15 January 1972 by BLW for profile option
	Modified on:	28 March 1972 by BLW for storage use summary
	Modified on:	27 June 1972 by PG for tssi_, msf_manager_, prepare_symbol_table, and the link option
	Modified on:	21 August 1972 by PG for find_include_file_
	Modified on:	20 December 1972 by RAB for 2 segment tree
	Modified on:	23 June 1975 by EEW to recognize arg: -separate_static
	Modified on:	4 December 1975 by EEW to fix cleanup problems (bug 1434)
	Modified on:	14 April 1976 by RAB to use get_line_length_
	Modified on:	22 June 1976 by RHS to support the "new" area package, with full "retry"
	Modified on:	29 July 1976 by RAB to not allow control args of the form "- xxxxxx"
	Modified on:	1 Dec 1976 by RAB for -long_profile
	Modified on:	16 Feb 1977 by RAB for -check_ansi
	Modified on:	April 1977 by RHS to use standard areas
	Modified on:	770504 by PG for EIS lex
	Modified on:	14 June 1977 by RAB for pl1_stat_$defined_list
	Modified on:	770712 by PG for pl1_severity_
	Modified on:	17 October 1977 by RAB to fix bug 1681
	Modified on:	26 September 1978 by PCK to flag unaligned decimal for Release 25, not accept -source and
			-symbol control arguments, require a dash to precede every control argument,
			and print the Release number of the compiler.
	Modified on:	10 Feb 1978 by RAB to clean up printing out of tree and xeq_tree info.
	Modified on:	24 May 1979 by PCK to implement options(packed_decimal)
	Modified on:	26 May 1979 by D. Spector to add -single_symbol_list (-ssl) control arg.
	Modified on:	3 October 1979 by PCK to allow pl1_version to be
			bound with bound_pl1_ and rename pl1_error_messages_
	Modified on:	20 November 1979 by PCK to initialize cg_static_$in_prologue and
			cg_static_$in_thunk to "0"b (part of the fix to bug 1858)
	Modified on:	4 March 1980 by M. N. Davidoff to clean up, fix bugs 1874, 1876, 1904, 1907 and allow
			-source, -symbols (suggestion 1892).
	Modified on:	20 March 1980 by PCK to implement by name assignment
			and increase the default error message width
	Modified on:	17 April 1980 by M. N. Davidoff to use pl1_error_messages_ for installed compiler.
	Modified on:	23 September 1980 by M. N. Davidoff to print message when invoked as an active function
			(suggestion 1957) and did some restructuring to make planned modifications easier.
	Modified on:	16 October 1980 by M. N. Davidoff to move call to tree_manager$init to after the command
			argument parsing loop (2024), implement -long, -no_check, -no_check_ansi, -no_list,
			-no_optimize, -no_profile, -no_separate_static, -no_table, -no_debug, -no_time (1943), and to
			make -table the default unless -no_table, -brief_table or -optimize were specified (1946).
	Modified on:	24 October 1980 by M. N. Davidoff to implement -prefix (1947).
	Modified on:	19 November 1981 by C. Hornig to allow long_profile with separate_static.
   	Modified on:	28 August 1984 by JAFalksen to use date_time_$format ("date_time",...
*/
/* format: style3,idind30 */
pl1exl:
v2pl1:
pl1:
     procedure options (variable);

/* automatic */

declare	argument_no		fixed bin;
declare	arg_count			fixed bin;
declare	arg_length		fixed bin (21);
declare	arg_ptr			ptr;
declare	bitcnt			fixed bin (24);
declare	1 blast_ca,
	  2 off			bit (1),
	  2 on			bit (1),
	  2 set			bit (1);
declare	blast_msg_len		fixed bin (21);
declare	blast_msg_ptr		ptr;
declare	1 ca			aligned,
	  2 no_optimize		bit (1),
	  2 optimize		bit (1),
	  2 no_table		bit (1),
	  2 brief_table		bit (1),
	  2 table			bit (1),
	  2 no_check		bit (1),
	  2 check			bit (1),
	  2 no_list		bit (1),
	  2 source		bit (1),
	  2 symbols		bit (1),
	  2 map			bit (1),
	  2 list			bit (1),
	  2 single_symbol_list	bit (1),
	  2 brief			bit (1),
	  2 long			bit (1),
	  2 severity		bit (1),
	  2 no_profile		bit (1),
	  2 profile		bit (1),
	  2 long_profile		bit (1),
	  2 no_separate_static	bit (1),
	  2 separate_static		bit (1),
	  2 no_check_ansi		bit (1),
	  2 check_ansi		bit (1),
	  2 no_time		bit (1),
	  2 time			bit (1),
	  2 no_debug		bit (1),
	  2 debug			bit (1),
	  2 debug_semant		bit (1),
	  2 debug_cg		bit (1),
	  2 no_cpdcls		bit (1),
	  2 cpdcls		bit (1),
	  2 no_link		bit (1),
	  2 link			bit (1),
	  2 prefix		bit (1);
declare	called_cg			bit (1) aligned;
declare	clock_time		fixed bin (71);
declare	code			fixed bin (35);
declare	component			fixed bin;
declare	entryname			char (32);
declare	fcb			ptr;
declare	i			fixed bin;
declare	in_cg			bit (1) aligned;
declare	len			fixed bin (21);
declare	list_hold			ptr;
declare	list_size			fixed bin (19);
declare	listname			char (32);
declare	object_hold		ptr;
declare	output_pt			ptr;
declare	pathname			char (168);
declare	pd_faults			fixed bin;
declare	1 prefix			aligned,
	  2 mask			bit (12),
	  2 conditions		bit (12);
declare	prefix_string_length	fixed bin (21);
declare	prefix_string_ptr		ptr;
declare	produce_listing		bit (1) aligned;
declare	source_seg		ptr;
declare	sourcename		char (32);
declare	symbols_on		bit (1) aligned;
declare	translation_failed		bit (1) aligned;
declare	wdirname			char (168);

/* based */

declare	arg_string		char (arg_length) based (arg_ptr);
declare	blast_msg			char (blast_msg_len) based (blast_msg_ptr);
declare	digit_pic			picture "9" based;
declare	prefix_string		char (prefix_string_length) based (prefix_string_ptr);
declare	source_string		char (len) based (source_seg);

/* builtin */

declare	(addrel, after, baseno, binary, char, clock, codeptr, convert, divide, index, hbound, lbound, length, ltrim,
	mod, null, reverse, rtrim, search, string, substr, verify)
				builtin;

/* condition */

declare	cleanup			condition;
declare	listing_overflow		condition;

/* internal static */

declare	HT_SP			char (2) internal static options (constant) initial ("	 ");
declare	HT_SP_COMMA		char (3) internal static options (constant) initial ("	 ,");
declare	blast_time		fixed bin (71) internal static initial (0);
declare	comptime			char (64)var internal static;
declare	error_messages		ptr internal static initial (null);
declare	my_name			char (3) internal static options (constant) initial ("pl1");
declare	ncpu			(0:7) fixed bin (71) internal static initial ((8) 0);
declare	npages			(0:7) fixed bin internal static;
declare	number_free_segs		fixed bin internal static;
declare	objectbc			fixed bin (24) internal static;
declare	phase_name		(7) char (9) internal static options (constant)
				initial ("setup", "parse", "semantics", "optimizer", "code gen", "listing",
				"cleanup");
declare	storage			(0:7) char (10) internal static initial ((8) (1)"         0");
declare	version			char (132) varying internal static;
declare	xeq_storage		(0:7) char (10) internal static initial ((8) (1)"         0");

/* external static */

declare	cg_static_$debug		bit (1) aligned external static;
declare	cg_static_$in_prologue	bit (1) aligned external static;
declare	cg_static_$in_thunk		bit (1) aligned external static;
declare	cg_static_$optimize		bit (1) aligned external static;
declare	cg_static_$separate_static	bit (1) aligned external static;
declare	cg_static_$stop_id		bit (27) external static;
declare	cg_static_$support		bit (1) aligned external static;
declare	error_table_$badopt		fixed bin (35) external static;
declare	error_table_$inconsistent	fixed bin (35) external static;
declare	error_table_$translation_failed
				fixed bin (35) external static;
declare	error_table_$zero_length_seg	fixed bin (35) external static;
declare	pl1_blast_$blast_message	char (64) varying external static;
declare	pl1_blast_$blast_on		bit (1) aligned external static;
declare	pl1_blast_$blast_time	fixed bin (71) external static;
declare	pl1_severity_		fixed bin (35) external static;
declare	pl1_stat_$abort_label	label external static;
declare	pl1_stat_$brief_error_mode	bit (1) aligned external static;
declare	pl1_stat_$by_name_free_list	ptr aligned external static;
declare	pl1_stat_$by_name_parts_free_list
				ptr aligned external static;
declare	pl1_stat_$by_name_parts_tree	ptr aligned external static;
declare	pl1_stat_$by_name_ref_list	ptr aligned external static;
declare	pl1_stat_$char_pos		fixed bin (21) external static;
declare	pl1_stat_$check_ansi	bit (1) aligned external static;
declare	pl1_stat_$compiler_invoked	bit (1) aligned external static;
declare	pl1_stat_$compiler_name	char (8) varying external static;
declare	pl1_stat_$constant_list	ptr external static;
declare	pl1_stat_$debug_semant	bit (1) aligned external static;
declare	pl1_stat_$defined_list	ptr external static;
declare	pl1_stat_$dummy_block	ptr external static;
declare	pl1_stat_$error_messages	ptr external static;
declare	pl1_stat_$error_width	fixed bin external static;
declare	pl1_stat_$generate_symtab	bit (1) aligned external static;
declare	pl1_stat_$greatest_severity	fixed bin external static;
declare	pl1_stat_$index		fixed bin external static;
declare	pl1_stat_$last_statement_id	bit (36) external static;
declare	pl1_stat_$line_count	fixed bin external static;
declare	pl1_stat_$list_ptr		ptr external static;
declare	pl1_stat_$listing_on	bit (1) aligned external static;
declare	pl1_stat_$max_list_size	fixed bin (21) external static;
declare	pl1_stat_$max_node_type	fixed bin external static;
declare	pl1_stat_$new_fortran_option	bit (1) aligned external static;
declare	pl1_stat_$node_name		(32) char (12) external static;
declare	pl1_stat_$node_size		(32) fixed bin external static;
declare	pl1_stat_$node_uses		(32) fixed bin external static;
declare	pl1_stat_$ok_list		ptr external static;
declare	pl1_stat_$optimize		bit (1) aligned external static;
declare	pl1_stat_$options		char (400) varying external static;
declare	pl1_stat_$options_packed_dec	bit (1) aligned external static;
declare	pl1_stat_$pathname		char (168) varying external static;
declare	pl1_stat_$phase		fixed bin external static;
declare	pl1_stat_$print_cp_dcl	bit (1) aligned external static;
declare	pl1_stat_$profile		bit (1) aligned external static;
declare	pl1_stat_$profile_length	fixed bin external static;
declare	pl1_stat_$root		ptr external static;
declare	pl1_stat_$seg_name		char (32) varying external static;
declare	pl1_stat_$severity_plateau	fixed bin external static;
declare	pl1_stat_$single_symbol_list	bit (1) aligned external static;
declare	pl1_stat_$stop_id		bit (27) external static;
declare	pl1_stat_$table		bit (1) aligned external static;
declare	pl1_stat_$temporary_list	ptr external static;
declare	pl1_stat_$tree_area_ptr	ptr external static;
declare	pl1_stat_$unaligned_dec	bit (1) aligned external static;
declare	pl1_stat_$use_old_area	bit (1) aligned external static;
declare	pl1_stat_$user_id		char (32) aligned external static;
declare	pl1_stat_$validate_proc	ptr external static;
declare	pl1_stat_$version		fixed bin external static;
declare	pl1_stat_$xeq_tree_area_ptr	ptr external static;
declare	pl1_version$pl1_release	char (3) varying external static;
declare	pl1_version$pl1_version	char (256) varying external static;

/* entry */

/* Parts of the compiler */

declare	code_gen_			entry (char (32) varying, char (3) varying, char (132) varying, ptr, ptr, ptr,
				ptr, ptr, ptr, fixed bin (71), fixed bin, bit (1) aligned, bit (1) aligned,
				bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned,
				bit (1) aligned, entry, entry, fixed bin (24), fixed bin, fixed bin (71),
				bit (1) aligned, ptr, bit (1) aligned, fixed bin, fixed bin (71), bit (1) aligned)
				;
declare	code_gen_$return_bit_count	entry (fixed bin (24), fixed bin, fixed bin (71), fixed bin, fixed bin (71));
declare	error_$finish		entry;
declare	lex$terminate_source	entry;
declare	optimizer			entry (ptr);
declare	parse			entry (ptr, char (*), 1 aligned, 2 bit (12), 2 bit (12));
declare	pl1_print$non_varying	entry (char (*) aligned, fixed bin);
declare	pl1_print$non_varying_nl	entry (char (*) aligned, fixed bin);
declare	pl1_print$varying_nl	entry (char (*) varying);
declare	pl1_signal_catcher		entry (ptr, char (*), ptr, ptr, bit (1) aligned);
declare	pl1_symbol_print		entry (ptr, bit (1) aligned, bit (1) aligned);
declare	prepare_symbol_table	entry (ptr);
declare	scan_token_table		entry;
declare	semantic_translator		entry;
declare	tree_manager$init		entry (label);
declare	tree_manager$truncate	entry;

/* Others */

declare	com_err_			entry options (variable);
declare	com_err_$suppress_name	entry options (variable);
declare	condition_		entry (char (*), entry);
declare	cu_$arg_count		entry (fixed bin, fixed bin (35));
declare	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
declare	cpu_time_and_paging_	entry (fixed bin, fixed bin (71), fixed bin);
declare	date_time_$format		entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
declare	debug			entry options (variable);
declare	expand_pathname_$add_suffix	entry (char (*), char (*), char (*), char (*), fixed bin (35));
declare	get_line_length_$switch	entry (ptr, fixed bin (35)) returns (fixed bin);
declare	get_group_id_		entry () returns (char (32));
declare	get_wdir_			entry () returns (char (168));
declare	hcs_$initiate_count		entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				fixed bin (35));
declare	hcs_$get_max_length_seg	entry (ptr, fixed bin (19), fixed bin (35));
declare	hcs_$make_ptr		entry (ptr, char (*), char (*), ptr, fixed bin (35));
declare	hcs_$terminate_noname	entry (ptr, fixed bin (35));
declare	hcs_$truncate_seg		entry (ptr, fixed bin (19), fixed bin (35));
declare	how_many_users		entry options (variable);
declare	ioa_			entry options (variable);
declare	ioa_$nnl			entry options (variable);
declare	msf_manager_$get_ptr	entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
declare	system_info_$installation_id	entry (char (*));
declare	tssi_$clean_up_file		entry (ptr, ptr);
declare	tssi_$clean_up_segment	entry (ptr);
declare	tssi_$finish_file		entry (ptr, fixed bin, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
declare	tssi_$finish_segment	entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
declare	tssi_$get_file		entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35));
declare	tssi_$get_segment		entry (char (*), char (*), ptr, ptr, fixed bin (35));

/* format: style3,inddcls */

%include condition_name;
%include area_structures;
%include pl1_version;

/* program */

	pl1_severity_ = 5;

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

	if pl1_stat_$compiler_invoked
	then do;
		call com_err_ (0, my_name, "The compiler has been invoked with a previous invocation suspended.");
		call com_err_ (error_table_$translation_failed, my_name,
		     "Attempt to invoke pl1 recursively. Use release first.");
		return;
	     end;

	call cpu_time_and_paging_ (npages (0), ncpu (0), pd_faults);

	do i = 1 to hbound (npages, 1);
	     npages (i) = -1;
	end;

	number_free_segs = 0;

	if error_messages = null
	then begin;
		declare	error_messages_name char (32);

		version = pl1_version$pl1_version;
		pl1_stat_$user_id = get_group_id_ ();

		if pl1_version$pl1_release = "EXL"
		then error_messages_name = "pl1exl_error_messages_";
		else error_messages_name = "pl1_error_messages_";

		call hcs_$make_ptr (codeptr (v2pl1), error_messages_name, "", error_messages, code);
		if code ^= 0
		then do;
			call com_err_ (code, my_name, "^a", error_messages_name);
			return;
		     end;
	     end;

	pl1_stat_$error_messages = error_messages;
	pl1_stat_$greatest_severity = 5;
	pl1_stat_$compiler_name = my_name;
	pl1_stat_$use_old_area = "0"b;

	do i = 1 to pl1_stat_$max_node_type;
	     pl1_stat_$node_uses (i) = 0;
	end;

	pl1_stat_$abort_label = abort_return;

	in_cg, called_cg, translation_failed, pl1_stat_$generate_symtab, pl1_stat_$last_statement_id,
	     pl1_stat_$new_fortran_option, pl1_stat_$unaligned_dec, pl1_stat_$options_packed_dec, cg_static_$support,
	     cg_static_$in_prologue, cg_static_$in_thunk = "0"b;

	pl1_stat_$error_width = get_line_length_$switch (null, code);

	pl1_stat_$validate_proc, pl1_stat_$constant_list, pl1_stat_$ok_list, pl1_stat_$dummy_block,
	     pl1_stat_$defined_list, pl1_stat_$by_name_free_list, pl1_stat_$by_name_parts_free_list,
	     pl1_stat_$by_name_parts_tree, pl1_stat_$by_name_ref_list, pl1_stat_$temporary_list = null;

	pl1_stat_$profile_length, pl1_stat_$index = 0;

	pl1_stat_$stop_id, cg_static_$stop_id = (27)"1"b;

	pl1_stat_$version = pl1_version;

/* Parse the command line arguments. */

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

	     if index (arg_string, "-") = 1
	     then if arg_string = "-no_optimize" | arg_string = "-not"
		then do;
			ca.no_optimize = "1"b;
			ca.optimize = "0"b;
		     end;

		else if arg_string = "-optimize" | arg_string = "-ot"
		then do;
			ca.no_optimize = "0"b;
			ca.optimize = "1"b;
		     end;

		else if arg_string = "-no_table" | arg_string = "-ntb"
		then do;
			ca.no_table = "1"b;
			ca.brief_table = "0"b;
			ca.table = "0"b;
		     end;

		else if arg_string = "-brief_table " | arg_string = "-bftb"
		then do;
			ca.no_table = "0"b;
			ca.brief_table = "1"b;
			ca.table = "0"b;
		     end;

		else if arg_string = "-table" | arg_string = "-tb"
		then do;
			ca.no_table = "0"b;
			ca.brief_table = "0"b;
			ca.table = "1"b;
		     end;

		else if arg_string = "-no_check" | arg_string = "-nck"
		then do;
			ca.no_check = "1"b;
			ca.check = "0"b;
		     end;

		else if arg_string = "-check" | arg_string = "-ck"
		then do;
			ca.no_check = "0"b;
			ca.check = "1"b;
		     end;

		else if arg_string = "-no_list" | arg_string = "-nls"
		then do;
			ca.no_list = "1"b;
			ca.source = "0"b;
			ca.symbols = "0"b;
			ca.map = "0"b;
			ca.list = "0"b;
			ca.single_symbol_list = "0"b;
		     end;

		else if arg_string = "-source" | arg_string = "-sc"
		then do;
			ca.no_list = "0"b;
			ca.source = "1"b;
		     end;

		else if arg_string = "-symbols" | arg_string = "-sb"
		then do;
			ca.no_list = "0"b;
			ca.symbols = "1"b;
		     end;

		else if arg_string = "-map"
		then do;
			ca.no_list = "0"b;
			ca.map = "1"b;
		     end;

		else if arg_string = "-list" | arg_string = "-ls"
		then do;
			ca.no_list = "0"b;
			ca.list = "1"b;
		     end;

		else if arg_string = "-single_symbol_list" | arg_string = "-ssl"
		then do;
			ca.no_list = "0"b;
			ca.single_symbol_list = "1"b;
		     end;

		else if arg_string = "-brief" | arg_string = "-bf"
		then do;
			ca.brief = "1"b;
			ca.long = "0"b;
		     end;

		else if arg_string = "-long" | arg_string = "-lg"
		then do;
			ca.brief = "0"b;
			ca.long = "1"b;
		     end;

		else if index (arg_string, "-severity") = 1
		then if ^parse_severity (arg_string, "-severity")
		     then return;
		     else ;

		else if index (arg_string, "-sv") = 1
		then if ^parse_severity (arg_string, "-sv")
		     then return;
		     else ;

		else if arg_string = "-no_profile" | arg_string = "-npf"
		then do;
			ca.no_profile = "1"b;
			ca.profile = "0"b;
			ca.long_profile = "0"b;
		     end;

		else if arg_string = "-profile" | arg_string = "-pf"
		then do;
			ca.no_profile = "0"b;
			ca.profile = "1"b;
			ca.long_profile = "0"b;
		     end;

		else if arg_string = "-long_profile" | arg_string = "-lpf"
		then do;
			ca.no_profile = "0"b;
			ca.profile = "0"b;
			ca.long_profile = "1"b;
		     end;

		else if arg_string = "-no_separate_static" | arg_string = "-nss"
		then do;
			ca.no_separate_static = "1"b;
			ca.separate_static = "0"b;
		     end;

		else if arg_string = "-separate_static" | arg_string = "-ss"
		then do;
			ca.no_separate_static = "0"b;
			ca.separate_static = "1"b;
		     end;

		else if arg_string = "-no_check_ansi"
		then do;
			ca.no_check_ansi = "1"b;
			ca.check_ansi = "0"b;
		     end;

		else if arg_string = "-check_ansi"
		then do;
			ca.no_check_ansi = "0"b;
			ca.check_ansi = "1"b;
		     end;

		else if arg_string = "-no_time" | arg_string = "-ntm"
		then do;
			ca.no_time = "1"b;
			ca.time = "0"b;
		     end;

		else if arg_string = "-time" | arg_string = "-tm"
		then do;
			ca.no_time = "0"b;
			ca.time = "1"b;
		     end;

		else if arg_string = "-no_debug" | arg_string = "-ndb"
		then do;
			ca.no_debug = "1"b;
			ca.debug = "0"b;
			ca.debug_semant = "0"b;
			ca.debug_cg = "0"b;
		     end;

		else if arg_string = "-debug" | arg_string = "-db"
		then do;
			ca.no_debug = "0"b;
			ca.debug = "1"b;
		     end;

		else if arg_string = "-debug_semant" | arg_string = "-dbse"
		then do;
			ca.no_debug = "0"b;
			ca.debug_semant = "1"b;
		     end;

		else if arg_string = "-debug_cg" | arg_string = "-dbcg"
		then do;
			ca.no_debug = "0"b;
			ca.debug_cg = "1"b;
		     end;

		else if arg_string = "-no_cpdcls"
		then do;
			ca.no_cpdcls = "1"b;
			ca.cpdcls = "0"b;
		     end;

		else if arg_string = "-cpdcls"
		then do;
			ca.no_cpdcls = "0"b;
			ca.cpdcls = "1"b;
		     end;

		else if arg_string = "-no_link" | arg_string = "-nlk"
		then do;
			ca.no_link = "1"b;
			ca.link = "0"b;
		     end;

		else if arg_string = "-link" | arg_string = "-lk"
		then do;
			ca.no_link = "0"b;
			ca.link = "1"b;
		     end;

		else if arg_string = "-prefix"
		then do;
			i = i + 1;
			if i > arg_count
			then do;
				call com_err_ (0, my_name, "Missing prefix string after -prefix.");
				return;
			     end;

			call cu_$arg_ptr (i, prefix_string_ptr, prefix_string_length, code);
			if code ^= 0
			then do;
				call com_err_ (code, my_name, "Argument ^d.", i);
				return;
			     end;

			ca.prefix = "1"b;
		     end;

		else do;
			call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
			return;
		     end;

	     else do;
		     argument_no = argument_no + 1;

		     if argument_no = 1
		     then do;
			     call expand_pathname_$add_suffix (arg_string, my_name, pathname, sourcename, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, my_name, "^a", arg_string);
				     return;
				end;
			end;
		end;
	end;

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

/* Apply defaults. */

	if ^ca.no_table & ^ca.brief_table & ^ca.optimize
	then ca.table = "1"b;

/* We now know what options were specified. */

	pl1_stat_$options = "";

	pl1_stat_$optimize, cg_static_$optimize = ca.optimize;
	if ca.optimize
	then pl1_stat_$options = pl1_stat_$options || " optimize";

	if ca.brief_table
	then pl1_stat_$options = pl1_stat_$options || " brief_table";

	pl1_stat_$table = ca.table;
	if ca.table
	then pl1_stat_$options = pl1_stat_$options || " table";

	if ca.check
	then pl1_stat_$options = pl1_stat_$options || " check";

	if ca.source
	then pl1_stat_$options = pl1_stat_$options || " source";

	if ca.symbols
	then pl1_stat_$options = pl1_stat_$options || " symbols";

	if ca.map
	then pl1_stat_$options = pl1_stat_$options || " map";

	if ca.list
	then pl1_stat_$options = pl1_stat_$options || " list";

	pl1_stat_$single_symbol_list = ca.single_symbol_list;
	if ca.single_symbol_list
	then pl1_stat_$options = pl1_stat_$options || " single_symbol_list";

	symbols_on = ca.symbols | ca.map | ca.list | ca.single_symbol_list;
	produce_listing, pl1_stat_$listing_on = ca.source | symbols_on;

	pl1_stat_$brief_error_mode = ca.brief;

	if ca.severity
	then pl1_stat_$options = pl1_stat_$options || " severity" || convert (digit_pic, pl1_stat_$severity_plateau);
	else pl1_stat_$severity_plateau = 1;

	if ca.profile
	then pl1_stat_$options = pl1_stat_$options || " profile";

	if ca.long_profile
	then pl1_stat_$options = pl1_stat_$options || " long_profile";

	pl1_stat_$profile = ca.profile | ca.long_profile;

	cg_static_$separate_static = ca.separate_static;
	if ca.separate_static
	then pl1_stat_$options = pl1_stat_$options || " separate_static";

	pl1_stat_$check_ansi = ca.check_ansi;

	pl1_stat_$print_cp_dcl = ca.cpdcls;
	if ca.cpdcls
	then pl1_stat_$options = pl1_stat_$options || " cpdcls";

	cg_static_$debug = ca.debug | ca.debug_semant | ca.debug_cg;
	pl1_stat_$debug_semant = ca.debug_semant;

	if ca.link
	then pl1_stat_$options = pl1_stat_$options || " link";

	prefix = ""b;
	if ca.prefix
	then if ^parse_prefix (prefix_string)
	     then return;

	pl1_stat_$options = ltrim (pl1_stat_$options);

	entryname = reverse (after (reverse (rtrim (sourcename)), reverse (".pl1")));

	if index (reverse (rtrim (entryname)), reverse (".ex")) = 1
	then entryname = reverse (after (reverse (rtrim (entryname)), reverse (".ex")));

	pl1_stat_$pathname = rtrim (pathname) || ">" || rtrim (sourcename);
	pl1_stat_$seg_name = rtrim (entryname);

	call hcs_$initiate_count (pathname, sourcename, "", bitcnt, 1, source_seg, code);
	if source_seg = null
	then do;
		call com_err_ (code, my_name, "^a^[>^]^a", pathname, pathname ^= ">", sourcename);
		return;
	     end;

	if bitcnt = 0
	then do;
		call com_err_ (error_table_$zero_length_seg, my_name, "^a^[>^]^a", pathname, pathname ^= ">",
		     sourcename);
		call hcs_$terminate_noname (source_seg, code);
		return;
	     end;

	len = divide (bitcnt + 8, 9, 21);

	if pl1_blast_$blast_on
	then if pl1_blast_$blast_time > blast_time
	     then do;
		     call ioa_ ("^a", pl1_blast_$blast_message);
		     blast_time = clock ();
		end;

	call ioa_ ("PL/I ^a", pl1_version$pl1_release);

	wdirname = get_wdir_ ();
	clock_time = clock ();
	comptime = date_time_$format ("date_time", clock_time, "", "");

	list_hold = null;
	object_hold = null;

	on cleanup
	     begin;
		if ^cg_static_$debug
		then call truncate;

		pl1_stat_$compiler_invoked = "0"b;
	     end;

	if produce_listing
	then begin;
		declare	installation_id	char (32);

		component = 0;
		listname = rtrim (entryname) || ".list";

		call tssi_$get_file (wdirname, listname, pl1_stat_$list_ptr, list_hold, fcb, code);
		if pl1_stat_$list_ptr = null
		then do;
			call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
			call hcs_$terminate_noname (source_seg, code);
			return;
		     end;

		call hcs_$get_max_length_seg (pl1_stat_$list_ptr, list_size, code);
		if code ^= 0
		then do;
			call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
			call hcs_$terminate_noname (source_seg, code);
			return;
		     end;

		pl1_stat_$max_list_size = 4 * list_size;
		pl1_stat_$char_pos = 1;

		call pl1_print$non_varying_nl ("	COMPILATION LISTING OF SEGMENT " || rtrim (entryname), 0);
		call pl1_print$non_varying_nl ("	Compiled by: " || pl1_version$pl1_version, 0);

		call system_info_$installation_id (installation_id);
		call pl1_print$non_varying_nl ("	Compiled at: " || installation_id, 0);
		call pl1_print$non_varying_nl ("	Compiled on: " || comptime, 0);

		if length (pl1_stat_$options) > 0
		then do;
			call pl1_print$non_varying ("	    Options: ", 0);
			call pl1_print$varying_nl (pl1_stat_$options);
		     end;

		call pl1_print$non_varying_nl ("", 0);
	     end;

	if produce_listing
	then on listing_overflow
		begin;
		     declare   component_bit_count fixed binary (24);

		     component = component + 1;

		     call msf_manager_$get_ptr (fcb, component, "1"b /* create */, pl1_stat_$list_ptr,
			component_bit_count, code);

		     if pl1_stat_$list_ptr ^= null
		     then call hcs_$get_max_length_seg (pl1_stat_$list_ptr, list_size, code);

		     if pl1_stat_$list_ptr = null | code ^= 0
		     then do;
			     call com_err_ (code, my_name, "Component ^d of ^a^[>^]^a", component, wdirname,
				wdirname ^= ">", listname);

			     if in_cg
			     then call code_gen_$return_bit_count (objectbc, npages (5), ncpu (5), npages (6),
				     ncpu (6));

			     translation_failed = "1"b;
			     goto close_list;
			end;

		     pl1_stat_$max_list_size = 4 * list_size;
		     pl1_stat_$char_pos = 1;
		end;

/* Call the phases of pl1. */

	call tree_manager$init (pl1_stat_$abort_label);

	pl1_stat_$phase = 1;
	pl1_severity_, pl1_stat_$greatest_severity = 0;
	pl1_stat_$compiler_invoked = "1"b;

	call condition_ ("any_other", pl1_signal_catcher);

	call cpu_time_and_paging_ (npages (1), ncpu (1), pd_faults);

	call parse (pl1_stat_$root, source_string, prefix);

	call cpu_time_and_paging_ (npages (2), ncpu (2), pd_faults);
	call set_storage_usage (storage (2), xeq_storage (2));

	if ca.debug_semant
	then do;
		call ioa_$nnl ("Beginning semantic translator.^/debug: ");
		call debug;
	     end;

	pl1_stat_$phase = 2;
	call semantic_translator;
	call scan_token_table;

	call cpu_time_and_paging_ (npages (3), ncpu (3), pd_faults);
	call set_storage_usage (storage (3), xeq_storage (3));

/**** Removed 2/82 BIM, its 3 releases later!
	if pl1_stat_$unaligned_dec & ^pl1_stat_$options_packed_dec
	then call com_err_ (0, my_name, "Warning: The implementation of unaligned decimal variables has changed.");
*****/

	if ^ca.check
	then call generate_code (translation_failed);

continue_from_abort:
	if translation_failed
	then call com_err_ (error_table_$translation_failed, my_name, "^a", sourcename);

	if ^called_cg
	then do;
		call cpu_time_and_paging_ (npages (5), ncpu (5), pd_faults);
		npages (6) = npages (5);
		ncpu (6) = ncpu (5);
	     end;

	if produce_listing
	then do;
		if ^called_cg
		then do;
			if symbols_on
			then call pl1_symbol_print (pl1_stat_$root, pl1_stat_$print_cp_dcl,
				ca.check | translation_failed | pl1_stat_$greatest_severity >= 3);

			call pl1_print$non_varying_nl ("", 0);

			if pl1_stat_$greatest_severity > 0
			then call error_$finish;
		     end;

close_list:
		call tssi_$finish_file (fcb, component, 9 * pl1_stat_$char_pos - 9, "101"b, list_hold, code);
		if code ^= 0
		then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
	     end;

	if ^ca.check & ^translation_failed
	then do;
		call hcs_$truncate_seg (output_pt, divide (objectbc + 35, 36, 19), code);
		if code ^= 0
		then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", entryname);

		call tssi_$finish_segment (output_pt, objectbc, "110"b, object_hold, code);
		if code ^= 0
		then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", entryname);
	     end;

	call cpu_time_and_paging_ (npages (7), ncpu (7), pd_faults);
	call set_storage_usage (storage (5), xeq_storage (5));

	storage (6), storage (7) = storage (5);
	xeq_storage (6), xeq_storage (7) = xeq_storage (5);

	if ^cg_static_$debug
	then call truncate;

	pl1_severity_ = pl1_stat_$greatest_severity;

	pl1_stat_$compiler_invoked = "0"b;

	if ca.time
	then call print_times;

	return;

abort_return:
	call com_err_ (0, my_name, "An unrecoverable error has occurred.");
	translation_failed = "1"b;
	goto continue_from_abort;

times:
     entry options (variable);

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

	if arg_count ^= 0
	then do;
		call com_err_$suppress_name (0, my_name, "Usage: ^a$times", my_name);
		return;
	     end;

	call print_times;

	return;

clean_up:
     entry options (variable);

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

	if arg_count ^= 0
	then do;
		call com_err_$suppress_name (0, my_name, "Usage: ^a$clean_up", my_name);
		return;
	     end;

	object_hold = null;
	list_hold = null;

	call truncate;
	pl1_stat_$compiler_invoked = "0"b;

	return;

blast:
     entry options (variable);

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

	string (blast_ca) = ""b;
	argument_no = 0;
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, my_name, "Argument ^d.", i);
		     return;
		end;

	     if arg_string = "-on"
	     then do;
		     blast_ca.on = "1"b;
		     blast_ca.off = "0"b;
		end;

	     else if arg_string = "-off"
	     then do;
		     blast_ca.on = "0"b;
		     blast_ca.off = "1"b;
		end;

	     else if arg_string = "-set"
	     then do;
		     i = i + 1;
		     if i > arg_count
		     then do;
			     call com_err_ (0, my_name, "Missing blast message after -set.");
			     return;
			end;

		     call cu_$arg_ptr (i, blast_msg_ptr, blast_msg_len, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, my_name, "Argument ^d.", i);
			     return;
			end;

		     blast_ca.set = "1"b;
		end;

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

	     else argument_no = argument_no + 1;
	end;

	if argument_no ^= 0 | string (blast_ca) = ""b
	then do;
		call com_err_$suppress_name (0, my_name, "Usage: ^a$blast -control_args", my_name);
		return;
	     end;

	if blast_ca.set & (blast_ca.on | blast_ca.off)
	then do;
		call com_err_ (error_table_$inconsistent, my_name, "-set and -^[on^;off^]", blast_ca.on);
		return;
	     end;

	if blast_ca.on
	then pl1_blast_$blast_on = "1"b;

	else if blast_ca.off
	then pl1_blast_$blast_on = "0"b;

	else if blast_ca.set
	then do;
		pl1_blast_$blast_on = "0"b;
		pl1_blast_$blast_message = blast_msg;
		pl1_blast_$blast_time = clock ();
		pl1_blast_$blast_on = "1"b;
	     end;

	call ioa_ ("Accepted.");

	return;

parse_severity:
     procedure (arg_string, prefix) returns (bit (1) aligned);

	declare	arg_string	char (*);
	declare	prefix		char (*);

	declare	severity		fixed bin;

	if length (rtrim (arg_string)) = length (prefix) + 1
	then severity = index ("1234", substr (arg_string, length (prefix) + 1, 1));
	else severity = 0;

	if severity = 0
	then do;
		call com_err_ (0, my_name, "Invalid severity level. ^a", arg_string);
		return ("0"b);
	     end;

	ca.severity = "1"b;
	pl1_stat_$severity_plateau = severity;

	return ("1"b);
     end parse_severity;

parse_prefix:
     procedure (prefix_string) returns (bit (1) aligned);

	declare	prefix_string	char (*);

	declare	scan_position	fixed bin (21);

	scan_position = verify (prefix_string, HT_SP);
	if scan_position = 0
	then return ("1"b);

	pl1_stat_$options = pl1_stat_$options || " prefix(";

	if ^parse_condition_name ()
	then return ("0"b);
	do while (scan_position <= length (prefix_string));
	     if substr (prefix_string, scan_position, 1) ^= ","
	     then do;
		     call com_err_ (0, my_name, "Missing comma between condition names. ^a", prefix_string);
		     return ("0"b);
		end;

	     scan_position = scan_position + 1;

	     if ^parse_condition_name ()
	     then return ("0"b);
	end;

	pl1_stat_$options = pl1_stat_$options || ")";

	return ("1"b);

parse_condition_name:
     procedure returns (bit (1) aligned);

	declare	enabled		bit (1) aligned;
	declare	i		fixed bin;
	declare	token_length	fixed bin (21);
	declare	token_start	fixed bin (21);

	call skip_white_space;

	token_length = search (substr (prefix_string, scan_position), HT_SP_COMMA) - 1;
	if token_length < 0
	then token_length = length (substr (prefix_string, scan_position));

	if token_length = 0
	then do;
		call com_err_ (0, my_name, "Missing condition name. ^a", prefix_string);
		return ("0"b);
	     end;

	token_start = scan_position;
	scan_position = scan_position + token_length;

	enabled = index (substr (prefix_string, token_start, token_length), "no") ^= 1;
	if ^enabled
	then do;
		token_start = token_start + length ("no");
		token_length = token_length - length ("no");
	     end;

	do i = lbound (condition_name, 1) to hbound (condition_name, 1)
	     while (condition_name (i) ^= substr (prefix_string, token_start, token_length));
	end;

	if i > hbound (condition_name, 1)
	then do;
		call com_err_ (0, my_name, "Invalid condition name. ^[no^]^a", ^enabled,
		     substr (prefix_string, token_start, token_length));
		return ("0"b);
	     end;

/* The variable i never equals 10.  This takes advantage of the condition_name
   array encoding.  This is the same algorithm that statement_type uses.  The
   long names and short names of the conditions are stored in the same array.
   The indices of the long name and the short name differ by 10.  The size
   condition has the same long name and short name. */

	i = mod (i, 10);

	if substr (prefix.mask, i, 1)
	then if substr (prefix.conditions, i, 1) ^= enabled
	     then do;
		     call com_err_ (0, my_name,
			"A condition may not be enabled and disabled in the prefix string. ^a", condition_name (i));
		     return ("0"b);
		end;
	     else ;
	else do;
		substr (prefix.mask, i, 1) = "1"b;
		substr (prefix.conditions, i, 1) = enabled;

		if substr (pl1_stat_$options, length (pl1_stat_$options)) ^= "("
		then pl1_stat_$options = pl1_stat_$options || ",";

		if ^enabled
		then pl1_stat_$options = pl1_stat_$options || "no";

		pl1_stat_$options = pl1_stat_$options || rtrim (condition_name (i));
	     end;

	call skip_white_space;

	return ("1"b);

skip_white_space:
     procedure;

	declare	scan_length	fixed bin (21);

	scan_length = verify (substr (prefix_string, scan_position), HT_SP) - 1;
	if scan_length < 0
	then scan_length = length (substr (prefix_string, scan_position));

	scan_position = scan_position + scan_length;
     end skip_white_space;

     end parse_condition_name;

     end parse_prefix;

generate_code:
     procedure (translation_failed);

	declare	translation_failed	bit (1) aligned;

	translation_failed = "0"b;

	if pl1_stat_$greatest_severity >= 3
	then do;
		call com_err_ (0, my_name, "An error of severity ^d has occurred.", pl1_stat_$greatest_severity);

		if ca.debug_cg
		then do;
			call ioa_$nnl ("debug for -debug_cg: ");
			call debug;
		     end;

		translation_failed = "1"b;
		return;
	     end;

	if pl1_stat_$table | pl1_stat_$generate_symtab
	then do;
		pl1_stat_$phase = 3;
		call prepare_symbol_table (pl1_stat_$root);
	     end;

	if ca.optimize
	then do;
		pl1_stat_$phase = 4;
		call optimizer (pl1_stat_$root);
	     end;

	call cpu_time_and_paging_ (npages (4), ncpu (4), pd_faults);
	call set_storage_usage (storage (4), xeq_storage (4));

	call tssi_$get_segment (wdirname, entryname, output_pt, object_hold, code);
	if output_pt = null
	then do;
		call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", entryname);
		translation_failed = "1"b;
		return;
	     end;

	if baseno (output_pt) = baseno (source_seg)
	then do;
		call com_err_ (0, my_name,
		     "The source segment is the same as the object segment. It has been truncated. ^a^[>^]^a",
		     pathname, pathname ^= ">", sourcename);
		translation_failed = "1"b;
		return;
	     end;

	if ^ca.profile & ^ca.long_profile
	then pl1_stat_$profile_length = 0;

	if ca.debug_cg
	then do;
		call ioa_$nnl ("Beginning code generator.^/debug: ");
		call debug;
	     end;

	in_cg = "1"b;
	pl1_stat_$phase = 5;

	call code_gen_ (pl1_stat_$seg_name, (my_name), version, pl1_stat_$root, pl1_stat_$validate_proc,
	     pl1_stat_$temporary_list, pl1_stat_$constant_list, pl1_stat_$ok_list, output_pt, clock_time,
	     pl1_stat_$profile_length, produce_listing, symbols_on, pl1_stat_$print_cp_dcl, ca.map, ca.list,
	     pl1_stat_$table, pl1_stat_$generate_symtab, pl1_symbol_print, error_$finish, objectbc, npages (5),
	     ncpu (5), ca.link, pl1_stat_$dummy_block, ca.brief_table, npages (6), ncpu (6), ca.long_profile);

	in_cg = "0"b;
	called_cg = "1"b;
     end generate_code;

print_times:
     procedure;

	declare	need_nl		bit (1) aligned;
	declare	tx		float bin;
	declare	ty		float bin;

	ty = -1e0;
	do i = hbound (ncpu, 1) to 1 by -1 while (ty < 0e0);
	     ty = ncpu (i) - ncpu (0);
	end;

	if ty <= 0e0
	then do;
		call com_err_ (0, my_name, "No times available.");
		return;
	     end;

	call ioa_ ("^/Segment ^a (^d lines) was compiled by ^a on ^a", pl1_stat_$seg_name, pl1_stat_$line_count,
	     my_name, comptime);

	call how_many_users;

	call ioa_ ("^/Phase          CPU    %   Pages      Tree     Xeq_tree");

	do i = 1 to hbound (npages, 1);
	     if npages (i) < 0
	     then do;
		     ncpu (i) = ncpu (i - 1);
		     npages (i) = npages (i - 1);
		     storage (i) = storage (i - 1);
		     xeq_storage (i) = xeq_storage (i - 1);
		end;

	     tx = ncpu (i) - ncpu (i - 1);
	     call ioa_ ("^9a^9.3f^6.1f^6d ^10a ^10a", phase_name (i), tx / 1.0e6, 1.0e2 * tx / ty,
		npages (i) - npages (i - 1), storage (i), xeq_storage (i));
	end;

	call ioa_ ("TOTAL    ^9.3f      ^6d", ty / 1.0e6, npages (7) - npages (0));

	call ioa_ ("^/Summary of node usage in ^d free segments^/", number_free_segs);
	call ioa_ ((2)"NODE TYPE   NUMBER  SIZE   TOTAL^8x");

	need_nl = "0"b;
	do i = 1 to pl1_stat_$max_node_type;
	     if pl1_stat_$node_uses (i) ^= 0
	     then do;
		     call ioa_$nnl ("^12a^6d^6d^8d^[^/^;^8x^]", pl1_stat_$node_name (i), pl1_stat_$node_uses (i),
			pl1_stat_$node_size (i), pl1_stat_$node_uses (i) * pl1_stat_$node_size (i), need_nl);
		     need_nl = ^need_nl;
		end;
	end;

	call ioa_ ("^[^/^]", need_nl);
     end print_times;

truncate:
     procedure;

	call lex$terminate_source;
	call tree_manager$truncate;

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

	if list_hold ^= null
	then call tssi_$clean_up_file (fcb, list_hold);
     end truncate;

set_storage_usage:
     procedure (tree_used, xeq_tree_used);

	declare	tree_used		char (*);
	declare	xeq_tree_used	char (*);

	declare	n		fixed bin;

	tree_used = char (binary (pl1_stat_$tree_area_ptr -> area_header.next_virgin, 18), 10);

	number_free_segs = count_components (pl1_stat_$tree_area_ptr);
	if number_free_segs > 1
	then substr (tree_used, 1, 3) = "(" || convert (digit_pic, number_free_segs) || ")";

	xeq_tree_used = char (binary (pl1_stat_$xeq_tree_area_ptr -> area_header.next_virgin, 18), 10);

	n = count_components (pl1_stat_$xeq_tree_area_ptr);
	if n > 1
	then substr (xeq_tree_used, 1, 3) = "(" || convert (digit_pic, n) || ")";

	number_free_segs = number_free_segs + n;

	return;

count_components:
     procedure (areap) returns (fixed bin);

	declare	areap		ptr;

	declare	p		ptr;
	declare	i		fixed bin;

	i = 0;
	do p = areap repeat addrel (p, p -> area_header.extend_info) -> extend_block.next_area while (p ^= null);
	     i = i + 1;
	end;

	return (i);
     end count_components;

     end set_storage_usage;

     end v2pl1;




*/
                                          -----------------------------------------------------------


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

*/
