COMPILATION LISTING OF SEGMENT reduction_compiler Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 11/01/84 0826.9 mst Thu Options: optimize map 1 2 /* *************************************************************** 3* * * 4* * * 5* * Copyright (c) 1975 by Massachusetts Institute of Technology * 6* * * 7* * * 8* *************************************************************** */ 9 10 11 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 12 /* */ 13 /* Status */ 14 /* */ 15 /* 1) Modified: February, 1981 by G. C. Dixon */ 16 /* a) Add the -trace ctl_arg to invoke the internal tracing facility provided by the */ 17 /* SEMANTIC_ANALYSIS routine. When a translator is compiled with -trace, a */ 18 /* special trace routine is invoked each time a reduction is matched. This */ 19 /* routine prints the matching reduction (as it appears in the .rd source), */ 20 /* followed by the tokens which matched the reduction. */ 21 /* b) Upgrade code to 1981 coding standards. */ 22 /* 2) Modified: July 24, 1983 by G. C. Dixon */ 23 /* a) Change long name from reduction_compiler to reductions. Name */ 24 /* reduction_compiler will be retained for compatibility but will be undocumented. */ 25 /* b) Make rdc invoke the pl1 command to compile the generated source, iff the rdc */ 26 /* translation was successful. */ 27 /* c) Make rdc set a severity variable accessible by the severity AF to indicate the */ 28 /* results of both the rdc and pl1 translations. */ 29 /* 3) Modified: Sep 10, 1984 by G. C. Dixon to change name in error messages from */ 30 /* reduction_compiler to reductions. This was left out of change 2 above. */ 31 /* */ 32 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 33 34 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 35 36 37 reduction_compiler: 38 reductions: 39 rdc: procedure; 40 41 dcl /* automatic variables */ 42 Iarg fixed bin, 43 Larg fixed bin, /* length of our input argument. */ 44 Lobject fixed bin(21), /* length of output object segment (in chars). */ 45 Lsource fixed bin(21), /* length of input source segment (in chars). */ 46 Nargs fixed bin, /* number of input arguments. */ 47 Parea ptr, /* ptr to our temporary allocation segment. */ 48 Pacl_obj ptr, /* ptr to object seg's acl-info structure. */ 49 Parg ptr, /* ptr to our input argument. */ 50 Pobject ptr, /* ptr to object segment we're creating. */ 51 Psource ptr, /* ptr to input source segment. */ 52 1 Scontrol aligned, 53 (2 long bit(1), 54 2 brief bit(1), 55 2 trace bit(1), 56 2 trace_on_by_default bit(1), 57 2 pad bit(32)) unal, /* reduction_compiler_ control switches. */ 58 bc_source fixed bin(24), /* bit count of source segment. */ 59 cleanup condition, 60 code fixed bin(35), /* a status code. */ 61 dir char(168), /* dir part of source segment's path name. */ 62 ent_source char(32), /* ent part of source segment's path name. */ 63 ent_object char(32), /* ent part of object segment's path name. */ 64 pl1_args char(300) varying; /* Args to be passed to pl1 compiler. */ 65 66 dcl /* based variables */ 67 arg char(Larg) based (Parg); 68 /* our input argument. */ 69 70 dcl /* builtin functions */ 71 (addr, divide, index, length, max, null, string, substr) 72 builtin; 73 74 75 dcl /* entries and functions */ 76 com_err_ entry options (variable), 77 cu_$arg_count entry (fixed bin, fixed bin(35)), 78 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)), 79 cu_$cp entry (ptr, fixed bin(21), fixed bin(35)), 80 expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)), 81 get_wdir_ entry returns (char(168) aligned), 82 hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, 83 fixed bin(35)), 84 hcs_$terminate_noname entry (ptr, fixed bin(35)), 85 hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)), 86 ioa_$nnl entry options(variable), 87 pathname_ entry (char(*), char(*)) returns(char(168)), 88 reduction_compiler_ entry (ptr, fixed bin(21), ptr, ptr, fixed bin(21), char(32), bit(*), 89 fixed bin(35), fixed bin(35)), 90 requote_string_ entry (char(*)) returns(char(*)), 91 suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(32), fixed bin(35)), 92 translator_temp_$get_segment entry (char(*) aligned, ptr, fixed bin(35)), 93 translator_temp_$release_all_segments 94 entry (ptr, fixed bin(35)), 95 tssi_$clean_up_segment entry (ptr), 96 tssi_$finish_segment entry (ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)), 97 tssi_$get_segment entry (char(*), char(*), ptr, ptr, fixed bin(35)); 98 99 dcl /* static variables */ 100 (error_table_$mdc_path_dup_args, 101 error_table_$no_makeknown, 102 error_table_$noentry, 103 error_table_$wrong_no_of_args) 104 fixed bin(35) ext static, 105 pl1_severity_ fixed bin(35) ext static init(0), 106 proc char(10) aligned int static init ("reductions"), 107 reductions_severity_ fixed bin(35) ext static init(0), 108 sys_info$max_seg_size fixed bin(35) ext static; 109 110 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 111 112 call cu_$arg_count (Nargs, code); /* if we have less than one arg, complain. */ 113 if code ^= 0 then go to NOT_AF; 114 if Nargs < 1 then go to WNOA; 115 string(Scontrol) = "0"b; 116 ent_source = ""; 117 pl1_args = ""; 118 do Iarg = 1 to Nargs; 119 call cu_$arg_ptr (Iarg, Parg, Larg, code); 120 if arg = "-lg" | arg = "-long" then 121 Scontrol.long = "1"b; 122 else if arg = "-bf" | arg = "-brief" then 123 Scontrol.brief = "1"b; 124 else if arg = "-trace" then do; 125 Scontrol.trace = "1"b; 126 Scontrol.trace_on_by_default = "1"b; 127 if Iarg < Nargs then do; 128 Iarg = Iarg + 1; 129 call cu_$arg_ptr (Iarg, Parg, Larg, code); 130 if arg = "on" then; 131 else if arg = "off" then 132 Scontrol.trace_on_by_default = "0"b; 133 else 134 Iarg = Iarg - 1; 135 end; 136 end; 137 else if arg = "-no_trace" then 138 Scontrol.trace = "0"b; 139 140 else if index(arg,"-") ^= 1 then do; 141 if ent_source ^= "" then go to DUP_PATH; 142 call expand_pathname_$add_suffix (arg, "rd", dir, ent_source, code); 143 if code ^= 0 then go to BAD_PATH; 144 call suffixed_name_$new_suffix (ent_source, "rd", "pl1", ent_object, code); 145 if code ^= 0 then go to BAD_SOURCE; 146 end; 147 148 else do; /* A pl1 option? Let pl1 diagnose it. */ 149 if arg = "-prefix" & Iarg < Nargs then do; 150 Iarg = Iarg + 1; 151 call cu_$arg_ptr (Iarg, Parg, Larg, code); 152 pl1_args = pl1_args || " "; 153 pl1_args = pl1_args || "-prefix"; 154 pl1_args = pl1_args || " "; 155 pl1_args = pl1_args || requote_string_(arg); 156 end; 157 else do; 158 pl1_args = pl1_args || " "; 159 pl1_args = pl1_args || arg; 160 end; 161 end; 162 end; 163 Parea = null; 164 Psource = null; 165 Pobject = null; /* initialize ptrs used by cleanup on-unit. */ 166 on cleanup call cleaner; /* cleanup when required. */ 167 168 169 call hcs_$initiate_count (dir, ent_source, "", bc_source, 0, Psource, code); 170 if Psource = null then go to BAD_SOURCE; /* initiate source segment. */ 171 Lsource = divide (bc_source, 9, 35, 0); /* convert bit count to character count. */ 172 173 call translator_temp_$get_segment (proc, Parea, code); 174 if Parea = null then go to BAD_AREA; 175 dir = get_wdir_(); /* put object segment in working directory. */ 176 call tssi_$get_segment (dir, ent_object, Pobject, Pacl_obj, code); 177 if code ^= 0 then go to BAD_OBJECT; /* get ptr to object segment we're creating. */ 178 Lobject = sys_info$max_seg_size * 4; 179 call ioa_$nnl ("RDC - "); 180 call reduction_compiler_ (Psource, Lsource, Parea, Pobject, Lobject, 181 ent_source, string(Scontrol), reductions_severity_, code); 182 if Lobject = 0 then /* create object segment. If 0 length, ERROR. */ 183 call hcs_$truncate_seg (Pobject, 0, 0); 184 call tssi_$finish_segment (Pobject, Lobject * 9, "1000"b, Pacl_obj, 0); 185 /* finish up the object segment. */ 186 Pobject = null; /* cleanup now. */ 187 call cleaner; 188 if code ^= 0 then go to ERROR; 189 190 pl1_args = "[where pl1]$pl1 " || pathname_ (dir, ent_object) || pl1_args; 191 call cu_$cp (addr(substr(pl1_args,1)), length(pl1_args), code); 192 reductions_severity_ = max(reductions_severity_, pl1_severity_); 193 return; 194 195 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 196 197 198 cleaner: proc; /* cleanup procedure. */ 199 200 dcl code fixed bin(35); /* It has its own status code. */ 201 202 if Psource ^= null then 203 call hcs_$terminate_noname (Psource, code); 204 if Parea ^= null then 205 call translator_temp_$release_all_segments (Parea, code); 206 if Pobject ^= null then 207 call tssi_$clean_up_segment (Pacl_obj); 208 209 end cleaner; 210 211 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 212 213 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 214 215 DUP_PATH: call com_err_ (error_table_$mdc_path_dup_args, proc, "^a 216 Only one pathname may be given.", arg); 217 return; 218 219 NOT_AF: call com_err_ (code, proc); 220 return; 221 222 WNOA: call com_err_ (error_table_$wrong_no_of_args, proc, 223 "^/Calling sequence:^-reductions pathname {-ctl_args} 224 control_arg is:^--long, -lg^/^2--brief,-bf^/^2--trace {on|off}^/^2--no_trace, -ntrace"); 225 return; 226 227 BAD_PATH: call com_err_ (code, proc, " ^a", arg); 228 return; 229 230 BAD_SOURCE: 231 if code = error_table_$no_makeknown then code = error_table_$noentry; 232 call com_err_ (code, proc, " ^a^[>^]^a", dir, dir^=">", ent_source); 233 return; 234 235 BAD_AREA: call com_err_ (code, proc, "^/While creating a temporary segment in the process directory."); 236 call cleaner; 237 return; 238 239 BAD_OBJECT: 240 call com_err_ (code, proc, "^/While creating the object segment^/(^a^[>^]^a).", dir, dir^=">", ent_object); 241 call cleaner; 242 return; 243 244 ERROR: call com_err_ (code, proc, "^/No object segment will be generated."); 245 return; 246 247 end reduction_compiler; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/01/84 0825.4 reduction_compiler.pl1 >special_ldd>online>6967-11/01/84>reduction_compiler.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. Iarg 000100 automatic fixed bin(17,0) dcl 41 set ref 118* 119* 127 128* 128 129* 133* 133 149 150* 150 151* Larg 000101 automatic fixed bin(17,0) dcl 41 set ref 119* 120 120 122 122 124 129* 130 131 137 140 142 142 149 151* 155 155 159 215 215 227 227 Lobject 000102 automatic fixed bin(21,0) dcl 41 set ref 178* 180* 182 184 Lsource 000103 automatic fixed bin(21,0) dcl 41 set ref 171* 180* Nargs 000104 automatic fixed bin(17,0) dcl 41 set ref 112* 114 118 127 149 Pacl_obj 000110 automatic pointer dcl 41 set ref 176* 184* 206* Parea 000106 automatic pointer dcl 41 set ref 163* 173* 174 180* 204 204* Parg 000112 automatic pointer dcl 41 set ref 119* 120 120 122 122 124 129* 130 131 137 140 142 149 151* 155 159 215 227 Pobject 000114 automatic pointer dcl 41 set ref 165* 176* 180* 182* 184* 186* 206 Psource 000116 automatic pointer dcl 41 set ref 164* 169* 170 180* 202 202* Scontrol 000120 automatic structure level 1 dcl 41 set ref 115* 180 180 addr builtin function dcl 70 ref 191 191 arg based char unaligned dcl 66 set ref 120 120 122 122 124 130 131 137 140 142* 149 155* 159 215* 227* bc_source 000121 automatic fixed bin(24,0) dcl 41 set ref 169* 171 brief 0(01) 000120 automatic bit(1) level 2 packed unaligned dcl 41 set ref 122* cleanup 000122 stack reference condition dcl 41 ref 166 code 000100 automatic fixed bin(35,0) dcl 200 in procedure "cleaner" set ref 202* 204* code 000130 automatic fixed bin(35,0) dcl 41 in procedure "rdc" set ref 112* 113 119* 129* 142* 143 144* 145 151* 169* 173* 176* 177 180* 188 191* 219* 227* 230 230* 232* 235* 239* 244* com_err_ 000014 constant entry external dcl 75 ref 215 219 222 227 232 235 239 244 cu_$arg_count 000016 constant entry external dcl 75 ref 112 cu_$arg_ptr 000020 constant entry external dcl 75 ref 119 129 151 cu_$cp 000022 constant entry external dcl 75 ref 191 dir 000131 automatic char(168) unaligned dcl 41 set ref 142* 169* 175* 176* 190* 232* 232 239* 239 divide builtin function dcl 70 ref 171 ent_object 000213 automatic char(32) unaligned dcl 41 set ref 144* 176* 190* 239* ent_source 000203 automatic char(32) unaligned dcl 41 set ref 116* 141 142* 144* 169* 180* 232* error_table_$mdc_path_dup_args 000062 external static fixed bin(35,0) dcl 99 set ref 215* error_table_$no_makeknown 000064 external static fixed bin(35,0) dcl 99 ref 230 error_table_$noentry 000066 external static fixed bin(35,0) dcl 99 ref 230 error_table_$wrong_no_of_args 000070 external static fixed bin(35,0) dcl 99 set ref 222* expand_pathname_$add_suffix 000024 constant entry external dcl 75 ref 142 get_wdir_ 000026 constant entry external dcl 75 ref 175 hcs_$initiate_count 000030 constant entry external dcl 75 ref 169 hcs_$terminate_noname 000032 constant entry external dcl 75 ref 202 hcs_$truncate_seg 000034 constant entry external dcl 75 ref 182 index builtin function dcl 70 ref 140 ioa_$nnl 000036 constant entry external dcl 75 ref 179 length builtin function dcl 70 ref 191 191 long 000120 automatic bit(1) level 2 packed unaligned dcl 41 set ref 120* max builtin function dcl 70 ref 192 null builtin function dcl 70 ref 163 164 165 170 174 186 202 204 206 pathname_ 000040 constant entry external dcl 75 ref 190 pl1_args 000223 automatic varying char(300) dcl 41 set ref 117* 152* 152 153* 153 154* 154 155* 155 158* 158 159* 159 190* 190 191 191 191 191 pl1_severity_ 000072 external static fixed bin(35,0) initial dcl 99 ref 192 proc 000010 internal static char(10) initial dcl 99 set ref 173* 215* 219* 222* 227* 232* 235* 239* 244* reduction_compiler_ 000042 constant entry external dcl 75 ref 180 reductions_severity_ 000074 external static fixed bin(35,0) initial dcl 99 set ref 180* 192* 192 requote_string_ 000044 constant entry external dcl 75 ref 155 string builtin function dcl 70 set ref 115* 180 180 substr builtin function dcl 70 ref 191 191 suffixed_name_$new_suffix 000046 constant entry external dcl 75 ref 144 sys_info$max_seg_size 000076 external static fixed bin(35,0) dcl 99 ref 178 trace 0(02) 000120 automatic bit(1) level 2 packed unaligned dcl 41 set ref 125* 137* trace_on_by_default 0(03) 000120 automatic bit(1) level 2 packed unaligned dcl 41 set ref 126* 131* translator_temp_$get_segment 000050 constant entry external dcl 75 ref 173 translator_temp_$release_all_segments 000052 constant entry external dcl 75 ref 204 tssi_$clean_up_segment 000054 constant entry external dcl 75 ref 206 tssi_$finish_segment 000056 constant entry external dcl 75 ref 184 tssi_$get_segment 000060 constant entry external dcl 75 ref 176 NAMES DECLARED BY EXPLICIT CONTEXT. BAD_AREA 001522 constant label dcl 235 ref 174 BAD_OBJECT 001553 constant label dcl 239 ref 177 BAD_PATH 001414 constant label dcl 227 ref 143 BAD_SOURCE 001447 constant label dcl 230 ref 145 170 DUP_PATH 001315 constant label dcl 215 set ref 141 ERROR 001625 constant label dcl 244 ref 188 NOT_AF 001351 constant label dcl 219 set ref 113 WNOA 001367 constant label dcl 222 ref 114 cleaner 001653 constant entry internal dcl 198 ref 166 187 236 241 rdc 000206 constant entry external dcl 37 reduction_compiler 000224 constant entry external dcl 37 reductions 000215 constant entry external dcl 37 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2324 2424 1735 2334 Length 2664 1735 100 223 367 4 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME rdc 340 external procedure is an external procedure. on unit on line 166 64 on unit cleaner 72 internal procedure is called by several nonquick procedures. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 proc rdc STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cleaner 000100 code cleaner rdc 000100 Iarg rdc 000101 Larg rdc 000102 Lobject rdc 000103 Lsource rdc 000104 Nargs rdc 000106 Parea rdc 000110 Pacl_obj rdc 000112 Parg rdc 000114 Pobject rdc 000116 Psource rdc 000120 Scontrol rdc 000121 bc_source rdc 000130 code rdc 000131 dir rdc 000203 ent_source rdc 000213 ent_object rdc 000223 pl1_args rdc THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_ne_as alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return enable shorten_stack ext_entry int_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ cu_$arg_count cu_$arg_ptr cu_$cp expand_pathname_$add_suffix get_wdir_ hcs_$initiate_count hcs_$terminate_noname hcs_$truncate_seg ioa_$nnl pathname_ reduction_compiler_ requote_string_ suffixed_name_$new_suffix translator_temp_$get_segment translator_temp_$release_all_segments tssi_$clean_up_segment tssi_$finish_segment tssi_$get_segment THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$mdc_path_dup_args error_table_$no_makeknown error_table_$noentry error_table_$wrong_no_of_args pl1_severity_ reductions_severity_ sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 37 000205 112 000231 113 000241 114 000243 115 000246 116 000247 117 000252 118 000253 119 000261 120 000276 122 000313 124 000326 125 000332 126 000334 127 000336 128 000341 129 000342 130 000357 131 000366 133 000375 136 000377 137 000400 140 000407 141 000421 142 000425 143 000463 144 000465 145 000521 146 000523 149 000524 150 000533 151 000534 152 000551 153 000560 154 000572 155 000601 156 000641 158 000643 159 000652 162 000664 163 000666 164 000670 165 000671 166 000672 169 000714 170 000756 171 000762 173 000765 174 001006 175 001012 176 001024 177 001054 178 001056 179 001062 180 001074 182 001143 184 001162 186 001207 187 001211 188 001215 190 001217 191 001266 192 001306 193 001314 215 001315 217 001350 219 001351 220 001366 222 001367 225 001413 227 001414 228 001446 230 001447 232 001455 233 001521 235 001522 236 001546 237 001552 239 001553 241 001620 242 001624 244 001625 245 001651 198 001652 202 001660 204 001675 206 001713 209 001727 ----------------------------------------------------------- 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