



		    apl_zcode_to_ascii_.alm         08/12/81  2123.1r   08/08/81  1559.8       42210



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

"ALM subroutine to convert from 9 bit EBCDIC ZCODE to 9 bit Multics APL ASCII
"Input bytes must be valid EBCDIC characters in the range
"00 <_ hexadecimal_value <_ FF, or 000 <_ octal_value <_ 377.
"
"ARG 1: source string - data to be converted
"ARG 2: target string - converted data
"
"PL/I Usage:
"
"dcl  apl_zcode_to_ascii_ entry (char (*), char (*));
"     call apl_zcode_to_ascii_ (input_string, output_string);
"
"Note: the EBCDIC to ASCII mapping used is defined in the text
"      of this procedure.  It is available to the user program
"      through the following declaration.
"
"dcl  apl_zcode_to_ascii_$za_table char (256) external static;
"
"The table consists of 256 ASCII characters which correspond to
"the 256 EBCDIC characters.  As only 128 of the EBCDIC characters
"have ASCII mappings, the other 128 are mapped into the ASCII SUB
"character, octal 032.  (The EBCDIC SUB character is also mapped
"into octal 032.
"
"    0)  Created (as ebcdic_to_ascii_) by Ross E. Klinger, 02/14/74
"    1)  Modified (as ebcdic_to_ascii) by R.E. Klinger, 03/13/75
"    2)  Rewritten to be apl_zcode_to_ascii_ by Paul Green, 7/30/76
	name	apl_zcode_to_ascii_
	segdef	apl_zcode_to_ascii_
	segdef	za_table
apl_zcode_to_ascii_:
	epp1	ap|2,*		address of source string to pr1
	epp3	ap|4,*		address of target string to pr3
	ldx3	0,du		set x3 not to skip parent pointer if none
	lxl2	ap|0		load argument list code value
	canx2	=o000004,du	check for code 4 - no parent pointer
	tnz	*+2		transfer if no parent pointer
	ldx3	2,du		parent pointer - set x3 to skip it
	lda	ap|6,x3*		load source string descriptor
	ldq	ap|8,x3*		load target string descriptor
	ana	mask		drop all but string size bits
	anq	mask		ditto
	mvt	(pr,rl),(pr,rl),fill(230)	translate ebcdic to ascii
	desc9a	pr1|0,al		source string
	desc9a	pr3|0,ql		target string
	arg	za_table
	short_return		"exit

mask:	oct	000077777777
	even
"		ASCII OUTPUT	ASCII GRAPHIC	EBCDIC INPUT
za_table:	oct	000001002003	NUL SOH STX ETX	00-03
	oct	032011032072	- HT - FAKECOLON	04-07
	oct	056032032013	FAKEPERIOD - - VT 	08-0B
	oct	014015133135	FF CR [ ]		0C-0F
	oct	050051073057	( ) SEMICOLON /	10-13
	oct	134255256032	\ -< -> -		14-17
	oct	032245053055	- DIAR + -	18-1B
	oct	251205052212	x -: * c		1C-1F
	oct	213174204203	f | & v		20-23
	oct	074200075201	< <_ = >_		24-27
	oct	076202252206	> /= a e		28-2B
	oct	247250246054	i p w ,		2C-2F
	oct	041233220221	! o| _| t		30-33
	oct	211077176207	o ? ~ ^|		34-37
	oct	210222223217	v| (_ )_ n		38-3B
	oct	224137234242	u _ \o b		3C-3F
	oct	215216241232	_o q 'q *o		40-43
	oct	226225240237	&~ v~ .n d|		44-47
	oct	236227230243	g| -o -/ -\		48-4B
	oct	244275274046	m _f _e "046	4C-4F
	oct	100043044032	@ # $ -		50-53
	oct	777776141142	Td Sd A B		54-57
	oct	143144145146	C D E F		58-5B
	oct	147150151152	G H I J		5C-5F
	oct	153154155156	K L M N		60-63
	oct	157160161162	O P Q R		64-67
	oct	163164165166	S T U V		68-6B
	oct	167170171172	W X Y Z		6C-6F
	oct	214101102103	d A_ B_ C_		70-73
	oct	104105106107	D_ E_ F_ G_		74-77
	oct	110111112113	H_ I_ J_ K_		78-7B
	oct	114115116117	L_ M_ N_ O_		7C-7F
	oct	120121122123	P_ Q_ R_ S_		80-83
	oct	124125126127	T_ U_ V_ W_		84-87
	oct	130131132272	W_ Y_ Z_ _d		88-8B
	oct	060061062063	0 1 2 3		8C-8F
	oct	064065066067	4 5 6 7		90-93
	oct	070071056253	8 9 . ^		94-97
	oct	040047072254	SP ' : g		98-9B
	oct	012775010300	NL EOB BS LF	9C-9F
	oct	231032032032	g~ - - -		A0-A3
	oct	032032032032	- - - -		A4-A7
	oct	032032136042	- - "136 "042	A8-AB
	oct	045032032032	% - - -		AC-AF
	oct	032032032032	- - - -		B0-B3
	oct	032032032302	- - - c|		B4-B7
	oct	032032032032	- - - -		B8-BB
" END OF ZCODES.
	oct	032135032032	-,],-,-		BC-F
	oct	173101102103	{,A,B,C		C0-3
	oct	104105106107	D,E,F,G		C4-7
	oct	110111032032	H,I,-,-		C8-B
	oct	032032032032	-,-,-,-		CC-F
	oct	175112113114	},J,K,L		D0-3
	oct	115116117120	M,N,O,P		D4-7
	oct	121122032032	Q,R,-,-		D8-B
	oct	032032032032	-,-,-,-		DC-F
	oct	134032123124	\,-,S,T		E0-3
	oct	125126127130	U,V,W,X		E4-7
	oct	131132032032	Y,Z,-,-		E8-B
	oct	032032032032	-,-,-,-		EC-F
	oct	060061062063	0,1,2,3		F0-3
	oct	064065066067	4,5,6,7		F4-7
	oct	070071032032	8,9,-,-		F8-B
	oct	032032032032	-,-,-,-		FC-F
	end




		    convert_tsoapl_ws.pl1           09/24/84  1339.5rew 09/24/84  1247.5      227160



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

/* format: style3 */
convert_tsoapl_ws:
ctw:
     procedure;

/* Written by Bernard Greenberg, from display_aplsv_ws.pl1, 10/77 */
/* Modified 771121 by PG to cleanup error handling and aborting. */
/* Modified 771207 by PG to convert library_number and man_number */
/* Modified 771209 by PG to make vput quick */
/* Modified 771212 by PG to fix bug that was reversing vectors in functions, and speed up function
   converter by processing only lines backwards, not the whole function. */
/* Modified 771230 by PG to fix bug in which we forgot to use cv_fb17 on a 360 number. */
/* Modified 771230 by PG to fix bug in fix of 771212...integers and floats were getting reversed. */
/* Modified 781005 by PG to fix bug 347 in declaration of function line offsets, and to fix bug 346 whereby symbol_bead
   for groups never pointed to the group_bead!
   Modified 800212 by PG to fix 450 (unknown symbol types got counted in num_symbols, but not converted).
   Modified 800227 by PG to add -relock_functions control argument.
   Modified 840907 by C Spitzer. correct length of format string passed to dump_segment_
*/

/* Ideas:
   1. All error messages should include name of ws.
   2. Option to suppress "too small/too large" msg.
   3. "Too small/too large" msg should give context (var name or fcn line number).
*/

/* automatic */

dcl	arg_len		fixed bin (21),
	arg_number	fixed bin,
	arg_ptr		ptr,
	bitcount		fixed bin (24),
	code		fixed bin (35),
	curr_component	fixed bin,
	curr_seglen	fixed bin (18),
	dname		char (168),
	ename		char (32),
	ename1		char (32),
	ename2		char (32),
	fcbp		ptr,
	idx		fixed bin,
	inpath_arg_len	fixed bin (21),
	inpath_arg_ptr	ptr,
	num_symbols	fixed bin,
	number_of_ptrs	fixed bin,
	outpath_arg_len	fixed bin (21),
	outpath_arg_ptr	ptr,
	pathx		fixed bin,
	q		(3) ptr init ((3) null ()),
	qr13stk		fixed bin,
	qsymbot		fixed bin,
	relock_functions	bit (1) aligned,
	saved_bead_table_ptr
			ptr,
	segptrs		(0:15) ptr,
	s360_trtblptr	ptr,
	suspbarf		bit (1) aligned,
	sx		fixed bin,
	symbolx		fixed bin,
	symtab_len	fixed bin,
	ten_digits	picture "(9)z9",
	this_rho		fixed bin,
	type		bit (9) aligned;

/* internal static */

dcl	MaxSegSize	fixed binary (21) internal static initial (65535);
						/* used to be in apl_number_data.incl.pl1 */

/* based */

dcl	arg_string	char (arg_len) based (arg_ptr),
	inpath		char (inpath_arg_len) based (inpath_arg_ptr),
	outpath		char (outpath_arg_len) based (outpath_arg_ptr),
	s360_trtbl	(0:99999) fixed bin (21) based (s360_trtblptr),
	saved_bead_table	(saved_bead_count) ptr unal based (saved_bead_table_ptr);

/* builtins */

dcl	(abs, addr, addrel, baseno, baseptr, bin, binary, bit, copy, divide, fixed, length, ltrim, maxlength, mod, null,
	ptr, rel, size, string, substr, unspec)
			builtin;

/* conditions */

dcl	cleanup		condition;

/* entries */

dcl	com_err_		entry options (variable),
	(get_temp_segments_, release_temp_segments_)
			entry (char (*), (*) ptr, fixed bin (35)),
	convert_date_to_binary_
			entry (char (*), fixed bin (71), fixed bin (35)),
	apl_zcode_to_ascii_ entry (char (*), char (*)),
	dump_segment_	entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)),
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	delete_$path	entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
	expand_pathname_$add_suffix
			entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	get_equal_name_	entry (char (*), char (*), char (32), fixed bin (35)),
	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
	hcs_$terminate_noname
			entry (ptr, fixed bin (35)),
	hcs_$truncate_seg	entry (ptr, fixed bin (18), fixed bin (35)),
	ioa_		entry options (variable),
	ioa_$nnl		entry options (variable),
	ioa_$rsnnl	entry options (variable),
	msf_manager_$open	entry (char (*), char (*), ptr, fixed bin (35)),
	msf_manager_$get_ptr
			entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)),
	msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)),
	msf_manager_$close	entry (ptr);

/* external static */

dcl	(
	error_table_$badopt fixed bin (35),
	error_table_$too_many_args
			fixed bin (35),
	iox_$user_output	ptr
	)		external static;

/* internal static */

dcl	myname		char (17) internal static initial ("convert_tsoapl_ws") options (constant);
dcl	EQUALS		char (1) unal internal static initial ("=") options (constant);
dcl	NL		char (1) varying internal static options (constant) init ("
");

/* include files */

%include apl_number_data;
%include tsoapl_dcls;

/* program */

	pathx = 0;
	outpath_arg_ptr = addr (EQUALS);
	outpath_arg_len = length (EQUALS);
	relock_functions = "0"b;

	arg_number = 1;
	call cu_$arg_ptr (arg_number, arg_ptr, arg_len, code);

	do while (code = 0);
	     if substr (arg_string, 1, 1) ^= "-"
	     then do;
		     go to pathcase (pathx);

pathcase (0):
		     inpath_arg_ptr = arg_ptr;
		     inpath_arg_len = arg_len;
		     pathx = pathx + 1;
		     go to end_pathcase;

pathcase (1):
		     outpath_arg_ptr = arg_ptr;
		     outpath_arg_len = arg_len;
		     pathx = pathx + 1;
		     go to end_pathcase;

pathcase (2):
		     call com_err_ (error_table_$too_many_args, myname, "Maximum of 2 pathnames permitted.");
		     go to usage;

end_pathcase:
		end;
	     else if arg_string = "-relock_functions" | arg_string = "-relock_function"
	     then relock_functions = "1"b;
	     else if arg_string = "-unlock_functions" | arg_string = "-unlock_function"
	     then relock_functions = "0"b;
	     else do;
		     call com_err_ (error_table_$badopt, myname, "^a", arg_string);
		     return;
		end;

	     arg_number = arg_number + 1;
	     call cu_$arg_ptr (arg_number, arg_ptr, arg_len, code);
	end;

	if pathx = 0
	then do;
usage:
		call com_err_ (code, myname, "Usage: ^a inpath {outpath} {-relock_functions|-unlock_functions}", myname);
		return;
	     end;

	call expand_pathname_$add_suffix (inpath, "sv.tsoapl", dname, ename, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, "^a", inpath);
		return;
	     end;

	call hcs_$initiate_count (dname, ename, "", bitcount, 0, aplsv_ws_ptr, code);
	if aplsv_ws_ptr = null
	then do;
		call com_err_ (code, myname, "^a>^a", dname, ename);
		return;
	     end;

	call expand_pathname_$add_suffix (outpath, "sv.apl", dname, ename1, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, outpath);
		go to termin_finale;
	     end;

	call get_equal_name_ ((ename), ename1, ename2, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, arg_string);
		go to termin_finale;
	     end;

	call msf_manager_$open (dname, ename2, fcbp, code);
	if fcbp = null
	then do;
		call com_err_ (code, myname, "^a>^a", dname, ename2);
		go to termin_finale;
	     end;

	saved_bead_pointer = null ();
	curr_component = -1;
	curr_seglen = MaxSegSize + 2;
	saved_ws_info_pointer = allocate (size (saved_ws_info));
						/* Get ball rolling */

/* Get 360 symbol table parameters */

	qr13stk = cvb36f32 (aplsv_ws.qr13stk) / 4;
	qsymbot = cvb36f32 (aplsv_ws.qsymbot) / 4;

	aplsv_symtab_ptr = byteptr (aplsv_ws.qsymbot);
	symtab_len = (qr13stk - qsymbot) / size (symtbe);

/* Allocate bead translation table */

	on cleanup call release_temp_segments_ (myname, q, (0));
	call get_temp_segments_ (myname, q, (0));
	saved_bead_table_ptr = q (1);

/* Set up 360 translate table */

	s360_trtblptr = q (2);

/* Count number of good symbols & allocate saved bead table */

	suspbarf = "0"b;
	num_symbols = 0;
	do sx = 1 to symtab_len;
	     type = aplsv_symtab (sx).type;

	     if type ^= UNUSED_TYPE
	     then if (type = VARIABLE_TYPE) | (type = FUNCTION_TYPE) | (type = FUNCTIONZ_TYPE) | (type = GROUP_TYPE)
		then num_symbols = num_symbols + 1;
		else if (type = SYSTEM_VAR_TYPE) | (type = SYSTEM_FCN_TYPE)
		then ;
		else if (type = SUSP_TEMPVAR_TYPE)
		then do;
			if ^suspbarf
			then call ioa_ ("^a: Warning: suspended functions and values of ^a not being restored.", myname,
				ename);

			suspbarf = "1"b;
		     end;
		else call report_bad_symbol (addr (aplsv_symtab (sx)));
	end;

	symbolx = 0;
	saved_bead_count = num_symbols;

/* Process good symbols */

	do sx = 1 to symtab_len;
	     type = aplsv_symtab (sx).type;

	     if type ^= UNUSED_TYPE
	     then if (type = VARIABLE_TYPE) | (type = FUNCTION_TYPE) | (type = FUNCTIONZ_TYPE) | (type = GROUP_TYPE)
		then call process_symbol (sx);
	end;

/* Set up the parse frame and null latent expresson */

	number_of_ptrs = 0;
	saved_frame_pointer = allocate (size (saved_pf));
	saved_pf.current_line_number = 1;
	saved_pf.parse_frame_type = 1;		/* SUSPENDED FRAME */
	saved_pf.last_parse_frame_ptr = null;
	saved_ws_info.current_parse_frame_ptr = vp_ptr (saved_frame_pointer);

	number_of_dimensions = 1;
	saved_bead_pointer = allocate (size (saved_value_bead));
	saved_ws_info.latent_expression = beadno (vp_ptr (saved_bead_pointer));
	string (saved_value_bead.type) = character_value_type;
	saved_value_bead.size = bit (fixed (size (value_bead), 18), 18);
	saved_value_bead.total_data_elements = 0;
	saved_value_bead.rhorho = 1;
	saved_value_bead.data_pointer = null;
	saved_value_bead.rho (1) = 0;

/* Allocate the master bead table */

	bead_description_pointer = allocate (size (bead_description_table));
	saved_ws_info.bead_table_pointer = vp_ptr (bead_description_pointer);
	bead_description_table.bead_pointer (*) = saved_bead_table (*);

/* Fill in the workspace header. */

	saved_ws_info.save_version = 4;
	saved_ws_info.lock = "";
	saved_ws_info.highest_segment = curr_component;
	saved_ws_info.total_beads = saved_bead_count;
	saved_ws_info.number_of_symbols = num_symbols;
	saved_ws_info.integer_fuzz = 1.110223e-16;	/* Multics default */
	saved_ws_info.fuzz = 1e-13;
	ten_digits = cvb36f32 (aplsv_ws.library_number);
	saved_ws_info.wsid = ltrim (ten_digits) || " " || cv_ascii (substr (aplsv_ws.wsname.chars, 1, aplsv_ws.wsname.len));
	saved_ws_info.float_index_origin = bin (aplsv_ws.index_origin, 17);
	saved_ws_info.random_link = cvb36f32 (aplsv_ws.seed);
	call convert_date_to_binary_ (cv_ascii (aplsv_ws.date_saved) || " 00:00", saved_ws_info.time_saved, (0));
	saved_ws_info.time_saved = saved_ws_info.time_saved + fixed (1e6 * cvb36f32 (aplsv_ws.time_saved) / 3e2, 71);
	saved_ws_info.index_origin = bin (aplsv_ws.index_origin, 17);
	saved_ws_info.digits = cvb36f32 (aplsv_ws.digits);
	saved_ws_info.width = bin (cv_b18 (aplsv_ws.printing_width), 16);
	saved_ws_info.user_number = cvb36f32 (aplsv_ws.man_number);
	ten_digits = saved_ws_info.user_number;
	saved_ws_info.user_name = "TSO user " || ltrim (ten_digits);

/* All done, close the workspace and quit */

	call msf_manager_$adjust (fcbp, curr_component, curr_seglen * 36, "111"b, code);
	if code = 0
	then call msf_manager_$close (fcbp);
	else call com_err_ (code, myname, "Problem in closing msf");
	call release_temp_segments_ (myname, q, (0));

termin_finale:
	call hcs_$terminate_noname (aplsv_ws_ptr, code);
	return;

abort:
	call release_temp_segments_ (myname, q, (0));
	call hcs_$terminate_noname (aplsv_ws_ptr, code);
	call msf_manager_$close (fcbp);
	call delete_$path (dname, ename2, "100101"b, myname, code);
	return;

process_symbol:
     procedure (bv_symdex);

/* parameters */

dcl	bv_symdex		fixed bin;

/* automatic */

dcl	bit72		bit (72) aligned;
dcl	code		bit (9);
dcl	cx		fixed bin;
dcl	data_ptr		ptr;
dcl	dtype		fixed bin;
dcl	elmtct		fixed bin;
dcl	f17un		fixed bin (17) unaligned;
dcl	float_temp	char (100) varying;
dcl	floatbin63	float bin (63);
dcl	fx35		fixed bin (35);
dcl	(j, k)		fixed bin;
dcl	line		char (3000) varying;
dcl	mulsym_ptr	ptr;
dcl	nlines		fixed bin;
dcl	space_state	bit (1);
dcl	sx		fixed bin;
dcl	ten_digits	picture "(9)z9";
dcl	varsymptr		ptr;
dcl	vtemp		char (1000) varying;

/* based */

dcl	based_elmtct_charcons
			char (elmtct) based (addr (fun_code.code (cx)));
dcl	cxa		(0:99999) bit (36) aligned based (aplsv_ws_ptr);
dcl	funexp		char (262143) based (q (3)) varying;

/* program */

	sx = bv_symdex;
	symtbep = addr (aplsv_symtab (sx));
	mulsym_ptr = intern_360_sym (symtbep);
	aplsv_value_ptr = byteptr ("000"b3 || symtbe.value_offset);

	if symtbe.type = VARIABLE_TYPE
	then do;
		if symtbe.value_offset = "000000"b3
		then return;			/* intern did all work */
		number_of_dimensions = cv_fb17 (aplsv_value.rhorho_x4) / 4;
		array_ptr = addr (aplsv_value.rho (number_of_dimensions + 1));
		saved_bead_pointer = allocate (size (saved_value_bead));
		mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer));

		saved_value_bead.rhorho = number_of_dimensions;
		data_elements = 1;
		do idx = 1 to number_of_dimensions;
		     this_rho = binary (pack (aplsv_value.rho (idx)));
		     saved_value_bead.rho (idx) = this_rho;
		     data_elements = data_elements * this_rho;
		end;
		saved_value_bead.total_data_elements = data_elements;
		dtype = binary (aplsv_value.type, 9);

(subrg):
		go to data_type (dtype);

data_type (1):
		data_ptr = allocate (size (saved_boolean_datum));
		do j = 1 to data_elements / 8;
		     substr (data_ptr -> saved_boolean_datum, j * 8 - 7, 8) = bit_array.data (j);
		end;
		j = mod (data_elements, 8);
		if j ^= 0
		then substr (data_ptr -> saved_boolean_datum, data_elements - j + 1) = bit_array.tail;
		saved_general_bead.size = bit (fixed (size (saved_boolean_datum), 18), 18);
		string (saved_general_bead.type) = zero_or_one_value_type;
		go to end_data_type;

data_type (2):
		curr_seglen = curr_seglen + mod (curr_seglen, 2);
		data_ptr = allocate (size (numeric_datum));
		string (saved_general_bead.type) = integral_value_type;
		saved_general_bead.size = bit (fixed (size (numeric_datum) + 1, 18), 18);
		do idx = 1 to data_elements;
		     data_ptr -> numeric_datum (idx - 1) = binary (pack (fixed_array (idx)));
		end;
		go to end_data_type;

data_type (3):
		curr_seglen = curr_seglen + mod (curr_seglen, 2);
		data_ptr = allocate (size (numeric_datum));
		string (saved_general_bead.type) = numeric_value_type;
		saved_general_bead.size = bit (fixed (size (numeric_datum) + 1, 18), 18);
		do idx = 1 to data_elements;
		     data_ptr -> numeric_datum (idx - 1) = cv_float (float_array (idx));
		end;
		go to end_data_type;

data_type (4):
		data_ptr = allocate (size (character_data_structure));
		data_ptr -> character_string_overlay = cv_ascii (char_array);
		saved_general_bead.size = bit (fixed (size (character_string_overlay), 18), 18);
		string (saved_general_bead.type) = character_value_type;
end_data_type:
		saved_general_bead.size = bit (fixed (size (value_bead) + fixed (saved_general_bead.size, 18), 18), 18);
		saved_value_bead.data_pointer = vp_ptr (data_ptr);
	     end;
	else if symtbe.type = FUNCTION_TYPE | symtbe.type = FUNCTIONZ_TYPE
	then do;
		aplsv_function_ptr = aplsv_value_ptr;

		nlines = cv_fb17 (aplsv_function.nlines);

		funexp = "";
		do idx = 0 to nlines - 1;		/* the lines are built top-down, but each line is built right-to-left */
		     line = NL;
		     if idx = 0
		     then code_ptr = byteptr ("000"b3 || aplsv_function.header_offset);
		     else code_ptr = byteptr ("000"b3 || aplsv_function.line (idx).offset);
		     code_len = cv_fb17 (fun_code.size);
		     space_state = "0"b;		/* Assume operator */
		     do cx = code_len to 1 by -1;
			code = fun_code.code (cx);

			if substr (code, 9, 1) = "1"b /* short syllable */
			then do;

				if code = "003"b3
				then ;		/* unl sta */
				else if code = "005"b3
				then ;		/* labeled sta */
				else if code = CECONST | code = CBCONST | code = CICONST | code = CFCONST
					| code = CCCONST
				then do;
					if code = CCCONST
					then space_state = "0"b;
					else do;
						if space_state
						then call vput (" ");
						space_state = "1"b;
					     end;
					elmtct = fixed (get_packs (2), 18);
					if code = CCCONST
					then do;	/* chars */
						cx = cx - elmtct;
						if fun_code.code (cx - 1) = "46"b4 || "1"b
						/* lamp/comment */
						then vtemp = cv_ascii (based_elmtct_charcons);
						else vtemp = requote (cv_ascii (based_elmtct_charcons));

						call vput (vtemp);
					     end;
					else if code = CICONST
					then do;	/* INTEGER */
						vtemp = "";
						do j = 1 to elmtct;
						     fx35 = cvf32 (get_packs (4));
						     ten_digits = abs (fx35);

						     if fx35 >= 0
						     then vtemp = ltrim (ten_digits);
						     else do;
							     vtemp = QUpperMinus;
							     vtemp = vtemp || ltrim (ten_digits);
							end;

						     if j ^= 1
						     then vtemp = vtemp || " ";

						     call vput (vtemp);
						end;
					     end;
					else if code = CBCONST
					then do;	/* BOOLEAN */
						j = cx - divide (elmtct + 7, 8, 17, 0);
						vtemp = "";
						do k = 1 to elmtct;
						     if mod (k, 8) = 1
						     then do;
							     code = fun_code.code (j);
							     j = j + 1;
							end;
						     if k ^= 1
						     then vtemp = vtemp || " ";

						     if substr (code, 2, 1) = "0"b
						     then vtemp = vtemp || "0";
						     else vtemp = vtemp || "1";
						     code = substr (copy (code, 1), 2);
						end;
						call vput (vtemp);
						cx = cx - divide (elmtct + 7, 8, 17, 0);
					     end;
					else if code = CFCONST | code = CECONST
					then do;	/* FLOAT */
						if code = CECONST
						then call com_err_ (0, myname,
							"ECONST encountered. Please call Bernard Greenberg, 617-492-9300"
							);
						vtemp = "";
						do j = 1 to elmtct;
						     bit72 = get_packs (8);
						     floatbin63 = cv_floatx (bit72);
						     call ioa_$rsnnl ("^[^e^;^f^]", float_temp, 0, code = CECONST,
							abs (floatbin63));

						     if floatbin63 >= 0e0
						     then vtemp = float_temp;
						     else do;
							     vtemp = QUpperMinus;
							     vtemp = vtemp || float_temp;
							end;

						     if j ^= 1
						     then vtemp = vtemp || " ";

						     call vput (vtemp);
						end;
					     end;
				     end;
				else if code = "007"b3
				then ;		/* dummy */
				else do;		/* zcode operator */
					call vput (cv_asciich (substr (code, 1, 8)));
					space_state = "0"b;
				     end;
			     end;
			else if code = "000"b3 & fun_code.code (cx - 1) = "000"b3
			then cx = cx - 1;
			else do;			/* long syllable */
				if space_state = "1"b
				then call vput (" ");
				unspec (f17un) = "11"b || substr (fun_code.code (cx - 1), 2) || substr (code, 2);
				cx = cx - 1;
				vtemp = get_symname (addr (cxa (qr13stk + f17un)));
				call vput (vtemp);
				space_state = "1"b; /* name/num */
			     end;
		     end;
		     funexp = funexp || line;
		end;
		data_elements = length (funexp);
		saved_bead_pointer = allocate (size (saved_fb));
		mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer));
		string (saved_general_bead.type) = function_type;
		saved_general_bead.size = bit (fixed (size (function_bead), 18), 18);

		if relock_functions & (symtbe.type = FUNCTIONZ_TYPE)
		then saved_fb.class = 1;		/* locked */
		else saved_fb.class = 0;		/* unlocked */
		saved_fb.text_length = data_elements;
		saved_fb.text = funexp;
	     end;
	else if symtbe.type = GROUP_TYPE
	then do;
		aplsv_group_ptr = aplsv_value_ptr;
		total_members = cv_fb17 (aplsv_group.count);
		saved_bead_pointer = allocate (size (saved_gb));
		mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer));
		saved_general_bead.size = bit (fixed (size (group_bead) + total_members, 18), 18);
						/* UGH KLUDGE THANK LAMSON */
		string (saved_general_bead.type) = group_type;
		saved_gb.number_of_members = total_members;
		do idx = 1 to total_members;
		     varsymptr = byteptr (aplsv_group.symbp (idx));
		     mulsym_ptr = intern_360_sym (varsymptr);
		     saved_gb.member (idx) = s360_trtbl (fixed (rel (varsymptr), 18));
		end;
	     end;
	return;

/* Internal procedures for process_symbol */

vput:
     procedure (cs);

/* parameters */

dcl	cs		char (*) varying;

/* program */

	if length (line) + length (cs) > maxlength (line)
	then do;
		call ioa_ ("^a: Buffer size exceeded.", myname);
		return;
	     end;

	line = cs || line;

     end vput;

get_packs:
     proc (n) returns (bit (*));

dcl	n		fixed bin;

dcl	btemp		bit (100) varying;
dcl	j		fixed bin;

	btemp = ""b;
	do j = cx - n to cx - 1 by 1;
	     btemp = btemp || substr (fun_code.code (j), 2, 8);
	end;
	cx = cx - n;
	return (btemp);

     end get_packs;

     end process_symbol;

allocate:
     proc (sz) returns (ptr);				/* Master allocator */

dcl	sz		fixed bin;

	if curr_seglen + sz > MaxSegSize + 1
	then do;
		curr_component = curr_component + 1;
		call msf_manager_$get_ptr (fcbp, curr_component, "1"b, segptrs (curr_component), (0), code);
		if segptrs (curr_component) = null
		then do;
			call com_err_ (code, myname, "Getting comp. #^d of msf.", curr_component);
			go to abort;
		     end;
		call hcs_$truncate_seg (segptrs (curr_component), 0, code);
		if code ^= 0
		then do;
			call com_err_ (code, myname, "Truncating new ws seg #^d.", curr_component);
			go to abort;
		     end;
		curr_seglen = 0;
	     end;
	curr_seglen = curr_seglen + sz;
	return (ptr (segptrs (curr_component), curr_seglen - sz));
     end;

vp_ptr:
     proc (pt) returns (ptr);				/* cv ptr in CURRENT SEGMENT to virtual */

dcl	pt		ptr;

	return (ptr (baseptr (curr_component), rel (pt)));
     end;

uvp_ptr:
     proc (pt) returns (ptr);				/* Unvirtualize ptr */

dcl	pt		ptr;

	return (ptr (segptrs (binary (baseno (pt), 15)), rel (pt)));
     end;

beadno:
     proc (vp) returns (fixed bin (21));		/* ASSIGN bead number */

dcl	vp		ptr;

	saved_bead_count = saved_bead_count + 1;
	saved_bead_table (saved_bead_count) = vp;
	return (saved_bead_count);

beadno$symbol:
     entry (vp) returns (fixed bin (21));

	symbolx = symbolx + 1;
	saved_bead_table (symbolx) = vp;
	return (symbolx);

     end;

get_symname:
     proc (a_pt) returns (char (*));

dcl	(pt, a_pt)	ptr;

	pt = a_pt;
	if pt -> symtbe.size >= 4
	then pt = addrel (byteptr ("000"b3 || pt -> symtbe.name_or_offset), 1);
	return (cv_ascii (pt -> symbol_struc.name));

     end;

requote:
     proc (instring) returns (char (*));

/* How difficult is PL/I for character string manipulation */
/* B. Greenberg 5/31/77 */


dcl	instring		char (*);
dcl	outstringl	fixed bin (21);
dcl	QUOTE		char (1) static init ("'") options (constant);
dcl	QUOTEQUOTE	char (2) static init ("''") options (constant);
dcl	outstring		char (2 * length (instring) + 2);
dcl	(i, j)		fixed bin (21);

dcl	(index, length, substr)
			builtin;

	outstringl = 1;
	substr (outstring, 1, 1) = QUOTE;
	i = 1;
nextj:
	j = index (substr (instring, i), QUOTE);
	if j = 0
	then do;
		substr (outstring, outstringl + 1, length (instring) - i + 1) = substr (instring, i);
		outstringl = outstringl + length (instring) - i + 2;
		substr (outstring, outstringl, 1) = QUOTE;
		return (substr (outstring, 1, outstringl));
	     end;
	substr (outstring, outstringl + 1, j - 1) = substr (instring, i, j - 1);
	outstringl = outstringl + j;
	substr (outstring, outstringl, 2) = QUOTEQUOTE;
	outstringl = outstringl + 1;
	i = i + j;
	go to nextj;
     end;

cv_asciich:
     proc (zc) returns (char (1) varying);

dcl	zc		bit (8);
dcl	asc		char (1);

	unspec (asc) = "0"b || zc;
	call apl_zcode_to_ascii_ ((asc), asc);
	return (asc);

     end;

report_bad_symbol:
     procedure (P_symtabe_ptr);

/* parameters */

declare	P_symtabe_ptr	ptr parameter;

/* automatic */

declare	symtabe_ptr	ptr;

/* program */

	symtabe_ptr = P_symtabe_ptr;

	call ioa_ ("^a: Unknown symbol type ^2.4b hex for ""^a"".", substr (symtabe_ptr -> symtbe.type, 2),
	     get_symname (symtabe_ptr));
	call dumphex (symtabe_ptr, size (symtbe));
	return;

     end report_bad_symbol;

dumphex:
     proc (p, n);
dcl	p		ptr,
	n		fixed bin;

	call ioa_$nnl ("^p:", p);
	call dump_segment_ (iox_$user_output, p, 0, 0, n, "000001000010"b /*"0102"b3 */);

     end;

intern_360_sym:
     proc (s360sp) returns (ptr);

dcl	s360relo		fixed bin (18);
dcl	savep		ptr init (saved_bead_pointer);
dcl	s360sp		ptr;

	s360relo = fixed (rel (s360sp), 18);
	if s360_trtbl (s360relo) = 0
	then do;
		symbol_name_length = s360sp -> symtbe.size;
		saved_bead_pointer = allocate (size (saved_sb));
		saved_sb.name_length = symbol_name_length;
		saved_sb.name = get_symname (s360sp);
		string (saved_general_bead.type) = symbol_type;
		saved_general_bead.size = bit (fixed (size (symbol_bead), 18), 18);
		s360_trtbl (s360relo) = beadno$symbol (vp_ptr (addr (saved_sb)));
	     end;
	saved_bead_pointer = savep;
	return (uvp_ptr ((saved_bead_table (s360_trtbl (s360relo)))));
     end;

/* include files */

%include apl_symbol_bead;
%include apl_value_bead;
%include apl_function_bead;
%include apl_saved_ws;
%include apl_bead_format;
%include apl_operator_bead;
%include apl_group_bead;
%include apl_characters;

     end;




		    display_tsoapl_ws.pl1           09/24/84  1339.5rew 09/24/84  1247.6      129195



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

display_tsoapl_ws: dtw:
     procedure;

/* Started by Paul Green */
/* Brought to fruition by Bernard Greenberg, 10/77, features galore. */
/* Modified 771208 by PG to display library_number and man_number */
/* Modified 781005 by PG to fix bug 347 in declaration of function line offsets */
/* Modified 840907 by C Spitzer. correct length of format string passed to dump_segment_ */

/* automatic */

dcl  arg_len fixed bin (21),
     aoutsw ptr,
     arg_ptr ptr,
     bitcount fixed bin (24),
     code fixed bin (35),
     dname char (168),
     ename char (32),
     idx fixed bin,
     long_option bit (1) aligned,
     rhorho fixed bin,
     this_rho fixed bin,
     qr13stk fixed bin,
     qsymbot fixed bin,
     symtab_len fixed bin,
     dtype fixed bin,
     sx fixed bin,
     temp_time fixed bin (71),
     temp_timec char (24);

/* based */

dcl  arg_string char (arg_len) based (arg_ptr);

/* builtins */

dcl (addr, addrel, bin, binary, copy, divide, fixed, maxlength, mod, null, size, substr, translate, unspec) builtin;

/* entries */

dcl  com_err_ entry options (variable),
     convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)),
     date_time_ entry (fixed bin (71), char (*)),
     apl_zcode_to_ascii_ entry (char (*), char (*)),
     dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
     fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$ioa_switch entry options (variable),
     ioa_$ioa_switch_nnl entry options (variable),
     ioa_$nnl entry options (variable),
     ioa_$rsnnl entry options (variable),
     iox_$look_iocb entry (char (*), ptr, fixed bin (35));

/* external static */

dcl  iox_$user_output ptr ext;
dcl  error_table_$badopt fixed bin (35) ext;

/* internal static */

dcl  my_name char (17) internal static initial ("display_tsoapl_ws");

/* include files */

%include apl_characters;
%include apl_number_data;
%include tsoapl_dcls;

/* program */

	call iox_$look_iocb ("aplout", aoutsw, code);
	if code ^= 0 then aoutsw = iox_$user_output;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0
	then do;
	     call com_err_ (code, my_name, "Usage: display_tsoapl_ws path");
	     return;
	end;

	call expand_pathname_$add_suffix (arg_string, "sv.tsoapl", dname, ename, code);
	if code ^= 0
	then do;
	     call com_err_ (code, my_name, "^a", arg_string);
	     return;
	end;

	call hcs_$initiate_count (dname, ename, "", bitcount, 0, aplsv_ws_ptr, code);
	if aplsv_ws_ptr = null
	then do;
	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;
	end;

	qr13stk = cvb36f32 (aplsv_ws.qr13stk)/4;
	qsymbot = divide (binary (pack (aplsv_ws.qsymbot)), 4, 20, 0);

	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code = 0
	then if arg_string = "-lg" | arg_string = "-long"
	     then long_option = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, my_name, arg_string);
		go to finale;
	     end;
	else long_option = "0"b;

	if long_option
	then do;
	     call ioa_ ("name:^-^d ^a", cvb36f32 (aplsv_ws.library_number),
		cv_ascii (substr (aplsv_ws.wsname.chars, 1, aplsv_ws.wsname.len)));
	     call convert_date_to_binary_ (cv_ascii (aplsv_ws.date_saved) || " 00:00", temp_time, code);
	     temp_time = temp_time + fixed (1e6 * cvb36f32 (aplsv_ws.time_saved)/3e2, 71);
	     call date_time_ (temp_time, temp_timec);
	     call ioa_ ("saved:^-^a", temp_timec);
	     call ioa_ ("saved by:^-^d", cvb36f32 (aplsv_ws.man_number));
	     call ioa_ ("fuzz:^-^w", aplsv_ws.fuzz);
	     call ioa_ ("index origin:^-^d", cvb36f32 (aplsv_ws.index_origin));
	     call ioa_ ("seed:^-^d", cvb36f32 (aplsv_ws.seed));
	     call ioa_ ("digits:^-^d", cvb36f32 (aplsv_ws.digits));
	     call ioa_ ("width:^-^d", bin (cv_b18 (aplsv_ws.printing_width), 16));
	     call ioa_ ("");
	     call ioa_ ("qsymbot:^-^w", qsymbot);
	     call ioa_ ("qr13stk:^-^w", qr13stk);
	     call ioa_ ("mx:^-^w", divide (cvb36f32 (aplsv_ws.mx), 4, 20, 0));
	     call ioa_ ("svi:^-^w", divide (cvb36f32 (aplsv_ws.svi), 4, 20, 0));
	     call ioa_ ("");
	end;

	aplsv_symtab_ptr = byteptr (aplsv_ws.qsymbot);
	symtab_len = (qr13stk - qsymbot)/size (symtbe);

	do sx = 1 to symtab_len;
	     if aplsv_symtab (sx).type ^= UNUSED_TYPE
	     then call process_symbol (sx);
	end;
finale:
	call hcs_$terminate_noname (aplsv_ws_ptr, code);
	return;

process_symbol:
	procedure (bv_symdex);

/* parameters */

dcl  bv_symdex fixed bin;

/* automatic */

dcl  nlabels_w_nargs fixed bin;
dcl  nlines fixed bin;
dcl  sx fixed bin;
dcl  code bit (9);
dcl  cx fixed bin;
dcl  space_state bit (1);
dcl  f17un fixed bin (17) unaligned;
dcl  bit72 bit (72) aligned;
dcl  elmtct fixed bin;
dcl (i, j, k) fixed bin;
dcl  fx35 fixed bin (35);
dcl  varsymptr ptr;
dcl  funexp char (5000) varying;
dcl  vtemp char (100) varying;

/* based */

dcl  based_elmtct_charcons char (elmtct) based (addr (fun_code.code (cx)));
dcl  cxa (0:99999) bit (36) aligned based (aplsv_ws_ptr);

/* program */

	     sx = bv_symdex;
	     symtbep = addr (aplsv_symtab (sx));

	     if symtbe.value_offset = ""b		/* ignore names with no value */
	     then return;

	     aplsv_value_ptr = byteptr ("000"b3 || symtbe.value_offset);

	     if symtbe.type = VARIABLE_TYPE
	     then do;
		rhorho = divide (cv_fb17 (aplsv_value.rhorho_x4), 4, 21, 0);
		array_ptr = addr (aplsv_value.rho (rhorho + 1));
		data_elements = 1;
		do idx = 1 to rhorho;
		     this_rho = cvb36f32 (aplsv_value.rho (idx));
		     data_elements = data_elements * this_rho;
		end;
		funexp = get_symname (symtbep) || cv_asciich ("15"b4); /* <- */
		do idx = 1 to rhorho;
		     if idx ^= 1 then funexp = funexp || " ";
		     call ioa_$rsnnl ("^d", vtemp, 0, cvb36f32 (aplsv_value.rho (idx)));
		     funexp = funexp || vtemp;
		end;
		call ioa_$ioa_switch_nnl
		     (aoutsw, "^a ^[^a ^;^s^]", funexp, rhorho ^= 0, cv_asciich ("2D"b4));
						/* rho */
		dtype = binary (aplsv_value.type, 9);
		if dtype < 1 | dtype > 4 then do;
		     call ioa_$nnl ("Bad data type: ^d: ", dtype);
		     call dumphex (aplsv_value_ptr, 16);
		     go to badsym;
		end;
		go to data_type (dtype);

data_type (1):
		do j = 1 to data_elements/8;
		     do k = 1 to 8;
			call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^b", ^(j = 1 & k = 1),
			     substr (bit_array.data (j), k, 1));
		     end;
		end;
		do k = 1 to mod (data_elements, 8);
		     call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^b", ^(k = 1 & data_elements < 8),
			substr (bit_array.tail, k, 1));
		end;
		go to end_data_type;

data_type (2):
		do idx = 1 to data_elements;
		     call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^d", idx ^= 1, binary (pack (fixed_array (idx))));
		end;
		go to end_data_type;

data_type (3):
		do idx = 1 to data_elements;
		     call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^e", idx ^= 1, cv_float (float_array (idx)));
		end;
		go to end_data_type;

data_type (4):
		call ioa_$ioa_switch_nnl (aoutsw, "^a^/", requote (cv_ascii (char_array)));

end_data_type:	call ioa_$ioa_switch_nnl (aoutsw, "^/");
	     end;
	     else

	     if symtbe.type = FUNCTION_TYPE
	     | symtbe.type = FUNCTIONZ_TYPE
	     then do;
		aplsv_function_ptr = aplsv_value_ptr;

		nlines = cv_fb17 (aplsv_function.nlines);
		nlabels_w_nargs = cv_fb17 (aplsv_function.nlabels_w_nargs);

		do idx = 0 to nlines - 1;
		     funexp = "";			/* Init varying output */
		     if idx = 0 then code_ptr = byteptr ("000"b3 || aplsv_function.header_offset);
		     else code_ptr = byteptr ("000"b3 || aplsv_function.line (idx).offset);
		     code_len = cv_fb17 (fun_code.size);
		     if idx = 0 then call ioa_$ioa_switch_nnl (aoutsw, "^p^-", addr (fun_code.size));
		     else call ioa_$ioa_switch_nnl (aoutsw, "^p^-[^2d] ", addr (fun_code.size), idx);

		     space_state = "0"b;		/* Assume operator */
		     do cx = code_len to 1 by -1;
			code = fun_code.code (cx);

			if substr (code, 9, 1) = "1"b /* short syllable */
			then do;

			     if code = "003"b3 then;	/* unl sta */
			     else if code = "005"b3 then; /* labeled sta */
			     else if code = CECONST | code = CBCONST | code = CICONST | code = CFCONST | code = CCCONST
			     then do;
				if code = CCCONST then space_state = "0"b;
				else do;
				     if space_state then call vput (" ");
				     space_state = "1"b;
				end;
				elmtct = fixed (get_packs (2), 18);
				if code = CCCONST then do; /* chars */
				     cx = cx - elmtct;
				     if fun_code.code (cx - 1) = "46"b4 || "1"b /* lamp/comment */
				     then call vput (cv_ascii (based_elmtct_charcons));
				     else call vput (requote (cv_ascii (based_elmtct_charcons)));
				end;
				else if code = CICONST then do; /* integer, fullword */
				     do j = 1 to elmtct;
					fx35 = cvf32 (get_packs (4));
					call ioa_$rsnnl ("^d^[ ^]", vtemp, 0, fx35, j ^= 1);
					vtemp = translate (vtemp, QUpperMinus, "-");
					call vput ((vtemp));
				     end;
				end;
				else if code = CBCONST then do;	/* BOOLEAN */
				     j = cx - divide (elmtct+ 7, 8, 17, 0);
				     vtemp = "";
				     do k = 1 to elmtct;
					if mod (k, 8) = 1 then do;
					     code = fun_code.code (j);
					     j = j + 1;
					end;

					if k ^= 1
					then vtemp = vtemp || " ";

					if substr (code, 2, 1) = "0"b
					then vtemp = vtemp || "0";
					else vtemp = vtemp || "1";
					code = substr (copy (code, 1), 2);
				     end;
				     call vput ((vtemp));
				     cx = cx - divide (elmtct + 7, 8, 17, 0);
				end;
				else if code = CFCONST | code = CECONST then do;
				     do j = 1 to elmtct;
					bit72 = get_packs (8);
					call ioa_$rsnnl ("^[^e^;^f^]^[ ^]", vtemp, 0,
					     code = CECONST, cv_floatx (bit72), j ^= 1);
					vtemp = translate (vtemp, QUpperMinus, "-");
					call vput ((vtemp));
				     end;
				end;
			     end;
			     else if code = "007"b3 then; /* dummy */
			     else do;		/* zcode operator */
				call vput (cv_asciich (substr (code, 1, 8)));
				space_state = "0"b;
			     end;
			end;
			else if code = "000"b3 & fun_code.code (cx - 1) = "000"b3 then cx = cx - 1;
			else do;			/* long syllable */
			     if space_state = "1"b then call vput (" ");
			     unspec (f17un) = "11"b || substr (fun_code.code (cx - 1), 2) || substr (code, 2);
			     cx = cx - 1;
			     call vput (get_symname (addr (cxa (qr13stk + f17un))));
			     space_state = "1"b;	/* name/num */
			end;
		     end;
		     if idx = 0 then do;
			call vput (cv_asciich ("9B"b4) || " "); /* del */
		     end;
		     if length (funexp) = maxlength (funexp)
		     then call ioa_$ioa_switch (aoutsw, "Function too big to convert. Max is ^d chars",
			maxlength (funexp));
		     call ioa_$ioa_switch_nnl (aoutsw, "^a^/", funexp);
		end;
		call ioa_$ioa_switch_nnl (aoutsw, "^-^a^/", cv_asciich ("9B"b4));
	     end;
	     else if symtbe.type = GROUP_TYPE
	     then do;
		call ioa_$ioa_switch_nnl (aoutsw, "^5x)group ^a", get_symname (symtbep));
		aplsv_group_ptr = aplsv_value_ptr;
		do i = 1 to cv_fb17 (aplsv_group.count);
		     varsymptr = byteptr (aplsv_group.symbp (i));
		     call ioa_$ioa_switch_nnl (aoutsw, " ^a", get_symname (varsymptr));
		end;
		call ioa_$ioa_switch_nnl (aoutsw, "^/");
	     end;
	     else if symtbe.type = SYSTEM_VAR_TYPE
	     then;
	     else if symtbe.type = SYSTEM_FCN_TYPE
	     then;
	     else do;
		call ioa_$nnl ("Unknown symbol type: ^2.4b. ", substr (symtbe.type, 2));
badsym:		call ioa_ ("Losing symbol is ""^a""", get_symname (symtbep));
		call dumphex (addr (symtbe), size (symtbe));
	     end;
	     return;

vput:	     proc (cs);

dcl  cs char (*);

		funexp = cs || copy (funexp, 1);

	     end vput;

get_packs:     proc (n) returns (bit (*));

dcl  n fixed bin;

dcl  btemp bit (100) varying;
dcl  j fixed bin;

		btemp = ""b;
		do j = cx - n to cx - 1 by 1;
		     btemp = btemp || substr (fun_code.code (j), 2, 8);
		end;
		cx = cx - n;
		return (btemp);

	     end get_packs;

	end process_symbol;

get_symname: proc (a_pt) returns (char (*));

dcl (pt, a_pt) ptr;

	     pt = a_pt;
	     if pt -> symtbe.size >= 4
	     then pt = addrel (byteptr ("000"b3 || pt -> symtbe.name_or_offset), 1);
	     return (cv_ascii (pt -> symbol_struc.name));

	end;

requote:	proc (instring) returns (char (*));

/* How difficult is PL/I for character string manipulation */
/* B. Greenberg 5/31/77 */


dcl  instring char (*);
dcl  outstringl fixed bin (21);
dcl  QUOTE char (1) static init ("'") options (constant);
dcl  QUOTEQUOTE char (2) static init ("''") options (constant);
dcl  outstring char (2 * length (instring) + 2);
dcl (i, j) fixed bin (21);

dcl (index, length, substr) builtin;

	     outstringl = 1;
	     substr (outstring, 1, 1) = QUOTE;
	     i = 1;
nextj:	     j = index (substr (instring, i), QUOTE);
	     if j = 0 then do;
		substr (outstring, outstringl + 1, length (instring) - i + 1)
		     = substr (instring, i);
		outstringl = outstringl + length (instring) - i + 2;
		substr (outstring, outstringl, 1) = QUOTE;
		return (substr (outstring, 1, outstringl));
	     end;
	     substr (outstring, outstringl + 1, j - 1) = substr (instring, i, j - 1);
	     outstringl = outstringl + j;
	     substr (outstring, outstringl, 2) = QUOTEQUOTE;
	     outstringl = outstringl + 1;
	     i = i + j;
	     go to nextj;
	end;

cv_asciich: proc (zc) returns (char (1));

dcl  zc bit (8);
dcl  asc char (1);

	     unspec (asc) = "0"b || zc;
	     call apl_zcode_to_ascii_ ((asc), asc);
	     return (asc);

	end;

dumphex:	proc (p, n);
dcl  p ptr, n fixed bin;

	     call ioa_$nnl ("^p:", p);
	     call dump_segment_ (iox_$user_output, p, 0, 0, n, "000001000010"b /* "0102"b3 */);

	end;

     end;




		    read_tsoapl_tape.pl1            08/12/81  2123.1r   08/08/81  1600.1      119565



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

/* READ_TSOAPL_TAPE - Program to read in an IBM tape created by APLUTIL (at MIT) or APL/DOS.
   These tapes have a 144 byte workspace header record, followed by as many 10000 byte records
   as necessary to hold the workspace.

   To increase the maximum tape record size, change the variable TPMXL and the -bk argument in the attach description.
*/

read_tsoapl_tape: rtt:
     procedure;

/* Written by Paul Green */
/* Changed for tape_nstd_, name args by B. Greenberg 10/77 */
/* Modified 771122 by PG to use correct maximum tape record length (10000 bytes). */
/* Modified 771201 by PG to set remaining_bytes to maximum before every workspace. */
/* Modified 771208 by PG to put library_number in workspace name. */
/* Modified 780811 by PG to permit density to be specified. */

/* automatic */

dcl	arg_count fixed bin,
	argno fixed bin,
	arg_len fixed bin (21),
	arg_ptr ptr,
	attach_desc char (128) varying,
	bitcount fixed bin (24),
	buff_offset fixed bin (21),
	buff_ptr ptr,
	bytes_read fixed bin (21),
	bytes_to_read fixed bin (21),
	code fixed bin (35),
	density char (4) varying,
	dname char (168),
	ename char (32),
	end_of_tape bit (1) aligned,
	file_found (10) bit (1) aligned,
	fileno fixed bin,
	filenames (10) char (15),
	i fixed bin,
	listopt bit (1) init ("0"b),
	input_iocb_ptr ptr,
	n_words fixed bin (18),
	nfiles fixed bin,
	record_length fixed bin (21),
	record_number fixed bin,
	remaining_bytes fixed bin (21),
	tapename char (16) varying,
	ws_number fixed bin,
	ws_ptr ptr;

/* based */

dcl	arg_string char (arg_len) based (arg_ptr),
	buffer (0:1044479) char (1) based (buff_ptr);

/* builtins */

dcl	(addr, binary, divide, hbound, ltrim, min, null, rtrim, substr, translate) builtin;

/* conditions */

dcl	cleanup condition;

/* entries */

dcl	com_err_ entry options (variable),
	apl_zcode_to_ascii_ entry (char (*), char (*)),
	cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
	cu_$arg_count entry (fixed bin),
	cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	get_wdir_ entry () returns (char (168)),
	ioa_ entry options (variable),
	hcs_$delentry_seg entry (ptr, fixed bin (35)),
	hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)),
	hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
	hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
	hcs_$terminate_noname entry (ptr, fixed bin (35)),
	hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
	iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)),
	iox_$close entry (ptr, fixed bin (35)),
	iox_$control entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$detach_iocb entry (ptr, fixed bin (35)),
	iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
	iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));

/* external static */

dcl	(error_table_$badopt,
	error_table_$tape_error,
	error_table_$too_many_files,
	error_table_$noarg,
	error_table_$long_record,
	error_table_$end_of_info) fixed bin (35) external static;

/* internal static */

dcl	my_name char (16) aligned internal static initial ("read_tsoapl_tape") options (constant);
dcl	TPMXL fixed bin init (10000) static options (constant);

/* include files */

%include apl_characters;
%include iox_modes;

/* program */

	input_iocb_ptr = null;
	ws_ptr = null;
	dname = get_wdir_ ();
	attach_desc = "";
	fileno = 0;
	nfiles = 0;
	file_found (*) = "0"b;
	tapename = "";
	density = "1600";				/* default value */

	call cu_$arg_count (arg_count);
	if arg_count = 0
	then do;
		call com_err_ (0, my_name, "Usage: ^a tapename [filenames]", my_name);
		return;
	     end;

	do argno = 1 to arg_count;
	     call cu_$arg_ptr (argno, arg_ptr, arg_len, code);

	     if arg_string = "-atd" | arg_string = "-attach_description"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, my_name, "Attach description expected.");
			     return;
			end;

		     attach_desc = arg_string;
		end;
	     else if arg_string = "-list" | arg_string = "-ls" then listopt = "1"b;
/* busted	     else if arg_string = "-number" | arg_string = "-nb"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, my_name, "File number expected.");
			     return;
			end;

		     fileno = cv_dec_check_ (arg_string, code);
		     if code ^= 0 then do;
			call com_err_ (0, my_name, "Bad numeric arg: ^a", arg_string);
			return;
		      end;
		end;	*/
	     else if arg_string = "-den" | arg_string = "-density"
		then do;
			argno = argno + 1;
			call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
			if code ^= 0
			then do;
				call com_err_ (code, my_name, "Density value of 200, 556, 800, or 1600 expected.");
				return;
			     end;

			if arg_string ^= "200" & arg_string ^= "556" & arg_string ^= "800" & arg_string ^= "1600"
			then do;
				call com_err_ (0, my_name, "Invalid density ^a. Permissible values are 200, 556, 800, or 1600.",
				     arg_string);
				return;
			     end;

			density = arg_string;
		     end;
	     else if substr (arg_string, 1, 1) = "-" then do;
		     call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
		     return;
		end;
	     else do;
		if argno = 1 then tapename = arg_string;
		else do;
		     if nfiles >= hbound (filenames, 1) then do;
			call com_err_ (error_table_$too_many_files, my_name, "Max is ^d workspaces.", hbound (filenames, 1));
			return;
		     end;
		     nfiles = nfiles + 1;
		     filenames (nfiles) = arg_string;
		end;
		end;
	end;

	if attach_desc = "" & tapename = "" then do;
	     call com_err_ (error_table_$noarg, my_name, "Neither attach desc nor tape name given.");
	     return;
	end;

	if attach_desc = ""
	then attach_desc = "tape_nstd_ " || tapename ||  " -bk 10000"; /* 10000 is biggest tape record. */

	on cleanup call clean_up;

	call iox_$attach_ioname ("apl_tape_input_", input_iocb_ptr, (attach_desc), code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Trying to attach I/O switch.");
		return;
	     end;

	call iox_$open (input_iocb_ptr, Sequential_input, "0"b, code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Trying to open I/O switch for sequential input.");
		call clean_up;
		return;
	     end;

	call iox_$control (input_iocb_ptr, "d" || density, null (), code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Trying to set density to ^a bpi.", density);
		call clean_up;
		return;
	     end;

	call iox_$control (input_iocb_ptr, "nine", null(), code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Trying to set nine mode.");
		call clean_up;
		return;
	     end;

	call ioa_ ("Begin processing of ^a at ^a bpi.", tapename, density);
	call skip_file;
	record_number = 0;
	ws_number = 0;
	end_of_tape = "0"b;

	do while (^end_of_tape);
	     call do_workspace;
	     if fileno > 0 then end_of_tape = "1"b;
	end;

	do i = 1 to nfiles;
	     if ^file_found (i)
	     then call com_err_ (0, my_name, "File ^a not found.", filenames (i));
	end;

	call clean_up;
	return;

abort:
	call ioa_ ("Tape reading aborted at record ^d.", record_number);

return_from_main:
	call clean_up;
	return;

do_workspace:
     procedure;

/* automatic */

declare	new_ename char (32),
	this_file_name char (32),
	this_library_number fixed bin,
	ten_digits picture "(9)z9";

/* based */

dcl	1 ws_header	aligned based (ws_ptr),
	2 pad1 (32)	bit (36),
	2 qr13stk		bit (36),
	2 qsymbot		bit (36),
	2 mx		bit (36),
	2 svi		bit (36),
	2 pad2 (21)	bit (36),
	2 library_number	bit (36),
	2 name,
	 3 len		fixed bin (8) unal,
	 3 chars		char (11) unal;

/* program */

	ws_ptr, buff_ptr = get_ws_seg ();
	call iox_$read_record (input_iocb_ptr, buff_ptr, min (remaining_bytes, TPMXL), record_length, code);
	if code ^= 0
	then if code = error_table_$end_of_info
	     then do;
		     end_of_tape = "1"b;
		     return;
		end;
	     else do;
		     call com_err_ (code, my_name, "While reading workspace header.");
		     go to abort;
		end;

	record_number = record_number + 1;

	if record_length ^= 144
	then do;
		call ioa_ ("Tape not in expected format: first record of workspace not 144 bytes long.");
		go to abort;
	     end;

	bytes_read = record_length;
	buff_offset = record_length;
	bytes_to_read = binary (pack (ws_header.mx));
	remaining_bytes = remaining_bytes - record_length;
	call fill_buffer;

	bytes_read = 0;
	buff_offset = binary (pack (ws_header.svi));
	bytes_to_read = binary (pack (ws_header.qr13stk), 22) - binary (pack (ws_header.svi), 22) + 1000;
	call fill_buffer;

	bitcount = (buff_offset + bytes_read) * 9;
	n_words = divide (bitcount + 35, 36, 24, 0);

	call apl_zcode_to_ascii_ (substr (ws_header.name.chars, 1, ws_header.name.len), this_file_name);
	this_file_name = translate (this_file_name, "dD", QDelta || QDelta_);
	this_library_number = binary (pack (ws_header.library_number));

	if substr (this_file_name, 1, 11) = "PLDIRECTORY"
	then return;				/* ignore useless APLDIRECTORY */

	ws_number = ws_number + 1;

	if nfiles > 0 then do;
	     do i = 1 to nfiles;
		if this_file_name = filenames (i) then do;
		     call list_file;
		     file_found (i) = "1"b;
		     go to yes_save_this_file;
		end;
	     end;
	     return;
	end;

	call list_file;
yes_save_this_file:
	if listopt then return;

	ten_digits = this_library_number;
	new_ename = rtrim (this_file_name) || ".lib" || ltrim (ten_digits) || ".sv.tsoapl";
	call hcs_$chname_seg (ws_ptr, ename, new_ename, code);
	if code ^= 0
	then call com_err_ (code, my_name, "Cannot rename ^a>^a to ^a", dname, ename, new_ename);

	call hcs_$truncate_seg (ws_ptr, n_words, code);
	if code ^= 0
	then call com_err_ (code, my_name, "Unable to truncate ^a>^a to ^d words.", dname, ename, n_words);

	call hcs_$set_bc_seg (ws_ptr, bitcount, code);
	if code ^= 0
	then call com_err_ (code, my_name, "Unable to set bitcount of ^a>^a to ^d.",
		dname, ename, bitcount);

	call hcs_$terminate_noname (ws_ptr, code);
	buff_ptr, ws_ptr = null ();
	return;


list_file:
	procedure;

	     call ioa_ ("^3d ^7d ^a", ws_number, this_library_number, this_file_name);

	end list_file;

     end do_workspace;

fill_buffer:
     procedure;

	buff_ptr = addr (ws_ptr -> buffer (buff_offset));
	do while (bytes_read < bytes_to_read);
	     call iox_$read_record (input_iocb_ptr, buff_ptr, min (remaining_bytes, TPMXL), record_length, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, my_name, "While reading record ^d.", record_number + 1);
		if code ^= error_table_$tape_error then go to abort;
	     end;

	     record_number = record_number + 1;		/* Successfully read another record! */
	     bytes_read = bytes_read + record_length;
	     buff_ptr = addr (buffer (record_length));	/* step over this record */
	     remaining_bytes = remaining_bytes - record_length;
	end;

	return;

     end fill_buffer;

get_ws_seg:
     procedure returns (ptr);

dcl	get_wdir_ entry () returns (char (168));
dcl	unique_chars_ entry (bit (*)) returns (char (15));

	if ws_ptr = null then do;
	     dname = get_wdir_ ();
	     ename = unique_chars_ ("0"b);
	     call hcs_$make_seg (dname, ename, "", 1010b, ws_ptr, code);
	     if ws_ptr = null
	     then do;
		call com_err_ (code, my_name, "Cannot create ^a>^a", dname, ename);
		go to return_from_main;
	     end;
	end;

	call hcs_$truncate_seg (ws_ptr, 0, code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Unable to zero-truncate ^a>^a", dname, ename);
		go to return_from_main;
	     end;

	remaining_bytes = 1044480;
	return (ws_ptr);

     end get_ws_seg;

pack:
	procedure (aplsv_word) returns (bit (36) aligned);

/* parameters */

dcl	aplsv_word bit (36) aligned;

/* automatic */

dcl	word bit (36) aligned;

/* program */

	word = ""b;
	substr (word, 5, 8) = substr (aplsv_word, 2, 8);
	substr (word, 13, 8) = substr (aplsv_word, 11, 8);
	substr (word, 21, 8) = substr (aplsv_word, 20, 8);
	substr (word, 29, 8) = substr (aplsv_word, 29, 8);
	return (word);

     end pack;

clean_up:
     procedure;

	if ws_ptr ^= null
	then do;
		call hcs_$delentry_seg (ws_ptr, code);
		ws_ptr = null;
	     end;
	call iox_$close (input_iocb_ptr, code);
	call iox_$detach_iocb (input_iocb_ptr, code);

     end;



skip_file: proc;

dcl  tbuf char (4) aligned;

	code = error_table_$end_of_info - 1;
	do while (code ^= error_table_$end_of_info);
	     call iox_$read_record (input_iocb_ptr, addr (tbuf), 4, (0), code);
	     if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$long_record then do;
		call com_err_ (code, my_name, "Error during file spacing.");
		go to return_from_main;
	     end;
	end;

     end skip_file;

     end;






		    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
