



		    assign_type_d.pl1               10/03/83  1722.3rew 10/03/83  1005.3       12258



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

assign_type_d:	proc(descriptor_bit,psp,picture_ptr,assign_type,scale_prec) options(support);

dcl	descriptor_bit bit(36) aligned,

	(picture_ptr,psp) ptr;

dcl	assign_type	fixed bin(17),
	scale_prec	fixed bin(35),

	1 fo		based(addr(scale_prec)) aligned,
	2 scale		fixed bin(17) unal,
	2 prec		fixed bin(17) unal;

dcl	(addr,addrel,fixed,unspec) builtin;

dcl	assign_type_p	ext entry(ptr,fixed bin(17),fixed bin(35));

%include descriptor;
%include pl1_stack_frame;
%include plio2_ps;

	if descriptor_bit="0"b
	then do;
		picture_ptr = psp->ps.stack_frame_p;
		picture_ptr = picture_ptr->pl1_stack_frame.text_base_ptr;

		picture_ptr = addrel(picture_ptr,psp->ps.top_half);

		call assign_type_p(picture_ptr,assign_type,scale_prec);

		return;
	end;

	unspec(desc_) = descriptor_bit;

	assign_type = type_*2 + fixed(pack_,17,0);
	fo.scale = scale_;
	fo.prec = precision_;

	end assign_type_d;




		    assign_type_p.pl1               10/03/83  1722.3rew 10/03/83  1005.3        9342



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

assign_type_p:	proc(p,assign_type,scale_prec) options(support);

dcl	p ptr;

dcl	assign_type	fixed bin(17),
	scale_prec	fixed bin(35),

	1 fo		based(addr(scale_prec)) aligned,
	2 scale		fixed bin(17) unal,
	2 prec		fixed bin(17) unal;

dcl	addr builtin;

%include desc_types;
%include picture_desc_;
%include picture_image;

	assign_type = type(p->picture_image.type);
	fo.scale = p->picture_image.scale - p->picture_image.scalefactor;

	if assign_type=char_desc*2
	then	fo.prec = p->picture_image.varlength;
	else	fo.prec = p->picture_image.prec;

	end assign_type_p;




		    decode_oldesc_.pl1              10/03/83  1722.3rew 10/03/83  1005.3       11817



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

decode_oldesc_:	proc(old) returns(bit(36)aligned) options(support);

dcl	old bit(36) aligned;

dcl	1 old_descriptor	aligned,
	2 old_type	fixed bin(14) unal,
	2 old_junk	bit(3) unal,
	2 old_decimal	bit(1) unal,
	2 old_scale	fixed bin(7) unal,
	2 old_precision	fixed bin(8) unal;

dcl	(divide,unspec) builtin;

%include desc_types;
%include descriptor;

	unspec(old_descriptor) = old;

	unspec(desc_) = (36) "0"b;

	scale_ = old_scale;
	precision_ = old_precision;

	if old_decimal
	then do;
		type_ = D_fixed_real_desc + divide(old_type-1,2,17,0);
		goto ret;
	end;

	if old_type<=entry_desc
	then do;
		type_ = old_type;
		goto ret;
	end;

	if old_type>=518 & old_type<=522
	then do;
		type_ = old_type-500;

		if type_=v_bit_desc | type_=char_desc
		then	type_ = 41-type_;

		goto ret;
	end;

ret:
	return(unspec(desc_));

	end decode_oldesc_;




		    display_pl1io_error.pl1         07/30/86  0927.7rew 07/28/86  1500.1       81774



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



/****^  HISTORY COMMENTS:
  1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), audit(86-07-16,Mabey),
     install(86-07-28,MR12.0-1105):
     Change by M Mabey (installed by Ginter) to report an error if an argument
     is supplied or if used as an active function.
                                                   END HISTORY COMMENTS */


display_pl1io_error: dpe:
     procedure ();

/* Modified 850515 by MM to report an error if an argument is supplied or   */
/*	if used as an active function.			      */
/* Modified 770829 by PG for read/write to stream files */

/* automatic */

dcl  bad_job bit (36);
dcl (psp, fsbp) ptr;
dcl (i, j) fixed bin (15);
dcl arg_count fixed bin;
dcl code fixed bin (35);

dcl  vs char (128) varying;
dcl  attribute_conflict bit (1) aligned;
dcl  bad_code bit (1) aligned;
dcl  pseudo_file bit (1) aligned;
dcl  file_name_string char (40) varying;

/* builtins */

dcl (null, substr, length, string) builtin;

/* entries */

dcl  ioa_ entry external options (variable);
dcl  ioa_$nnl entry external options (variable);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  error_table_$too_many_args fixed bin(35) ext static;

/* internal static */

dcl  ME char (20) init ("display_pl1io_error") int static options (constant);
dcl  test_conflicts (20) bit (20) internal static init (

/* .  zzvopiousnrsdixxskne   */
/* .  ooeprnuptoeeinxxtemn   */
/* .  ttreiptdrkcqrtxxvylv   */
/* .    snnupamerueexxaes      */
/* .    2 tttt ydecr  ldt      */
     "00000001001110001100"b,				/* data	*/
     "00000001001110001100"b,				/* edit	*/
     "00000001001110001100"b,				/* list	*/
     "00000011001111001100"b,				/* get	*/
     "00000101001110001100"b,				/* put	*/
     "00000101001110001100"b,				/* page	*/
     "00000001001110001100"b,				/* line	*/
     "00000001001110001100"b,				/* skip	*/
     "00001010000001000000"b,				/* read	*/
     "00000100000000000000"b,				/* write	*/
     "00001110100001000000"b,				/* rewrite	*/
     "00001110100001000000"b,				/* delete	*/
     "00001101100001000000"b,				/* locate	*/
     "00001000110001000000"b,				/* key	*/
     "00001010110011000000"b,				/* keyto	*/
     "00001100110001000000"b,				/* keyfrom	*/
     "00001010100001000000"b,				/* set	*/
     "00001010000001000000"b,				/* into	*/
     "00001010100011000000"b,				/* ignore	*/
     "00000100000000000000"b);			/* from	*/

dcl  switch_word (36) char (15) varying static internal
     init ("zot1 ", "zot2 ", "version2 ",
     "open ", "print ", "input ",
     "output ", "update ", "stream ",
     "notkeyed ", "record ", "sequential ",
     "direct ", "interactive ", "not_used_pos15 ",
     "not_used_pos16 ", "stringvalue ", "keyed ",
     "namelist ", "environment ", "end_of_file ",
     "transmit_error ", "buffer_in_use ", "copy ",
     "detach ", "te_hold ", "prelim_eof ",
     "internal ", "threaded ", "fsb_in_use ",
     "not_used_pos31 ", "emptyline ", "iox_close ",
     "not_used_pos34 ", "not_used_pos35 ", "not_used_pos36 ");

dcl  nono_word (18) char (12) varying static internal
     init ("lock ", "unlock ", "read ",
     "write ", "rewrite ", "delete ",
     "locate ", "key ", "keyto ",
     "keyfrom ", "set ", "into ",
     "ignore ", "from ", "nofrom ",
     "nokey ", "nokeyfrom ", "nolock");

dcl  bad_job_word (20) char (12) varying static internal
     init (
     "data ", "edit ", "list ",
     "get ", "put ", "page ",
     "line ", "skip ",
     "read ", "write ", "rewrite ",
     "delete ", "locate ", "key ",
     "keyto ", "keyfrom ", "set ",
     "into ", "ignore ", "from ");

dcl  switch_nonos (5:18) bit (14) internal static init (

/* .  piousnrsdixxsk   */
/* .  rnuptoeeinxxte   */
/* .  iptdrkcqrtxxvy   */
/* .  nupamerueexxae   */
/* .  tttt ydecr  ld   */
     ""b,						/* print		*/
     "1"b,					/* input		*/
     "01"b,					/* output		*/
     "011"b,					/* update		*/
     "0001"b,					/* stream		*/
     "00000"b,					/* notkeyed	*/
     "100010"b,					/* record		*/
     "0000100"b,					/* sequential	*/
     "00001101"b,					/* direct		*/
     "010100101"b,					/* interactive	*/
     "0000000000"b,					/* notused	*/
     "00000000000"b,				/* notused	*/
     "000010000100"b,				/* stringvalue	*/
     "0000110001000"b);				/* keyed		*/

/* include files */

%include plio2_fsb;
%include plio2_ps;

/* program */

	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;
	if arg_count ^= 0 then do;
	     call com_err_ (error_table_$too_many_args, ME, "No arguments are permitted.");
	     return;
	end;

	fsbp = plio2_data_$badfsbp;
	bad_job = plio2_data_$badjob;
	if fsbp = null
	then do;
	     call ioa_ ("^/There was no error raised during PL/I i/o in this process.");
	     return;
	end;

	pseudo_file = substr (bad_job, 2, 1);		/* string option bit	*/

	if pseudo_file
	then file_name_string = "^/Error on string option pseudo-file ";
	else file_name_string = "^/Error on file ^a";

	call ioa_$nnl (file_name_string, fsb.filename);

	bad_job = substr (bad_job, 4, 8)||substr (bad_job, 16, 12)|| (16)"0"b;

	if fsb.lnzc > 0 & ^fsb.switch.stream
	then call show_code;			/* stream errors are not generally associated with a system error */
	else call ioa_ ("");			/* because ioa_$nnl was used, we need a trailing new_line	*/

	call show_fsb;
	if plio2_data_$undef_file_sw
	then do;
	     attribute_conflict = "0"b;
	     call ioa_$nnl ("Error in opening or closing ^a", fsb.filename);
	     call show_badfile;
	     if ^attribute_conflict
	     then do;
		bad_code = "0"b;
		if fsb.switch.stream
		then call show_code;
		if ^bad_code then call ioa_ ("");	/* insert the final trailing new-line */
	     end;
	end;
	else do;
	     call show_job;
	     call show_conflicts;
	end;
	return;

show_fsb:	proc;
	     if fsb.filename ^= """get_string_option"""
	     & fsb.filename ^= """put_string_option"""
	     then call ioa_ ("Title: ^a", fsb.path_name);
	     vs = "Attributes: ";
	     call print_attributes ((string (fsb.switch)));

	     if substr (fsb.declared_attributes (1), 4, 33)
	     then if ^pseudo_file			/* fake fsb's do not have a valid decl_attrs field */
		then do;
		     vs = "Permanent attributes: ";
		     call print_attributes (fsb.declared_attributes (1));
		end;
	     return;
	end show_fsb;


show_job:	proc;
	     if bad_job = "0"b
	     then call ioa_ ("No i/o job found.");
	     else do;
		vs = "Last i/o operation attempted: ";
		do i = 1 to 20;
		     if substr (string (bad_job), i, 1) then vs = vs||bad_job_word (i);
		     if length (vs)>65 then call print_vs;
		end;
		if length (vs) ^= 0 then call print_vs;
	     end;
	     return;
	end show_job;

print_vs:	proc;
	     call ioa_ ("^a", vs);
	     vs = "";
	end print_vs;


print_attributes: proc (bit_str);
dcl  bit_str bit (36) aligned;
	     do i = 4 to 14, 16 to 20, 24, 28;
		if substr (string (bit_str), i, 1) then vs = vs||switch_word (i);
		if length (vs)>65 then call print_vs;
	     end;
	     if length (vs) ^= 0 then call print_vs;
	end print_attributes;

show_code: proc;
dcl  c1 char (8) aligned;
dcl  c2 char (100) aligned;
dcl  c3 char (100) varying;
	     call convert_status_code_ ((fsb.lnzc), c1, c2);
	     c3 = c2;
	     if length (c3)>0
	     then do;
		call ioa_ (", status code: ^a", c3);
		bad_code = "1"b;
	     end;
	end show_code;


show_conflicts: proc;
	     do i = 1 to 20;
		if substr (bad_job, i, 1) then do;
		     if string (fsb.switch)&test_conflicts (i) then do;
			vs = "Attempted """||bad_job_word (i)||""" operation conflicts with";
			call print_vs;
			do j = 1 to 20;
			     if substr (string (fsb.switch), j, 1)&substr (test_conflicts (i), j, 1) then do;
				vs = "	file """||switch_word (j)||""" attribute.";
				j = 20;
			     end;
			end;
		     end;
		     if vs ^= "" then call print_vs;
		end;
	     end;
	end show_conflicts;


show_badfile: proc;
	     do i = 5 to 18;
		if substr (string (fsb.switch), i, 1)
		then do j = 5 to 18;
		     if substr (switch_nonos (i), j-4, 1) & substr (string (fsb.switch), j, 1)
		     then do;
			if ^attribute_conflict then call ioa_ (""); /* give trailing NL to last line */
			call ioa_ ("The ^a attribute conflicts with the ^a attribute.",
			     switch_word (i), switch_word (j));
			attribute_conflict = "1"b;
		     end;
		end;
	     end;
	     return;
	end show_badfile;


     end						/* display_pl1io_error */;




		    pl1_io_.pl1                     10/03/83  1722.3rew 10/03/83  1005.3       11619



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

pl1_io_: proc;

	return;

	/* pl1_io_:  user-accessible interfaces to get PL/I I/O data */
	/* Bernard Greenberg 12/20/76 */

dcl 1 file_variable aligned based,			/* Declaration of any PL/I File Value */
    2 fab_ptr ptr,					/* Pointer to File Attribute Block (FAB) */
    2 fsb_ptr ptr;					/* Pointer to File State Block (FSB */

dcl  a_file file variable;				/* Argument File */

dcl 1 a_file_value like file_variable aligned based (addr (a_file)); /* Redeclaration of parameter. */

get_iocb_ptr: entry (a_file) returns (ptr);		/* Return pointer to IOCB */

	return (a_file_value.fsb_ptr -> fsb.iocb_p);

error_code: entry (a_file) returns (fixed bin (35));	/* Return last non-zero error code. */

	return (a_file_value.fsb_ptr -> fsb.lnzc);


dcl  fsbp ptr;					/* Satisfy include file */

%include plio2_fsb;
end;




		    plio2_data_.alm                 10/03/83  1722.3rew 10/03/83  1005.3       13626



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

"	
"		plio2_data_
"	
"		static stuff to be bound into PLIO2
"		P.A.Belmont
"		12-17-70
"		updated 7-27-72
"	
"	
	name plio2_data_
"	
	segdef	pspstat,fsbpstat,fabpstat,fab2pstat,pliostringfsbp
	segdef	bs,ht,nl,cr,np
	segdef	max_page_size
	segdef	badfsbp
	segdef	badjob
	segdef	user_debug_plio_sw,spds,undef_file_sw
	segdef	interconv_debug_sw,finalconv_debug_sw
	segdef	pliostatswitch,ermsgsw,realsignalsw
	segdef	get_data_debug_sw,put_data_debug_sw,real_signal_debug_sw
"	
	use	linkc
	join	/link/linkc
"	
"	
	even
pspstat:	its	-1,1
fsbpstat:	its	-1,1
fabpstat:	its	-1,1
badfsbp:	its	-1,1
fab2pstat: its	-1,1
pliostringfsbp: its	-1,1
user_debug_plio_sw: dec 0
undef_file_sw:	dec 0
badjob:		dec 0
spds:		dec 0
interconv_debug_sw: dec 0
finalconv_debug_sw: dec 0
pliostatswitch:     dec 0
ermsgsw:		dec 0
get_data_debug_sw:	dec 0
put_data_debug_sw:	dec 0
real_signal_debug_sw: dec 0
realsignalsw:	dec 1
max_page_size:	dec 34000000000
bs:	oct	010000000000
ht:	oct	011000000000
nl:	oct	012000000000
cr:	oct	015000000000
np:	oct	014000000000
"	
"	
"	
	end




		    plio2_debug_.pl1                10/03/83  1722.3rew 10/03/83  1005.4        9909



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

plio2_debug_:proc options(support);
% include plio2_ps;
% include plio2_fsb;

dcl (null, string) builtin;
dcl (fsbp,psp,jobp) ptr;
/*  */

renew_cur:entry;
	jobp=plio2_data_$fsbpstat;
	goto work;

renew:	entry(sn,of);
	dcl (sn,of) char(*);
	dcl octptr entry(char(*),char(*)) returns(ptr);

	jobp=octptr(sn,of);
	goto work;


work:
	/* closes and unthreads the JOB file */

	fsbp=plio2_data_fsb_thread_;
	do while(fsbp^=null);
	if fsb.fsb_thread=jobp then
		do;
		fsb.fsb_thread=fsb.fsb_thread->fsb.fsb_thread;
		jobp->fsb.fsb_thread=null;
		string(jobp->fsb.switch)="0"b;
		return;
		end;
	fsbp=fsb.fsb_thread;
	end;

	return;
end;




		    plio2_dnd_.pl1                  10/24/88  1656.2r w 10/24/88  1400.1       38619



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

/*	Modified: 05/01/78 by PCK to implement unsigned binary
	Modified: 9 August 1978 by PCK to fix 1768
	Modified: 25 Apr 1979 by PCK to implement 4-bit decimal */

dnd:proc(d,p,code) options(support);
	dcl d bit(36) aligned, p ptr, code fixed bin(15);
	/* d is descriptor, p points at D_structure (see below), and code=1 for failure */

/* updated 5-4-71 */

	dcl 1 D aligned based(q),	/* this is the D_STRUCTURE ! ! !  */
		2 type5 aligned,
			3 ( cr,bd,ff,ls,pack) char(1) unaligned,
		2 ( precx,
		    scalex,
		    bit_lengthx,
		    typex ) fixed bin(15);




	dcl ( prec, scale,  bit_length,type ) fixed bin(15);
	dcl q ptr;
dcl (addr, string, substr) builtin;
	dcl WS fixed bin(15);

	dcl fixed builtin;
% include plio2_descriptor_forms;
%include std_descriptor_types;

	/* 	START */
	WS=0;
common:

	q=p;
	desc_ptr=addr(d);
	code=0;



	if nd_first then
		do;
		type=fixed(nd_type,6,0);
		if type=0 then go to bad_type;
		if type > cplx_flt_dec_9bit_dtype & type < real_fix_dec_9bit_ls_overp_dtype then		/* if not an arithmetic data type then */
			do;
			if WS=0 then go to bad_type;
			if type < bit_dtype | type > varying_char_dtype then go to bad_type;	/* if not a string data type then */
			addr(D.type5)->based_char5=string_types(type - bit_dtype + 1);
			D.precx=fixed(substr(desc_ptr->based_bits,13,24),24,0);
			go to string_exit;
			end;

		if type <= cplx_flt_dec_9bit_dtype
		then addr(D.type5)->based_char5=types_table(type)||" ";
		else if type<=real_fix_bin_2_uns_dtype
		     then addr(D.type5)->based_char5=types_table(type - real_fix_bin_1_uns_dtype + real_fix_bin_1_dtype) || " ";
		     else addr(D.type5)->based_char5=types_table(type - real_fix_dec_4bit_bytealigned_ls_dtype + real_fix_dec_9bit_ls_dtype) || " ";

		prec=fixed(nd_prec,12,0);

		scale=fixed(nd_scale,12,0);
		if scale>100000000000b then  scale=scale - 1000000000000b;

		if nd_pack then D.type5.pack="p";

		if D.type5.bd="d" then
			do;
			if D.type5.ff="l" then bit_length=prec+2;
			else bit_length=prec+1;

			if type <= cplx_flt_dec_9bit_dtype
			then bit_length=bit_length*9;	/* chars are 9 bits */
			else bit_length=(bit_length+mod(bit_length,2))*4.5; /* 2 digits per character */
			end;
		else	do;
			if nd_pack then
				do;
				if D.type5.ff="l" then bit_length=prec+9;
				else if type <= real_fix_bin_2_dtype
				     then bit_length = prec + 1;
				     else bit_length = prec;
				end;
			else go to unpacked_binary;
			end;
		end;

	else	do;
		type=fixed(od_type,15,0);
		if type=0
		then	do;
				/* descriptor="0"b is the signal for a pictured item */
			string (D.type5) = "p    ";
			return;
			end;
		if type>8 then
			do;
			if WS=0 then go to bad_type;
			if type>522|type<519 then go to bad_type;
			addr(D.type5)->based_char5=string_types(type-514);
			D.precx=fixed(substr(desc_ptr->based_bits,19,18),18,0);
string_exit:
			if D.bd="b" then D.bit_lengthx=D.precx;
			else D.bit_lengthx=9*D.precx;
			return;
			end;

		prec=fixed(od_prec,9,0);

		scale=fixed(od_scale,8,0);
		if scale>10000000b then scale=scale-100000000b;

		addr(D.type5)->based_char5=types_table(type)||" ";

unpacked_binary:
		if D.type5.ls="l" then bit_length=72;
		else bit_length=36;
		end;


	if prec>63 then
		do;
		if D.type5.bd="d" then goto bad_prec;
		if D.type5.ff="l" then goto bad_prec;
		if prec>71 then goto bad_prec;
		end;
	D.precx=prec;


	if scale>127 then goto bad_scale;
	if scale<-128 then goto bad_scale;
	D.scalex=scale;

	D.typex=type;
	D.bit_lengthx=bit_length;

	return;

bad_prec:
bad_scale:
bad_type:
	code=1;
	return;

with_strings:entry(d,p,code);
	WS=1;
	go to common;

	dcl string_types(8) char(4) static internal init(
		"sb n", /*	514	*/
		"sbvn", /*	520	*/
		"sc n", /*	524	*/
		"scvn", /*	530	*/
		"sb o", /*	01007	*/
		"sc o", /*	01010	*/
		"sbvo", /*	01011	*/
		"scvo"	 /*	01012	*/	);


end;




		    plio2_dump_.pl1                 10/03/83  1722.3rew 10/03/83  1005.4       84762



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

/* Modified 9 October 1980 by M. N. Davidoff to fix 1978 (doesn't compile because nono_word had wrong number of initial list
	elements).
*/
/* format: style3 */
plio2_dump_:
     procedure;

/* parameters */

dcl	OF		char (*);
dcl	SN		char (*);

/* automatic */

dcl	fsbp		ptr;
dcl	i		fixed bin;
dcl	psp		ptr;

/* based */

dcl	fsb_buffer	char (fsb.bsize) based (fsb.bptr);

/* builtin */

dcl	(hbound, length, low, max, maxlength, min, null, string, substr)
			builtin;

/* entry */

dcl	ioa_$ioa_switch	entry options (variable);
dcl	octptr		entry (char (*), char (*)) returns (ptr);

/* internal static */

dcl	switch_word	(36) char (16) varying static internal options (constant)
			init ("zot(1)", "zot(2)", "version_2", "open", "print", "input", "output", "update", "stream",
			"notkeyed", "record", "sequential", "direct", "interactive", "not_used_1", "not_used_2",
			"stringvalue", "keyed", "namelist", "implementation", "not_used_4", "transmit_error",
			"buffer_in_use", "copy", "detach", "te_hold", "not_used_5", "internal", "threaded",
			"fsb_in_use", "console", "emptyline", "iox_close", "xxx4", "xxx5", "xxx6");

dcl	nono_word		(18) char (12) varying static internal options (constant)
			init ("bit_string", "not_used_3", "read", "write", "rewrite", "delete", "locate", "key",
			"keyto", "keyfrom", "set", "into", "ignore", "from", "nofrom", "nokey", "nokeyfrom", "nolock");

dcl	job_word		(36) char (16) varying static internal options (constant)
			init ("explicit_file", "string", "varying_string", "data", "edit", "list", "get", "put", "page",
			"line", "skip", "copy", "p1p2", "bit_string", "char_string", "read", "write", "rewrite",
			"delete", "locate", "key", "keyto", "keyfrom", "set", "into", "ignore", "from", "version(1)",
			"version(2)", "version(3)", "version(4)", "version(5)", "version(6)", "not_byte_buffer", "pad1",
			"packed_ptr");

dcl	ps_switch_word	(4) char (16) varying internal static options (constant)
			initial ("first_field", "file", "transmit_error", "semi_sep");

/* external static */

dcl	iox_$error_output	ptr external static;

%include plio2_fsb;
%include plio2_fsbr;
%include plio2_ps;
%include plio2_psr;

/* program */

setfsbp:
     entry (SN, OF);

	plio2_data_$fsbpstat = octptr (SN, OF);

	return;

setpsp:
     entry (SN, OF);

	plio2_data_$pspstat = octptr (SN, OF);

	return;

filelist:
     entry;

	call ioa_$ioa_switch (iox_$error_output, "List of files open or opened:");

	do fsbp = plio2_data_fsb_thread_ repeat fsbp -> fsb.fsb_thread while (fsbp ^= null);
	     call ioa_$ioa_switch (iox_$error_output, "fspb: ^p, filename: ^a^[, open pathname: ^a^;^s^]", fsbp,
		fsb.filename, fsb.switch.open, fsb.path_name);
	end;

	call ioa_$ioa_switch (iox_$error_output, "");

	return;

dgfsb:
     entry (SN, OF);

	fsbp = octptr (SN, OF);
	goto dfsbcommon;

dcfsb:
     entry;

	fsbp = plio2_data_$fsbpstat;

dfsbcommon:
	call ioa_$ioa_switch (iox_$error_output, "fsbp: ^p", fsbp);
	if fsbp = null
	then return;

	call ioa_$ioa_switch (iox_$error_output, "filename: ^a", validate ((fsb.filename)));
	call ioa_$ioa_switch (iox_$error_output, "title: ^a", validate (fsb.title));

	if fsb.filename ^= """get_string_option""" & fsb.filename ^= """put_string_option"""
	then call ioa_$ioa_switch (iox_$error_output, "pathname: ^a", validate (fsb.path_name));

	call print_switches ("attributes", string (fsb.switch), switch_word);
	call ioa_$ioa_switch (iox_$error_output, "bsize: ^d, thread: ^p, DA: ^w", fsb.bsize, fsb.fsb_thread,
	     fsb.declared_attributes (1));

	if fsb.switch.record
	then do;
		call print_switches ("forbidden operations", string (fsb.nono), nono_word);
		call ioa_$ioa_switch (iox_$error_output,
		     "^[^[Current record exists.^;Current record deleted.^]^;^sNo current record.^]",
		     fsbr.recio.rec_exists, fsbr.recio.rec_valid);

		if fsbr.recio.buffer_used
		then call ioa_$ioa_switch (iox_$error_output, "buffer_used");

		if fsbr.switch.keyed
		then call ioa_$ioa_switch (iox_$error_output, "key_saved: ""^v^a""", length (fsbr.key_saved),
			fsbr.key_saved);

		if fsbr.inbuf_sw.exists
		then do;
			call ioa_$ioa_switch (iox_$error_output, "inbuf_exists^[ free^]^[ in_use^]", fsbr.inbuf_sw.free,
			     fsbr.inbuf_sw.use);
			call ioa_$ioa_switch (iox_$error_output, "max: ^d, cur: ^d, ptr: ^p", fsbr.inbuf_maxlen,
			     fsbr.inbuf_curlen, fsbr.inbuf_ptr);
		     end;
		else call ioa_$ioa_switch (iox_$error_output, "no inbuf");

		if fsbr.outbuf_sw.exists
		then do;
			call ioa_$ioa_switch (iox_$error_output, "outbuf_exists^[ free^]^[ in_use^]",
			     fsbr.outbuf_sw.free, fsbr.outbuf_sw.use);
			call ioa_$ioa_switch (iox_$error_output, "max: ^d, cur: ^d, ptr: ^p", fsbr.outbuf_maxlen,
			     fsbr.outbuf_curlen, fsbr.outbuf_ptr);

			if fsbr.outbuf_sw.use & fsbr.switch.keyed
			then call ioa_$ioa_switch (iox_$error_output, "outbuf_key: ""^v^a""", length (fsbr.outbuf_key),
				fsbr.outbuf_key);
		     end;
		else call ioa_$ioa_switch (iox_$error_output, "no outbuf");
	     end;

	else do;
		call ioa_$ioa_switch (iox_$error_output, "lsep: ^d, blc: ^d, bnc: ^d", fsb.lsep, fsb.blc, fsb.bnc);
		call ioa_$ioa_switch (iox_$error_output, "bptr: ^p, kol: ^d", fsb.bptr, fsb.kol);

		if fsb.switch.stream
		then call ioa_$ioa_switch (iox_$error_output, "limit: ^d", fsb.limit);

		if fsb.switch.output
		then call ioa_$ioa_switch (iox_$error_output, "lsize: ^d", fsb.lsize);

		if fsb.switch.print
		then call ioa_$ioa_switch (iox_$error_output, "lineno: ^d, pageno: ^d, psize: ^d", fsb.lineno, fsb.pageno,
			fsb.psize);

		i = min (max (fsb.blc, fsb.bnc - 1), 20);
		if i > 0
		then call ioa_$ioa_switch (iox_$error_output, "buffer: ""^v^a""", i, substr (fsb_buffer, 1, i));
	     end;

	call ioa_$ioa_switch (iox_$error_output, "");

	return;

dgps:
     entry (SN, OF);

	psp = octptr (SN, OF);
	goto pscommon;

dcps:
     entry;

	psp = plio2_data_$pspstat;

pscommon:
	call ioa_$ioa_switch (iox_$error_output, "psp: ^p", psp);
	if psp = null
	then return;

	if ps.job.read | ps.job.write | ps.job.rewrite | ps.job.delete | ps.job.locate
	then do;
		call print_switches ("job", string (ps.job), job_word);
		call ioa_$ioa_switch (iox_$error_output, "keytemp: ^a", validate_vs (psr.keytemp));
		call ioa_$ioa_switch (iox_$error_output, "var_p: ^p, set_p_p: ^p, source_p: ^p", psr.variable_p,
		     psr.set_p_p, psr.source_p);
		call ioa_$ioa_switch (iox_$error_output, "number: ^d, variable_bitlen: ^d", psr.number,
		     psr.variable_bitlen);
		call ioa_$ioa_switch (iox_$error_output, "file_p: ^p, fsbp: ^p, auxp: ^p, fabp: ^p, fab2p: ^p",
		     psr.file_p, psr.fsbp, psr.auxp, psr.fabp, psr.fab2p);
	     end;

	else do;
		call ioa_$ioa_switch (iox_$error_output, "sfp: ^p, STTp: ^p, STBp: ^p", ps.stack_frame_p, ps.ST_top_p,
		     ps.ST_block_p);
		call ioa_$ioa_switch (iox_$error_output, "format_area_p: ^p, ss_list_p: ^p", ps.format_area_p,
		     ps.ss_list_p);
		call ioa_$ioa_switch (iox_$error_output, "source_p: ^p, special_list_p: ^p, copy_file_p: ^p", ps.source_p,
		     ps.special_list_p, ps.copy_file_p);
		call print_switches ("job", string (ps.job), job_word);
		call ioa_$ioa_switch (iox_$error_output, "number: ^d", ps.number);
		call ioa_$ioa_switch (iox_$error_output, "value_p: ^p, descriptor: ^w, length: ^d, offset: ^w",
		     ps.value_p, ps.descriptor, ps.length, ps.offset);
		call ioa_$ioa_switch (iox_$error_output, "prep: ^d, new_format: ^d", ps.prep, ps.new_format);
		call print_switches ("ps.switch", substr (string (ps.switch), 1, hbound (ps_switch_word, 1)),
		     ps_switch_word);
		call ioa_$ioa_switch (iox_$error_output, "file_p: ^p, fsbp: ^p, auxp: ^p", ps.file_p, ps.fsbp, ps.auxp);
		call ioa_$ioa_switch (iox_$error_output, "fabp: ^p, fab2p: ^p", ps.fabp, ps.fab2p);
		call ioa_$ioa_switch (iox_$error_output, "vp: ^p, descr: ^w, start_copy: ^d", ps.vp, ps.descr,
		     ps.start_copy);
	     end;

	call ioa_$ioa_switch (iox_$error_output, "");

	return;

print_switches:
     procedure (title, bits, names);

dcl	title		char (*);
dcl	bits		bit (*);
dcl	names		(*) char (*) varying;

dcl	i		fixed bin;
dcl	line		char (72) varying;

	if bits = ""b
	then return;

	line = title || ":";
	do i = 1 to length (bits);
	     if substr (bits, i, 1)
	     then if length (line) + 1 + length (names (i)) <= maxlength (line)
		then line = line || " " || names (i);
		else do;
			call ioa_$ioa_switch (iox_$error_output, "^a", line);
			line = (5)" " || names (i);
		     end;
	end;

	call ioa_$ioa_switch (iox_$error_output, "^a", line);
     end print_switches;

validate:
     procedure (str) returns (char (256) varying);

dcl	str		char (*);

	if str = low (length (str))
	then return ("Unset string.");
	else return (str);
     end validate;

validate_vs:
     procedure (arg_str) returns (char (256) varying);

dcl	arg_str		char (*) varying;

	if length (arg_str) > maxlength (arg_str)
	then return ("Unset string.");
	else return (arg_str);
     end validate_vs;

     end plio2_dump_;




		    plio2_fl_.pl1                   10/03/83  1722.3rew 10/03/83  1005.4       89604



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

plio2_fl_:
fl_:
fl:format_list:proc options(support);
	/* updated 73-11-8:  picture formats added */

				/*		D E B U G    I N F O
				
				   (plio2_$)dcfi will turn on or turn off display mode
				   (plio2_$)dcfi25 will display the next 25 formats obtained.  */
				


% include plio_format_codes;
%include picture_image;
dcl 1  fb aligned based(fbxp),
	2 bits,
		3 code	bit(9) unaligned,
		3 nval	bit(9) unaligned,
		3 offset	bit(18) unaligned,
	2 rep fixed bin(35),
	2 val(3) fixed bin(35);



dcl 1 fx aligned based(flxp),
	2 fe(3)	,		/* cur, two more for the complex case */
		3 type	fixed bin(15),
		3 nval	fixed bin(15),
		3 val(3)	fixed bin(15),
	2 cur_rep fixed bin(15),	/* octal offset 17  */
	2 cur_sfp	ptr,		/* octal offset 20,21   */
	2 cur_fep	ptr,
	2 first_open_paren_sw bit(18),
	2 stk_index fixed bin(15),
	2 frame(10),		/* push down for "(" in a format list */
		3 sf1p	ptr,
		3 sf2p	ptr,
		3 fe1p	ptr,
		3 fe2p	ptr,
		3 rep	fixed bin(15),
		3 type	fixed bin(15);

	/* facts about the form of FORMAT LISTSs in object
	   programs are given herein in passim */


	dcl (pspp,fbxp,psp,flxp,blp,block_sym_tab_p,qq) ptr;
	dcl (indexlimit,irep,ival,realstype) fixed bin(35);
	dcl stu_$decode_runtime_value ext entry(fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin(35)) returns(fixed bin(35));
	dcl stu_$remote_format ext entry(fixed bin(35),ptr,ptr,label)
	returns(fixed bin(35));
	dcl flabel label;
	dcl icode fixed bin(35);
	dcl i fixed bin(15);
	dcl erno fixed bin(15);
	dcl bl(2) ptr based(blp);
	dcl based_int fixed bin (35) based;

	dcl ( addr,addrel,fixed,null,baseptr,baseno,rel,substr ) builtin;
	dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));

	dcl (ioa_,ioa_$nnl) entry ext options(variable);
	dcl format_letters char(44) aligned static int
	init	("   r   c   f   e   b   a   xskip colpageline");
	dcl (dcfi_sw,dcfi_ct) fixed bin(15) static internal init(0);
	dcl node(5) based(p) fixed bin(15);
	dcl p ptr;
	dcl c4 char(4) aligned;

% include plio2_ps;
/*  */
reset_:entry(pspp);
	psp=pspp;
	flxp=ps.format_area_p;
	ps.new_format=0;



	   /* fx.fe(1) is the structure passed to get edit and put edit
	   which contains the current fully evaluated format item.
	   In the case of the complex format, if fe(1).nval=1 then
	   fe(2) gives both real formats; if fe(1).nval=2 then
	   fe(2) and fe(3) give the two real formats.  */


	fx.stk_index=1;
	fx.cur_rep=0;

	fx.cur_fep=ps.special_list_p;
	if fx.cur_fep->based_int^=0 then goto err196; 

		/* Note: the compiled format list begins with 
		   a word of ZEROs to distinguish a format_label
		   from any other label on the basis of the material
		   pointed to by it.  */

	fx.frame(1).sf1p,fx.frame(1).fe1p=null;
	fx.frame(1).sf2p=ps.stack_frame_p;
	fx.frame(1).fe2p=addrel(ps.special_list_p,1);	/* since first word is zeros */
	return;


/* 	GET	GET	*/



get_next_:entry(pspp);

		/* gets next format item and leaves it, fully
		   evaluated, in fe(1).    REP factors are evaluated
		   before any of the rest of the format item is examined.
		   PARAMs are evaluated before EACH use of the item. */


	psp=pspp;
	block_sym_tab_p=null;	/* used in call to decode value,
				   should be pointer to the ST for
				   the block of the (remote) format.
				   detail a little unsettled now, so
				   I'll use NULL */
	flxp=ps.format_area_p;
	if ps.p1p2 then indexlimit =6;
	else /* ordinary PL2 case */ indexlimit=10;


/*   */
test_rep:
	if fx.cur_rep>0 then
		do;
		fx.cur_rep=fx.cur_rep-1;
		if fx.fe(1).type=c_format then
			do;
			fx.fe(2).val(1)=0;	/* compiler bug made fx.fe(2).val(*)=0 very costly  */
			fx.fe(2).val(2)=0;
			fx.fe(2).val(3)=0;
			fx.fe(3).val(1)=0;
			fx.fe(3).val(2)=0;
			fx.fe(3).val(3)=0;
			if fx.fe(1).nval <1 then goto err194;
			fbxp=addrel(fx.cur_fep,fx.fe(1).val(1));

			if fx.fe(2).type = picture_format
			then	call decode_picture_format(2);

			else	do i=1 to fx.fe(2).nval;
				ival=fbxp->fb.val(i);
				if ival<0 then
					do;
					ival=stu_$decode_runtime_value
					(ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode);
					if icode^=0 then goto err195;
					end;
				fx.fe(2).val(i)=ival;
				end;

			if fx.fe(1).nval<2 
			then	do;
				fx.fe(3).val(1)=fx.fe(2).val(1);
				fx.fe(3).val(2)=fx.fe(2).val(2);
				fx.fe(3).val(3)=fx.fe(2).val(3);
				end;
			else	do;
				fbxp=addrel(fx.cur_fep,fixed(fx.fe(1).val(2),18));

				if fx.fe(3).type = picture_format
				then	call decode_picture_format(3);
				else	do i=1 to fx.fe(3).nval;
					ival=fbxp->fb.val(i);
					if ival<0 then
						do;
						ival=stu_$decode_runtime_value
						(ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode);
						if icode^=0 then goto err195;
						end;
					fx.fe(3).val(i)=ival;
					end;

				end;
			end;

		else	do;	/* non COMPLEX case */
			fbxp=fx.cur_fep;
			fx.fe(1).val(1)=0;
			fx.fe(1).val(2)=0;
			fx.fe(1).val(3)=0;

			if fx.fe(1).type = picture_format
			then	call decode_picture_format(1);

			else	do i=1 to fx.fe(1).nval;
				ival=fbxp->fb.val(i);
				if ival<0 then
					do;
					ival=stu_$decode_runtime_value
					(ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode);
					if icode^=0 then goto err195;
					end;
				fx.fe(1).val(i)=ival;
				end;
			end;
		go to get_fb_exit;
		end;


decode_picture_format:	proc(number);

dcl	number fixed bin(15),
	p ptr;

	p = addrel(fbxp,fb.val(1));

	fx.fe(number).nval = 3;
	fx.fe(number).val(1) = p->picture_image.varlength;
	fx.fe(number).val(2) = fixed(baseno(p),18);
	fx.fe(number).val(3) = fixed(rel(p),18);

end decode_picture_format;



test_next:
	tb18=fx.cur_fep->fb.bits.offset;
	dcl tb18 bit(18);
	if tb18="0"b then go to test_fx_stack;
	fx.cur_fep=addrel(fx.cur_fep,tb18);

set_rep:
	irep=fx.cur_fep->fb.rep;
	if irep<0 then
		do;
		irep=stu_$decode_runtime_value(irep,block_sym_tab_p,fx.cur_sfp,null,null,null,icode);
		if icode^=0 then goto err195;
		end;
	fx.cur_rep=irep;
	fx.fe(1).type=fixed(fx.cur_fep->fb.bits.code,9);
	fx.fe(1).nval=fixed(fx.cur_fep->fb.bits.nval,9);

	if fx.fe(1).type> c_format  then go to test_rep;	/* non special */
	if fx.cur_rep<1 then go to test_next;


/* for n>0
   nC or n( or nR  */


	if fx.fe(1).type= c_format  then
		do;
c_formatx:
		fx.fe(1).val(*)=fx.cur_fep->fb.val(*);

		if fx.fe(1).nval<1 then goto err194;
		fbxp=addrel(fx.cur_fep,fx.cur_fep->fb.val(1));
		fx.fe(2).type,realstype=fixed(fbxp->fb.bits.code,9);
		     /*   if realstype^=f_format
			then if realstype^=e_format
			then if realstype^=picture_format
			then goto err194;  */
		fx.fe(2).nval=fixed(fbxp->fb.bits.nval,9);

		if fx.fe(1).nval<2 then
			do;
			fx.fe(3).type=fx.fe(2).type;
			fx.fe(3).nval=fx.fe(2).nval;
			end;


		else	do;
			fbxp=addrel(fx.cur_fep,fx.cur_fep->fb.val(2));
			fx.fe(3).type,realstype=fixed(fbxp->fb.bits.code,9);
			      /*  if realstype^=f_format
				then if realstype^=e_format
				then if realstype^=picture_format
				then goto err194;  */
			fx.fe(3).nval=fixed(fbxp->fb.bits.nval,9);
			end;

		go to test_rep;
		end;





open_paren:



	fx.stk_index=fx.stk_index+1;
	if fx.stk_index>indexlimit then goto err197;
	fx.frame(fx.stk_index).sf1p=fx.cur_sfp;
	fx.frame(fx.stk_index).fe1p=fx.cur_fep;

	fx.frame(fx.stk_index).rep=fx.cur_rep;

	if fx.fe(1).type= r_format  then
		do;
r_formatx:
		icode=stu_$remote_format(fx.cur_fep->fb.val(1),
					fx.cur_sfp,null,flabel);
		if icode^=0 then goto err195;
		blp=addr(flabel);
		fx.frame(fx.stk_index).sf2p=bl(2);	/* assumes LABEL=(format-list-p,stack-frame-p) */
		if bl(1)->based_int^=0 then goto err196;
		fx.frame(fx.stk_index).fe2p=addrel(bl(1),1);
		end;

	else	do;
		fx.frame(fx.stk_index).sf2p=fx.cur_sfp;
		fx.frame(fx.stk_index).fe2p=addrel(fx.cur_fep,fixed(fx.cur_fep->fb.val(1),18));
		end;

test_fx_stack:
	if fx.stk_index=1 then go to inner_cycle;


	if fx.frame(fx.stk_index).rep>0 then
		do;
		fx.frame(fx.stk_index).rep=fx.frame(fx.stk_index).rep -1;
		go to inner_cycle;
		end;


	fx.cur_sfp=fx.frame(fx.stk_index).sf1p;
	fx.cur_fep=fx.frame(fx.stk_index).fe1p;
	fx.stk_index=fx.stk_index-1;
	go to test_next;

inner_cycle:
	fx.cur_sfp=fx.frame(fx.stk_index).sf2p;
	fx.cur_fep=fx.frame(fx.stk_index).fe2p;
	go to set_rep;


err194:	/* bad_complex_pair */
	erno=194;
	go to error_exit;

err195:	/* decode error */
	erno=195;
	goto error_exit;

err196:	/* first-word-of-format-not-zero  */
	erno=196;
	goto error_exit;

err197:	/* exceeds the depth of the format STACK  */
	erno=197;
	goto error_exit;
error_exit:
	call plio2_signal_$s_r_(psp,"ERROR","format_list_processor",erno);

get_fb_exit:

	if dcfi_sw=1 then
		do;
		dcfi_ct=dcfi_ct - 1;
		if dcfi_ct=0 then dcfi_sw=0;

		p=addr(fx.fe(1));
		if node(1)=3 then goto disp_c;

		call disp_f;
		goto disp_ret;

disp_c:
		call ioa_$nnl("complex(");
		p=addrel(p,5);
		call disp_f;
		call ioa_$nnl(",");
		p=addrel(p,5);
		call disp_f;
		call ioa_$nnl(")");

disp_ret:
		call ioa_("");
		end;
	return;	/* return from disp OR from normal get_next_  */


disp_f:proc;
	if node(1)=13
	then	do;
		qq=addrel(baseptr(node(4)),node(5));
		call ioa_$nnl("p ""^a""",qq->picture_image.chars);
		end;
	else	do;
		c4=substr(format_letters,node(1)*4-7,4);
		if node(2)=3 then call ioa_$nnl("^a(^d,^d,^d)",	c4,node(3),node(4),node(5));
		if node(2)=2 then call ioa_$nnl("^a(^d,^d)",	c4,node(3),node(4));
		if node(2)=1 then call ioa_$nnl("^a(^d)",	c4,node(3));
		if node(2)=0 then call ioa_$nnl("^a",		c4);
		end;
end disp_f;

dcfi:entry;
	dcfi_sw=1-dcfi_sw;
	return;

dcfi25:entry;
	dcfi_sw=1;
	dcfi_ct=25;
	return;


end plio2_fl_;




		    plio2_gdt_.pl1                  10/03/83  1722.3rew 10/03/83  1005.4       53910



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

plio2_gdt_:
get_data_temp_:proc(pspp) options(support);

/*	Modified:	4 April 1978 by RAB to more properly determine time to call stu_$get_implicit_qualifier */


dcl (pspp,psp) ptr;

dcl ( oklist_p, val_p, sym_p, new_sp , ldip,new_block_p, p) ptr;
dcl (text_p, link_p, ref_p) ptr init(null);
dcl ( i, n,  isteps, icode, nsubs ) fixed bin;
dcl isize fixed bin(35);
dcl	bbit36 bit(36) based;
dcl (addr, addrel, bit, binary, fixed, null, rel, substr) builtin;
dcl  based_bit36 bit (36) aligned based;
dcl new_ST_sw bit(1) aligned;

dcl	stu_$find_runtime_symbol ext entry(ptr,char(*) aligned, ptr , fixed bin) returns(ptr);
dcl	stu_$get_runtime_address ext entry(ptr,ptr,ptr,ptr,ptr,ptr,ptr) returns (ptr);
dcl	stu_$decode_runtime_value ext entry (fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin) returns(fixed bin(35));
dcl	stu_$get_implicit_qualifier ext entry (ptr,ptr,ptr,ptr,ptr) returns(ptr);
dcl	plio2_sym_to_desc ext entry(ptr,ptr,ptr,ptr) returns(bit(36)aligned);



	dcl 1 val_struct based,
		2 flag bit(2) unal,
		2 type bit(4) unal,
		2 rest bit(30) unal;

	dcl 1 oklist aligned based(oklist_p),
		2 okln fixed bin(15),
		2 offset(128) bit(18) unaligned;

	dcl oklistlength fixed bin(17);
	dcl delta bit(18);
	dcl sym_q ptr;
	dcl erno fixed bin(35);

	dcl 1 ldi aligned based(ldip),
		2 l fixed bin(15),
		2 chars char(256) aligned,
		2 name_l fixed bin(15),
		2 (isub,sub(128)) fixed bin(15);

	dcl ( jsub,jlower,jupper ) fixed bin(35);

%include pl1_stack_frame;
% include symbol_node;
% include runtime_symbol;
% include plio2_ps;




/*  */
/*	NOTE WELL on SymTab: I use the old symtab whenever it seems
		to agree with the new.
*/

start:
	psp=pspp;
	ldip=ps.auxp;

	sym_p=stu_$find_runtime_symbol(ps.ST_block_p,substr(ldi.chars,1,ldi.name_l),new_block_p,isteps);
	if sym_p=null then goto err72;
	if isteps<0 then  goto err72;
			/* isteps is now used to report errors;
			   -5 means a partial name which is  ambiguous (sym_p is NOT null in this case)
			   -1 means a null block ptr
			   -2,-3 mean th name is too long or has too many parts
			   -4 means the symbol has been searched for but not found */

	if sym_p->runtime_symbol.flag then new_ST_sw = "1"b;
	else new_ST_sw = "0"b;

	oklist_p=ps.special_list_p;
	oklistlength=oklist.okln;
	if ps.job.p1p2 then oklistlength=oklistlength+oklistlength;
	/* since, in version one, oklist is stored one per word */

	if oklistlength>0 then
		do;
		sym_q=sym_p;

okloop:		delta=bit(fixed(binary(rel(sym_q),18,0)-binary(rel(ps.ST_top_p),18,0),18,0),18);
			do i=1 to oklistlength;
			if delta=oklist.offset(i) then go to ok_exit;
			end;

		if fixed(sym_q->symbol_node.level,6)<2 then goto err73;	/* SAME */
		sym_q=addrel(sym_q,sym_q->symbol_node.father);		/* SAME */
		go to okloop;

ok_exit:		end;



	nsubs=fixed(sym_p->symbol_node.ndims,6);			/* SAME */
	if nsubs^=ldi.isub then goto  err74;

	new_sp=ps.stack_frame_p;
	do i=1 to isteps;
	new_sp=new_sp->pl1_stack_frame.display_ptr;
					/* Here's an OPERATING SYSTEM
					   interface for you. son's SF
					   points to parent's SF
					   in this fashion in MULTICS */


	end;


	/* check subscript ranges */

	do i=1 to nsubs;

	jsub=ldi.sub(i);
	if new_ST_sw then
		do;
		jlower=sym_p->runtime_symbol.bounds(i).lower;
		jupper=sym_p->runtime_symbol.bounds(i).upper;
		end;
	else	do;
		jlower=sym_p->symbol_node.bounds(i).lower;
		jupper=sym_p->symbol_node.bounds(i).upper;
		end;

	icode=0;

	if jlower<0
	then do;
		if ref_p = null & sym_p -> runtime_symbol.class = "0011"b
		then ref_p = stu_$get_implicit_qualifier(new_block_p,sym_p,new_sp,link_p,text_p);
		else;
	 	jlower=stu_$decode_runtime_value((jlower),new_block_p,new_sp,null,null,ref_p,icode);
		end;

	if icode^=0 then goto err76;
	if jupper<0
	then do;
		if ref_p = null & sym_p -> runtime_symbol.class = "0011"b
		then ref_p = stu_$get_implicit_qualifier(new_block_p,sym_p,new_sp,link_p,text_p);
		else;
	 	jupper=stu_$decode_runtime_value((jupper),new_block_p,new_sp,null,null,ref_p,icode);
		end;

	if icode^=0 then goto err76;
	if jsub<jlower|jsub>jupper then goto err77;
	end;	/* end of do-loop on all subscripts */

	val_p=stu_$get_runtime_address(new_block_p,sym_p,new_sp,null,null,null,addr(ldi.sub(1)));
	if val_p=null then goto err75;

	if sym_p->runtime_symbol.type="111111"b
	then do;
		ps.top_half = bit(fixed(sym_p->runtime_symbol.size,18),18);
		ps.descr = "0"b;
	end;
	else	ps.descr=plio2_sym_to_desc(sym_p,null,psp,new_sp);

	ps.vp=val_p;

	if substr(ps.descr,1, 7)="1010100"b then goto varstrret;
	if substr(ps.descr,1, 7)="1010110"b then goto varstrret;
	/*
	if substr(ps.descr,1,15)="000001000001001"b then goto varstrret;
	if substr(ps.descr,1,15)="000001000001010"b then goto varstrret;
	*/


	return;

varstrret:
	ps.vp=addrel(ps.vp,1);	/* PLIO2 needs to have the pointer "as an argument"  */
	return;


err72:	erno=72;
	goto error_exit;

err73:	erno=73;
	goto error_exit;

err74:	erno=74;
	goto error_exit;

err75:	erno=75;
	goto error_exit;

err76:	erno=76;
	goto error_exit;

err77:	erno=77;
	goto error_exit;

error_exit:
	addr(ps.descr)->based_bit36=addr(erno)->based_bit36;
		/* returns erno to which 63 will be added:

		72 135 identifier not found in S.T.
		73 136 identifier not found in (or under) data list of get-data statement
		74 137 number of subscripts in identifier not equal number specified in S.T.
		75 138 error return from stu_$get_runtime_address
		76 139 error return from stu_$decode_runtime_value
		77 140 subscript range error, info from S.T.

		*/
	ps.vp=null;
	return;

end plio2_gdt_;




		    plio2_get_util_.pl1             10/03/83  1722.3rew 10/03/83  1005.4      118476



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

plio2_get_util_:proc options(support);

/* updated 73-12-6  */
	/* 76-09-08: changed to use iox_$get_line call forwarder	*/
	/* 73-12-6: updated to replace ios_ with iox_ */

	/* 73-10-25:
		changed to comply with BASIS.
		Check how our guesses are when BASIS/1-12 comes out.
	*/
	/* 9-13-72: AG94 redefines the scanning for list
		and data-directed fields.  We implement these
		changes here.  */


	/* 7-26-71: brought SKIP and COLUMN into the fold by
		adding them to the table-driven department.

		made eob = blc for a one-level rather than a two-level
		scanning strategy.     */

	/* 5-20-71: fixed get_prep to call get_value_data when appropriate.
		there will thus only have to be the one call to terminate. */

	/* 5-18-71: fixed get_edit so that it does not count
	            or transmit NL characters.  */


/*
	This is the only procedure in the stream-directed input package
	which actually touches the input stream itself, hence does actual
	reads.
					*/


dcl (addr, addrel, divide, index, mod, null, string, substr) builtin;
dcl  based_int fixed bin (35) based;
dcl  p_vector (100) ptr based;
	dcl ( off_end_sw init(0),return_sw ,i,erno,gcn,gsn,
	      lout,gsi,count ) fixed bin(15);

	dcl (psp,pspp,fsbp) ptr;

	dcl condition char(10) init("ERROR");
	dcl ermsg char(9) init("plio2_get_util_");

	dcl ( ctl_char$np,ctl_char$nl,ctl_char$ht ) char(1) aligned external static;

	dcl x char(1) aligned;
	dcl 1 fakeinteger aligned based(addr(xint)),
		2 xx char(3) unaligned,
		2 intchar char(1) unaligned;
	dcl xint fixed bin(15) init(0);

	dcl ( iaction,iactstate,istate,itype,last_space) fixed bin(15);


	dcl 1 getfab2 aligned internal static,
		2 gfs bit(36) init("001001001"b),
		2 gfn char(32) init(""),
		2 ( gfbs,gfls,gfps) fixed bin(15) init(0);

	dcl 1 gu_data aligned based(ps.auxp),
		2 ii fixed bin(15),
		2 char256al char(256) aligned,
		2 first_non_space fixed bin(15);

	dcl plio2_get_util_$get_prep_ ext entry(ptr);
	dcl iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
	dcl plio2_open_$open_implicit_ ext entry(ptr);
	dcl put_copy_ ext entry(ptr,fixed bin(21));
	dcl plio2_gvd_ ext entry(ptr);
	dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));
	dcl ioa_ ext entry options(variable);

dcl iocb_p ptr;
dcl iocb_status fixed bin(35);
dcl error_table_$short_record fixed bin(35) external;
dcl error_table_$long_record fixed bin(35) external;
% include plio2_fsb;
% include plio2_ps;
% include iocb;




/*    	GET FIELD and SPACING ENTRIES */
get_field_data_:entry(pspp);
	/* will signal EOF unless field of length >0 of the form:
	   [<space>]...[<something>] {;|=}
	   is scanned.  MAY RETURN SHORT FIELD: {;|=}
	   leading <space>s are NOT returned
	   no <newline> characters are returned.
	   For the sake of "onfield" included <space>s are left, so
	   a field of the form:
	     "a(3, 5).          b(88  ,  99 )   ="
	   is possible.
	*/

	istate=2;
field_prep:
	psp=pspp;
	fsbp=ps.fsbp;
	lout=0;
	go to get_next_char;




get_field_edit_:entry(pspp);
	return_sw=1;
edit_set_up:
	psp=pspp;
	istate=1;
	count=ii;
	if count>256 then goto err149;
	go to field_prep;




get_field_list_:entry(pspp);
	/* will signal EOF or ERROR.
	   lout=0 returned to indicate [<space>]... {EOF | ,}
	   leading <space>s are required for "onfield", so
	   all <space>s except <newline>s (which are removed)
	   are left in place.  Thus, for example, a character representation
	   may not contain a <newline> (usefully, anyhow), for a <newline>
	   will not be returned.

	   Sets  first_non_space  for ease of scanning.
	*/
	istate=4;
	last_space=0;
	go to field_prep;




get_x_format_:entry(pspp);
	return_sw=0;
	go to edit_set_up;


get_skip_:entry(pspp);
	psp=pspp;
	gsn=ii;
	gsi=2;	/* return*/
	fsbp=ps.fsbp;
	go to do_skip;


get_column_:entry(pspp);
	psp=pspp;
	gcn=ii-1;		/* we shall skip to and over the column
			   preceding the named column so that the 
			   NEXT get will be from the numbered column */
	if gcn<0 then gcn=0;
	fsbp=ps.fsbp;
	go to do_column;



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

return_field:
	ii=lout;
	first_non_space=last_space+1;

check_transmission_error:
	if fsb.switch.transmit_error then go to set_trans_error;
	if fsb.switch.te_hold then
		do;
		fsb.switch.te_hold="0"b;
set_trans_error:
		ps.switch.transmit_error="1"b;
		end;

place(2):
gc_exit:
	return;

/*   	plio2_get_util_ character class table  */

	dcl gu_cc(0:61) fixed bin(3) internal static init(
	(9)0,	/* 000 ... 010 */
	3,4,	/* TAB,NL  */
	0,4,(19)0,	/* 013, NP, 015 ... 037 */
	2,0,7,	/* BLANK, 041, QUOTE  */
	(9)0,	/* 043 ... 053  */
	1,	/* COMMA */
	(14)0,	/* 055 ... 072 */
	5,0,6);	/* SEMI, 074 , EQUAL  */

/* ACTIONS and STATES - look O.K. 12-21-70 */

	dcl gu_matrix(9,0:8) fixed bin(9) static internal init(

/* STATE		OTHER COMMA BLANK   TAB  NPNL  SEMI EQUAL QUOTE OFFEND */
/*		    0     1     2     3     4     5     6     7     8  */

/* 1-edit */	   61,   61,   61,   61,   11,   61,   61,   61,   51,
/* 2-data prep */	   23,   12,   12,   12,   12,   32,   32,   23,   52,
/* 3-data loop */	   23,   23,   23,   23,   13,   33,   33,   23,   53,

/* 4-list prep */	   29,   44,   24,   24,   14,   74,   29,   25,   54,
/* 5-list odd  quote*/ 25,   25,   25,   25,   25,   25,   25,   26,   55,
/* 6-list even quote */29,   76,   76,   76,   76,   76,   29,   25,   76,
/* 7-skip */			(8)87,57,
/* 8-column */			(8)98,58,
/* 9-unquoted */	   29,   76,   76,   76,   76,   76,   29,   29,   79);

/*   (action code, next state code )	*/


/* actions:
	1-get		2-move		3-move,exit
	4-list's comma	5-off the end	6-count for edit		
	7-eo_list		8-skip		9-column		*/

action(3):
		/* returns terminating EQ or SEMI
		   that character must be re-scanned and then
		   removed in the calling program  */
	lout=lout+1;
	if lout<257 then substr(char256al,lout,1)=x;
	go to return_field;

action(4):
			/* list-prep sees [<space>]...{EOF|,}  */
	lout=0;
	if fsb.lsep=1 | ^ps.job.list then goto return_field;	/* this is a second comma */
	fsb.lsep=1;	/* this is a first comma - mark it */
	go to get_next_char;
			/* lout=0 insures that the comma will not be passed
			   since there is nothing to move, "get next character"  */


action(5):
	/* off-end may be either ENDFILE or ERROR depending
	   on file/string
	   and on stoppage DURING meaningful scan or before (or after)
	   meaningful scan.  BASIS is unclear about purposes, but
	   generally says that EOF or EOS before the <space>s have
	   been scanned leads to EOF, but in the midst of a scan leads
	   to ERROR.  */

	if istate=2 then condition="ENDFILE";
	if istate=4 then if lout=0 then condition="ENDFILE";
				else goto action(4);
	if istate=1 then if lout=0 then condition="ENDFILE";

	goto err162;

action(6):
	/* count for edit and get_x_format_ */
	lout=lout+1;
	if return_sw^=0 then substr(char256al,lout,1)=x;
	if lout=count then  go to check_transmission_error;
	go to action(1);

action(7):
	/* we seem to have found an <input delimiter>  */
	if itype=8 /* off-end */
	then goto return_field;

	if x=";" then if ps.job.list then
		do;
		istate=9;
		goto action(2);
		end;
	else if istate=4 then lout=0;

	fsb.lsep=index(", 	"||"
;",x);
	if x=";" then
		ps.switch.semi_sep="1"b;
	go to return_field;

/*   */
err149:
		/* will not extract field of length over 256 */
	erno=149;
	goto sandr;

err162:
		/* string of string-option too short */
	if ^ps.job.string then goto err163;
	erno=162;
	goto sandr;

err163:
		/* EOF while scanning */
	erno=163;
	goto signal_endfile;

/*
err164:
		/* EOF already encountered 
	erno=164;
	goto signal_endfile;
*/

err165:
		/* get requires   input,stream  */
	erno=165;
	goto sandr;

err166:
		/* target of COLUMN lies inside a TAB */
	erno=166;
	goto sandr;

signal_endfile:
	condition="endfile";
	goto sandr;

sandr:
	if ps.job.string then condition="ERROR";

	call plio2_signal_$s_r_(psp,condition,ermsg,erno);
	/* signals and causes abnormal return */

/*  */
move:
action(2):		/*  <newline> is never made part of the string to be returned   */
	if x=ctl_char$nl then goto get_next_char;

	lout=lout+1;
	if istate=4 then last_space=lout;
	if lout>256 then go to return_field;
	substr(char256al,lout,1)=x;

get_next_char:
action(1):
	if bnc>blc then
		do;
get_replenish:
		bnc=1;	/* we will attempt to fill up the buffer
			   and we start at position 1		*/
		if ps.job.copy then
			do;
			call put_copy_(psp,fsb.blc);
			ps.start_copy=1;
			end;

		if ps.job.string then goto string_is_empty;
		if fsb.switch.not_used_4 then goto file_at_eof; 	/* OLD EOF FLAG */
		if fsb.switch.transmit_error then
			do;
			fsb.switch.transmit_error="0"b;
			fsb.switch.te_hold="1"b;
			end;

		iocb_p=fsb.iocb_p;
		call iox_$get_line(iocb_p,fsb.bptr,fsb.bsize,fsb.blc,iocb_status);
		if iocb_status ^=0 then
			do;
			if iocb_status=error_table_$long_record then;  else
			if iocb_status=error_table_$short_record  then;  else
			fsb.transmit_error = "1"b;
			end;

		if fsb.blc^=0 then go to buffer_replenished;
file_at_eof:
		fsb.switch.not_used_4="1"b;		/* EOF ACTION */
string_is_empty:
		off_end_sw=1;
buffer_replenished:
		if off_end_sw^=0 then
			do;
			itype=8;
			go to re_act;
			end;
		end;

	x=substr(xbuf,bnc,1);
	bnc=bnc+1;

	if x=ctl_char$nl then
			/* new line character . . .   */
		do;
		kol=0;
		go to get_itype;
		end;

	if x=ctl_char$ht then
			/* horizontal tab character */
		do;
		kol=10+10*(divide(kol,10,15,0));
		go to get_itype;
		end;

	if x=ctl_char$np then goto get_itype;
			/* new page character  */

	kol=kol+1;

get_itype:
	intchar=x;
	if xint>61 then itype=0;	/* other */
	else itype=gu_cc(xint);

re_act:
	iactstate=gu_matrix(istate,itype);
	iaction=divide(iactstate,10,15,0);
	istate=mod(iactstate,10);
	go to action(iaction);


/*  */
/*  CODE for SKIP and COLUMN  */




do_column:
	if kol=gcn then go to gc_exit;
	if kol > gcn then
		do;
		gsi=4;
		gsn=1;
		go to do_skip;	/* try to find column in next line */
place(4):		go to do_column;
		end;
	istate=8;
	go to get_next_char;
action(9):
	if kol=0 then go to gc_exit;
	if kol=gcn then go to gc_exit;
	if kol<gcn then go to get_next_char;

	/* kol > gcn :      a tab has carried us over the desired column */
	goto err166;


do_skip:
	istate=7;

	if fsb.lsep=4 /* NL */ then gsn=gsn-1;

	do i= 1 to gsn;
	go to get_next_char;
action(8):
	if x=ctl_char$nl then go to dse;		/* kol=0      doesn't work now that there is NP */
	go to get_next_char;
dse:	end;

	if gsi=6 then goto return_from_prep_skip;
	go to place(gsi);

/* 	TERMINATE and PREP  for GET     */
get_terminate_:entry(pspp);
	psp=pspp;
	if ps.prep^=0 then call plio2_get_util_$get_prep_(psp);
				/* Due to a change in pl1_operator_'s
				   entry stream_prep, the prep work will
				   be done prior to the first transmission
				   or terminate call.   */
	fsbp=ps.fsbp;
	if ps.job.copy then call put_copy_(psp,fsb.bnc-1);
	if ^ps.job.list then fsb.lsep=1;	/* so that following comma
					   will be 2nd comma */
	return;

get_prep_:entry(pspp);
	plio2_data_$pspstat,
	psp=pspp;
	ps.prep=0;

	string(ps.switch)="0"b;
     /* STRING OPTION */
	if ps.job.string then
		do;
		plio2_data_$pliostringfsbp,
		plio2_data_$fsbpstat,
		ps.fsbp,
		fsbp=	ps.source_p;		/* for STRING OPTION
					   source_p points to the fake FSB
					   and fake FSB's bptr is addr(string).
					   length(string) is in ps.number */

		bnc=1;
		kol=0;

		if ps.varying_string then i=addrel(bptr,-1)->based_int;
		else i=ps.number;

		bsize,blc=i;

		fsb.title,fsb.filename="""get_string_option""";
		/* for string option,
			fsb.buffer,
			fsb.path_name,
			fsb.declared_attributes(2)
		   must not be used - fake_fsb is too short */


		string(fsb.switch)="001101001"b;
		ps.file_p=null;
		go to prep_exit;
		end;

     /* FILE OPTION - EXPLICIT OR IMPLICIT */
	if ps.job.explicit_file then
		ps.file_p=ps.source_p;
	else	do;
		call ioa_("error in get prep: no explicit file");
		ps.file_p=addr_sysin();
		ps.job.explicit_file="1"b;
		end;

	ps.fsbp,fsbp,plio2_data_$fsbpstat=ps.file_p->p_vector(2);
	if fsb.switch.open then go to open1;
	plio2_data_$fab2pstat,ps.fab2p=addr(getfab2);
	call plio2_open_$open_implicit_(psp);
open1:
	/* if fsb.switch.eof then goto err164;  */
	if fsb.switch.input="0"b|fsb.switch.stream="0"b then goto err165;
prep_exit:
	if ps.job.copy then
		do;
		ps.start_copy=bnc;
		call put_copy_(psp,-1);	/* SIGNAL to OPEN the COPY-FILE */
		end;
	if ps.job.skip then
		do;
		gsi=6;	/* and then return */
		gsn=ps.number;
		go to do_skip;
return_from_prep_skip:
place(6):
		end;

	if ps.job.data then call plio2_gvd_(psp);

	return;

addr_sysin:proc returns(ptr);
	dcl sysin file input stream;
	return(addr(sysin));
end addr_sysin;

end plio2_get_util_;




		    plio2_gvd_.pl1                  10/03/83  1722.3rew 10/03/83  1005.4       61740



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

plio2_gvd_:
gvd_:gvd:
get_value_data_:proc(pspp) options(support);


/* updated 9-13-72 */
	/* 9-13-72: conforming to AG94 */



	dcl ( erno init(999), ignore,tsub,num_sw,sign,
	     bnc,blc,oi,ns_len,vs_len,first_non_space) fixed bin(15);
	dcl ( pspp,psp,bp) ptr;

	dcl 1 ldi aligned,
		2 l fixed bin(15),
		2 chars char(256) aligned,
		2( name_l,isub,sub(128)) fixed bin(15);

	dcl condition_name char(5);
	dcl value_saved char(256) aligned;
	dcl name_saved char(256) aligned;	/* needed since ldi.chars is
				   overwritten in the call to
				   get_field_list.   */



	dcl based_int fixed bin (35) based;
	dcl 1 fakeint aligned based(addr(xint)),
		2 aaa char(3) unaligned,
		2 xchar char(1) unaligned;
	dcl xint init(0) fixed bin(15);
	dcl x char(1) aligned;
	dcl (iaction,istate,itype,iactstate,strlen) fixed bin(15);
	dcl fake_arg bit(1) unaligned based;


	dcl plio2_gdt_$get_data_temp_ ext entry(ptr);
	dcl plio2_get_util_$get_field_data_ ext entry(ptr);
	dcl plio2_get_util_$get_field_list_ ext entry(ptr);
	dcl plio2_get_util_$get_prep_ ext entry(ptr);
	dcl plio2_get_util_$get_terminate_ ext entry(ptr);
	dcl plio2_ldi_ ext entry(ptr);
	dcl plio2_signal_$s_l_ ext entry(ptr,char(*),char(*),fixed bin(15),char(*),fixed bin(15),fixed bin(15),fixed bin(15));
	dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15));
	dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));

dcl ( addr,divide,min,mod,null,substr ) builtin;

% include plio2_ps;






/*  	CODE STARTS  */

	psp=pspp;
	ps.auxp=addr(ldi);
	/* there is no need to call GET_PREP
	   for GVD is called from GET_PREP after prep work is done */
	ps.switch.semi_sep="0"b;
loop:
	if ps.switch.semi_sep then go to exit;
	call plio2_get_util_$get_field_data_(psp);
	if ldi.l>256 then goto err143;
	name_saved=ldi.chars;
	ns_len=ldi.l;

	if substr(ldi.chars,ldi.l,1)=";" then goto exit;
	if ldi.l=0 then goto loop;

get_datum:
	call plio2_get_util_$get_field_list_(psp);
	if ldi.l=0 then goto loop;
	value_saved=ldi.chars;
	vs_len=ldi.l;
	first_non_space=ldi.name_l;
	if substr(value_saved,first_non_space,1)=";" then goto exit;


	ldi.chars=name_saved;
	ldi.l=ns_len;

	goto id_parse;
OK:
	call plio2_gdt_$get_data_temp_(psp);
	if ps.vp=null then
		do;
		addr(erno)->based_int=addr(ps.descr)->based_int;
		erno=erno+63;	/* yields 135-140: see plio2_gdt_  */
		go to NG_1;
		end;


	ldi.l,vs_len=vs_len+1-first_non_space;
	ldi.chars=substr(value_saved,first_non_space,vs_len);

	call plio2_ldi_(psp);
	go to loop;

/*  */
NG:
	erno=istate+125;
		/*   (...) appears illegally in datum identifier:

			126:misc		127:numeric	128:sign
			129:comma		130:equal		131:parens
			132:dollar-or-_	133:dot		134:alphabetic
		*/
NG_1:
	vs_len=min(vs_len,256-ns_len);
	name_saved=substr(name_saved,1,ns_len)
	         ||substr(value_saved,1,vs_len);
	ns_len=ns_len+vs_len;
	if ps.job.string then condition_name="ERROR";
	else condition_name="NAME";
	call plio2_signal_$s_l_(psp,condition_name,"get_data",erno,
			substr(name_saved,1,ns_len),1,ns_len,0);

		do;
		ps.switch.transmit_error="0"b;
		goto loop;
		end;

	goto loop;

err123:
		/* problem in scan of datum identifier */
	erno=123;
	goto sandr;

err124:
	erno=124;
	goto sandr;	/* more than 128 subscripts */

err143:
			/* identifier longer than 256 */
	erno=143;
	goto sandr;


sandr:
	call plio2_signal_$s_r_(psp,"ERROR","get_data",erno);



exit:
	/* there is no need to call GET_TERMINATE for
	   GVD is called from GET_PREP from GET_TERMINATE itself ! !  */
	return;
/*   */
dcl data_char_class(0:127) fixed bin(9) internal static init(
		(9)10,	/* 000...010 */
		(2)11,	/* TAB,NL */
		(3)11,	/* VTAB, NPAGE, CRETURN */
		(18)10,	/* 016 ... 037 */
		11,	/* BLANK */
		10,	/* 041 */
		10,	/* QUOTE */
		10,	/* 043 */
		1,	/* DOLLAR */
		(3)10,	/* 045 ... 047 */
		6,7,	/* OPEN_PAR, CLOSE_PAR */
		10,	/* 052 */
		4,5,4,9,	/* PLUS, COMMA, MINUS, DOT */
		10,	/* 057 */
		(2)3,	/* ZERO, ONE */
		(8)3,	/* TWO, THREE, . . . NINE */
		10,	/* 072 */
		10,	/* SEMI */
		10,	/* 074 */
		8,	/* EQUAL */
		(3)10,	/* 076 ... 080 */
		(26)2,	/*  CAPS */
		(4)10,	/* 133 ... 136 */
		1,	/* UNDERSCORE */
		10,	/* 140 */
		(26)2,	/* LOWER CASE */
		(5)10	/* 173 ... 177 */
					);

/*	dollar,underscore	1
	letters		2
	numerals		3
	plus/minus	4
	comma		5
	open paren	6
	close paren	7
	equal sign	8
	dot		9
	junk		10
	ignorable		11 */


/*	field has NOT had leading  and intervening blank, tab, newpage, and newline
	characters removed by get_util_$get_field_data_.
	field terminates with the first equalsign or semicolon after the first character   */



	dcl data_mat(5,10) fixed bin(9) static internal init(
/* STATE		  $_   ALPH NUM  SIGN CMMA OPEN CLOZ EQU  DOT  JUNK*/
/* 1-prep */	  37,  12,  32,  33,  34,  36,  36,  35,  38,  31,
/* 2-name  */	  12,  12,  12,  33,  34,  23,  36,  00,  11,  31,
/* 3- presubscr */	  37,  39,  64,  64,  34,  36,  36,  35,  38,  31,
/* 4-subscr */	  37,  39,  74,  33,  83,  36,  85,  35,  38,  31,
/* 5- endlist */	  37,  39,  32,  33,  34,  36,  36,  00,  11,  31); 

/*
		(   ACTION    ,     new STATE      )


	actions:


	0	OK
	1	move
	2 	get
	3	NG
	6	set sign for ss
	7	set ss digit
	8	store ss
*/
/*  */
id_parse:
	istate=1;
	bnc=1;
	blc=ldi.l;
	ldi.isub=0;

	oi=0;
	go to action(2);

action(0):
	ldi.name_l=oi;	/* index of last character of name */
	go to OK;

action(1):
	/* ldi.chars already contains the identifier ("as.you.like.it(1,2,-3)=")
	   left adjusted.   */

	oi=oi+1;
	substr(ldi.chars,oi,1)=x;


action(2):
GET:
	if bnc>blc then goto err123;
	x=substr(ldi.chars,bnc,1);
	bnc=bnc+1;
	xchar=x;
	if xint>127 then
		do;
		itype=10;
		go to re_act;
		end;
	itype=data_char_class(xint);
	if itype=11 then goto GET;	/* ignore blanks and so on. */
re_act:
	iactstate=data_mat(istate,itype);
	istate=mod(iactstate,10);
	iaction=divide(iactstate,10,15,0);
transfer:
	go to action(iaction);

action(3):
	go to NG;

action(6):
	if x="-" then sign=1;
	else sign=0;

	tsub=0;
	if itype=4 then
		do;		/* sign */
		num_sw=0;
		goto GET;
		end;
	num_sw=1;			/* a number has appeared in the current subscript */

action(7):
	num_sw=1;
	tsub=10*tsub+xint -48;
	go to GET;

action(8):
	if num_sw=0 then
		do;		/* bad subscript consisting of a sign only */
		istate=itype-1;
		goto NG;
		end;
	if sign=1 then tsub=-tsub;
	isub=isub+1;
	if isub>128 then goto err124;
	ldi.sub(ldi.isub)=tsub;
	go to GET;


end plio2_gvd_;




		    plio2_gvl_.pl1                  05/14/87  1614.8rew 05/14/87  1551.5      198207



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


/****^  HISTORY COMMENTS:
  1) change(87-03-05,Huen), approve(87-03-05,MCR7629), audit(87-04-15,RWaters),
     install(87-05-14,MR12.1-1030):
     Fix PL/1 error 2142 -
     Signal the error condition when the string supplied has insufficient data
     for the "get" statement.
                                                   END HISTORY COMMENTS */

plio2_gvl_:
get_value_list_:
     procedure (p_ps_ptr) options (support);

/*        Modified: 9 January 1987 by S. Huen to signal the error condition when the string supplied has insufficient data for the "get" statement */
/*	Modified:	18 July 1978 by R. A. Barnes to make gvl more quit-start proof if blocked */

/*	Modified: 4 April 1978 by Peter C. Krupp to implement radix-n bit strings for get list	*/

/*	Modified:	20 December 1977 by Richard A. Barnes to fix 1695 (get string)	*/

/* Rewritten Spring 1977 by R.Schoeman as part of the quick stream_io package.
   Recoded 770612 by PG to maintain fsb.kol accurately, and to use algorithms similar to EIS lex.
   package.

   This procedure is called once for each item in a data list
   in a get list statement. It is called at runtime by pl1_operators_ through the entrypoint
   get_value_list_.  Section 12.14 (GET statement) of AG94 describes in detail
   the language-defined actions which are performed by this program.	*/

/* parameters */

declare	p_ps_ptr ptr parameter;			/* ptr to PS */

/* automatic */

declare	BIT_STRING bit (1) aligned,
	bit256 bit (256) varying aligned,
	break fixed bin (21),
	code fixed bin (35),
	convert_index fixed bin (15),
	erno fixed bin (15),			/* oncode number */
	error_string char (1000) varying,		/* used when raising conversion */
	first_bit fixed bin (15),
	first_char fixed bin (21),
	in_ptr ptr,
	iocbp ptr,
	left fixed bin (21),
	onchar_index fixed bin (15),
	pic_buf char(64),
	pic_ptr ptr,
	psp ptr,
	RADIX_FACTOR fixed bin(15),
	rn_digit char(1) aligned,
	rn_value fixed bin(15),
	scan_index fixed bin (21),
	scan_start fixed bin (21),
	targ_ptr ptr,
	token_length fixed bin (21),
	token_start fixed bin (21),
	token_string char (257) varying;

/* based */

declare	buffer_array (1044480) char (1) unaligned based (fsb.bptr);

/* builtins */

declare	(addr, addrel, binary, bit, divide, index, length, reverse, search, substr, verify, unspec) builtin;

/* conditions */

declare	conversion condition;

/* entries */

declare	iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	plio2_get_util_$get_prep_ entry (ptr),
	plio2_signal_$conversion_error_ entry (ptr, char (*), fixed bin (15), ptr, fixed bin (15), fixed bin (15), fixed bin (15)),
	plio2_signal_$s_ entry (ptr, char (*), char (*), fixed bin (15)),
	plio2_signal_$s_r_ entry (ptr, char (*), char (*), fixed bin (15)),
	plio2_resig_ entry (ptr),
	put_copy_ entry (ptr, fixed bin (21));

/* external static */

dcl (error_table_$short_record,
     error_table_$long_record,
     error_table_$end_of_info) external static fixed bin (35);

/* internal static */

declare (	HT char (1) aligned initial ("	"),
	NL char (1) aligned initial ("
"),
	QUOTE char (1) aligned initial (""""),
	HT_NL_quote char (3) aligned initial ("	
"""),
	HT_NL_SP_comma char (4) aligned initial ("	
 ,")
	) internal static;

declare	max_io_string_length internal static options(constant) initial(256);

/* include files */

%include plio2_ps;
%include plio2_fsb;
%include pl1_stack_frame;
%include desc_dcls;
%include desc_types;
%include descriptor;
%include picture_desc_;
%include picture_image;
%include picture_util;
%include radix_factor_constants;

/* program */

	psp = p_ps_ptr;

	if ps.prep ^= 0
	then call plio2_get_util_$get_prep_ (psp);

	iocbp = ps.fsbp -> fsb.iocb_p;
	BIT_STRING = "0"b;
	RADIX_FACTOR = 0;

	on conversion call plio2_resig_ (psp);

init_scan:
	left = fsb.blc - fsb.bnc + 1;
	first_char = verify (substr (xbuf, fsb.bnc, left), " ");

	if first_char = 0
	then do;					/* rest of string was blanks */
		call refill_buffer_ldi;
		if code ^= 0
		then go to raise_eof;
		go to init_scan;
	     end;

	fsb.kol = fsb.kol + first_char - 1;
	fsb.bnc = fsb.bnc + first_char - 1;		/* step over blanks */

	if substr (xbuf, fsb.bnc, 1) = NL
	then do;
		fsb.kol = 0;			/* reset current column */
		fsb.bnc = fsb.bnc + 1;		/* step over newline */
		go to init_scan;
	     end;

	if substr (xbuf, fsb.bnc, 1) = HT
	then do;
		fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0);
		fsb.bnc = fsb.bnc + 1;		/* step over HT */
		go to init_scan;
	     end;

	if substr (xbuf, fsb.bnc, 1) = ","
	then do;
		fsb.kol = fsb.kol + 1;
		fsb.bnc = fsb.bnc + 1;		/* step over comma */

		if fsb.lsep = 2
		then do;				/* last separator was not a comma... */
			fsb.lsep = 1;		/* let this comma pass by */
			goto init_scan;
		     end;
						/* last separator was a comma...this comma means */
		return;				/* two commas in a row...input item is unchanged */
	     end;
	else if substr (xbuf, fsb.bnc, 1) = QUOTE	/* current char is a quote? */
	     then do;				/* yes...scan a quoted string */
		     scan_start = fsb.bnc + 1;	/* start copying after quote */
		     token_start = scan_start;
		     token_length = 0;

rescan:
		     scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_quote);

		     if scan_index = 0
		     then do;			/* eof while looking for closing quote */
			     if token_start = 0	/* copy has begun */
			     then token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1);
			     else do;
				     token_string = substr (xbuf, token_start, fsb.blc - token_start + 1);
				     token_start = 0;
				end;

			     call refill_buffer_ldi;
			     if code ^= 0
			     then go to err163;	/* error -- end of file */

			     scan_start = 1;
			     go to rescan;
			end;

		     fsb.kol = fsb.kol + scan_index - 1;	/* update kol but not scan_start just yet */

		     if substr (xbuf, scan_start + scan_index - 1, 1) = NL
		     then do;
			     /* AG94 says ignore newlines inside quoted strings when in
			        list-directed input.  So we do. Ugh. */

			     fsb.kol = 0;

			     if token_start > 0	/* if not copied yet, copy now */
			     then do;
				     token_string = substr (xbuf, token_start, token_length);
				     token_start = 0;
				end;

			     token_string = token_string || substr (xbuf, scan_start, scan_index - 1);
			     scan_start = scan_start + scan_index;
			     go to rescan;
			end;
		     else if substr (xbuf, scan_start + scan_index - 1, 1) = HT
			then do;
				fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0);

				if token_start = 0
				then token_string = token_string || substr (xbuf, scan_start, scan_index);
				else token_length = token_length + scan_index;

				scan_start = scan_start + scan_index;
				go to rescan;
			     end;

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

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

		     scan_start = scan_start + scan_index;
		     fsb.kol = fsb.kol + 1;		/* step over quote */

		     /* Now look for a quote immediately following, which means we have two quotes in a row. */
		     /* First make sure we are not at the end of the buffer */

		     if scan_start > fsb.blc
		     then do;
			     if token_start > 0	/* if not copied yet, copy now */
			     then do;
				     token_string = substr (xbuf, token_start, token_length);
				     token_start = 0;
				end;

			     call refill_buffer_ldi;
			     if code ^= 0
			     then goto finish;		/* eof encountered */
			     scan_start = 1;
			end;

		     if substr (xbuf, scan_start, 1) = QUOTE
		     then do;
			     if token_start > 0	/* if not copied yet, copy now */
			     then do;
				     token_string = substr (xbuf, token_start, token_length);
				     token_start = 0;
				end;

			     token_string = token_string || QUOTE;
			     fsb.kol = fsb.kol + 1;
			     scan_start = scan_start + 1;
			     go to rescan;
			end;

		     /* We have now parsed the quoted section of the string...scan until the next
		        space or comma and include those characters, too. */

find_break:
		     break = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma);
		     if break = 0
		     then do;			/* eof while looking for delimiters */
			     if token_start > 0	/* if not copied yet, do it now */
			     then do;
				     token_string = substr (xbuf, token_start, fsb.blc - token_start + 1);
				     token_start = 0;
				end;
			     else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1);

			     call refill_buffer_ldi;
			     if code ^= 0
			     then goto finish;	/* AG94 says this is a legal termination, not an error */

			     scan_start = 1;
			     goto find_break;
			end;

		     fsb.kol = fsb.kol + break - 1;

		     if substr (xbuf, scan_start + break - 1, 1) = HT
		     then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0);
		     else if substr (xbuf, scan_start + break - 1, 1) = NL
			then fsb.kol = 0;

						/* determine whether we have a bit string */
		     if break = 2			/* exactly one char after trailing quote */
		     then if substr (xbuf, scan_start, 1) = "b"	/* and that char is "b" */
			then do;
			     RADIX_FACTOR = 1;
			     BIT_STRING = "1"b;
			     end;

						/* determine whether we have a radix-n (n=2,4,8,16) bit string */
		     if break = 3			/* exactly two characters after the trailing quote */
		     then do;
			     RADIX_FACTOR = index ("1234", substr (xbuf, scan_start + 1, 1));

			     if substr (xbuf, scan_start, 1) = "b" & RADIX_FACTOR ^= 0
			     then BIT_STRING = "1"b;

			end;

		     fsb.bnc = scan_start + break;	/* step over scanned chars and over delim */

		     if break > 1			/* if trailing stuff after closing quote... */
		     then do;
			     if token_start > 0	/* ...and not yet copied */
			     then do;		/* ...copy it now. */
				     token_string = substr (xbuf, token_start, token_length);
				     token_start = 0;
				end;

			     /* At this point, token_string contains the (unquoted) portion of the
			        input item that was originally quoted, and substr (xbuf, scan_start, break - 1)
			        contains the portion of the input item that appeared after the quoted part
			        and before the delimiter. */

			     if ^BIT_STRING
			     then do;			/* unknown text immediately follow closing quote of a character string */
				     erno = 167;
				     call conversion_error;
				end;

			end;
		end;				/* end quoted string section */
	     else do;				/* scan an unquoted input item */
		     scan_start = fsb.bnc;
		     token_start = scan_start;	/* token starts at first char */
		     token_length = 0;

find_break_nq:
		     scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma);
		     if scan_index = 0                  /* token ends at the end of buffer */
		     then do;
			     if token_start > 0	/* if not copied, copy & concatenate */
			     then do;
				     token_string = substr (xbuf, token_start, fsb.blc - token_start + 1);
				     token_start = 0;
				end;
			     else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1);

			     fsb.bnc = fsb.bnc + fsb.blc - scan_start + 1;   /* step over token */
			     call refill_buffer_ldi;
			     if code ^= 0
			     then go to finish;	/* not an error -- normal termination */

			     scan_start = 1;
			     go to find_break_nq;
			end;

		     fsb.kol = fsb.kol + scan_index - 1;	/* update kol but not scan_start yet */

		     if substr (xbuf, scan_start + scan_index - 1, 1) = HT
		     then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0);
		     else if substr (xbuf, scan_start + scan_index - 1, 1) = NL
			then fsb.kol = 0;

		     if token_start > 0
		     then token_length = token_length + scan_index - 1;
		     else token_string = token_string || substr (xbuf, scan_start, scan_index - 1);

		     fsb.bnc = scan_start + scan_index;	/* step over scanned chars & delim */
		end;

	if substr (xbuf, fsb.bnc - 1, 1) = ","		/* item terminated by comma? */
	then fsb.lsep = 1;				/* yes...next comma means null item */
	else fsb.lsep = 2;				/* no....next comma is ignored */

/* We have now parsed the input item....convert it to the type of the target */

finish:
	if token_start > 0				/* token has not been copied */
	then do;
		intype = char_desc * 2;
		in_ptr = addr (buffer_array (token_start));	/* use substraddr when available! */
		inscale_prec = token_length;

		if token_length > max_io_string_length
		then go to err172;

	     end;
	else if BIT_STRING
	     then do;

		     if length (token_string) > max_io_string_length
		     then go to err172;

		     if RADIX_FACTOR = 1		/* radix-2 bit string - no radix conversion necessary */
		     then do;
			     bit256 = bit (token_string);
			     intype = v_bit_desc * 2;
			     in_ptr = addr (bit256);
			     inscale_prec = length (bit256);
			end;
		     else do;			/* radix-4, 8, or 16 bit string - radix conversion necessary */

			     if length (token_string) * RADIX_FACTOR > max_io_string_length
			     then go to err171;

			     if RADIX_FACTOR = 4	/* radix-16 bit string - are hexadecimal digits upper or lower case */
			     then if search (token_string, capital_hex) > 0
				then substr (digits (4), 11, 6) = capital_hex;
				else substr (digits (4), 11, 6) = lower_case_hex;

			     bit256 = ""b;

			     do convert_index=1 to length(token_string);	/* convert from radix-n to radix-2 */
				rn_digit = substr (token_string, convert_index, 1);
				rn_value = index (digits (RADIX_FACTOR), rn_digit);

				if rn_value = 0
				then do;
					onchar_index = convert_index;
					erno = 168;
					error_string = token_string;
					call conversion_error_for_RADIX_N;
					go to finish;		/* retry conversion with value returned from on unit */
				     end;

				first_bit = RADIX_FACTOR * (rn_value - 1) + 1;
				bit256 = bit256 || substr (expand_bits (RADIX_FACTOR), first_bit, RADIX_FACTOR);
			     end;

			     intype = v_bit_desc * 2;
			     in_ptr = addr (bit256);
			     inscale_prec = length (bit256);
			end;
		end;
	     else do;
		     intype = v_char_desc * 2;
		     in_ptr = addr (token_string);
		     inscale_prec = length (token_string);

		     if length (token_string) > max_io_string_length
		     then go to err172;

		end;

	ps.vp = ps.value_p;
	ps.descr = ps.descriptor;

	if ps.descr = "0"b
	then do;
	     pic_ptr = psp -> ps.stack_frame_p -> pl1_stack_frame.text_base_ptr;
	     pic_ptr = addrel (pic_ptr, psp -> ps.top_half);

/* The following block of code should be similiar to or
   identical with the int. subroutine "set_pic_args" in plio2_qge.	*/

	     outtype = type (pic_ptr -> picture_image.type);
	     outfo.outscale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor;
	     if outtype = char_desc * 2
	     then outfo.outprec = pic_ptr -> picture_image.varlength;
	     else outfo.outprec = pic_ptr -> picture_image.prec;

/* end of "set_pic_args"  	*/

	     call assign_ (addr (pic_buf), outtype, outscale_prec, in_ptr, intype, inscale_prec);
	     call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (pic_buf) -> char1);
	end;
	else do;
	     unspec (desc_) = unspec (ps.descr);
	     outtype = desc_.type_ * 2 + binary (desc_.pack_, 1);

	     if outtype = v_char_desc * 2 | outtype = v_bit_desc * 2
	     then targ_ptr = addrel (ps.value_p, -1);
	     else targ_ptr = ps.value_p;

	     outfo.outscale = desc_.scale_;
	     outfo.outprec = desc_.precision_;
	     call assign_ (targ_ptr, outtype, outscale_prec, in_ptr, intype, inscale_prec);
	     end;

no_assign:				/* target of go to in conversion_error - transfer here when input item is to be left unchanged */
	return;

raise_eof:
	if  ^ ps.string
	then do;
	     call plio2_signal_$s_r_ (psp, "endfile", "quick_get_list", 163);
	     return;
	     end;

err163:
	if ps.string
	     then erno = 162;			/* the string supplied with string option	*/
						/* has insufficient data for this get statement.	*/
	     else erno = 163;			/* end_of_file encountered while executing get statement.	*/
	go to any_err;


err171:
	erno=171;					/* radix-factor bit string has a expanded length that exceeds 256 bits */
	go to any_err;

err172:
	erno=172;					/* string whose length exceeds 256 not handled by plio2_ */

any_err:
	call plio2_signal_$s_r_ (psp, "ERROR", "quick_get_list", erno);
	return;

/* The following procedure refills the buffer and returns with code = 0
   if all went well, otherwise either raises an error itself or
   returns with a non-zero value of code, depending on AG-94's defined action.	 */

refill_buffer_ldi:
	procedure;

	     if ps.copy
	     then do;
		     call put_copy_ (psp, fsb.blc);
		     ps.start_copy = 1;
		end;

	     if ps.string
	     then do;
		code = error_table_$end_of_info;
		return;
		end;

	     fsb.blc = 0;	/* protects us somewhat from quit-start */
	     fsb.bnc = 1;	/* .. */

	     if fsb.console
	     then call iox_$get_line (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code);
	     else call iox_$get_chars (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code);

	     fsb.bnc = 1;

	     if code ^= 0
	     then if (code = error_table_$short_record) | (code = error_table_$long_record)
		then code = 0;
		else if code ^= error_table_$end_of_info
		     then do;
			     call plio2_signal_$s_ (psp, "TRANSMIT", "quick_get_list", 153);
			     return;
			end;
	     return;

	end /* refill_buffer_ldi */;

/* The following procedure processes conversion errors encountered during The execution
   of get list statements.  It also validates the corrected onsource string and raises the conversion
   condition again if necessary.	*/

conversion_error:
	procedure;

	     /* AG94 (and ANSI) says raise conversion here. But since we have
	        not been saving the original input string (in the interests
	        of speed), we have to reconstruct it. Ugh. */

	     error_string = QUOTE;
	     do scan_index = 1 to length (token_string);
		if substr (token_string, scan_index, 1) = QUOTE
		then error_string = error_string || QUOTE;

		error_string = error_string || substr (token_string, scan_index, 1);
	     end;
	     error_string = error_string || QUOTE;
	     error_string = error_string || substr (xbuf, scan_start, break - 1);

	     if substr (xbuf, scan_start, 1) = "b"	/* "..."b... ??? */
	     then break = break - 1;	/* set onchar to char after b */

	     onchar_index = length (error_string) - break + 2;

conversion_error_for_RADIX_N:
	entry;

raise_conversion:
	     call plio2_signal_$conversion_error_ (psp, "quick_get_list",
		erno, addrel (addr (error_string), 1), 1, length (error_string),
		onchar_index);

	     if erno = 168
	     then do;			/* radix conversion error occurred - go back */
		     token_string = error_string;
		     return;
		end;

	     /* Now check the returned onsource of validity. */

	     if substr (error_string, 1, 1) = QUOTE
	     then do;
		     error_string = rtrim (error_string);	/* ignore white space to the right fo quoted string */
		     if substr (error_string, length (error_string) - 1, 2) = """b"
		     then do;
		          BIT_STRING = "1"b;
			RADIX_FACTOR = 1;
		          token_string = substr (error_string, 2,
		     	length (error_string) - 3);
		     end;
		     else if substr (error_string, length (error_string), 1) = QUOTE
		     then do;
		     	BIT_STRING = "0"b;
		     	token_string = "";
		     	do scan_index = 2 to length (error_string) - 1;
		     	     if substr (error_string, scan_index, 1) = QUOTE
		     	     then do;
		     		     scan_index = scan_index + 1;
		     		     if substr (error_string,
		     			scan_index, 1) ^= QUOTE
		     		     then do;
		     			     onchar_index = scan_index;
		     			     go to raise_conversion;
		     			end;
		     		end;

		     	     token_string = token_string || substr (
		     		error_string, scan_index, 1);
		     	end;

		     	if token_string = ""
		     	then go to no_assign;	/* null item...no assign */

		          end;
		     else if substr (error_string, length (error_string) - 2, 2) = """b"
		          then do;
		     	     RADIX_FACTOR = index ("1234", substr (error_string, length (error_string), 1));
		     	     if RADIX_FACTOR ^= 0
		     	     then do;
		     		     BIT_STRING = "1"b;
		     		     token_string = substr (error_string, 2, length (error_string) - 4);
		     		end;
		     	     else do;
		     		     onchar_index = length (error_string);
		     		     go to raise_conversion;
		     		end;
		     	end;
			else do;
			     onchar_index = length (error_string) -
				index (reverse (error_string), QUOTE) + 2;

			     if onchar_index < length (error_string)
			     then if substr (error_string, onchar_index, 1) = "b"
				then do;
					onchar_index = onchar_index + 1;
					if onchar_index < length (error_string)
					then if index ("1234", substr (error_string, onchar_index, 1)) ^= 0
					     then onchar_index = onchar_index + 1;
				     end;

			    go to raise_conversion;
			    end;
		end;
	     else if error_string = ""
		then do;
			onchar_index = 1;
			go to raise_conversion; /* onsource cannot be blanks */
		     end;
		else do;				/* onsource OK */
			BIT_STRING = "0"b;
			token_string = error_string;
		     end;

	end /* conversion_error */;


     end /* plio2_gvl_ */;




		    plio2_ldi_.pl1                  10/03/83  1722.3rew 10/03/83  1005.4       38187



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

plio2_ldi_:proc(pspp) options(support);


/* updated 5-5-71 */
/* updated 10-73 for
	a) new conversion routines
	b) new BASIS/1-10 inspired converting rules
*/

dcl  based_chars char (1044480) based;
dcl ( oncharind,oci,bnc,blc,istore,istate,erno,i,fnb,sn) fixed bin(15);

dcl	(sp,bp,psp,pspp,picture_p) ptr;

dcl temp_answer bit(2304) aligned;
dcl output256 char(256) aligned based(addr(temp_answer));
dcl bit256varying bit(256) aligned varying;
dcl x char(1) aligned;

dcl	buffer char(64) aligned;

dcl 1 ldi aligned based,
	2 l fixed bin(15),
	2 char256 char(256) aligned;

dcl QUOTE char(1) aligned static internal init("""");
dcl char_vector(1000) unaligned based;

dcl	(addr,addrel,bit,fixed,substr,unspec,length,verify) builtin;

dcl	plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15));
dcl	plio2_signal_$conversion_error_ ext entry(ptr,char(*),fixed bin(15),ptr,fixed bin(15),fixed bin(15),fixed bin(15));

dcl	plio2_resig_ ext entry(ptr);
dcl	conversion condition;

%include desc_dcls;
%include desc_types;
%include descriptor;
%include picture_util;
% include plio2_ps;

/* A character string, S, is given which is not of zero length.
   It has neither leading nor trailing blanks or other spaces.
   (get_util_ returns the string ldi.chars _w_i_t_h leading <space>s
   but gvd and gvl remove them before calling ldi.)

   Case 1.  S::= {"xxx"}...
	remove outside quotes, doubled inside quotes to yield SS
	assign SS to target, leaving "assign" to raise CONVERSION.
   Case 2.  S::= {"xxx"}...b
	remove outside quotes and final b and doubled inside quotes to obtain SS
	assign SS to bit256varying to obtain a bit string B of effective length L
	("assign" may raise CONVERSION)
	assign B-L to target.
   Case 3.  S::= something else.
	assign S to target, leaving "assign" to raise CONVERSION.

C A U T I O N

   This is a very new idea, obtained from BASIS/1-10 with a lot of SALT.
   Examine BASIS/1-11 and BASIS/1-12 carefully for conformance.

   Also note that a lot of error-numbers are no longer used (here at least),
   since CONVERSION will now be raised by "assign" in ALL cases.

				P. A. Belmont  10-13-73
*/
	psp=pspp;
	istore=0;
	blc=ps.auxp->ldi.l;
	if blc > 256
	then call plio2_signal_$s_(psp,"ERROR","ldi",242);

	bp=addr(ps.auxp->ldi.char256);




	on conversion call plio2_resig_(psp);

	x=substr(bp->based_chars,1,1);
	if x=QUOTE then go to is_quoted;

output_original_CS:

	sp=bp;
	sn=blc;
	intype=char_desc*2;

output:
	call assign_type_d(ps.descr,psp,picture_p,outtype,outscale_prec);

	if ps.descr="0"b
	then do;
		call assign_(addr(buffer),outtype,outscale_prec,sp,intype,(sn));
		call pack_picture_(ps.vp->char1,picture_p->char1,addr(buffer)->char1);
	end;
	else do;
		unspec(desc_) = ps.descr;
		if type_=v_bit_desc
		|  type_=v_char_desc
		then	ps.vp = addrel(ps.vp,-1);

		call assign_(ps.vp,outtype,outscale_prec,sp,intype,(sn));
	end;

	if ps.switch.transmit_error then
		do;
		ps.switch.transmit_error="0"b;
		call plio2_signal_$s_(psp,"TRANSMIT","ldi",153);
		end;
	return;

is_quoted:
	istate=1;
	bnc=2;

get_x:
	if bnc>blc then
		do;
		if istate=1 then goto output_original_CS;
found_CS:
		intype = char_desc*2;
		sn = istore;
		sp=addr(output256);

		go to output;
		end;

	x=substr(bp->based_chars,bnc,1);
	bnc=bnc+1;
	go to action(istate);



action(1):
	if x=QUOTE then
		do;
		istate=2;
		go to get_x;
		end;

store_char:
	istore=istore+1;
	substr(output256,istore,1)=x;
	go to get_x;

action(2):
	if x=QUOTE then
		do;
		istate=1;
		go to store_char;
		end;

	if x^="b" then goto output_original_CS;
	bit256varying=bit(substr(output256,1,istore));
	sn=length(bit256varying);	/* if CONVERSION is signalled, length may no longer be = istore */
	sp=addr(bit256varying);
	intype=v_bit_desc*2;
	goto output;

end;




		    plio2_ldo_.pl1                  10/03/83  1722.3rew 10/03/83  1005.4       48915



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

	/* Modified: 05/01/78 by PCK to implement unsigned binary	*/

plio2_ldo_:proc(pspp) options(support);
put_value_list_:entry(pspp);

dcl	(pspp,psp,picture_p) ptr;

dcl	based_bit36 bit (36) aligned based;
dcl	based_chars char (1044480) based;
dcl	p_vector (100) ptr based;
	dcl based_bits bit(1000) unal based;
	dcl (code,erno,n_out,i ) fixed bin(15);
	dcl output char(516) unaligned;

	dcl v_output char(516) varying;

	dcl (addr,addrel,fixed,length,substr,unspec) builtin;

	dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15));
	dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15));
	dcl plio2_put_util_$put_prep_ ext entry(ptr);
	dcl dnd$with_strings ext entry(bit(36) aligned,ptr,fixed bin(15));

	dcl plio2_resig_ ext entry(ptr);
	dcl conversion condition;


	dcl based_VL fixed bin(35) based;

	dcl x char(1) aligned;
	dcl 1 descriptive aligned,
		2 type5 aligned,
			3 (cr,bd,ff,ls,pack) char(1) unal,
		2 ( prec,scale,bit_length,type) fixed bin(15);


%include desc_dcls;
%include desc_types;
%include descriptor;
%include picture_image;
%include picture_types;
%include picture_util;
% include plio2_fsb;
% include plio2_ps;
/* 		START   */
	psp=pspp;
	if ps.prep^=0 then call plio2_put_util_$put_prep_(psp);

	ps.vp=ps.value_p;
	ps.descr=ps.descriptor;
	go to common;


err232:
		/* bad descriptor of output item */
	erno=232;
	goto sandr;

string_too_big:
err242:
		/* strings of length >256 not handled */
	erno=242;
	goto sandr;

sandr:	call plio2_signal_$s_(psp,"ERROR","LDO",erno);
	return;

ldo_for_data:entry(pspp);
	psp=pspp;
		/*  desc & ptr have already been moved to ps.vp,ps.descr
		    and put_prep_ has already been called             */



common:
	on conversion call plio2_resig_(psp);

	i=0;
	substr(addr(i)->based_bit36,30,7)=substr(ps.descr,1,7);
	if i<77 then goto standard_types;		/* arithmetic data types 1-12	*/
	if i<83 then goto non_standard_types;		/* address, area, structure data types 13-18	*/
	if i<87 then goto standard_types;		/* string data types 19-22	*/
	if i=87 then goto non_standard_types;		/* file data type 23	*/
						/* unsigned binary and packed decimal data types 33-46	*/
standard_types:

	call dnd$with_strings(ps.descr,addr(descriptive),code);
	if code=1 then goto err232;
	if type5.cr="s" then go to is_string;

	call assign_type_d(ps.descr,psp,picture_p,intype,inscale_prec);

	if ps.descr="0"b
	then do;
		intype = char_desc*2;
		if picture_p->picture_image.type = cplx_fixed_picture
		|  picture_p->picture_image.type = cplx_float_picture
		then inscale_prec = picture_p->picture_image.varlength * 2;	/* a cplx pic's varlength is len of real part only */
		else inscale_prec = picture_p->picture_image.varlength;
	end;

	call assign_(addr(v_output),v_char_desc*2,516,ps.vp,intype,inscale_prec);

	n_out = length(v_output);
	output = v_output;

publish:


	/* put_field will put on the terminal blank
	   or, if it is the last data directed, the semi in due course
	   as "    x=5 "  OR  "     x=5;"    */

	call plio2_put_util_$put_field_(psp,addr(output),n_out);
	return;

is_string:
	if type5.ff="v"  /* varying */ then descriptive.prec=addrel(ps.vp,-1)->based_VL;
	if descriptive.prec > 256 then goto string_too_big;
	if type5.bd="b" then go to bits;
	if ps.fsbp->fsb.switch.print then if ps.job.list then
		do;
		n_out=descriptive.prec;
		substr(output,1,n_out)=substr(ps.vp->based_chars,1,n_out);
		go to publish;
		end;

	substr(output,1,1)="""";
	n_out=2;

	do i=1 to descriptive.prec;
	x=substr(ps.vp->based_chars,i,1);
	if x="""" then
		do;
		substr(output,n_out,1)="""";
		n_out=n_out+1;
		end;
	substr(output,n_out,1)=x;
	n_out=n_out+1;
	end;

	substr(output,n_out,1)="""";
	go to publish;

bits:

	substr(output,1,1)="""";
	do i=1 to descriptive.prec;
	if substr(ps.vp->based_bits,i,1) then x="1";
	else x="0";
	substr(output,i+1,1)=x;
	end;

	n_out=descriptive.prec+3;
	substr(output,n_out-1,2)="""b";
	go to publish;

/*  */

	dcl packed bit(1) aligned;
	dcl b36 bit(36) aligned;
	dcl pt ptr;
	dcl based_ptr ptr based;
	dcl based_packed_ptr ptr unaligned based;
	dcl title5 char(5) aligned;
	dcl title7 char(7) aligned;
	dcl ioa_$rsnnl entry options(variable);

non_standard_types:

	packed=substr(ps.descr,8,1);
	goto nst(i);

nst(77):
	if packed then pt=ps.vp->based_packed_ptr;
	          else pt=ps.vp->based_ptr;

	title7="pointer";
single_ptr:
	call ioa_$rsnnl("^a(^p)",output,n_out,title7,pt);
	goto publish;

nst(78):
	if packed then b36=substr(ps.vp->based_bits,1,36);
	          else b36=ps.vp->based_bit36;
	call ioa_$rsnnl("offset(^w)",output,n_out,b36);
	goto publish;

nst(79):
	title5="label";
	goto double_ptr;

nst(80):
	title5="entry";
	goto double_ptr;

nst(87):
	title5="file ";
	goto double_ptr;

double_ptr:
	call ioa_$rsnnl("^a(^p,^p)",output,n_out,title5,ps.vp->p_vector(1),ps.vp->p_vector(2));
	goto publish;

nst(82):
	title7="area at";
	goto single_ptr;

nst(81):
	substr(output,1,9)="structure";
	n_out=9;
	goto publish;

end plio2_ldo_;




		    plio2_octptr_.pl1               10/03/83  1722.3rew 10/03/83  1005.4        9288



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

plio2_octptr_:proc options(support);
octptr:entry(s,o) returns(ptr);
dcl (s,o) char(*);

dcl op ptr;
dcl (substr,addr,null,index,length) builtin;
dcl (si,oi,i,ti) fixed bin(17);
dcl 1 ptrform aligned based(addr(op)),
	2 filler(4) fixed bin(17) unaligned;

	op=null;
	si,oi=0;

	do i=1 to length(s);
	ti=index("01234567",substr(s,i,1));
	if ti=0 then goto badptr;
	si=si*8+ti-1;
	end;

	do i=1 to length(o);
	ti=index("01234567",substr(o,i,1));
	if ti=0 then goto badptr;
	oi=oi*8+ti-1;
	end;

	filler(1)=si;
	filler(3)=oi;

badptr:
	return(op);
end plio2_octptr_;




		    plio2_open_.pl1                 11/05/86  1245.1r w 11/04/86  1042.0      188415



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

plio2_open_: proc options (support);

/* Modified 790710 by PCK to fix bug 1845 */
/* Modified 790327 by RAB to use stackframeptr builtin */
/* Modified 780706 by PG to fix close_in_this_static to unthread multiple fsb's properly */
/* Modified 780309 by PG to fix 1706 (sysprint didn't get print attribute if opened explicitly) */
/* Modified 78.01.31 by RAB for close_in_this_static	*/
/* Modified 77.09.19 by RAB to fix 1674 in which get_chars was attempted for I/O modules that didn't support it */
/* Modified 770823 by PG to permit read & write statements on stream files */
/* 77-03-04: changed to support quick pl1 io by adding the "console" bit to the fsb	*/
/* 76-09-08: changed to use iox_$foo call forwarder	*/
/* 76-03-12: changed to get right referencing_dir for search rules in call to iox_$attach */
/* 75-05-27: changed to fix bug 1363 */
/* 74-12-17: modified for bit_string in job_bits,lock checking removed  */
/* 74-12-2: modified for env(stringvalue) */
/* 74.09.12: fixed for add_finish_handler */
/* 73-12-3: updated for new io (iox).  */

/* parameters */

dcl (pspp ptr,
     xname char (*)
     ) parameter;

/* based */

dcl  bch168 char (168) aligned based;
dcl  based_label label based;
dcl 1 fab aligned based,
    2 switch bit (36) aligned,
    2 name char (32) aligned,
    2 (line_size, page_size, buffer_size) fixed bin (17),
    2 ch168p ptr;

/* builtins */

dcl (addr, baseno, bit, fixed, min, null, rel, stackframeptr, string, substr) builtin;

/* entries */

dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  ioa_ options (variable);
dcl  plio2_recio_$recio_close_ ext entry (ptr);
dcl  plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (15));
dcl  plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15));
dcl  com_err_ entry options (variable);
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  add_epilogue_handler_ entry (entry, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl   iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  unique_bits_ entry returns (bit (70));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$err_no_operation entry;

/* external static */

dcl  plio2_data_$max_page_size fixed bin (35) external;

/* internal static */

dcl  begining_of_file fixed bin int static options(constant) initial(-1);
dcl  debug_sw fixed bin (15) static internal init (0);

/* automatic */

dcl  evx entry variable;
dcl  code fixed bin (35);
dcl (psp, fsbp, fabp, fab2p) ptr;
dcl (i, iroute, erno) fixed bin (15);
dcl  title_option bit (1) aligned;
dcl  lnzc_set bit (1) aligned init ("0"b);
dcl  condition char (13) init ("ERROR");
dcl  fab2px ptr;
dcl (default_ps, default_ls) fixed bin (35);
dcl (A18, B18) bit (18) aligned;
dcl  nono_18 bit (18) aligned;
dcl  iocb_name char (32);
dcl  iocb_status fixed bin (35) init (0);
dcl  iocb_p ptr;
dcl  iocb_title char (200);
dcl  iocb_attach_type fixed bin;
dcl  1 temp_file aligned like file_value;
dcl  1 temp_ps aligned like ps;
dcl  fabprime bit (36) aligned;

/* include files */

%include stack_frame;
%include pl1_file_value;
%include plio2_fsb;
%include plio2_fsbr;
%include plio2_ps;
%include iocb;

/* program */

/* 	OPEN ENTRIES  */

open_implicit_: entry (pspp);
	psp = pspp;
	fsbp = ps.fsbp;
	fab2p = ps.fab2p;
	iroute = 4;
	go to open_question;

open_explicit_: entry (pspp);

	iroute = 1;
	plio2_data_$pspstat, psp = pspp;

	plio2_data_$fsbpstat, ps.fsbp, fsbp = ps.source_p -> file_value.fsb_ptr;
	plio2_data_$fab2pstat, ps.fab2p, fab2p = ps.special_list_p;
	ps.file_p = ps.source_p;

	addr (ps.ab_return) -> based_label = EXIT;

open_question:
	if fsb.switch.open then go to check;

/* thread on first opening and at the
   same time store the declared attributes
   and filename in the FSB.

   To get new declared attributes (for debugging)
   RENEW by unthreading, zeroing FSB-attributes */

	if fsb.switch.threaded
	then fsb.declared_attributes (1) = fsb.declared_attributes (1) | ps.source_p -> file_value.fab_ptr -> fab.switch;
	else do;
	     fsb.fsb_thread = plio2_data_fsb_thread_;

	     if fsb.fsb_thread = null then
		do;
		evx = close_all_;
		call add_epilogue_handler_ (evx, code);
		if code ^= 0
		then call com_err_ (code, "plio2_$open", "Unable to add epilogue handler.");
	     end;
	     fabp = ps.source_p -> file_value.fab_ptr;
	     fsb.declared_attributes (1) = fabp -> fab.switch;
	     fsb.filename = fabp -> fab.name;

/* avoid a LOOP in the THREAD as surely as easily
   possible by setting the "threaded" bit here.  */

	     plio2_data_fsb_thread_ = fsbp;
	     fsb.switch.threaded = "1"b;
	end;

	title_option = "0"b;			/* but we will look to see if there is one */
	if fab2p -> fab.name ^= "" then
	     do;
	     title_option = "1"b;
	     fsb.title = fab2p -> fab.name;
	end;
	else fsb.title = fsb.filename;

	if iroute = 4 then goto no_title168;		/* no title with implicit opening */
	if substr (fab2p -> fab.switch, 3, 1) = "0"b then goto no_title168; /* compiled with version 1 of PL1  */
	if fab2p -> fab.buffer_size = -111111111111011101b then goto no_title168; /* corrects for bug in
						   early version 2 PL1 compilers */
	if fab2p -> fab.ch168p = null then goto no_title168; /* no title option */
	fsb.path_name = fab2p -> fab.ch168p -> bch168;	/* title168 is correctly present - use it */
	title_option = "1"b;
	goto title_is_set;
no_title168:
	if ^title_option then fsb.path_name = "vfile_ " || fsb.filename;
	else fsb.path_name = fsb.title;
title_is_set:

	if substr (fsb.declared_attributes (1), 28, 1) /* internal */ then fsb.title = unique_chars_ (unique_bits_ ());
	else fsb.title = fsb.filename;
	iocb_name = fsb.title;

/* COMMENT ON ALL OF THESE NAMES:

   at this point we have:

   fsb.filename = declared file name
   fsb.title    = (a) fsb.filename if external
   = (b) uniquename if internal
   and is to be used as iocb_name (for find_iocb)
   fsb.path_name= (a) "vfile_ "||fsb.filename if no title option
   = (b) TITLE if title option is specified
   and is to be used as iocb_title (for iox_$attach_iocb)

   later, for the canonical sysin and sysprint, fsb.path_name will
   be changed to "syn_ user_input" or "syn_ user_output".
   */

	if iroute = 1
	then fab2px = fab2p;			/* explicit open - use all attributes */
	else do;
	     fabprime = fab2p -> fab.switch;
	     fab2px = addr (fabprime);

	     if substr (fsb.declared_attributes (1), 8, 1) /* update */
	     then if substr (string (ps.job), 16, 2)	/* read,write */
		then substr (fabprime, 6, 3) = "000"b;	/* in,out,up */
	end;
	string (fsb.switch) = (fsb.declared_attributes (1)|
	     fab2px -> fab.switch|"000000000000000000000000000010010000"b)
	     &"111111111111111111110001000111110111"b;

/* zero out:	eof,prelim_eof,transmit_error,detach,iox_close,te_hold,buffer_in_use  */
/* set to one:	threaded,emptyline		*/

/*   TABLES for IMPLICATIONS,DEFAULTS,CONFLICTS, "NONOS"    */

dcl 1 open_bits (27) aligned static internal,
    2 (
     b18 init (
						/* [1-15] IMPLICATIONS  */
     "1"b, "01"b, "1010000000"b, "0001"b, "1000100000"b, "0"b,
     "000100111011011"b, "0000000100010"b, "000000001"b,
     "0000000001"b, "00000000001"b, "000000000001"b, "0000000000001"b,
     "00000000100001"b, "000000000000001"b,

/* [16-20] DEFAULTS  */
     "0111"b,					/* 16 - input, output, update */
     "0000101"b,					/* 17 - stream, record */
     "000010011"b,					/* 18 - stream(!?), sequential, direct */
     "0000000000011"b,				/* 19 - not_used_2, stringvalue */
     "00000100000001"b,				/* 20 - notkeyed, keyed */

/* [21-27] NONOs  */
     "01"b,					/* 21 - input */
     "001"b,					/* 22 - output */
     "000000001"b,					/* 23 - interactive */
     "000001"b,					/* 24 - notkeyed */
     "000000000001"b,				/* 25 - not_used_2 */
     "00000000000001"b,				/* 26 - keyed */
     "00001"b),					/* 27 - stream */

     c18 init (

/* [1-6] [7-15] CONFLICTS  */
     "011"b, "0101"b, "0011"b, "0000101"b, "000000011"b,
 (10) (1)"0"b,

/* [16-20] DEFAULTS  */
     "01"b,					/* 16 - input */
     "00001"b,					/* 17 - stream */
     "00000001"b,					/* 18 - sequential */
     "00000000001"b,				/* 19 - not_used_1 */
     "000001"b,					/* 20 - notkeyed */

/* [21-27] NONOs  */
     "0001111"b,					/* 21 - write, rewrite, delete, locate */
     "001011"b,					/* 22 - read, rewrite, delete */
     "00000000000010011"b,				/* 23 - ignore, nokey, nokeyfrom */
     "0000000111"b,					/* 24 - key, keyto, keyfrom */
     "000000000010001"b,				/* 25 - set, nofrom */
     "00000000000000001"b,				/* 26 - nokeyfrom */
     "0000111"b)					/* 27 - rewrite, delete, locate */
     ) bit (18) unaligned;

	A18 = substr (string (fsb.switch), 5, 15);	/* NOTE: begins on bit number 5 */
	B18 = "0"b;

/* Open step 2. Supply implied attributes */

	do i = 1 to 15;
	     if A18 & open_bits.b18 (i) then substr (B18, i, 1) = "1"b;
	end;

/* Open step 3. Supply default attributes */

	do i = 16 to 20;
	     if (B18 & open_bits.b18 (i)) = "0"b then B18 = (B18 | open_bits.c18 (i));
	end;

/* Open step 4. Supply print attribute. */

	if (fsb.filename = "sysprint") & substr (B18, 5, 1) /* stream */ & substr (B18, 3, 1) /* output */
	& ^fsb.switch.internal
	then substr (B18, 1, 1) = "1"b;		/* PRINT */

/* Open step 5. Check for a consistent file description. */

	do i = 1 to 5;
	     if (B18 & open_bits.c18 (i)) = open_bits.c18 (i) then
		do;
		erno = 109+i;

/* 110: input and output conflict
   111: input and update conflict
   112: output and update conflict
   113: record and stream conflict
   114: sequential and direct conflict
   115: forwards and backwards conflict - NOT USED ANY MORE
   */
		go to check;
	     end;
	end;

	if ((B18 & "0000001001"b) = "0000001001"b)	/* record and interactive */
	| ((B18 & "0100000001"b) = "0100000001"b)	/* input  and interactive */
	| ((B18 & "000010000000100"b) = "000010000000100"b) /* stream and stringvalue */
	then do;
	     erno = 108;
						/* file cannot be opened: interactive may apply to stream output only,
						   stringvalue may apply to record i/o only	*/
	     goto check;
	end;

	nono_18 = "0"b;

	do i = 21 to 27;
	     if (B18 & open_bits.b18 (i)) then nono_18 = (nono_18 | open_bits.c18 (i));
	end;
	if ((B18 & "000101"b) = "000101"b) then nono_18 = (nono_18 | "0001001"b);
						/* notkeyed and update --> no write or locate */

	substr (string (fsb.switch), 5, 15) = substr (B18, 1, 15);
	substr (string (fsb.nono), 1, 18) = substr (nono_18, 1, 18);

	if fsb.filename = "sysprint"
	then if fsb.switch.print
	     then if ^title_option
		then if ^fsb.switch.internal
		     then fsb.path_name = "syn_ user_output";

	if fsb.filename = "sysin"
	then if fsb.switch.input
	     then if fsb.switch.stream
		then if ^title_option
		     then if ^fsb.switch.internal
			then fsb.path_name = "syn_ user_input";

	call iox_$find_iocb (iocb_name, iocb_p, iocb_status);
	if iocb_status ^= 0 then
	     do;
	     erno = 104;				/* call to iox_$find_iocb fails */
	     goto attach_fails;
	end;

	fsb.iocb_p = iocb_p;

	if iocb_p -> iocb.attach_descrip_ptr = null then
	     do;
	     iocb_title = fsb.path_name;

	     do sp = stackframeptr()
		     repeat (sp -> stack_frame.prev_sp)
		     while (sp -> stack_frame_flags.support);
	     end;
	     call iox_$attach_ptr (iocb_p, iocb_title, sp -> stack_frame.entry_ptr, iocb_status);

	     if iocb_status ^= 0 then
		do;
		erno = 105;			/* call to attach_iocb fails */
		goto attach_fails;
	     end;
	     else fsb.switch.detach = "1"b;

	end;

	if iocb_p -> iocb.open_descrip_ptr = null then
	     do;
	     if fsb.switch.input then iocb_attach_type = 1; else
	     if fsb.switch.output then iocb_attach_type = 2; else
	     iocb_attach_type = 3;
	     if fsb.switch.record then
		if fsb.switch.direct then iocb_attach_type = iocb_attach_type+10;
		else if fsb.switch.keyed then iocb_attach_type = iocb_attach_type+7;
		else iocb_attach_type = iocb_attach_type+3;
	     if iocb_attach_type = 6 then iocb_attach_type = 7;
						/* iox_ has 4 io types: in,out,up, and in-out */

	     call iox_$open (iocb_p, iocb_attach_type, "0"b, iocb_status);
	     if iocb_status ^= 0 then
		do;
		erno = 106;			/* call to iocb.open fails */
		goto attach_fails;
	     end;
	     fsb.switch.iox_close = "1"b;
	     goto is_iox_opened;
	end;

/* Here we may test compatibility for data-sets already opened.
   Not implemented 73-12-3 */

/* AG94 requires that files with the input stream or record sequential (input | update) attributes be
   positioned to the beginning of the file.  If iox_$open has been called this was already done, otherwise
   iox_$position must be called. */


	if (fsb.stream & fsb.input) | (fsb.record & fsb.sequential & (fsb.input | fsb.update))
	then call iox_$position (iocb_p, begining_of_file, 0, iocb_status);

is_iox_opened:
	if fsb.switch.record then
	     do;
	     string (fsbr.recio) = "000"b;
	     string (fsbr.inbuf_sw) = "0"b;
	     string (fsbr.outbuf_sw) = "0"b;
	     fsbr.lnzc = 0;
	     fsbr.outbuf_key = "";
	     fsbr.key_saved = "";
	end;

	else do;

	     i = get_line_length_$switch (iocb_p, iocb_status);
	     if iocb_status = 0
	     then do;
		default_ls = i;
		default_ps = plio2_data_$max_page_size;
		fsb.console = "1"b;			/* if there was a meaningful line len, we will want to use get_line, not get_chars */
	     end;
	     else do;
		default_ls = 132;
		default_ps = 60;
		if iocb_p -> iocb.get_chars = iox_$err_no_operation
		then fsb.console = "1"b;		/* use get_line for input */
		else fsb.console = "0"b;		/* use get_chars for input */
	     end;


	     if fab2p -> fab.line_size>0 then fsb.lsize = fab2p -> fab.line_size;
	     else fsb.lsize = default_ls;

	     if fsb.switch.print then
		do;
		if fab2p -> fab.page_size>0 then fsb.psize = fab2p -> fab.page_size;
		else fsb.psize = default_ps;
	     end;
	     else fsb.psize = 0;			/* 0 for 'not a print file'  */

/* AG94 specifies that if a linesize is given then
   the file _m_u_s_t have the output attribute;
   and that if a pagesize is given then it _m_u_s_t have
   the print attribute.  The punishment is unspecified
   and none is supplied here.  */

	     fsb.blc,
		fsb.kol = 0;
	     fsb.lineno,
		fsb.pageno,
		fsb.bnc = 1;
	     if fsb.print then fsb.lsep = 4;		/* set up for initial PAGE option */
	     else fsb.lsep = 1;			/* set up for GET LIST initial comma */


	     fsb.bptr = addr (fsb.buffer);
	     fsb.bsize = 848;

	     if fsb.stream
	     then if fsb.output
		then fsb.limit = min (fsb.bsize, fsb.lsize);
	end;
						/*  C A U T I O N :

						   check this value against
						   fsb.incl.pl1 at fsb.buffer.

						   Size is in bytes.     */

	fsb.switch.open = "1"b;
	goto check;

attach_fails:
	if debug_sw = 1 then call ioa_ ("iocb_status=^d", iocb_status);
	fsb.lnzc = iocb_status;
	lnzc_set = "1"b;

check:
	if ^fsb.switch.open then
	     do;
	     if fsb.switch.iox_close then call iox_$close (iocb_p, iocb_status);
	     if iocb_status ^= 0
	     then do;
		fsb.lnzc = iocb_status;
		lnzc_set = "1"b;
	     end;

	     if fsb.switch.detach then call iox_$detach_iocb (iocb_p, iocb_status);
	     if iocb_status ^= 0
	     then do;
		fsb.lnzc = iocb_status;
		lnzc_set = "1"b;
	     end;
	     if ^lnzc_set then fsb.lnzc = 0;
	     call plio2_signal_$s_ (psp, "UNDEFINEDFILE", "plio2_open_", erno);
	end;
	if iroute = 1 then return;

	if ^fsb.switch.open then
	     do;
	     condition = "ERROR";
	     erno = 102;
						/* file not open after return from handler of undefinedfile */
	     call plio2_signal_$s_r_ (psp, condition, "plio2_open_", erno);
	end;
	return;

debug_open: entry;
	debug_sw = 1-debug_sw;
	return;


clear_sysprint_: entry;

	call hcs_$make_ptr (null, "stat_", "sysprint.fsb", fsbp, code);
	if fsbp = null then return;

	if fsb.switch.open
	then if ^fsb.switch.internal
	     then if fsb.switch.stream
		then if fsb.switch.output
		     then do;
			fsb.bnc = 1;
			fsb.lineno = 1;
			fsb.pageno = 1;
			fsb.kol = 0;
			return;
		     end;
	return;

set_pageno: entry (isfile, page_num);
dcl  isfile (2) ptr;
dcl  page_num fixed bin (15);
dcl  pnln fixed bin (15);
	pnln = 1;
	goto pnlnjoin;

get_pageno: entry (isfile) returns (fixed bin (15));
	pnln = 2;
	goto pnlnjoin;

get_lineno: entry (isfile) returns (fixed bin (15));
	pnln = 3;

pnlnjoin:
	fsbp = isfile (2);
	if ^fsb.switch.open then
	     do;
	     erno = 141;
get_lineno_sig:
	     call plio2_signal_$s_ (null, "ERROR", "get_lineno", erno);
	     if pnln = 1 then return;
	     else return (0);
	end;
	if ^fsb.switch.print then
	     do;
	     erno = 142;
	     goto get_lineno_sig;
	end;
	if pnln = 1 then
	     do;
	     fsb.pageno = page_num;
	     return;
	end;
	if pnln = 2 then return (fsb.pageno);
	else return (fsb.lineno);
						/*  	CLOSE ENTRIES  */

close_:	entry (pspp);
	psp = pspp;
	plio2_data_$pspstat = psp;
	fsbp = ps.source_p -> file_value.fsb_ptr;
	iroute = 10;
	go to close10;

closebyname_:
close_by_name_: entry (xname);
dcl  msg_sw bit (1) ;
dcl  found_name bit (1);
	msg_sw = "0"b;
by_name_join:
	found_name = "0"b;

	psp = null;
dcl  name32 char (32) aligned;
	name32 = xname;
	iroute = 12;
	fsbp = plio2_data_fsb_thread_;
	do while (fsbp ^= null);
	     if name32 = fsb.filename then
		do;
		go to close10;
by_name_rejoin:	found_name = "1"b;
	     end;
	     fsbp = fsb.fsb_thread;
	end;

	if found_name then return;
	if ^msg_sw then call ioa_ ("filename ^a not found", xname);
	else by_name_code = /* error_table_$no_file */ 1 ;
	return;
close_by_name_sys_: entry (xname, by_name_code);
dcl  by_name_code fixed bin (35);
	by_name_code = 0;
	msg_sw = "1"b;
	go to by_name_join;

closeall_:
closeall:
close_all:
close_all_: entry;
	psp = null;
	iroute = 11;
	fsbp = plio2_data_fsb_thread_;
	do while (fsbp ^= null);
close10:
	     plio2_data_$fsbpstat = fsbp;
	     if fsb.switch.open then
		do;
		if fsb.switch.record
		then do;
		     temp_file.fab_ptr = null;
		     temp_file.fsb_ptr = fsbp;
		     temp_ps.source_p = addr (temp_file);
		     call plio2_recio_$recio_close_ (addr (temp_ps));
		end;
		iocb_p = fsb.iocb_p;
		if fsb.switch.iox_close then call iox_$close (iocb_p, iocb_status);
		if iocb_status ^= 0
		then do;
		     fsb.lnzc = iocb_status;
		     lnzc_set = "1"b;
		end;
		if fsb.switch.detach then call iox_$detach_iocb (iocb_p, iocb_status);
		if iocb_status ^= 0
		then do;
		     fsb.lnzc = iocb_status;
		     lnzc_set = "1"b;
		end;

		fsb.switch.open = "0"b;
	     end;
	     if iroute = 10 then return;
	     if iroute = 12 then go to by_name_rejoin;
	     fsbp = fsb.fsb_thread;
	end;
	return;

listfiles:
	entry ();

	fsbp = plio2_data_fsb_thread_;
	call ioa_ ("thread:^p", fsbp);
	do while (fsbp ^= null);
	     call ioa_ ("  fsbp=^p,name=^a", fsbp, fsbp -> fsb.filename);
	     fsbp = fsbp -> fsb.fsb_thread;
	end;

EXIT:	return;

get_fsb_thread: entry (pspp);
	pspp = plio2_data_fsb_thread_;
	return;

set_fsb_thread: entry (pspp);
	plio2_data_fsb_thread_ = pspp;
	return;

/* This procedure closes and unthreads all fsb's contained in a specified static section. */

close_in_this_static: entry (start_thread, static_ptr, static_len);

dcl  start_thread ptr,				/* start of fsb thread (Input/Output) */
     static_ptr ptr,				/* start of static section (Input) */
     static_len fixed bin (18);			/* length of static section in words (Input) */

dcl (static_seg_no, static_start, static_end) bit (18) aligned;
dcl  last ptr;

	static_seg_no = baseno (static_ptr);
	static_start = rel (static_ptr);
	static_end = bit (fixed (fixed (static_start, 18) + static_len, 18), 18);

	psp = null;
	last = null;

	do fsbp = start_thread repeat fsbp -> fsb.fsb_thread while (fsbp ^= null);
	     if baseno (fsbp) = static_seg_no
	          & rel (fsbp) >= static_start & rel (fsbp) < static_end
	     then do;
		     if fsbp -> fsb.switch.open
		     then do;
			temp_file.fab_ptr = null;
			temp_file.fsb_ptr = fsbp;
			temp_ps.source_p = addr (temp_file);
			call close_ (addr (temp_ps));
		     end;

		     if last ^= null
		     then last -> fsb.fsb_thread = fsbp -> fsb.fsb_thread;
		     else start_thread = fsbp -> fsb.fsb_thread;
		end;
	     else last = fsbp;
	end;

	return;

     end /* plio2_open_ */;




		    plio2_pdt_.pl1                  10/03/83  1722.3rew 10/03/83  1005.5       46809



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

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

plio2_pdt_:
put_value_data_:proc(pspp) options(support);








% include plio2_ident;
/* updated 10-14-71 */

	go to start;


	dcl (pspp,psp,sslp ) ptr;
	dcl (offset,i,ii) fixed bin(15);
	dcl idesc bit(36);

	dcl (addr,addrel,bit,divide,fixed,null,substr) builtin;
	dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15));
	dcl plio2_put_util_$put_prep_ ext entry(ptr);
	dcl plio2_ldo_$ldo_for_data ext entry(ptr);
	dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(17));

	dcl plio2_sym_to_desc ext entry(ptr,ptr,ptr,ptr) returns(bit(36) aligned);
% include plio2_ps;

/*  */




% include runtime_symbol;


	dcl identifier_string char(256) aligned;
	dcl char_buf char(1000) unaligned based;
	dcl name_string char(512) varying;
	dcl ssl(100) fixed bin(15) based;
	dcl jtype fixed bin(12);
	dcl isize fixed bin(35);
	dcl ( dfxb15 init("100000100000000000000000000000001111"b),
	      dfxd63 init("100100100000000000000000000000111111"b) ) bit(36) static internal;
	dcl subscr_dec char(64) aligned;
	dcl icode fixed bin(15);
	dcl (last_node_p,l1_p,name_p,stack_frame(17) based,sym_p,sym_q,new_sp) ptr;
	dcl stu_$decode_value ext entry(fixed bin(35),ptr,ptr,fixed bin(15))
		returns( fixed bin(35));
	dcl  subscr fixed bin(15);
	dcl subscr_string char(32) aligned;
	dcl subscr_chl fixed bin(15);
	dcl bbit36 bit(36) based;
	dcl bbit9 bit(9) based;
	dcl fixed9 fixed bin(9);

	dcl isl fixed bin(15);	/* identifier string length */

					dcl carry fixed bin(15);
					dcl dgt(0:9) char(1) static internal
					init("0","1","2","3","4","5","6","7","8","9");






/*  */
start:
	psp=pspp;
	ps.switch.semi_sep="0"b;
	if ps.prep^=0 then call plio2_put_util_$put_prep_(psp);
	last_node_p,
	sym_p=addrel(ps.ST_top_p,ps.offset);

		/* given addr(symbol_node)
		   obtain a descriptor taking care
		   of the two contingencies:
		   first, that it may be either an old or a new ST.
		   second, that it may be an element or an array node.    */



	/* get the level one ST_node_pointer  */

	sym_q=sym_p;
loop_struct:
	if fixed(sym_q->runtime_symbol.level,6)<2 then go to level_1_node;
	sym_q=addrel(sym_q,sym_q->runtime_symbol.father);
	go to loop_struct;

level_1_node:
	l1_p=sym_q;

	if sym_p->runtime_symbol.type="111111"b
	then do;
		idesc = "0"b;
		ps.top_half = bit(fixed(sym_p->runtime_symbol.size,18),18);
	end;
	else	idesc=plio2_sym_to_desc(sym_p,l1_p,psp,null);
		/* the null stack frame ptr will be replaced
		   by s_to_d using information in PS */

/*   */

/* make name  */



	isl=0;
	name_string="";
	sym_p=last_node_p;	/* start from level_N_name */
name_loop:


	name_p=addrel(sym_p,sym_p->runtime_symbol.name);

	fixed9=fixed(name_p->bbit9,9);
	name_string=substr(name_p->char_buf,2,fixed9)||"."||name_string;
	isl=fixed9+isl+1;
	if isl>255 then goto err244;



	if sym_p=l1_p then go to end_name_loop;	/*  end at the level one node */
	/* if fixed(sym_p->runtime_symbol.level,6)<2 then go to end_name_loop; */
	sym_p=addrel(sym_p,sym_p->runtime_symbol.father);
	go to name_loop;
end_name_loop:



	sslp=ps.ss_list_p;
	if sslp->ssl(1)>0 then
		do;
		substr(name_string,isl,1)="(";
			do i=2 to sslp->ssl(1)+1;
			subscr=sslp->ssl(i);
	
			if subscr<0 then
				do;
				subscr=-subscr;
				isl=isl+1;
				name_string=name_string||"-";
				end;
			if subscr=0 then
				do;
				name_string=name_string||"0,";
				isl=isl+2;
				end;
			else	do;
					do ii=64 to 1 by -1;
					carry=divide(subscr,10,35,0);
					substr(subscr_dec,ii,1)=dgt(subscr-10*carry);
					if carry=0 then go to signif;
					subscr=carry;
					end;


	signif:
				name_string=name_string||substr(subscr_dec,ii,65-ii)||",";
				isl=isl+66-ii;
				end;
			if isl>255 then goto err244;
			end;
	
		substr(name_string,isl,1)=")";
		/* replaces the final comma with the close_paren  */

		end;	/* end of subscript pack */

	else 	isl=isl-1;	/* kill the final DOT:       a.b.c. -> a.b.c     */
publish_name:
	identifier_string=substr(name_string,1,isl)||"=";
	isl=isl+1;

	call plio2_put_util_$put_field_(psp,addr(identifier_string),isl);


	ps.descr=idesc;
	ps.vp=ps.value_p;

	call plio2_ldo_$ldo_for_data(psp);

	return;

err244:
	call plio2_signal_$s_(psp,"ERROR","put data",244);
				/* err244: Identifier longer than 255 not handled by this implementation */
	isl=255;
	goto publish_name;

end plio2_pdt_;




		    plio2_put_util_.pl1             04/26/88  1220.0rew 04/26/88  1214.8      159084



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



/****^  HISTORY COMMENTS:
  1) change(88-04-06,Huen), approve(88-04-06,MCR7871), audit(88-04-13,RWaters),
     install(88-04-26,MR12.2-1043):
     Add comments for PL/1 bug 2140 and 2152.
                                                   END HISTORY COMMENTS */


plio2_put_util_:proc options(support);


/* updated 73-12-6 */
          /* 88-04-06: Insert a comment to warn users about the obsoletion
		   of the modules by SHuen */
	/* 77-05-26: to fix 1626 by RAB */
	/* 76-09-08: changed to use iox_$put_chars call forwarder */
	/* 73-12-6: changed over for iox_  */
	/* 73-10-30: fixed for new splitting rules
		and an entry for clearing output buffers introduced. */
	/* 9-27-72: finished internal-proceduring; added <NP> */
	/* 9-7-72: began internal-proceduring it and fixed bug in put_normal_char */
	/* 1-28-72: pageno stuff added */
	/*1-21-72:	There should no longer be non-explicit files */
	/* 8-2-71: slight fix to handling of SKIP by put_prep */


/* 	plio2_put_util_$
	contains the entries:
		put_prep_(psp)
		put_terminate_(psp)

		put_copy_(psp,n)

		put_page_(psp)
		put_skip_(psp,n)
		put_line_(psp,n)
		put_column_(psp,n)
		put_field_(psp,csp,csl)

	and, internally, the PUT_PUBLISH code which includes
	the code for the host interface procedure WRITE_HOST.

	This is the only procedure in the stream-directed output
	package which actually touches the output stream, that is,
	actually writes.

	1975: In order to improve performance, R.Schoeman has 
	reimplemented pl1 stream output in the operators which is 
	resided in bound_library_wired_. Therefore most of the 
	modules in this program for stream output has been obsoleted.
          For example, the put_field_ module is rewritten in put_field_.alm
							*/


/* automatic */

dcl	(pspp,psp,sptr,fsbp,fieldp,fieldpp) ptr;
dcl	(erno,nn,skip_count,target_line,fieldl,fieldll,/*col_no,*/blanks_out,blanks_left) fixed bin(15);
dcl	(pfstart,kkolx,sl,si,sll,shortline,/*iskip,*/testkol) fixed bin(15);
dcl	(x,y) char(1) aligned;

/* based */

dcl  based_int fixed bin (35) based;
dcl  p_vector (100) ptr based;

/* builtins */

dcl (addr, addrel, divide, min, mod, null, substr, string) builtin;

/* internal static */

dcl	NL char(1) aligned static internal init("
");
dcl	TAB char(1) aligned static internal init("	");
dcl	BL  char(1) aligned static internal init(" ");
dcl	SEMI char(1) aligned static internal init(";");
dcl	new_line_line char(100) aligned static internal init((100)"
");
dcl	blank_line char(100) aligned static internal init(" ");


dcl	1 putfab2 aligned static internal,
	2 pfs bit(36) aligned init("001000101"b),
	2 pfn char(32) aligned init(" "),
	2 (pfbs,pfls,pfps) fixed bin(35) init(0);

dcl	ybuf char(1000) aligned based(sptr);

dcl ioa_ ext entry options(variable);
dcl put_data_block_all_ entry (ptr);
dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15));
dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));
dcl plio2_open_$open_implicit_ ext entry(ptr);
dcl ctl_char$cr char(1) ext;
dcl ctl_char$np char(1) ext;
dcl iocb_p ptr;
dcl iocb_status fixed bin(35);
dcl plio2_data_$max_page_size fixed bin(35) external;

/* include files */

%include plio2_fsb;
%include plio2_ps;

/* program */

/* PREP */

put_prep_:entry(pspp);
	psp=pspp;
	call put_prep;
	return;


put_prep:proc;
			/* By a revision of pl1_operators_'s entry
			   stream_prep, put_prep_ will be called before
			   any call to put_terminate_ or the transmission
			   entries.  Thus there is less need to keep the
			   historical  test of the prep_sw and call to
			   put_prep_ in these routines.  The reason for
			   putting back the "prep_call" which was so
			   carefully removed in the original design is to
			   assure that the output file is open BEFORE the
			   first element for transmission is evaluated.  */
	plio2_data_$pspstat=psp;
	ps.prep=0;
	string(ps.switch)="0"b;

	if ps.job.string then
		do;
     /* STRING
        OPTION  */
		plio2_data_$pliostringfsbp,
		plio2_data_$fsbpstat,
		ps.fsbp,
		fsbp=ps.source_p;

		bnc=1;
		blc,kol=0;

		bsize=ps.number;
		lsize=ps.number+10000;
		fsb.limit=fsb.bsize;
		fsb.title,fsb.filename="""put_string_option""";
		/* for string option,
			fsb.buffer,
			fsb.path_name,
			fsb.declared_attributes(2)
		   must not be used - fske_fsb is too short  */
		string(fsb.switch)="001100101"b;
		/* v2pl1,open,stream,output */
		/* fsb.bptr has already been set to addr(string) by
		   the calling program  */
		ps.file_p=null;
		goto exit_put_prep;
		end;

     /* FILE or
        SYSPRINT   */

	if ps.job.explicit_file then ps.file_p=ps.source_p;
				else	do;
					call ioa_ ("error in put_util: no explicit file");
					ps.file_p=addr_sysprint();
					ps.job.explicit_file="1"b;
					end;

	ps.fsbp,fsbp,plio2_data_$fsbpstat=ps.file_p->p_vector(2);
	if fsb.switch.open then go to open1;
     /* IMPLICIT OPEN */
	plio2_data_$fabpstat,ps.fabp=ps.file_p->p_vector(1);
	plio2_data_$fab2pstat,ps.fab2p=addr(putfab2);
	call plio2_open_$open_implicit_(psp);
open1:
	if fsb.switch.output="0"b|fsb.switch.stream="0"b then go to err221;
	if ps.job.skip then
		do;
		skip_count=ps.number;
		call put_skip;
		end;
	else	do;
		if ps.job.page then call put_page;
		if ps.job.line then
			do;
			target_line=ps.number;
			call put_line;
			end;
		end;

exit_put_prep:
	ps.switch.first_field="1"b;
	ps.switch.semi_sep="1"b;
	return;
end put_prep;



/* TERMINATE  */

put_terminate_:entry(pspp);

	psp=pspp;
	if ps.prep^=0 then call put_prep;
					/* see NOTE at "put_prep" */
	fsbp=ps.fsbp;
	ps.switch.first_field="0"b;
	if ps.job.data then
		do;
		if ps.switch.semi_sep then
			do;
			ps.switch.first_field="1"b;
			call put_data_block_all_(psp);
			ps.switch.first_field="0"b;
			end;
		if bnc=1 then
			do;
			y=SEMI;
			call put_normal_char;
			end;
		else substr(xbuf,bnc-1,1)=";";

		end;
	if ps.job.string then
		do;
		if ps.job.varying_string then   addrel(bptr,-1)->based_int=bnc-1;
		else	do;
			if bnc>bsize then return;
			substr(xbuf,bnc,bsize+1-bnc)=" ";
			end;
		return;
		end;

	if fsbp->fsb.switch.interactive then
		do;
		skip_count=1;
		call put_skip;
		end;


	call put_publish;
	return;




clear_output_buffer:entry(pspp);
	psp=pspp;
	if ps.job.string then return;
	fsbp=ps.fsbp;

	if ^fsb.switch.open then return;
	if ^fsb.switch.output then return;
	if ^fsb.switch.stream then return;

	fsb.bnc=1;
	fsb.lineno=1;
	fsb.kol=0;
	fsb.switch.emptyline="0"b;

	return;
put_publish_:entry(pspp);
	psp=pspp;
	fsbp=ps.fsbp;
	call put_publish;
	return;


put_field_:entry(pspp,fieldpp,fieldll);
	psp=pspp;
	fsbp=ps.fsbp;

	if ps.job.edit then
		do;
		call put_field;
		return;
		end;
	if ps.switch.first_field then
		do;
		if kol=0 then go to post_tab;
		if fsb.switch.print then
			do;
			testkol=10 + 10*divide(kol-1,10,35,0);
			if testkol=kol then goto post_tab;
			kol=testkol;
			if kol<lsize then
				do;
				x=TAB;
				call insert_char;
				end;
			else call put_new_line;
			end;
post_tab:
		if ps.job.data then ps.switch.first_field="0"b;
		end;
	else ps.switch.first_field="1"b;
	call put_field;
				/* Always first-field for LIST,
				   alternately first/second field
				   for DATA; at this point, "first_field"
				   is correct for the NEXT field.  */
	y=BL;
	if ps.switch.first_field then call put_normal_char;
	return;


put_field:proc;
	fieldp=fieldpp;
	fieldl=fieldll;
	pfstart=1;
	sptr=fieldp;
try_this_line:
	kkolx=kol+fieldl;
	if kkolx>lsize then go to pf1;
	kol=kkolx;	/* ASSUMES that field consists of single
			   column characters only !!!!!!!!!!!!!!  */
	go to pf22;
pf2:	kol=fieldl;	/* kol must have been =0  */
pf22:	sl=fieldl;
				/* "put" remainder of string in one piece */
	si=pfstart;
	call insert_string;
	return;

pf1:	if ps.job.edit then go to pf3;
pf4:	if kol^=0    then call put_new_line;
	if emptyline then call put_new_line;
	if fieldl<=lsize then go to pf2;
	shortline=lsize;
	go to pf33;
pf3:	shortline=lsize-kol;
pf33:	sl=shortline;
	si=pfstart;
	call insert_string;
	/* kol=lsize but see below that kol becomes 0 */

	fieldl=fieldl-shortline;
	pfstart=pfstart+shortline;
	call put_new_line;	/* kol becomes 0 */
	goto try_this_line;

end put_field;




put_normal_char:proc;
				/* The "put_field" for a single character. */
	if kol=lsize then call put_new_line;
	kol=kol+1;
	x=y;
	call insert_char;
end put_normal_char;



put_skip_fast:proc;
				/* sets kol=0,emptyline,lineno */
	/* doesn't care about psize !!! */
	if skip_count > 1 then go to psf98;
	x=NL;
	call insert_char;
	goto exit_psf;

psf98:	sptr=addr(new_line_line);
	si=1;
psf99:	if skip_count>100 then go to psf100;
	sl=skip_count;
	call insert_string;
	fsb.limit = min(bsize,lsize+bnc-1);
	goto exit_psf;
psf100:
	sl=100;
	call insert_string;
	skip_count=skip_count-100;
	lineno=lineno+100;
	go to psf99;

exit_psf:
	kol=0;
	emptyline="0"b;
	lineno=lineno+skip_count;

end put_skip_fast;



/*  */
insert_char:proc;			/* doesn't care about lsize or psize */
	if bnc>bsize then call put_publish;
	substr(xbuf,bnc,1)=x;
	if x=NL  | x=ctl_char$cr | x=ctl_char$np
	then fsb.limit = min(bsize,lsize+bnc);
	bnc=bnc+1;
	return;
end insert_char;


insert_string:proc;			/* doesn't care about psize or lsize */
insert_string_1:
	if sl<1 then return;
	if sl < bsize-bnc+2 then
		do;
		substr(xbuf,bnc,sl)=substr(ybuf,si,sl);
		bnc=bnc+sl;
		return;
		end;
	sll=bsize+1-bnc;
	substr(xbuf,bnc,sll)=substr(ybuf,si,sll);
	bnc=bsize+1;
	call put_publish;
	sl=sl-sll;
	si=si+sll;
	go to insert_string_1;
end insert_string;


put_publish:proc;
	if ps.job.string then goto err220;
	iocb_p=fsb.iocb_p;
	if bnc>1 then
		do;
		call iox_$put_chars(iocb_p,bptr,bnc-1,iocb_status);
		if iocb_status ^=0 then fsb.switch.transmit_error="1"b;

		bnc=1;	/* buffer has been cleared */
		fsb.limit=min(bsize,lsize-kol);

		if fsb.switch.transmit_error then call plio2_signal_$s_(psp,"TRANSMIT",
							"put_util",222);
		fsb.switch.transmit_error="0"b;
		end;
	return;
end put_publish;

addr_sysprint:proc returns(ptr);
	dcl sysprint file print stream output;
	return(addr(sysprint));
end addr_sysprint;




/*  */


/*put_column_:entry(pspp,nn);	*/
/*	psp=pspp;	*/
/*	fsbp=ps.fsbp;	*/
/*	col_no=nn;	*/
/*	*/
/*	if col_no>lsize | col_no<1 then col_no=1;	*/
/*				/* AG94 doesn't say what to do if col_no<1 */
/*	if col_no>kol then goto pc90;	*/
/*	call put_new_line;	*/
/*pc90:	*/
/*	iskip=col_no -1 -kol;	/* number of intervening blanks */
/*	kol  =col_no -1;		/* kol of last of these blanks is col_no -1 */
/*	*/
/*	sptr=addr(blank_line);	*/
/*	si=1;	*/
/*pc99:	*/
/*	if iskip>100 then go to pc100;	*/
/*	sl=iskip;	*/
/*	call insert_string;	*/
/*	return;	*/
/*pc100:	*/
/*	sl=100;	*/
/*	call insert_string;	*/
/*	iskip=iskip-100;	*/
/*	go to pc99;	*/
/*	*/
/*	*/
put_blanks_:entry(pspp,nn);
	psp=pspp;
	fsbp=ps.fsbp;
	do blanks_left=nn  repeat(blanks_left-100) while (blanks_left>0);
		blanks_out=min(blanks_left,100);
		call put_field_(psp,addr(blank_line),blanks_out);
		end;
	return;



/*put_skip_:entry(pspp,nn);	*/
/*	psp=pspp;	*/
/*	fsbp=ps.fsbp;	*/
/*	skip_count=nn;	*/
/*	call put_skip;	*/
/*	return;	*/
/*	*/
/*	*/
put_skip:proc;
	if ps.job.string then goto err223;
	fsb.limit = min(fsb.bnc+fsb.lsize,fsb.bsize);
	if skip_count>0 then go to pso_1;
	if fsb.switch.print then
		do;
		x=ctl_char$cr;
		call insert_char;
		kol=0;
		emptyline="1"b;
		return;
		end;
	goto err224;

pso_1:
	if lineno>psize | (lineno+skip_count)<=psize then
		do;
		call put_skip_fast;
		return;
		end;
	call fill_page_with_NLs;
	call plio2_signal_$s_(psp,"ENDPAGE","put_skip",225);
	return;

end put_skip;
/*	*/
/*	*/
/*	*/
/*put_line_:entry(pspp,nn);	*/
/*	psp=pspp;	*/
/*	fsbp=ps.fsbp;	*/
/*	target_line=nn;	*/
/*	call put_line;	*/
/*	return;	*/


put_line:proc;
	if ps.job.string then goto err226;
	if ^fsb.switch.print then goto err227;
	if target_line<1 then target_line=1;
				/* AG94 says "must be >0"  */
	if target_line=lineno then return;
	if lineno > psize 
	then do;
		if target_line > lineno 
		then do;
			skip_count=target_line-lineno;
			call put_skip_fast;
			end;
		else call put_page;
		return;
		end;
	if target_line < lineno | target_line > psize then
		do;
		call fill_page_with_NLs;
		call plio2_signal_$s_(psp,"ENDPAGE","put_line",228);
		return;
		end;

	/* lineno < target_line  */
	skip_count=target_line-lineno;
	call put_skip_fast;
	return;

end put_line;
/*	*/
/*	*/
/*	*/
/*put_page_:entry(pspp);	*/
/*	psp=pspp;	*/
/*	fsbp=ps.fsbp;	*/
/*	call put_page;	*/
/*	return;	*/


put_page:proc;
	/* call fill_page_with_NLs; */
	if (lineno<=psize)
	|  (kol>0)
	| (kol=0 & emptyline)
	then	do;
		x=NL;
		call insert_char;
		end;
	lineno=1;
	pageno=pageno+1;
	kol=0;
	emptyline="0"b;
	x=ctl_char$np;
	call insert_char;
				/* MULTICS must insert <CR> if necessary. */
				/* This entry called by default handler for the
				   endpage condition.  */
	return;

end put_page;

fill_page_with_NLs:proc;

	if ps.job.string then goto err229;
	if ^fsb.switch.print then goto err230;

	if psize=plio2_data_$max_page_size then
		do;
		kol=0;
		emptyline="0"b;
		lineno=1;
		return;	/* RETURN */
		end;

	/* returns with
		kol=0
		emptyline="0"b
		lineno=pagesize*M+1    */

	if kol^=0 		then go to ppo_work;
	if lineno=1 		then go to ppo_work;
	if mod(lineno,psize)^=1 	then go to ppo_work;
	if emptyline 	then go to ppo_work;

	/* we are looking at the beginning of a page
	   with lineno=1+N*psize,  N^=1     
	   Hence, when put_page_ is called by the handler of the PAGE
	   condition, all that happens is that lineno=1  */

	return;

ppo_work:
	skip_count=1 - lineno + psize*(1+divide(lineno-1,psize,35,0));
	call put_skip_fast;
	return;

end fill_page_with_NLs;




put_new_line:proc;

	/* puts the NL character duly considering psize.
	   used by:  put_field,put_tab,put_bl,put_col  */

	if ps.job.string then goto err226;
	x=NL;
	call insert_char;
	kol=0;
	emptyline="0"b;
	lineno=lineno+1;
	if lineno=psize+1 then call plio2_signal_$s_(psp,"ENDPAGE","new_line",231);
	return;
end put_new_line;


/*  */
     /* ABNORMAL RETURNS */

err220:
	erno=220;
			/* PUT STRING overflows the string */
	goto sig_and_return;

err221:
	erno=221;
			/* FILE used with PUT STATEMENT must have stream,output attributes */
	goto sig_and_return;

err223:
	erno=223;
			/* SKIP not allowed with STRING OPTION */
	goto sig_and_return;

err224:
	erno=224;
			/* SKIP with count<1 requires PRINT attribute */
	goto sig_and_return;

err226:
	erno=226;
			/* LINE not allowed with STRING OPTION */
	goto sig_and_return;

err227:
	erno=227;
			/* LINE requires the PRINT attribute */
	goto sig_and_return;

err229:
	erno=229;
			/* PAGE not allowed with STRING OPTION */
	goto sig_and_return;

err230:
	erno=230;
			/* PAGE requires PRINT attribute */
	goto sig_and_return;

err233:
	erno=233;
	goto sig_and_return;

sig_and_return:	call plio2_signal_$s_r_(psp,"ERROR","put_util",erno);
	/* signals and then returns abnormally to the user's procedure */



quick_condition:	entry(pspp,condition_code);

dcl	condition_code fixed bin(35);

	psp=pspp;
	fsbp=ps.fsbp;
	goto quick_cond(condition_code);

quick_cond(0):			/* non-zero code returned by iox_$put_chars */
	fsb.transmit_error="1"b;
	call plio2_signal_$s_(psp,"TRANSMIT","quick_stream",222);
	fsb.transmit_error="0"b;
	return;

quick_cond(1):			/* ENDPAGE is to be signalled */
	call plio2_signal_$s_(psp,"ENDPAGE","quick_new_line",234);
	return;

quick_cond(2):			/* LINE or PAGE option or format in PUT stmnt  */
				/* on file without print attribute             */
	erno = 235;
	goto qs_signal_abnormal_ret;

quick_cond(3):			/* COL or LINE format/option with zero value  */
	erno = 236;
	goto qs_signal_abnormal_ret;

quick_cond(4):			/* CONTROL format with value <0	      */
	erno = 237;
	goto qs_signal_abnormal_ret;

quick_cond(5):			/* SKIP(0) found on non-print file	      */
	erno = 224;
	goto qs_signal_abnormal_ret;

quick_cond(6):			/* fill_page_with_NL's when psize = max!!!!	*/
	erno = 233;
	goto qs_signal_abnormal_ret;

quick_cond(7):		/* "buffer", i.e. target string, overflowed on put with string option */
	erno = 220;
	goto qs_signal_abnormal_ret;

quick_cond(8):		/* request is for a string of over 260 final output length */
	call plio2_signal_$s_(psp,"ERROR","quick_260_limit",242);
	return;

quick_cond(9):		/* request for line(0) was made	*/
	erno = 262;
	goto qs_signal_abnormal_ret;

quick_cond(10):		/* no parameter to format item given where one  was needed	*/
	erno = 148;
	goto qs_signal_abnormal_ret;

quick_cond(11):		/* non-zero error code returned by stu_ while evaluating format	*/
	erno = 195;
	goto qs_signal_abnormal_ret;

quick_cond(12):		/* max nesting depth of 10 for r_formats exceeded	*/
	erno = 197;
	goto qs_signal_abnormal_ret;

quick_cond(13):		/* attempt to restart after ERROR or SIZE */
	erno = 266;
	goto qs_signal_abnormal_ret;

quick_cond(14):
quick_cond(15):
quick_cond(16):
quick_cond(17):
quick_cond(18):		/* no such quick_cond codes! */
	erno = 174;
	goto qs_signal_abnormal_ret;

qs_signal_abnormal_ret:
	call  plio2_signal_$s_r_(psp,"ERROR","quick_put_cond",erno);
	/* signals & returns abnormally to user's procedure */

end plio2_put_util_;




		    plio2_pve_.pl1                  10/03/83  1722.3rew 10/03/83  1005.5      178119



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

plio2_pve_:proc(pspp) options(support);
put_value_edit_:entry(pspp);

		/* Ref: see AG94 section 12.12 page 12-17 ff  format statement
		                 section 8.2.12 page 8-11 ff  format controlled conversion
		*/

dcl	(/*p,*/psp,pspp/*,inpicture_p,outpicture_p*/) ptr;

/*	dcl erno fixed bin(15);	*/
/*	dcl (i,ipreciz,code,idn,topdigits) fixed bin(15);	*/
/*	dcl fake_arg bit(1) unaligned based;	*/
/*	dcl based_bits bit(1000) unaligned based;	*/
/*	*/
/*	dcl decimal_temp char(130) aligned;	*/
/*	dcl decimal char(130) aligned;	*/
/*	*/
/*	dcl 1 descriptive aligned,	*/
/*		2 type5 aligned,	*/
/*			3 ( cr,bd,ff,ls,pack ) char(1) unal,	*/
/*		2 (prec,scale,bit_length,typex) fixed bin(15);	*/
/*	dcl 1 based_mask aligned based(addr(type5)),	*/
/*	     2 bc2 char(2) unaligned;	*/
/*	dcl 1 xm12 aligned based,	*/
/*		2 top_24 bit(24) unal,	*/
/*		2 m_12 bit(12) unal;	*/
/*	dcl  1 xlc aligned based,	*/
/*		2 c3 char(3) unal,	*/
/*		2 last_char char(1) unal;	*/
/*	*/
/*	dcl ( addr,addrel,baseptr,divide,fixed,length,mod,substr,unspec) builtin;	*/
/*	*/
/*dcl	plio2_fl_$reset_ ext entry(ptr);	*/
/*dcl	plio2_fl_$get_next_ ext entry(ptr);	*/
/*dcl	plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15));	*/
/*dcl	plio2_put_util_$put_prep_ ext entry(ptr);	*/
/*dcl	plio2_put_util_$put_page_ ext entry(ptr);	*/
/*dcl	plio2_put_util_$put_line_ ext entry(ptr,fixed bin(15));	*/
/*dcl	plio2_put_util_$put_skip_ ext entry(ptr,fixed bin(15));	*/
/*dcl	plio2_put_util_$put_column_ ext entry(ptr,fixed bin(15));	*/
/*dcl	dnd$with_strings ext entry(bit(36) aligned,ptr,fixed bin(15));	*/
dcl	plio2_signal_$s_ ext entry(ptr,char(*),char(*), fixed bin(15));	
/*dcl	plio2_signal_$s_r_ ext entry(ptr,char(*),char(*), fixed bin(15));	*/
/*	*/
/*	dcl sign_char char(1) unaligned;	*/
/*	dcl format_bp ptr;	*/
/*	dcl expstr char(5) aligned;	*/
/*	*/
/*	dcl v_output char(516) varying;	*/
/*	*/
/*	dcl zeroes char(256) aligned static internal init((256)"0");	*/
/*	*/
/*	dcl dgt(0:9) char(1) static internal	*/
/*	init("0","1","2","3","4","5","6","7","8","9");	*/
/*	*/
/*	dcl 1 second_part unaligned based,	*/
/*		2 xxx bit(bit_offset),	*/
/*		2 next_bit bit(1);	*/
/*	*/
/*	dcl 1 format_block aligned based(format_bp),	*/
/*		2 ( type,nval,val(3)) fixed bin(15);	*/
/*	*/
/*	dcl (exp,ftype,iw,icomplex,is,ip,id,nval) fixed bin(15);	*/
/*	dcl bl24 char(24) aligned init("");	*/
/*	*/
/*	dcl ( ddfix,ddflo) bit(36) aligned;	*/
/*	dcl char256 char(256) aligned;	*/
/*	dcl vbit256 bit(256) varying aligned;	*/
/*	dcl efbuf char(264) aligned;	*/
/*	dcl (lzero,ief,dscale,lpref) fixed bin(15);	*/
/*	*/
/*dcl	buffer char(64) aligned;	*/
/*dcl	space char(128) aligned;	*/
/*	*/
/*dcl	conversion condition;	*/
/*dcl	plio2_resig_ ext entry(ptr);	*/
/*	*/
/*dcl	1 dec_fixed(2)	based(addr(space)) unal,	*/
/*	2 sign_of_mantissa	char(1) unal,	*/
/*	2 mantissa	char(outprec) unal,	*/
/*	*/
/*	1 dec_float(2)	based(addr(space)) unal,	*/
/*	2 sign_of_mantissa	char(1) unal,	*/
/*	2 mantissa	char(outprec) unal,	*/
/*	2 unused		bit(1) unal,	*/
/*	2 exponent	fixed bin(7) unal;	*/
/*	*/
/*%include desc_dcls;	*/
/*%include desc_types;	*/
/*%include descriptor;	*/
/*%include picture_desc_;	*/
/*%include picture_image;	*/
/*%include picture_util;	*/
/*%include plio_format_codes;	*/
/*%include plio2_ps;	*/

/*	psp=pspp;	*/
/*	if ps.prep^=0 then call plio2_put_util_$put_prep_(psp);	*/
/*	on conversion call plio2_resig_(psp);	*/
/*	ps.vp=ps.value_p;	*/
/*	ps.descr=ps.descriptor;	*/
/*	call dnd$with_strings(ps.descr,addr(descriptive),code);	*/
/*	if code^=0 then goto err232;	*/
/*	*/
/*	if type5.cr="s"	*/
/*	then	if type5.ff="v"	*/
/*		then	ps.vp = addrel(ps.vp,-1);	*/
/*	*/
/*	icomplex=0;	*/
/*	format_bp=ps.format_area_p;	*/
/*	if ps.new_format^=0 then call plio2_fl_$reset_(psp);	*/
/*	*/
/*get_next_format_item:	*/
/*	*/
/*	call plio2_fl_$get_next_(psp);	*/
/*	*/
/*complex_edit_1:	*/
/*	ftype=format_block.type;	*/
/*	nval=format_block.nval;	*/
/*	iw=format_block.val(1);	*/
/*	*/
/*	if nval>0 then if iw<0 then goto bad_param_values;	*/
/*	*/
/*	if icomplex>0 then go to ef_prep;	*/
/*	*/
/*	if ftype<x_format then go to data_format;	*/
/*	if ftype=x_format then	*/
/*		do;	*/
/*		if nval<1 then goto too_few_params;	*/
/*more_x:		if iw<1 then goto get_next_format_item;	*/
/*		if iw>24 then is=24;	*/
/*		else is=iw;	*/
/*		iw=iw-is;	*/
/*		call plio2_put_util_$put_field_(psp,addr(bl24),is);	*/
/*		goto more_x;	*/
/*		end;	*/
/*	*/
/*	if ftype=skip_format then	*/
/*		do;	*/
/*		if nval<1 then iw=1;	*/
/*		call plio2_put_util_$put_skip_(psp,iw);	*/
/*		go to get_next_format_item;	*/
/*		end;	*/
/*	*/
/*	*/
/*	if ftype=column_format then	*/
/*		do;	*/
/*		if nval<1 then go to too_few_params;	*/
/*		if iw<1 then iw=1;		/* not AG94-0 ........... */
/*		call plio2_put_util_$put_column_(psp,iw);	*/
/*		go to get_next_format_item;	*/
/*		end;	*/
/*	*/
/*	*/
/*	if ftype=page_format then	*/
/*		do;	*/
/*		call plio2_put_util_$put_page_(psp);	*/
/*		go to get_next_format_item;	*/
/*		end;	*/
/*	*/
/*	*/
/*	if ftype=line_format then	*/
/*		do;	*/
/*		if nval<1 then go to too_few_params;	*/
/*		if iw<1 then goto bad_param_values;	*/
/*		call plio2_put_util_$put_line_(psp,iw);	*/
/*		go to get_next_format_item;	*/
/*		end;	*/
/*	*/
/*pic_format:	*/
/*	if ftype=picture_format	*/
/*	then do;	*/
/*		outpicture_p = addrel(baseptr(format_block.val(2)),format_block.val(3));	*/
/*	*/
/*		call assign_type_p(outpicture_p,outtype,outscale_prec);	*/
/*		call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec);	*/
/*	*/
/*		if icomplex=2	*/
/*		then	if outtype^=char_desc*2	*/
/*			then	outtype = outtype+4;	*/
/*	*/
/*		if ps.descr="0"b	*/
/*		then	if outtype=char_desc*2	*/
/*			then do;	*/
/*				call assign_(addr(buffer),char_desc*2,outscale_prec,ps.vp,intype,inscale_prec);	*/
/*				call pack_picture_(addr(char256)->char1,p->char1,addr(buffer)->char1);	*/
/*	*/
/*				icomplex = 2;	*/
/*	*/
/*				goto put_field_edit;	*/
/*			end;	*/
/*			else do;	*/
/*				call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1);	*/
/*				call assign_(addr(space),outtype,outscale_prec,addr(buffer),intype,inscale_prec);	*/
/*			end;	*/
/*		else	call assign_(addr(space),outtype,outscale_prec,ps.vp,intype,inscale_prec);	*/
/*	*/
/*		if icomplex=2	*/
/*		then	i = 2;	*/
/*		else	i = 1;	*/
/*	*/
/*		if outtype=D_fixed_real_desc*2	*/
/*		|  outtype=D_fixed_cplx_desc*2	*/
/*		then	p = addr(dec_fixed(i));	*/
/*		else	p = addr(dec_float(i));	*/
/*	*/
/*		call pack_picture_(addr(decimal)->char1,outpicture_p->char1,p->char1);	*/
/*	*/
/*		iw = outpicture_p->picture_image.varlength;	*/
/*	*/
/*		substr(char256,1,iw) = substr(decimal,1,iw);	*/
/*	*/
/*		goto put_field_edit;	*/
/*	end;	*/
/*	*/
/*	goto no_such_format_type;	*/
/*	*/
/*err232:	*/
/*	erno=232;	*/
/*			/*  bad output descriptor */
/*	goto sandr;	*/
/*	*/
/*too_few_params:	*/
/*	erno=148;	*/
/*			/* too few parameters in format item */
/*	goto sandr;	*/
/*	*/
/*no_such_format_type:	*/
/*	*/
/*	erno=260;	*/
/*			/* illegal format code assembled - containt maint-pers */
/*	goto sandr;	*/
/*	*/
/*bad_string_size:	*/
/*	erno=261;	*/
/*			/* size of field ("w") not in range 0 to 256 */
/*	goto sandr;	*/
/*	*/
/*bad_param_values:	*/
/*	erno=262;	*/
/*			/* bad parameter value in format item (output)  */
/*	goto sandr;	*/
/*	*/
/*err264:	*/
/*	erno=264;	*/
/*			/* put edit cannot handle a string longer than 256 */
/*	goto sandr;	*/
/*	*/
/*err265:	*/
/*	erno=265;	*/
/*			/* put edit cannot handle a string of length <0.	*/
/*			   possible compiler error.   contain maint-pers.  */
/*	goto sandr;	*/
/*	*/
/*sandr:	*/
/*	call plio2_signal_$s_r_(psp,"ERROR","PVE",erno);	*/
/*	*/
/*data_format:	*/
/*	if ftype=a_format then	*/
/*		do;	*/
/*		if bc2="sc" then	*/
/*			do;	*/
/*			if type5.ff="v"	*/
/*			then do;	*/
/*				descriptive.prec = ps.vp->based_int;	*/
/*				ps.vp = addrel(ps.vp,1);	*/
/*			end;	*/
/*	*/
/*			if descriptive.prec>256 then goto err264;	*/
/*			if descriptive.prec<0   then goto err265;	*/
/*			substr(char256,1,descriptive.prec)=substr(ps.vp->based_chars,1,descriptive.prec);	*/
/*			end;	*/
/*	*/
/*		else	do;	*/
/*			call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec);	*/
/*	*/
/*			if ps.descr="0"b	*/
/*			then do;	*/
/*				intype = char_desc*2;	*/
/*				inprec = inpicture_p->picture_image.varlength;	*/
/*				inscale = 0;	*/
/*			end;	*/
/*	*/
/*			call assign_(addr(v_output),v_char_desc*2,256,ps.vp,intype,inscale_prec);	*/
/*	*/
/*			descriptive.prec = length(v_output);	*/
/*	*/
/*			if descriptive.prec>256 then goto err264;	*/
/*			if descriptive.prec<0   then goto err265;	*/
/*			substr(char256,1,descriptive.prec) = substr(v_output,1,descriptive.prec);	*/
/*			end;	*/
/*		goto put_field_string;	*/
/*	*/
/*		end;	*/
/*	*/
/*	if ftype=b_format then	*/
/*		do;	*/
/*		if bc2="sb" then	*/
/*			do;	*/
/*			if type5.ff="v"	*/
/*			then do;	*/
/*				descriptive.prec = ps.vp->based_int;	*/
/*				ps.vp = addrel(ps.vp,1);	*/
/*			end;	*/
/*	*/
/*			if descriptive.prec>256 then goto err264;	*/
/*			if descriptive.prec<0   then goto err265;	*/
/*			substr(vbit256,1,descriptive.prec)=substr(vp->based_bits,1,descriptive.prec);	*/
/*			end;	*/
/*	*/
/*		else	do;	*/
/*			call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec);	*/
/*	*/
/*			if ps.descr="0"b	*/
/*			then do;	*/
/*				call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1);	*/
/*				call assign_(addr(vbit256),v_bit_desc*2,256,addr(buffer),intype,inscale_prec);	*/
/*			end;	*/
/*			else	call assign_(addr(vbit256),v_bit_desc*2,256,ps.vp,intype,inscale_prec);	*/
/*	*/
/*			descriptive.prec = length(vbit256);	*/
/*	*/
/*			if descriptive.prec>256 then goto err264;	*/
/*			if descriptive.prec<0   then goto err265;	*/
/*			end;	*/
/*	*/
/*		char256=(128)"0"||(128)"0";	*/
/*			do i= 1 to descriptive.prec;	*/
/*			if substr(vbit256,i,1) then substr(char256,i,1)="1";	*/
/*			end;	*/
/*	*/
/*		go to put_field_string;	*/
/*		end;	*/
/*	*/
/*	if ftype=c_format then	*/
/*		do;	*/
/*		icomplex=1;	*/
/*		format_bp=addrel(format_bp,5);	*/
/*		go to complex_edit_1;	*/
/*		end;	*/
/*	*/
/*ef_prep:		*/
/*	if nval<1 then goto too_few_params;	*/
/*	if iw>256 then go to  bad_string_size;	*/
/*	if iw<0 then goto bad_param_values;	*/
/*	if iw=0 then goto edit_exit;	*/
/*	*/
/*	lzero=0;	*/
/*	sign_char="+";	*/
/*	efbuf="";	*/
/*	*/
/*	if ftype=e_format then	*/
/*		do;	*/
/*	*/
/*			/* E format forms - AG94 preserves the Y33 forms	*/
/*	*/
/*			  zeros		nonzeros	*/
/*	*/
/*			     0e+000	    56e-123	s>0,d=0 [s=2,d=0]	*/
/*			 0.000e+000	56.123e-123	s>d>0   [s=5,d=3]	*/
/*			 0.000e+000	 0.123e-123	s=d>0   [s,d=3]	*/
/*			*/
/*	*/
/*			/* check parameters, make defaults */
/*		if nval<2 then id=iw-8;	*/
/*		else do;	*/
/*			id = format_block.val(2);	*/
/*			if id>59 then goto bad_param_values;	*/
/*			end;	*/
/*		if nval<3 then is=id+1;	*/
/*		else do;	*/
/*			is=format_block.val(3);	*/
/*			if id>59 then goto bad_param_values;	*/
/*			end;	*/
/*	*/
/*		if id<0 | is<id | is<1 then goto bad_param_values;	*/
/*		if id>iw then goto sig_size_for_ef;	*/
/*	*/
/*	*/
/*			/* prepare to convert INPUT to decimal float */
/*	*/
/*			/* NB: Technically, according to AG94-0, two	*/
/*			   conversions take place.  First, INPUT->FLO DEC(n_input)	*/
/*			   and then FLO DEC(n_input)->FLO DEC(n_format).	*/
/*	*/
/*			   However, AG94 says elsewhere that precision of	*/
/*			   floating point number is the _m_i_n_i_m_u_m number of	*/
/*			   digits which must be kept; I may elect to keep	*/
/*			   more;  and no double rounding may occur (except due to	*/
/*			   bin->dec) and so the single conversion done here	*/
/*			   is functionally equivalent to the double conversion	*/
/*			   specified.      */
/*	*/
/*		if icomplex=2 then	ddflo="1001100"b;	*/
/*		else		ddflo="1001010"b;	*/
/*		if is>59 then	*/
/*			do;	*/
/*			lzero=is-59;	*/
/*			ipreciz=59;	*/
/*			end;	*/
/*	*/
/*		else	ipreciz=is;	*/
/*	*/
/*		expstr="e+000";	*/
/*		if id>0 then idn=1; else idn=0;	*/
/*	*/
/*		addr(ddflo)->m_12=addr(ipreciz)->m_12;	*/
/*	*/
/*		call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec);	*/
/*		call assign_type_d(ddflo,psp,outpicture_p,outtype,outscale_prec);	*/
/*	*/
/*		if ps.descr="0"b	*/
/*		then do;	*/
/*			call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1);	*/
/*			call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec);	*/
/*		end;	*/
/*		else	call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec);	*/
/*	*/
/*			/* ************************** */
/*			/* 			*/
/*			/*  must contrive that this	*/
/*			/*  conversion is ROUNDED	*/
/*			/*			*/
/*			/* ************************** */
/*	*/
/*		if icomplex=2 then	substr(decimal,1,ipreciz+2)=	*/
/*				substr(decimal,ipreciz+3,ipreciz+2);	*/
/*	*/
/*			do i= 2 to ipreciz+1;	*/
/*			if substr(decimal,i,1)^="0" then go to float_signif;	*/
/*			end;	*/
/*	*/
/*		lzero=id+1+idn;	*/
/*		ief=260-lzero;	*/
/*		goto finish_e_picture;	*/
/*	*/
/*float_signif:	*/
/*		exp=0;	*/
/*		addr(exp)->last_char=substr(decimal,ipreciz+2,1);	*/
/*		if exp>=128 then exp=exp-256;	*/
/*		if i>2 then	*/
/*			do;	*/
/*			exp=exp+2-i;	*/
/*			decimal_temp=decimal;	*/
/*			substr(decimal,2,ipreciz)=	*/
/*			substr(decimal_temp,i,ipreciz+2-i)||	*/
/*			substr(decimal_temp,2,i-2);	*/
/*			end;	*/
/*		sign_char=substr(decimal,1,1);	*/
/*	*/
/*			/* make up non-trivial expstr */
/*	*/
/*		exp=exp +id +ipreciz -is;	*/
/*			/* shift decimal point to left (ipreciz),	*/
/*			   then to far right (is), then to proper	*/
/*			   decimal point (id)	*/
/*			*/
/*	*/
/*		if exp<0 then	*/
/*			do;	*/
/*			exp=-exp;	*/
/*			substr(expstr,2,1)="-";	*/
/*			end;	*/
/*		if exp>=100 then	*/
/*			do;	*/
/*			exp=exp-100;	*/
/*			substr(expstr,3,1)="1";	*/
/*			end;	*/
/*		substr(expstr,4,2)=dgt(divide(exp,10,35,0))||dgt(mod(exp,10));	*/
/*	*/
/*		ief=260 - is -idn;		/* leaving space for decimal point if necessary */
/*		topdigits=is - id;	*/
/*	*/
/*		if topdigits >= ipreciz then	*/
/*			do;		/* -xxxxxx000.00000e+000  */
/*					/* if id=0 then topdigits=is	*/
/*					   and topdigits >= ipreciz;	*/
/*					   thus, id=0 is handled here */
/*			substr(efbuf,ief,ipreciz)=substr(decimal,2,ipreciz);	*/
/*			lzero=lzero+idn;	*/
/*			end;	*/
/*	*/
/*		else	do;	*/
/*					/* -xxxxx.xx0000000e+000  */
/*					/* id^=0  */
/*			substr(efbuf,ief,topdigits)=substr(decimal,2,topdigits);	*/
/*			substr(efbuf,ief+topdigits+1,ipreciz-topdigits)=	*/
/*			substr(decimal,topdigits+2,  ipreciz-topdigits);	*/
/*	*/
/*			if is=id then	*/
/*				do;	*/
/*					/* -0.xxxxxxxx00000000e+000  */
/*				ief=ief-1;	*/
/*				substr(efbuf,ief,1)="0";	*/
/*				end;	*/
/*	*/
/*			end;	*/
/*	*/
/*finish_e_picture:	*/
/*		substr(efbuf,260-lzero,lzero)=substr(zeroes,1,lzero);	*/
/*		if idn=1 then substr(efbuf,259-id,1)=".";	*/
/*		substr(efbuf,260,5)=expstr;	*/
/*	*/
/*		goto put_field_ef;	*/
/*	*/
/*		end;	*/
/*	*/
/*	*/
/*	if ftype=f_format then	*/
/*		do;	*/
/*	*/
/*		/* F-format output forms:	*/
/*		zero		nonzero	*/
/*		    0		  123  	d=0	*/
/*		0.000		0.012	d>0	*/
/*		0.000	        345.123	d>0	*/
/*							*/
/*		if nval<1 then go to too_few_params;	*/
/*		if nval<2 then id=0;	*/
/*		else id=format_block.val(2);	*/
/*		if nval<3 then ip=0;	*/
/*		else ip=format_block.val(3);	*/
/*		if id<0 then go to bad_param_values;	*/
/*		if id>iw then goto sig_size_for_ef;	*/
/*	*/
/*		if icomplex=2 then	ddfix="100101100000000000000000000000111011"b;	*/
/*		else		ddfix="100100100000000000000000000000111011"b;	*/
/*	*/
/*			/* AG94-0 specifies two conversions:	*/
/*			   First, INPUT to DEC (fix/flo according to INPUT)	*/
/*					   (prec,scale according to INPUT)	*/
/*			   Multiply the result of this by 10**ip.	*/
/*			   Second, intermediate-value -> FIX DEC(p,q) where	*/
/*			   p and q come from the format:	*/
/*				if d=0, (w-1,0)	*/
/*				else    (w-2,d)	*/
/*			   I do not do these two conversions at present.	*/
/*			   As a result, my CHAR->F-format can preserve	*/
/*			   the fractional part of a CHAR like "23.456"	*/
/*			   whereas AG94-0 calls for CHAR->FIX DEC(59,0)	*/
/*			   which would lose the fractional part.	*/
/*	*/
/*			*/
/*	*/
/*	*/
/*		dscale=id+ip;	*/
/*		substr(ddfix,13,12)=addr(dscale)->m_12;	*/
/*	*/
/*		call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec);	*/
/*		call assign_type_d(ddfix,psp,outpicture_p,outtype,outscale_prec);	*/
/*	*/
/*		if ps.descr="0"b	*/
/*		then do;	*/
/*			call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1);	*/
/*			call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec);	*/
/*		end;	*/
/*		else	call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec);	*/
/*	*/
/*			/* ************************** */
/*			/* 			*/
/*			/*  must contrive that this	*/
/*			/*  conversion is ROUNDED	*/
/*			/*			*/
/*			/* ************************** */
/*	*/
/*		if icomplex=2 then substr(decimal,1,60)=substr(decimal,61,60);	*/
/*	*/
/*	*/
/*			do i=2 to 60;	*/
/*			if substr(decimal,i,1)^="0" then go to fixed_signif;	*/
/*			end;	*/
/*	*/
/*		ipreciz=1;	*/
/*		go to build_fixed_output;	*/
/*	*/
/*fixed_signif:	*/
/*		ipreciz=61-i;	*/
/*		sign_char=substr(decimal,1,1);	*/
/*	*/
/*build_fixed_output:	*/
/*		if id=0|id>=ipreciz then	*/
/*			do;	*/
/*			ief=265-ipreciz;	*/
/*			substr(efbuf,ief,ipreciz)=substr(decimal,61-ipreciz,ipreciz);	*/
/*			if id=0 then go to put_field_ef;	*/
/*	*/
/*			ief=263-id;	*/
/*			lpref=id+2-ipreciz;	*/
/*			substr(efbuf,ief,lpref)=substr(zeroes,2,lpref);	*/
/*			substr(efbuf,ief+1,1)=".";	*/
/*			end;	*/
/*	*/
/*		else	do;	*/
/*			ief=264-ipreciz;	*/
/*			substr(efbuf,ief,ipreciz+1)=	*/
/*			substr(decimal,i,ipreciz-id)||"."||	*/
/*			substr(decimal,61-id,id);	*/
/*			end;	*/
/*		goto put_field_ef;	*/
/*		end;	*/
/*	*/
/*	if ftype=picture_format	*/
/*	then	goto pic_format;	*/
/*	*/
/*	go to no_such_format_type;	*/
/*	*/
/*	*/
/*	*/
/*	*/
/*put_field_ef:	*/
/*	if sign_char="-" then	*/
/*		do;	*/
/*		ief=ief-1;	*/
/*		substr(efbuf,ief,1)="-";	*/
/*		end;	*/
/*	if (265-ief)>iw then	*/
/* sig_size_for_ef:	*/
/*	call plio2_signal_$s_(psp,"SIZE","put_edit",263);	*/
/*	substr(char256,1,iw)=substr(efbuf,265-iw,iw);	*/
/*	go to put_field_edit;	*/
/*	*/
/*	*/
/*	*/
/*put_field_string:	*/
/*	if nval<1 then iw=descriptive.prec;	*/
/*	if iw>256 then goto bad_string_size;	*/
/*	if iw<0   then goto bad_param_values;	*/
/*	*/
/*	if iw<descriptive.prec then call plio2_signal_$s_(psp,"STRINGSIZE","pve",-1);	*/
/*	else	if iw>descriptive.prec then substr(char256,descriptive.prec+1,iw-descriptive.prec)=" ";	*/
/*	goto put_field_edit;	*/
/*	*/
/*put_field_edit:	*/
/*		if iw>256 then goto bad_string_size;	*/
/*		if iw>0 then call plio2_put_util_$put_field_(psp,addr(char256),iw);	*/
/*edit_exit:	*/
/*		if icomplex=1 then	*/
/*			do;	*/
/*			icomplex=2;	*/
/*			format_bp=addrel(format_bp,5);	*/
/*			go to complex_edit_1;	*/
/*			end;	*/
/*		return;	*/
/*	*/
pve_error:entry(pspp);		/* entry added for use by pl1_operators when	*/
			/* in checking a f_format finds that the size	*/
			/* has been violated.  This way the buffer gets	*/
			/* put out and full processing of the condiition	*/
			/* is possible.*/

	psp=pspp;
	call plio2_signal_$s_(psp,"SIZE","put_edit",263);
	return;


end plio2_pve_;




		    plio2_qge_.pl1                  10/03/83  1722.3rew 10/03/83  1005.5      201708



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

quick_get_edit_:
plio2_qge_: proc (pspp) options (support);

/* Written by R.Schoeman Spring 1977 to replace plio2_gve_ with faster algorithms & code.	*/
/* Modified 780223 by PG to fix 1709 (get edit failed when very first thing was column format). */
/* Modified 780406 by RAB to fix 1724 (seg fault with get string edit doing col format with no newline). */
/* Modified 780718 by RAB to make slightly more quit-start proof */

/*	plio2_qge_$
   is called from the user's procedure to get one
   value in edit-directed mode and, of course, to
   perform such control functions as may correspond
   to formats preceeding the next data format.

   This procedure is called from put_format_.alm in the operators,
   which has already walked the format list and gotten the next prepared format
   item. This procedure gets the input field of the length defined by that
   format and does the necessary conversions, finally assigning the
   value to the variable specified by the ps.
  It is analagous to the latter half of put_format_.alm, which does
   the output conversions for pl1 edit_directed io.
*/

dcl (erno init (999), ftype, nval, i, j,
     radix_factor, first_bit,
     to_move, targ_index, si, cc,
     string_start, first_char_len,
     old_nl, from_old_nl,
     oncharind, icomplex) fixed bin (15);

dcl (char_pic_format, warned) bit (1) aligned;

dcl  code fixed bin (35);
dcl  x char (1) aligned;
dcl  conname char (12);
dcl  ctl_char char (1) aligned;
dcl  ctl_chars char (4) aligned init (
     "	
") options (constant) int static;

/* The preceding four characters were , in order: carriage_return, horizontal tab, new_line, and new_page 	*/

dcl  based_char256 char (256) based;
dcl  based_packed_ptr ptr unaligned based;
dcl  char_array (1000) char (1) unaligned based;

dcl 1 based_byte_array (60) unal based (addr (buffer (icomplex))),
    2 unused bit (1) unal,
    2 exp_fac fixed bin (7) unal;

dcl  buf1000 char (1000);
dcl  new_line char (1) aligned int static options (constant) init ("
");

dcl  tab char (1) aligned int static options (constant) init ("	");



dcl (error_table_$short_record,
     error_table_$long_record,
     error_table_$end_of_info) external static fixed bin (35);

dcl (pspp, psp, fp, pic_ptr, targ_ptr, in_ptr) ptr;

dcl 1 facts (2),
    2 (pow, sc, iw, ef, use) fixed bin (15);


dcl 1 info_struct,
    2 next_position fixed (21),			/* output */
    2 last_position fixed (21);			/* output */


dcl (n_read, n_left, tk) fixed bin (21);


dcl 1 fb based (ps.format_area_p),
    2 type fixed bin (15),
    2 nval fixed bin (15),
    2 val (3) fixed bin (15);

dcl 1 fbc (0:2) based (fp),
    2 type fixed bin (15),
    2 nval fixed bin (15),
    2 val (3) fixed bin (15);

dcl  types (2) fixed bin (17),

     scale_prec (2) fixed bin (35),

     1 fo (2) based (addr (scale_prec (1))) aligned,
     2 scale fixed bin (17) unal,
     2 prec fixed bin (17) unal;

dcl 1 dec_fixed (2) based (addr (space)) unal,
    2 sign_of_mantissa char (1) unal,
    2 mantissa char (info.inprec) unal;

dcl 1 dec_float (2) based (addr (space)) unal,
    2 sign_of_mantissa char (1) unal,
    2 mantissa char (info.inprec) unal,
    2 unused bit (1) unal,
    2 exponent fixed bin (7) unal;

dcl (dec_pos, e_pos, exp_sign_pos) fixed bin (17);

dcl  buffer (2) char (64) aligned,
     space char (128) aligned;



dcl (addr, addrel, fixed, index, min, max, mod, length, search, substr, unspec, reverse, size,
     ltrim, rtrim) builtin;


dcl  put_copy_ ext entry (ptr, fixed bin (21));

dcl  iox_$get_chars ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (15));
dcl  plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15));
dcl  plio2_signal_$conversion_error_ ext entry (ptr, char (*), fixed bin (15), ptr, fixed bin (15), fixed bin (15), fixed bin (15));
dcl  plio2_resig_ ext entry (ptr);

dcl  conversion condition;

%include pl1_stack_frame;
%include desc_dcls;
%include desc_types;
%include radix_factor_constants;
%include descriptor;
%include picture_desc_;
%include picture_image;
%include picture_types;
%include picture_util;
%include plio_format_codes;
%include plio2_ps;
%include system;


/* QUICK declarations, i.e. dcls for quick_get_edit */

dcl 1 def_desc structure aligned based (addr (ps.descr)) like desc_;
%include plio2_fsb;

dcl  iocbp ptr;
dcl (targ_type) fixed bin (17) aligned;

dcl 1 scale_prec_ aligned,
    2 scale fixed bin (17) unal,
    2 prec fixed bin (17) unal;

dcl  fb35_based fixed bin (35) based aligned;

dcl 1 s,
    2 width fixed bin (17),
    2 chars char (256);

dcl  def_string char (256) varying based (addr (s));
dcl  imag_def_string varying char (256);

dcl  bit_str bit (256) aligned;
dcl  max_io_string_length int static options (constant) fixed bin (17) init (256);

/*		*/

	psp = pspp;

	on conversion call plio2_resig_ (psp);

	ps.auxp = addr (s);
	icomplex = 1;	/* This index is used to cycle through the 2 conversions
			   needed for a complex format. If its not a complex format,
			   this index is always "1".	*/
	nval = fb.nval;
	ftype = fb.type;
	iocbp = ps.fsbp -> fsb.iocb_p;
	if ftype ^= bn_format
	then s.width = fb.val (1);
	else s.width = fb.val (2);
	goto char_length_action (ftype);

char_length_action (3):				/* complex stuff */

	fp = ps.format_area_p;

	do i = 1 to 2;
	     if fbc (i).nval < 1
	     then goto err148;

	     facts.iw (i) = fbc (i).val (1);
	     if facts.iw (i) < 0
	     then goto err145;
	end;
	s.width = facts.iw (1) + facts.iw (2);
					/* The length of a complex format item is the
					   sum of the lengths of its real & cplx parts.	*/

/* INTENTIONAL FALL THROUGH HERE !!	*/

char_length_action (1):
						/*	 l_paren	*/
char_length_action (2):
						/*	r_format	*/
char_length_action (4):
						/*	f_format	*/
char_length_action (5):
						/*	e_format	*/
char_length_action (6):
						/*	b_format	*/
char_length_action (7):
						/*	a_format	*/
char_length_action (8):
						/*	x_format	*/
char_length_action (13):
						/*	picture_format	*/
char_length_action (14):				/* normal input chars */
						/*	bn_format	*/

	if nval < 1
	then goto err148;

	if s.width < 0
	then goto err145;
	else if s.width > max_io_string_length
	then goto err149;

/* Although it would be nice to optimize the case of char input string going to
   a char target, the problem of padding if too short and raising stringsize if too
   long means that a prohibitive amount of processing by hand would have to be done. */

	if s.width>0
	then do;
	     targ_ptr = addr (s.chars);
	     to_move = s.width;
	     call get_chars;			/* targ_ptr & to_move are the pseudo_args */
	end;


	goto process_format (ftype);


char_length_action (9):				/* input lines */
						/* skip format	*/
	if nval < 1
	then call get_skip (1);
	else call get_skip (s.width);


	goto all_done;


char_length_action (10):
						/* column format */
	if fb.nval ^= 1				/* This test should be unnecessary, because compiler should prevent this case from occuring */
	then goto err148;

	if fb.val (1) < 1
	then goto err145;
	else tk = fb.val (1)-1;
				/* tk is the target column number, starting at 0,
				   therefore it is equal to the pl1 col #,
				   which starts at one, minus 1.	*/


	if fsb.kol = tk
	then goto all_done;

	warned = "0"b;

	if fsb.kol > tk
	then call get_skip (1);
				/* If the present column is greater than the
				   desired column, look for that column on the
				   NEXT line.	*/

	n_left = chars_left_on_line ();
				/* This internal subroutine returns the number of
				   chars left on the present line. If there are
				   enough to go to the requested column,move the
				   requisite distance, otherwise AG94 says skip to
				   the next line & you're done.	*/

	if n_left > tk-fsb.kol
	then do;
	     to_move = tk-fsb.kol;
	     if to_move > 1000
	     then goto err180;
	     targ_ptr = addr (buf1000);
	     call get_chars;
	     if index (substr (buf1000, 1, to_move), tab) > 0
	     then call tab_in_col_input;
	     goto all_done;
	end;
	else do;
	     call get_skip (1);
	     goto all_done;
	end;

char_length_action (11):
char_length_action (12):				/* illegal input format */
	goto err147;



null_string:
	intype = char_desc * 2;
	in_ptr = addr (s.chars);
	inscale_prec = 0;
	goto final_conv;

process_format (3):					/* complex */

	first_char_len = ps.format_area_p -> fbc (1).val (1);
	imag_def_string = substr (def_string, first_char_len+1);
	def_string = substr (def_string, 1, first_char_len);

	do icomplex = 1 to 2;

	     ps.format_area_p = addrel (ps.format_area_p, size (fb));
	     if icomplex = 2
	     then def_string = imag_def_string;
	     if fb.type = picture_format
	     then call p_format_proc;
	     else if fb.type = e_format
	     then call e_format_proc;
	     else if fb.type = f_format
	     then call f_format_proc;
	     else goto err259;
	     types (icomplex) = intype;
	     scale_prec (icomplex) = inscale_prec;
	end;

	ps.format_area_p = addrel (ps.format_area_p, -2* (size (fb)));
	if types (1) = D_fixed_real_desc*2
	& types (2) = D_fixed_real_desc*2
	then do;
	     intype = D_fixed_real_desc*2+1;
	     info.inprec = min (max_p_dec, max (fo.prec (1)-fo.scale (1), fo.prec (2)-fo.scale (2))+max (fo.scale (1), fo.scale (2))+1);
	     info.inscale = max (fo.scale (1), fo.scale (2));

	     do i = 1 to 2;
		call assign_ (addr (dec_fixed (i)), intype, inscale_prec, addr (buffer (i)),
		     types (i), scale_prec (i));
	     end;

	     intype = D_fixed_cplx_desc*2+1;
	end;
	else do;
	     intype = D_float_real_desc*2+1;
	     info.inprec = max (fo.prec (1), fo.prec (2));
	     info.inscale = 0;

	     do i = 1 to 2;
		call assign_ (addr (dec_float (i)), intype, inscale_prec, addr (buffer (i)),
		     types (i), scale_prec (i));
	     end;

	     intype = D_float_cplx_desc*2+1;
	end;

	in_ptr = addr (space);
	goto final_conv;

process_format (4):					/* fixed format */
	string_start = 1;
	in_ptr = addr (buffer (icomplex));
	call f_format_proc;
	goto final_conv;


process_format (5):					/* e_format */
	string_start = 1;
	in_ptr = addr (buffer (icomplex));
	call e_format_proc;
	goto final_conv;


process_format (6):					/* b_format */
process_format (14):				/* bn_format */

	def_string = ltrim (rtrim (def_string));
	if s.width = 0
	then goto null_string;
	if ftype = b_format
	| fb.val (1) = 1
	then do;
	     call assign_ (addr (bit_str), bit_desc * 2, addr (s.width) -> fb35_based, addr (s.chars), char_desc * 2, addr (s.width) -> fb35_based);
	     radix_factor = 1;
	end;
	else do;
ce_return:
	     radix_factor = fb.val (1);
	     if s.width * radix_factor > max_io_string_length
	     then goto err144;

	     if radix_factor = 4
	     then if search (def_string, capital_hex) > 0
		then substr (digits (4), 11, 6) = capital_hex;
		else substr (digits (4), 11, 6) = lower_case_hex;

	     do i = 1 to length (def_string);
		x = substr (def_string, i, 1);
		si = index (digits (radix_factor), x);
		if si = 0
		then goto CE_for_bn;
		first_bit = (radix_factor* (si-1))+1;
		substr (bit_str, radix_factor* (i-1)+1, radix_factor) =
		     substr (expand_bits (radix_factor), first_bit, radix_factor);
	     end;
	end;

	in_ptr = addr (bit_str);
	intype = bit_desc * 2;			/* bit_desc * 2 */
	inscale_prec = s.width*radix_factor;
	goto final_conv;

process_format (7):					/* a_format	*/


/* 1st figure out output type, from ps.descr & ps.value_p, then call assign_	*/
/* to convert it & store result in ps.value_p.				*/

	intype = char_desc * 2;			/* char_desc * 2	*/
	in_ptr = addr (s.chars);
	inscale_prec = s.width;

final_conv:
	if ps.descr = "0"b
	then do;
	     pic_ptr = psp -> ps.stack_frame_p -> pl1_stack_frame.text_base_ptr;
	     pic_ptr = addrel (pic_ptr, psp -> ps.top_half);

	     call set_pic_args;
	     if targ_type = char_desc * 2 & ftype = picture_format & char_pic_format
	     then do;
		if scale_prec_.prec < inscale_prec
		then call plio2_signal_$s_ (psp, "stringsize", "quick_get_edit", -1);
		else if scale_prec_.prec > inscale_prec
		then substr (s.chars, s.width+1) = "";
		call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1,
		     addr (s.chars) -> char1);
	     end;
	     else do;
		call assign_ (addr (buffer (1)), targ_type, addr (scale_prec_) -> fb35_based,
		     in_ptr, intype, inscale_prec);
		call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (buffer (icomplex)) -> char1);
	     end;
	     goto all_done;
	end;
	unspec (desc_) = unspec (ps.descr);
	targ_type = desc_.type_ * 2+ fixed (desc_.pack_, 17, 0);
	if targ_type = v_char_desc * 2 | targ_type = v_bit_desc * 2
	then targ_ptr = addrel (ps.value_p, -1);
	else targ_ptr = ps.value_p;
	scale_prec_.scale = desc_.scale_;
	scale_prec_.prec = desc_.precision_;
	call assign_ (targ_ptr, targ_type, addr (scale_prec_) -> fb35_based,
	     in_ptr, intype, inscale_prec);
	goto all_done;

process_format (13):				/* picture format */
	string_start = 1;
	in_ptr = addr (buffer (icomplex));
	call p_format_proc;
	goto final_conv;


/*		*/
err180:
	erno = 180;
	goto allerr;

err181:
	erno = 181;
	goto allerr;

err182:
	erno = 182;
	goto allerr;

err145:
	erno = 145;
	goto allerr;

eof163:
	erno = 163;
	conname = "ENDFILE";
	goto sandr;

err147:
	erno = 147;
	goto allerr;

err162:
	erno = 162;
	goto allerr;

err163:
	erno = 163;
	goto allerr;

err148:
	erno = 148;
	goto allerr;

err144:
	erno = 144;
	goto allerr;

err149:
	erno = 149;
	goto allerr;

err150:
	erno = 150;
	goto allerr;

err216:
	erno = 216;
	goto allerr;

err217:
	erno = 217;
	goto allerr;

err259:
	erno = 259;
	goto allerr;
allerr:
	conname = "ERROR";

/* One can NEVER return from these error-raising calls except for conversion_error !	*/

sandr:
	call plio2_signal_$s_r_ (psp, conname, "quick_get_edit", erno);

CE_for_bn:
	call plio2_signal_$conversion_error_ (psp, "quick_get_edit_bn", 151, addr (s.chars), 1,
	     (s.width), i);
	goto ce_return;

raise_transmit:
	call plio2_signal_$s_r_ (psp, "TRANSMIT", "quick_get_edit", 183);

process_format (8):					/* x_format is total ignore so KEEP label on all_done */
all_done:
	return;
						/*		*/
p_format_proc: proc;

	     pic_ptr = addr (fb.val (2)) -> based_packed_ptr;
val_pic:
	     call validate_picture_ (addr (s.chars) -> char1, pic_ptr -> char1,
		erno, oncharind);
	     if erno ^= 0
	     then do;
		call plio2_signal_$conversion_error_ (psp, "quick_get_edit", erno,
		     addr (s.chars), 1, (s.width), oncharind);
		goto val_pic;
	     end;
	     if pic_ptr -> picture_image.type = char_picture /* char */
	     then do;
		in_ptr = addr (s.chars);
		intype = char_desc * 2;
		inscale_prec = s.width;
		char_pic_format = "1"b;
	     end;

	     else do;
		call unpack_picture_ (addr (buffer (icomplex)) -> char1,
		     pic_ptr -> char1, addr (s.chars) -> char1);
		intype = type (pic_ptr -> picture_image.type);
		info.inscale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor;
		info.inprec = pic_ptr -> picture_image.prec; /* type cant be  char cause that already has been filtered out prior to unpack  call */
		in_ptr = addr (buffer (icomplex));
		char_pic_format = "0"b;
	     end;


	end p_format_proc;

/*		*/
f_format_proc: proc;

	     def_string = ltrim (rtrim (def_string));
	     dec_pos = index (def_string, ".");

	     if length (def_string) = 0
	     then def_string = "0";			/* else char_to_numeric will call it fixed bin, not fixed dec */

	     call char_to_numeric_ (addr (buffer (icomplex)), intype, inscale_prec, addr (s.chars), length (def_string));

	     if intype ^= D_fixed_real_desc*2
	     then goto err150;

	     if dec_pos > 0
	     then info.inscale = length (def_string) - dec_pos;
	     else if fb.nval > 1
	     then info.inscale = fb.val (2);
	     if fb.nval > 2
	     then info.inscale = info.inscale - fb.val (3);

	     if info.inscale < min_scale
	     then goto err217;
	     else if info.inscale > max_scale
	     then goto err216;

	end f_format_proc;

/*		*/
e_format_proc: proc;

	     def_string = ltrim (rtrim (def_string));
	     dec_pos = index (def_string, ".");
	     e_pos = index (def_string, "e");
	     if length (def_string) = 0
	     then def_string = "0e0";			/* KLUDGE to make zero-len string work	*/
	     else do;
		exp_sign_pos = search (substr (def_string, 2), "+-")+1;

		if e_pos = 0
		then if exp_sign_pos = 1
		     then def_string = def_string||"e0";
		     else def_string = substr (def_string, 1, exp_sign_pos-1)||"e"||substr (def_string, exp_sign_pos);
	     end;

	     call char_to_numeric_ (addr (buffer (icomplex)), intype, inscale_prec, addr (s.chars), length (def_string));

	     if intype ^= D_float_real_desc*2
	     then goto err182;

	     if dec_pos = 0
	     then if fb.val (2) ^= 0
		then do;
		     based_byte_array (inscale_prec+2).exp_fac = based_byte_array (inscale_prec+2).exp_fac-fb.val (2);
		     if based_byte_array (inscale_prec+2).exp_fac > max_scale
		     then goto err216;
		     else if based_byte_array (inscale_prec+2).exp_fac < min_scale
		     then goto err217;
		end;


	end e_format_proc;


/*		*/
set_pic_args: proc;
	     targ_type = type (pic_ptr -> picture_image.type);
	     scale_prec_.scale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor;
	     if targ_type = char_desc * 2		/* char_desc * 2 */
	     then scale_prec_.prec = pic_ptr -> picture_image.varlength;
	     else scale_prec_.prec = pic_ptr -> picture_image.prec;
	end;


/*		*/
get_chars: proc;
						/* INPUT ARGS are targ_ptr, to_move 	*/

	     targ_index = 1;

scan:	     si = min (to_move, fsb.blc-fsb.bnc+1);

	     cc = search (substr (xbuf, fsb.bnc, si), ctl_chars);

	     if cc = 0
	     then do;
		substr (targ_ptr -> based_char256, targ_index, si) = substr (xbuf, fsb.bnc, si);
		fsb.bnc = fsb.bnc + si;
		targ_index = targ_index + si;
		fsb.kol = fsb.kol + si;

		if to_move = si
		then return;

		to_move = to_move - si;

		call refill_buffer;

		if code ^= 0
		then if targ_index = 1
		     then goto eof163;
		     else goto err163;

		goto scan;
	     end;

	     ctl_char = substr (xbuf, fsb.bnc+cc-1, 1);

	     if ctl_char ^= tab
	     then do;
						/* The remaining ctl chars are new_line, new_page, and carriage return	*/
		substr (targ_ptr -> based_char256, targ_index, cc-1) = substr (xbuf, fsb.bnc, cc-1);
		to_move = to_move - cc + 1;
		fsb.bnc = fsb.bnc+cc;
		targ_index = targ_index+cc-1;
		if ctl_char = new_line
		then fsb.kol = 0;
		else fsb.kol = fsb.kol+cc-1;
		goto scan;
	     end;

	     substr (targ_ptr -> based_char256, targ_index, cc) = substr (xbuf, fsb.bnc, cc);
	     fsb.bnc = fsb.bnc+cc;
	     targ_index = targ_index+cc;
	     to_move = to_move-cc;

	     fsb.kol = fsb.kol + cc;
	     fsb.kol = fsb.kol+10-mod (fsb.kol, 10);
	     goto scan;

	end get_chars;
						/*		*/
refill_buffer: proc;

	     if ps.copy
	     then do;
		call put_copy_ (psp, fsb.blc);
		ps.start_copy = 1;
	     end;

	     if ps.string
	     then goto err162;

	     fsb.blc = 0;	/* protects us somewhat from quit-start */
	     fsb.bnc = 1;	/* .. */

	     if fsb.console
	     then call iox_$get_line (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code);
	     else call iox_$get_chars (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code);

	     fsb.bnc = 1;

	     if code ^= 0
	     then if code = error_table_$long_record|code = error_table_$short_record
		then code = 0;
	     else if code = error_table_$end_of_info
	     then ;
	     else goto raise_transmit;



	end refill_buffer;


/*		*/
chars_left_on_line: proc returns (fixed bin (21));

dcl  n_left fixed bin (21);


	     if fsb.blc = 0				/* never have read from file... */
	     then call refill_buffer;

	     n_left = index (substr (xbuf, fsb.bnc, fsb.blc-fsb.bnc+1), new_line);

	     if n_left > 0
	     then return (n_left);

	     /* Have partial input line (no final NL). Find out why. */

	     from_old_nl = index (reverse (substr (xbuf, 1, fsb.blc)), new_line);

	     if from_old_nl = 0
	     then do;
		if ps.string
		     then return(fsb.blc - fsb.bnc + 1);

		call iox_$get_line (iocbp, addr (xbuf), fsb.bsize, n_read, code);

		if code = error_table_$end_of_info
		then return (fsb.blc - fsb.bnc + 1);
		else goto err181;
	     end;

						/* It should be noted here that if we just returned 0, the col format
						   handling mechanism will shorty raise an end_of_file anyway, by calling
						   a guaranteed subsequent "get_skip(2)"	*/

	     old_nl = fsb.blc-from_old_nl;

	     if ps.copy
	     then do;
		call put_copy_ (psp, fsb.blc);
		ps.start_copy = 1;
	     end;

	     if ps.string
	     then goto err162;



	     substr (xbuf, 1, from_old_nl) = substr (substr (xbuf, 1, from_old_nl), old_nl+1, from_old_nl); /* the +1 is to flush the last NL, too */
	     call iox_$get_line (iocbp, addr (addr (xbuf) -> char_array (from_old_nl+1)),
		fsb.bsize-from_old_nl, n_read, code);
	     if code ^= 0
	     then if code = error_table_$long_record
		then goto err181;
		else if code = error_table_$short_record|code = error_table_$end_of_info
		then code = 0;
		else goto raise_transmit;


	     fsb.bnc = fsb.bnc - old_nl;
	     fsb.blc = from_old_nl+n_read;
	     n_left = fsb.blc-fsb.bnc+1;

	     return (n_left);
	end;
						/*		*/
get_skip:	proc (skip_count_param);

dcl (skip_count, skip_count_param) fixed bin (17) aligned;


	     skip_count = skip_count_param;
	     fsb.kol = 0;

	     do while (skip_count > 0);

		j = index (substr (xbuf, fsb.bnc, fsb.blc-fsb.bnc+1), new_line);

		if j = 0
		then do;
		     call refill_buffer;

		     if code ^= 0
		     then goto eof163;

		end;

		else do;

		     fsb.bnc = fsb.bnc + j;
		     skip_count = skip_count-1;
		end;

	     end;


	end;


/*		*/
tab_in_col_input: proc;

	     if ^warned
	     then call plio2_signal_$s_ (psp, "ERROR", "quick_get_edit", 157);

	     warned = "1"b;
	     return;

	end;
     end;




		    plio2_recio_.pl1                10/03/83  1722.3rew 10/03/83  1005.5      221130



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

plio2_recio_:
     procedure (pspp) options (support);

/* Modified 780830 by RAB to fix bug 1755 (reads of lines > 848 chars fail) */
/* Modified 780718 by RAB to make stream I/O slightly more quit-start proof */
/* Modified 770825 by PG to implement read/write to stream files */
/* 76-09-08:  changed to use the iox_$foo call forwarder	*/
/* 75-07-01:  changed the error handling for rewrite statements
   to fix bug 1378.			*/

/* 75-05-08:  changed the keyto_assignment_made bit to the keyto_keyset bit
   in the psr to support quick keyed record i/o and added code to
   the error entry block.			*/

/* 74-12-31:  changed the rewrite error codes from the incorrect "480", "481",
   to the correct "280", "281".			*/

/* 74-12-17: updated to support bit_string stringvalue io and rewrite
   stringvalue io; to check that varying_array is off before
   accepting that stringvalue is valid; error entry and associated
   code added for use by quick record io.		*/

/* 74-12-2: updated to support env(stringvalue) */

/* 74-8-5: fixed for version-2 of compiler which sets ab-ret label
   in the KEYTO case.   seereferences to keyto_keyset.  */

/* fixed to perform the KEYTO copy before the SET/INTO copy
   74-7-1  B U G :     if abnormal return to user, KEYTO post-copy may copy JUNK */


/* 73-12-12: updated for change from File Manager to iox_
   please note that the new KEY is char256v, the old KEY
   is c32, both starting in the same place.  */

/* 1-3-73:	removed all traces of locking.
   corrected test for no-file to include no-dir
   as well as noentry.  */

/* parameters */

dcl (error_status fixed bin (35),
     pspp ptr
     ) parameter;

/* automatic */

dcl  buffer_len fixed bin (21);
dcl  bytes_read fixed bin(21);
dcl  char_buffer bit (1) aligned;
dcl  conname char (16);
dcl  copy_len fixed bin (21);
dcl (psp, fsbp, wptr, copyp, statep) ptr;
dcl (i, erno init (975), code init (0), ballocn) fixed bin (17);
dcl (wlen, release, copyn, rlength, xrlength, vlength) fixed bin (21);
dcl  ends_in_NL bit (1) aligned;
dcl  iocb_p ptr;
dcl  iocb_status fixed bin (35);
dcl  onkeyx char (256) varying;
dcl 1 reciofab aligned,
    2 sw bit (36),
    2 name char (32);
dcl  scan_index fixed bin (21);
dcl  signal_record bit(1) aligned;
dcl (test_18, job_18) bit (18) aligned;
dcl  valid_stringvalue bit (1) aligned;
dcl  vptr ptr;
dcl  w_char_buffer bit (1) aligned;
dcl 1 work aligned like psr.job;

/* based */

dcl  based_pointer ptr based;
dcl 1 buffer_state based (statep) aligned,
    2 blen fixed bin (15),
    2 bmax fixed bin (15),
    2 bptr ptr,
    2 bsw aligned,
      3 (exists, pad, use) bit (1) unaligned;
dcl  balloc char (ballocn) aligned based;		/* ballocn must be a byte-length */
dcl  based_packedptr ptr unaligned based;
dcl  bc32 char (32) aligned based;
dcl  based_label label based;
dcl  release_bits bit (36) aligned based (addr (release));
dcl  string_len fixed bin (24) based;
dcl  variable_overlay char (vlength) based (vptr);
dcl 1 work_overlay aligned based (addr (work)),
    2 pad1 bit (27) unal,
    2 nofrom bit (1) unal,
    2 nokey bit (1) unal,
    2 nokeyfrom bit (1) unal,
    2 nolock bit (1) unal,
    2 close bit (1) unal,
    2 pad2 bit (4) unal;

/* NOTE: the bits of "job" and, thus, of "work"
   ending on the 34-th (six bits
   are reserved) contain the "release-number" of
   the io_semantics which produced the calling
   program.  Since these bits are reused by
   RECIO, the release number must be extracted
   and its bits reset to zero.

   release 1:     implements the 256-char var KEY
   sets the not_bytebuffer bit.

   release 2:	implements ab-return in KEYTO case.
   */

/* entries */

dcl  iox_$delete_record entry (ptr, fixed bin (35)),
     iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$read_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
dcl  iox_$read_length entry (ptr, fixed bin (21), fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (17));
dcl  plio2_open_$open_implicit_ ext entry (ptr);

/* builtins */

dcl (addr, addrel, divide, fixed, index, length, min, mod, string, substr) builtin;

/* external static */

dcl (plio2_data_$pspstat,
     plio2_data_$fsbpstat) ptr external;
dcl (error_table_$no_record,
     error_table_$long_record,
     error_table_$short_record,
     error_table_$key_order,
     error_table_$end_of_info
     ) fixed bin (35) external;

/* internal static */

dcl  NL char (1) internal static options(constant) init ("
");

/* include files */

%include pl1_file_value;
%include plio2_fsb;
%include plio2_fsbr;
%include plio2_psr;
%include its;

/* program */

	plio2_data_$pspstat,
	     psp = pspp;

	string (work) = string (psr.job);
	release = 0;
	substr (release_bits, 31, 6) = substr (string (work), 28, 6); /* release number of io_semantics */
	substr (string (work), 28, 6) = "000000"b;	/* these bits are re-used by RECIO */

	if work.keyto then psr.keyto_keyset = "0"b;
	else addr (psr.ab_return) -> based_label = EXIT;
						/* ab-ret label is set by compiler/runtime
						   only for KEYTO, version 2 and later. */

	psr.file_p = psr.source_p;
	plio2_data_$fsbpstat,
	     fsbp, psr.fsbp = psr.file_p -> file_value.fsb_ptr;

	if ^fsbr.switch.open
	then do;
	     psr.fab2p = addr (reciofab);
	     reciofab.name = " ";
	     if work.read then reciofab.sw = "00000100001"b;
	     if work.write then reciofab.sw = "00000010001"b;
	     if work.rewrite then reciofab.sw = "00000001001"b;
	     if work.delete then reciofab.sw = "0000000100101"b;
	     if work.locate then reciofab.sw = "000000100011001"b;
	     call plio2_open_$open_implicit_ (psp);
	end;

	valid_stringvalue = fsbr.switch.stringvalue & work.varying_string & ^work.varying_array;
	iocb_p = fsbr.iocb_p;
	vlength = psr.variable_bitlen;
	if work.varying_string & ^valid_stringvalue then
	     do;
						/* special code inserted here to handle anomalous case
						   of "into" or "from" option where "target" is a varying
						   string.  For the compiler addresses the data portion
						   of such a string only. */
						/* More queer, an array of varying strings
						   is given its correct length but the address
						   of its second word - whereas a scalar varying string
						   is given the length of its data portion and the
						   address of its data portion. */
	     if ^work.varying_array then vlength = vlength + 36;
	     psr.variable_p = addrel (psr.variable_p, -1);
	end;

	onkeyx = "";

	if work.read & substr (string (work), 24, 3) = "000"b /* (set, into, ignore) = 0 */
	then do;
	     work.ignore = "1"b;
	     psr.number = 1;
	end;

	if (work.write | work.rewrite) & ^work.from
	then work_overlay.nofrom = "1"b;

	if work.write | work.locate
	then if ^work.keyfrom
	     then work_overlay.nokeyfrom = "1"b;
	     else;
	else if ^work.key
	then work_overlay.nokey = "1"b;

	if work_overlay.nokeyfrom & work_overlay.nokey
	then psr.keytemp = "";

/*	TESTING AND SIGNALLING */

	job_18 = substr (string (work), 14, 18);
	test_18 = job_18 & string (fsbr.nono);

	if test_18 ^= "0"b then
	     do;
	     i = index (test_18, "1"b);
	     erno = 251;				/* required option missing */
	     if i<15 then erno = 250;			/* illegal option present or implied */
	     if i<8 then erno = 249;			/* statement type conflicts with file attributes */

signal_error:
	     conname = "ERROR";
	     goto sandr1;

sandr:
	     conname = "TRANSMIT";
sandr1:
	     if iocb_status ^= 0 then fsbr.lnzc = iocb_status;
	     call plio2_signal_$s_ (psp, conname, substr (onkeyx, 1, length (onkeyx)), erno);

	     if work.keyto then if ^psr.keyto_keyset then goto addr (psr.ab_return) -> based_label;

/* The abnormal label is only different from the following return statement
   if KEYTO is specified.  We take it whenever the assignment to the KEYTO-
   TARGET has not been done.  */

EXIT:
						/* the label EXIT M_ U_ S_ T_ identify this return statement !! */

	     return;

sig_rec:
	     conname = "RECORD";
	     go to sandr1;

sig_eof:
	     conname = "ENDFILE";
	     go to sandr1;

sig_key:
	     conname = "KEY";
	     go to sandr1;
	end;


/*	CHECK FOR READ/WRITE TO A STREAM FILE */

	if fsbr.switch.stream			/* A stream file... */
	then do;

	     if work.varying_string
	     then vptr = addrel (psr.variable_p, 1);
	     else vptr = psr.variable_p;

	     if work.read				/* A READ STATEMENT */
	     then do;

		if ^fsb.switch.input
		then do;
		     erno = 289;			/* Stream file referenced by read statement isn't input */
		     go to signal_error;
		end;

/* Fill input buffer, if necessary */

		if fsb.bnc > fsb.blc		/* buffer is empty */
		then do;
		     fsb.blc = 0;
		     call fill_stream_input_buffer ("0"b);
		end;

/* Now grab 1 line out of the buffer */

		/* initialize loop for reading */

		vlength = divide(vlength,9,21,0);

		if work.varying_string
		then vlength = vlength - 4;

		bytes_read = 0;
		signal_record = "0"b;
		ends_in_NL = "0"b;

		/* loop until line is read */

		do while( ^ ends_in_NL & fsb.blc ^= 0);

		     /* scan for a newline */

		     buffer_len = fsb.blc - fsb.bnc + 1;
		     scan_index = index(substr(xbuf, fsb.bnc, buffer_len), NL) - 1;

		     /* remember if newline found */

		     if scan_index >= 0
		     then ends_in_NL = "1"b;
		     else scan_index = buffer_len;

		     /* check if buffer_load will fit in target */

		     if scan_index > vlength - bytes_read
		     then do;
			signal_record = "1"b;
			copy_len = vlength - bytes_read;
			end;
		     else copy_len = scan_index;

		     /* move buffer_load into target */

		     if copy_len > 0
		     then do;
			substr(variable_overlay, bytes_read + 1, copy_len) =
			     substr(xbuf, fsb.bnc, copy_len);
			bytes_read = bytes_read + copy_len;
			end;

		     /* if newline not found, get another buffer_load,
		        otherwise, step past the newline */

		     if ^  ends_in_NL
		     then do;
			fsb.blc = 0;
			call fill_stream_input_buffer("1"b);
			end;
		     else fsb.bnc = fsb.bnc + (scan_index + 1);
		     end;

		fsb.kol = 0;

		/* finish assignment */

		if work.varying_string
		then psr.variable_p -> string_len = bytes_read;
		else if bytes_read < vlength
		     then substr(variable_overlay, bytes_read + 1) = " ";

		if signal_record
		then call plio2_signal_$s_(psp,"RECORD","",294);	/* input line too long */
	     end;
	     else if work.write			/* A WRITE STATEMENT */
	     then do;

		if ^fsb.switch.output
		then do;
		     erno = 290;			/* Stream file referenced by write statement isn't output */
		     go to signal_error;
		end;

		if work.varying_string
		then vlength = psr.variable_p -> string_len;
		else vlength = divide (vlength, 9, 21, 0);

/* Check that the record will fit on the current line. */

		if vlength > fsb.lsize - fsb.kol
		then do;
		     call plio2_signal_$s_ (psp, "RECORD", "", 288);
		     vlength = fsb.lsize - kol;
		     end;
		call iox_$put_chars (iocb_p, vptr, vlength, iocb_status);
		if iocb_status ^= 0 then go to write_error;

		call iox_$put_chars (iocb_p, addr (NL), 1, iocb_status);
		if iocb_status ^= 0 then go to write_error;

		fsb.kol = 0;

		if fsb.switch.print
		then do;
		     fsb.lineno = fsb.lineno + 1;

		     if fsb.lineno = fsb.psize + 1
		     then call plio2_signal_$s_ (psp, "ENDPAGE", "", 234);
		end;
	     end;
	     return;
	end;

/* if FROM/INTO then prepare for buffer operations.
   IOX_ wants to use aligned byte buffers but the program may
   specify a buffer that is not byte aligned OR which is not byte-lengthed,
   either of which necessitates use of bitcopies.   */

	if (work.locate | work.from | work.into) then
	     do;
	     vlength = divide (vlength+8, 9, 21, 0);	/* must be in units of words AND must be tested !! */
	     if release>0 then if ^work.not_bytebuffer then char_buffer = "1"b;
		else do;
		     if mod (psr.variable_bitlen, 9) ^= 0 then goto not_byteish;
		     if mod (fixed (addr (psr.variable_p) -> its.bit_offset, 6), 9) = 0
		     then char_buffer = "1"b; else
not_byteish:	     char_buffer = "0"b;
		end;
	end;

/* buffer is described as follows:
   char_buffer="1"b		length in bytes given by _v_l_e_n_g_t_h
   char_buffer="0"b		length in bits  given by _p_s_r.__v_a_r_i_a_b_l_e___b_i_t_l_e_n  */

/*  	DISPATCH ....................DISPATCH */

	if job_18 & "0001001"b then go to WL;		/* write and locate */
	if job_18 & "000011"b then go to RD;		/* rewrite and delete */

/*  READ  */

free_inbuf:
	if fsbr.inbuf_sw.exists then
	     do;
	     ballocn = fsbr.inbuf_maxlen;
	     free fsbr.inbuf_ptr -> balloc;
	     fsbr.switch.buffer_in_use,
		fsbr.inbuf_sw.exists = "0"b;
	end;

	if work_overlay.close
	then go to EXIT;

	if work.key then
	     do;
	     if release>0 then onkeyx = psr.keytemp;
	     else onkeyx = addr (psr.keytemp) -> bc32;
						/* we can handle old as well as new KEYs */
	     call iox_$seek_key (iocb_p, onkeyx, rlength, iocb_status);
	     if iocb_status ^= 0 then goto read_error;
	     fsbr.key_saved = onkeyx;
	end;

	if work.ignore then
	     do;
	     if psr.number<1 then goto EXIT;
	     call iox_$position (iocb_p, 0, psr.number, iocb_status);
	     if iocb_status ^= 0 then goto read_error;
	     fsbr.rec_valid = "1"b;
	     goto EXIT;
	end;

	if ^work.key & work.keyto then
	     do;
	     call iox_$read_key (iocb_p, fsbr.key_saved, rlength, iocb_status);
	     if iocb_status ^= 0 then goto read_error;
	end;
	fsbr.rec_valid = "1"b;

	if work.keyto then
	     do;
	     if release>0 then psr.keytemp = fsbr.key_saved;
	     else addr (psr.keytemp) -> bc32 = fsbr.key_saved;
	     keyto_keyset = "1"b;
	end;


	if work.set then
	     do;
	     statep = addr (fsbr.inbuf_curlen);
	     if ^work.key & ^work.keyto		/* if either of these, rlength has been already set	*/
	     then do;
		call iox_$read_length (iocb_p, rlength, iocb_status);
		if iocb_status ^= 0 then goto read_error;
	     end;

	     vlength = rlength;			/* keyed or not, rlength is the length of the record in the file */
	     call obtain_buffer;
	     copyp = buffer_state.bptr;

	     if work.packedptr then psr.set_p_p -> based_packedptr = buffer_state.bptr;
	     else psr.set_p_p -> based_pointer = buffer_state.bptr;
	     char_buffer = "1"b;
	end;

	else /* INTO  */ if char_buffer then copyp = psr.variable_p; /* vlength having been set  above  */


	if char_buffer
	then do;
	     call iox_$read_record (iocb_p, copyp, vlength, xrlength, iocb_status);
	     if iocb_status ^= 0 then goto read_error;

	     if valid_stringvalue
	     then if work.bit_string
		then addrel (copyp, -1) -> string_len = xrlength*9;
		else addrel (copyp, -1) -> string_len = xrlength;
	     else if vlength ^= xrlength then goto short_record;
	end;

	else					/* BEGIN BLOCK to allocate a temporary bit-buffer */
	begin;					/* this is a READ INTO with a target which
						   is either not byte-aligned or not an even
						   number of bytes long.  */
dcl  tempbuffer char (vlength) aligned;			/* vlength has been corrected, above */
dcl  bitbuffer bit (nnn) unaligned based;
dcl  nnn fixed bin (17);

	     call iox_$read_record (iocb_p, addr (tempbuffer), vlength, xrlength, iocb_status);
	     if iocb_status ^= 0 then if iocb_status ^= error_table_$long_record then goto read_error;
	     nnn = 9*min (vlength, xrlength);
	     psr.variable_p -> bitbuffer = addr (tempbuffer) -> bitbuffer;
	     if iocb_status = error_table_$long_record then goto long_record;
	     if vlength ^= xrlength then goto short_record;
						/* ASSUMPTION: that record length equals variable length
						   if variable_bitlen+8/9 = record_length  */
	end;

	return;

read_error:
	if iocb_status = error_table_$end_of_info then
	     do;
	     erno = 258;
						/* unable to read beyond EOF in sequential file */
	     goto sig_eof;
	end;

	if iocb_status = error_table_$no_record then
	     do;
	     erno = 292;
						/* unable to perform keyed lookup - key not found */
	     goto sig_key;
	end;

	if iocb_status = error_table_$long_record then
	     do;
long_record:
	     erno = 253;
						/* record in data set  larger than variable */
	     goto sig_rec;
	end;

/* mysterious case:     */
	erno = 293;
						/* unable to perform sequential access */
	goto sandr;

short_record:
	erno = 254;
						/* record in data set smaller than variable */
	iocb_status = error_table_$short_record;	/* this is so fsb.lnzc gets set, so dpe  gets good info */

	goto sig_rec;

/* 	WRITE and LOCATE                */

WL:	if fsbr.outbuf_sw.use then
	     do;
	     w_char_buffer = "1"b;
	     wptr = fsbr.outbuf_ptr;
	     wlen = fsbr.outbuf_curlen;

	     call write_x;

	     ballocn = fsbr.outbuf_maxlen;
	     free fsbr.outbuf_ptr -> balloc;
	     fsbr.outbuf_sw.exists,
		fsbr.outbuf_sw.use = "0"b;
	end;

	if work_overlay.close
	then go to free_inbuf;

	if work.locate then
	     do;
	     fsbr.outbuf_sw.use = "1"b;
	     if fsbr.switch.keyed
	     then do;
		if release>0 then fsbr.outbuf_key = psr.keytemp;
		else fsbr.outbuf_key = addr (psr.keytemp) -> bc32;
	     end;
	     statep = addr (fsbr.outbuf_curlen);
	     call obtain_buffer;
	     if work.packedptr then psr.set_p_p -> based_packedptr = buffer_state.bptr;
	     else psr.set_p_p -> based_pointer = buffer_state.bptr;
	end;
	else do;
	     fsbr.outbuf_sw.use = "0"b;
	     w_char_buffer = char_buffer;
	     wptr = psr.variable_p;
	     if valid_stringvalue
	     then if work.bit_string
		then wlen = divide (addrel (psr.variable_p, -1) -> string_len+8, 9, 21, 0);
		else wlen = addrel (psr.variable_p, -1) -> string_len;
	     else wlen = vlength;

	     call write_x;

	end;
	return;

write_error:
	if iocb_status = error_table_$key_order then
	     do;
	     erno = 282;
						/* unable to add record to keyed sequential output
						   file : keys must be distinct and ascending */
	     goto sig_key;
	end;

	if iocb_status = 0 then
	     do;
	     erno = 296;
						/* unable to create keyed record because the
						   specified key has already been used. */
	     goto sig_key;
	end;

	else do;
	     erno = 284;
						/* unable to create new record for write,
						   locate, or close statement.  */
	     goto sandr;
	end;					/* mysterious */

/*  		rewrite,delete . . . . . . . . . . . . . . . . .   */

RD:
	if work.key then
	     do;
	     onkeyx = psr.keytemp;
	     call iox_$seek_key (iocb_p, onkeyx, rlength, iocb_status);
	     if iocb_status ^= 0 then goto rewrite_error;
	     fsbr.recio.rec_valid = "1"b;
	end;
	else if fsbr.switch.keyed then onkeyx = fsbr.key_saved;

	if fsbr.recio.rec_valid = "0"b
	then do;
	     erno = 256;
	     go to sandr;
	end;
						/* record to be rewritten or deleted has already
						   been deleted.  */
	if work.delete then
	     do;
	     call iox_$delete_record (iocb_p, iocb_status);
	     if iocb_status ^= 0 then goto rewrite_error;
						/* unable to delete designated record. */
	     fsbr.recio.rec_valid = "0"b;		/* cannot be deleted, rewritten  */
	     go to EXIT;
	end;

	if work.from then wptr = psr.variable_p;
	else do;
	     if fsbr.inbuf_sw.use = "0"b then
		do; erno = 255; go to sandr; end;
						/* There is no FROM OPTION or input buffer */
	     vlength = fsbr.inbuf_curlen;
	     wptr = fsbr.inbuf_ptr;
	     char_buffer = "1"b;
	end;

	if valid_stringvalue
	then if work.bit_string
	     then vlength = divide (addrel (psr.variable_p, -1) -> string_len+8, 9, 21, 0);
	     else vlength = addrel (psr.variable_p, -1) -> string_len;

	if char_buffer then call iox_$rewrite_record (iocb_p, wptr, vlength, iocb_status);
	else begin;

dcl  tempbuffer_r char (vlength) aligned;
dcl  bitbuffer_r bit (9*vlength) unaligned based;

	     addr (tempbuffer_r) -> bitbuffer_r = wptr -> bitbuffer_r;
	     call iox_$rewrite_record (iocb_p, addr (tempbuffer_r), vlength, iocb_status);
	end;

	if iocb_status ^= 0 then
	     do;
rewrite_error: if iocb_status = error_table_$long_record then
		do;
		erno = 280;
		goto sig_rec;
	     end;
	     if iocb_status = error_table_$short_record then
		do;
		erno = 280;
		goto sig_rec;
	     end;
	     if iocb_status = error_table_$no_record then
		do;
		erno = 292;
		goto sig_key;
	     end;
						/* unable to rewrite record. */
	     if psr.job.delete
	     then erno = 285;
	     else erno = 281;
	     goto sandr;
	end;
	return;

recio_close_: entry (pspp);
	psp = pspp;
	fsbp = psr.source_p -> file_value.fsb_ptr;
	iocb_p = fsbr.iocb_p;
	string (work) = "00000000000000000000000000000001"b; /* close */

	go to WL;

error:	entry (pspp, error_status);
	psp = pspp;
	string (work) = string (psr.job);
	psr.file_p = psr.source_p;
	plio2_data_$fsbpstat,
	     fsbp, psr.fsbp = psr.file_p -> file_value.fsb_ptr;
	if fsbr.switch.keyed
	then onkeyx = psr.keytemp;
	else onkeyx = "";
	iocb_status = error_status;
	if psp -> psr.job.read
	then if iocb_status>0
	     then goto read_error;
	     else goto short_record;
	if psp -> psr.job.write then goto write_error;
	goto rewrite_error;

/* INTERNAL PROCEDURES */

fill_stream_input_buffer:
	procedure (bv_ignore_eof);

/* parameters */

declare bv_ignore_eof bit (1) aligned parameter;

/* automatic */

declare  buffer_ptr ptr,
         max_read_len fixed bin (21),
         read_len fixed bin (21);

/* based */

declare  buffer_array_overlay char (1) dim (fsb.bsize) based (fsb.bptr);

/* program */

	     buffer_ptr = addr (buffer_array_overlay);
	     max_read_len = fsb.bsize;

	     fsb.bnc = 1;	/* redundant stmt protects us somewhat from quit-start */

	     if fsb.console
	     then call iox_$get_line (iocb_p, buffer_ptr, max_read_len, read_len, iocb_status);
	     else call iox_$get_chars (iocb_p, buffer_ptr, max_read_len, read_len, iocb_status);

	     fsb.bnc = 1;

	     if iocb_status ^= 0
	     then if iocb_status = error_table_$short_record | iocb_status = error_table_$long_record
		then iocb_status = 0;
		else if iocb_status = error_table_$end_of_info
		then do;
		     if bv_ignore_eof
		     then do;
			iocb_status = 0;
			return;
		     end;
		     erno = 291;			/* EOF during read to stream file */
		     go to sig_eof;
		end;
		else do;
		     erno = 295;			/* transmit */
		     go to sandr;
		end;

	     fsb.blc = fsb.blc + read_len;

	end fill_stream_input_buffer;

obtain_buffer:
	procedure ();

	     if ^bsw.exists | vlength > bmax
	     then do;
		if bsw.exists
		then do;
		     ballocn = bmax;
		     free buffer_state.bptr -> balloc;
		end;
		ballocn = vlength;
		allocate balloc set (buffer_state.bptr);
		bmax = ballocn;
		bsw.exists = "1"b;
	     end;

	     blen, copyn = vlength;
	     fsbr.switch.buffer_in_use,
		bsw.use = "1"b;

	end obtain_buffer;

write_x:	proc;
	     if fsbr.switch.keyed then
		do;
		if fsbr.outbuf_sw.use then onkeyx = fsbr.outbuf_key;
		else do;
		     if release>0 then onkeyx = psr.keytemp;
		     else onkeyx = addr (psr.keytemp) -> bc32;
		end;
		call iox_$seek_key (iocb_p, onkeyx, xrlength, iocb_status);
		if iocb_status ^= error_table_$no_record then goto write_error;
	     end;

	     if w_char_buffer
	     then call iox_$write_record (iocb_p, wptr, wlen, iocb_status);
	     else begin;

dcl  tempbuffer_w char (wlen) aligned;
dcl  bitbuffer_w bit (9*vlength) unaligned based;

		addr (tempbuffer_w) -> bitbuffer_w = psr.variable_p -> bitbuffer_w;
		call iox_$write_record (iocb_p, addr (tempbuffer_w), wlen, iocb_status);
	     end;
	     if iocb_status ^= 0 then goto write_error;
	     fsbr.switch.buffer_in_use = "0"b;
	     if fsbr.switch.keyed then fsbr.key_saved = onkeyx;
	     fsbr.recio.rec_valid = "1"b;
	end write_x;

     end						/* plio2_recio_ */;




		    plio2_resig_.pl1                10/03/83  1722.3rew 10/03/83  1005.5       14490



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

plio2_resig_:proc(pspp) options(support);

	dcl pspp ptr;
	dcl psp ptr;
	dcl fsbp ptr;
	dcl file_p ptr;
	dcl name33 char(33) aligned;
	dcl (index,null,substr) builtin;
	dcl addr builtin;
	dcl q ptr;


	dcl find_condition_info_ entry(ptr,ptr,fixed bin(35));
	dcl continue_to_signal_ entry(fixed bin(35));


	dcl code fixed bin(35);


dcl 1 condition_structure_ aligned like condition_info;

%include condition_info;

%include on_data_;

%include pl1_info;
%include condition_info_header;

%include plio2_fsb;
%include plio2_ps;



			/* called by the following programs.

					LDI
					LDO
					GVE
					PVE

							P.Belmont  74.01.07     */
	psp=pspp;
	if ps.job.string then goto resig;

	file_p=ps.file_p;
	fsbp=ps.fsbp;
	name33=fsb.filename;

	q=addr(condition_structure_);
	call find_condition_info_(null,q,code);
	if code^=0 then goto resig;

	q=condition_structure_.info_ptr;

	q->pl1_info.onfile=name33;
	q->pl1_info.onfile_sw="1"b;
	q->pl1_info.file_ptr=file_p;
	q->pl1_info.file_ptr_sw="1"b;

	ondata_$fileptr=file_p;
	ondata_$onfile=substr(name33,1,index(name33," ")-1);

resig:

	call continue_to_signal_(code);

end plio2_resig_;




		    plio2_signal_.pl1               09/21/89  1350.2rew 09/21/89  1348.0       48744



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


/****^  HISTORY COMMENTS:
  1) change(89-03-24,Huen), approve(89-03-24,MCR8102), 
     audit(89-09-15,Vu), install(89-21-09,MR12.3-1071):	
     Modify r_ to branch to the correct label "work_1" instead of the label
     "work" so that the parameter "condition_name" which is undefined will not
     be referenced.  (pl1_2197)
                                                   END HISTORY COMMENTS */

/* updated 5-13-72 by PAB to shift burden to HELP_PLIO2_SIGNAL_  */


plio2_signal_: proc options(support);


/* 	plio2_signal_$
   s_			signals
   s_l_			signals with datafield
   s_r_			signals and does abnormal return
   s_r_l_			signals with datafield and does abnormal return
   r_                         does abnormal return
   conversion_error_	signals conversion condition, repairs string */

/* 	DECLARATION */

dcl c fixed bin (15);              /* conversion */
dcl l fixed bin (15);              /* data field */
dcl r fixed bin (15);              /* abnormal return */
dcl s fixed bin (15);              /* signal */
dcl (erno, n1,n2,n3,oncharind) fixed bin(15);
dcl (addr, null, string, substr) builtin;
dcl CN char(20) aligned;
dcl (psp,pspp,fsbp,chp,file_ptr,p2(2) based) ptr;
dcl based_chars char (1044480) based;
dcl based_label label based;
dcl onsource char(256) varying;
dcl (condition_name,msg,datafield) char(*);
dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));
dcl plio2_put_util_$put_publish_ ext entry (ptr);
dcl put_copy_ ext entry(ptr,fixed bin(15));
dcl pl1_signal_$help_plio2_signal_ ext entry(char(*),ptr,fixed bin(15),char(256) varying,fixed bin(15));

% include plio2_fsb;
% include plio2_ps;
% include plio2_psr;
						/* 	ENTRIES	 */

s_:	entry(pspp,condition_name,msg,erno);
	s = 1;
	c,l,r = 0;
	go to work;

r_:	entry(pspp);
	r = 1;
	c,l,s = 0;
	CN="";                                    /* bug 2197 */
	go to work_1;

s_r_:	entry(pspp,condition_name,msg,erno);
	r,s = 1;
	c,l = 0;
	go to work;

s_r_l_:	entry(pspp,condition_name,msg,erno,datafield);
	s,r,l = 1;
	c = 0;
	go to work;

s_l_:	entry(pspp,condition_name,msg,erno,datafield);
	s,l = 1;
	c,r = 0;
	go to work;

conversion_error_: entry(pspp,msg,erno,chp,n1,n2,n3);
	c,s = 1;
	l,r = 0;
	CN="CONVERSION";
	go to work_1;

work:

	CN=condition_name;
work_1:
	psp = pspp;
	if CN = "UNDEFINEDFILE"
	then plio2_data_$undef_file_sw = "1"b;
	else plio2_data_$undef_file_sw = "0"b;

	if psp^=null 
	then do;
		fsbp=ps.fsbp;
		plio2_data_$badfsbp = ps.fsbp;
		plio2_data_$badjob = string(psr.job);	/* MUST use psr.job, not ps.job, to get all 36 bits! */
		end;
	else goto work_2;

	if CN = "UNDEFINEDFILE" then goto work_2;	/* ps.job is garbage if error was in plio2_open_ ! */


	/* Here there may be materials which need to be "put":
	   either the present contents of the output buffer for PUT
	   or the current content of the COPY-STACK for GET/COPY  */

	if ps.job.copy then
		do;
		call put_copy_(psp,fsb.bnc-1);
		ps.start_copy=fsb.bnc;
		end;

	if ps.job.put then if ^ps.job.string then call plio2_put_util_$put_publish_(psp);

work_2:
	if s^=1 then go to return_test;
	oncharind=0;
	onsource="";


	if psp^=null then file_ptr=ps.file_p;
	else file_ptr=null;
	if file_ptr^=null then
		do;
		fsbp=file_ptr->p2(2);
		if CN = "ENDFILE"
		|  CN = "TRANSMIT"
		|  CN = "UNDEFINEDFILE"
		|  CN = "KEY"
		|  CN = "RECORD"
		then;
		else fsb.lnzc = 0;

		if fsb.switch.record & fsb.switch.keyed then
			do;
			onsource=msg;
			oncharind=-1;
			end;
		/* SEVERAL conditions will be accompanied with KEY */
		end;


	if CN = "CONVERSION"	then CN = "conversion";
  else	if CN = "SIZE"		then CN = "size";
  else	if CN = "ENDFILE"		then CN = "endfile";
  else	if CN = "ENDPAGE"		then CN = "endpage";
  else	if CN = "TRANSMIT"		then CN = "transmit";
  else	if CN = "UNDEFINEDFILE"	then CN = "undefinedfile";
  else	if CN = "NAME"		then CN = "name";
  else	if CN = "KEY"		then CN = "key";
  else	if CN = "RECORD"		then CN = "record";
  else	if CN = "ERROR"		then CN = "error";
  else	if CN = "OVERFLOW"		then CN = "overflow";
  else	if CN = "UNDERFLOW"		then CN = "underflow";
  else	if CN="MATH_ERROR"		then CN = "error";
  else	if CN="FIXEDOVERFLOW"	then CN = "fixedoverflow";
  else	if CN="ZERODIVIDE"		then CN = "zerodivide";
  else	if CN="STRINGRANGE"		then CN = "stringrange";
  else	if CN="STRINGSIZE"		then CN = "stringsize";
  else	if CN="SUBSCRIPTRANGE"	then CN = "subscriptrange";


	if c = 1 then
	do;
	     if n1>n2|n3<n1|n3>n2 then
		call plio2_signal_$s_r_(psp,"ERROR","CE",116);
	     onsource = substr(chp->based_chars,n1,n2+1-n1);
	     oncharind=n3-n1+1;
	end;

	if l = 1 then onsource = datafield;
	call pl1_signal_$help_plio2_signal_((CN),pspp,erno,onsource,oncharind);
	if c = 1 then substr(chp->based_chars,n1,n2+1-n1) = onsource;

return_test: 
	if r = 1 then go to addr(ps.ab_return)->based_label;     /* ABNORMAL RETURN */
	return;

end plio2_signal_;




		    plio2_sym_to_desc.pl1           10/03/83  1722.3rew 10/03/83  1005.6       29997



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

plio2_sym_to_desc:proc(sp,l1p,psp,new_sfp) returns(bit(36) aligned) options(support);

/*	Modified:	4 April 1978 by RAB to partially fix 1720 */
/*	Modified: 1 May 1978 by PCK to implement unsigned binary */

dcl	based_bit36 bit (36) aligned based;
	dcl (sp,l1p,psp,new_sfp) ptr;
	dcl (sfp,tp,tbp,sym_p,ref_p) ptr;
	dcl (bit,fixed,null,addrel,substr,addr) builtin;
	dcl ( i,icode ) fixed bin(15);
	dcl d bit(36) aligned;
	dcl old_type fixed bin(12);
	dcl size fixed bin(35);
	dcl old_symbol based bit(12) aligned;
dcl	data_type fixed bin (6);

	dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15));
	dcl stu_$decode_runtime_value ext entry(fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin(15)) returns(fixed bin(35));
dcl	stu_$get_implicit_qualifier entry(ptr,ptr,ptr,ptr,ptr) returns(ptr);

%include stu_frame;
/*  */
%include runtime_symbol;
%include symbol_node;
%include plio2_ps;
%include desc_types;
/*  */

start:
	sym_p=sp;
	size=sym_p->runtime_symbol.size;
	if size < 0 then
		do;
		sfp=new_sfp;
		if sfp=null then
			do;
			sfp=ps.stack_frame_p;
			tp=addrel(l1p,l1p->runtime_symbol.father);
			tbp=ps.ST_block_p;

loop:
			if tbp ^= tp then
				do;
				if ^tbp->runtime_block.quick then sfp=sfp->frame.display;
				tbp=addrel(tbp,tbp->runtime_symbol.father);
				goto loop;
				end;

			end;	/* sfp is symbol's stack_frame_ptr */

		if sym_p -> runtime_symbol.class = "0011"b	/* NOTE: if stu_ interface changes, this must change */
		     then ref_p = stu_$get_implicit_qualifier(tbp,sym_p,sfp,null,null);
		     else ref_p = null;

		size=stu_$decode_runtime_value(size,tbp,sfp,null,null,ref_p,icode);
			/* NB: uses  ST_block (tbp) and Stack_Frame (sfp) of
			   proper block, not necessarily of current block. */
		if icode^=0 then call plio2_signal_$s_r_(psp,"ERROR","s_to_d",239);
		end;

test:
	d="0"b;
	if sym_p->runtime_symbol.flag then goto new_desc;
	old_type=fixed(sym_p->old_symbol,12);
		if old_type>524 then old_type=old_type-6;
		if old_type<519
		&  old_type>16 then old_type=old_type-16;

		substr(d,4,12)=bit(old_type,12);


	if substr(d,1,6) then go to make_string_desc;
	substr(d,19,1)=sym_p->symbol_node.bits.decimal;
	substr(d,20,8)=sym_p->symbol_node.scale;
	substr(d,28,9)=bit(fixed(size,9));
	goto exit;
make_string_desc:
	substr(d,19,18)=bit(fixed(size,18));
	goto exit;
/*  */

new_desc:
	substr(d,1,1)="1"b;
	substr(d,2,6)=sym_p->runtime_symbol.type;	/* no bits need be removed for arrays */
	substr(d,8,1)=sym_p->runtime_symbol.bits.packed;

	data_type = fixed (sym_p -> runtime_symbol.type, 6);

	if data_type >= bit_desc & data_type <= v_char_desc
	then substr(d,13,24)=bit(fixed(size,24));
	else do;
		substr(d,17,8)=sym_p->runtime_symbol.scale;
		if substr(d,17,1) then substr(d,13,4)="1111"b;	/* negative scale */
		substr(d,25,12)=bit(fixed(size,12));
	     end;

exit:
	return(d);

end plio2_sym_to_desc;




		    put_copy_.pl1                   10/03/83  1722.3rew 10/03/83  1005.6       17766



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

put_copy_:proc(pspp,nn) options(support);


	dcl pspp ptr;
	dcl nn fixed bin(21);

	dcl ( psp , cp , cpfp ) ptr;
	dcl ( n1 , n2 , i  ) fixed bin(15);
	dcl (addr,null,substr) builtin;
	dcl copy_file file based;
	dcl ( pspstatsaved,fsbpstatsaved ) ptr;
	dcl NL char(1) aligned static internal init("
");



% include plio2_fsb;
% include plio2_ps;


	psp=pspp;
	n1=psp->ps.start_copy;
	n2=nn;
	cp=psp->ps.fsbp->fsb.bptr;

	if psp->ps.copy_file_p=null then cpfp=addr_sysprint();
	else cpfp=psp->ps.copy_file_p;
/*
		dcl ioa_ entry ext implementation(variable);
	call ioa_("cpfp=^p,cp=^p,n1=^d,n2=^d,stuff=^a",cpfp,cp,n1,n2,substr(cp->xbuf,n1,n2+1-n1));
	call ioa_("filename(get)=^a",psp->ps.fsbp->fsb.filename);
	call ioa_("filename(copy)=^a",psp->ps.copy_file_p->p_vector(2)->fsb.filename);
*/

	pspstatsaved=plio2_data_$pspstat;
	fsbpstatsaved=plio2_data_$fsbpstat;

		/* TO OPEN THE COPY FILE PRIOR TO FIRST GET . . . */
	if n2=-1 then
		do;
		put file(cpfp->copy_file) edit("")(a);
		goto exit;
		end;


copy_loop:
	if n1 > n2 then
		do;
exit:
		plio2_data_$pspstat=pspstatsaved;
		plio2_data_$fsbpstat=fsbpstatsaved;
		return;
		end;

	do i=n1 to n2;
	if substr(cp->xbuf,i,1)=NL then goto copy;
	end;

	i=n2+1;
copy:
	if n1<i then put file(cpfp->copy_file) edit(substr(cp->xbuf,n1,i-n1)) (a);
	n1=i+1;

	if i<=n2  then put file(cpfp->copy_file) skip;

	goto copy_loop;

addr_sysprint:proc returns(ptr);
dcl sysprint file output print stream;
return(addr(sysprint));
end addr_sysprint;

end put_copy_;




		    put_data_block_all_.pl1         10/03/83  1722.3rew 10/03/83  1005.6       19107



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

/* written 05.30.73 by A. Downing as part of the pl1 runtime suport */
put_data_block_all_: proc (psp) options(support);
dcl (duplication, n) fixed bin;
dcl (block_ptr,					/* points at current block */
     save_sp,					/* save the stack pointer */
     save_bp,					/* save the block ptr */
     sslpsaved,
     psp) ptr,					/* points at ps */
     more bit(1) aligned,
     ptrsave bit(72) aligned based,
     put_data_var_all_ ext entry (fixed bin, fixed bin, ptr, ptr, ptr),
     1 bounds (128) aligned int static,
     2 lower fixed bin,
     2 upper fixed bin,
    (addrel,addr, rel, null) builtin;

%include stu_frame;
%include runtime_symbol;
%include plio2_ps;











	block_ptr = ps.ST_block_p;

  	addr(sslpsaved)->ptrsave=addr(ps.ss_list_p)->ptrsave;
	addr(save_bp  )->ptrsave=addr( block_ptr  )->ptrsave;
	addr(save_sp  )->ptrsave=addr( ps.stack_frame_p  )->ptrsave;

	duplication = 0;
	more="1"b;

	do while(more);
	     n = 0;
	     call put_data_var_all_ (duplication, n, addrel (block_ptr, block_ptr -> runtime_block.start), addr (bounds), psp);
	     block_ptr = addrel (block_ptr, block_ptr -> runtime_block.father);

	     if block_ptr -> runtime_block.father = block_ptr -> runtime_block.header
	     then more="0"b;
	     else
		do;
		     if ^ block_ptr -> runtime_block.quick then
		     psp -> ps.stack_frame_p = ps.stack_frame_p -> frame.display;
		     psp -> ps.ST_block_p = block_ptr;
		end;
	end;

	addr(ps.ST_block_p   )->ptrsave=addr( save_bp  )->ptrsave;
	addr(ps.stack_frame_p)->ptrsave=addr( save_sp  )->ptrsave;
	addr(ps.ss_list_p    )->ptrsave=addr(sslpsaved )->ptrsave;

	return;

     end put_data_block_all_;




		    put_data_var_all_.pl1           10/03/83  1722.3rew 10/03/83  1005.6       66663



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

/* written 05.30.73 by A. Downing to suport put data; */
/* modified 04.04.78 by R. Barnes to more properly decide when to call stu_$get_implicit_qualifier */
/*	Modified: 05/01/78 by PCK to implement unsigned binary	*/
put_data_var_all_: proc (duplication, n, vp, bounds_p, psp) options(support);
dcl (link_p, text_p, ref_p) ptr init (null ());
dcl 1 bounds (128) based (bounds_p),
    2 lower fixed bin,
    2 upper fixed bin;
dcl  ss_list (0:128) int static fixed bin (26);
dcl  ssl (128) fixed bin (26) based (sslp),
     sslp ptr;

   dcl 1 val_struct based,
	2 flag bit(2) unal,
	2 type bit(4) unal,
	2 rest bit(30) unal;

dcl  duplication fixed bin,				/* number of duplicate variable declarations encountered */
    (vp, bounds_p, var_ptr) ptr,
   p ptr,
     search_ptr ptr,				/* used in searching through duplication chains */
     psp ptr,					/* points at the sp */
     duplication_list (1000) bit (18) int static,		/* holds the offset of the duplicated variable actually (put) */
     more bit (1),
    (item_type,i, j, k, l, n, father_n, own_dims) fixed bin (26),
     com_err_ ext entry options (variable),
     plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15)),
     stu_$decode_runtime_value ext entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin (26)) returns (fixed bin),
     stu_$get_implicit_qualifier ext entry (ptr,ptr,ptr,ptr,ptr) returns(ptr),
     stu_$get_runtime_address ext entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
     plio2_pdt_ ext entry (ptr),
    (addrel,addr, fixed, convert, null,rel,bit) builtin;

%include runtime_symbol;
%include plio2_ps;

	var_ptr = vp;
	ps.ss_list_p = addr (ss_list);
	sslp = addr (ss_list (n+1));
	father_n = n;
top:	
	n = fixed (var_ptr -> runtime_symbol.ndims, 6);
	ss_list (0) = n;
	own_dims = n - father_n;
	search_ptr = addrel (var_ptr, var_ptr -> runtime_symbol.name);
	search_ptr = addrel (search_ptr, -1);
	search_ptr = addrel (search_ptr, search_ptr -> runtime_token.dcl);
	if search_ptr -> runtime_symbol.address.next ^= (14)"0"b then do;
	     if fixed (var_ptr -> runtime_symbol.level, 6) < 2 then do;
		do i = 1 to duplication;
		     if rel (search_ptr) = duplication_list (i) then go to found;
		end;				/* end of i loop */
		duplication = duplication + 1;
		duplication_list (duplication) =
		rel (search_ptr);
	     end;					/* end of looking at and adding to duplication_list */
	end;					/* end of do group */
	do l = father_n + 1 to n;
	     if var_ptr -> runtime_symbol.bounds (l).lower >= 0 then
	     bounds_p -> bounds (l).lower = var_ptr -> runtime_symbol.bounds (l).lower;
	     else do;

		if ref_p = null & var_ptr -> runtime_symbol.class = "0011"b
		then ref_p = stu_$get_implicit_qualifier(ps.ST_block_p,var_ptr,ps.stack_frame_p,
						  link_p,text_p);
		else;

		bounds_p -> bounds (l).lower =
		stu_$decode_runtime_value (var_ptr -> runtime_symbol.bounds (l).lower, ps.ST_block_p, ps.stack_frame_p, null,
		null, ref_p, i);
		if i ^= 0 then go to bounds_error;
	     end;
	     if var_ptr -> runtime_symbol.bounds (l).upper >= 0 then
	     bounds_p -> bounds (l).upper = var_ptr -> runtime_symbol.bounds (l).upper;
	     else do;

		if ref_p = null & var_ptr -> runtime_symbol.class = "0011"b
		then ref_p = stu_$get_implicit_qualifier(ps.ST_block_p,var_ptr,ps.stack_frame_p,
						  link_p,text_p);
		else;

		bounds_p -> bounds (l).upper = stu_$decode_runtime_value
		(var_ptr -> runtime_symbol.bounds (l).upper,ps.ST_block_p,ps.stack_frame_p,null,null,ref_p,i);
		if i ^= 0 then go to bounds_error;
	     end;
	end;					/* end of filling in lower and upper bounds */
	if var_ptr -> runtime_symbol.son ^= (18)"0"b then do;
	     if n = father_n then
	     call put_data_var_all_ (duplication, n, addrel (var_ptr, var_ptr -> runtime_symbol.son), bounds_p, psp);
	     else do;				/* we have arrayness at this level */
		do l = father_n + 1 to n -1;
		     ss_list (l) = bounds_p -> bounds (l).lower;
		end;
		more = "1"b;
		do while (more);
		     do i = bounds_p -> bounds (n).lower to
			bounds_p -> bounds (n).upper;
			ss_list (n) = i;
			call put_data_var_all_ (duplication, n, addrel (var_ptr, var_ptr -> runtime_symbol.son), bounds_p, psp);
		     end;				/* end of do i */
		     j = n -1;
		     do while (j > father_n & ss_list (j)+1 > bounds_p ->
			bounds (j).upper);
			j = j - 1;
		     end;
		     if j > father_n then do;
			ss_list (j) = ss_list (j) + 1;
			do i = j + 1 to n - 1;
			     ss_list (i) = bounds_p -> bounds (i).lower;
			end;			/* end of i loop */
		     end;
		     else more = "0"b;
		end;				/* end of outer while */
	     end;					/* end of having subscripts at this level */
	end;					/* end of having a son pointer */
	else do;					/* we are at the end of a branch */
		item_type=fixed(var_ptr->runtime_symbol.type,6);

		if (item_type>23 & item_type<33) | (item_type>46 & item_type<63)
		then go to found;	/* skip this item */

	     k = fixed (rel (var_ptr), 18) - fixed (rel (ps.ST_top_p), 18);
	     ps.offset = bit (fixed (k, 18), 18);
	     if own_dims = 0 then call put;
	     else do;				/* its an array */
		do i = 1 to own_dims;
		     ssl (i) = bounds_p -> bounds (i + father_n).lower;
		end;
		more = "1"b;
		do while (more);
		     do i = bounds_p -> bounds (n).lower to
			bounds_p -> bounds (n).upper;
			ssl (own_dims) = i;
			call put;
		     end;				/* end of i loop */
		     j = own_dims -1;
		     do while (j > 0 &ssl (j) +1 > bounds_p -> bounds (j + father_n).upper);
			j = j -1;
		     end;				/* end of do while */
		     if j > 0 then do;
			ssl (j) = ssl (j) + 1;
			do k = j+1 to own_dims - 1;
			     ssl (k) = bounds_p -> bounds (k + father_n).lower;
			end;
		     end;				/* end of do group */
		     else more = "0"b;
		end;				/* end of outer do while */
	     end;					/* end of its an array */
	end;					/* end of handling a terminal element */
found:	
	n = father_n;				/* reset n */
	ss_list (0) = n;
	if var_ptr -> runtime_symbol.brother ^= (18)"0"b then
	do;
	     var_ptr = addrel (var_ptr, var_ptr -> runtime_symbol.brother);
	     go to top;
	end;
	return;

/* 



*/
put:	proc;
	     ps.value_p = stu_$get_runtime_address
	     (ps.ST_block_p, var_ptr, ps.stack_frame_p, link_p, text_p, ref_p, addr (ss_list (1)));
	     if ps.value_p = null () then do;
		call com_err_
		(0, "put_data_var_all_", "Can not get runtime address for symbol table offset ^o", fixed (ps.offset, 18));
		go to found;
	     end;

		if item_type^=20 
		     then if item_type^=22
			then goto non_varying;
		ps.value_p=addrel(ps.value_p,1);

		/* plio2_pdt_ needs the address of varying strings as for parameter passing */

non_varying:
	     call plio2_pdt_ (psp);

	     return;
	end put;

bounds_error:
	call com_err_
	(i, "put_data_var_all_", "Cannot decode runtime bounds for symbol table offset ^d", fixed (ps.offset, 18));
	call plio2_signal_$s_r_ (psp, "ERROR", "put_data_var_all_", 239);
	go to found;
     end put_data_var_all_;




		    display_file_value_.pl1         10/03/83  1722.3rew 10/03/83  1005.7       36279



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

display_file_value_: proc (P_switch, P_file, P_code);

/* formats information about the file, and outputs it on switch.
   Code is returned 0 for no errors, oterwise it is a standard system error code

   Designed 18 July 78 by James R. Davis
*/

dcl (P_switch ptr,					/* to switch for io */
     P_file file variable,				/* the file whose value we print */
     P_code fixed bin (35)				/* standard system error code */
     ) parameter;


dcl  fsbp ptr,					/* to file state block */
     fabp ptr,					/* to file attribute block */
     swp ptr,					/* to switch for io */
     ioa_$ioa_switch entry options (variable),
     chbuf char (fsb.bsize) based (fsb.bptr),
    (addr, substr, null) builtin;

dcl  iox_$user_output ptr external;			/* default switch */
dcl  TIC char (1) static options (constant) init ("!");	/* used in stream input */

	P_code = 0;
	fsbp = addr (P_file) -> file_value.fsb_ptr;
	fabp = addr (P_file) -> file_value.fab_ptr;
	swp = P_switch;
	if swp = null () then swp = iox_$user_output;

	call ioa_$ioa_switch (swp, "fab: ^p, fsb: ^p", fabp, fsbp);

	if ^ fsb.switch.open
	then if fab.switch.stream
	     then if fab.switch.input
		then call ioa_$ioa_switch (swp,
		     "closed ^[internal^;external^] stream input file: ^32a",
		     fab.switch.internal, fab.name);
		else if fab.switch.output
		then call ioa_$ioa_switch (swp,
		     "closed ^[internal^;external^] stream output file: ^32a ^[print page size: ^d line size: ^d^;^2s^]",
		     fab.switch.internal, fab.name, fab.switch.print, fab.page_size, fab.line_size);
		else call ioa_$ioa_switch (swp,
		     "closed ^[internal^;external^] stream file not input or output: ^32a",
		     fab.switch.internal, fab.name);
	     else if fab.switch.record
	     then call ioa_$ioa_switch (
		"closed ^[internal^;external^]  record ^[output ^;^] ^[input ^;^]^[update ^;^]^[keyed ^;^]^[sequential^;^]^[direct^;^]^[(stringvalue)^;^] file: ^32a",
		fab.switch.internal, fab.switch.output, fab.switch.input, fab.switch.update,
		fab.switch.keyed, fab.switch.sequential, fab.switch.direct,
		fab.switch.stringvalue, fab.name);
	     else call ioa_$ioa_switch (swp, "closed file not record or stream name: ^32a", fab.name);
	else do;					/* open file */
	     call ioa_$ioa_switch (swp, "^[internal^;external^] file name: ^32a ^/ path: ^168a^/iocb at ^p",
		fsb.switch.internal, fsb.filename, fsb.path_name, fsb.iocb_p);

	     if fsb.switch.stream
	     then if fsb.switch.input
		then do;
		     call ioa_$ioa_switch (swp, "stream input last char ^d", fsb.blc);
		     call ioa_$ioa_switch (swp, "^a^a^a",
			substr (chbuf, 1, fsb.bnc-1), TIC, substr (chbuf, bnc, blc -bnc + 1));
		end;				/* of input stream file */
		else if fsb.switch.output
		then call ioa_$ioa_switch (swp,
		     "stream output ^[print page size ^d line size ^d^/pageno ^d lineno ^d colno^d^;^5s^]",
		     fsb.switch.print,		/* if print then give print parms */
		     fsb.psize, fsb.lsize, fsb.pageno, fsb.lineno, fsb.kol);
		else call ioa_$ioa_switch (swp, "stream, but not input or output");
	     else if fsb.switch.record then call ioa_$ioa_switch (swp,
		"record ^[input^;^]^[output^;^]^[update^;^] ^[keyed^;^]^[sequential^;^]^[direct^;^] ^[(string value)^;^]",
		fsb.switch.input, fsb.switch.output, fsb.switch.update,
		fsb.switch.keyed, fsb.switch.sequential, fsb.switch.direct, fsb.switch.stringvalue);
	     else call ioa_$ioa_switch (swp, "not stream or record");
	end;					/* of open file */
						/*  */
%include  pl1_file_value;
%include plio2_fsb;
%include plio2_fab;
     end display_file_value_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
