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