COMPILATION LISTING OF SEGMENT apl_group_command_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1607.4 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 apl_group_command_: 11 procedure (nargs, arglist); 12 13 /* 14* * apl command to create, append, or disband a group 15* * 16* * written 73.9.06 by DAM 17* Modified 800819 by WMY to fix bug 468 ()GROUP X F F gives a system 18* error (attempt to free bead with non-zero ref count)) 19* */ 20 21 dcl nargs fixed bin parameter, 22 arglist dim (*) char (*) parameter; 23 24 25 call apl_create_save_frame_; /* use global meanings */ 26 call apl_get_symbol_ (before (arglist (1), " "), group_symbol, (0)); 27 28 if nargs = 1 29 then do; 30 31 /* disband group */ 32 33 if group_symbol -> symbol_bead.meaning_pointer = null 34 then go to cant_disband; 35 else if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group 36 then ; 37 else go to cant_disband; 38 call wash (group_symbol -> symbol_bead.meaning_pointer); 39 group_symbol -> symbol_bead.meaning_pointer = null; 40 end; 41 42 else do; /* create or append to existing group */ 43 44 /* Check to see if group of this name already exists */ 45 46 if group_symbol -> symbol_bead.meaning_pointer ^= null 47 then if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group 48 then do argno = 2 by 1 while (argno <= nargs); 49 50 /* group already exists, check to see if we are appending 51* or replacing the group */ 52 53 call apl_get_symbol_ (before (arglist (argno), " "), symb, (0)); 54 if symb = group_symbol 55 then go to append_to_group; 56 else call wash (symb); 57 end; 58 59 /* create group bead */ 60 61 if group_symbol -> symbol_bead.meaning_pointer ^= null 62 then if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group 63 then call wash (group_symbol -> symbol_bead.meaning_pointer); 64 else go to name_dup; 65 66 /* have already flushed old value, if any */ 67 68 call apl_allocate_words_ (size (group_bead) + nargs - 1, gbp); 69 string (gbp -> general_bead.type) = group_type; 70 gbp -> group_bead.number_of_members = nargs - 1; 71 72 /* Add new symbols to group bead. */ 73 74 do argno = 2 by 1 while (argno <= nargs); 75 76 call apl_get_symbol_ (before (arglist (argno), " "), symb, (0)); 77 78 /* Check for duplicate entries in symbol list */ 79 80 do dupx = 1 to argno - 2; 81 if gbp -> group_bead.member (dupx) = symb 82 then go to mem_dup_create; 83 end; 84 85 /* Add this symbol to group bead */ 86 87 gbp -> group_bead.member (argno - 1) = symb; 88 end; 89 90 /* Attach group bead to symbol */ 91 92 group_symbol -> symbol_bead.meaning_pointer = gbp; 93 94 end; /* create or append to group */ 95 96 97 finish: 98 call wash (group_symbol); 99 call apl_destroy_save_frame_update_; 100 return; 101 102 103 104 105 append_to_group: 106 group_symbol -> symbol_bead.reference_count = group_symbol -> symbol_bead.reference_count - 1; 107 /* adjust for goto out of do loop */ 108 109 /* name of group is in members list, append */ 110 111 n_mem = group_symbol -> symbol_bead.meaning_pointer -> group_bead.number_of_members + nargs - 2; 112 call apl_allocate_words_ (size (group_bead) + n_mem, gbp); 113 /* make new, larger group bead */ 114 115 string (gbp -> general_bead.type) = group_type; 116 gbp -> group_bead.number_of_members = n_mem; 117 118 /* copy old members */ 119 120 do memx = 1 by 1 while (memx <= group_symbol -> symbol_bead.meaning_pointer -> group_bead.number_of_members); 121 gbp -> group_bead.member (memx) = group_symbol -> symbol_bead.meaning_pointer -> 122 group_bead.member (memx); 123 end; 124 125 /* add new members */ 126 127 do argx = 2 by 1 while (argx <= nargs); 128 if argx ^= argno 129 then do; /* append member (skipping over the group's own name) */ 130 call apl_get_symbol_ (before (arglist (argx), " "), symb, (0)); 131 do dupx = 1 by 1 while (dupx < memx); 132 /* look for duplications */ 133 if gbp -> group_bead.member (dupx) = symb 134 then go to mem_dup_append; 135 end; 136 gbp -> group_bead.member (memx) = symb; 137 memx = memx + 1; 138 end; 139 end; 140 141 /* flush old bead - do not decrement reference counts of old members since copied over */ 142 143 call apl_free_words_ (fixed (group_symbol -> symbol_bead.meaning_pointer -> general_bead.size, 18), 144 group_symbol -> symbol_bead.meaning_pointer); 145 group_symbol -> symbol_bead.meaning_pointer = gbp; 146 go to finish; 147 148 149 wash: 150 proc (bp); 151 152 dcl bp unaligned pointer; 153 154 dcl p unaligned pointer; 155 156 p = bp; 157 if p = null 158 then return; 159 p -> general_bead.reference_count = p -> general_bead.reference_count - 1; 160 if p -> general_bead.reference_count <= 0 161 then call apl_free_bead_ (p); 162 end; 163 164 165 /* error exits */ 166 167 mem_dup_create: 168 gbp -> group_bead.number_of_members = argno - 2; 169 go to mem_dup; 170 171 mem_dup_append: 172 gbp -> group_bead.number_of_members = memx - 1; 173 mem_dup: 174 call ioa_$ioa_stream (apl_output_stream, "^Rincorrect command - group member ^a appears twice^B", 175 symb -> symbol_bead.name); 176 call wash (gbp); /* flush space for group bead, fix up reference counts on members */ 177 go to finish; 178 179 cant_disband: 180 call ioa_$ioa_stream (apl_output_stream, "^Rcan't disband - ^a is not a group^B", group_symbol -> symbol_bead.name); 181 go to finish; 182 183 name_dup: 184 call ioa_$ioa_stream (apl_output_stream, "^Rnot grouped, name in use^B"); 185 go to finish; 186 187 dcl group_symbol unaligned pointer, 188 argno fixed bin, 189 symb unaligned pointer, 190 gbp unaligned pointer, 191 ioa_$ioa_stream entry options (variable), 192 n_mem fixed bin, 193 memx fixed bin, 194 dupx fixed bin, 195 argx fixed bin; 196 197 declare apl_output_stream char (11) static initial ("apl_output_"); 198 199 dcl (null, string, addr, fixed, size, before) 200 builtin; 201 202 dcl apl_create_save_frame_ entry, 203 apl_destroy_save_frame_update_ 204 entry, 205 apl_get_symbol_ entry (char (*), unaligned pointer, fixed bin), 206 apl_allocate_words_ entry (fixed bin (18), unaligned pointer), 207 apl_free_words_ entry (fixed bin (18), unaligned pointer), 208 apl_free_bead_ entry (unaligned pointer); 209 210 211 212 /* include files */ 213 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 1 2 1 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 1 4 2 type unaligned, 1 5 3 bead_type unaligned, 1 6 4 operator bit (1), /* ON if operator bead */ 1 7 4 symbol bit (1), /* ON if symbol bead */ 1 8 4 value bit (1), /* ON if value bead */ 1 9 4 function bit (1), /* ON if function bead */ 1 10 4 group bit (1), /* ON if group bead */ 1 11 4 label bit (1), /* ON if label bead */ 1 12 4 shared_variable bit (1), /* ON if shared variable bead */ 1 13 4 lexed_function bit (1), /* ON if lexed function bead */ 1 14 3 data_type unaligned, 1 15 4 list_value bit (1), /* ON if a list value bead */ 1 16 4 character_value bit (1), /* ON if a character value bead */ 1 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 1 18 4 integral_value bit (1), /* ON if an integral value bead */ 1 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 1 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 1 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 1 22 2 size bit (18) unaligned, /* Number of words this bead occupies 1 23* (used by bead storage manager) */ 1 24 2 reference_count fixed binary (29); /* Number of pointers which point 1 25* to this bead (used by bead manager) */ 1 26 1 27 1 28 /* constant strings for initing type field in various beads */ 1 29 1 30 declare ( 1 31 operator_type init("100000000000000000"b), 1 32 symbol_type init("010000000000000000"b), 1 33 value_type init("001000000000000000"b), 1 34 function_type init("000100000000000000"b), 1 35 group_type init("000010000000000000"b), 1 36 label_type init("001001000011000000"b), 1 37 shared_variable_type init("001000100000000000"b), 1 38 lexed_function_type init("000000010000000000"b), 1 39 1 40 list_value_type init("000000001000000000"b), 1 41 character_value_type init("001000000100000000"b), 1 42 numeric_value_type init("001000000010000000"b), 1 43 integral_value_type init("001000000011000000"b), 1 44 zero_or_one_value_type init("001000000011100000"b), 1 45 complex_value_type init("001000000000010000"b), 1 46 1 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 1 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 1 49 ) bit(18) internal static; 1 50 1 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 214 2 1 /* BEGIN INCLUDE FILE: apl_group_bead.incl.pl1 */ 2 2 2 3 /* Initial Version: 1973.06.18 2 4* Typed in by: Richard S. Lamson */ 2 5 2 6 2 7 declare 1 group_bead aligned based, /* Group: bead_type.group = "1"b */ 2 8 2 9 2 header aligned like general_bead, 2 10 2 11 2 number_of_members fixed binary, 2 12 2 13 2 member pointer unaligned dimension (0 refer (group_bead.number_of_members)); 2 14 /* Pointer to the symbol bead for each 2 15* member of the group */ 2 16 2 17 /* END INCLUDE FILE apl_group_bead.incl.pl1 */ 215 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ================================== */ 3 2 3 3 /* Explanation of fields: 3 4* symbol_bead.hash_link_pointer points to next symbol in same hash bucket in the symbol table. 3 5* symbol_bead.meaning_pointer points to current "value" of this name: 3 6* = null => unused (e.g. undefined variable) 3 7* -> group bead => group name 3 8* -> value bead => variable with a value 3 9* -> function bead => function name 3 10* -> label bead => localized label value 3 11* -> shared var bead => shared variable */ 3 12 3 13 declare 1 symbol_bead aligned based, 3 14 2 header aligned like general_bead, 3 15 2 hash_link_pointer pointer unaligned, 3 16 2 meaning_pointer pointer unaligned, 3 17 2 name_length fixed binary, 3 18 2 name character (0 refer (symbol_bead.name_length)) unaligned; 3 19 3 20 /* ------ END INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ---------------------------------- */ 216 217 218 219 220 end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.4 apl_group_command_.pl1 >special_ldd>on>apl.1129>apl_group_command_.pl1 214 1 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 215 2 03/27/82 0438.7 apl_group_bead.incl.pl1 >ldd>include>apl_group_bead.incl.pl1 216 3 03/27/82 0439.2 apl_symbol_bead.incl.pl1 >ldd>include>apl_symbol_bead.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. apl_allocate_words_ 000024 constant entry external dcl 202 ref 68 112 apl_create_save_frame_ 000016 constant entry external dcl 202 ref 25 apl_destroy_save_frame_update_ 000020 constant entry external dcl 202 ref 99 apl_free_bead_ 000030 constant entry external dcl 202 ref 160 apl_free_words_ 000026 constant entry external dcl 202 ref 143 apl_get_symbol_ 000022 constant entry external dcl 202 ref 26 53 76 130 apl_output_stream 000010 internal static char(11) initial unaligned dcl 197 set ref 173* 179* 183* arglist parameter char array unaligned dcl 21 ref 10 26 26 53 53 76 76 130 130 argno 000101 automatic fixed bin(17,0) dcl 187 set ref 46* 46* 53 53* 74* 74* 76 76 80 87* 128 167 argx 000107 automatic fixed bin(17,0) dcl 187 set ref 127* 127* 128 130 130* bead_type based structure level 3 packed unaligned dcl 1-3 before builtin function dcl 199 ref 26 26 53 53 76 76 130 130 bp parameter pointer unaligned dcl 152 ref 149 156 dupx 000106 automatic fixed bin(17,0) dcl 187 set ref 80* 81* 131* 131* 133* fixed builtin function dcl 199 ref 143 143 gbp 000103 automatic pointer unaligned dcl 187 set ref 68* 69 70 81 87 92 112* 115 116 121 133 136 145 167 171 176* general_bead based structure level 1 dcl 1-3 group 0(04) based bit(1) level 4 packed unaligned dcl 1-3 set ref 35 46 61 group_bead based structure level 1 dcl 2-7 set ref 68 112 group_symbol 000100 automatic pointer unaligned dcl 187 set ref 26* 33 35 38 39 46 46 54 61 61 61 92 97* 105 105 111 120 121 143 143 143 145 179 group_type constant bit(18) initial unaligned dcl 1-30 ref 69 115 header based structure level 2 dcl 3-13 ioa_$ioa_stream 000014 constant entry external dcl 187 ref 173 179 183 meaning_pointer 3 based pointer level 2 packed unaligned dcl 3-13 set ref 33 35 38* 39* 46 46 61 61 61* 92* 111 120 121 143 143 143* 145* member 3 based pointer array level 2 packed unaligned dcl 2-7 set ref 81 87* 121* 121 133 136* memx 000105 automatic fixed bin(17,0) dcl 187 set ref 120* 120* 121 121* 131 136 137* 137 171 n_mem 000104 automatic fixed bin(17,0) dcl 187 set ref 111* 112 116 name 5 based char level 2 packed unaligned dcl 3-13 set ref 173* 179* name_length 4 based fixed bin(17,0) level 2 dcl 3-13 ref 173 173 179 179 nargs parameter fixed bin(17,0) dcl 21 ref 10 28 46 68 70 74 111 127 null builtin function dcl 199 ref 33 39 46 61 157 number_of_members 2 based fixed bin(17,0) level 2 dcl 2-7 set ref 70* 111 116* 120 167* 171* p 000120 automatic pointer unaligned dcl 154 set ref 156* 157 159 159 160 160* reference_count 1 based fixed bin(29,0) level 2 in structure "general_bead" dcl 1-3 in procedure "apl_group_command_" set ref 159* 159 160 reference_count 1 based fixed bin(29,0) level 3 in structure "symbol_bead" dcl 3-13 in procedure "apl_group_command_" set ref 105* 105 size 0(18) based bit(18) level 2 in structure "general_bead" packed unaligned dcl 1-3 in procedure "apl_group_command_" ref 143 143 size builtin function dcl 199 in procedure "apl_group_command_" ref 68 112 string builtin function dcl 199 set ref 69* 115* symb 000102 automatic pointer unaligned dcl 187 set ref 53* 54 56* 76* 81 87 130* 133 136 173 symbol_bead based structure level 1 dcl 3-13 type based structure level 2 packed unaligned dcl 1-3 set ref 69* 115* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addr builtin function dcl 199 character_value_type internal static bit(18) initial unaligned dcl 1-30 complex_value_type internal static bit(18) initial unaligned dcl 1-30 function_type internal static bit(18) initial unaligned dcl 1-30 integral_value_type internal static bit(18) initial unaligned dcl 1-30 label_type internal static bit(18) initial unaligned dcl 1-30 lexed_function_type internal static bit(18) initial unaligned dcl 1-30 list_value_type internal static bit(18) initial unaligned dcl 1-30 not_integer_mask internal static bit(18) initial unaligned dcl 1-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 1-30 numeric_value_type internal static bit(18) initial unaligned dcl 1-30 operator_type internal static bit(18) initial unaligned dcl 1-30 shared_variable_type internal static bit(18) initial unaligned dcl 1-30 symbol_type internal static bit(18) initial unaligned dcl 1-30 value_type internal static bit(18) initial unaligned dcl 1-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 1-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_group_command_ 000061 constant entry external dcl 10 append_to_group 000475 constant label dcl 105 set ref 54 cant_disband 000742 constant label dcl 179 ref 33 35 finish 000465 constant label dcl 97 set ref 146 177 181 185 mem_dup 000707 constant label dcl 173 ref 169 mem_dup_append 000704 constant label dcl 171 ref 133 mem_dup_create 000700 constant label dcl 167 ref 81 name_dup 000772 constant label dcl 183 set ref 61 wash 001013 constant entry internal dcl 149 ref 38 56 61 97 176 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1200 1232 1061 1210 Length 1470 1061 32 222 117 4 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_group_command_ 126 external procedure is an external procedure. wash internal procedure shares stack frame of external procedure apl_group_command_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 apl_output_stream apl_group_command_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_group_command_ 000100 group_symbol apl_group_command_ 000101 argno apl_group_command_ 000102 symb apl_group_command_ 000103 gbp apl_group_command_ 000104 n_mem apl_group_command_ 000105 memx apl_group_command_ 000106 dupx apl_group_command_ 000107 argx apl_group_command_ 000120 p wash THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_ext_out_desc call_ext_out return shorten_stack ext_entry_desc THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_allocate_words_ apl_create_save_frame_ apl_destroy_save_frame_update_ apl_free_bead_ apl_free_words_ apl_get_symbol_ ioa_$ioa_stream NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000055 25 000074 26 000100 28 000153 33 000160 35 000165 38 000171 39 000177 40 000202 46 000203 53 000222 54 000275 56 000301 57 000303 61 000305 68 000324 69 000342 70 000345 74 000351 76 000360 80 000433 81 000445 83 000452 87 000454 88 000460 92 000462 97 000465 99 000467 100 000474 105 000475 111 000500 112 000506 115 000522 116 000525 120 000527 121 000540 123 000544 127 000546 128 000554 130 000556 131 000631 133 000637 135 000644 136 000646 137 000652 139 000653 143 000655 145 000674 146 000677 167 000700 169 000703 171 000704 173 000707 176 000737 177 000741 179 000742 181 000771 183 000772 185 001012 149 001013 156 001015 157 001024 159 001027 160 001032 162 001043 ----------------------------------------------------------- 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