



		    apl_display_bead.pl1            08/12/81  2117.9r   08/08/81  1558.8       89838



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

/* Utility command for Version 2 APL.
   Dumps APL beads in a useful form.
   Written by Dave Moon.
   Modified 790316 by PG to change name and make minor changes.
*/

apl_display_bead:
adb:
     procedure options (variable);

/* parameter */

dcl	(
	p_bead_ptr	ptr,
	p_brief_mode	bit (1) aligned
	)		parameter;

/* automatic */

dcl	arg_len		fixed bin (21),
	arg_ptr		ptr,
	brief		bit (1) aligned,
	code		fixed bin (35),
	command		bit (1) aligned,
	data_elements	fixed bin (21),
	n_args		fixed bin,
	p2b		ptr,
	tp		ptr,
	vcs		char (100),
	n		fixed bin;

/* based */

dcl	arg_string	char (arg_len) based (arg_ptr);

/* builtins */

dcl	(fixed, null, rel, string, substr, unspec)
			builtin;

/* entries */

dcl	cu_$arg_count	entry (fixed bin),
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	cv_ptr_		entry (char (*), fixed bin (35)) returns (ptr),
	cv_ptr_$terminate	entry (ptr),
	(ioa_, com_err_)	entry options (variable);

/* external static */

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

/* internal static */

dcl	function_classes	(0:4) char (8) int static options (constant)
			init ("normal", "locked", "ext zfn", "ext mfn", "ext dfn");

/* include files */

%include apl_number_data;
%include apl_bead_format;
%include apl_value_bead;
%include apl_symbol_bead;
%include apl_group_bead;
%include apl_operator_bead;
%include apl_function_bead;
%include apl_lexed_function_bead;
%include apl_list_bead;
%include apl_ws_info;

/* program */

	call cu_$arg_count (n_args);

	if (n_args = 0) | (n_args > 2)
	then do;
		call com_err_ (error_table_$noarg, "apl_display_bead", "Usage: adb virtual_ptr {-brief|-bf}");
		return;
	     end;

	brief = "0"b;

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

	p2b = cv_ptr_ (arg_string, code);
	if code ^= 0
	then do;
		call com_err_ (code, "apl_display_bead", "^a", arg_string);
		return;
	     end;

	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code = 0
	then if arg_string = "-bf" | arg_string = "-brief"
	     then brief = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, "apl_display_bead", "^a", arg_string);
		     return;
		end;

	command = "1"b;
	go to rejoinder;

apl_display_bead_:
     entry (p_bead_ptr, p_brief_mode);

	p2b = p_bead_ptr;
	brief = p_brief_mode;
	command = "0"b;

rejoinder:
	if p2b = null ()
	then do;
		call ioa_ ("pointer is null.");
		return;
	     end;

	if p2b -> general_bead.type.symbol
	then call ioa_ (
		"symbol bead ^p, reference_count = ^d, size = ^dd = ^oo^/^-named ^a^/^-hash link ^p^/^-meaning ^p^/", p2b,
		p2b -> general_bead.reference_count, fixed (p2b -> general_bead.size, 18),
		fixed (p2b -> general_bead.size, 18), /*once in decimal, once in octal */ p2b -> symbol_bead.name,
		p2b -> symbol_bead.hash_link_pointer, p2b -> symbol_bead.meaning_pointer);

	else if p2b -> general_bead.type.group
	then do;
		call ioa_ ("group bead ^p, reference_count = ^d, size = ^dd = ^oo^/^-with ^d members:", p2b,
		     p2b -> general_bead.reference_count, fixed (p2b -> general_bead.size, 18),
		     fixed (p2b -> general_bead.size, 18), p2b -> group_bead.number_of_members);
		do n = 1 to p2b -> group_bead.number_of_members;
		     call ioa_ ("^2-^p", p2b -> group_bead.member (n));
		end;
		call ioa_ ("");
	     end;

	else if p2b -> general_bead.type.operator
	then call ioa_ (
		"operator bead ^p^/^-bits_for_lex = ^o, bits_for_parse = ^o, op = ^dd, op2 = ^dd, type_code = ^dd^/", p2b,
		fixed (string (p2b -> operator_bead.bits_for_lex), 18),
		fixed (substr (unspec (p2b -> operator_bead.bits_for_parse), 1, 18), 18),
		fixed (p2b -> operator_bead.op1, 9), fixed (p2b -> operator_bead.op2, 9), p2b -> operator_bead.type_code);

	else if p2b -> general_bead.type.value
	then do;
		if p2b -> general_bead.type.list_value
		then vcs = "list";
		else if p2b -> general_bead.type.character_value
		then vcs = "character";
		else if p2b -> general_bead.type.zero_or_one_value
		then vcs = "0 or 1";
		else if p2b -> general_bead.type.integral_value
		then vcs = "integral";
		else if p2b -> general_bead.type.numeric_value
		then vcs = "numeric";
		else vcs = "??? no value_type bits on ???";
		if p2b -> general_bead.type.label
		then vcs = "(label) " || vcs;

		call ioa_
		     (
		     "value bead ^p, reference_count = ^d, size = ^dd = ^oo^/^-data_type = ^a^/^-total_data_elements = ^d, rhorho = ^d, data_pointer = ^p"
		     , p2b, p2b -> general_bead.reference_count, fixed (p2b -> general_bead.size, 18),
		     fixed (p2b -> general_bead.size, 18), vcs, p2b -> value_bead.total_data_elements,
		     p2b -> value_bead.rhorho, p2b -> value_bead.data_pointer);
		if p2b -> value_bead.rhorho ^= 0
		then do;
			call ioa_ ("^-rho vector:");
			do n = 1 to p2b -> value_bead.rhorho;
			     call ioa_ ("^2-^d", p2b -> value_bead.rho (n));
			end;
		     end;

		call check_ptr_alignment (p2b, "value_bead ptr");

		if p2b -> value_bead.numeric_value
		then call check_ptr_alignment ((p2b -> value_bead.data_pointer), "value_bead.data_pointer");

/* now display the actual values (ugh) */

		if ^brief & (p2b -> value_bead.total_data_elements > 0)
		then do;
			call ioa_ ("^-values:");
			data_elements = p2b -> value_bead.total_data_elements;

			if p2b -> value_bead.numeric_value
			then do n = 1 to data_elements;
				call ioa_ ("^2-^e", p2b -> value_bead.data_pointer -> numeric_datum (n - 1));
			     end;
			else call ioa_ ("^a", p2b -> value_bead.data_pointer -> character_string_overlay);
		     end;
		call display_value_stack_ptr;
	     end;
	else if p2b -> general_bead.type.lexed_function
	then do;
		call ioa_ ("lexed function bead ^p, reference_count = ^d, size = ^dd = ^oo", p2b,
		     p2b -> general_bead.reference_count, fixed (p2b -> general_bead.size, 18),
		     fixed (p2b -> general_bead.size, 18));
		call ioa_ ("^5xname = ^p, bits_for_parse = ^w", p2b -> lexed_function_bead.name,
		     unspec (p2b -> lexed_function_bead.bits_for_parse));
		call ioa_ ("^5xstmts = ^d, locals = ^d, labels = ^d", p2b -> lexed_function_bead.number_of_statements,
		     p2b -> lexed_function_bead.number_of_localized_symbols, p2b -> lexed_function_bead.number_of_labels);
		call ioa_ ("^5xlabel_values_ptr = ^p^/^5xstatement_map_ptr =^p^/^5xlexeme_array_ptr = ^p",
		     p2b -> lexed_function_bead.label_values_ptr, p2b -> lexed_function_bead.statement_map_ptr,
		     p2b -> lexed_function_bead.lexeme_array_ptr);
		call ioa_ ("^5xlocalized symbols:");
		do n = 1 to p2b -> lexed_function_bead.number_of_localized_symbols;
		     tp = p2b -> lexed_function_bead.localized_symbols (n);
		     if tp = null
		     then call ioa_ ("^-null");
		     else if tp -> general_bead.symbol
			then call ioa_ ("^-^10p ^a", tp, tp -> symbol_bead.name);
			else call ioa_ ("^-^10p op1 = ^d (system var)", tp, tp -> operator_bead.op1);
		end;
		call ioa_ ("^5xlabel values:");
		do n = 1 to p2b -> lexed_function_bead.number_of_labels;
		     call ioa_ ("^-^p", p2b -> lexed_function_bead.label_values (n));
		end;
		call ioa_ ("^5xstatement map:");
		do n = 1 to p2b -> lexed_function_bead.number_of_statements;
		     call ioa_ ("^-^d^-^d", n, p2b -> lexed_function_bead.statement_map (n));
		end;
		if ^brief
		then do;
			call ioa_ ("^5xlexeme array:");
			do n = 1
			     to p2b
			     -> lexed_function_bead.statement_map (p2b -> lexed_function_bead.number_of_statements);
			     call ioa_ ("^-^d^-^p", n, p2b -> lexed_function_bead.lexeme_array (n));
			end;
		     end;
		call ioa_ ("end of lexed_function_bead ^p", p2b);
	     end;
	else if p2b -> general_bead.type.function
	then call ioa_
		(
		"function bead ^p, reference_count = ^d, size = ^dd = ^oo,^/^-l-f-b-p = ^p, class = ^a, stop_control = ^p, trace_control = ^p, text_length = ^d, text:^/^a^/"
		, p2b, p2b -> function_bead.reference_count, fixed (p2b -> function_bead.size, 18),
		fixed (p2b -> function_bead.size, 18), p2b -> function_bead.lexed_function_bead_pointer,
		function_classes (p2b -> function_bead.class), p2b -> function_bead.stop_control_pointer,
		p2b -> function_bead.trace_control_pointer, p2b -> function_bead.text_length, p2b -> function_bead.text);

	else if p2b -> general_bead.type.list_value
	then do;
		call ioa_ ("list bead ^p, reference_count = ^d, size = ^dd = ^oo^/^d members:^2/", p2b,
		     p2b -> general_bead.reference_count, fixed (p2b -> general_bead.size, 18),
		     fixed (p2b -> general_bead.size, 18), p2b -> list_bead.number_of_members);
		do n = 1 to p2b -> list_bead.number_of_members;
		     call ioa_ ("^-member #^d at ^p, bits = ^w", n, p2b -> list_bead.member_ptr (n),
			p2b -> list_bead.bits (n));
		     call apl_display_bead_ ((p2b -> list_bead.member_ptr (n)), (brief));
		end;
		call ioa_ ("^/end list bead ^p^2/", p2b);
		call display_value_stack_ptr;
	     end;

	else call ioa_ ("some random bead ^p, type field = ^o, reference_count = ^d, size = ^dd = ^oo", p2b,
		fixed (string (p2b -> general_bead.type), 18), p2b -> general_bead.reference_count,
		fixed (p2b -> general_bead.size, 18), fixed (p2b -> general_bead.size, 18));

	if command
	then call cv_ptr_$terminate (p2b);

	return;

check_ptr_alignment:
     procedure (p_ptr, p_msg);

dcl	(
	p_ptr		ptr,
	p_msg		char (*)
	)		parameter;

/* program */

	if substr (rel (p_ptr), 18, 1)
	then call ioa_ ("^a (^p) is not even-word aligned!", p_msg, p_ptr);

     end /* check_ptr_alignment */;

display_value_stack_ptr:
     procedure;

	if ws_info_ptr ^= null
	then call ioa_ ("ws_info.value_stack_ptr = ^p", ws_info.value_stack_ptr);

     end;

     end;




		    apl_display_map.pl1             08/12/81  2117.9r   08/08/81  1558.8       34371



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

apl_display_map:
adm:
     procedure;

/* This program dumps out the apl storage system data. */

/* Written 750905 by PG to track down hideous re-used storage bug */
/* Modified 790327 by PG to rename from apl_dump_map, and to print more info */

/* automatic */

declare	global_storage_system_data_pointer
			ptr,
	segx		fixed bin;

/* builtins */

declare	(binary, divide, hbound, lbound, mod, null, string, unspec)
			builtin;

/* entries */

declare	com_err_		entry options (variable),
	ioa_		entry options (variable);

/* internal static */

declare	(
	my_name		char (15) initial ("apl_display_map"),
	type_names	dim (4) char (12) varying initial ("available", "value stack", "little seg", "big seg")
	)		internal static options (constant);

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_storage_system_data;

/* program */

	if ws_info_ptr = null
	then do;
		call com_err_ (0, my_name, "No active workspace.");
		return;
	     end;
	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	call ioa_ ("storage map at ^p, size = ^d", global_storage_system_data_pointer, binary (rel (last_map), 18));
	call ioa_ ("last_map = ^p", global_storage_system_data.last_map);
	call ioa_ ("cur_little_seg = ^d", current_little_bead_seg);
	call ioa_ ("cur_little_scan = ^d", current_little_scan_pos);
	call ioa_ ("cur_big_seg = ^d", current_big_bead_seg);
	call ioa_ ("cur_big_scan = ^d", current_big_scan_pos);

	do segx = lbound (seg_list, 1) to hbound (seg_list, 1);
	     if seg_list (segx).usage > 0
	     then call dump_map (segx);
	end;

	return;

dump_map:
     procedure (bv_seg_index);

/* parameters */

declare	bv_seg_index	fixed bin;

/* automatic */

declare	(fatherx, mapx, segx, type)
			fixed bin;
declare	message		char (16);

/* program */

	segx = bv_seg_index;
	type = seg_list.usage (segx);

	if (type = 1) | (type = 2)
	then do;
		call ioa_ ("^/map ^2d for ^p, ^a", segx, seg_list.pointer (segx), type_names (type));
		return;
	     end;

	seg_map_p = seg_list.pointer (segx);

	call ioa_ ("^/map ^2d for ^p, ^a", segx, seg_map.seg_ptr, type_names (type));
	call ioa_ ("map_ptr = ^p^/smallest_piece = ^d", seg_map_p, seg_map.smallest_piece);
	call ioa_ ("num_entries = ^d^/last_entry = ^d", seg_map.number_of_entries, seg_map.last_entry_used);
	call ioa_ ("amount_used = ^d^/words_free = ^d", seg_map.amount_of_seg_used, seg_list (segx).words_free);

	do mapx = lbound (seg_map.map, 1) to seg_map.last_entry_used;
	     if string (map (mapx)) ^= ""b
	     then do;				/* check that this entry is in proper relation to dad */
		     message = "";			/* assume all ok */
		     fatherx = divide (mapx, 2, 17, 0);
		     if (fatherx ^= mapx) & (fatherx ^= 0)
		     then do;
			     if string (map (fatherx)) = ""b
						/* not good...tree is unconnected... */
			     then message = "no father";
			     else if mod (mapx, 2) = 1/* mapx ODD means it is RIGHT son */
			     then if map.rel_loc (fatherx) ^< map.rel_loc (mapx)
				then message = "father ^< son";
						/* dum da dum dum */
				else ;
			     else if map.rel_loc (fatherx) ^> map.rel_loc (mapx)
			     then message = "father ^> son";
			     else ;

			end;
		     call ioa_ ("^3d ^6o ^6o ^a", mapx, binary (map.size (mapx)), binary (map.rel_loc (mapx)), message);
		end;
	end;

     end;

     end /* apl_display_map */;




		    apl_display_saved_ws.pl1        08/12/81  2117.9r   08/08/81  1558.8       95148



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

/* Program to symbolically dump a saved Version 2 APL workspace. */
/* PG 740126
   Modified 740626 by PG to print bead info.
   Modified 741031 by PG to print stack info.
   Modified 750404 b y PG to correctly print value beads
   Modified 771003 by PG to change program name and print a little more info
   Modified 790328 by PG to use iox_ and clock builtin.
*/

apl_display_saved_ws:
adsw:
     procedure;

/* entries */

declare	(ioa_, ioa_$nnl)	entry options (variable),
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (20), fixed bin (35)),
	com_err_		entry options (variable),
	date_time_	entry (fixed bin (71), char (*)),
	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)),
	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* automatic */

declare	argument_pointer	ptr,
	argument_length	fixed bin (20),
	bead_index	fixed bin,
	code		fixed bin (35),
	data_elements	fixed bin (21),
	directory_name	char (168),
	entry_name	char (32),
	bitcount		fixed bin (24),
	date_string	char (24),
	ws_ptr		(0:63) ptr aligned,
	n		fixed bin (21),
	p		ptr;

/* external static */

declare	iox_$user_output	ptr external static;

/* internal static initial */

declare	my_name		char (20) internal static options (constant) initial ("apl_display_saved_ws");
declare	value_name	(0:5) char (9) internal static
			initial ("Unknown", "Boolean", "Integral", "Numeric", "Character", "List");
declare	frame_name	(5) char (10) aligned internal static options (constant)
			initial ("SUSPENDED", "FUNCTION", "EVALUATED", "EXECUTE", "SAVE");
declare	save_frame_type	fixed bin internal static initial (5);

/* based */

declare	argument		char (argument_length) based (argument_pointer),
	based_fixed_bin	fixed bin based,
	varying_string	char (n) varying based;

/* builtins */

declare	(addr, addrel, baseno, clock, divide, fixed, hbound, index, lbound, length, min, null, pointer, ptr, rel, reverse,
	string)		builtin;

/* include files */

%include apl_number_data;
%include apl_bead_format;
%include apl_value_bead;
%include apl_symbol_bead;
%include apl_operator_bead;
%include apl_ws_info;
%include apl_saved_ws;

	call cu_$arg_ptr (1, argument_pointer, argument_length, code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "Usage: ^a pathname", my_name);
		return;
	     end;

	call expand_pathname_$add_suffix (argument, "sv.apl", directory_name, entry_name, code);
	if code ^= 0
	then do;
		call com_err_ (code, my_name, "^a", argument);
		return;
	     end;

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

	ws_ptr (0) = saved_ws_info_pointer;

	call date_time_ (clock (), date_string);

	call ioa_ ("^/^-^a>^a^-^a^/", directory_name, entry_name, date_string);

	call date_time_ (saved_ws_info.time_saved, date_string);

	call ioa_ ("workspace:^-^a^/saved by:^2-^a^/saved on:^2-^a^/lock:^2-^a^/user number:^-^5d", saved_ws_info.wsid,
	     saved_ws_info.user_name, date_string, saved_ws_info.lock, saved_ws_info.user_number);

	call ioa_ ("version:^2-^5d^/components:^-^5d^/size in words:^-^5d", saved_ws_info.save_version,
	     saved_ws_info.highest_segment + 1, divide (bitcount + 35, 36, 24, 0));

	call ioa_ ("digits:^2-^5d^/width:^2-^5d^/origin:^2-^5d^/float_origin:^-^e^/link:^-^15d^/fuzz:^2-^e",
	     saved_ws_info.digits, saved_ws_info.width, saved_ws_info.index_origin, saved_ws_info.float_index_origin,
	     saved_ws_info.random_link, saved_ws_info.fuzz);

	call ioa_ ("integer fuzz:^-^e", saved_ws_info.integer_fuzz);

	call ioa_ ("latent expression:^-bead ^d", saved_ws_info.latent_expression);

	call ioa_ ("number of symbols:^-^5d^/number of beads:^-^5d", saved_ws_info.number_of_symbols,
	     saved_ws_info.total_beads);

/* print bead information */

	saved_bead_count = saved_ws_info.total_beads;
	bead_description_pointer = pointer (saved_ws_info_pointer, rel (saved_ws_info.bead_table_pointer));

	do bead_index = lbound (bead_description_table (*), 1) to hbound (bead_description_table (*), 1);
	     call display_bead (bead_index, bead_pointer (bead_index));
	end;

/* print stack information */

	do saved_frame_pointer = un_pseudo_pointer (saved_ws_info.current_parse_frame_ptr)
	     repeat un_pseudo_pointer (saved_pf.last_parse_frame_ptr) while (saved_frame_pointer ^= null);
	     call ioa_ ("^/^a FRAME at ^6.3b", frame_name (saved_pf.parse_frame_type), rel (saved_frame_pointer));

	     if saved_pf.parse_frame_type = save_frame_type
	     then do;
		     call ioa_ ("saved_symbol_count = ^d", saved_sf.saved_symbol_count);
		     call ioa_ ("Symbol  Meaning");
		     do bead_index = lbound (saved_sf.symbol_list, 1) to hbound (saved_sf.symbol_list, 1);
			call ioa_ ("^6d^3x^6d", saved_sf.symbol_list (bead_index).symbol_pointer,
			     saved_sf.symbol_list (bead_index).saved_meaning_pointer);
		     end;
		     go to frame_type (5);
		end;

	     call ioa_ ("function_bead_ptr = ^d", saved_pf.function_bead_ptr);
	     call ioa_ ("current_parseme = ^d", saved_pf.current_parseme);
	     call ioa_ ("current_lexeme = ^d", saved_pf.current_lexeme);
	     call ioa_ ("current_line_number = ^d", saved_pf.current_line_number);
	     call ioa_ ("return_point = ^d", saved_pf.return_point);
	     call ioa_ ("put_result = ^d", saved_pf.put_result);
	     call ioa_ ("print_final_value = ""^1b""b", saved_pf.print_final_value);

	     go to frame_type (saved_pf.parse_frame_type);

frame_type (1):					/* suspended frame */
frame_type (3):					/* evaluated frame */
	     if saved_ws_info.save_version = 3
	     then p = addr (v3_saved_pf.old_meaning_ptrs (1));
	     else p = addr (saved_pf.old_meaning_ptrs (1));

	     n = length (p -> varying_string);
	     call ioa_ ("re-lex source = ""^1b""b", saved_pf.re_lex_source);
	     call ioa_ ("Source: ^a", p -> varying_string);
	     go to end_loop;

frame_type (2):					/* function frame */
	     if saved_ws_info.save_version > 3
	     then do;				/* can print old meanings */
		     call ioa_ ("number_of_ptrs = ^d", saved_pf.number_of_ptrs);
		     do bead_index = 1 to saved_pf.number_of_ptrs;
			call ioa_ ("old(^d) = ^d", bead_index, saved_pf.old_meaning_ptrs (bead_index));
		     end;
		end;
	     go to end_loop;

frame_type (4):					/* execute frame */
	     go to end_loop;

frame_type (5):					/* save frame */
	     go to end_loop;

end_loop:
	end;

	call hcs_$terminate_noname (saved_ws_info_pointer, code);

	return;

un_pseudo_pointer:
     procedure (bv_pseudo_pointer) returns (ptr);

/* parameters */

declare	bv_pseudo_pointer	ptr unaligned;

/* program */

	if bv_pseudo_pointer = null
	then return (null);
	else return (addrel (ws_ptr (fixed (baseno (bv_pseudo_pointer), 18, 0)), rel (bv_pseudo_pointer)));

     end un_pseudo_pointer;

display_bead:
     procedure (bv_bead_index, bv_bead_pointer);

/* parameters */

declare	(
	bv_bead_index	fixed bin,
	bv_bead_pointer	ptr unaligned
	)		parameter;

/* automatic */

declare	i		fixed bin,
	more		bit (1) aligned,
	p		ptr;

/* program */

	saved_bead_pointer = un_pseudo_pointer (bv_bead_pointer);

	call ioa_ ("^/BEAD ^d at ^6.3b, size = ^dd, ^oo", bv_bead_index, rel (bv_bead_pointer),
	     fixed (saved_general_bead.size), fixed (saved_general_bead.size));

	go to type (index (string (saved_general_bead.bead_type), "1"b));

type (0):
type (1):						/* operator */
type (6):						/* label */
type (7):						/* shared variable */
type (8):						/* lexed function */
	call ioa_ ("Impossible type! header = ^w", saved_bead_pointer -> based_fixed_bin);
	return;

type (2):						/* symbol */
	call ioa_ ("Symbol '^a'", saved_sb.name);

	if saved_sb.meaning_pointer ^= 0
	then call ioa_ ("meaning is bead ^d", saved_sb.meaning_pointer);

	return;

type (3):						/* value */
	data_elements = saved_value_bead.total_data_elements;
	i = index (reverse (string (saved_value_bead.data_type)), "1"b);
	call ioa_ ("^a value: total_data_elements = ^d, rhorho = ^d, data_pointer = ^w", (value_name (i)), data_elements,
	     saved_value_bead.rhorho, saved_value_bead.data_pointer);

	if saved_value_bead.rhorho > 0
	then do i = 0 by 1 while (i < saved_value_bead.rhorho);
		call ioa_ ("rho(^d) = ^d", i + 1, saved_value_bead.rho (i + 1));
	     end;

	if data_elements = 0
	then return;

	p = ptr (saved_bead_pointer, rel (saved_value_bead.data_pointer));

	more = "0"b;

	if saved_value_bead.character_value
	then do;
		call iox_$put_chars (iox_$user_output, p, min (70, data_elements), code);
		call ioa_ ("");
		if data_elements > 70
		then more = "1"b;
	     end;
	else if saved_value_bead.zero_or_one_value
	then do;
		if data_elements > 70
		then do;
			data_elements = 70;
			more = "1"b;
		     end;

		call ioa_ ("""^vb""b", data_elements, p -> saved_boolean_datum);
	     end;
	else do;
		if data_elements > 4
		then do;
			data_elements = 4;
			more = "1"b;
		     end;

		do i = 0 by 1 while (i < data_elements);
		     call ioa_ ("^19e", p -> numeric_datum (i));
		end;
	     end;

	if more
	then call ioa_ ("(more)");

	return;

type (4):						/* function */
	call ioa_ ("Function: class = ^d, text_length = ^d", saved_fb.class, saved_fb.text_length);

	if saved_fb.stop_control_pointer ^= 0
	then call ioa_ ("stop control is bead ^d", saved_fb.stop_control_pointer);

	if saved_fb.trace_control_pointer ^= 0
	then call ioa_ ("trace control is bead ^d", saved_fb.trace_control_pointer);

	call ioa_$nnl ("text = ");
	call iox_$put_chars (iox_$user_output, addr (saved_fb.text), length (saved_fb.text), code);

	return;

type (5):						/* group */
	call ioa_ ("Group of ^d members", saved_gb.number_of_members);

	do i = 0 by 1 while (i < saved_gb.number_of_members);
	     call ioa_ ("member(^d) = bead ^d", i + 1, saved_gb.member (i + 1));
	end;

	return;

     end /* display_bead */;

     end /* apl_display_saved_ws */;




		    apl_display_si.pl1              08/12/81  2117.9r   08/08/81  1558.8       41148



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

apl_display_si:
adsi:
     procedure;

/* builtins */

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

/* entries */

dcl	ioa_		entry options (variable);

/* automatic */

declare	(p, parse_frame_ptr, rsp)
			ptr;
declare	local		fixed bin;
declare	(i, symbol_number)	fixed bin;
declare	n		fixed bin (21);
declare	rs_type		fixed bin;

/* named constants (internal static initial) */

declare	(
	frame_names	dimension (5) char (12) varying
			initial ("suspended", "function", "evaluated", "execute", "save"),
	rs_type_name	dimension (0:11) char (4)
			initial ("eol", "bol", "val", "op", "(", ")", "[", "]sb", "]rk", "", "sub", "bad")
	)		internal static options (constant);

/* based */

declare	varying_string	char (n) varying based;

/* program */

	do parse_frame_ptr = ws_info.current_parse_frame_ptr repeat parse_frame.last_parse_frame_ptr
	     while (parse_frame_ptr ^= null);

	     call ioa_ ("^a frame at ^p", frame_names (parse_frame.parse_frame_type), parse_frame_ptr);

	     go to frame_type (parse_frame.parse_frame_type);

frame_type (1):					/* suspended */
frame_type (2):					/* function */
frame_type (3):					/* evaluated */
frame_type (4):					/* execute */
	     call ioa_ ("fbp = ^p", parse_frame.function_bead_ptr);

	     if parse_frame.lexed_function_bead_ptr ^= null
	     then call ioa_ ("lfbp = ^p", parse_frame.lexed_function_bead_ptr);

	     rsp = parse_frame.reduction_stack_ptr;

	     call ioa_ ("rsp = ^p", rsp);

	     if parse_frame.current_parseme ^= 0
	     then do;
		     do i = 1 to parse_frame.current_parseme;
			if rsp -> reduction_stack (i).type < lbound (rs_type_name (*), 1)
			     | rsp -> reduction_stack (i).type > hbound (rs_type_name (*), 1)
			then rs_type = hbound (rs_type_name (*), 1);
			else rs_type = rsp -> reduction_stack (i).type;

			call ioa_ ("rs(^d) = ^d ^4a ^w ^w ^w", i, rsp -> reduction_stack (i).type,
			     rs_type_name (rs_type), rsp -> reduction_stack (i).bits,
			     rsp -> reduction_stack (i).semantics, rsp -> reduction_stack (i).lexeme);
		     end;
		end;

	     if parse_frame.current_lexeme ^= 0
	     then call ioa_ ("current lexeme = ^d", parse_frame.current_lexeme);

	     if parse_frame.current_line_number ^= 0
	     then call ioa_ ("current line = ^d", parse_frame.current_line_number);

	     call ioa_ ("return point = ^d", parse_frame.return_point);

	     if parse_frame.put_result ^= 0
	     then call ioa_ ("put result = ^d", parse_frame.put_result);

	     if parse_frame.print_final_value
	     then call ioa_ ("print final value");

	     call ioa_ ("ivsp = ^p", parse_frame.initial_value_stack_ptr);

	     go to sub_type (parse_frame.parse_frame_type);

sub_type (1):					/* suspended */
sub_type (3):					/* evaluated */
	     p = addr (parse_frame.old_meaning_ptrs (1));
	     n = length (p -> varying_string);
	     call ioa_ ("source = ^a", p -> varying_string);
	     go to end_loop;

sub_type (2):					/* function */
	     do local = 1 to parse_frame.number_of_ptrs;
		call ioa_ ("old(^d) = ^p", local, parse_frame.old_meaning_ptrs (local));
	     end;
	     go to end_loop;

sub_type (4):					/* execute */
	     go to end_loop;

frame_type (5):					/* save frame */
	     save_frame_pointer = parse_frame_ptr;

	     call ioa_ ("symbol count = ^d", save_frame.saved_symbol_count);

	     do symbol_number = lbound (save_frame.symbol_list (*), 1) to hbound (save_frame.symbol_list (*), 1);
		call ioa_ ("symbol(^d):", symbol_number);
		call ioa_ ("sp = ^p", save_frame.symbol_list (symbol_number).symbol_pointer);
		call ioa_ ("mp = ^p", save_frame.symbol_list (symbol_number).saved_meaning_pointer);
		call ioa_ ("gmpp = ^p", save_frame.symbol_list (symbol_number).global_meaning_pointer_pointer);
	     end;

end_loop:
	     call ioa_ ("");
	end;

/* include files */

%include apl_number_data;
%include apl_bead_format;
%include apl_function_bead;
%include apl_list_bead;
%include apl_operator_bead;
%include apl_operators_argument;
%include apl_parse_frame;
%include apl_save_frame;
%include apl_symbol_bead;
%include apl_value_bead;
%include apl_ws_info;
     end /* apl_display_si */;




		    apl_display_symbol.pl1          08/12/81  2117.9r   08/08/81  1558.8       22023



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

apl_display_symbol:
ads:
     procedure options (variable);

	call cu_$arg_ptr (1, arg_ptr, arg_length, code);
	if code ^= 0
	then do;
		call com_err_ (code, "apl_display_symbol", "Usage: ads symbol_name");
		return;
	     end;

	call apl_get_symbol_ (arg_string, symbol_bead_ptr, hash_link);

/* In order to be transparent, we must decrement the reference count....since
   apl_get_symbol_ auto-increments it for us! */

	symbol_bead_ptr -> symbol_bead.reference_count = symbol_bead_ptr -> symbol_bead.reference_count - 1;

	brief = "0"b;
	call cu_$arg_ptr (2, arg_ptr, arg_length, code);
	if code = 0
	then if arg_string = "-bf" | arg_string = "-brief"
	     then brief = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, "apl_display_symbol", "Only control arg is -brief(-bf)");
		     return;
		end;

	call apl_display_bead_ ((symbol_bead_ptr), brief);

	if symbol_bead_ptr -> symbol_bead.meaning_pointer ^= null ()
	then do;
		call ioa_ ("Meaning:");
		call apl_display_bead_ ((symbol_bead_ptr -> symbol_bead.meaning_pointer), brief);
	     end;

	return;

/* entries */

declare	com_err_		entry options (variable);
declare	ioa_		entry options (variable);
declare	apl_get_symbol_	entry (char (*), pointer unaligned, fixed bin);
declare	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
declare	apl_display_bead_	entry (pointer, bit (1) aligned);

/* external static */

declare	error_table_$badopt fixed bin (35) external static;

/* builtin */

declare	(hbound, lbound, null)
			builtin;

/* automatic */

declare	arg_length	fixed bin (21),
	arg_ptr		ptr,
	brief		bit (1) aligned,
	bucket_index	fixed bin,
	code		fixed bin (35),
	hash_link		fixed bin,
	symbol_bead_ptr	pointer unaligned;

/* based */

declare	arg_string	char (arg_length) based (arg_ptr);

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_symbol_table;
%include apl_symbol_bead;
     end /* apl_display_symbol */;




		    apl_display_symtab.pl1          08/12/81  2117.9r   08/08/81  1558.8       24858



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

/* Modified 790328 by PG to let ioa_ line up the pointers, now that ^10p works. */
/* Modified 790705 by PG to fix bug in ioa_ format */

apl_display_symtab:
adst:
     procedure;

/* automatic */

dcl	arg_len		fixed bin (21);
dcl	arg_ptr		ptr;
dcl	brief		bit (1) aligned;
dcl	code		fixed bin (35);
dcl	flag		char (1);
dcl	meaning_ptr	ptr unal;
dcl	meaning_reference_count
			fixed bin (29);
dcl	symbol_bead_ptr	ptr unaligned;
dcl	(bucket_index, index_within_bucket)
			fixed bin;

/* based */

dcl	arg_string	char (arg_len) based (arg_ptr);

/* builtins */

dcl	(binary, fixed, hbound, lbound, max, null)
			builtin;

/* entries */

dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	ioa_		entry options (variable);

/* program */

	brief = "0"b;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code = 0
	then if arg_string = "-bf" | arg_string = "-brief"
	     then brief = "1"b;

	call ioa_ ("symbol table at ^p, ^d symbols", ws_info.symbol_table_ptr, ws_info.number_of_symbols);
	call ioa_ ("bucket^2xloc^xref ct^xsize^2xmeaning^2xref ct^2xname");
	do bucket_index = lbound (symbol_table.hash_bucket_ptr, 1) to hbound (symbol_table.hash_bucket_ptr, 1);
	     index_within_bucket = 1;
	     do symbol_bead_ptr = symbol_table.hash_bucket_ptr (bucket_index)
		repeat symbol_bead_ptr -> symbol_bead.hash_link_pointer while (symbol_bead_ptr ^= null);

		flag = " ";
		meaning_ptr = symbol_bead_ptr -> symbol_bead.meaning_pointer;

		if meaning_ptr ^= null
		then do;
			meaning_reference_count = meaning_ptr -> general_bead.reference_count;

			if meaning_reference_count < 1
			then flag = "*";
		     end;
		else meaning_reference_count = 0;

		if ^brief | flag = "*"
		then call ioa_ ("^2d.^d ^10p ^2d ^4o  ^[^10p  ^3d^;^2s^15x^]^1a ^a", bucket_index, index_within_bucket,
			symbol_bead_ptr, symbol_bead_ptr -> symbol_bead.reference_count,
			fixed (symbol_bead_ptr -> symbol_bead.size, 18), (meaning_ptr ^= null), meaning_ptr,
			meaning_reference_count, flag, symbol_bead_ptr -> symbol_bead.name);

		index_within_bucket = index_within_bucket + 1;
	     end;
	end;
	return;

/* include files */

%include apl_number_data;
%include apl_bead_format;
%include apl_ws_info;
%include apl_symbol_bead;
%include apl_symbol_table;
     end /* apl_display_symtab */;




		    apl_display_ws_info.pl1         08/12/81  2117.9r   08/08/81  1558.8       28305



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

/* Modified 790329 by PG to print a few more items. */
/* Modified 791013 by PG to print output_info items */

apl_display_ws_info:
adwi:
     procedure;

/* builtins */

declare	null		builtin;

/* entries */

declare	ioa_		entry options (variable);

/* include files */

%include apl_number_data;
%include apl_ws_info;

/* program */

	if ws_info_ptr = null
	then do;
		call ioa_ ("No active workspace.");
		return;
	     end;

	call ioa_ ("ws_info at ^p", ws_info_ptr);

	call ioa_ ("version_number:^-^d", ws_info.version_number);
	call print_switch ("long_error_mode", ws_info.long_error_mode);
	call print_switch ("debug_mode", ws_info.debug_mode);
	call print_switch ("canonicalize_mode", ws_info.canonicalize_mode);
	call print_switch ("transparent_mode", ws_info.transparent_to_signals);
	call print_switch ("meter_mode", ws_info.meter_mode);
	call print_switch ("compatibility_mode", ws_info.compatibility_check_mode);
	call print_switch ("no_quit_handler", ws_info.no_quit_handler);

	call ioa_ ("digits:^2-^d", ws_info.digits);
	call ioa_ ("width:^2-^d", ws_info.width);
	call ioa_ ("index_origin:^-^d", index_origin);
	call ioa_ ("random_link:^-^d", ws_info.random_link);
	call ioa_ ("fuzz:^2-^e", ws_info.fuzz);
	call ioa_ ("float_index_origin:^-^f", ws_info.float_index_origin);
	call ioa_ ("number_of_symbols:^-^d", ws_info.number_of_symbols);
	call ioa_ ("maximum_value_stack_size:^-^d", ws_info.maximum_value_stack_size);

	call ioa_ ("symbol_table_ptr:^2-^p", ws_info.symbol_table_ptr);
	call ioa_ ("current_parse_frame_ptr:^-^p", ws_info.current_parse_frame_ptr);
	call ioa_ ("value_stack_ptr:^2-^p", ws_info.value_stack_ptr);
	call ioa_ ("alloc_free_info_ptr:^-^p", ws_info.alloc_free_info_ptr);

	call ioa_ ("integer_fuzz:^-^f", ws_info.integer_fuzz);
	call ioa_ ("user_number:^-^d", ws_info.user_number);
	call ioa_ ("latent_expression:^-^p", ws_info.latent_expression);
	call ioa_ ("wsid:^2-^a", ws_info.wsid);

	call ioa_ ("interrupt_info:^-^8b", string (ws_info.interrupt_info));

	call ioa_ ("output_buffer_ptr:^-^p", ws_info.output_info.output_buffer_ptr);
	call ioa_ ("output_buffer_len:^-^d", ws_info.output_info.output_buffer_len);
	call ioa_ ("output_buffer_pos:^-^d", ws_info.output_info.output_buffer_pos);
	call ioa_ ("output_buffer_ll:^-^d", ws_info.output_info.output_buffer_ll);
	call ioa_ ("tab_width:^-^d", ws_info.tab_width);
	return;

print_switch:
     procedure (bv_switch_name, bv_value);

/* parameters */

declare	(
	bv_switch_name	char (*),
	bv_value		bit (1) unaligned
	)		parameter;

/* program */

	call ioa_ ("^a:^-^[on^;off^]", bv_switch_name, bv_value);
	return;

     end print_switch;

     end /* apl_display_ws_info */;




		    apl_storage_meters.pl1          08/12/81  2117.9r   08/08/81  1559.5       63747



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

apl_storage_meters:
asm:
     procedure ();

/*
 * command to display the meters kept by apl_storage_manager_
 *
 * written 73.8.04 by DAM
 * Modified 731206 by PG for modified include file format.
 * Modified 740617 by PG to print more info.
 * Modified 750911 by PG to rename from meter_apl_storage to apl_storage_meters
 * Modified 750330 by PG to re-format output
 */




dcl	com_err_		entry options (variable),
	error_table_$badopt fixed bin (35) external,
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35)),
	argp		ptr,
	argl		fixed bin,
	code		fixed bin (35),
	arg		char (argl) based (argp),
	brief		bit (1),
	ioa_		entry options (variable);

dcl	(addr, null, divide, sum, lbound, hbound, baseno, float, unspec, fixed, rel, max)
			builtin;

/* automatic */

dcl	sli		fixed bin,
	(alloc_count, free_count)
			fixed bin,
	global_storage_system_data_pointer
			ptr,
	vst		char (1),
	end_vs		bit (1),
	sgt		char (10),
	n_map_ent		fixed bin,
	i		fixed bin,
	rangex		fixed bin,
	rx		fixed bin,
	upper		fixed bin (18),
	range_break	fixed bin;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_storage_system_data;

	if ws_info_ptr = null
	then do;
		call com_err_ (0, "apl_storage_meters", "No active workspace in this process.");
		return;
	     end;
	else if unspec (ws_info_ptr) = ""b		/* blasted type-6 links do this */
	then do;
		call com_err_ (0, "apl_storage_meters", "Search rules did not find apl_static_.");
		return;
	     end;

	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0
	then brief = "0"b;
	else if arg = "-bf"
	then brief = "1"b;
	else if arg = "-brief"
	then brief = "1"b;
	else do;
		call com_err_ (error_table_$badopt, "apl_storage_meters", "^a", arg);
		return;
	     end;

dcl	1 lrange		(range_break - 1) aligned based (addr (metric.range)) like metric.range;
dcl	1 brange		(hbound (metric.range, 1) - range_break + 1) aligned
			based (addr (metric.range (range_break))) like metric.range;


	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	if metric.big_seg_balance.count ^= 0
	then call ioa_
		(
		"big-bead seg_maps balanced ^d times, avg time = ^.3f, avg map size after = ^d,
	^d beads had to be thrown away, avg ^d words^/"
		, metric.big_seg_balance.count,
		divide (float (metric.big_seg_balance.time_spent_balancing), 1e3 * metric.big_seg_balance.count, 27),
		divide (metric.big_seg_balance.space_left, metric.big_seg_balance.count, 18, 0),
		metric.big_seg_balance.thrown_away,
		divide (metric.big_seg_balance.amt_thrown_away, max (1, metric.big_seg_balance.thrown_away), 18, 0));

	if metric.little_seg_balance.count ^= 0
	then call ioa_
		(
		"little-bead seg_maps balanced ^d times, avg time = ^.3f, avg map size after = ^d,
	^d beads had to be thrown away, avg ^d words^/"
		, metric.little_seg_balance.count,
		divide (float (metric.little_seg_balance.time_spent_balancing), 1e3 * metric.little_seg_balance.count, 27)
		, divide (metric.little_seg_balance.space_left, metric.little_seg_balance.count, 18, 0),
		metric.little_seg_balance.thrown_away,
		divide (metric.little_seg_balance.amt_thrown_away, max (1, metric.little_seg_balance.thrown_away), 18, 0))
		;

	if get_next_value_stack_seg_calls ^= 0
	then call ioa_ ("value stack crossed segments ^d times^/", get_next_value_stack_seg_calls);

	if copy_apl_value_calls ^= 0
	then call ioa_ ("^d value beads copied into heap, avg time ^.3f milliseconds per bead^/", copy_apl_value_calls,
		divide (float (copy_apl_value_time), 1e3 * copy_apl_value_calls, 27));

	if brief
	then return;

	call ioa_ (
	     "Alloc/Free Meters^/Size range    Nfreed Nmapped Avg ms Avg size Nalloc Nfm end Nnew seg Avg ms Avg size");

	do rx = lbound (metric.range, 1) to hbound (metric.range, 1);
	     upper = 2 * range (rx).size - 1;
	     if range (rx).free_count ^= 0
	     then free_count = range (rx).free_count;
	     else free_count = 1;

	     if range (rx).alloc_count ^= 0
	     then alloc_count = range (rx).alloc_count;
	     else alloc_count = 1;

	     if (range (rx).free_count ^= 0) | (range (rx).alloc_count ^= 0)
	     then call ioa_ ("^6d-^6d ^6d  ^6d ^6.3f   ^6d ^6d  ^6d   ^6d ^6.3f ^6d", range (rx).size, upper,
		     range (rx).free_count, range (rx).map_free_count, float (range (rx).free_time) / (1e3 * free_count),
		     divide (range (rx).words_freed, free_count, 18, 0), range (rx).alloc_count,
		     range (rx).alloc_end_count, range (rx).alloc_new_count,
		     float (range (rx).alloc_time) / (1e3 * alloc_count),
		     divide (range (rx).words_alloced, alloc_count, 18, 0));
	end;


	do range_break = lbound (metric.range, 1) to hbound (metric.range, 1);
	     if metric.range (range_break).size = 64	/* BreakSize in apl_storage_mngr_.pl1 */
	     then go to g0001;
	end;

g0001:
	call ioa_ ("Summaries:^/^6d-^6d ^6d  ^6d ^6.3f   ^6d ^6d  ^6d   ^6d ^6.3f ^6d", 0, 63,
	     fixed (sum (lrange.free_count), 35), sum (lrange.map_free_count),
	     divide (float (sum (lrange.free_time)), max (sum (lrange.free_count), 1) * 1e3, 27),
	     divide (sum (lrange.words_freed), max (sum (lrange.free_count), 1), 18, 0),
	     fixed (sum (lrange.alloc_count), 35), sum (lrange.alloc_end_count), sum (lrange.alloc_new_count),
	     divide (float (sum (lrange.alloc_time)), max (sum (lrange.alloc_count), 1) * 1e3, 27),
	     divide (sum (lrange.words_alloced), max (sum (lrange.alloc_count), 1), 18, 0));

	call ioa_ ("^6d-^6d ^6d  ^6d ^6.3f   ^6d ^6d  ^6d   ^6d ^6.3f ^6d", 64, 262143, fixed (sum (brange.free_count), 35),
	     sum (brange.map_free_count),
	     divide (float (sum (brange.free_time)), max (sum (brange.free_count), 1) * 1e3, 27),
	     divide (sum (brange.words_freed), max (sum (brange.free_count), 1), 18, 0),
	     fixed (sum (brange.alloc_count), 35), sum (brange.alloc_end_count), sum (brange.alloc_new_count),
	     divide (float (sum (brange.alloc_time)), max (sum (brange.alloc_count), 1) * 1e3, 27),
	     divide (sum (brange.words_alloced), max (sum (brange.alloc_count), 1), 18, 0));

	call ioa_ ("^6d-^6d ^6d  ^6d ^6.3f   ^6d ^6d  ^6d   ^6d ^6.3f ^6d", 0, 262143, fixed (sum (range.free_count), 35),
	     sum (range.map_free_count), divide (float (sum (range.free_time)), max (sum (range.free_count), 1) * 1e3, 27),
	     divide (sum (range.words_freed), max (sum (range.free_count), 1), 18, 0), fixed (sum (range.alloc_count), 35),
	     sum (range.alloc_end_count), sum (range.alloc_new_count),
	     divide (float (sum (range.alloc_time)), max (sum (range.alloc_count), 1) * 1e3, 27),
	     divide (sum (range.words_alloced), max (sum (range.alloc_count), 1), 18, 0));
						/* whew!! */

     end;




		    check_storage_manager_.pl1      08/12/81  2117.9r   08/08/81  1600.0       41958



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

/* Program to check an allocation package. */
/* PG 760312 */
/* Modified 790328 by PG to bring up to coding standards, and to put memory
   segment into the user's home dir. */

check_storage_manager_$allocate:
     procedure (bv_storage_ptr, bv_n_words);

/* parameters */

dcl	(
	bv_storage_ptr	ptr unal,
	bv_n_words	fixed bin (18)
	)		parameter;

/* automatic */

dcl	code		fixed bin (35),
	dname		char (168),
	ename		char (32),
	offset		fixed bin,
	person_id		char (22),
	project_id	char (9),
	segno		fixed bin,
	segx		fixed bin;

/* internal static */

dcl	memory_seg_ptr	ptr internal static initial (null);

/* based */

dcl	1 memory		aligned based (memory_seg_ptr),
	  2 last_memory_slot
			fixed bin,
	  2 segno		(35) fixed bin,
	  2 allocated	(35) bit (262144) unaligned;

/* entries */

dcl	com_err_		entry options (variable),
	cu_$cl		entry (),
	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
	hcs_$truncate_seg	entry (ptr, fixed bin (18), fixed bin (35)),
	ioa_		entry options (variable),
	user_info_	entry options (variable);

/* builtins */

dcl	(baseno, binary, copy, lbound, hbound, null, rel, rtrim, substr)
			builtin;

/* program */

	if memory_seg_ptr = null
	then call initialize;

	segno = binary (baseno (bv_storage_ptr), 15);
	offset = binary (rel (bv_storage_ptr), 18) + 1;	/* convert to 1-origin */

	do segx = lbound (memory.segno, 1) to last_memory_slot while (memory.segno (segx) ^= segno);
	end;

	if segx <= last_memory_slot
	then do;
		if substr (memory.allocated (segx), offset, bv_n_words) ^= ""b
		then do;
			call ioa_ ("check_storage_manager_: ^d words at ^p reuses storage", bv_n_words, bv_storage_ptr);
			call cu_$cl;
		     end;
	     end;
	else if last_memory_slot < hbound (memory.segno, 1)
	then do;
		segx, last_memory_slot = last_memory_slot + 1;
		memory.segno (segx) = segno;
	     end;
	else do;
		call ioa_ ("check_storage_manager_: no more room for memory maps");
		return;
	     end;


	substr (memory.allocated (segx), offset, bv_n_words) = copy ("1"b, bv_n_words);
	return;

free:
     entry (bv_storage_ptr, bv_n_words);

	if memory_seg_ptr = null
	then call initialize;

	segno = binary (baseno (bv_storage_ptr), 15);
	offset = binary (rel (bv_storage_ptr), 18) + 1;	/* convert to 1-origin */

	do segx = lbound (memory.segno, 1) to last_memory_slot while (memory.segno (segx) ^= segno);
	end;

	if segx > last_memory_slot
	then do;
		call ioa_ ("check_storage_manager_: no map for ^d at ^p", bv_n_words, bv_storage_ptr);
		call cu_$cl;
		return;
	     end;

	if (^substr (memory.allocated (segx), offset, bv_n_words)) ^= ""b
	then do;
		call ioa_ ("check_storage_manager_: not all words allocated at free time: ^d at ^p", bv_n_words,
		     bv_storage_ptr);
		call ioa_ ("pattern is ^b", substr (memory.allocated (segx), offset, bv_n_words));
		call cu_$cl;
	     end;

	substr (memory.allocated (segx), offset, bv_n_words) = ""b;
	return;

clear:
     entry ();

	call initialize;
	return;

initialize:
     procedure;

	if memory_seg_ptr = null			/* have we found the segment yet? */
	then do;					/* no */
		call user_info_ (person_id, project_id);
		dname = ">user_dir_dir>" || rtrim (project_id) || ">" || person_id;
		ename = rtrim (person_id) || ".csm";

		call hcs_$initiate (dname, ename, "", 0b, 0b, memory_seg_ptr, code);
		if memory_seg_ptr = null
		then do;				/* not there, try creating it. */
			call hcs_$make_seg (dname, ename, "", 01010b, memory_seg_ptr, code);
			if memory_seg_ptr = null
			then do;
				call com_err_ (code, "check_storage_manager_", "Cannot create ^a>^a", dname, ename);
				return;
			     end;

			call ioa_ ("check_storage_manager_: Creating ^a>^a", dname, ename);
		     end;
	     end;

	call hcs_$truncate_seg (memory_seg_ptr, 0, code);
	if code ^= 0
	then do;
		call com_err_ (code, "check_storage_manager_", "Cannot truncate ^a>^a to 0 words.", dname, ename);
		memory_seg_ptr = null;
		return;
	     end;

	memory.last_memory_slot = lbound (memory.segno, 1) - 1;
	return;

     end /* initialize */;

     end /* check_storage_manager_ */;





		    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
