COMPILATION LISTING OF SEGMENT rje_args Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/04/82 1818.5 mst Thu Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 rje_args: proc; 12 13 14 /* This is the initial version of an active function to return some information about 15* the submission of an RJE card input job. It will eventually be fashoned after the 16* user active function. This version is modeled after the value command to set certain 17* values which are then returned by giving the correct key to the active function. 18* 19* Only the active function entry is to be documented. The setting entry is internal 20* interfaces and will go away when the source data can be put into the PIT. 21* */ 22 23 /* Initial version taken from the value active function by J. C. Whitmore, Aug. 1977 */ 24 25 26 27 dcl en char (32) aligned int static, 28 dn char (168) aligned int static, 29 segptr ptr int static init (null), 30 ap ptr, al fixed bin, bchr char (al) unal based (ap), 31 answer char (168) varying, 32 bvcs char (al) varying based (ap), 33 ec fixed bin, 34 i fixed bin, 35 af_sw bit (1) init ("0"b), 36 string char (168) aligned; 37 38 dcl (null, substr, addr, length, rtrim) builtin; 39 40 dcl com_err_ entry options (variable), 41 adjust_bit_count_ entry (char (*) aligned, char (*) aligned, bit (1), fixed bin (24), fixed bin (17)), 42 get_pdir_ entry () returns (char (168) aligned), 43 active_fnc_err_ entry options (variable), 44 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), 45 cu_$arg_count entry (fixed bin), 46 cu_$af_arg_count entry (fixed bin, fixed bin), 47 cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), 48 cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin), 49 error_table_$wrong_no_of_args fixed bin ext, 50 error_table_$bad_arg fixed bin ext, 51 error_table_$not_act_fnc fixed bin ext, 52 hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin), 53 unique_chars_ entry (bit (*)) returns (char (15)), 54 ioa_ entry options (variable); 55 56 dcl 1 valueseg based (segptr) aligned, 57 2 laste fixed bin, 58 2 freep fixed bin, 59 2 pad (6) fixed bin, 60 2 arry (1000), 61 3 name char (32), 62 3 valu char (168), 63 3 lth fixed bin, 64 3 chain fixed bin; 65 66 /* ========================================= */ 67 68 af_sw = "1"b; /* this should be an active function */ 69 70 call cu_$af_arg_count (i, ec); 71 if ec = error_table_$not_act_fnc then af_sw = "0"b; 72 else if ec ^= 0 then go to er; 73 74 if ^af_sw then call cu_$arg_count (i); /* not an active function so get valid count */ 75 if i ^= 1 then do; 76 ec = error_table_$wrong_no_of_args; 77 go to er; 78 end; 79 80 if segptr = null then do; 81 call get_segptr (ec); 82 if segptr = null then do; 83 er: if af_sw then 84 call active_fnc_err_ (ec, "rje_args"); 85 else call com_err_ (ec, "rje_args"); 86 return; 87 end; 88 end; 89 90 if af_sw then 91 call cu_$af_arg_ptr (1, ap, al, ec); 92 else call cu_$arg_ptr (1, ap, al, ec); 93 if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er; 94 95 /* check to see if the key given is legal */ 96 97 if bchr = "prt_rqt" then; /* the printer request type */ 98 else if bchr = "pun_rqt" then; /* the punch request type */ 99 else if bchr = "station" then; /* the station code of the job */ 100 else do; /* all others are invalid! */ 101 ec = error_table_$bad_arg; 102 go to er; 103 end; 104 105 do i = 1 to laste; 106 if chain (i) = 0 then if name (i) ^= "" then 107 if bchr = name (i) then go to found; 108 end; 109 answer = "undefined!"; 110 go to give; 111 112 found: answer = substr (valu (i), 1, lth (i)); 113 if answer = "" then answer = "undefined!"; /* always return something */ 114 give: if af_sw then do; 115 call cu_$af_return_arg (i, ap, al, ec); 116 if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er; 117 bvcs = answer; 118 return; 119 end; 120 call ioa_ (answer); 121 return; 122 123 /* ---------------------------------- */ 124 125 set: entry; 126 127 if segptr = null then do; 128 call get_segptr (ec); 129 if segptr = null then go to er; 130 end; 131 132 call cu_$arg_ptr (1, ap, al, ec); 133 if ec ^= 0 then go to er; 134 135 if bchr = "prt_rqt" then; /* ok to set the printer request type */ 136 else if bchr = "pun_rqt" then; /* ok to set the punch request type */ 137 else if bchr = "station" then; /* ok to set the station code */ 138 else do; /* all other keys are invalid! */ 139 ec = error_table_$bad_arg; 140 go to er; 141 end; 142 143 string = bchr; 144 145 call cu_$arg_ptr (2, ap, al, ec); 146 if ec ^= 0 then do; 147 do i = 1 to laste; 148 if string = name (i) then do; 149 chain (i) = freep; 150 freep = i; 151 name (i) = ""; 152 end; 153 end; 154 return; 155 end; 156 157 do i = 1 to laste; 158 if chain (i) = 0 then if name (i) ^= "" then 159 if name (i) = string then do; 160 go to f1; 161 end; 162 end; 163 if freep = 0 then i, laste = laste + 1; 164 else do; 165 i = freep; 166 freep = chain (i); 167 end; 168 name (i) = string; 169 f1: valu (i) = bchr; 170 chain (i) = 0; 171 lth (i) = al; 172 173 call adjust_bit_count_ (dn, en, "0"b, (0), ec); 174 175 return; 176 177 /* ------------------------------------------ */ 178 179 list: entry; 180 181 if segptr = null then do; 182 call get_segptr (ec); 183 if segptr = null then go to er; 184 end; 185 186 call cu_$arg_ptr (1, ap, al, ec); 187 do i = 1 to laste; 188 if name (i) = "" then go to nop; 189 if chain (i) = 0 then do; 190 if ec = 0 then if name (i) ^= bchr then go to nop; 191 call ioa_ ("^20a^-^a", name (i), substr (valu (i), 1, lth (i))); 192 end; 193 nop: end; 194 call ioa_ (""); 195 196 return; 197 198 /* ------------------------------------ */ 199 200 get_segptr: proc (code); 201 202 dcl code fixed bin; 203 204 dn = get_pdir_ (); 205 en = "rje_args." || unique_chars_ ((70)"0"b); /* make a unique name */ 206 207 call hcs_$make_seg (dn, en, "", 1011b, segptr, code); 208 209 if code = 0 then do; /* initialize the values to the defaults */ 210 laste = 3; /* 3 entries */ 211 name (1) = "prt_rqt"; 212 valu (1) = "printer"; 213 lth (1) = length (rtrim (valu (1))); 214 name (2) = "pun_rqt"; 215 valu (2) = "punch"; 216 lth (2) = length (rtrim (valu (2))); 217 name (3) = "station"; 218 valu (3) = "central_site"; 219 lth (3) = length (rtrim (valu (3))); 220 end; 221 222 return; 223 224 end get_segptr; 225 226 end rje_args; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/04/82 1627.7 rje_args.pl1 >dumps>old>recomp>rje_args.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_ 000102 constant entry external dcl 40 ref 83 adjust_bit_count_ 000076 constant entry external dcl 40 ref 173 af_sw 000160 automatic bit(1) initial unaligned dcl 27 set ref 27* 68* 71* 74 83 90 114 al 000102 automatic fixed bin(17,0) dcl 27 set ref 90* 92* 97 98 99 106 115* 117 132* 135 136 137 143 145* 169 171 186* 190 answer 000103 automatic varying char(168) dcl 27 set ref 109* 112* 113 113* 117 120* ap 000100 automatic pointer dcl 27 set ref 90* 92* 97 98 99 106 115* 117 132* 135 136 137 143 145* 169 186* 190 arry 10 based structure array level 2 dcl 56 bchr based char unaligned dcl 27 ref 97 98 99 106 135 136 137 143 169 190 bvcs based varying char dcl 27 set ref 117* chain 73 based fixed bin(17,0) array level 3 dcl 56 set ref 106 149* 158 166 170* 189 code parameter fixed bin(17,0) dcl 202 set ref 200 207* 209 com_err_ 000074 constant entry external dcl 40 ref 85 cu_$af_arg_count 000110 constant entry external dcl 40 ref 70 cu_$af_arg_ptr 000112 constant entry external dcl 40 ref 90 cu_$af_return_arg 000114 constant entry external dcl 40 ref 115 cu_$arg_count 000106 constant entry external dcl 40 ref 74 cu_$arg_ptr 000104 constant entry external dcl 40 ref 92 132 145 186 dn 000020 internal static char(168) dcl 27 set ref 173* 204* 207* ec 000156 automatic fixed bin(17,0) dcl 27 set ref 70* 71 72 76* 81* 83* 85* 90* 92* 93 93 101* 115* 116 116 128* 132* 133 139* 145* 146 173* 182* 186* 190 en 000010 internal static char(32) dcl 27 set ref 173* 205* 207* error_table_$bad_arg 000120 external static fixed bin(17,0) dcl 40 ref 101 139 error_table_$not_act_fnc 000122 external static fixed bin(17,0) dcl 40 ref 71 93 116 error_table_$wrong_no_of_args 000116 external static fixed bin(17,0) dcl 40 ref 76 freep 1 based fixed bin(17,0) level 2 dcl 56 set ref 149 150* 163 165 166* get_pdir_ 000100 constant entry external dcl 40 ref 204 hcs_$make_seg 000124 constant entry external dcl 40 ref 207 i 000157 automatic fixed bin(17,0) dcl 27 set ref 70* 74* 75 105* 106 106 106* 112 112 115* 147* 148 149 150 151* 157* 158 158 158* 163* 165* 166 168 169 170 171 187* 188 189 190 191 191 191 191 191* ioa_ 000130 constant entry external dcl 40 ref 120 191 194 laste based fixed bin(17,0) level 2 dcl 56 set ref 105 147 157 163 163* 187 210* length builtin function dcl 38 ref 213 216 219 lth 72 based fixed bin(17,0) array level 3 dcl 56 set ref 112 171* 191 191 213* 216* 219* name 10 based char(32) array level 3 dcl 56 set ref 106 106 148 151* 158 158 168* 188 190 191* 211* 214* 217* null builtin function dcl 38 ref 80 82 127 129 181 183 rtrim builtin function dcl 38 ref 213 216 219 segptr 000072 internal static pointer initial dcl 27 set ref 80 82 105 106 106 106 112 112 127 129 147 148 149 149 150 151 157 158 158 158 163 163 163 165 166 166 168 169 170 171 181 183 187 188 189 190 191 191 191 191 191 207* 210 211 212 213 213 214 215 216 216 217 218 219 219 string 000161 automatic char(168) dcl 27 set ref 143* 148 158 168 substr builtin function dcl 38 ref 112 191 191 unique_chars_ 000126 constant entry external dcl 40 ref 205 valu 20 based char(168) array level 3 dcl 56 set ref 112 169* 191 191 212* 213 215* 216 218* 219 valueseg based structure level 1 dcl 56 NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addr builtin function dcl 38 NAMES DECLARED BY EXPLICIT CONTEXT. er 000140 constant label dcl 83 ref 72 77 93 102 116 129 133 140 183 f1 000662 constant label dcl 169 ref 160 found 000335 constant label dcl 112 ref 106 get_segptr 001101 constant entry internal dcl 200 ref 81 128 182 give 000362 constant label dcl 114 ref 110 list 000733 constant entry external dcl 179 nop 001065 constant label dcl 193 ref 188 190 rje_args 000054 constant entry external dcl 11 set 000433 constant entry external dcl 125 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1506 1640 1302 1516 Length 2046 1302 132 172 203 64 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME rje_args 256 external procedure is an external procedure. get_segptr internal procedure shares stack frame of external procedure rje_args. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 en rje_args 000020 dn rje_args 000072 segptr rje_args STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME rje_args 000100 ap rje_args 000102 al rje_args 000103 answer rje_args 000156 ec rje_args 000157 i rje_args 000160 af_sw rje_args 000161 string rje_args THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_ext_out_desc call_ext_out return shorten_stack ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. active_fnc_err_ adjust_bit_count_ com_err_ cu_$af_arg_count cu_$af_arg_ptr cu_$af_return_arg cu_$arg_count cu_$arg_ptr get_pdir_ hcs_$make_seg ioa_ unique_chars_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_arg error_table_$not_act_fnc error_table_$wrong_no_of_args LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 27 000050 11 000053 68 000062 70 000064 71 000075 72 000103 74 000105 75 000115 76 000120 77 000123 80 000124 81 000131 82 000133 83 000140 85 000162 86 000201 90 000202 92 000223 93 000241 97 000246 98 000255 99 000262 101 000267 102 000272 105 000273 106 000303 108 000325 109 000327 110 000334 112 000335 113 000350 114 000362 115 000364 116 000401 117 000406 118 000417 120 000420 121 000431 125 000432 127 000441 128 000446 129 000450 132 000455 133 000473 135 000475 136 000504 137 000511 139 000516 140 000521 143 000522 145 000525 146 000544 147 000546 148 000556 149 000567 150 000573 151 000575 153 000601 154 000603 157 000604 158 000614 160 000634 162 000635 163 000637 165 000650 166 000651 168 000654 169 000662 170 000672 171 000673 173 000676 175 000731 179 000732 181 000741 182 000746 183 000750 186 000755 187 000773 188 001003 189 001014 190 001017 191 001027 192 001064 193 001065 194 001067 196 001100 200 001101 204 001103 205 001112 207 001145 209 001205 210 001210 211 001213 212 001217 213 001222 214 001234 215 001237 216 001242 217 001254 218 001257 219 001262 222 001274 ----------------------------------------------------------- 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