COMPILATION LISTING OF SEGMENT pl1_macro Compiled by: Multics PL/I Compiler, Release 32f, of October 9, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 10/09/89 0904.2 mst Mon Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(89-10-02,Blackmore), approve(89-10-02,MCR8138), audit(89-10-03,Vu), 17* install(89-10-09,MR12.3-1087): 18* Make consistent with 'pl1_macro_lex_' in use of 'translator_temp_' for 19* area management. 20* END HISTORY COMMENTS */ 21 22 23 /* format: style2 */ 24 pl1_macro: 25 pmac: 26 procedure; 27 28 /* Free standing command to macro_process a pl1 segment: 29* 1. Usual command line scan. 30* 2. set up temp_seg_3 for call to pl1_lex_ 31* 3. ... 32* 4. Produce an XREF listing, if requested. 33* 5. Clean-up pl1_macro. 34* 6. Produce the output segment. 35* 7. Usual cleanup. 36* 37* Written 30 Nov 79 by Marshall Presser 38* Modified: The first half of 1981, ending July 28, to make it work and for auditing, MEP 39**/ 40 41 /* automatic */ 42 43 declare arg_count fixed binary; 44 declare arg_length fixed binary (21); 45 declare arg_ptr pointer; 46 declare argument_no fixed binary; 47 declare argx fixed binary; 48 declare bit_count fixed binary (24); 49 declare 1 ca, 50 2 list bit (1), 51 2 pd bit (1), 52 2 print bit (1), 53 2 target bit (1), 54 2 version bit (1); 55 declare call_length fixed binary (21); 56 declare call_ptr pointer; 57 declare cannon_name char (32); 58 declare clargx fixed binary; 59 declare code fixed binary (35); 60 declare data_type fixed binary (8) unsigned; 61 declare in_dname char (168); 62 declare in_ename char (32); 63 declare in_seg_ptr pointer; 64 declare in_seg_length fixed binary (21); 65 declare language_suffix char (16) varying; 66 declare n_chars_left fixed binary (2); 67 declare n_words fixed binary (19); 68 declare needs_cleanup bit (1); 69 declare num_of_clargs fixed binary (17); 70 declare num_of_params fixed binary (17); 71 72 declare out_dname char (168); 73 declare out_ename char (32); 74 declare out_seg_ptr pointer; 75 declare out_seg_length fixed binary (21); 76 declare output_length fixed binary (21); 77 declare output_ptr pointer; 78 declare real_seg_name character (32) varying; 79 declare source_length fixed binary (21); 80 declare source_ptr pointer; 81 declare target_length fixed binary (21); 82 declare target_ptr pointer; 83 declare target_value fixed binary (17); 84 declare temp_target char (32); 85 declare trans_temp_ptr pointer; 86 87 /* based */ 88 89 declare arg_string char (arg_length) based (arg_ptr); 90 declare call_string char (call_length) based (call_ptr); 91 declare in_seg char (in_seg_length) based (in_seg_ptr); 92 declare out_seg char (out_seg_length) based (out_seg_ptr); 93 declare result_string char (output_length) based (output_ptr); 94 declare target_string char (target_length) based (target_ptr); 95 96 97 /* builtin */ 98 99 declare (addr, baseno, divide, index, low, length, mod, null, reverse, rtrim, search, string, substr, verify) 100 builtin; 101 102 /* condition */ 103 104 declare cleanup condition; 105 106 /* internal static */ 107 108 declare MINUS_SIGN char (1) internal static options (constant) initial ("-"); 109 declare suffix char (4) internal static options (constant) initial ("pmac"); 110 111 /* external static */ 112 113 declare ( 114 error_table_$badopt, 115 error_table_$inconsistent, 116 error_table_$noarg 117 ) fixed binary (35) external static; 118 declare iox_$user_output pointer external static; 119 120 /* entry */ 121 122 declare com_err_ entry options (variable); 123 declare com_err_$suppress_name entry options (variable); 124 declare cu_$arg_count entry (fixed bin, fixed bin (35)); 125 declare cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); 126 declare cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); 127 declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35)); 128 declare expand_pathname_$add_suffix 129 entry (char (*), char (*), char (*), char (*), fixed bin (35)); 130 declare get_pdir_ entry returns (char (168)); 131 declare get_system_free_area_ entry () returns (pointer); 132 declare get_temp_segments_ entry (char (*), (*) pointer, fixed binary (35)); 133 declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), 134 pointer, fixed binary (35)); 135 declare hcs_$make_seg entry (char (*), char (*), char (*), fixed binary (5), pointer, 136 fixed binary (35)); 137 declare hcs_$set_bc_seg entry (pointer, fixed binary (24), fixed binary (35)); 138 declare hcs_$terminate_noname entry (pointer, fixed binary (35)); 139 declare hcs_$truncate_seg entry (pointer, fixed binary (19), fixed binary (35)); 140 declare ioa_ entry options (variable); 141 declare iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35)); 142 declare pathname_ entry (char (*), char (*)) returns (char (168)); 143 declare release_temp_segments_ entry (char (*), (*) pointer, fixed binary (35)); 144 declare translator_temp_$get_segment 145 entry (char (*), ptr, fixed bin (35)); 146 declare translator_temp_$release_all_segments 147 entry (ptr, fixed bin (35)); 148 1 1 /* Begin include file pl1_macro_lex_dcls.incl.pl1 */ 1 2 1 3 1 4 /****^ HISTORY COMMENTS: 1 5* 1) change(87-05-11,Huen), approve(87-05-11,MCR7675), 1 6* audit(87-05-11,RWaters), install(87-12-01,MR12.2-1005): 1 7* Fix PL/1 bug2163 : Speeding up the macro processing. 1 8* END HISTORY COMMENTS */ 1 9 1 10 /* format: style2 */ 1 11 1 12 /* Created Dec 80 M E Presser 1 13* Modified 1 14* 11 May 87 - SH, speeding up the macro processing 1 15* 3 August 81 - MEP redefined token 1 16* 18 May 81 - MEP, redefined token, temp_seg_3, and token types 1 17**/ 1 18 1 19 /* automatic */ 1 20 1 21 declare temp_segs (5) pointer; 1 22 1 23 /* use of temp_segs: 1 24* 1. tokens in pl1_macro_lex_ 1 25* 2. output_string 1 26* 3. job information 1 27* 4. listing and cross_ref 1 28* 5. Unused just now 1 29**/ 1 30 /* area */ 1 31 1 32 declare area area based (temp_seg_3.area_ptr); 1 33 1 34 /* based */ 1 35 1 36 declare 1 atoken aligned based, 1 37 2 string_size fixed binary (21) unaligned, 1 38 /* length of token string */ 1 39 2 created bit (1) unaligned, /* "1" iff created by pl1_macro */ 1 40 2 pct_type fixed binary (5) unsigned unaligned, 1 41 2 type fixed binary (8) unsigned unaligned, 1 42 /* token_type */ 1 43 2 replace_by fixed binary, /* index of replacement value, if any */ 1 44 2 string_ptr unaligned pointer; /* pointer to start of token */ 1 45 1 46 declare 1 token (divide (sys_info$max_seg_size, size (atoken), 19)) aligned based (temp_segs (1)) 1 47 like atoken; 1 48 1 49 /* builtin */ 1 50 1 51 declare size builtin; 1 52 1 53 /* structure for command line args */ 1 54 1 55 declare 1 args aligned based, 1 56 2 string_size fixed binary (21), 1 57 2 string_ptr unaligned pointer; 1 58 1 59 /* structure for command line parameter control arg arguments */ 1 60 1 61 declare 1 params aligned based, 1 62 2 name aligned like args, 1 63 2 value aligned like token; 1 64 1 65 /* temp_seg_3 is used for general storage of system wide information */ 1 66 1 67 declare 1 temp_seg_3 aligned based (temp_segs (3)), 1 68 2 area_ptr pointer, /* base of area */ 1 69 2 source_ptr pointer, /* ptr to source seg */ 1 70 2 source_length fixed binary (21), /* lenght (chars) of source */ 1 71 2 output_length fixed binary (21), /* length (chars) of output */ 1 72 2 constant_base pointer, /* start of chain of constant nodes */ 1 73 2 variable_base pointer, /* start of chain of variable nodes */ 1 74 2 source_depth fixed binary, /* depth of file_macro_stack */ 1 75 2 file_stack_ptr pointer, /* ptr -> file_macro_stack */ 1 76 2 flags unaligned, 1 77 3 list bit (1), /* if .maclist to be made */ 1 78 3 pad1 bit (35), 1 79 2 target_value fixed binary (17), /* as returned by system_type_ */ 1 80 2 number_of_clargs fixed binary, 1 81 2 number_of_params fixed binary, 1 82 2 cl_args (64) aligned like args, 1 83 2 cl_params (64) aligned like params; 1 84 1 85 1 86 declare output_string char (4 * sys_info$max_seg_size) based (temp_segs (2)); 1 87 1 88 /* variable node */ 1 89 1 90 declare 1 variable aligned based, 1 91 2 next pointer unaligned, /* next alloc in chain */ 1 92 2 nextv pointer unaligned, /* next var in hash chain */ 1 93 2 alias_id fixed binary (17) unaligned, 1 94 /* index into token chain */ 1 95 2 variable_type fixed binary unaligned, /* default, replace or set type */ 1 96 2 name_length fixed binary (17) unaligned, 1 97 2 name character (variable_name_length refer (variable.name_length)); 1 98 1 99 declare variable_name_length fixed binary; 1 100 1 101 /* constant node */ 1 102 1 103 declare 1 constant aligned based, 1 104 2 next pointer, /* next in chain */ 1 105 2 string_length fixed binary (21), 1 106 2 string_value character (constant_length refer (constant.string_length)); 1 107 1 108 declare constant_length fixed binary (21); 1 109 1 110 /* token types */ 1 111 1 112 declare ( 1 113 no_token initial (0), 1 114 invalid_char initial (1), 1 115 identifier initial (2), 1 116 keyword_token initial (3), 1 117 isub initial (4), 1 118 plus initial (5), 1 119 minus initial (6), 1 120 asterisk initial (7), 1 121 slash initial (8), 1 122 expon initial (9), 1 123 not initial (10), 1 124 and initial (11), 1 125 or initial (12), 1 126 cat initial (13), 1 127 eq initial (14), 1 128 ne initial (15), 1 129 lt initial (16), 1 130 gt initial (17), 1 131 le initial (18), 1 132 ge initial (19), 1 133 ngt initial (20), 1 134 nlt initial (21), 1 135 prefix_plus initial (22), 1 136 prefix_minus initial (23), 1 137 assignment initial (24), 1 138 colon initial (25), 1 139 semi_colon initial (26), 1 140 comma initial (27), 1 141 period initial (28), 1 142 arrow initial (29), 1 143 left_parn initial (30), 1 144 right_parn initial (31), 1 145 percent initial (32), 1 146 target_comma initial (33), 1 147 comment_token initial (34), 1 148 nl_vt_np_token initial (35), 1 149 bit_string initial (36), 1 150 char_string initial (37), 1 151 fixed_bin initial (38), 1 152 bin_integer initial (39), 1 153 fixed_dec initial (40), 1 154 dec_integer initial (41), 1 155 float_bin initial (42), 1 156 token_hole_1 initial (43), 1 157 float_dec initial (44), 1 158 token_hole_2 initial (45), 1 159 i_fixed_bin initial (46), 1 160 i_bin_integer initial (47), 1 161 i_fixed_dec initial (48), 1 162 i_dec_integer initial (49), 1 163 i_float_bin initial (50), 1 164 token_hole_3 initial (51), 1 165 i_float_dec initial (52), 1 166 token_hole_4 initial (53), 1 167 white_space_token initial (54) 1 168 ) fixed binary (8) unsigned internal static options (constant); 1 169 1 170 /* token class limits */ 1 171 1 172 declare ( 1 173 min_delimiter_token initial (5), 1 174 max_delimiter_token initial (35), 1 175 min_constant_token initial (36), 1 176 max_constant_token initial (53), 1 177 min_arithmetic_token initial (38), 1 178 max_arithmetic_token initial (53) 1 179 ) fixed binary (8) unsigned internal static options (constant); 1 180 1 181 /* arithmetic token type masks */ 1 182 1 183 declare ( 1 184 is_imaginary_constant initial ("1000"b), 1 185 is_float_constant initial ("0100"b), 1 186 is_decimal_constant initial ("0010"b), 1 187 is_integral_constant initial ("0001"b) 1 188 ) bit (4) aligned internal static options (constant); 1 189 1 190 /* valid keyword following a percent_sign and their attributes */ 1 191 1 192 /* format: off */ 1 193 1 194 declare 1 pct_keywords (19) aligned structure internal static options (constant), 1 195 2 name character (8) varying 1 196 initial( 1 197 "page", "skip", "replace", "default", "target", "isarg", "isdef", 1 198 "include","if", "then", "else", "elseif", "endif", "print", 1 199 "error", "warn", "abort", "INCLUDE", "set"), 1 200 1 201 2 terminator fixed binary (17) unaligned /* refer to macro stack types */ 1 202 initial( 1 203 3, 3, 3, 3, 1, 1, 1, 1 204 3, 2, 2, 2, 2, 2, 3, 1 205 3, 3, 3, 3, 3), 1 206 1 207 2 needs_reinterpreation bit (1) unaligned 1 208 initial( 1 209 "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, 1 210 "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, 1 211 "1"b, "1"b, "1"b, "1"b, "1"b), 1 212 1 213 2 m_index fixed binary (17) unaligned 1 214 initial( 1 215 2, 3, 4, 1, 7, 8, 6, 1 216 15, 9, 10, 11, 12, 13, 16, 1 217 5, 17, 18, 14, 19); 1 218 1 219 /* format: on */ 1 220 1 221 /* pct_types */ 1 222 1 223 declare ( 1 224 pct_default initial (1), 1 225 pct_page initial (2), 1 226 pct_skip initial (3), 1 227 pct_replace initial (4), 1 228 pct_error initial (5), 1 229 pct_isdef initial (6), 1 230 pct_target initial (7), 1 231 pct_isarg initial (8), 1 232 pct_if initial (9), 1 233 pct_then initial (10), 1 234 pct_else initial (11), 1 235 pct_elseif initial (12), 1 236 pct_endif initial (13), 1 237 pct_INCLUDE initial (14), 1 238 pct_include initial (15), 1 239 pct_print initial (16), 1 240 pct_warn initial (17), 1 241 pct_abort initial (18), 1 242 pct_set initial (19) 1 243 ) fixed binary internal static options (constant); 1 244 1 245 /* variable types - in which statement type they were first declared */ 1 246 1 247 declare ( 1 248 replace_var initial (1), 1 249 default_var initial (2), 1 250 set_var initial (3), 1 251 parameter_var initial (4) 1 252 ) fixed binary internal static options (constant); 1 253 1 254 /* macro stack types */ 1 255 1 256 declare ( 1 257 paren_macro initial (1), 1 258 if_macro initial (2), 1 259 semicolon_macro initial (3), 1 260 reinterpret_macro initial (4) 1 261 ) fixed binary internal static options (constant); 1 262 1 263 /* lexical limits */ 1 264 1 265 declare ( 1 266 max_bit_string_constant 1 267 initial (253), 1 268 max_char_string_constant 1 269 initial (254), 1 270 max_identifier_length initial (256) 1 271 ) fixed binary internal static options (constant); 1 272 1 273 1 274 /* external static */ 1 275 1 276 declare pl1_macro_severity_ fixed binary (35) external static; 1 277 declare sys_info$max_seg_size fixed binary (19) external static; 1 278 1 279 /* entry */ 1 280 1 281 declare pl1_macro_error_ entry (fixed binary (35), char (*), pointer, fixed binary (21), fixed binary (21)); 1 282 declare pl1_macro_lex_ entry ((*) pointer, fixed binary (35)); 1 283 declare pl1_macro_lex_$cleanup entry ((*) pointer); 1 284 declare system_type_ entry (char (*), char (*), fixed binary (17), fixed binary (35)); 1 285 1 286 /* constants mostly used by lex */ 1 287 1 288 declare arithchar char (28) internal static options (constant) 1 289 initial ("0123456789(=^=<=>=+-*/) ."" 1 290 "); 1 291 declare alphabetics char (52) internal static options (constant) 1 292 initial ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"); 1 293 1 294 declare numerals char (10) internal static options (constant) initial ("0123456789"); 1 295 1 296 declare identifier_chars char (64) internal static options (constant) 1 297 initial ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"); 1 298 1 299 declare lower_case_letters char (26) internal static options (constant) initial ("abcdefghijklmnopqrstuvwxyz"); 1 300 declare upper_case_letters char (26) internal static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); 1 301 1 302 declare zero_one char (2) internal static options (constant) initial ("01"); 1 303 declare QUOTE char (1) internal static options (constant) initial (""""); 1 304 declare QUOTEQUOTE char (2) internal static options (constant) initial (""""""); 1 305 1 306 /* miscellaneous constants */ 1 307 1 308 declare none fixed binary internal static options (constant) initial (0); 1 309 1 310 declare macro_version character (5) internal static options (constant) initial (" 2.0 "); 1 311 declare command character (9) internal static options (constant) initial ("pl1_macro"); 1 312 1 313 /* error codes */ 1 314 1 315 declare NO_RESULT fixed binary (35) internal static options (constant) initial (1); 1 316 declare COMPILER_ERROR fixed binary (35) internal static options (constant) initial (2); 1 317 declare SYNTAX_ERROR fixed binary (35) internal static options (constant) initial (3); 1 318 declare SEMANTIC_ERROR fixed binary (35) internal static options (constant) initial (4); 1 319 declare STORAGE_SYSTEM_ERROR fixed binary (35) internal static options (constant) initial (5); 1 320 declare IMPLEMENTATION_RESTRICTION 1 321 fixed binary (35) internal static options (constant) initial (6); 1 322 declare TARGET_STRING_ERROR fixed binary (35) internal static options (constant) initial (7); 1 323 2 1 /* BEGIN INCLUDE FILE ... system_types.incl.pl1 ... 03/23/81 ... W. Olin Sibert */ 2 2 2 3 dcl L68_SYSTEM fixed bin (17) internal static options (constant) init (1); 2 4 dcl ADP_SYSTEM fixed bin (17) internal static options (constant) init (2); 2 5 2 6 dcl SYSTEM_TYPE_NAME (2) char (8) internal static options (constant) init 2 7 ("Level68", "ADP"); 2 8 2 9 /* END INCLUDE FILE ... system_types.incl.pl1 */ 1 324 1 325 1 326 /* END INCLUDE FILE . . . pl1_macro_lex_dcls.incl. */ 149 150 151 /* program */ 152 153 source_ptr = null; 154 output_ptr = null; 155 temp_segs (*) = null; 156 trans_temp_ptr = null; 157 call_ptr = null; 158 call_length = 0; 159 pl1_macro_severity_ = 5; 160 string (ca) = ""b; 161 ca.version = "1"b; 162 needs_cleanup = "0"b; 163 num_of_clargs = 0; 164 num_of_params = 0; 165 166 on cleanup call macro_cleanup; 167 168 call translator_temp_$get_segment (command, trans_temp_ptr, code); 169 if code ^= 0 170 then do; 171 call com_err_ (code, command, "Getting area segment in process directory."); 172 call macro_cleanup; 173 return; 174 end; 175 call get_temp_segments_ (command, temp_segs (*), code); 176 if code ^= 0 177 then do; 178 call com_err_ (code, command, "Getting temporary segments in process directory."); 179 call macro_cleanup; 180 return; 181 end; 182 183 output_ptr = temp_segs (2); 184 185 call cu_$arg_count (arg_count, code); 186 if code ^= 0 187 then do; 188 call com_err_ (code, command); 189 return; 190 end; 191 argument_no = 0; 192 do argx = 1 to arg_count; 193 call cu_$arg_ptr (argx, arg_ptr, arg_length, code); 194 if code ^= 0 195 then do; 196 call com_err_ (code, command, "Argument ^d.", argx); 197 call macro_cleanup; 198 return; 199 end; 200 201 if arg_string = "" 202 then ; 203 204 else if arg_string = "-print" | arg_string = "-pr" 205 then ca.print = "1"b; 206 207 else if arg_string = "-process_dir" | arg_string = "-pd" 208 then ca.pd = "1"b; 209 210 else if arg_string = "-version" | arg_string = "-ver" 211 then ca.version = "1"b; 212 213 else if arg_string = "-no_version" | arg_string = "-nver" 214 then ca.version = "0"b; 215 216 else if arg_string = "-list" | arg_string = "-ls" 217 then ca.list = "1"b; 218 219 else if arg_string = "-target" | arg_string = "-tgt" 220 then do; 221 ca.target = "1"b; 222 argx = argx + 1; 223 if argx > arg_count 224 then do; 225 call com_err_ (error_table_$noarg, command, "Missing target string after -target."); 226 call macro_cleanup; 227 return; 228 end; 229 230 call cu_$arg_ptr (argx, target_ptr, target_length, code); 231 if code ^= 0 232 then do; 233 call com_err_ (code, command, "Argument ^d.", argx); 234 call macro_cleanup; 235 return; 236 end; 237 else do; 238 temp_target = target_string; 239 call system_type_ (temp_target, cannon_name, target_value, code); 240 if code ^= 0 241 then do; 242 call com_err_ (code, command, "Invalid target string: ^a", target_string); 243 call macro_cleanup; 244 return; 245 end; 246 else do; 247 temp_seg_3.target_value = target_value; 248 end; 249 end; 250 251 end; 252 else if arg_string = "-call" 253 then do; 254 argx = argx + 1; 255 if argx > arg_count 256 then do; 257 call com_err_ (error_table_$noarg, command, "Missing call string after -call."); 258 call macro_cleanup; 259 return; 260 end; 261 262 call cu_$arg_ptr (argx, call_ptr, call_length, code); 263 if code ^= 0 264 then do; 265 call com_err_ (code, command, "Argument ^d.", argx); 266 call macro_cleanup; 267 return; 268 end; 269 270 end; 271 272 else if arg_string = "-parameter" | arg_string = "-pm" 273 then do; 274 argx = argx + 1; 275 num_of_params = num_of_params + 1; 276 if num_of_params >= 65 277 then do; 278 call com_err_ (0, command, "No more than 64 parameters permitted."); 279 call macro_cleanup; 280 return; 281 end; 282 283 if argx + 1 > arg_count 284 then do; 285 call com_err_ (error_table_$noarg, command, "Missing arguments after -pm."); 286 call macro_cleanup; 287 return; 288 end; 289 call cu_$arg_ptr (argx, arg_ptr, arg_length, code); 290 if code ^= 0 291 then do; 292 call com_err_ (code, command, "Argument ^d.", argx); 293 call macro_cleanup; 294 return; 295 end; 296 else do; 297 data_type = get_data_type (arg_string); 298 if data_type ^= identifier 299 then do; 300 call com_err_ (0, command, 301 "The first arg in a parameter pair must be an identifier: ^a", 302 arg_string); 303 call macro_cleanup; 304 return; 305 end; 306 else do; 307 temp_seg_3.cl_params (num_of_params).name.string_size = arg_length; 308 temp_seg_3.cl_params (num_of_params).name.string_ptr = arg_ptr; 309 end; 310 argx = argx + 1; 311 call cu_$arg_ptr (argx, arg_ptr, arg_length, code); 312 if code ^= 0 313 then do; 314 call com_err_ (code, command, "argument ^d.", argx); 315 call macro_cleanup; 316 return; 317 end; 318 319 data_type = get_data_type (arg_string); 320 if data_type = no_token 321 then do; 322 call com_err_ (0, command, "Wrong data type in command line arg: ^a", 323 arg_string); 324 call macro_cleanup; 325 return; 326 end; 327 else do; 328 temp_seg_3.cl_params (num_of_params).value.string_ptr = arg_ptr; 329 temp_seg_3.cl_params (num_of_params).value.string_size = arg_length; 330 temp_seg_3.cl_params (num_of_params).value.type = data_type; 331 temp_seg_3.cl_params (num_of_params).value.created = "0"b; 332 end; 333 end; 334 335 end; 336 337 else if arg_string = "-arguments" | arg_string = "-ag" 338 then do; 339 argx = argx + 1; 340 if argx > arg_count 341 then do; 342 call com_err_ (error_table_$noarg, command, "Missing arguments after -ag."); 343 call macro_cleanup; 344 return; 345 end; 346 num_of_clargs = arg_count - argx + 1; 347 do clargx = 1 to num_of_clargs; 348 call cu_$arg_ptr (argx, arg_ptr, arg_length, code); 349 if code ^= 0 350 then do; 351 call com_err_ (code, command, "Argument ^d.", argx); 352 call macro_cleanup; 353 return; 354 end; 355 else do; 356 temp_seg_3.cl_args (clargx).string_ptr = arg_ptr; 357 temp_seg_3.cl_args (clargx).string_size = arg_length; 358 end; 359 360 argx = argx + 1; 361 if argx >= 65 362 then do; 363 call com_err_ (0, command, "No more than 64 cl_args permitted."); 364 call macro_cleanup; 365 return; 366 end; 367 end; 368 end; 369 else if index (arg_string, "-") = 1 370 then do; 371 call com_err_ (error_table_$badopt, command, "^a", arg_string); 372 call macro_cleanup; 373 return; 374 end; 375 376 else do; 377 argument_no = argument_no + 1; 378 379 if argument_no = 1 380 then do; 381 in_seg_ptr = arg_ptr; 382 in_seg_length = arg_length; 383 end; 384 385 else if argument_no = 2 386 then do; 387 out_seg_ptr = arg_ptr; 388 out_seg_length = arg_length; 389 end; 390 end; 391 end; 392 393 if argument_no = 0 | argument_no > 2 394 then do; 395 call com_err_$suppress_name (0, command, "Usage: ^a in_path {out_path} {-control_args}", command); 396 call macro_cleanup; 397 return; 398 end; 399 400 if ca.pd & argument_no > 1 401 then do; 402 call com_err_ (error_table_$inconsistent, command, 403 "The -pd control argument is incompatible with an output path name."); 404 call macro_cleanup; 405 return; 406 end; 407 408 if ca.print & argument_no > 1 409 then do; 410 call com_err_ (error_table_$inconsistent, command, 411 "The -pr control argument is incompatible with an output path name."); 412 call macro_cleanup; 413 return; 414 end; 415 416 if ca.print & ca.pd 417 then do; 418 call com_err_ (error_table_$inconsistent, command, 419 "The -pr and -pd control arguments are incompatible."); 420 call macro_cleanup; 421 return; 422 end; 423 424 call get_input_segment (code); 425 if code ^= 0 426 then do; 427 call macro_cleanup; 428 return; 429 end; 430 431 if ca.list 432 then call ioa_ ("List not yet implemented."); 433 434 if ^ca.print 435 then do; 436 if argument_no = 1 /* Should we use default output ? */ 437 then do; 438 if ca.pd 439 then out_dname = get_pdir_ (); 440 else out_dname = in_dname; 441 out_ename = real_seg_name; 442 end; 443 else do; /* second pathname given */ 444 call expand_pathname_ (out_seg, out_dname, out_ename, code); 445 if code ^= 0 446 then do; 447 call com_err_ (code, command, "^a", out_seg); 448 call macro_cleanup; 449 return; 450 end; 451 end; 452 453 call hcs_$make_seg (out_dname, out_ename, "", 1010b, output_ptr, code); 454 if output_ptr = null 455 then do; 456 call com_err_ (code, command, "^a", pathname_ (out_dname, out_ename)); 457 call macro_cleanup; 458 return; 459 end; 460 if baseno (output_ptr) = baseno (source_ptr) 461 /* same source as output not on */ 462 then do; 463 call com_err_ (0, command, 464 "The source segment and the output segment are the same. No output produced."); 465 call macro_cleanup; 466 return; 467 end; 468 end; 469 470 temp_seg_3.source_ptr = source_ptr; 471 temp_seg_3.source_length = source_length; 472 temp_seg_3.output_length = 4 * sys_info$max_seg_size; 473 temp_seg_3.flags.list = ca.list; 474 temp_seg_3.area_ptr = trans_temp_ptr; 475 temp_seg_3.number_of_clargs = num_of_clargs; 476 temp_seg_3.number_of_params = num_of_params; 477 temp_seg_3.constant_base = null (); 478 temp_seg_3.variable_base = null (); 479 480 if ^ca.target 481 then temp_seg_3.target_value = none; 482 483 if ^valid_penultimate_suffix (language_suffix) 484 then call com_err_ (0, command, "Warning: ^a an unrecognized penultimate suffix. PL/I lex rules used.", 485 language_suffix); 486 487 488 if ca.version 489 then call ioa_ ("^a ^a", command, macro_version); 490 491 pl1_macro_severity_ = 0; 492 needs_cleanup = "1"b; 493 call pl1_macro_lex_ (temp_segs, code); 494 needs_cleanup = "0"b; 495 496 if code ^= 0 497 then call com_err_ (0, command, "Errors in macro processing; output segment may be suspect."); 498 499 /* Copy the macro processed program over to the output segment */ 500 501 output_length = temp_seg_3.output_length; 502 503 if ca.print 504 then do; 505 call iox_$put_chars (iox_$user_output, temp_segs (2), output_length, code); 506 if code ^= 0 507 then do; 508 call com_err_ (code, command); 509 call macro_cleanup; 510 return; 511 end; 512 end; 513 514 else do; 515 516 substr (result_string, 1, output_length) = substr (temp_segs (2) -> output_string, 1, output_length); 517 518 n_chars_left = mod (4 - output_length, 4); 519 substr (result_string, output_length + 1, n_chars_left) = low (n_chars_left); 520 521 n_words = divide (output_length + 3, 4, 19); 522 523 call hcs_$truncate_seg (output_ptr, n_words, code); 524 if code ^= 0 525 then do; 526 pl1_macro_severity_ = 5; 527 call com_err_ (code, command, "Unable to truncate ^a to ^d words.", 528 pathname_ (out_dname, out_ename), n_words); 529 end; 530 531 bit_count = 9 * output_length; 532 533 call hcs_$set_bc_seg (output_ptr, bit_count, code); 534 if code ^= 0 535 then do; 536 pl1_macro_severity_ = 5; 537 call com_err_ (code, command, "Unable to set bit count of ^a to ^d.", 538 pathname_ (out_dname, out_ename), bit_count); 539 end; 540 end; 541 542 if call_ptr ^= null & pl1_macro_severity_ <= 1 543 then begin; 544 declare command_line character (call_length + 169); 545 command_line = call_string || " " || pathname_ (out_dname, out_ename); 546 call cu_$cp (addr (command_line), length (command_line), code); 547 end; 548 549 call macro_cleanup; 550 return; 551 552 get_data_type: 553 procedure (chars) returns (fixed binary (8) unsigned); 554 555 declare chars character (*); 556 declare ch_len fixed binary (24); 557 558 /* scan the character string: 559* if all digits , then data_type = dec_integer 560* else if begins and end with a QUOTE, then char_string 561* else if begins with a QUOTE and ends with QUOTE b and everythin inbetween is 1 or o then bit_string 562* else if begins with an alphabertic and others are identifier chars, then identifier 563* else invalid data type */ 564 565 ch_len = length (chars); 566 if ch_len = 0 567 then return (no_token); 568 569 if verify (chars, numerals) = 0 570 then return (dec_integer); 571 572 else if substr (chars, 1, 1) = QUOTE 573 then do; 574 if ch_len = 1 575 then return (no_token); 576 577 else if substr (chars, ch_len, 1) = QUOTE 578 then return (char_string); 579 580 else if substr (chars, ch_len, 1) = "b" & ch_len > 2 & substr (chars, ch_len - 1, 1) = QUOTE 581 & verify (substr (chars, 2, ch_len - 3), zero_one) = 0 582 then return (bit_string); 583 584 else return (no_token); 585 end; 586 587 else if search (chars, alphabetics) = 1 & verify (chars, identifier_chars) = 0 588 then return (identifier); 589 590 else if substr (chars, 1, 1) = MINUS_SIGN 591 then do; 592 if ch_len = 1 593 then return (no_token); 594 595 else if verify (substr (chars, 2), numerals) = 0 596 then return (dec_integer); 597 598 else return (no_token); 599 end; 600 601 else return (no_token); 602 603 end get_data_type; 604 605 get_input_segment: 606 procedure (code); 607 608 declare code fixed binary (35); /* (Output) standard status code */ 609 610 call expand_pathname_$add_suffix (in_seg, suffix, in_dname, in_ename, code); 611 if code ^= 0 612 then do; 613 call com_err_ (code, command, "^a", in_seg); 614 return; 615 end; 616 617 /* trim off the ".macro" to get the segments REAL name. */ 618 619 real_seg_name = substr (in_ename, 1, length (rtrim (in_ename)) - length (suffix) - 1); 620 if number_of_components (real_seg_name) > 1 621 then language_suffix = get_last_component (real_seg_name); 622 else language_suffix = ""; 623 624 call hcs_$initiate_count (in_dname, in_ename, "", bit_count, 0, source_ptr, code); 625 if source_ptr ^= null 626 then do; 627 code = 0; 628 source_length = divide (bit_count + 8, 9, 21); 629 return; 630 end; 631 else do; 632 call com_err_ (code, command, "^a", pathname_ (in_dname, in_ename)); 633 return; 634 end; 635 return; 636 end get_input_segment; 637 638 number_of_components: 639 procedure (seg_name) returns (fixed binary); 640 declare seg_name character (*) varying; 641 declare (indx, count, nex) fixed binary; 642 643 count = 0; 644 indx = 1; 645 do while (indx < length (seg_name)); 646 nex = search (substr (seg_name, indx), "."); 647 if nex = 0 648 then nex = length (seg_name); 649 indx = indx + nex; 650 count = count + 1; 651 652 end; 653 return (count); 654 end number_of_components; 655 656 get_last_component: 657 procedure (seg_name) returns (character (*) varying); 658 declare seg_name char (*) varying; 659 declare indx fixed binary; 660 661 indx = search (reverse (seg_name), "."); 662 return (substr (seg_name, length (seg_name) - indx + 2)); 663 664 end get_last_component; 665 666 valid_penultimate_suffix: 667 procedure (suffix_chars) returns (bit (1) aligned); 668 declare suffix_chars char (*) varying; 669 670 return (suffix_chars = "pl1" | suffix_chars = "cds" | suffix_chars = "rd"); 671 672 end valid_penultimate_suffix; 673 674 /* Release temporary storage and terminate segments. */ 675 676 macro_cleanup: 677 procedure; 678 679 if source_ptr ^= null 680 then do; 681 call hcs_$terminate_noname (source_ptr, code); 682 source_ptr = null; 683 end; 684 685 if (output_ptr ^= temp_segs (2) & output_ptr ^= null) 686 then do; 687 call hcs_$terminate_noname (output_ptr, code); 688 output_ptr = null; 689 end; 690 691 if needs_cleanup 692 then call pl1_macro_lex_$cleanup (temp_segs); 693 694 if temp_segs (1) ^= null 695 then call release_temp_segments_ (command, temp_segs (*), code); 696 temp_segs (*) = null; 697 698 call translator_temp_$release_all_segments (trans_temp_ptr, code); 699 trans_temp_ptr = null; 700 701 end macro_cleanup; 702 703 end pl1_macro; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/09/89 0900.0 pl1_macro.pl1 >spec>install>1087>pl1_macro.pl1 149 1 12/03/87 1248.1 pl1_macro_lex_dcls.incl.pl1 >ldd>include>pl1_macro_lex_dcls.incl.pl1 1-324 2 06/19/81 2115.0 system_types.incl.pl1 >ldd>include>system_types.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. MINUS_SIGN constant char(1) initial packed unaligned dcl 108 ref 590 QUOTE 006361 constant char(1) initial packed unaligned dcl 1-303 ref 572 577 580 addr builtin function dcl 99 ref 546 546 alphabetics 000031 constant char(52) initial packed unaligned dcl 1-291 ref 587 area_ptr based pointer level 2 dcl 1-67 set ref 474* arg_count 000100 automatic fixed bin(17,0) dcl 43 set ref 185* 192 223 255 283 340 346 arg_length 000101 automatic fixed bin(21,0) dcl 44 set ref 193* 201 204 204 207 207 210 210 213 213 216 216 219 219 252 272 272 289* 297 297 300 300 307 311* 319 319 322 322 329 337 337 348* 357 369 371 371 382 388 arg_ptr 000102 automatic pointer dcl 45 set ref 193* 201 204 204 207 207 210 210 213 213 216 216 219 219 252 272 272 289* 297 300 308 311* 319 322 328 337 337 348* 356 369 371 381 387 arg_string based char packed unaligned dcl 89 set ref 201 204 204 207 207 210 210 213 213 216 216 219 219 252 272 272 297* 300* 319* 322* 337 337 369 371* args based structure level 1 dcl 1-55 argument_no 000104 automatic fixed bin(17,0) dcl 46 set ref 191* 377* 377 379 385 393 393 400 408 436 argx 000105 automatic fixed bin(17,0) dcl 47 set ref 192* 193* 196* 222* 222 223 230* 233* 254* 254 255 262* 265* 274* 274 283 289* 292* 310* 310 311* 314* 339* 339 340 346 348* 351* 360* 360 361* atoken based structure level 1 dcl 1-36 baseno builtin function dcl 99 ref 460 460 bit_count 000106 automatic fixed bin(24,0) dcl 48 set ref 531* 533* 537* 624* 628 bit_string constant fixed bin(8,0) initial unsigned dcl 1-112 ref 580 ca 000107 automatic structure level 1 packed packed unaligned dcl 49 set ref 160* call_length 000110 automatic fixed bin(21,0) dcl 55 set ref 158* 262* 544 545 call_ptr 000112 automatic pointer dcl 56 set ref 157* 262* 542 545 call_string based char packed unaligned dcl 90 ref 545 cannon_name 000114 automatic char(32) packed unaligned dcl 57 set ref 239* ch_len 000406 automatic fixed bin(24,0) dcl 556 set ref 565* 566 574 577 580 580 580 580 592 char_string constant fixed bin(8,0) initial unsigned dcl 1-112 ref 577 chars parameter char packed unaligned dcl 555 ref 552 565 569 572 577 580 580 580 587 587 590 595 cl_args 22 based structure array level 2 dcl 1-67 cl_params 222 based structure array level 2 dcl 1-67 clargx 000124 automatic fixed bin(17,0) dcl 58 set ref 347* 356 357* cleanup 000354 stack reference condition dcl 104 ref 166 code 000125 automatic fixed bin(35,0) dcl 59 in procedure "pmac" set ref 168* 169 171* 175* 176 178* 185* 186 188* 193* 194 196* 230* 231 233* 239* 240 242* 262* 263 265* 289* 290 292* 311* 312 314* 348* 349 351* 424* 425 444* 445 447* 453* 456* 493* 496 505* 506 508* 523* 524 527* 533* 534 537* 546* 681* 687* 694* 698* code parameter fixed bin(35,0) dcl 608 in procedure "get_input_segment" set ref 605 610* 611 613* 624* 627* 632* com_err_ 000020 constant entry external dcl 122 ref 171 178 188 196 225 233 242 257 265 278 285 292 300 314 322 342 351 363 371 402 410 418 447 456 463 483 496 508 527 537 613 632 com_err_$suppress_name 000022 constant entry external dcl 123 ref 395 command 000000 constant char(9) initial packed unaligned dcl 1-311 set ref 168* 171* 175* 178* 188* 196* 225* 233* 242* 257* 265* 278* 285* 292* 300* 314* 322* 342* 351* 363* 371* 395* 395* 402* 410* 418* 447* 456* 463* 483* 488* 496* 508* 527* 537* 613* 632* 694* command_line 000100 automatic char packed unaligned dcl 544 set ref 545* 546 546 546 546 constant_base 6 based pointer level 2 dcl 1-67 set ref 477* count 000425 automatic fixed bin(17,0) dcl 641 set ref 643* 650* 650 653 created 224(22) based bit(1) array level 4 packed packed unaligned dcl 1-67 set ref 331* cu_$arg_count 000024 constant entry external dcl 124 ref 185 cu_$arg_ptr 000026 constant entry external dcl 125 ref 193 230 262 289 311 348 cu_$cp 000030 constant entry external dcl 126 ref 546 data_type 000126 automatic fixed bin(8,0) unsigned dcl 60 set ref 297* 298 319* 320 330 dec_integer constant fixed bin(8,0) initial unsigned dcl 1-112 ref 569 595 divide builtin function dcl 99 ref 521 628 error_table_$badopt 000010 external static fixed bin(35,0) dcl 113 set ref 371* error_table_$inconsistent 000012 external static fixed bin(35,0) dcl 113 set ref 402* 410* 418* error_table_$noarg 000014 external static fixed bin(35,0) dcl 113 set ref 225* 257* 285* 342* expand_pathname_ 000032 constant entry external dcl 127 ref 444 expand_pathname_$add_suffix 000034 constant entry external dcl 128 ref 610 flags 16 based structure level 2 packed packed unaligned dcl 1-67 get_pdir_ 000036 constant entry external dcl 130 ref 438 get_temp_segments_ 000040 constant entry external dcl 132 ref 175 hcs_$initiate_count 000042 constant entry external dcl 133 ref 624 hcs_$make_seg 000044 constant entry external dcl 135 ref 453 hcs_$set_bc_seg 000046 constant entry external dcl 137 ref 533 hcs_$terminate_noname 000050 constant entry external dcl 138 ref 681 687 hcs_$truncate_seg 000052 constant entry external dcl 139 ref 523 identifier constant fixed bin(8,0) initial unsigned dcl 1-112 ref 298 587 identifier_chars 000006 constant char(64) initial packed unaligned dcl 1-296 ref 587 in_dname 000127 automatic char(168) packed unaligned dcl 61 set ref 440 610* 624* 632* 632* in_ename 000201 automatic char(32) packed unaligned dcl 62 set ref 610* 619 619 624* 632* 632* in_seg based char packed unaligned dcl 91 set ref 610* 613* in_seg_length 000214 automatic fixed bin(21,0) dcl 64 set ref 382* 610 610 613 613 in_seg_ptr 000212 automatic pointer dcl 63 set ref 381* 610 613 index builtin function dcl 99 ref 369 indx 000100 automatic fixed bin(17,0) dcl 659 in procedure "get_last_component" set ref 661* 662 indx 000424 automatic fixed bin(17,0) dcl 641 in procedure "number_of_components" set ref 644* 645 646 649* 649 ioa_ 000054 constant entry external dcl 140 ref 431 488 iox_$put_chars 000056 constant entry external dcl 141 ref 505 iox_$user_output 000016 external static pointer dcl 118 set ref 505* language_suffix 000215 automatic varying char(16) dcl 65 set ref 483* 483* 620* 622* length builtin function dcl 99 ref 546 546 565 619 619 645 647 662 list 16 based bit(1) level 3 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pmac" set ref 473* list 000107 automatic bit(1) level 2 in structure "ca" packed packed unaligned dcl 49 in procedure "pmac" set ref 216* 431 473 low builtin function dcl 99 ref 519 macro_version 000004 constant char(5) initial packed unaligned dcl 1-310 set ref 488* mod builtin function dcl 99 ref 518 n_chars_left 000222 automatic fixed bin(2,0) dcl 66 set ref 518* 519 519 n_words 000223 automatic fixed bin(19,0) dcl 67 set ref 521* 523* 527* name 222 based structure array level 3 dcl 1-67 needs_cleanup 000224 automatic bit(1) packed unaligned dcl 68 set ref 162* 492* 494* 691 nex 000426 automatic fixed bin(17,0) dcl 641 set ref 646* 647 647* 649 no_token constant fixed bin(8,0) initial unsigned dcl 1-112 ref 320 566 574 584 592 598 601 none constant fixed bin(17,0) initial dcl 1-308 ref 480 null builtin function dcl 99 ref 153 154 155 156 157 454 477 478 542 625 679 682 685 688 694 696 699 num_of_clargs 000225 automatic fixed bin(17,0) dcl 69 set ref 163* 346* 347 475 num_of_params 000226 automatic fixed bin(17,0) dcl 70 set ref 164* 275* 275 276 307 308 328 329 330 331 476 number_of_clargs 20 based fixed bin(17,0) level 2 dcl 1-67 set ref 475* number_of_params 21 based fixed bin(17,0) level 2 dcl 1-67 set ref 476* numerals 000026 constant char(10) initial packed unaligned dcl 1-294 ref 569 595 out_dname 000227 automatic char(168) packed unaligned dcl 72 set ref 438* 440* 444* 453* 456* 456* 527* 527* 537* 537* 545* out_ename 000301 automatic char(32) packed unaligned dcl 73 set ref 441* 444* 453* 456* 456* 527* 527* 537* 537* 545* out_seg based char packed unaligned dcl 92 set ref 444* 447* out_seg_length 000314 automatic fixed bin(21,0) dcl 75 set ref 388* 444 444 447 447 out_seg_ptr 000312 automatic pointer dcl 74 set ref 387* 444 447 output_length 5 based fixed bin(21,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 472* 501 output_length 000315 automatic fixed bin(21,0) dcl 76 in procedure "pmac" set ref 501* 505* 516 516 516 518 519 519 521 531 output_ptr 000316 automatic pointer dcl 77 set ref 154* 183* 453* 454 460 516 519 523* 533* 685 685 687* 688* output_string based char packed unaligned dcl 1-86 ref 516 params based structure level 1 dcl 1-61 pathname_ 000060 constant entry external dcl 142 ref 456 456 527 527 537 537 545 632 632 pd 0(01) 000107 automatic bit(1) level 2 packed packed unaligned dcl 49 set ref 207* 400 416 438 pl1_macro_lex_ 000074 constant entry external dcl 1-282 ref 493 pl1_macro_lex_$cleanup 000076 constant entry external dcl 1-283 ref 691 pl1_macro_severity_ 000070 external static fixed bin(35,0) dcl 1-276 set ref 159* 491* 526* 536* 542 print 0(02) 000107 automatic bit(1) level 2 packed packed unaligned dcl 49 set ref 204* 408 416 434 503 real_seg_name 000320 automatic varying char(32) dcl 78 set ref 441 619* 620* 620* release_temp_segments_ 000062 constant entry external dcl 143 ref 694 result_string based char packed unaligned dcl 93 set ref 516* 519* reverse builtin function dcl 99 ref 661 rtrim builtin function dcl 99 ref 619 search builtin function dcl 99 ref 587 646 661 seg_name parameter varying char dcl 640 in procedure "number_of_components" ref 638 645 646 647 seg_name parameter varying char dcl 658 in procedure "get_last_component" ref 656 661 662 662 source_length 000331 automatic fixed bin(21,0) dcl 79 in procedure "pmac" set ref 471 628* source_length 4 based fixed bin(21,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 471* source_ptr 000332 automatic pointer dcl 80 in procedure "pmac" set ref 153* 460 470 624* 625 679 681* 682* source_ptr 2 based pointer level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 470* string builtin function dcl 99 set ref 160* string_ptr 223 based pointer array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pmac" set ref 308* string_ptr 226 based pointer array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pmac" set ref 328* string_ptr 23 based pointer array level 3 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pmac" set ref 356* string_size 22 based fixed bin(21,0) array level 3 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 357* string_size 224 based fixed bin(21,0) array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pmac" set ref 329* string_size 222 based fixed bin(21,0) array level 4 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 307* substr builtin function dcl 99 set ref 516* 516 519* 572 577 580 580 580 590 595 619 646 662 suffix 000046 constant char(4) initial packed unaligned dcl 109 set ref 610* 619 suffix_chars parameter varying char dcl 668 ref 666 670 670 670 sys_info$max_seg_size 000072 external static fixed bin(19,0) dcl 1-277 ref 472 516 system_type_ 000100 constant entry external dcl 1-284 ref 239 target 0(03) 000107 automatic bit(1) level 2 packed packed unaligned dcl 49 set ref 221* 480 target_length 000334 automatic fixed bin(21,0) dcl 81 set ref 230* 238 242 242 target_ptr 000336 automatic pointer dcl 82 set ref 230* 238 242 target_string based char packed unaligned dcl 94 set ref 238 242* target_value 000340 automatic fixed bin(17,0) dcl 83 in procedure "pmac" set ref 239* 247 target_value 17 based fixed bin(17,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pmac" set ref 247* 480* temp_seg_3 based structure level 1 dcl 1-67 temp_segs 000362 automatic pointer array dcl 1-21 set ref 155* 175* 183 247 307 308 328 329 330 331 356 357 470 471 472 473 474 475 476 477 478 480 493* 501 505* 516 685 691* 694 694* 696* temp_target 000341 automatic char(32) packed unaligned dcl 84 set ref 238* 239* token based structure array level 1 dcl 1-46 trans_temp_ptr 000352 automatic pointer dcl 85 set ref 156* 168* 474 698* 699* translator_temp_$get_segment 000064 constant entry external dcl 144 ref 168 translator_temp_$release_all_segments 000066 constant entry external dcl 146 ref 698 type 224(28) based fixed bin(8,0) array level 4 packed packed unsigned unaligned dcl 1-67 set ref 330* value 224 based structure array level 3 dcl 1-67 variable_base 10 based pointer level 2 dcl 1-67 set ref 478* verify builtin function dcl 99 ref 569 580 587 595 version 0(04) 000107 automatic bit(1) level 2 packed packed unaligned dcl 49 set ref 161* 210* 213* 488 zero_one constant char(2) initial packed unaligned dcl 1-302 ref 580 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ADP_SYSTEM internal static fixed bin(17,0) initial dcl 2-4 COMPILER_ERROR internal static fixed bin(35,0) initial dcl 1-316 IMPLEMENTATION_RESTRICTION internal static fixed bin(35,0) initial dcl 1-320 L68_SYSTEM internal static fixed bin(17,0) initial dcl 2-3 NO_RESULT internal static fixed bin(35,0) initial dcl 1-315 QUOTEQUOTE internal static char(2) initial packed unaligned dcl 1-304 SEMANTIC_ERROR internal static fixed bin(35,0) initial dcl 1-318 STORAGE_SYSTEM_ERROR internal static fixed bin(35,0) initial dcl 1-319 SYNTAX_ERROR internal static fixed bin(35,0) initial dcl 1-317 SYSTEM_TYPE_NAME internal static char(8) initial array packed unaligned dcl 2-6 TARGET_STRING_ERROR internal static fixed bin(35,0) initial dcl 1-322 and internal static fixed bin(8,0) initial unsigned dcl 1-112 area based area(1024) dcl 1-32 arithchar internal static char(28) initial packed unaligned dcl 1-288 arrow internal static fixed bin(8,0) initial unsigned dcl 1-112 assignment internal static fixed bin(8,0) initial unsigned dcl 1-112 asterisk internal static fixed bin(8,0) initial unsigned dcl 1-112 bin_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 cat internal static fixed bin(8,0) initial unsigned dcl 1-112 colon internal static fixed bin(8,0) initial unsigned dcl 1-112 comma internal static fixed bin(8,0) initial unsigned dcl 1-112 comment_token internal static fixed bin(8,0) initial unsigned dcl 1-112 constant based structure level 1 dcl 1-103 constant_length automatic fixed bin(21,0) dcl 1-108 default_var internal static fixed bin(17,0) initial dcl 1-247 eq internal static fixed bin(8,0) initial unsigned dcl 1-112 expon internal static fixed bin(8,0) initial unsigned dcl 1-112 fixed_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 fixed_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 float_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 float_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 ge internal static fixed bin(8,0) initial unsigned dcl 1-112 get_system_free_area_ 000000 constant entry external dcl 131 gt internal static fixed bin(8,0) initial unsigned dcl 1-112 i_bin_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 i_dec_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 i_fixed_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 i_fixed_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 i_float_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 i_float_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 if_macro internal static fixed bin(17,0) initial dcl 1-256 invalid_char internal static fixed bin(8,0) initial unsigned dcl 1-112 is_decimal_constant internal static bit(4) initial dcl 1-183 is_float_constant internal static bit(4) initial dcl 1-183 is_imaginary_constant internal static bit(4) initial dcl 1-183 is_integral_constant internal static bit(4) initial dcl 1-183 isub internal static fixed bin(8,0) initial unsigned dcl 1-112 keyword_token internal static fixed bin(8,0) initial unsigned dcl 1-112 le internal static fixed bin(8,0) initial unsigned dcl 1-112 left_parn internal static fixed bin(8,0) initial unsigned dcl 1-112 lower_case_letters internal static char(26) initial packed unaligned dcl 1-299 lt internal static fixed bin(8,0) initial unsigned dcl 1-112 max_arithmetic_token internal static fixed bin(8,0) initial unsigned dcl 1-172 max_bit_string_constant internal static fixed bin(17,0) initial dcl 1-265 max_char_string_constant internal static fixed bin(17,0) initial dcl 1-265 max_constant_token internal static fixed bin(8,0) initial unsigned dcl 1-172 max_delimiter_token internal static fixed bin(8,0) initial unsigned dcl 1-172 max_identifier_length internal static fixed bin(17,0) initial dcl 1-265 min_arithmetic_token internal static fixed bin(8,0) initial unsigned dcl 1-172 min_constant_token internal static fixed bin(8,0) initial unsigned dcl 1-172 min_delimiter_token internal static fixed bin(8,0) initial unsigned dcl 1-172 minus internal static fixed bin(8,0) initial unsigned dcl 1-112 ne internal static fixed bin(8,0) initial unsigned dcl 1-112 ngt internal static fixed bin(8,0) initial unsigned dcl 1-112 nl_vt_np_token internal static fixed bin(8,0) initial unsigned dcl 1-112 nlt internal static fixed bin(8,0) initial unsigned dcl 1-112 not internal static fixed bin(8,0) initial unsigned dcl 1-112 or internal static fixed bin(8,0) initial unsigned dcl 1-112 parameter_var internal static fixed bin(17,0) initial dcl 1-247 paren_macro internal static fixed bin(17,0) initial dcl 1-256 pct_INCLUDE internal static fixed bin(17,0) initial dcl 1-223 pct_abort internal static fixed bin(17,0) initial dcl 1-223 pct_default internal static fixed bin(17,0) initial dcl 1-223 pct_else internal static fixed bin(17,0) initial dcl 1-223 pct_elseif internal static fixed bin(17,0) initial dcl 1-223 pct_endif internal static fixed bin(17,0) initial dcl 1-223 pct_error internal static fixed bin(17,0) initial dcl 1-223 pct_if internal static fixed bin(17,0) initial dcl 1-223 pct_include internal static fixed bin(17,0) initial dcl 1-223 pct_isarg internal static fixed bin(17,0) initial dcl 1-223 pct_isdef internal static fixed bin(17,0) initial dcl 1-223 pct_keywords internal static structure array level 1 dcl 1-194 pct_page internal static fixed bin(17,0) initial dcl 1-223 pct_print internal static fixed bin(17,0) initial dcl 1-223 pct_replace internal static fixed bin(17,0) initial dcl 1-223 pct_set internal static fixed bin(17,0) initial dcl 1-223 pct_skip internal static fixed bin(17,0) initial dcl 1-223 pct_target internal static fixed bin(17,0) initial dcl 1-223 pct_then internal static fixed bin(17,0) initial dcl 1-223 pct_warn internal static fixed bin(17,0) initial dcl 1-223 percent internal static fixed bin(8,0) initial unsigned dcl 1-112 period internal static fixed bin(8,0) initial unsigned dcl 1-112 pl1_macro_error_ 000000 constant entry external dcl 1-281 plus internal static fixed bin(8,0) initial unsigned dcl 1-112 prefix_minus internal static fixed bin(8,0) initial unsigned dcl 1-112 prefix_plus internal static fixed bin(8,0) initial unsigned dcl 1-112 reinterpret_macro internal static fixed bin(17,0) initial dcl 1-256 replace_var internal static fixed bin(17,0) initial dcl 1-247 right_parn internal static fixed bin(8,0) initial unsigned dcl 1-112 semi_colon internal static fixed bin(8,0) initial unsigned dcl 1-112 semicolon_macro internal static fixed bin(17,0) initial dcl 1-256 set_var internal static fixed bin(17,0) initial dcl 1-247 size builtin function dcl 1-51 slash internal static fixed bin(8,0) initial unsigned dcl 1-112 target_comma internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_1 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_2 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_3 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_4 internal static fixed bin(8,0) initial unsigned dcl 1-112 upper_case_letters internal static char(26) initial packed unaligned dcl 1-300 variable based structure level 1 dcl 1-90 variable_name_length automatic fixed bin(17,0) dcl 1-99 white_space_token internal static fixed bin(8,0) initial unsigned dcl 1-112 NAMES DECLARED BY EXPLICIT CONTEXT. get_data_type 004060 constant entry internal dcl 552 ref 297 319 get_input_segment 004271 constant entry internal dcl 605 ref 424 get_last_component 004650 constant entry internal dcl 656 ref 620 macro_cleanup 004762 constant entry internal dcl 676 ref 166 172 179 197 226 234 243 258 266 279 286 293 303 315 324 343 352 364 372 396 404 412 420 427 448 457 465 509 549 number_of_components 004575 constant entry internal dcl 638 ref 620 pl1_macro 000570 constant entry external dcl 24 pmac 000561 constant entry external dcl 24 valid_penultimate_suffix 004721 constant entry internal dcl 666 ref 483 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 6762 7064 6365 6772 Length 7400 6365 102 277 375 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME pmac 531 external procedure is an external procedure. on unit on line 166 64 on unit begin block on line 542 128 begin block uses auto adjustable storage. get_data_type internal procedure shares stack frame of external procedure pmac. get_input_segment internal procedure shares stack frame of external procedure pmac. number_of_components internal procedure shares stack frame of external procedure pmac. get_last_component 68 internal procedure uses returns(char(*)) or returns(bit(*)). valid_penultimate_suffix internal procedure shares stack frame of external procedure pmac. macro_cleanup 86 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME begin block on line 542 000100 command_line begin block on line 542 get_last_component 000100 indx get_last_component pmac 000100 arg_count pmac 000101 arg_length pmac 000102 arg_ptr pmac 000104 argument_no pmac 000105 argx pmac 000106 bit_count pmac 000107 ca pmac 000110 call_length pmac 000112 call_ptr pmac 000114 cannon_name pmac 000124 clargx pmac 000125 code pmac 000126 data_type pmac 000127 in_dname pmac 000201 in_ename pmac 000212 in_seg_ptr pmac 000214 in_seg_length pmac 000215 language_suffix pmac 000222 n_chars_left pmac 000223 n_words pmac 000224 needs_cleanup pmac 000225 num_of_clargs pmac 000226 num_of_params pmac 000227 out_dname pmac 000301 out_ename pmac 000312 out_seg_ptr pmac 000314 out_seg_length pmac 000315 output_length pmac 000316 output_ptr pmac 000320 real_seg_name pmac 000331 source_length pmac 000332 source_ptr pmac 000334 target_length pmac 000336 target_ptr pmac 000340 target_value pmac 000341 temp_target pmac 000352 trans_temp_ptr pmac 000362 temp_segs pmac 000406 ch_len get_data_type 000424 indx number_of_components 000425 count number_of_components 000426 nex number_of_components THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_g_a r_e_as alloc_char_temp cat_realloc_chars enter_begin_block leave_begin_block call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other return_mac alloc_auto_adj mdfx1 enable_op shorten_stack ext_entry int_entry int_entry_desc return_chars_eis THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ com_err_$suppress_name cu_$arg_count cu_$arg_ptr cu_$cp expand_pathname_ expand_pathname_$add_suffix get_pdir_ get_temp_segments_ hcs_$initiate_count hcs_$make_seg hcs_$set_bc_seg hcs_$terminate_noname hcs_$truncate_seg ioa_ iox_$put_chars pathname_ pl1_macro_lex_ pl1_macro_lex_$cleanup release_temp_segments_ system_type_ translator_temp_$get_segment translator_temp_$release_all_segments THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$badopt error_table_$inconsistent error_table_$noarg iox_$user_output pl1_macro_severity_ sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 24 000560 153 000575 154 000577 155 000600 156 000613 157 000615 158 000616 159 000617 160 000622 161 000624 162 000626 163 000627 164 000630 166 000631 168 000653 169 000674 171 000676 172 000722 173 000726 175 000727 176 000750 178 000752 179 000776 180 001002 183 001003 185 001005 186 001016 188 001020 189 001035 191 001036 192 001037 193 001047 194 001064 196 001066 197 001120 198 001124 201 001125 204 001134 207 001147 210 001162 213 001175 216 001210 219 001223 221 001233 222 001235 223 001236 225 001241 226 001265 227 001271 230 001272 231 001307 233 001311 234 001343 235 001347 238 001350 239 001355 240 001401 242 001403 243 001436 244 001442 247 001443 251 001446 252 001447 254 001453 255 001454 257 001457 258 001503 259 001507 262 001510 263 001525 265 001527 266 001561 267 001565 270 001566 272 001567 274 001577 275 001600 276 001601 278 001604 279 001631 280 001635 283 001636 285 001642 286 001666 287 001672 289 001673 290 001710 292 001712 293 001744 294 001750 297 001751 298 001770 300 001773 303 002027 304 002033 307 002034 308 002042 310 002044 311 002045 312 002062 314 002064 315 002116 316 002122 319 002123 320 002142 322 002144 324 002200 325 002204 328 002205 329 002212 330 002220 331 002224 335 002226 337 002227 339 002237 340 002240 342 002243 343 002267 344 002273 346 002274 347 002300 348 002307 349 002324 351 002326 352 002360 353 002364 356 002365 357 002372 360 002375 361 002376 363 002401 364 002426 365 002432 367 002433 368 002435 369 002436 371 002450 372 002502 373 002506 377 002507 379 002510 381 002513 382 002514 383 002516 385 002517 387 002521 388 002522 391 002524 393 002526 395 002532 396 002562 397 002566 400 002567 402 002602 404 002626 405 002632 408 002633 410 002642 412 002666 413 002672 416 002673 418 002677 420 002723 421 002727 424 002730 425 002732 427 002734 428 002740 431 002741 434 002760 436 002763 438 002766 440 003001 441 003004 442 003010 444 003011 445 003041 447 003043 448 003075 449 003101 453 003102 454 003141 456 003145 457 003214 458 003220 460 003221 463 003230 465 003255 466 003261 470 003262 471 003265 472 003267 473 003273 474 003277 475 003301 476 003303 477 003305 478 003307 480 003310 483 003315 488 003354 491 003402 492 003404 493 003406 494 003422 496 003423 501 003452 503 003455 505 003460 506 003475 508 003477 509 003514 510 003520 512 003521 516 003522 518 003527 519 003534 521 003540 523 003544 524 003557 526 003561 527 003564 531 003637 533 003642 534 003655 536 003657 537 003662 542 003735 544 003750 545 003761 546 004033 547 004052 549 004053 550 004057 552 004060 565 004071 566 004076 569 004104 572 004124 574 004132 577 004140 580 004151 584 004177 587 004202 590 004234 592 004236 595 004244 598 004263 601 004266 605 004271 610 004273 611 004330 613 004333 614 004365 619 004366 620 004407 622 004444 624 004446 625 004511 627 004515 628 004517 629 004523 632 004524 633 004574 638 004575 643 004606 644 004607 645 004611 646 004617 647 004636 649 004641 650 004642 652 004643 653 004644 656 004647 661 004663 662 004700 666 004721 670 004732 676 004761 679 004767 681 004774 682 005004 685 005007 687 005017 688 005030 691 005033 694 005046 696 005074 698 005110 699 005121 701 005124 ----------------------------------------------------------- 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