COMPILATION LISTING OF SEGMENT general_format_parse_ Compiled by: Multics PL/I Compiler, Release 28e, of February 14, 1985 Compiled at: Honeywell Multics Op. - System M Compiled on: 07/28/86 1547.4 mst Mon Options: optimize map 1 /****^ ****************************************************** 2* * * 3* * Copyright, (C) Honeywell Limited, 1983 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* ****************************************************** */ 9 10 11 12 /****^ HISTORY COMMENTS: 13* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 14* install(86-07-28,MR12.0-1105): 15* Fix fortran bug 462. 16* 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 17* install(86-07-28,MR12.0-1105): 18* Fix fortran bug 122. 19* END HISTORY COMMENTS */ 20 21 22 /* Modified: 23* 25 Nov 85, RW - 122: Raised the max number of items in a format 24* statement to 1023, up from 510 25* 18 Jul 85, BW - 462: Detect implementation restriction that 131071 26* (2**17 - 1) is the maximum value that an r, w, or d field 27* can be. 28* 01 Nov 84, BW - 445: Allow use of * to indicate list-directed I/0. 29* 30 Oct 82, HH - 115: Conform to the FORTRAN/77 Standard for D, E, F 30* and G formats by removing restrictions that d <= w and 31* w - d >= size of exponent field. 32* 09 Sep 82, HH - 114: Allow unary plus sign wherever unary minus is 33* allowed. 34* 27 Apr 82, HH - Defer range check on scale factor to runtime. 35* 26 Apr 82, HH - Ignore NUL's outside of Hollerith's. 36* 24 July,1981 MEP - add new features for FORTRAN77, comment the code better, slightly alter the layout of the code 37* 23 May, 1978, DSL - fix code that zeros unused portion of last word. 38* March, April 1978, DSL - To implement new format. 39* modified March 1973 by A. Downing to be used at compile time and run time. 40* modified June, 1976 by D.S.Levin to clean up and to implement s- and :-formats. 41* modified April 7, 1977 David Levin - improve error messages. 42**/ 43 44 /* format: style2 */ 45 general_format_parse_: 46 proc (source_chars, encoded_format, ansi77, error_code); 47 48 /* parameter */ 49 dcl source_chars char (1320) aligned; 50 /* INPUT */ 51 dcl encoded_format char (4096) aligned; 52 /* OUTPUT */ 53 declare ansi77 bit (1) aligned; /* INPUT */ 54 dcl error_code fixed bin (35); /* OUTPUT */ 55 56 /* automatic */ 57 dcl V_format_location fixed bin; /* if a v_format, where it is */ 58 dcl asterisk_format_location 59 fixed bin; /* if an asterisk_format, where it is */ 60 dcl ch char (1) aligned; /* quote char */ 61 dcl char_type fixed bin; /* ascii value of character */ 62 dcl d fixed bin; /* precision field */ 63 dcl digit_encountered bit (1) aligned; 64 dcl dollar_format_location fixed bin; /* if a dollar-format, where it is */ 65 declare expon_field fixed bin; /* width in g and e formats */ 66 dcl field_count fixed bin; /* number of fields in encoded format */ 67 dcl first_string fixed bin; /* location of first Hollerith in encoded fmt */ 68 dcl fmt_spec fixed bin; /* coded format specifier as understood by interpreter */ 69 dcl from_runtime bit (1) aligned; /* if called at runtime */ 70 dcl i fixed bin; 71 dcl in fixed bin; /* index in source_chars */ 72 dcl input_ptr ptr; 73 dcl j fixed bin; 74 dcl last_string fixed bin; /* like first string */ 75 dcl minus_encountered bit (1) aligned; /* if a minus before digits */ 76 dcl new_state fixed bin; /* NEXT state of finite state machine */ 77 dcl out fixed bin; /* index into encoded fomt */ 78 dcl output_ptr ptr; 79 dcl p ptr; 80 dcl paren_count fixed bin; /* nested paren level */ 81 dcl paren_stored (100) bit (1) aligned; 82 /* for rep count of paren fields */ 83 dcl prev_delim fixed bin; /* value of last delimiter */ 84 dcl r fixed bin; /* repition count */ 85 dcl state fixed bin; /* PRESENT state */ 86 dcl w fixed bin; /* width field */ 87 88 dcl 1 fields aligned structure, 89 2 spec fixed bin (17) unal, 90 2 rep_factor fixed bin (17) unal, 91 2 width fixed bin (17) unal, 92 2 precision fixed bin (17) unal; 93 94 /* constants */ 95 96 declare ALLOWED char (42) internal static options (constant) 97 init ("-format allowed in a format specification."); 98 declare FALSE bit (1) aligned internal static options (constant) initial ("0"b); 99 declare LIST_DIRECTED_ERROR char (63) internal static options (constant) 100 initial ("V-format can only appear with line number skipping or $-format."); 101 declare LIST_DIRECTED_ERROR2 char (74) internal static options (constant) 102 initial ( 103 "*-format can only appear with line number skipping, $-format, or a-format."); 104 declare ONLY1 char (9) internal static options (constant) initial ("Only one "); 105 declare TRUE bit (1) aligned internal static options (constant) initial ("1"b); 106 declare WHITE char (3) aligned int static options (constant) initial (" "); 107 /* SP, TAB and NUL */ 108 declare WITH_CONTEXT bit (1) aligned internal static options (constant) initial ("1"b); 109 declare NO_CONTEXT bit (1) aligned internal static options (constant) initial ("0"b); 110 declare ascii_for_zero fixed binary internal static options (constant) initial (48); 111 dcl char_mask (3) bit (36) aligned int static options (constant) 112 init ("777000000000"b3, "777777000000"b3, "777777777000"b3); 113 declare comma fixed bin internal static options (constant) initial (2); 114 dcl delimiter (2) char (16) varying int static options (constant) 115 init ("Left parenthesis", "Comma"); 116 declare illegal_char fixed binary internal static options (constant) init (22); 117 dcl left_parn fixed bin int static options (constant) init (1); 118 declare ( 119 v_format init (28), 120 dollar_format init (29), 121 caret init (26), 122 tl_format init (99), 123 b_format init (25), 124 asterisk_format init (21) 125 ) fixed bin int static options (constant); 126 127 /* based */ 128 129 dcl 1 based_fields like fields unaligned based structure; 130 dcl in_fmt char (1320) aligned based (input_ptr); 131 dcl 1 neat_source_text aligned based (input_ptr), 132 2 pad1 char (in) unaligned, 133 2 this_char char (1) unaligned, 134 2 next_char char (1) unaligned, 135 2 pad2 char (1320 - in - 2) unaligned; 136 declare 1 overlay_for_strings aligned based (input_ptr), 137 2 pad1 char (in) unaligned, 138 2 rest_of_format char (1320 - i) unaligned; 139 dcl 1 output_format aligned like runtime_format based (output_ptr); 140 dcl word (1024) bit (36) aligned based (output_ptr); 141 142 /* builtin */ 143 144 declare (addr, binary, divide, hbound, index, length, substr, string, unspec, verify) 145 builtin; 146 147 /* general format parse is implemented as a finite state machine of sorts. The states are defined by 148* action_matrix.state_table. This is a two dimension array, the columns defining the character just seen, 149* and the rows the "state" of the format being parsed. 150* 151* The entry in the table is the row of the table to use as the next "state". 152* 153* There is also action_matrix.action_list, which is used as the index of a label array of actions to take when 154* encountering the input character in the given state. 155* 156* The array table_column converts the character just seen to the proper column in the table to use,so reducing 157* the size of the table needed, and additional information is kept in the variables type_char and format_spec. 158* For this reason, and for the fact that we do a little special casing and one character look-ahead, 159* this is not really a TRUE finite state machine. 160**/ 161 162 /* A FEW TABLES TO HELP FUTURE MAINTAINERS, basically inverted lists 163* 164* char_type versus letter (type 22 is illegal characters) 165* 0 i 1 f 2 e 3 l 4 d 5 o 6 g 166* 7 0..9 8 +- 9 r 10 a 11 h 12 x 13 t 167* 14 p 15 ( 16 ) 17 / 18 : 19 '" 20 168* 21 * 22 23 , 24 . 25 ^ 26 b 27 s 169* 28 v 29 $ 170* 171* there is an almost one-to-one relation ship between char_type and the fmt_spec as understood 172* by fortran_io_. The differences are that 20 is used for end_of_format, 21 for TL/TR, 22 for extended I format (Iw.m), 173* 25 for BN, 26 for BN, 27 for S, 28 for SP, and 29 for SS. 174* 175* actions 176* 1 slash or colon: terminate and create current format 177* 2 left paren: implied iteration is 1 178* 3 right paren: terminate format is necessary 179* 4 left paren: iteration explicitly given 180* 5 x-format: implied iteration is 1 181* 6 plus or minus sign: signed scale factor 182* 7 build replication factor 183* 8 a,d,e,f,g,h,i,l,o,r: implied iteration is 1 184* 9 failure - can't translate 185* 10 create hollerith from " or ' 186* 11 white space -skip to next character 187* 12 a,d,e,f,g,h,i,l,o,r: iteration explicitly given 188* 13 field width is * 189* 14 create formats with a w,but no d field (a,o,l,r,t,i?) 190* 15 build width field 191* 16 hollerith from h-format 192* 17 x-format iteration explicitly given 193* 18 failure - out of place 194* 19 p-format terminate 195* 20 create d and f formats 196* 21 build precision field 197* 22 build width field, expect precision field 198* 23 comma as separator 199* 24 recognize new Iw.m format 200* 25 failure - no precision field 201* 26 build specs with neither width nor replication: s, b, v, $, and ^ 202* 27 build exponent field 203* 28 complete e and g fileds with expon 204* 29 begin t field 205* 30 recognize Ef.dEe and Gf.dEe formats 206**/ 207 208 /* format: off */ 209 /* Table to convert character to format type. */ 210 211 dcl type_char(0:127) fixed bin internal static options(constant) init( 212 213 /* 0 1 2 3 4 5 6 7 */ 214 215 /* 000 */ 20, 22, 22, 22, 22, 22, 22, 22, /* \000 - \007 */ 216 /* 010 */ 22, 20, 22, 22, 22, 22, 22, 22, /* \010 TAB \012 - \017 */ 217 /* 020 */ 22, 22, 22, 22, 22, 22, 22, 22, /* \020 - \027 */ 218 /* 030 */ 22, 22, 22, 22, 22, 22, 22, 22, /* \030 - \037 */ 219 /* 040 */ 20, 22, 19, 22, 29, 22, 22, 19, /* SP ! " # $ % & ' */ 220 /* 050 */ 15, 16, 21, 8, 23, 8, 24, 17, /* ( ) * + , - . / */ 221 /* 060 */ 7, 7, 7, 7, 7, 7, 7, 7, /* 0 1 2 3 4 5 6 7 */ 222 /* 070 */ 7, 7, 18, 22, 22, 22, 22, 22, /* 8 9 : ; < = > ? */ 223 /* 100 */ 22, 10, 25, 22, 4, 2, 1, 6, /* @ A B C D E F G */ 224 /* 110 */ 11, 0, 22, 22, 3, 22, 22, 5, /* H I J K L M N O */ 225 /* 120 */ 14, 22, 9, 27, 13, 22, 28, 22, /* P Q R S T U V W */ 226 /* 130 */ 12, 22, 22, 22, 22, 22, 26, 22, /* X Y Z [ \ ] ^ _ */ 227 /* 140 */ 22, 10, 25, 22, 4, 2, 1, 6, /* ` a b c d e f g */ 228 /* 150 */ 11, 0, 22, 22, 3, 22, 22, 5, /* h i j k l m n o */ 229 /* 160 */ 14, 22, 9, 27, 13, 22, 28, 22, /* p q r s t u v w */ 230 /* 170 */ 12, 22, 22, 22, 22, 22, 22, 22); /* x y z */ 231 232 233 /* table to convert format spec type (or character type) to proper COLUMN for lex action table */ 234 235 dcl table_column (0:29) fixed bin internal static options(constant) init( 236 1, 2, 2, 1, 2, 1, 2, 3, 4, 1, 1, 6, 7, 8, 9, 10, 11, 12, 12, 14, 15, 16, 18, 5, 13, 17, 17, 17, 17, 17); 237 238 /* the use of this table eliminates the need for a multiplication */ 239 240 dcl offset(6) fixed bin options(constant) internal static init( 241 0, 18, 36, 54, 72, 90); 242 243 /* The table of actions and new states for each lexical form */ 244 245 dcl 1 action_matrix(108) aligned internal static structure, 246 247 /* the NEXT state table */ 248 249 2 state_table unaligned fixed bin(17) init( 250 251 /* iloa defg 0..9 +- , h x t p ( ) /: . "' SP * sbv Others 252* r ^$ */ 253 /* Start */ 2, 3, 5, 5, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 254 255 /* Build w, no d */ 1, 1, 2, 5, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 256 257 /* Build w, w/ d */ 1, 1, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 1, 3, 1, 1, 1, 258 259 /* Build d */ 1, 1, 4, 5, 1, 1, 1, 2, 1, 1, 1, 1, 6, 1, 4, 1, 1, 1, 260 261 /* Build r or p */ 2, 3, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 1, 1, 1, 262 263 /* Build e */ 1, 1, 6, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 6, 1, 1, 1), 264 265 266 /* actions for all occasions */ 267 268 2 action_list unaligned fixed bin(17) init( 269 270 /* iloa defg 0..9 +- , h x t p ( ) /: . "' SP * svb Others 271* r ^$ */ 272 /* Start */ 8, 8, 7, 6, 23, 18, 5, 29, 18, 2, 3, 1, 18, 10, 11, 26, 26, 9, 273 274 /* Build w, no d */ 18, 18, 15, 14, 14, 18, 18, 14, 18, 18, 14, 14, 24, 14, 11, 13, 18, 9, 275 276 /* Build w, w/ d */ 25, 25, 15, 25, 25, 25, 25, 25, 25, 25, 25, 25, 22, 25, 11, 25, 25, 9, 277 278 /* Build d */ 18, 30, 21, 20, 20, 18, 18, 20, 18, 18, 20, 20, 18, 20, 11, 18, 18, 9, 279 280 /* Build r or p */ 12, 12, 7, 18, 18, 16, 17, 18, 19, 4, 18, 18, 18, 18, 11, 18, 18, 9, 281 282 /* Build e */ 18, 18, 27, 18, 28, 18, 18, 18, 18, 18, 28, 28, 18, 18, 11, 18, 18, 9); 283 284 /* format: on */ 285 1 1 /* BEGIN format_tables.incl.pl1 */ 1 2 1 3 /****^ HISTORY COMMENTS: 1 4* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter): 1 5* Fix fortran bug 122. 1 6* END HISTORY COMMENTS */ 1 7 1 8 /* format: style2 */ 1 9 /* 1 10* Modified: 1 11* 27 Nov 85, RW 122 - Changed fmt_len from fixed bin (11) to 1 12* fixed bin (12) unsigned. 1 13* 19 Oct 82, TO - Added 'd_format'. 1 14* 27-31 July 1981, MEP - Changed names of format_desc_bit fields, and added names of new formats. 1 15* 23 May 1978, DSL - Change precision of scalars to fixed bin(8). 1 16* Modified: March 1978, DSL - to implement new runtime format 1 17* modified: June 1976, by D Levin 1 18* 1 19* This include file defines the internal representation of format specifications for fortran. */ 1 20 1 21 1 22 /* number of array elements required to represent a format specification */ 1 23 1 24 /* format: off */ 1 25 dcl increment_table (0:29) fixed bin internal static options (constant) 1 26 init (3, 4, 4, 3, 4, 3, 4, 0, 0, 3, 3, 3, 2, 3, 2, 2, 1, 1, 1, 3, 1, 3, 0, 0, 0, 1, 1, 1, 1, 1); 1 27 /* i f e l d o g r a h x t p ( ) / : " E tr bz bn s sp ss */ 1 28 1 29 /* format: on */ 1 30 /* actual representation of a format statement */ 1 31 1 32 dcl 1 runtime_format based aligned structure, 1 33 2 header_word unaligned structure, 1 34 3 version bit (6), /* current version is fmt_parse_ver1 */ 1 35 3 last_left_paren fixed bin (11), /* position at which to repeat the spec */ 1 36 3 format_desc_bits structure, 1 37 4 anyitems bit (1), /* ON if format contains a field descriptor */ 1 38 4 list_directed bit (1), /* ON if format specifies list directed format */ 1 39 4 skip_line_numbers 1 40 bit (1), /* ON if format specifies skiping line numbers */ 1 41 4 contains_hollerith 1 42 bit (1), /* ON if format contains hollerith fields */ 1 43 4 suppress_newline 1 44 bit (1), /* ON if final new_line not wanted */ 1 45 4 pad bit (1), 1 46 3 fmt_len fixed bin (12) unsigned,/* length of format, in chars */ 1 47 2 fmt (1023) bit (36); /* encoded format specs */ 1 48 1 49 dcl 1 old_format aligned based structure, 1 50 2 header_word like runtime_format.header_word unaligned structure, 1 51 2 fmt (1022) fixed bin (17) unaligned; 1 52 1 53 dcl 1 format aligned based, 1 54 2 long_format bit (1) unaligned, 1 55 2 spec fixed bin (7) unaligned, 1 56 2 rep_factor fixed bin (8) unaligned, 1 57 2 width fixed bin (8) unaligned, 1 58 2 precision fixed bin (8) unaligned; 1 59 1 60 dcl 1 long_format aligned based, 1 61 2 long_format bit (1) unaligned, 1 62 2 spec fixed bin (7) unaligned, 1 63 2 exponent fixed bin (9) unsigned unaligned, 1 64 2 rep_factor fixed bin (17) unaligned, 1 65 2 width fixed bin (17) unaligned, 1 66 2 precision fixed bin (17) unaligned; 1 67 1 68 1 69 /* error message overlay */ 1 70 1 71 dcl 1 format_error aligned based structure, 1 72 2 input_length fixed bin, 1 73 2 error_message char (128); 1 74 1 75 1 76 /* named constants for format specifications */ 1 77 1 78 dcl ( 1 79 a_format init (10), 1 80 bn_format init (25), 1 81 bz_format init (26), 1 82 d_format init (4), 1 83 e_format init (2), 1 84 extended_i_format init (22), 1 85 g_format init (6), 1 86 i_format init (0), 1 87 s_format init (27), 1 88 sp_format init (28), 1 89 ss_format init (29), 1 90 t_format init (13), 1 91 tr_format init (21), 1 92 end_of_format init (20), 1 93 hollerith_field init (11), 1 94 quoted_string init (19) 1 95 ) fixed bin int static options (constant); 1 96 1 97 dcl fmt_parse_ver1 bit (6) aligned int static options (constant) init ("110000"b); 1 98 dcl max_value fixed bin (8) int static options (constant) init (255); 1 99 dcl chars_per_word fixed bin (8) int static options (constant) init (4); 1 100 dcl chars_per_halfword fixed bin (8) int static options (constant) init (2); 1 101 1 102 /* END format_tables.incl.pl1 */ 286 287 288 from_runtime = FALSE; 289 goto common; 290 291 runtime: 292 entry (source_chars, encoded_format, ansi77, error_code); 293 294 from_runtime = TRUE; 295 296 common: /* copy input argument */ 297 input_ptr = addr (source_chars); 298 output_ptr = addr (encoded_format); 299 300 /* Initialize */ 301 302 unspec (output_format.header_word) = "0"b; 303 output_format.version = fmt_parse_ver1; 304 output_format.last_left_paren = 1; /* default is containing paren */ 305 306 paren_count = 0; 307 first_string = 0; 308 last_string = 0; 309 dollar_format_location = 0; 310 V_format_location = 0; 311 asterisk_format_location = 0; 312 field_count = 0; 313 new_state = 1; 314 out = 0; 315 digit_encountered = FALSE; 316 prev_delim = 0; 317 minus_encountered = FALSE; 318 r, w, d, expon_field = 0; 319 320 /* Convert old style format to new format. */ 321 322 if input_ptr -> runtime_format.version = "0"b & input_ptr -> old_format.fmt (1) = 15 & from_runtime 323 then do; 324 string (output_format.format_desc_bits) = string (input_ptr -> old_format.format_desc_bits); 325 326 if output_format.list_directed 327 then do; 328 out = chars_per_word; 329 goto list_directed_return; 330 end; 331 332 i = 1; /* to get into loop */ 333 do in = 3 repeat in + i while (i ^= 0); 334 335 if in = input_ptr -> old_format.last_left_paren 336 then output_format.last_left_paren = out + 1; 337 338 unspec (fields) = unspec (addr (input_ptr -> old_format.fmt (in)) -> based_fields); 339 340 i = increment_table (fields.spec); 341 goto unpack_fields (i); 342 unpack_fields (4): 343 d = fields.precision; 344 unpack_fields (3): 345 w = fields.width; 346 unpack_fields (2): 347 r = fields.rep_factor; 348 unpack_fields (1): 349 if fields.spec = end_of_format 350 then i = 0; 351 call store_specification ((fields.spec)); 352 end; 353 goto successful_return; 354 end; 355 356 /* find the beginning of the format specifications */ 357 358 in = verify (in_fmt, WHITE) - 1; 359 if in < 0 /* entire spec is blank */ 360 then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT); 361 362 if this_char ^= "(" /* must start with left paren */ 363 then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT); 364 365 in = in - 1; 366 367 /* the loop to parse the format specifications begins here */ 368 369 new_action (11): /* action=11 No operation, get next char. */ 370 main_loop: /* get the next character */ 371 in = in + 1; 372 if in >= length (in_fmt) 373 then call parse_failure ("Final right parenthesis not found.", NO_CONTEXT); 374 j = binary (unspec (this_char), 9, 0); 375 376 /* determine format type, if any, and lex type */ 377 378 if j > hbound (type_char, 1) 379 then char_type = illegal_char; 380 else char_type = type_char (j); 381 382 /* get new state and do new action */ 383 384 state = new_state; 385 i = offset (state) + table_column (char_type); 386 new_state = state_table (i); 387 go to new_action (action_list (i)); 388 389 /* end of the loop */ 390 391 392 new_action (1): /* Character is a "/" or ":". */ 393 field_count = field_count + 1; 394 call store_specification (char_type); 395 go to main_loop; 396 397 398 new_action (2): /* Character is "(", Implied repetition is 1. */ 399 r = 1; 400 goto left_paren_common; 401 402 new_action (4): /* Character is "(", Explicit repetition given. */ 403 if r = 0 | minus_encountered 404 then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT); 405 406 left_paren_common: 407 field_count = field_count + 1; 408 paren_count = paren_count + 1; 409 if paren_count > hbound (paren_stored, 1) 410 then call parse_failure ("Too many parenthesis.", WITH_CONTEXT); 411 412 /* if this is a level 1 left paren, format starts here when it is repeated. */ 413 414 if paren_count = 2 415 then output_format.last_left_paren = out + 1; 416 417 /* Parens are stored only if repetition count is greater than 1. */ 418 419 if r = 1 420 then do; 421 paren_stored (paren_count) = FALSE; 422 r = 0; /* reset this field. */ 423 end; 424 else do; 425 call store_specification (char_type); 426 paren_stored (paren_count) = TRUE; 427 end; 428 429 prev_delim = left_parn; /* Prohibit delimiter after "(". */ 430 goto main_loop; 431 432 433 new_action (3): /* Character is a ")". */ 434 field_count = field_count + 1; 435 paren_count = paren_count - 1; 436 437 /* the format "()" is valid only if that is the entire specification */ 438 439 if prev_delim ^= 0 & field_count ^= 2 440 then call parse_failure (delimiter (prev_delim) || " immediately precedes a right parenthesis.", WITH_CONTEXT); 441 442 if paren_stored (paren_count + 1) 443 then call store_specification (char_type); 444 445 if paren_count ^= 0 446 then goto main_loop; /* continue if not last paren */ 447 448 call store_specification (end_of_format); 449 goto successful_return; 450 451 new_action (5): /* Now have 1x. */ 452 r = 1; 453 goto x_format_common; 454 455 new_action (17): /* Come here if x is preceded by an integer. */ 456 if r = 0 | minus_encountered 457 then call parse_failure ("Field width for x-format must be greater than zero.", WITH_CONTEXT); 458 459 x_format_common: 460 field_count = field_count + 1; 461 call store_specification (char_type); 462 go to main_loop; 463 464 465 new_action (6): /* Plus or minus sign encountered. */ 466 digit_encountered = FALSE; 467 if this_char = "-" 468 then minus_encountered = TRUE; 469 go to main_loop; 470 471 472 new_action (7): /* Build repetition factor or scale factor. */ 473 digit_encountered = TRUE; 474 r = r * 10 + j - ascii_for_zero; 475 go to main_loop; 476 477 new_action (8): /* Repetition factor = 1. a,d,e,f,g,i,l,o fields. */ 478 r = 1; 479 goto width_only_common; 480 481 new_action (12): /* Repetition factor given. a,d,e,f,g,i,l,o fields. */ 482 if r = 0 | minus_encountered 483 then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT); 484 485 width_only_common: 486 digit_encountered = FALSE; 487 fmt_spec = char_type; 488 go to main_loop; 489 490 new_action (9): 491 call parse_failure ("The character """ || this_char || """ cannot be translated.", WITH_CONTEXT); 492 493 new_action (10): /* Create a character string. */ 494 field_count = field_count + 1; 495 output_format.contains_hollerith = TRUE; 496 w = in + 2; 497 ch = this_char; /* pick up delimiting character */ 498 499 if first_string = 0 500 then first_string = out + 1; 501 else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1; 502 last_string = out + 1; 503 504 /* loop until the terminating delimit character is found */ 505 506 do while (TRUE); 507 508 in = in + 1; /* skip the delimiter */ 509 i = index (rest_of_format, ch) - 1; /* find the next one */ 510 if i < 0 511 then call parse_failure ("Missing string delimiter.", NO_CONTEXT); 512 513 in = in + i; /* move up to the delimiter */ 514 r = r + i; /* update length, without delimit char */ 515 516 if next_char ^= ch /* this delimit char is really the end of the string */ 517 then do; 518 call store_specification (char_type); 519 goto main_loop; 520 end; 521 522 in = in + 1; /* skip first of the pair of delimiters */ 523 r = r + 2; /* length includes both delimiters */ 524 end; 525 go to main_loop; 526 527 new_action (13): /* Field width is "*". */ 528 field_count = field_count + 1; 529 if digit_encountered | fmt_spec ^= a_format 530 then call parse_failure ("Invalid use of ""*"".", WITH_CONTEXT); 531 w = 4; 532 533 call store_specification (fmt_spec); 534 output_format.anyitems = TRUE; 535 goto main_loop; 536 537 new_action (14): /* Formats i, l, o, a, h, and t terminate here. */ 538 field_count = field_count + 1; 539 540 /* width must be positive or not_specified (a_format ONLY) 541* in unspecified a_format, fortran_io_ should use the char_len of the variable as the width of the field */ 542 543 if w = 0 544 then if fmt_spec ^= a_format | fmt_spec = a_format & digit_encountered 545 then call parse_failure ("Field width must be greater than zero.", WITH_CONTEXT); 546 if fmt_spec = tl_format 547 then do; /* tl format is tr_format, but in a "negative" direction */ 548 w = -w; 549 fmt_spec = tr_format; 550 end; 551 else if fmt_spec ^= tr_format & fmt_spec ^= t_format 552 then output_format.anyitems = TRUE; 553 554 call store_specification (fmt_spec); 555 goto new_action (action_list (table_column (char_type))); 556 557 new_action (15): /* Build field width. */ 558 digit_encountered = TRUE; 559 w = w * 10 + j - ascii_for_zero; 560 goto main_loop; 561 562 new_action (16): /* Encode hollerith string. */ 563 output_format.contains_hollerith = TRUE; 564 field_count = field_count + 1; 565 if r = 0 | minus_encountered 566 then call parse_failure ("Length of hollerith constant must be greater than zero.", WITH_CONTEXT); 567 568 w = in + 2; 569 in = in + r; 570 571 if first_string = 0 572 then first_string = out + 1; 573 else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1; 574 last_string = out + 1; 575 576 call store_specification (char_type); 577 goto main_loop; 578 579 MISPLACED: 580 new_action (18): /* missing delimiter. */ 581 call parse_failure ("The character """ || this_char || """ is out of place.", WITH_CONTEXT); 582 583 new_action (19): /* End of 'p' specification. */ 584 field_count = field_count + 1; 585 if ^digit_encountered 586 then call parse_failure ("Sign must be followed by a digit.", WITH_CONTEXT); 587 if minus_encountered 588 then r = -r; 589 prev_delim = 0; 590 591 call store_specification (char_type); 592 goto main_loop; 593 594 process_d_field: 595 new_action (20): /* Formats f, e, d, and g are defined here. */ 596 if ^digit_encountered 597 then call parse_failure ("Missing precision field.", WITH_CONTEXT); 598 599 output_format.anyitems = TRUE; 600 601 if new_state = 6 /* building expon field */ 602 then do; 603 digit_encountered = FALSE; 604 goto main_loop; 605 end; 606 else do; /* no expon field, store it */ 607 field_count = field_count + 1; 608 call store_specification (fmt_spec); 609 go to new_action (action_list (table_column (char_type))); 610 end; 611 612 new_action (21): /* Create decimal position. */ 613 digit_encountered = TRUE; 614 d = d * 10 + j - ascii_for_zero; 615 go to main_loop; 616 617 process_w_field: 618 new_action (22): /* Make sure there was a legal numeric field. */ 619 if w = 0 620 then call parse_failure ("Width of field must be greater than zero.", WITH_CONTEXT); 621 digit_encountered = FALSE; 622 go to main_loop; 623 624 new_action (23): /* Test for legal appearance of a comma. */ 625 if prev_delim ^= 0 626 then call parse_failure (delimiter (prev_delim) || " immediately precedes a comma.", WITH_CONTEXT); 627 628 prev_delim = comma; 629 go to main_loop; 630 631 new_action (24): /* possibly unexpected "." */ 632 if fmt_spec = i_format /* new Iw.m format indicated */ 633 then do; 634 fmt_spec = extended_i_format; 635 new_state = 4; /* build "precision" field */ 636 goto process_w_field; 637 end; 638 else goto MISPLACED; 639 640 new_action (25): 641 call parse_failure ("Precision field is omitted.", WITH_CONTEXT); 642 643 new_action (26): /* If char = v and this the only field, list directed */ 644 if char_type = v_format 645 then do; 646 if field_count ^= 1 | dollar_format_location ^= 0 647 then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT); 648 if V_format_location ^= 0 649 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); 650 651 field_count = field_count + 1; 652 V_format_location = field_count + 1; 653 prev_delim = 0; 654 end; 655 656 else if char_type = asterisk_format 657 then do; 658 if field_count ^= 1 | dollar_format_location ^= 0 659 then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT); 660 if asterisk_format_location ^= 0 661 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); 662 663 field_count = field_count + 1; 664 asterisk_format_location = field_count + 1; 665 prev_delim = 0; 666 end; 667 668 /* sadly, in ansi 66 mode, s-format meant skip line numbers, now it refers to the processing of leading plus signs. 669* so, it is hung on the ansi77 switch input argument. 670* To get the same effect in ansi77, use ^N (the two characters,caret and N ). */ 671 672 else if char_type = s_format 673 then do; 674 if next_char = "s" | next_char = "S" 675 then do; 676 in = in + 1; 677 call store_specification (ss_format); 678 end; 679 else if next_char = "p" | next_char = "P" 680 then do; 681 in = in + 1; 682 call store_specification (sp_format); 683 end; 684 else if ansi77 685 then call store_specification (s_format); 686 else call skip_line_numbers; 687 end; 688 else if char_type = caret 689 then do; 690 if next_char = "l" | next_char = "L" 691 then do; 692 in = in + 1; 693 call skip_line_numbers; 694 end; 695 else goto MISPLACED; 696 end; 697 698 /* $-format */ 699 700 else if char_type = dollar_format 701 then do; 702 if dollar_format_location ^= 0 703 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); 704 705 dollar_format_location = field_count + 1; 706 prev_delim = 0; 707 end; 708 709 else if char_type = b_format 710 then do; 711 if next_char = "z" | next_char = "Z" 712 then fmt_spec = bz_format; 713 else if next_char = "n" | next_char = "N" 714 then fmt_spec = bn_format; 715 else goto MISPLACED; 716 in = in + 1; 717 field_count = field_count + 1; 718 call store_specification (fmt_spec); 719 end; 720 goto main_loop; 721 722 new_action (27): /* build exponent field */ 723 digit_encountered = TRUE; 724 expon_field = expon_field * 10 + j - ascii_for_zero; 725 goto main_loop; 726 727 new_action (28): /* complete e and g formats with expon */ 728 field_count = field_count + 1; 729 730 if ^digit_encountered 731 then call parse_failure ("Missing exponent field.", WITH_CONTEXT); 732 733 if expon_field > max_value 734 then call parse_failure ("Exponent field too large.", WITH_CONTEXT); 735 736 call store_specification (fmt_spec); 737 goto new_action (action_list (table_column (char_type))); 738 739 new_action (29): 740 if next_char = "l" | next_char = "L" 741 then do; 742 in = in + 1; 743 fmt_spec = tl_format; 744 end; 745 else if next_char = "r" | next_char = "R" 746 then do; 747 in = in + 1; 748 fmt_spec = tr_format; 749 end; 750 else fmt_spec = t_format; 751 752 digit_encountered = FALSE; 753 r = 1; 754 goto main_loop; 755 756 new_action (30): /* prepare for expon field in Ew.dEe formats */ 757 if char_type = e_format & (fmt_spec = e_format | fmt_spec = g_format) 758 then do; 759 new_state = 6; /* build expon field */ 760 goto process_d_field; 761 end; 762 else goto MISPLACED; 763 764 successful_return: 765 out = out * chars_per_word + 1; /* Length of spec in chars. Only the first char of the */ 766 /* final word is included in length. */ 767 768 /* If called by compiler and hollerith fields exist, copy them into spec. */ 769 770 if ^from_runtime 771 then do i = first_string repeat p -> long_format.precision while (i ^= 0); 772 p = addr (output_format.fmt (i)); 773 774 if out + p -> long_format.rep_factor > length (encoded_format) - chars_per_halfword 775 then call parse_failure ("Format specification is too long.", WITH_CONTEXT); 776 777 substr (encoded_format, out + 1, p -> long_format.rep_factor) = 778 substr (source_chars, p -> long_format.width, p -> long_format.rep_factor); 779 p -> long_format.width = out + 1; 780 out = out + p -> long_format.rep_factor; 781 end; 782 783 /* Zero remaining character positions in the last word. */ 784 785 j = divide (out, chars_per_word, 17, 0); 786 i = out - j * chars_per_word; 787 788 if i ^= 0 789 then word (j + 1) = word (j + 1) & char_mask (i); 790 791 792 out = divide (out + chars_per_halfword - 1, chars_per_halfword, 17, 0) * chars_per_halfword; 793 /* round to half word */ 794 795 /* Post processing for v-format. */ 796 797 if V_format_location ^= 0 798 then do; 799 if V_format_location ^= field_count 800 then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT); 801 output_format.list_directed = TRUE; 802 out = chars_per_word; 803 end; 804 805 /* Post processing for asterisk-format. */ 806 807 else if asterisk_format_location ^= 0 808 then do; 809 if asterisk_format_location ^= field_count 810 then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT); 811 output_format.list_directed = TRUE; 812 out = chars_per_word; 813 end; 814 815 /* Post processing for $-format. */ 816 817 if dollar_format_location ^= 0 818 then do; 819 if dollar_format_location ^= field_count 820 then call parse_failure ("$-format must be the last specification in a format specification.", 821 NO_CONTEXT); 822 output_format.suppress_newline = TRUE; 823 end; 824 825 826 list_directed_return: 827 output_format.fmt_len = out; /* Copy length into format */ 828 output_ptr -> old_format.fmt (divide (out, chars_per_halfword, 17, 0) - 1) = in + 1; 829 /* Return number of chars parsed. */ 830 error_code = 0; 831 return; 832 833 834 abort_return: 835 error_code = -1; 836 return; 837 838 store_specification: 839 procedure (a_type); 840 841 dcl a_type fixed bin; 842 dcl word_count fixed bin; 843 dcl p ptr; 844 dcl spec_type fixed bin; 845 846 dcl fix_bin_17 fixed bin internal static options (constant) initial (131071); 847 848 if r > fix_bin_17 849 then call parse_failure ("Implementation restriction: repetition count must be less than 131072.", WITH_CONTEXT) 850 ; 851 if w > fix_bin_17 | -w > fix_bin_17 852 then call parse_failure ("Implementation restriction: field width must be less than 131072.", WITH_CONTEXT); 853 if d > fix_bin_17 854 then call parse_failure ("Implementation restriction: number of fractional digits must be less than 131072.", 855 WITH_CONTEXT); 856 857 spec_type = a_type; 858 859 p = addr (output_format.fmt (out + 1)); 860 861 /* Use long format for all string fields or if overflow occurs. 862* Note: w must always be positive, except for tl_format which is implemented as "negative" tr_format 863* */ 864 865 if r > max_value | w > max_value | d > max_value | spec_type = hollerith_field | spec_type = quoted_string 866 | expon_field > 0 | -w > max_value 867 then do; 868 if increment_table (spec_type) <= 2 869 then word_count = 1; 870 else word_count = 2; 871 872 if out + word_count > hbound (output_format.fmt, 1) 873 then call parse_failure ("Format specification is too long.", WITH_CONTEXT); 874 else out = out + word_count; 875 876 p -> long_format.spec = spec_type; 877 p -> long_format.long_format = TRUE; 878 p -> long_format.exponent = expon_field; 879 p -> long_format.rep_factor = r; 880 881 if word_count > 1 882 then do; 883 p -> long_format.width = w; 884 p -> long_format.precision = d; 885 end; 886 end; 887 888 else do; 889 if out + 1 > hbound (output_format.fmt, 1) 890 then call parse_failure ("Format specifiation is too long.", WITH_CONTEXT); 891 else out = out + 1; 892 893 p -> format.spec = spec_type; 894 p -> format.long_format = FALSE; 895 p -> format.rep_factor = r; 896 p -> format.width = w; 897 p -> format.precision = d; 898 end; 899 900 r, w, d, expon_field, prev_delim = 0; 901 minus_encountered, digit_encountered = FALSE; 902 end /* store_specification */; 903 904 skip_line_numbers: 905 procedure; 906 907 declare err_chars char (2) varying; 908 909 if field_count ^= 1 910 then call parse_failure ("Line number skipping must be the first specification in a format specification.", 911 NO_CONTEXT); 912 if output_format.skip_line_numbers 913 then do; 914 if ansi77 915 then err_chars = "^N"; 916 else err_chars = "S"; 917 call parse_failure (ONLY1 || err_chars || ALLOWED, NO_CONTEXT); 918 end; 919 920 output_format.skip_line_numbers = TRUE; 921 prev_delim = 0; 922 end skip_line_numbers; 923 924 parse_failure: 925 procedure (err_str, add_chars); 926 927 dcl add_chars bit (1) aligned; 928 dcl err_str char (*); 929 dcl max builtin; 930 931 /* This procedure is called to return abnormally from parsing a format specification. */ 932 933 i = length (err_str); /* length of message */ 934 addr (encoded_format) -> error_message = err_str; /* copy message and blank the rest */ 935 936 if add_chars /* if message is to include context, add it now */ 937 then do; 938 substr (encoded_format, i + 5, 13) = " Context is: 939 "; 940 j = max (in - 9, 0); /* Try to get preceding characters */ 941 substr (encoded_format, i + 18, in - j + 1) = substr (in_fmt, j + 1, in - j + 1); 942 end; 943 944 /* return number of characters parsed */ 945 946 addr (encoded_format) -> input_length = in + 1; 947 goto abort_return; 948 end /* parse_failure */; 949 end /* general_format_parse_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 07/28/86 1458.5 general_format_parse_.pl1 >spec>install>1105>general_format_parse_.pl1 286 1 07/28/86 1335.5 format_tables.incl.pl1 >spec>install>1105>format_tables.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. ALLOWED 000607 constant char(42) initial unaligned dcl 96 ref 648 660 702 917 FALSE constant bit(1) initial dcl 98 ref 288 315 317 421 465 485 603 621 752 894 901 LIST_DIRECTED_ERROR 000567 constant char(63) initial unaligned dcl 99 set ref 646* 799* LIST_DIRECTED_ERROR2 000544 constant char(74) initial unaligned dcl 101 set ref 658* 809* NO_CONTEXT 000655 constant bit(1) initial dcl 109 set ref 359* 362* 372* 510* 646* 648* 658* 660* 702* 799* 809* 819* 909* 917* ONLY1 000541 constant char(9) initial unaligned dcl 104 ref 648 660 702 917 TRUE 000540 constant bit(1) initial dcl 105 ref 294 426 467 472 495 506 534 551 557 562 599 612 722 801 811 822 877 920 V_format_location 000100 automatic fixed bin(17,0) dcl 57 set ref 310* 648 652* 797 799 WHITE constant char(3) initial dcl 106 ref 358 WITH_CONTEXT 000540 constant bit(1) initial dcl 108 set ref 402* 409* 439* 455* 481* 490* 529* 543* 565* 579* 585* 594* 617* 624* 640* 730* 733* 774* 848* 851* 853* 872* 889* a_format constant fixed bin(17,0) initial dcl 1-78 ref 529 543 543 a_type parameter fixed bin(17,0) dcl 841 ref 838 857 action_list 0(18) 000000 constant fixed bin(17,0) initial array level 2 packed unaligned dcl 245 ref 387 555 609 737 action_matrix 000000 constant structure array level 1 dcl 245 add_chars parameter bit(1) dcl 927 ref 924 936 addr builtin function dcl 144 ref 296 298 338 501 573 772 859 934 946 ansi77 parameter bit(1) dcl 53 ref 45 291 684 914 anyitems 0(18) based bit(1) level 4 packed unaligned dcl 139 set ref 534* 551* 599* ascii_for_zero constant fixed bin(17,0) initial dcl 110 ref 474 559 614 724 asterisk_format constant fixed bin(17,0) initial dcl 118 ref 656 asterisk_format_location 000101 automatic fixed bin(17,0) dcl 58 set ref 311* 660 664* 807 809 b_format constant fixed bin(17,0) initial dcl 118 ref 709 based_fields based structure level 1 packed unaligned dcl 129 ref 338 binary builtin function dcl 144 ref 374 bn_format constant fixed bin(17,0) initial dcl 1-78 ref 713 bz_format constant fixed bin(17,0) initial dcl 1-78 ref 711 caret constant fixed bin(17,0) initial dcl 118 ref 688 ch 000102 automatic char(1) dcl 60 set ref 497* 509 516 char_mask 000535 constant bit(36) initial array dcl 111 ref 788 char_type 000103 automatic fixed bin(17,0) dcl 61 set ref 378* 380* 385 394* 425* 442* 461* 487 518* 555 576* 591* 609 643 656 672 688 700 709 737 756 chars_per_halfword constant fixed bin(8,0) initial dcl 1-100 ref 774 792 792 792 828 chars_per_word constant fixed bin(8,0) initial dcl 1-99 ref 328 764 785 786 802 812 comma constant fixed bin(17,0) initial dcl 113 ref 628 contains_hollerith 0(21) based bit(1) level 4 packed unaligned dcl 139 set ref 495* 562* d 000104 automatic fixed bin(17,0) dcl 62 set ref 318* 342* 614* 614 853 865 884 897 900* delimiter 000523 constant varying char(16) initial array dcl 114 ref 439 624 digit_encountered 000105 automatic bit(1) dcl 63 set ref 315* 465* 472* 485* 529 543 557* 585 594 603* 612* 621* 722* 730 752* 901* divide builtin function dcl 144 ref 785 792 828 dollar_format 000521 constant fixed bin(17,0) initial dcl 118 ref 700 dollar_format_location 000106 automatic fixed bin(17,0) dcl 64 set ref 309* 646 658 702 705* 817 819 e_format constant fixed bin(17,0) initial dcl 1-78 ref 756 756 encoded_format parameter char(4096) dcl 51 set ref 45 291 298 774 777* 934 938* 941* 946 end_of_format constant fixed bin(17,0) initial dcl 1-78 set ref 348 448* err_chars 000330 automatic varying char(2) dcl 907 set ref 914* 916* 917 err_str parameter char unaligned dcl 928 ref 924 933 934 error_code parameter fixed bin(35,0) dcl 54 set ref 45 291 830* 834* error_message 1 based char(128) level 2 dcl 1-71 set ref 934* expon_field 000107 automatic fixed bin(17,0) dcl 65 set ref 318* 724* 724 733 865 878 900* exponent 0(09) based fixed bin(9,0) level 2 packed unsigned unaligned dcl 1-60 set ref 878* extended_i_format constant fixed bin(17,0) initial dcl 1-78 ref 634 field_count 000110 automatic fixed bin(17,0) dcl 66 set ref 312* 392* 392 406* 406 433* 433 439 459* 459 493* 493 527* 527 537* 537 564* 564 583* 583 607* 607 646 651* 651 652 658 663* 663 664 705 717* 717 727* 727 799 809 819 909 fields 000304 automatic structure level 1 dcl 88 set ref 338* first_string 000111 automatic fixed bin(17,0) dcl 67 set ref 307* 499 499* 571 571* 770 fix_bin_17 constant fixed bin(17,0) initial dcl 846 ref 848 851 851 853 fmt 1 based bit(36) array level 2 in structure "output_format" dcl 139 in procedure "general_format_parse_" set ref 501 573 772 859 872 889 fmt 1 based fixed bin(17,0) array level 2 in structure "old_format" packed unaligned dcl 1-49 in procedure "general_format_parse_" set ref 322 338 828* fmt_len 0(24) based fixed bin(12,0) level 3 packed unsigned unaligned dcl 139 set ref 826* fmt_parse_ver1 constant bit(6) initial dcl 1-97 ref 303 fmt_spec 000112 automatic fixed bin(17,0) dcl 68 set ref 487* 529 533* 543 543 546 549* 551 551 554* 608* 631 634* 711* 713* 718* 736* 743* 748* 750* 756 756 format based structure level 1 dcl 1-53 format_desc_bits 0(18) based structure level 3 in structure "output_format" packed unaligned dcl 139 in procedure "general_format_parse_" set ref 324* format_desc_bits 0(18) based structure level 3 in structure "old_format" packed unaligned dcl 1-49 in procedure "general_format_parse_" ref 324 format_error based structure level 1 dcl 1-71 from_runtime 000113 automatic bit(1) dcl 69 set ref 288* 294* 322 770 g_format constant fixed bin(17,0) initial dcl 1-78 ref 756 hbound builtin function dcl 144 ref 378 409 872 889 header_word based structure level 2 in structure "output_format" packed unaligned dcl 139 in procedure "general_format_parse_" set ref 302* header_word based structure level 2 in structure "runtime_format" packed unaligned dcl 1-32 in procedure "general_format_parse_" header_word based structure level 2 in structure "old_format" packed unaligned dcl 1-49 in procedure "general_format_parse_" hollerith_field constant fixed bin(17,0) initial dcl 1-78 ref 865 i 000114 automatic fixed bin(17,0) dcl 70 set ref 332* 333 340* 341 348* 352 385* 386 387 509* 509 510 513 514 770* 770* 772* 786* 788 788 933* 938 941 i_format constant fixed bin(17,0) initial dcl 1-78 ref 631 illegal_char constant fixed bin(17,0) initial dcl 116 ref 378 in 000115 automatic fixed bin(17,0) dcl 71 set ref 333* 335 338* 352* 358* 359 362 365* 365 369* 369 372 374 467 490 496 497 508* 508 509 513* 513 516 522* 522 568 569* 569 579 648 660 674 674 676* 676 679 679 681* 681 690 690 692* 692 702 711 711 713 713 716* 716 739 739 742* 742 745 745 747* 747 828 940 941 941 946 in_fmt based char(1320) dcl 130 ref 358 372 941 increment_table 000217 constant fixed bin(17,0) initial array dcl 1-25 ref 340 868 index builtin function dcl 144 ref 509 input_length based fixed bin(17,0) level 2 dcl 1-71 set ref 946* input_ptr 000116 automatic pointer dcl 72 set ref 296* 322 322 324 335 338 358 362 372 374 467 490 497 509 516 579 648 660 674 674 679 679 690 690 702 711 711 713 713 739 739 745 745 941 j 000120 automatic fixed bin(17,0) dcl 73 set ref 374* 378 380 474 559 614 724 785* 786 788 788 940* 941 941 941 last_left_paren 0(06) based fixed bin(11,0) level 3 in structure "output_format" packed unaligned dcl 139 in procedure "general_format_parse_" set ref 304* 335* 414* last_left_paren 0(06) based fixed bin(11,0) level 3 in structure "old_format" packed unaligned dcl 1-49 in procedure "general_format_parse_" ref 335 last_string 000121 automatic fixed bin(17,0) dcl 74 set ref 308* 501 502* 573 574* left_parn constant fixed bin(17,0) initial dcl 117 ref 429 length builtin function dcl 144 ref 372 774 933 list_directed 0(19) based bit(1) level 4 packed unaligned dcl 139 set ref 326 801* 811* long_format based bit(1) level 2 in structure "long_format" packed unaligned dcl 1-60 in procedure "general_format_parse_" set ref 877* long_format based structure level 1 dcl 1-60 in procedure "general_format_parse_" long_format based bit(1) level 2 in structure "format" packed unaligned dcl 1-53 in procedure "general_format_parse_" set ref 894* max builtin function dcl 929 ref 940 max_value constant fixed bin(8,0) initial dcl 1-98 ref 733 865 865 865 865 minus_encountered 000122 automatic bit(1) dcl 75 set ref 317* 402 455 467* 481 565 587 901* neat_source_text based structure level 1 dcl 131 new_state 000123 automatic fixed bin(17,0) dcl 76 set ref 313* 384 386* 601 635* 759* next_char based char(1) level 2 packed unaligned dcl 131 ref 516 674 674 679 679 690 690 711 711 713 713 739 739 745 745 offset 000255 constant fixed bin(17,0) initial array dcl 240 ref 385 old_format based structure level 1 dcl 1-49 out 000124 automatic fixed bin(17,0) dcl 77 set ref 314* 328* 335 414 499 501 502 571 573 574 764* 764 774 777 779 780* 780 785 786 792* 792 802* 812* 826 828 859 872 874* 874 889 891* 891 output_format based structure level 1 dcl 139 output_ptr 000126 automatic pointer dcl 78 set ref 298* 302 303 304 324 326 335 414 495 501 534 551 562 573 599 772 788 788 801 811 822 826 828 859 872 889 912 920 overlay_for_strings based structure level 1 dcl 136 p 000316 automatic pointer dcl 843 in procedure "store_specification" set ref 859* 876 877 878 879 883 884 893 894 895 896 897 p 000130 automatic pointer dcl 79 in procedure "general_format_parse_" set ref 772* 774 777 777 777 779 780 781 paren_count 000132 automatic fixed bin(17,0) dcl 80 set ref 306* 408* 408 409 414 421 426 435* 435 442 445 paren_stored 000133 automatic bit(1) array dcl 81 set ref 409 421* 426* 442 precision 0(27) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 1-53 in procedure "general_format_parse_" set ref 897* precision 1(18) 000304 automatic fixed bin(17,0) level 2 in structure "fields" packed unaligned dcl 88 in procedure "general_format_parse_" set ref 342 precision 1(18) based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 1-60 in procedure "general_format_parse_" set ref 501* 573* 781 884* prev_delim 000277 automatic fixed bin(17,0) dcl 83 set ref 316* 429* 439 439 589* 624 624 628* 653* 665* 706* 900* 921* quoted_string constant fixed bin(17,0) initial dcl 1-78 ref 865 r 000300 automatic fixed bin(17,0) dcl 84 set ref 318* 346* 398* 402 419 422* 451* 455 474* 474 477* 481 514* 514 523* 523 565 569 587* 587 753* 848 865 879 895 900* rep_factor 0(09) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 1-53 in procedure "general_format_parse_" set ref 895* rep_factor 0(18) based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 1-60 in procedure "general_format_parse_" set ref 774 777 777 780 879* rep_factor 0(18) 000304 automatic fixed bin(17,0) level 2 in structure "fields" packed unaligned dcl 88 in procedure "general_format_parse_" set ref 346 rest_of_format based char level 2 packed unaligned dcl 136 ref 509 runtime_format based structure level 1 dcl 1-32 s_format 000216 constant fixed bin(17,0) initial dcl 1-78 set ref 672 684* skip_line_numbers 0(20) based bit(1) level 4 packed unaligned dcl 139 set ref 912 920* source_chars parameter char(1320) dcl 49 set ref 45 291 296 777 sp_format constant fixed bin(17,0) initial dcl 1-78 set ref 682* spec 0(01) based fixed bin(7,0) level 2 in structure "format" packed unaligned dcl 1-53 in procedure "general_format_parse_" set ref 893* spec 0(01) based fixed bin(7,0) level 2 in structure "long_format" packed unaligned dcl 1-60 in procedure "general_format_parse_" set ref 876* spec 000304 automatic fixed bin(17,0) level 2 in structure "fields" packed unaligned dcl 88 in procedure "general_format_parse_" set ref 340 348 351 spec_type 000320 automatic fixed bin(17,0) dcl 844 set ref 857* 865 865 868 876 893 ss_format constant fixed bin(17,0) initial dcl 1-78 set ref 677* state 000301 automatic fixed bin(17,0) dcl 85 set ref 384* 385 state_table 000000 constant fixed bin(17,0) initial array level 2 packed unaligned dcl 245 ref 386 string builtin function dcl 144 set ref 324* 324 substr builtin function dcl 144 set ref 777* 777 938* 941* 941 suppress_newline 0(22) based bit(1) level 4 packed unaligned dcl 139 set ref 822* t_format constant fixed bin(17,0) initial dcl 1-78 ref 551 750 table_column 000263 constant fixed bin(17,0) initial array dcl 235 ref 385 555 609 737 this_char based char(1) level 2 packed unaligned dcl 131 ref 362 374 467 490 497 579 648 660 702 tl_format constant fixed bin(17,0) initial dcl 118 ref 546 743 tr_format constant fixed bin(17,0) initial dcl 1-78 ref 549 551 748 type_char 000321 constant fixed bin(17,0) initial array dcl 211 ref 378 380 unspec builtin function dcl 144 set ref 302* 338* 338 374 v_format 000522 constant fixed bin(17,0) initial dcl 118 ref 643 verify builtin function dcl 144 ref 358 version based bit(6) level 3 in structure "output_format" packed unaligned dcl 139 in procedure "general_format_parse_" set ref 303* version based bit(6) level 3 in structure "runtime_format" packed unaligned dcl 1-32 in procedure "general_format_parse_" ref 322 w 000302 automatic fixed bin(17,0) dcl 86 set ref 318* 344* 496* 531* 543 548* 548 559* 559 568* 617 851 851 865 865 883 896 900* width 1 based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 1-60 in procedure "general_format_parse_" set ref 777 779* 883* width 0(18) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 1-53 in procedure "general_format_parse_" set ref 896* width 1 000304 automatic fixed bin(17,0) level 2 in structure "fields" packed unaligned dcl 88 in procedure "general_format_parse_" set ref 344 word based bit(36) array dcl 140 set ref 788* 788 word_count 000314 automatic fixed bin(17,0) dcl 842 set ref 868* 870* 872 874 881 NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. d_format internal static fixed bin(17,0) initial dcl 1-78 NAMES DECLARED BY EXPLICIT CONTEXT. MISPLACED 002500 constant label dcl 579 ref 631 690 713 756 abort_return 003706 constant label dcl 834 ref 947 common 001337 constant label dcl 296 ref 289 general_format_parse_ 001317 constant entry external dcl 45 left_paren_common 001672 constant label dcl 406 ref 400 list_directed_return 003664 constant label dcl 826 ref 329 main_loop 001561 constant label dcl 369 set ref 395 430 445 462 469 475 488 519 525 535 560 577 592 604 615 622 629 720 725 754 new_action 000160 constant label array(30) dcl 369 ref 387 555 609 737 parse_failure 004317 constant entry internal dcl 924 ref 359 362 372 402 409 439 455 481 490 510 529 543 565 579 585 594 617 624 640 646 648 658 660 702 730 733 774 799 809 819 848 851 853 872 889 909 917 process_d_field 002567 constant label dcl 594 ref 760 process_w_field 002641 constant label dcl 617 ref 636 runtime 001330 constant entry external dcl 291 skip_line_numbers 004205 constant entry internal dcl 904 ref 686 693 store_specification 003712 constant entry internal dcl 838 ref 351 394 425 442 448 461 518 533 554 576 591 608 677 682 684 718 736 successful_return 003452 constant label dcl 764 ref 353 449 unpack_fields 000154 constant label array(4) dcl 342 ref 341 width_only_common 002133 constant label dcl 485 set ref 479 x_format_common 002057 constant label dcl 459 ref 453 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4704 4714 4640 4714 Length 5116 4640 10 165 43 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME general_format_parse_ 382 external procedure is an external procedure. store_specification internal procedure shares stack frame of external procedure general_format_parse_. skip_line_numbers internal procedure shares stack frame of external procedure general_format_parse_. parse_failure 65 internal procedure is called during a stack extension. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME general_format_parse_ 000100 V_format_location general_format_parse_ 000101 asterisk_format_location general_format_parse_ 000102 ch general_format_parse_ 000103 char_type general_format_parse_ 000104 d general_format_parse_ 000105 digit_encountered general_format_parse_ 000106 dollar_format_location general_format_parse_ 000107 expon_field general_format_parse_ 000110 field_count general_format_parse_ 000111 first_string general_format_parse_ 000112 fmt_spec general_format_parse_ 000113 from_runtime general_format_parse_ 000114 i general_format_parse_ 000115 in general_format_parse_ 000116 input_ptr general_format_parse_ 000120 j general_format_parse_ 000121 last_string general_format_parse_ 000122 minus_encountered general_format_parse_ 000123 new_state general_format_parse_ 000124 out general_format_parse_ 000126 output_ptr general_format_parse_ 000130 p general_format_parse_ 000132 paren_count general_format_parse_ 000133 paren_stored general_format_parse_ 000277 prev_delim general_format_parse_ 000300 r general_format_parse_ 000301 state general_format_parse_ 000302 w general_format_parse_ 000304 fields general_format_parse_ 000314 word_count store_specification 000316 p store_specification 000320 spec_type store_specification 000330 err_chars skip_line_numbers THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs cat_realloc_cs call_int_this_desc return tra_ext shorten_stack ext_entry int_entry_desc NO EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 45 001312 288 001324 289 001325 291 001326 294 001335 296 001337 298 001342 302 001344 303 001345 304 001347 306 001351 307 001352 308 001353 309 001354 310 001355 311 001356 312 001357 313 001360 314 001362 315 001363 316 001364 317 001365 318 001366 322 001372 324 001403 326 001405 328 001410 329 001412 332 001413 333 001415 335 001422 338 001434 340 001444 341 001451 342 001453 344 001457 346 001462 348 001466 351 001472 352 001475 353 001500 358 001501 359 001512 362 001532 365 001557 369 001561 372 001562 374 001604 378 001615 380 001622 384 001624 385 001626 386 001632 387 001635 392 001640 394 001641 395 001643 398 001644 400 001646 402 001647 406 001672 408 001673 409 001674 414 001721 419 001731 421 001734 422 001736 423 001737 425 001740 426 001742 429 001745 430 001747 433 001750 435 001751 439 001753 442 002016 445 002024 448 002026 449 002030 451 002031 453 002033 455 002034 459 002057 461 002060 462 002062 465 002063 467 002064 469 002074 472 002075 474 002077 475 002104 477 002105 479 002107 481 002110 485 002133 487 002134 488 002136 490 002137 493 002173 495 002175 496 002177 497 002202 499 002210 501 002216 502 002223 508 002226 509 002227 510 002243 513 002263 514 002265 516 002266 518 002274 519 002276 522 002277 523 002300 524 002302 525 002303 527 002304 529 002305 531 002331 533 002333 534 002335 535 002337 537 002340 543 002341 546 002370 548 002373 549 002375 550 002377 551 002400 554 002406 555 002410 557 002414 559 002416 560 002423 562 002424 564 002426 565 002427 568 002452 569 002455 571 002457 573 002465 574 002472 576 002475 577 002477 579 002500 583 002534 585 002536 587 002557 589 002563 591 002564 592 002566 594 002567 599 002613 601 002615 603 002620 604 002621 607 002622 608 002623 609 002625 612 002631 614 002633 615 002640 617 002641 621 002662 622 002663 624 002664 628 002723 629 002726 631 002727 634 002731 635 002733 636 002735 640 002736 643 002755 646 002760 648 003001 651 003037 652 003041 653 003044 654 003045 656 003046 658 003050 660 003071 663 003127 664 003131 665 003134 666 003135 672 003136 674 003140 676 003152 677 003153 678 003155 679 003156 681 003162 682 003163 683 003165 684 003166 686 003175 687 003176 688 003177 690 003201 692 003213 693 003214 696 003215 700 003216 702 003220 705 003256 706 003262 707 003263 709 003264 711 003266 713 003303 716 003311 717 003312 718 003313 720 003315 722 003316 724 003320 725 003325 727 003326 730 003327 733 003353 736 003375 737 003377 739 003403 742 003415 743 003416 744 003420 745 003421 747 003425 748 003426 749 003430 750 003431 752 003433 753 003434 754 003436 756 003437 759 003447 760 003451 764 003452 770 003456 772 003464 774 003466 777 003515 779 003527 780 003533 781 003537 785 003544 786 003547 788 003554 792 003561 797 003566 799 003570 801 003606 802 003610 803 003612 807 003613 809 003615 811 003633 812 003635 817 003637 819 003641 822 003662 826 003664 828 003667 830 003703 831 003705 834 003706 836 003711 838 003712 848 003714 851 003736 853 003763 857 004005 859 004010 865 004014 868 004037 870 004046 872 004050 874 004073 876 004075 877 004102 878 004104 879 004110 881 004113 883 004116 884 004122 886 004124 889 004125 891 004151 893 004152 894 004157 895 004161 896 004165 897 004171 900 004174 901 004201 902 004204 904 004205 909 004206 912 004230 914 004233 916 004244 917 004250 918 004311 920 004312 921 004314 922 004315 924 004316 933 004332 934 004334 936 004343 938 004346 940 004351 941 004360 946 004371 947 004376 ----------------------------------------------------------- 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