COMPILATION LISTING OF SEGMENT severity Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/04/82 1716.8 mst Thu Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* *********************************************************** */ 6 7 /* SEVERITY - Command/Active Function to return the value (as a char string) 8* of an external static severity value. 9* 10* Designed by Webber, Written 770729 by Green 11* Modified 770914 by PG to restrict to just FORTRAN and PL/I for MR6.0 version 12* Modified 4/80 by Michael R. Jordan to use get_external_variable_ 13* Modified 5/13/82 by L. Baldwin to fix the short name for -default to -dft. 14**/ 15 16 severity: 17 procedure options (variable); 18 19 /* automatic */ 20 21 declare active_function bit (1) aligned, 22 arg_length fixed bin (21), 23 arg_num fixed bin, 24 arg_ptr ptr, 25 argument_routine entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable, 26 code fixed bin (35), 27 default_arg_length fixed bin (21), 28 default_arg_ptr ptr, 29 error_routine entry options (variable) variable, 30 n_args fixed bin, 31 return_length fixed bin (21), 32 return_ptr ptr, 33 severity_string picture "-----------9", /* room for sign + 11 digits */ 34 severity_value fixed bin (35), 35 vdesc_ptr ptr, 36 var_ptr ptr, 37 var_size fixed bin (19); 38 39 /* based */ 40 41 declare arg_string char (arg_length) based (arg_ptr), 42 default_arg_string char (default_arg_length) based (default_arg_ptr), 43 return_value char (return_length) varying based (return_ptr), 44 severity_variable fixed bin (35) based (var_ptr); 45 46 /* builtins */ 47 48 declare ltrim builtin; 49 50 /* entries */ 51 52 declare active_fnc_err_ entry options (variable), 53 com_err_ entry options (variable), 54 cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), 55 cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), 56 cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), 57 get_external_variable_ entry (char (*), ptr, fixed bin (19), ptr, fixed bin (35)), 58 ioa_ entry options (variable); 59 60 /* external static */ 61 62 declare (error_table_$badopt, 63 error_table_$noarg, 64 error_table_$not_act_fnc) fixed bin (35) external static; 65 66 /* internal static */ 67 68 declare my_name char (8) internal static init ("severity") options (constant); 69 70 /* program */ 71 72 call cu_$af_return_arg (n_args, return_ptr, return_length, code); 73 if code = 0 74 then do; /* called as active function */ 75 error_routine = active_fnc_err_; 76 argument_routine = cu_$af_arg_ptr; 77 active_function = "1"b; 78 return_value = ""; /* in case we get started after an error */ 79 end; 80 else if code = error_table_$not_act_fnc /* called as command */ 81 then do; 82 error_routine = com_err_; 83 argument_routine = cu_$arg_ptr; 84 active_function = "0"b; 85 end; 86 else do; 87 call com_err_ (code, my_name, ""); 88 return; 89 end; 90 if n_args = 0 91 then do; 92 call error_routine (error_table_$noarg, my_name, "^/Usage: severity indicator_name {-default STR}"); 93 return; 94 end; 95 96 default_arg_ptr = null (); 97 do arg_num = 2 repeat arg_num+1 while (arg_num <= n_args); 98 call argument_routine (arg_num, arg_ptr, arg_length, code); 99 if code ^= 0 100 then do; 101 call error_routine (code, my_name, "Unable to access argument #^d.", arg_num); 102 return; 103 end; 104 if arg_string = "-default" | arg_string = "-dft" 105 then do; 106 if arg_num = n_args 107 then do; 108 call error_routine (error_table_$noarg, my_name, "Default string missing following ^a.", arg_string); 109 return; 110 end; 111 arg_num = arg_num+1; 112 call argument_routine (arg_num, default_arg_ptr, default_arg_length, code); 113 if code ^= 0 114 then do; 115 call error_routine (code, my_name, "Unable to access default string argument."); 116 return; 117 end; 118 end; 119 else do; 120 call error_routine (error_table_$badopt, my_name, "^a", arg_string); 121 return; 122 end; 123 end; 124 125 call argument_routine (1, arg_ptr, arg_length, code); 126 if code ^= 0 127 then do; 128 call error_routine (code, my_name, "Unable to access argument #1."); 129 return; 130 end; 131 132 call get_external_variable_ (arg_string || "_severity_", var_ptr, var_size, vdesc_ptr, code); 133 if code ^= 0 134 then do; 135 if default_arg_ptr = null () 136 then do; 137 call error_routine (code, my_name, 138 "^/Error accessing severity indicator ^a.", arg_string); 139 return; 140 end; 141 if active_function 142 then return_value = default_arg_string; 143 else call ioa_ ("^a", default_arg_string); 144 return; 145 end; 146 147 if var_size ^= 1 148 then do; 149 call error_routine (0b, my_name, "The severity indicator ^a is not a single word variable.", arg_string); 150 return; 151 end; 152 153 severity_value = severity_variable; 154 severity_string = severity_value; /* convert to pictured form */ 155 156 if active_function 157 then return_value = ltrim (severity_string); 158 else call ioa_ ("^a", ltrim (severity_string)); 159 160 return; 161 162 end severity; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/04/82 1606.3 severity.pl1 >dumps>old>recomp>severity.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. active_fnc_err_ 000010 constant entry external dcl 52 ref 75 active_function 000100 automatic bit(1) dcl 21 set ref 77* 84* 141 156 arg_length 000101 automatic fixed bin(21,0) dcl 21 set ref 98* 104 104 108 108 120 120 125* 132 137 137 149 149 arg_num 000102 automatic fixed bin(17,0) dcl 21 set ref 97* 97* 98* 101* 106 111* 111 112* 123 arg_ptr 000104 automatic pointer dcl 21 set ref 98* 104 104 108 120 125* 132 137 149 arg_string based char unaligned dcl 41 set ref 104 104 108* 120* 132 137* 149* argument_routine 000106 automatic entry variable dcl 21 set ref 76* 83* 98 112 125 code 000112 automatic fixed bin(35,0) dcl 21 set ref 72* 73 80 87* 98* 99 101* 112* 113 115* 125* 126 128* 132* 133 137* com_err_ 000012 constant entry external dcl 52 ref 82 87 cu_$af_arg_ptr 000014 constant entry external dcl 52 ref 76 cu_$af_return_arg 000016 constant entry external dcl 52 ref 72 cu_$arg_ptr 000020 constant entry external dcl 52 ref 83 default_arg_length 000113 automatic fixed bin(21,0) dcl 21 set ref 112* 141 143 143 default_arg_ptr 000114 automatic pointer dcl 21 set ref 96* 112* 135 141 143 default_arg_string based char unaligned dcl 41 set ref 141 143* error_routine 000116 automatic entry variable dcl 21 set ref 75* 82* 92 101 108 115 120 128 137 149 error_table_$badopt 000026 external static fixed bin(35,0) dcl 62 set ref 120* error_table_$noarg 000030 external static fixed bin(35,0) dcl 62 set ref 92* 108* error_table_$not_act_fnc 000032 external static fixed bin(35,0) dcl 62 ref 80 get_external_variable_ 000022 constant entry external dcl 52 ref 132 ioa_ 000024 constant entry external dcl 52 ref 143 158 ltrim builtin function dcl 48 ref 156 158 158 my_name 000000 constant char(8) initial unaligned dcl 68 set ref 87* 92* 101* 108* 115* 120* 128* 137* 149* n_args 000122 automatic fixed bin(17,0) dcl 21 set ref 72* 90 97 106 return_length 000123 automatic fixed bin(21,0) dcl 21 set ref 72* 78 141 156 return_ptr 000124 automatic pointer dcl 21 set ref 72* 78 141 156 return_value based varying char dcl 41 set ref 78* 141* 156* severity_string 000126 automatic picture(12) unaligned dcl 21 set ref 154* 156 158 158 severity_value 000131 automatic fixed bin(35,0) dcl 21 set ref 153* 154 severity_variable based fixed bin(35,0) dcl 41 ref 153 var_ptr 000134 automatic pointer dcl 21 set ref 132* 153 var_size 000136 automatic fixed bin(19,0) dcl 21 set ref 132* 147 vdesc_ptr 000132 automatic pointer dcl 21 set ref 132* NAME DECLARED BY EXPLICIT CONTEXT. severity 000144 constant entry external dcl 16 NAME DECLARED BY CONTEXT OR IMPLICATION. null builtin function ref 96 135 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1222 1256 1074 1232 Length 1434 1074 34 141 126 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME severity 183 external procedure is an external procedure. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME severity 000100 active_function severity 000101 arg_length severity 000102 arg_num severity 000104 arg_ptr severity 000106 argument_routine severity 000112 code severity 000113 default_arg_length severity 000114 default_arg_ptr severity 000116 error_routine severity 000122 n_args severity 000123 return_length severity 000124 return_ptr severity 000126 severity_string severity 000131 severity_value severity 000132 vdesc_ptr severity 000134 var_ptr severity 000136 var_size severity THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_var_desc call_var call_ext_out_desc call_ext_out return shorten_stack ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. active_fnc_err_ com_err_ cu_$af_arg_ptr cu_$af_return_arg cu_$arg_ptr get_external_variable_ ioa_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$badopt error_table_$noarg error_table_$not_act_fnc LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 16 000143 72 000151 73 000165 75 000167 76 000174 77 000177 78 000201 79 000202 80 000203 82 000206 83 000212 84 000215 85 000216 87 000217 88 000237 90 000240 92 000242 93 000265 96 000266 97 000270 98 000275 99 000311 101 000313 102 000342 104 000343 106 000355 108 000360 109 000413 111 000414 112 000415 113 000431 115 000433 116 000456 118 000457 120 000460 121 000512 123 000513 125 000515 126 000533 128 000535 129 000560 132 000561 133 000627 135 000632 137 000636 139 000670 141 000671 143 000706 144 000730 147 000731 149 000734 150 000767 153 000770 154 000772 156 001001 158 001026 160 001066 ----------------------------------------------------------- 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