THIS FILE IS DAMAGED COMPILATION LISTING OF SEGMENT ext_parse Compiled by: Multics PL/I Compiler, Release 33c, of October 25, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 91-12-11_2227.17_Wed_mst Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Bull Inc., 1987 * 6* * * 7* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 8* * * 9* * Copyright, (C) Honeywell Limited, 1983 * 10* * * 11* * Copyright (c) 1972 by Massachusetts Institute of * 12* * Technology and Honeywell Information Systems, Inc. * 13* * * 14* *********************************************************** */ 15 16 17 18 /****^ HISTORY COMMENTS: 19* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 20* install(86-07-28,MR12.0-1105): 21* Fix fortran bugs 457, 458, 461, and 463. 22* 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 23* install(86-07-28,MR12.0-1105): 24* Fix fortran bugs 122, 389, 396, 428, 470, 473, 481, and 482. 25* 3) change(86-07-14,BWong), approve(86-07-14,MCR7442), audit(86-07-17,Ginter), 26* install(86-07-28,MR12.0-1105): 27* Fix fortran bugs 410, 497, and 498. 28* 4) change(87-04-15,Huen), approve(87-04-15,MCR7651), audit(87-04-15,RWaters), 29* install(87-05-08,MR12.1-1031): 30* Fix fortran bugs 479 and 431. 31* 5) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 32* install(87-08-06,MR12.1-1069): 33* Implemented SCP 6315: Added a fortran runtime error-handler argument. 34* 6) change(88-02-29,Huen), approve(88-02-29,MCR7846), audit(88-03-07,RWaters), 35* install(88-03-15,MR12.2-1036): 36* Fix bug 506: Do not always assign bp -> header.units to char_units 37* whenever the first element of the common block is of character type. 38* 7) change(88-04-28,RWaters), approve(88-04-28,MCR7875), audit(88-07-13,Huen), 39* install(88-11-10,MR12.2-1209): 40* Implement SCP 6339: Allow character variables to be up to 128K-1 41* (131071) character long. 42* 8) change(89-06-14,RWaters), approve(89-06-14,MCR8115), 43* audit(89-07-21,Blackmore), install(89-07-31,MR12.3-1065): 44* Fix bug 511; error in format statements > 512 chars long. 45* 9) change(91-11-06,Huen), approve(91-11-06,MCR8246), audit(91-11-25,Vu), 46* install(91-12-11,MR12.5-1004): 47* Fix Fortran compiler (ft_514) to be able to consistently diagnose errors 48* when the VLA size is greater than the maximum value. The maximum value is 49* (2**24 - 1) words long. 50* END HISTORY COMMENTS */ 51 52 53 /* format: style3,^indattr,linecom,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */ 54 ext_parse: 55 procedure (p, q); 56 57 /* Created: June 1976, David Levin 58* 59* Modified: 60* 15 May 87, RW SCP 6315 added the -debug_io argument, set 61* io_bits.debug according to subr_options.debug_io; 62* 23 Feb 87, SH & RW - 431: Allow substrings in equivalence 63* statements in ansi77 mode. 64* 02 Jan 87, SH - 479: Whenever a left parenthesis prior to 65* an input list item in a set context, display 66* additional information "A redundant parenthesis 67* was encountered." after the error message 95. 68* 21 Mar 86, NS - 498: Put in check for invalid unit numbers. 69* 18 Mar 86, NS - 497: Check for the typeless function fld. 70* 08 Mar 86, SH - 410: Allow builtin functions to be declared 71* in external statements in ansi66 mode. Update the 72* bif_table.external table and delete the intrinsic 73* include file. 74* 28 Feb 86, BW - 428.a: Make minor declaration changes: 75* o default_char_size only needs to be increased from 76* fixed bin (9) to fixed bin (10) 77* o token can be left as bit (9) aligned 78* o token_list structure is padded to make it word aligned 79* o temp_str only needs to be increased from char (256) 80* to char (512). 81* 27 Feb 86, BW - 461.a: Fix error introduced with the character 82* equivalencing. Block lengths were calculated larger then 83* they should be causing unnecessarily large text sections. 84* 19 Feb 86, BW & AG - 473.a: Fix allowing individual storage classes 85* (automatic, static, parameter, or common) to be addressed 86* as VLA's or LA's. Move code to set maximum array sizes 87* from fort_defaults_$check_global_args to the new routine 88* set_max_array_size so the values are set properly. 89* 12 Dec 85, NS, MM, & BW - 482: Change the default in precision of 90* an unsupported REAL type from single to double precision. 91* 12 Dec 85, NS, MM, & BW - 481: Warn user of a change in the 92* precision of a real variable from that in which it was 93* declared. 94* 11 Dec 85, NS - 389: Warn user of a complex type declaration of 95* precision other than single precision. 96* 05 Dec 85, RW - 396: Stop compiler from changing automatics into 97* named constants if they are in equivalence statements. 98* 29 Nov 85, RW - 428: Allow strings up to 512 (up from 256) 99* 25 Nov 85, RW - 122: Changed max number of items in a format 100* statement to 1023 (up from 510) 101* 09 Oct 85, BW - 473: Allow individual storage classes (automatic, 102* static, parameter, or common) to be addressed as 103* VLA's or LA's. 104* 26 Sept 85, BW - 470: Use only the significant digits of real and 105* double precision constants when converting from 106* character to floating point representation. 107* 02 Aug 85, BW - 463: Removed code to set must_save_stack_extent. 108* The saving will no longer be done because of fortran_io_ 109* problems. 110* 16 Jul 85, MM & BW - 461: Allow character variables and 111* non-character variables to be equivalenced in ansi77. 112* 12 Jun 85, BW - 458: Suppress generation of error messages for 113* compiler generated symbols. 114* 12 Jun 85, BW - 457: Correct cross referencing of format statements 115* which are declared before they are referenced. 116* 22 Mar 85, MM - 433: Correct the polish for the bypass label that 117* is emitted around entry statements. The label itself must 118* fall on the end of the last entry statement - not on the 119* following statement. 120* 12 Aug 84, BW - 435: Generate correct polish for entry points 121* followed by non-executable statements only. 122* 03 Aug 84, BW - 434: Allow option names of up to 32 characters. 123* 22 Jun 84, MM - Install typeless functions support. 124* 25 Apr 84, HH - 424: Argument type & shape specification disallowed 125* after 1st executable statement. 126* 13 Apr 84, MM - 419: Generate correct polish for routines that do 127* not contain executable statements. 128* 12 Apr 84, BW - 418: Correct lexer error which occurred when a 129* Hollerith string was followed by a labelled statement. 130* 28 Mar 84, MM - Install HFP support. 131* 05 Dec 83, HH - 412: Prevent possible endless loop when checking 132* for branches into do-loops in '77 mode. 133* 16 Sep 83, RG & MM - 242/370: Pass ptr (symbol.general) to arg_desc in entry node. 134* 14 Aug 83, HH - 387: Allow substrings as targets in DATA statements. 135* 14 Aug 83, HH - 386: Generalize expressions in DATA statements to 136* comply with the '77 Standard. 137* 12 Jul 83, MM - 379: Give more consistancy to compilation options. 138* 4 Jul 83, RG - 385: To allow conversions to integer in DATA statements 139* 19 Jun 83, HH - 145: Disallowing branching into do-loops in '77 mode. 140* 17 Jun 83, HH - 383: Make adjustable arrays conform to the Standard 141* in '77 mode. 142* 10 May 83, MM - 375: Allow common variables to be initilized to 0. 143* 10 May 83, RG - 174: Allow include files to be archive components. 144* 10 Feb 83, HH - Install LA/VLA support. 145* 21 Oct 82, TO - 360: Add default 'UNIT=' to INQUIRE. 146* 21 Oct 82, TO - 362: Add parsing for 'CHARACTER*(*) FUNCTION f ('. 147* 14 May 82, TO - Modify extraneous text error for parenthesis test. 148* 5 May 82, TO - Save stack extent if char_star_function is only one. 149* 22 Mar 82, TO - Fix navy test bug 1, label with code on continuation lines only. 150* 22 Mar 82, TO - Fix navy test bug 2, lack of comma in assigned goto. 151* 18 Mar 82, TO - Fix bug 296 - implied IO do loop gets errors on left_parn of expression. 152* 17 Mar 82, TO - Fix bug 326 - assign lex doesn't know about logical if with substr assign target. 153* 16 Mar 82, TO - Fix bug 269 - incorrect line number reporting. 154* 12 Mar 82, TO - Fix bug 320 - failure to detect duplicate entries. 155* 17 Dec 81, MEP - Fix bug in doubly subscripted implied do in data statement. 156* 15 Dec 81, MEP - Fix bugs in label_const parsing (*) and filed length in mode statements. 157* 14 Dec 81, MEP - Fix unreported bug in parsing of * as unit number. 158* 4 Dec 81, MEP - Fix bug 257 allow proper equivalencing of ansi66 and ansi77 arrays 159* 19 Nov 81, MEP - Fix bug 246 too many constants for variable list in data statment 160* 17 Nov 81, MEP - Fix bug 327 not allow chars and non-chars in fortran 77 equiv groups 161* 17 Nov 81, MEP - Fix bug 328 on external (descriptors) character functions in ansi_77. 162* 16 Nov 81, MEP - Fix bug 323 on lacking s permission of include file's directory. 163* 13 Nov 81, MEP - Fix unreported bug in typed functions 164* 22 Oct 81, MEP - Added code for INQUIRE statement. Changed parse_open_field to have parameter 165* for expression_type. 166* 1 Oct 1981, MEP - Fortran 77 internal files 167* 5 August 1981, MEP - Fixed bug 324, incorrect tally of stack high-water mark 168* 16 July 1981, MEP - Completion of ASSIGN with format labels 169* 14 July 1981, MEP - Full ansi77 format specifiers 170* 30 June 1981, MEP - Allow format statements to be objects of ASSIGN TO 171* June 1981, MEP - Finished alteration to REWIND, etc. Began changes for new 172* READ/WRITE specifications. 173* 1 June 81, MEP - Alterations to parse_parameter_list, and argument list of statement functions to 174* allow functions with no arguments. 175* 20 May 81, MEP - Alterations in the lex to allow blank lines to be comments in ansi77 176* 12 May 81, MEP - Added code for INTRINSIC statement. 177* 11 May 81, MEP - Added code for .EQV., .NEQV., and SAVE /common-block-name/ 178* 4 May 81, MEP - Added code for new features in rewind, backspace, and endfile statements. 179* 3 May 81, MEP - Minor changes per CRD's audit for array and data changes. 180* 29 Apr 81, MEP - Program statement and named block data subprogs. 181* 11 Mar 81, MEP - Began the enhancements for ansi77 array declarators 182* 22 Feb 81, MEP - Fixed bug 307 (blank common not recognized unless first in common statement and bug 305 183* (parse fails when identifier continued onto next line and next char is not letter or digit). 184* 26 January 1981, CRD - Improve interaction of elseif statement with 185* profile and breakpoints. 186* 5 January 1980, MEP - Added code to handle illegally referenced labels 187* 31 December 1980, MEP - Added a field in statement_attributes for warnings on labelled statements 188* 29 December 1980, MEP - Cleaned up the error handling for improperly nested do's and block if's. 189* 15 December 1980, MEP - Added code that manipulates the do_blockif_stack, formerly the do_stack for nested do loops 190* and the code for the parsing of block if's. 191* 19 November 1980, CRD - Fix bug in which array_size was computed for 192* star extent arrays instead of leaving it to later phases. 193* 24 October 1980, CRD - Added new intrinsics for Fortran 77. 194* 8 October 1980, CRD - Fixed bug 283. Lex was not properly handling 195* hollerith constants which need to be blank padded but are 196* not continued. 197* 29 September 1980, CRD - Fixed bug 281. Changed the lex not to make 198* substr_left_parn tokens; and invented the subroutine 199* get_next_token$paren_operator which differentiates between 200* left_parn and substr_left_parn by scanning the token list. 201* parse_expression calls this new subroutine, as it is the 202* only place which needs to differentiate. 203* 17 September 1980, CRD - Fixed bug 277: %include lex was not 204* stripping white space properly. Also fixed bug 268: 205* fold keyword not allowed in %options or %global. 206* 31 July 80, MEP - Added code to allow evaluation of fortran 77 207* parameter statements 208* 29 July 80, CRD - Fix bug in declaration processing of entry_points. 209* 16 July 80, MEP - Set symbol.variable_arglist in external statement. 210* 10 June 80, MEP - Added code to set must_save_stack_extent iff more 211* than one subprogram and char star-extent variables seen. 212* 5 June 80, MEP - Changed parse to properly set needs_descriptors bit 213* for all entry points. This is done if any of the formal parameters 214* is star_extents or the function itself is. 215* 16 May 80, MEP - Added code to set io_bits.ansi_77 so that character array i/o 216* is handled correctly in both modes. 217* 09 May 1980, MEP - Fixed two bugs in character mode. The first 218* bug was that the use of two substered variables in an expression was mishandled. 219* The second was that a reference to an unsubscripted substered variable failed to 220* correctly set the variable bit in symbol.attribute. 221* 01 May 1980, MEP - Removed the builtins until such time as the required 222* alterations to the back end are implemented. Also fixed a bug in which subscripted 223* substered references are correctly handled. 224* 04 Apr 1980, MEP - Add the new builtins sinh, cosh, dcosh, dtanh, 225* dsinh. Also fix bug to make tan externable. 226* 04 Apr 1980, PES - Fix uninitialized subroutine_options bug. 227* 18 Dec 1979, PES - Change parse to emit (read write)_namelist_op rather than namelist_op 228* when optimizing, to fix bug 249, in which the optimizer appears to ignore the 229* fact that a namelist read sets the values in the namelist. Eliminate all 230* references to the obsolete bit symbol.need_word_count. 231* 06 Dec 1979, PES - Multiplied all positive precedences in parse_expression by 10, to ease 232* addition of new operators. Since only relative values are supposed to matter, this 233* should have no visible effect. 234* 27 Nov 1979, PES - Fix bug 248, in which symbol.in_equiv_stmnt is not set for a 235* variable which is in both a common block and an equivalence statement. 236* 26 Sep 1979, PES - major butchery for new CHARACTER mode. Make comma in assigned goto 237* statement optional. 238* 02 Sep 1979, PES - Fix bug 206, in which certain unfortunate placements of delimiters in 239* card-image format statements could cause spurious error 134 messages. 240* 02 Sep 1979, PES - Allow multiple namelist declarations to refer to same namelist, if 241* they are consecutive statements; fix unreported bug in multiple segment 242* handling; minor cleanups; allow optional comma in COMMON statements declaring 243* multiple commons; change to allow blank lines before %options and %global 244* statements; slightly limit the free form check for unintended comment lines; 245* fix an unreported namelist bug in which if the first ref to a namelist was in a 246* write any following refs in a read would not cause the namelist members to be 247* marked set; fixed an unreported namelist bug in which namelist names were 248* always listed in the "not referenced" list, with proper cross-reference info; 249* changed namelist so that a namelist reference is also cross-referenced as a 250* reference to each member; and fixed bug 208, in which variables on the lhs of 251* the first assignment statement might be multiply cross-referenced. 252* 18 Jul 1979, PES - fix bug 211 in which fortran incorrectly evaluates a**b**c as 253* (a**b)**c, rather than as a**(b**c). Also adds diagnosis of possible 254* unintended comments in free format input. Also correct an error in handling of 255* encode/decode statements when the string is an entire character array, 256* introduced by the fix to 222/223. 257* 13 Jul 1979, CRD - initialize io_bits.fold to implement fortran_io_ suggested improvement 258* 078 (case insensitive namelist input with -fold or -card). 259* 12 Jul 1979, PES - changes to fix bug 222 and implement suggested improvment 223, both 260* having to do with encode/decode problems; and to fix various unreported bugs in 261* encode/decode. Also, allow the optional comma after the statement number in a 262* do statement, as permitted by the 77 ANSI Standard. 263* 05 Jul 1979, PES - fixes bug 219 in which an uninitialized variable in the parse may 264* cause the listing generator to fault. 265* 03 Jul 1979, PES - fix uninited variable which caused misc faults. 266* 12 Jun 1979, PES - major butchery for new PARAMETER statement. 267* 07 Jun 1979, PES - fixes bug 210 in which the parse will generate a spurious error 125 268* message (data type of entry does not match data type of function) if the data 269* type of a function entry does not match the default data type of the primary 270* function name. 271* 14 Mar 1979, PES - serious modifications towards include file handling. 272* 28 Feb 1979, PES - fixes bug 202 in which a missing ; on an %options or %global statement 273* will cause the parse to fault. 274* 8 Jan 1979, RAB - fixes bug 200 in which equivalence alignment is wrong if the second 275* item in a pair belongs to a header that is further to the left than the first 276* item and difference is odd. 277* 13 Dec 1978, PES -fixes bug in which named constants are not marked as referenced, and 278* bug in which fort_converter does not properly handle string_op. 279* 12 Dec 1978, PES - fixes bug 189 in which the compiler does not diagnose statements of 280* the form "x+y = exp". If optimizing, such a statement causes a fault; if not 281* optimizing, useless code is produced. 282* 06 Dec 1978, RAB - fixes 193 in which missing comma in implied do causes fault. 283* 06 Dec 1978, PES - Implement %options and %global--change implementation of octal 284* constants to match old_fortran. 285* 25 Oct 1978, PES - Changes for larger common and arrays. 286* 25 Sep 1978, PES - Change to fix bug 188, in which block data fails if data statements 287* for a common block contain only equivalenced variables and do not contain any 288* variables actually appearing in the common statement. 289* 06 Sep 1978, PES - Change so variables read by namelist directed read are marked as set. 290* 31 Aug 1978, PES - Change to the constants used by convert_real to check real number 291* magnitudes before conversion. Both original values were too small, meaning: 292* (1) That certain very large real constants would not be accepted, even though 293* they were proper values; and (2) that certain very small magnitude real 294* constants could cause the compiler to take an underflow fault , instead of 295* being diagnosed as errors. 296* 19 July 1978, PES - Fix to relaxed statment ordering, to again permit variables to be 297* declared in common after they have been declared equivalenced. This feature 298* was broken by the last change. 299* 20 June 1978, DSL - Fixes to declaration processing. Bug fixed in which a variable can 300* have two storage classes because default storage class was applied before(!) 301* equivalence processing; improved processing of invalid equiv groups; set 302* symbol.equivalenced when equiv st is parsed, rather than when dcl processor is 303* run. See comments concerning this parse design change under equiv st parser 304* #13. 305* 12 June 1978, DSL - Have "declaration_processor" set storage class as well as data type 306* for all variables, and data type for all ext funcs. Declare alternate return 307* symbol as a variable (bug fix). 308* 25 May 1978, DSL - Fix bug 157 correctly so compiler will not fault if label > 999999. 309* Move create_node to include file. Insure that statement.put_in_profile and 310* statement.put_in_map are always set correctly. 311* 18 May 1978, DSL - Final fix to bug 144 in which dcl for based_double assumed double word 312* alignment for all dp values; fix bug in which text of first statement appears 313* as text for main entry point entry sequence; fix bug 158 in which data type for 314* float bif is erroneously d.p.; fix bug 157 in which parse faults trying to 315* print error message for label > 131071. 316* 2 May 1978, dsl - minor code changes for v2 opt; also clean up a_complex_constant. 317* 26 April 1978, DSL - Fix introduced bug in which label parsing was broken. Other small 318* fixes. 319* 18 April 1978, DSL - Set symbol.set for a format if it is ref'd in a read st and 320* contains_hollerith; fix bug 151 in which parse neglects to set symbol.ref'd 321* (etc.) for parameter bounds. 322* 7 April 1978, DSL - Move complex constant processing from lexical analyzer to expression 323* parser; fix introduced bug in optimizer in which parse does not force data type 324* of a symbol before deciding how much temp space it needs; change card-image lex 325* to supply blanks for lines less than 72 chars in length. 326* 28 March 1978, DSL - Finish relaxed statement ordering; allow another form of function 327* statement; fix bug 144 in which conversion from dp to real fails because dcl of 328* based_double is wrong. 329* 330******************* Converted to version 2 optimizer. ****************** 331* 332* 28 February 1978, DSL - Change logic to allow statements to appear in any order. The 333* only surviving restrictions are: a) declaratives must precede first reference; 334* b) all statement func. defs. must precede all other executables. 335* 2 February 1978, DSL - Mark return statement code generated by an end line as being 336* executable. 337* 1 February 1978, DSL - Fix post-parse declaration processor to set all symbol.data_type 338* and symbol.element_size. 339* 29 December 1977, DSL - Fix bug 124 so that -3435... (-2**35) is accepted in a data 340* specification; fix bug 126 so that cg will not fault on an unreferenced 341* st.func. def.; fix bug 137 so that max number of consts is 500, not 200. 342* Also, some changes were made in preparation for relaxing all stmnt order 343* requirements. Also, fixed unreported bug in which char func with different 344* lengths declared at each entry point would not be diagnosed, although compiler 345* does not handle this case correctly. Also, modified data spec parse to allow 346* char consts and octal consts for all data type. Data spec parse no longer 347* limits the number of error msgs it prints. print_message is made responsible. 348* 30 August 1977, D Levin - print message if subr or func ref has too many args; 349* NOTE - value of bias changed from 65536 to 131072. 350* 18 July 1977, David Levin - fix bugs in open and close. 351* 30 June 1977, David Levin - 1) new fort_system_constants.incl.pl1; 2) open and close 352* statements; 3) move block data code from fort_ to here. 353* 26 May 1977, David Levin - data parser printed random stuff instead of octal constant in 354* error msg. 355* 2 May 1977, David Levin - for new fort_system_constants.incl.pl1 and changes for implied 356* do loop optimization and bug fix for stop/pause. 357* 22 April 1977, David Levin - convert long real const (>8) to dp; warn user if char var 358* init'ed with const too long; fix bug in warning msg. 359* 14 April 1977 David Levin - small optimizer fix; add 6 new builtin functions. 360* 25 March 1977 David Levin - fix for char const as fmt; set label.referenced_executable. 361* 24 February 1977 Gabriel Chang - to emit a zero operand for not, and negate operators and 362* emit no_ops for complicated subscripts for optimization. 363* 10 February 1977 David Levin - fix bug in equiv stmnt; improve lex for real constants. 364* 24 January 1977 David Levin - minor tuning; prepare for the addition of optimizer changes. 365* 19 January 1977 David Levin - bug fix for data stmnt parser. 366* 14 September 1976 David Levin - listing addition bug fixes, some error msg clean up. 367* 9 September, 1976 David Levin - bug fixes for listing additions. 368**/ 369 370 dcl p pointer; 371 dcl q pointer; 372 dcl parse_ptr pointer; 373 dcl shared_ptr pointer; 374 dcl polish_string (0:polish_max_len - 1) fixed bin (19) aligned based (polish_base); 375 dcl polish_base ptr; 376 dcl operand_base ptr; 377 dcl object_base ptr; 378 dcl cref_base ptr; 379 dcl source_line_base ptr; 380 dcl listing_base ptr; 381 dcl polish_max_len fixed bin (19); 382 dcl object_max_len fixed bin (19); 383 dcl 1 max_array_size, 384 2 auto fixed bin (24), 385 2 char fixed bin (24), 386 2 common fixed bin (24), 387 2 parm fixed bin (24), 388 2 static fixed bin (24); 389 390 dcl 1 segment_options aligned like fortran_options; 391 dcl 1 subr_options aligned like fortran_options; 392 dcl 1 segment_declared aligned like fortran_declared; 393 dcl 1 subr_declared aligned like fortran_declared; 394 395 dcl 1 parse_structure aligned based (parse_ptr), 1 1 1 2 2 source_info_ptr ptr, 1 3 1 4 2 add_to_lib_list entry(char(*),fixed bin(35)) 1 5 variable, 1 6 2 get_next_source_seg entry(ptr) 1 7 variable, 1 8 2 add_to_lib_list_run entry(char(*),fixed bin(35)) 1 9 entry; 1 10 396 397 398 dcl 1 shared_structure aligned based (shared_ptr), 2 1 2 2 /* BEGIN fort_shared_vars.incl.pl1 */ 2 3 2 4 2 5 2 6 /****^ HISTORY COMMENTS: 2 7* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 2 8* install(86-07-28,MR12.0-1105): 2 9* Fix fortran bug 463. 2 10* END HISTORY COMMENTS */ 2 11 2 12 2 13 /* Created: June 1976, David Levin 2 14* 2 15* Modified: 30 Aug 76, David Levin - to add global variables for listing segment. 2 16* Modified: 22 Nov 76, Richard Barnes - to add profile_size 2 17* Modified: 24 Feb 77, Gabriel Chang - for the optimizer 2 18* Modified: 06 Oct 77, Richard Barnes - for the loop optimizer 2 19* Modified: 16 Nov 77, David Levin - add next_free_(temp array_ref). 2 20* Modified: 09 Oct 78, Paul Smee - for larger common and arrays. 2 21* Modified: 03 Apr 79, Paul Smee - add list of include file data. 2 22* Modified: 17 May 79, Paul Smee - add cur_statement_list. 2 23* Modified: 28 Jun 79, Paul Smee - add compile-time math entry arrays. 2 24* Modified: 13 Sep 79, Paul Smee - add default_char_size. 2 25* Modified: 18 Dec 79, Richard Barnes - add free and freei 2 26* Modified: 03 Mar 80, C R Davis - add must_save_stack_extent. 2 27* Modified: 15 Mar 82, T G Oke - add source (line_number, file_number). 2 28* Modified: 20 Sept 82, T G Oke - add VLA_is_256K flag 2 29* Modified: 22 Sept 82, T G Oke - add area creation info to pass to 2 30* listing generator. 2 31* Modified: 17 May 83, M Mabey - add declared_options. 2 32* Modified: 02 Aug 85, B Wong - 463: changed 'must_save_stack_extent' 2 33* to 'pad' since the variable is no longer used. 2 34**/ 2 35 2 36 2 polish_base ptr, 2 37 2 operand_base ptr, 2 38 2 object_base ptr, 2 39 2 quadruple_base ptr, 2 40 2 opt_base ptr, 2 41 2 relocation_base ptr, 2 42 2 43 2 cref_base ptr, /* base of cross reference segment */ 2 44 2 source_line_base ptr, /* base of source line offset segment */ 2 45 2 listing_base ptr, /* base of listing info segment */ 2 46 2 cur_listing ptr, /* points to listing info for the active subprogram */ 2 47 2 48 2 free(2:4) ptr, /* free chains for optimizer */ 2 49 2 freei ptr, /* .. */ 2 50 2 51 2 polish_max_len fixed bin (19), 2 52 2 operand_max_len fixed bin (19), 2 53 2 object_max_len fixed bin (19), 2 54 2 quad_max_len fixed bin (19), 2 55 2 opt_max_len fixed bin (19), 2 56 2 57 2 next_free_polish fixed bin (18), 2 58 2 next_free_operand fixed bin (18), 2 59 2 next_free_object fixed bin (18), 2 60 2 next_free_listing fixed bin (18), 2 61 2 next_free_quad fixed bin (18), 2 62 2 next_free_array_ref fixed bin (18), /* Chain for freed array_ref nodes. */ 2 63 2 next_free_temp fixed bin (18), /* Chain for freed temporary nodes. */ 2 64 2 next_free_opt fixed bin (18), 2 65 2 66 2 first_segment fixed bin, 2 67 2 number_of_source_segments fixed bin (8), 2 68 2 number_of_lines fixed bin, 2 69 2 number_of_crefs fixed bin, 2 70 2 profile_size fixed bin, 2 71 2 72 2 main_entry_point_name char (32) varying, 2 73 2 74 2 cur_statement fixed bin (18), 2 75 2 cur_statement_list fixed bin (17), 2 76 2 cur_subprogram fixed bin (18), 2 77 2 first_subprogram fixed bin (18), 2 78 2 last_subprogram fixed bin (18), 2 79 2 unnamed_block_data_subprogram 2 80 fixed bin (18), 2 81 2 first_entry_name fixed bin (18), 2 82 2 last_entry_name fixed bin (18), 2 83 2 84 2 constant_info (4) aligned structure, 2 85 3 constant_count fixed bin (17), 2 86 3 first_constant fixed bin (18), 2 87 3 last_constant fixed bin (18), 2 88 2 89 2 options aligned, 2 90 3 user_options aligned like fortran_options, 2 91 3 system_options aligned, 2 92 4 is_fast bit (1) unaligned, 2 93 4 namelist_used bit (1) unaligned, 2 94 4 compile_only bit (1) unaligned, 2 95 4 VLA_is_256K bit (1) unaligned, /* FLAG 255/256K code */ 2 96 4 pad bit (32) unaligned, 2 97 2 98 2 incl_data aligned, 2 99 3 incl_count fixed bin, 2 100 3 file_list (0:255), 2 101 4 source_node_offset fixed bin (18), 2 102 4 incl_len fixed bin (21), 2 103 4 incl_ptr unaligned ptr, 2 104 2 105 2 create_constant entry (fixed bin (4), bit (72) aligned) returns (fixed bin (18)) 2 106 variable, 2 107 2 create_char_constant entry (char (*)) returns (fixed bin (18)) 2 108 variable, 2 109 2 print_message entry options (variable) 2 110 variable, 2 111 2 get_next_temp_segment entry (ptr, fixed bin (18)) returns (ptr) 2 112 variable, 2 113 2 negate_round (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 2 114 returns (bit (72)) variable, 2 115 2 negate_trunc (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 2 116 returns (bit (72)) variable, 2 117 2 binop_round (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 2 118 returns (bit (72)) variable, 2 119 2 binop_trunc (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 2 120 returns (bit (72)) variable, 2 121 2 comp_parm (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 2 122 returns (bit (72)) variable, 2 123 2 conv_round (6,6) entry (bit (72), fixed bin (35)) 2 124 returns (bit (72)) variable, 2 125 2 conv_trunc (6,6) entry (bit (72), fixed bin (35)) 2 126 returns (bit (72)) variable, 2 127 2 pad bit (1) aligned, 2 128 2 129 /* The following are used by "print_message - decode_source_id" if use_source_info set. */ 2 130 2 131 2 use_source_info bit (1) aligned, 2 132 2 source_file_number fixed bin (35), 2 133 2 source_line_number fixed bin (35), 2 134 2 Area_create_first fixed bin (18), /* start of text to do creation */ 2 135 2 Area_create_last fixed bin (18), /* Last item */ 2 136 2 Area_init_first fixed bin (18), /* start of text to init areas */ 2 137 2 Area_init_last fixed bin (18), /* Last item */ 2 138 2 declared_options aligned like fortran_declared; 2 139 2 140 dcl num_of_word_constants fixed bin (17) defined (constant_info (1).constant_count); 2 141 dcl first_word_constant fixed bin (18) defined (constant_info (1).first_constant); 2 142 dcl last_word_constant fixed bin (18) defined (constant_info (1).last_constant); 2 143 2 144 dcl num_of_dw_constants fixed bin (17) defined (constant_info (2).constant_count); 2 145 dcl first_dw_constant fixed bin (18) defined (constant_info (2).first_constant); 2 146 dcl last_dw_constant fixed bin (18) defined (constant_info (2).last_constant); 2 147 2 148 dcl num_of_char_constants fixed bin (17) defined (constant_info (3).constant_count); 2 149 dcl first_char_constant fixed bin (18) defined (constant_info (3).first_constant); 2 150 dcl last_char_constant fixed bin (18) defined (constant_info (3).last_constant); 2 151 2 152 dcl num_of_block_constants fixed bin (17) defined (constant_info (4).constant_count); 2 153 dcl first_block_constant fixed bin (18) defined (constant_info (4).first_constant); 2 154 dcl last_block_constant fixed bin (18) defined (constant_info (4).last_constant); 2 155 2 156 /* END fort_shared_vars.incl.pl1 */ 399 3 1 /* BEGIN INCLUDE FILE fort_options.incl.pl1 */ 3 2 3 3 /****^ *********************************************************** 3 4* * * 3 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 3 6* * * 3 7* *********************************************************** */ 3 8 3 9 /****^ HISTORY COMMENTS: 3 10* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 3 11* install(86-07-28,MR12.0-1105): 3 12* Fix fortran bug 473. 3 13* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 3 14* install(87-08-06,MR12.1-1069): 3 15* Implemented SCP 6315: fortran error-handling argument. 3 16* END HISTORY COMMENTS */ 3 17 3 18 3 19 /* 3 20* Modified: 12 May 87 by RWaters added debug_io 3 21* Modified: 19 February 1986 by B. Wong & A. Ginter - 473.a: Correct 3 22* comments and size of pad field in fort_declared 3 23* and pad out dfast and fast bit masks to two words. 3 24* Modified: 09 October 1985 by B. Wong - 473: add VLA_auto, VLA_static, 3 25* VLA_parm, VLC, LA_auto, and LA_static. Remove VLA and LA. 3 26* Modified: 28 March 1984 by M. Mabey - Install HFP support. 3 27* Modified: 21 September 1983 by M. Mabey - correct size of pad field in fortran_declared. 3 28* Modified: 16 May 1983 by M. Mabey - add fortran_declared 3 29* Modified: 18 December 1982 by T. Oke - Add 'long_profile'. 3 30* Modified: 22 September 1982 by T. Oke - add VLA and LA 3 31* Modified: 3 May 1982 by T. Oke - add check_multiply 3 32* Modified: 06/24/81 by S. Herbst - add do_rounding & auto_zero to fast_mask and dfast_mask 3 33* Modified: 26 February 1980 by C R Davis - add fast_mask, fix dfast_mask. 3 34* Modified: 31 January 1980 by C R Davis - add stringrange. 3 35* Modified: 13 September 1979 by Paul E. Smee--add ansi_77. 3 36* Modified: 05 December 1978 by Paul E. Smee--add do_rounding, auto_zero. 3 37* Modified: 25 January 1978 by Richard A. Barnes for the loop optimizer 3 38**/ 3 39 3 40 declare 3 41 3 42 1 fortran_options aligned based, 3 43 2 use_library bit (1) unaligned, /* (1) ON if library statements will be parsed */ 3 44 2 optimize bit (1) unaligned, /* (2) ON if optimized code is to be produced */ 3 45 2 time bit (1) unaligned, /* (3) ON for compile timing */ 3 46 2 source_format unaligned, 3 47 3 has_line_numbers bit (1) unaligned, /* (4) ON if each line begins with a line number */ 3 48 3 fold bit (1) unaligned, /* (5) ON if variable names are to be folded to lowercase */ 3 49 3 card bit (1) unaligned, /* (6) ON for card format */ 3 50 3 convert bit (1) unaligned, /* (7) ON for card format to be converted */ 3 51 2 listing unaligned, 3 52 3 source bit (1) unaligned, /* (8) ON for listing of numbered source */ 3 53 3 symbol bit (1) unaligned, /* (9) ON for listing with symbol map */ 3 54 3 map bit (1) unaligned, /* (10) ON for listing with statement map */ 3 55 3 list bit (1) unaligned, /* (11) ON for listing with assembler instructions */ 3 56 2 error_messages unaligned, 3 57 3 brief bit (1) unaligned, /* (12) ON for brief error messages */ 3 58 3 severity fixed bin (3), /* (13-16) suppresses messages below this severity */ 3 59 2 debugging unaligned, 3 60 3 subscriptrange bit (1) unaligned, /* (17) ON for subscript range checking */ 3 61 3 stringrange bit (1) unaligned, /* (18) ON for string range checking */ 3 62 3 brief_table bit (1) unaligned, /* (19) ON for statement table */ 3 63 3 table bit (1) unaligned, /* (20) ON for statement and symbol table */ 3 64 3 profile bit (1) unaligned, /* (21) ON to generate code to meter statements */ 3 65 3 check bit (1) unaligned, /* (22) ON for syntactic and semantic checking only */ 3 66 2 system_debugging unaligned, 3 67 3 stop_after_cg bit (1) unaligned, /* (23) ON if debug stop after code generator */ 3 68 3 stop_after_parse bit (1) unaligned, /* (24) ON if debug stop after parse */ 3 69 2 relocatable bit (1) unaligned, /* (25) ON if relocatable object segment generated */ 3 70 2 optimizing unaligned, 3 71 3 time_optimizer bit (1) unaligned, /* (26) ON if timings for optimizer requested */ 3 72 /* (27) ON if optimizer can loosen safety constraints */ 3 73 3 ignore_articulation_blocks bit (1) unaligned, 3 74 3 consolidate bit(1) unaligned, /* (28) ON if optimizer should run consolidation phase */ 3 75 2 do_rounding bit(1) unaligned, /* (29) ON if floating point round should be used */ 3 76 2 auto_zero bit(1) unaligned, /* (30) ON if auto storage should be zeroed when allocated */ 3 77 2 ansi_77 bit (1) unaligned, /* (31) ON if ansi77 rules are to be followed */ 3 78 2 check_multiply bit (1) unaligned, /* (32) ON if check integer multiply extent */ 3 79 2 VLA_auto bit (1) unaligned, /* (33) ON if auto VLA's being done */ 3 80 2 VLA_parm bit (1) unaligned, /* (34) ON if parm VLA's being done */ 3 81 2 VLA_static bit (1) unaligned, /* (35) ON if static VLA's being done */ 3 82 2 VLC bit (1) unaligned, /* (36) ON if VLC's being done */ 3 83 2 LA_auto bit (1) unaligned, /* (1) ON if auto LA's being done */ 3 84 2 LA_static bit (1) unaligned, /* (2) ON if static LA's being done */ 3 85 2 long_profile bit (1) unaligned, /* (3) ON to generate long_profile */ 3 86 2 static_storage bit (1) unaligned, /* (4) ON if static storage */ 3 87 2 hfp bit (1) unaligned, /* (5) ON if using hex floating point math */ 3 88 2 debug_io bit (1) unaligned, /* (6) */ 3 89 2 pad bit(30) unaligned; /* (7-36) Pad bits */ 3 90 3 91 declare 3 92 3 93 1 fortran_declared aligned based, 3 94 2 ansi66 bit(1) unaligned, /* (1) First word */ 3 95 2 ansi77 bit(1) unaligned, /* (2) */ 3 96 2 auto bit(1) unaligned, /* (3) */ 3 97 2 auto_zero bit(1) unaligned, /* (4) */ 3 98 2 brief bit(1) unaligned, /* (5) */ 3 99 2 binary_floating_point bit(1) unaligned, /* (6) */ 3 100 2 brief_table bit(1) unaligned, /* (7) */ 3 101 2 card bit(1) unaligned, /* (8) */ 3 102 2 check bit(1) unaligned, /* (9) */ 3 103 2 check_multiply bit(1) unaligned, /* (10) */ 3 104 2 consolidate bit(1) unaligned, /* (11) */ 3 105 2 debug bit(1) unaligned, /* (12) */ 3 106 2 debug_cg bit(1) unaligned, /* (13) */ 3 107 2 debug_io bit(1) unaligned, /* (14) */ 3 108 2 default_full bit(1) unaligned, /* (15) */ 3 109 2 default_safe bit(1) unaligned, /* (16) */ 3 110 2 fold bit(1) unaligned, /* (17) */ 3 111 2 free bit(1) unaligned, /* (18) */ 3 112 2 full_optimize bit(1) unaligned, /* (19) */ 3 113 2 hexadecimal_floating_point bit(1) unaligned, 3 114 /* (20) */ 3 115 2 la_auto bit(1) unaligned, /* (21) */ 3 116 2 la_static bit(1) unaligned, /* (22) */ 3 117 2 large_array bit(1) unaligned, /* (23) */ 3 118 2 line_numbers bit(1) unaligned, /* (24) */ 3 119 2 list bit(1) unaligned, /* (25) */ 3 120 2 long bit(1) unaligned, /* (26) */ 3 121 2 long_profile bit(1) unaligned, /* (27) */ 3 122 2 map bit(1) unaligned, /* (28) */ 3 123 2 no_auto_zero bit(1) unaligned, /* (29) */ 3 124 2 no_check bit(1) unaligned, /* (30) */ 3 125 2 no_fold bit(1) unaligned, /* (31) */ 3 126 2 no_large_array bit(1) unaligned, /* (32) */ 3 127 2 no_line_numbers bit(1) unaligned, /* (33) */ 3 128 2 no_map bit(1) unaligned, /* (34) */ 3 129 2 no_optimize bit(1) unaligned, /* (35) */ 3 130 2 no_check_multiply bit(1) unaligned, /* (36) */ 3 131 2 no_debug_io bit(1) unal, /* (1) Second Word */ 3 132 2 no_stringrange bit(1) unaligned, /* (2) */ 3 133 2 no_subscriptrange bit(1) unaligned, /* (3) */ 3 134 2 no_table bit(1) unaligned, /* (4) */ 3 135 2 no_very_large_array bit(1) unaligned, /* (5) */ 3 136 2 no_vla_parm bit(1) unaligned, /* (6) */ 3 137 2 no_version bit(1) unaligned, /* (7) */ 3 138 2 non_relocatable bit(1) unaligned, /* (8) */ 3 139 2 optimize bit(1) unaligned, /* (9) */ 3 140 2 profile bit(1) unaligned, /* (10) */ 3 141 2 relocatable bit(1) unaligned, /* (11) */ 3 142 2 round bit(1) unaligned, /* (12) */ 3 143 2 safe_optimize bit(1) unaligned, /* (13) */ 3 144 2 severity fixed bin(3) unaligned, /* (14-16) */ 3 145 2 static bit(1) unaligned, /* (17) */ 3 146 2 stringrange bit(1) unaligned, /* (18) */ 3 147 2 subscriptrange bit(1) unaligned, /* (19) */ 3 148 2 table bit(1) unaligned, /* (20) */ 3 149 2 time bit(1) unaligned, /* (21) */ 3 150 2 time_ot bit(1) unaligned, /* (22) */ 3 151 2 top_down bit(1) unaligned, /* (23) */ 3 152 2 truncate bit(1) unaligned, /* (24) */ 3 153 2 version bit(1) unaligned, /* (25) */ 3 154 2 very_large_array bit(1) unaligned, /* (26) */ 3 155 2 very_large_common bit(1) unaligned, /* (27) */ 3 156 2 vla_auto bit(1) unaligned, /* (28) */ 3 157 2 vla_parm bit(1) unaligned, /* (29) */ 3 158 2 vla_static bit(1) unaligned, /* (30) */ 3 159 2 pad bit(6) unaligned; /* (31-36) */ 3 160 3 161 3 162 declare /* Options used by DFAST */ 3 163 3 164 dfast_mask bit (72) internal static options (constant) initial ("100110000000000010100000000011"b); 3 165 /* use_library, has_line_numbers, fold, subscriptrange, brief_table */ 3 166 3 167 3 168 declare /* Options used by FAST */ 3 169 3 170 fast_mask bit (72) internal static options (constant) initial ("000100000000000010100000000011"b); 3 171 /* has_line_numbers, subscriptrange, brief_table */ 3 172 3 173 /* END INCLUDE FILE fort_options.incl.pl1 */ 400 4 1 /* BEGIN fort_system_constants.incl.pl1 */ 4 2 4 3 4 4 4 5 /****^ HISTORY COMMENTS: 4 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 4 7* install(86-07-28,MR12.0-1105): 4 8* Fix fortran bug 428. 4 9* END HISTORY COMMENTS */ 4 10 4 11 4 12 /* Created: June 1976, David Levin */ 4 13 4 14 /* Modified: 4 15* 15 Dec 85, RW - 428: Changed max_char_length from 256 to 512. 4 16* 22 Jun 84, MM - Install typeless functions support. 4 17* 17 Jun 83, HH - 383: Added 'process_param_list_op'. 4 18* 12 Jan 83, HH - Added 'form_VLA_packed_ptr_op'. 4 19* 05 Oct 82, HH - Added 'units_per_word'. 4 20* 27 Sep 82, HH - Added 'max_fixed_bin_18', 'max_fixed_bin_24' and 'sys_info$max_seg_size'. 4 21* Removed 'max_stored_value' and 'min_stored_value'. 4 22* 24 October 1981, ME Presser - added inquire_op. 4 23* 20 October 1981, C R Davis - add (read write)_internal_file_op. 4 24* 11 May 1981, Marshall Presser - added op-codes for .EQV. and .NEQV. 4 25* 28 April 1981, Marshall Presser - added default_main_entry_point_name 4 26* 11 March 1981, Marshall Presser - add min_stored_value 4 27* 8 December 1980, C R Davis - add block_if_op, else_if_op, else_op. 4 28* 15 January 1980, C R Davis - add bits_per_char. 4 29* 21 December 1979, Richard A. Barnes - add unrecoverable_errror and 4 30* max_error_level. 4 31* 3 November 1979, Richard Barnes - add pointer_node. 4 32* 17 September 1979, Richard Barnes - add load_preg_op & load_xreg_op 4 33* 13 September 1979, Paul Smee - add colon and concat token types, 4 34* change value of EOS_token, remove default_char_size. 4 35* 31 August 1979, Charlie Davis - change offset units to 4 36* be consistent with those in runtime symbols. 4 37* 13 August 1979, Richard Barnes - add cat_op & substr_op 4 38* 19 July 1979, Richard Barnes - char mode 4 39* 10 October 1978, Paul Smee - double max_stored_value and bias. 4 40* 15 June 1978, Paul Smee - add max_num_of_rands 4 41* 16 November 1977, David Levin - add machine_state_node 4 42* 12 September 1977, Richard Barnes - new ops for loop optimizer 4 43* 30 August 1977, David Levin - change bias from 65536 to 131072. 4 44* 5 July 1977, David Levin - add open_op, close_op, and iostat_op. 4 45* 28 April 1977, David Levin - add xmit_vector_op in operator list 4 46* 22 April 1977, David Levin - add max_prec_single, last_assigned_mode 4 47* 24 February 1977, Gabriel Chang for the optimizer. 4 48* 23 February 1977, David Levin to change name of count operand. 4 49* 28 October 1976, David Levin and Gabriel Chang to add 2 new ops and 4 50* 1 new node type. 4 51* 2 September 1976, David Levin - add 8 new ops and change name of 4 52* data_op. 4 53**/ 4 54 /* SYSTEM CONSTANTS */ 4 55 4 56 dcl bias init(262144) fixed bin(19) int static options(constant); 4 57 dcl gap_value init(0) fixed bin int static options(constant); 4 58 dcl max_fixed_bin_18 init(111111111111111111b) fixed bin (18) static options (constant); 4 59 dcl max_fixed_bin_24 init(111111111111111111111111b) fixed bin (24) static options (constant); 4 60 dcl max_num_of_rands init(127) fixed bin int static options(constant); 4 61 dcl sys_info$max_seg_size 4 62 fixed bin (18) ext; 4 63 4 64 dcl ( unrecoverable_error init(3), 4 65 max_error_level init(4)) 4 66 fixed bin int static options(constant); 4 67 4 68 dcl (main_program init(0), 4 69 block_data init(1), 4 70 subroutine init(2), 4 71 function init(3), 4 72 chars_per_word init(4), 4 73 chars_per_dw init(8), 4 74 bits_per_char init(9), 4 75 first_auto_loc init(64), 4 76 max_prec_single init(8)) fixed bin(9) int static options(constant); 4 77 dcl max_char_length init(512) fixed bin(10) int static options(constant); 4 78 4 79 dcl blank_common_name init("blnk*com") char(8) aligned int static options(constant); 4 80 declare default_main_entry_point_name 4 81 char (5) int static options (constant) initial ("main_"); 4 82 declare unnamed_block_data_subprg_name 4 83 char (29) int static options (constant) initial ("unnamed block data subprogram"); 4 84 4 85 /* NODE TYPES */ 4 86 4 87 dcl (fill_node init(0), 4 88 source_node init(1), 4 89 symbol_node init(2), 4 90 dimension_node init(3), 4 91 temporary_node init(4), 4 92 constant_node init(5), 4 93 label_node init(6), 4 94 header_node init(7), 4 95 char_constant_node init(8), 4 96 array_ref_node init(9), 4 97 proc_frame_node init(10), 4 98 library_node init(11), 4 99 subprogram_node init(12), 4 100 arg_desc_node init(13), 4 101 pointer_node init(14), 4 102 machine_state_node init(15)) fixed bin(4) aligned internal static options(constant); 4 103 4 104 /* DATA TYPES */ 4 105 4 106 dcl (int_mode init(1), 4 107 real_mode init(2), 4 108 dp_mode init(3), 4 109 cmpx_mode init(4), 4 110 logical_mode init(5), 4 111 char_mode init(6), 4 112 typeless_mode init(7), 4 113 last_assigned_mode init(7)) fixed bin(4) aligned internal static options(constant); 4 114 4 115 dcl data_type_size(7) init(1,1,2,2,1,0,1) fixed bin int static options(constant); 4 116 4 117 4 118 /* OPERAND TYPES */ 4 119 4 120 dcl (variable_type init(1), 4 121 constant_type init(2), 4 122 array_ref_type init(3), 4 123 temp_type init(4), 4 124 count_type init(5), 4 125 rel_constant init(6), 4 126 bif init(7), 4 127 statement_function init(8), 4 128 external init(9), 4 129 entry_type init(10), 4 130 dummy init(11), 4 131 error init(12)) fixed bin(4) aligned internal static options(constant); 4 132 4 133 4 134 /* OFFSET UNITS */ 4 135 4 136 dcl 4 137 (word_units init (0), 4 138 bit_units init (1), 4 139 char_units init (2), 4 140 halfword_units init (3)) fixed bin (3) aligned internal static options(constant); 4 141 4 142 dcl units_per_word (0:3) init (1, 36, 4, 2) fixed bin (6) static options (constant); 4 143 4 144 4 145 /* TOKEN MASKS */ 4 146 4 147 dcl 4 148 (is_operand initial("101000000"b), 4 149 is_operator initial("010000000"b), 4 150 is_constant initial("001000000"b), 4 151 is_arith_constant initial("000100000"b)) bit(9) aligned internal static options(constant); 4 152 4 153 4 154 /* TOKEN TYPES */ 4 155 4 156 dcl (no_token initial("000000000"b), 4 157 ident initial("100000000"b), 4 158 plus initial("010000001"b), 4 159 minus initial("010000010"b), 4 160 asterisk initial("010000011"b), 4 161 slash initial("010000100"b), 4 162 expon initial("010000101"b), 4 163 not initial("010000110"b), 4 164 and initial("010000111"b), 4 165 or initial("010001000"b), 4 166 eq initial("010001001"b), 4 167 ne initial("010001010"b), 4 168 lt initial("010001011"b), 4 169 gt initial("010001100"b), 4 170 le initial("010001101"b), 4 171 ge initial("010001110"b), 4 172 assign initial("010001111"b), 4 173 comma initial("010010000"b), 4 174 left_parn initial("010010001"b), 4 175 right_parn initial("010010010"b), 4 176 apostrophe initial("010010011"b), 4 177 colon initial("010010100"b), 4 178 concat initial("010010101"b), 4 179 substr_left_parn initial("010010110"b), 4 180 eqv initial("010010111"b), 4 181 neqv initial("010011000"b), 4 182 EOS_token initial("010011111"b), 4 183 char_string initial("001000001"b), 4 184 logical_const initial("001000010"b), 4 185 false initial("001000010"b), /* Must be identical to true except low order bit off. */ 4 186 true initial("001000011"b), /* Must be identical to false except low order bit on. */ 4 187 label_const initial("001000100"b), 4 188 octal_const initial("001000101"b), 4 189 dec_int initial("001100110"b), 4 190 real_const initial("001100111"b), 4 191 double_const initial("001101000"b), 4 192 complex_const initial("001101001"b)) bit(9) aligned internal static options(constant); 4 193 4 194 4 195 /* OPERATOR NAMES */ 4 196 4 197 declare 4 198 (assign_op initial(1), 4 199 add_op initial(2), 4 200 sub_op initial(3), 4 201 mult_op initial(4), 4 202 div_op initial(5), 4 203 exponentiation_op initial(6), 4 204 negate_op initial(7), 4 205 less_op initial(8), 4 206 less_or_equal_op initial(9), 4 207 equal_op initial(10), 4 208 not_equal_op initial(11), 4 209 greater_or_equal_op initial(12), 4 210 greater_op initial(13), 4 211 or_op initial(14), 4 212 and_op initial(15), 4 213 not_op initial(16), 4 214 jump_op initial(17), 4 215 jump_logical_op initial(18), 4 216 jump_arithmetic_op initial(19), 4 217 jump_computed_op initial(20), 4 218 jump_assigned_op initial(21), 4 219 assign_label_op initial(22), 4 220 read_op initial(23), 4 221 write_op initial(24), 4 222 format_op initial(25), 4 223 end_label_op initial(26), 4 224 error_label_op initial(27), 4 225 xmit_scalar_op initial(28), 4 226 xmit_array_op initial(29), 4 227 xmit_vector_op initial(30), 4 228 endfile_op initial(31), 4 229 rewind_op initial(32), 4 230 backspace_op initial(33), 4 231 margin_op initial(34), 4 232 openfile_op initial(35), 4 233 closefile_op initial(36), 4 234 record_number_op initial(37), 4 235 string_op initial(38), 4 236 string_length_op initial(39), 4 237 terminate_op initial(40), 4 238 return_op initial(41), 4 239 pause_op initial(42), 4 240 stop_op initial(43), 4 241 item_op initial(44), 4 242 exit_op initial(45), 4 243 eol_op initial(46), 4 244 do_op initial(47), 4 245 builtin_op initial(48), 4 246 sf_op initial(49), 4 247 sf_def_op initial(50), 4 248 subscript_op initial(51), 4 249 func_ref_op initial(52), 4 250 block_data_op initial(53), 4 251 increment_polish_op initial(54), 4 252 main_op initial(55), 4 253 func_op initial(56), 4 254 subr_op initial(57), 4 255 stat_op initial(58), 4 256 label_op initial(59), 4 257 call_op initial(60), 4 258 chain_op initial(61), 4 259 endunit_op initial(62), 4 260 non_executable initial(63), 4 261 no_op initial(64), 4 262 form_VLA_packed_ptr_op initial(65), 4 263 opt_subscript_op initial(66), 4 264 left_shift_op initial(67), 4 265 right_shift_op initial(68), 4 266 store_zero_op initial(69), 4 267 storage_add_op initial(70), 4 268 storage_sub_op initial(71), 4 269 neg_storage_add_op initial(72), 4 270 storage_add_one_op initial(73), 4 271 namelist_op initial(74), 4 272 open_op initial(75), 4 273 close_op initial(76), 4 274 iostat_op initial(77), 4 275 convert_to_int_op initial(78), 4 276 convert_to_real_op initial(79), 4 277 convert_to_dp_op initial(80), 4 278 convert_to_cmpx_op initial(81), 4 279 read_scalar_op initial(82), 4 280 read_array_op initial(83), 4 281 read_vector_op initial(84), 4 282 write_scalar_op initial(85), 4 283 write_array_op initial(86), 4 284 write_vector_op initial(87), 4 285 jump_true_op initial(88), 4 286 jump_false_op initial(89), 4 287 sub_index_op initial(90), 4 288 loop_end_op initial(91), 4 289 read_namelist_op initial(92), 4 290 write_namelist_op initial(93), 4 291 decode_string_op initial(94), 4 292 encode_string_op initial(95), 4 293 cat_op initial(96), 4 294 substr_op initial(97), 4 295 load_xreg_op initial(98), 4 296 load_preg_op initial(99), 4 297 block_if_op initial(100), 4 298 else_if_op initial(101), 4 299 else_op initial(102), 4 300 equiv_op initial (103), 4 301 not_equiv_op initial (104), 4 302 read_internal_file_op initial (105), 4 303 write_internal_file_op initial (106), 4 304 inquire_op initial (107), 4 305 process_param_list_op initial (108), 4 306 lhs_fld_op initial (109), 4 307 last_assigned_op initial (109)) fixed bin(18) internal static options(constant); 4 308 4 309 /* END fort_system_constants.incl.pl1 */ 401 5 1 /* BEGIN fort_nodes.incl.pl1 */ 5 2 5 3 5 4 5 5 /****^ HISTORY COMMENTS: 5 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 5 7* install(86-07-28,MR12.0-1105): 5 8* Fix fortran bug 473. 5 9* 2) change(88-04-28,RWaters), approve(88-04-28,MCR7875), audit(88-07-13,Huen), 5 10* install(88-11-10,MR12.2-1209): 5 11* Implement SCP 6339: Allow character variable to be up to 128K-1 (131071) 5 12* character long. 5 13* END HISTORY COMMENTS */ 5 14 5 15 5 16 /* Written: June 1976 by David Levin and Richard Barnes 5 17* 5 18*Modified: 5 19* Feb 24 1977 by G. Chang for the optimizer 5 20* Sept 12, 1977 by R. Barnes for the loop optimizer 5 21* Nov 16, 1977 by D. Levin to add machine state node for loop optimizer 5 22* Oct 09 1978 by P Smee for larger common and arrays. 5 23* Dec 05 1978 by P Smee for %options statement. 5 24* Jan 17 1979 by R Barnes for machine_state.value_in_xr 5 25* May 23 1979 by P Smee to add source.line_number 5 26* July 19 1979 by R Barnes for char mode changes 5 27* Sept 17 1979 by R Barnes for register optimizer changes 5 28* Oct 3 1979 by C R Davis for new EAQ management scheme. 5 29* 29 Oct 1979 by C R Davis for machine_state.eaq.reserved. 5 30* 3 Nov 1979 by R. Barnes for pointer node and to change 5 31* machine_state.next from a fixed bin to a pointer. 5 32* 18 Dec 1979 by R. Barnes for loop_ref_count to finalize 5 33* changes for the register optimizer. 5 34* 17 Dec 1979 by C R Davis for symbol.descriptor 5 35* 22 Dec 1979 by R. Barnes to remove in_list. 5 36* 22 Jan 1980 by P E Smee to try for long char arrays. 5 37* 23 Jan 1980 by C R Davis to fix bugs with yesterday's changes. 5 38* 4 Mar 1980 by C R Davis to rename node.multi_position to 5 39* node.stack_indirect, and to add machine_state.stack_extended 5 40* and machine_state.last_dynamic_temp. 5 41* 5 Jun 1980 by M E Presser to alter arg_desc node for use 5 42* in stack-extensions and arg-descriptor generation. 5 43* 16 July 1980 by C R Davis for symbol.variable_arglist. 5 44* 8 Jan 81 by M E Presser for label.not_referencable 5 45* 17 Feb 1981 by C R Davis for new dimension node layout. 5 46* 11 March 1981 by MEP for dimension.assumed_size 5 47* 3 May 1982 by TO to add star_extent_function to subprogram node. 5 48* Mod 1 25 August 1982 by TO to add VLA_chain and LA_chain to subprogram node. 5 49* Mod 1 2 September 1982 by TO to add 5 more entries to storage_info in 5 50* the subprogram node (13-17), and to add VLA and LA bits to the 5 51* symbol node. 5 52* Mod 1 2 September 1982 by TO move fields around in nodes to get correct 5 53* 24 (really 35) bit fields and still maintain mapping between 5 54* node, temporary, and array_ref (others limit to word 6 like node.) 5 55* 19 Jun 83, HH - 145: Add 'branched_to', 'ends_do_loop' & 'loop_end' 5 56* to 'label' node. 5 57* 19 Feb 86, BW & AG - 473.a: Add 'VLA' to 'arg_desc' node. 5 58*END Modifications */ 5 59 5 60 5 61 /* GENERAL NODE TEMPLATE */ 5 62 5 63 dcl 1 node aligned based structure, 5 64 5 65 /* WORD 1 */ 5 66 5 67 2 node_type fixed bin (4) unaligned, 5 68 2 data_type fixed bin (4) unaligned unsigned, 5 69 2 operand_type fixed bin (4) unaligned, 5 70 5 71 2 addressing_bits unaligned structure, 5 72 3 is_addressable bit (1), 5 73 3 value_in, 5 74 4 eaq bit (1), 5 75 4 x bit (1), 5 76 3 allocated bit (1), 5 77 3 needs_pointer bit (1), 5 78 3 stack_indirect bit (1), 5 79 3 large_address bit (1), 5 80 3 address_in_base bit (1), 5 81 3 dont_update bit (1), /* for optimizer */ 5 82 3 not_in_storage bit (1), /* for optimizer */ 5 83 3 globally_assigned bit (1), /* for optimizer */ 5 84 5 85 2 bits unaligned structure, 5 86 3 standard_bits, 5 87 4 allocate bit (1), 5 88 4 set bit (1), 5 89 4 referenced bit (1), 5 90 4 passed_as_arg bit (1), 5 91 5 92 3 fill bit (7), /* These bits may be used by individual nodes. */ 5 93 5 94 /* WORD 2 */ 5 95 5 96 2 address aligned structure, 5 97 3 base bit (3) unaligned, /* For labels and constants, base and offset are */ 5 98 3 offset fixed bin (14) unaligned, /* combined to: fixed bin (18) unsigned unaligned. */ 5 99 3 char_num fixed bin (2) unaligned unsigned, 5 100 3 bit_num fixed bin (4) unaligned unsigned, 5 101 3 fill bit (4) unaligned, 5 102 3 inhibit bit (1) unaligned, 5 103 3 ext_base bit (1) unaligned, 5 104 3 tag bit (6) unaligned, 5 105 5 106 /* WORD 3 */ 5 107 5 108 2 units fixed bin (3) unaligned unsigned, 5 109 2 fill bit (3) unaligned, /* already used in symbol node */ 5 110 2 reloc_hold bit (6) unaligned, 5 111 2 reloc bit (6) unaligned, 5 112 2 addr_hold bit (18) unaligned, 5 113 5 114 /* WORD 4. Must not change for constant, char_constant, header, label, or symbol nodes. */ 5 115 5 116 2 next fixed bin (18) unsigned unaligned, 5 117 2 hash_chain fixed bin (18) unsigned unaligned, /* No hash chain for header nodes. */ 5 118 5 119 /* WORD 5 */ 5 120 5 121 2 pad fixed bin (18) unsigned unaligned, 5 122 2 loop_ref_count fixed bin (17) unaligned, /* Only for symbols and temporaries. */ 5 123 5 124 /* WORD 6 */ 5 125 5 126 2 location fixed bin (24) aligned; /* Only for array refs, symbols, temporaries, and headers. */ 5 127 5 128 /* ARG DESCRIPTOR NODE */ 5 129 5 130 dcl 1 arg_desc based aligned, 5 131 5 132 /* WORD 1 */ 5 133 5 134 2 node_type fixed bin (4) unaligned, 5 135 2 n_args fixed bin (12) unaligned, 5 136 2 pad bit (18) unaligned, 5 137 5 138 /* WORDS 2 - N_ARGS + 1 */ 5 139 5 140 2 arg(num_args refer(n_args)) aligned, 5 141 3 data_type fixed bin (4) unaligned unsigned, 5 142 3 must_be unaligned, 5 143 4 array bit (1) unaligned, 5 144 4 scalar bit (1) unaligned, 5 145 4 VLA bit (1) unaligned, 5 146 3 star_extents bit (1) unaligned, 5 147 3 pad bit (9) unaligned, 5 148 3 symbol fixed bin (18) unaligned; 5 149 5 150 dcl num_args fixed bin; 5 151 5 152 5 153 /* ARRAY REF NODE -- Must be same size as TEMPORARY NODE. */ 5 154 5 155 dcl 1 array_ref aligned based structure, 5 156 5 157 /* WORD 1 */ 5 158 5 159 2 node_type fixed bin (4) unaligned, 5 160 2 data_type fixed bin (4) unaligned unsigned, 5 161 2 operand_type fixed bin (4) unaligned, 5 162 5 163 2 addressing_bits unaligned structure, 5 164 3 is_addressable bit (1), 5 165 3 value_in, 5 166 4 eaq bit (1), 5 167 4 x bit (1), 5 168 3 allocated bit (1), 5 169 3 needs_pointer bit (1), 5 170 3 stack_indirect bit (1), 5 171 3 large_address bit (1), 5 172 3 address_in_base bit (1), 5 173 3 dont_update bit (1), /* for optimizer */ 5 174 3 not_in_storage bit (1), /* for optimizer */ 5 175 3 globally_assigned bit (1), /* for optimizer */ 5 176 5 177 2 bits unaligned structure, 5 178 3 standard_bits, 5 179 4 allocate bit (1), 5 180 4 set bit (1), 5 181 4 referenced bit (1), 5 182 4 passed_as_arg bit (1), 5 183 5 184 3 variable_length bit (1), 5 185 5 186 3 variable_offset bit (1), 5 187 5 188 3 invariant bit (1), /* must line up with temporary node */ 5 189 3 irreducible bit (1), /* .. */ 5 190 3 used_across_loops bit (1), /* .. */ 5 191 5 192 3 large_offset bit (1), 5 193 5 194 3 has_address bit (1), 5 195 5 196 /* WORD 2 */ 5 197 5 198 2 address aligned structure, 5 199 3 base bit (3) unaligned, 5 200 3 offset fixed bin (14) unaligned, 5 201 3 char_num fixed bin (2) unaligned unsigned, 5 202 3 bit_num fixed bin (4) unaligned unsigned, 5 203 3 fill bit (4) unaligned, 5 204 3 inhibit bit (1) unaligned, 5 205 3 ext_base bit (1) unaligned, 5 206 3 tag bit (6) unaligned, 5 207 5 208 /* WORD 3 */ 5 209 5 210 2 units fixed bin (3) unaligned unsigned, 5 211 2 fill bit (3) unaligned, 5 212 2 reloc_hold bit (6) unaligned, 5 213 2 reloc bit (6) unaligned, 5 214 2 addr_hold bit (18) unaligned, 5 215 5 216 /* WORD 4 */ 5 217 5 218 2 next fixed bin (18) unsigned unaligned, 5 219 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay temporary.loop_end_fu_pos */ 5 220 5 221 /* WORD 5 */ 5 222 5 223 2 pad fixed bin (18) unsigned unaligned, 5 224 2 v_offset fixed bin (18) unsigned unaligned, 5 225 5 226 /* WORD 6 */ 5 227 5 228 2 location fixed bin (24) aligned, 5 229 5 230 /* WORD 7 */ 5 231 5 232 2 ref_count fixed bin (17) unaligned, /* must overlay temporary.ref_count */ 5 233 2 output_by fixed bin (18) unsigned unal, /* must overlay temporary.output_by */ 5 234 5 235 /* WORD 8 */ 5 236 5 237 2 length fixed bin (24) aligned, 5 238 5 239 /* WORD 9 */ 5 240 5 241 2 start_input_to fixed bin (18) unsigned unal, /* must overlay temporary.start_input_to */ 5 242 2 end_input_to fixed bin (18) unsigned unal, /* must overlay temporary.end_input_to */ 5 243 5 244 /* WORD 10 */ 5 245 5 246 2 ref_count_copy fixed bin (17) unaligned, /* must overlay temporary.ref_count_copy */ 5 247 2 parent fixed bin (18) unsigned unaligned, 5 248 5 249 /* WORD 11 */ 5 250 5 251 2 unused fixed bin (24) aligned; /* Pad to size of 'temporary'. */ 5 252 5 253 5 254 /* CONSTANT NODE */ 5 255 5 256 dcl 1 constant aligned based structure, 5 257 5 258 /* WORD 1 */ 5 259 5 260 2 node_type fixed bin (4) unaligned, 5 261 2 data_type fixed bin (4) unaligned unsigned, 5 262 2 operand_type fixed bin (4) unaligned, 5 263 5 264 2 addressing_bits unaligned structure, 5 265 3 is_addressable bit (1), 5 266 3 value_in, 5 267 4 eaq bit (1), 5 268 4 x bit (1), 5 269 3 allocated bit (1), 5 270 3 needs_pointer bit (1), 5 271 3 stack_indirect bit (1), 5 272 3 large_address bit (1), 5 273 3 address_in_base bit (1), 5 274 3 dont_update bit (1), /* for optimizer */ 5 275 3 not_in_storage bit (1), /* for optimizer */ 5 276 3 globally_assigned bit (1), /* for optimizer */ 5 277 5 278 2 bits unaligned structure, 5 279 3 standard_bits, 5 280 4 allocate bit (1), 5 281 4 set bit (1), 5 282 4 referenced bit (1), 5 283 4 passed_as_arg bit (1), 5 284 5 285 3 fill bit (7), 5 286 5 287 /* WORD 2 */ 5 288 5 289 2 address aligned structure, 5 290 3 location fixed bin (18) unsigned unaligned, 5 291 3 op bit (10) unaligned, 5 292 3 inhibit bit (1) unaligned, 5 293 3 ext_base bit (1) unaligned, 5 294 3 tag bit (6) unaligned, 5 295 5 296 /* WORD 3 */ 5 297 5 298 2 units fixed bin (3) unaligned unsigned, 5 299 2 fill bit (3) unaligned, 5 300 2 reloc_hold bit (6) unaligned, 5 301 2 reloc bit (6) unaligned, 5 302 2 addr_hold bit (18) unaligned, 5 303 5 304 /* WORD 4 */ 5 305 5 306 2 next_constant fixed bin (18) unsigned unaligned, 5 307 2 hash_chain fixed bin (18) unsigned unaligned, 5 308 5 309 /* WORDS 5 & 6 */ 5 310 5 311 2 value bit (72) aligned; 5 312 5 313 5 314 /* CHARACTER CONSTANT NODE */ 5 315 5 316 dcl 1 char_constant aligned based structure, 5 317 5 318 /* WORD 1 */ 5 319 5 320 2 node_type fixed bin (4) unaligned, 5 321 2 data_type fixed bin (4) unaligned unsigned, 5 322 2 operand_type fixed bin (4) unaligned, 5 323 5 324 2 addressing_bits unaligned structure, 5 325 3 is_addressable bit (1), 5 326 3 value_in, 5 327 4 eaq bit (1), 5 328 4 x bit (1), 5 329 3 allocated bit (1), 5 330 3 needs_pointer bit (1), 5 331 3 stack_indirect bit (1), 5 332 3 large_address bit (1), 5 333 3 address_in_base bit (1), 5 334 3 dont_update bit (1), /* for optimizer */ 5 335 3 not_in_storage bit (1), /* for optimizer */ 5 336 3 globally_assigned bit (1), /* for optimizer */ 5 337 5 338 2 bits unaligned structure, 5 339 3 standard_bits, 5 340 4 allocate bit (1), 5 341 4 set bit (1), 5 342 4 referenced bit (1), 5 343 4 passed_as_arg bit (1), 5 344 5 345 3 no_value_stored bit (1), 5 346 5 347 3 fill bit (6), 5 348 5 349 /* WORD 2 */ 5 350 5 351 2 address aligned structure, 5 352 3 location fixed bin (18) unsigned unaligned, 5 353 3 char_num fixed bin (2) unaligned unsigned, 5 354 3 bit_num fixed bin (4) unaligned unsigned, 5 355 3 fill bit (4) unaligned, 5 356 3 inhibit bit (1) unaligned, 5 357 3 ext_base bit (1) unaligned, 5 358 3 tag bit (6) unaligned, 5 359 5 360 /* WORD 3 */ 5 361 5 362 2 units fixed bin (3) unaligned unsigned, 5 363 2 fill bit (3) unaligned, 5 364 2 reloc_hold bit (6) unaligned, 5 365 2 reloc bit (6) unaligned, 5 366 2 addr_hold bit (18) unaligned, 5 367 5 368 /* WORD 4 */ 5 369 5 370 2 next_constant fixed bin (18) unsigned unaligned, 5 371 2 hash_chain fixed bin (18) unsigned unaligned, 5 372 5 373 /* WORDS 5 thru n */ 5 374 5 375 2 length fixed bin (18) unsigned unaligned, 5 376 2 value char(char_constant_length refer(char_constant.length)) unaligned; 5 377 5 378 dcl char_constant_length fixed bin (18) unsigned; 5 379 5 380 5 381 /* DIMENSION NODE */ 5 382 5 383 dcl 1 dimension aligned based structure, 5 384 5 385 /* WORD 1 */ 5 386 5 387 2 node_type fixed bin (4) unaligned, /* The only field in common with other nodes */ 5 388 5 389 2 number_of_dims fixed bin (3) unaligned, /* Number of dimensions */ 5 390 5 391 2 v_bound (7) unaligned, /* Variable bound info - up to 7 dims. */ 5 392 3 lower bit (1) unaligned, /* On if lower bound is variable */ 5 393 3 upper bit (1) unaligned, /* On if upper bound is variable */ 5 394 5 395 2 has_virtual_origin bit (1) unaligned, /* On if virtual_origin is valid */ 5 396 2 has_array_size bit (1) unaligned, /* On if array_size is valid */ 5 397 2 has_dim_sizes bit (1) unaligned, /* On if dim.size (*) is valid */ 5 398 5 399 2 variable_virtual_origin bit (1) unaligned, /* On if virtual_origin is variable */ 5 400 2 variable_array_size bit (1) unaligned, /* On if array_size is variable */ 5 401 2 assumed_size bit (1) unaligned, /* On if array has assumed size */ 5 402 5 403 2 fill bit (7) unaligned, 5 404 5 405 /* WORD 2 */ 5 406 5 407 2 virtual_origin fixed bin (24) aligned, 5 408 5 409 /* WORD 3 */ 5 410 5 411 2 element_count fixed bin (24) aligned, 5 412 5 413 /* WORD 4 */ 5 414 5 415 2 array_size fixed bin (24) aligned, /* Expressed in symbol.units */ 5 416 5 417 /* WORD 5 */ 5 418 5 419 2 VLA_base_addressor fixed bin (18) aligned, 5 420 5 421 /* WORDS 6 - n (max = 26) */ 5 422 5 423 2 dim (num_dims refer (dimension.number_of_dims)) aligned, 5 424 5 425 3 lower_bound fixed bin (24) aligned, /* Lower bound of this dimension */ 5 426 5 427 3 upper_bound fixed bin (24) aligned, /* Upper bound of this dimension */ 5 428 5 429 3 size fixed bin (24) aligned; /* No. of elements in this dimension */ 5 430 5 431 dcl num_dims fixed bin (3); 5 432 5 433 5 434 /* HEADER NODE */ 5 435 5 436 dcl 1 header aligned based structure, 5 437 5 438 /* WORD 1 */ 5 439 5 440 2 node_type fixed bin (4) unaligned, 5 441 2 data_type fixed bin (4) unaligned unsigned, 5 442 2 operand_type fixed bin (4) unaligned, 5 443 5 444 2 addressing_bits unaligned structure, 5 445 3 is_addressable bit (1), 5 446 3 value_in, 5 447 4 eaq bit (1), 5 448 4 x bit (1), 5 449 3 allocated bit (1), 5 450 3 needs_pointer bit (1), 5 451 3 stack_indirect bit (1), 5 452 3 large_address bit (1), 5 453 3 address_in_base bit (1), 5 454 3 dont_update bit (1), /* for optimizer */ 5 455 3 not_in_storage bit (1), /* for optimizer */ 5 456 3 globally_assigned bit (1), /* for optimizer */ 5 457 5 458 2 bits unaligned structure, 5 459 3 storage_info, 5 460 4 standard_bits, 5 461 5 allocate bit (1), 5 462 5 set bit (1), 5 463 5 referenced bit (1), 5 464 5 passed_as_arg bit (1), 5 465 4 initialed bit (1), /* On if any member has initial attribute. */ 5 466 5 467 3 alignment structure unaligned, 5 468 4 even bit (1), 5 469 4 odd bit (1), 5 470 4 character bit (1), 5 471 5 472 3 storage_class structure unaligned, 5 473 4 automatic bit (1), 5 474 4 static bit (1), 5 475 4 in_common bit (1), 5 476 5 477 /* WORD 2 */ 5 478 5 479 2 address aligned structure, 5 480 3 base bit (3) unaligned, 5 481 3 offset fixed bin (14) unaligned, 5 482 3 char_num fixed bin (2) unaligned unsigned, 5 483 3 bit_num fixed bin (4) unaligned unsigned, 5 484 3 fill bit (4) unaligned, 5 485 3 inhibit bit (1) unaligned, 5 486 3 ext_base bit (1) unaligned, 5 487 3 tag bit (6) unaligned, 5 488 5 489 /* WORD 3 */ 5 490 5 491 2 units fixed bin (3) unaligned unsigned, 5 492 2 VLA bit (1) unaligned, /* chain for VLA's */ 5 493 2 LA bit (1) unaligned, /* chain for LA's */ 5 494 2 fill bit (1) unaligned, 5 495 2 reloc_hold bit (6) unaligned, 5 496 2 reloc bit (6) unaligned, 5 497 2 addr_hold bit (18) unaligned, 5 498 5 499 /* WORD 4 */ 5 500 5 501 2 next_header fixed bin (18) unsigned unaligned, 5 502 2 first_element fixed bin (18) unsigned unaligned, 5 503 5 504 /* WORD 5 */ 5 505 5 506 2 last_element fixed bin (18) unsigned unaligned, 5 507 2 name_length fixed bin (17) unaligned, 5 508 5 509 /* WORD 6 */ 5 510 5 511 2 location fixed bin (24) aligned, 5 512 5 513 /* WORD 7 */ 5 514 5 515 2 length fixed bin (24) aligned, 5 516 5 517 /* WORD 8 */ 5 518 5 519 2 VLA_base_addressor fixed bin (18) aligned, 5 520 5 521 /* WORDS 9 - n. This field is variable in length. Its length is zero for equivalence groups. */ 5 522 5 523 2 block_name char(allocate_symbol_name refer (header.name_length)) aligned; 5 524 5 525 dcl allocate_symbol_name fixed bin; 5 526 5 527 5 528 /* LABEL NODE */ 5 529 5 530 dcl 1 label aligned based structure, 5 531 5 532 /* WORD 1 */ 5 533 5 534 2 node_type fixed bin (4) unaligned, 5 535 2 data_type fixed bin (4) unaligned unsigned, 5 536 2 operand_type fixed bin (4) unaligned, 5 537 5 538 2 addressing_bits unaligned structure, 5 539 3 is_addressable bit (1), 5 540 3 value_in, 5 541 4 eaq bit (1), 5 542 4 x bit (1), 5 543 3 allocated bit (1), 5 544 3 needs_pointer bit (1), 5 545 3 stack_indirect bit (1), 5 546 3 large_address bit (1), 5 547 3 address_in_base bit (1), 5 548 3 dont_update bit (1), /* for optimizer */ 5 549 3 not_in_storage bit (1), /* for optimizer */ 5 550 3 globally_assigned bit (1), /* for optimizer */ 5 551 5 552 2 bits unaligned structure, 5 553 3 storage_info, 5 554 4 standard_bits, 5 555 5 allocate bit (1), 5 556 5 set bit (1), 5 557 5 referenced bit (1), 5 558 5 passed_as_arg bit (1), 5 559 4 referenced_executable bit (1), 5 560 5 561 3 usage, /* Label is on a non-executable stmnt if both bits are ON. */ 5 562 4 format bit (1), 5 563 4 executable bit (1), 5 564 5 565 3 restore_prs bit (1), 5 566 3 not_referencable bit (1), 5 567 3 branched_to bit (1), 5 568 3 ends_do_loop bit (1), 5 569 5 570 /* WORD 2 */ 5 571 5 572 2 address aligned structure, 5 573 3 location fixed bin (18) unsigned unaligned, 5 574 3 op bit (10) unaligned, 5 575 3 inhibit bit (1) unaligned, 5 576 3 ext_base bit (1) unaligned, 5 577 3 tag bit (6) unaligned, 5 578 5 579 /* WORD 3 */ 5 580 5 581 2 units fixed bin (3) unaligned unsigned, 5 582 2 fill bit (3) unaligned, 5 583 2 reloc_hold bit (6) unaligned, 5 584 2 reloc bit (6) unaligned, 5 585 2 addr_hold bit (18) unaligned, 5 586 5 587 /* WORD 4 */ 5 588 5 589 2 next_label fixed bin (18) unsigned unaligned, 5 590 2 hash_chain fixed bin (18) unsigned unaligned, 5 591 5 592 /* WORD 5 */ 5 593 5 594 2 format_var fixed bin (18) unsigned unaligned, 5 595 2 name fixed bin (17) unaligned, 5 596 5 597 /* WORD 6 */ 5 598 5 599 2 statement fixed bin (18) unsigned unaligned, 5 600 2 loop_end fixed bin (18) unsigned unaligned; 5 601 5 602 5 603 /* LIBRARY NODE */ 5 604 5 605 dcl 1 library aligned based structure, 5 606 5 607 /* WORD 1 */ 5 608 5 609 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 5 610 2 fill bit (13) unaligned, 5 611 2 next_library_node fixed bin (18) unsigned unaligned, 5 612 5 613 /* WORD 2 */ 5 614 5 615 2 character_operand fixed bin (18) unsigned aligned; 5 616 5 617 5 618 /* MACHINE_STATE NODE */ 5 619 5 620 dcl 1 machine_state aligned based structure, 5 621 5 622 /* WORD 1 */ 5 623 5 624 2 node_type fixed bin (4) unal, 5 625 2 pad bit (31) unal, 5 626 5 627 /* WORD 2 */ 5 628 5 629 2 next pointer unaligned, 5 630 5 631 /* WORDS 3-104 */ 5 632 5 633 2 ms aligned, 5 634 5 635 3 eaq (4), /* One for each of the A, Q, EAQ, and IND */ 5 636 4 name fixed bin, 5 637 4 number fixed bin, 5 638 4 variable(4) fixed bin (18), 5 639 4 reserved bit (1) aligned, 5 640 3 rounded bit (1) aligned, 5 641 3 indicators_valid fixed bin (18), 5 642 5 643 3 value_in_xr bit (1) aligned, 5 644 5 645 3 index_regs(0:7), 5 646 4 bits structure unaligned, 5 647 5 global bit (1), 5 648 5 reserved bit (1), 5 649 5 mbz bit (34), 5 650 4 type fixed bin (18), 5 651 4 variable fixed bin (18), 5 652 4 used fixed bin (18), 5 653 4 mbz fixed bin (18), 5 654 5 655 3 address_in_base bit (1) aligned, 5 656 5 657 3 base_regs(0:7), 5 658 4 bits structure unaligned, 5 659 5 global bit (1), 5 660 5 reserved bit (1), 5 661 5 mbz bit (34), 5 662 4 type fixed bin (18), 5 663 4 variable fixed bin (18), 5 664 4 used fixed bin (18), 5 665 4 offset fixed bin (18), 5 666 5 667 3 stack_extended bit (1) aligned, 5 668 3 last_dynamic_temp fixed bin (18); 5 669 5 670 /* POINTER NODE */ 5 671 5 672 dcl 1 pointer aligned based structure, 5 673 5 674 /* WORD 1 */ 5 675 5 676 2 node_type fixed bin (4) unaligned, 5 677 2 pad bit (4) unaligned, 5 678 2 code fixed bin (9) unaligned unsigned, 5 679 2 variable fixed bin (18) unaligned unsigned, 5 680 5 681 /* WORD 2 */ 5 682 5 683 2 offset fixed bin (18) unaligned unsigned, 5 684 2 count fixed bin (18) unaligned unsigned, 5 685 5 686 /* WORD 3 */ 5 687 5 688 2 hash_chain fixed bin (18) aligned; 5 689 5 690 5 691 /* SOURCE NODE */ 5 692 5 693 dcl 1 source aligned based structure, 5 694 5 695 /* WORD 1 */ 5 696 5 697 2 node_type fixed bin (4) unal, 5 698 2 pad bit (13) unal, 5 699 2 line_number fixed bin (17) unaligned, 5 700 5 701 /* WORD 2 */ 5 702 5 703 2 uid bit (36) aligned, 5 704 5 705 /* WORDS 3 & 4 */ 5 706 5 707 2 dtm fixed bin (71) unaligned, 5 708 5 709 /* WORD 5 */ 5 710 5 711 2 next fixed bin (18) unsigned unaligned, 5 712 2 initial_subprogram fixed bin (18) unsigned unaligned, 5 713 5 714 /* WORDS 6 - ? (depends on length of pathname) */ 5 715 5 716 2 pathname char(256) varying; 5 717 5 718 5 719 /* STATEMENT NODE - This node only appears in the polish. */ 5 720 5 721 dcl 1 statement aligned based structure, 5 722 5 723 /* WORD 1 */ 5 724 5 725 2 op_code fixed bin aligned, /* Always equal to "stat_op". */ 5 726 5 727 /* WORD 2 */ 5 728 5 729 2 next bit (18) unaligned, /* "0"b = no next stmnt */ 5 730 2 location bit (18) unaligned, /* (18)"1"b = no text */ 5 731 5 732 /* WORD 3 */ 5 733 5 734 2 source_id structure unaligned, 5 735 3 file fixed bin (8) unsigned, /* 0 = first file */ 5 736 3 line bit (14), 5 737 3 statement bit (5), /* 1 = first statement */ 5 738 5 739 2 length bit (9) unaligned, 5 740 5 741 /* WORD 4 */ 5 742 5 743 2 bits structure unaligned, 5 744 3 put_in_map bit (1) unaligned, 5 745 3 put_in_profile bit (1) unaligned, 5 746 3 pad bit (7) unaligned, 5 747 5 748 2 start fixed bin (26) unaligned; 5 749 5 750 5 751 /* SUBPROGRAM NODE */ 5 752 5 753 dcl 1 subprogram aligned based structure, 5 754 5 755 /* WORD 1 */ 5 756 5 757 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 5 758 2 subprogram_type fixed bin (3) unaligned, 5 759 2 default_is unaligned, 5 760 3 auto bit (1), 5 761 3 static bit (1), 5 762 2 need_PS bit (1) unaligned, 5 763 2 need_prologue bit (1) unaligned, 5 764 2 multiple_entry bit (1) unaligned, 5 765 2 namelist_used bit (1) unaligned, 5 766 2 has_parameters bit (1) unaligned, 5 767 2 star_extent_function bit (1) unaligned, 5 768 2 fill bit (1) unaligned, 5 769 5 770 2 symbol fixed bin (18) unsigned unaligned, /* symbol node for subprogram name */ 5 771 5 772 /* WORD 2 */ 5 773 5 774 2 previous_subprogram fixed bin (18) unsigned unaligned, 5 775 2 next_subprogram fixed bin (18) unsigned unaligned, 5 776 5 777 /* WORD 3 */ 5 778 5 779 2 common_chain fixed bin (18) unsigned unaligned, 5 780 2 equiv_chain fixed bin (18) unsigned unaligned, 5 781 5 782 /* WORD 4 */ 5 783 5 784 2 first_symbol fixed bin (18) unsigned unaligned, 5 785 2 last_symbol fixed bin (18) unsigned unaligned, 5 786 5 787 /* WORD 5 */ 5 788 5 789 2 first_label fixed bin (18) unsigned unaligned, 5 790 2 last_label fixed bin (18) unsigned unaligned, 5 791 5 792 /* WORD 6 */ 5 793 5 794 2 first_polish fixed bin (18) unsigned unaligned, 5 795 2 last_polish fixed bin (18) unsigned unaligned, 5 796 5 797 /* WORD 7 */ 5 798 5 799 2 map unaligned, 5 800 3 first fixed bin (18) unsigned unaligned, 5 801 3 last fixed bin (18) unsigned unaligned, 5 802 5 803 /* WORD 8 */ 5 804 5 805 2 entry_info fixed bin (18) unsigned unaligned, 5 806 2 runtime fixed bin (18) unsigned unaligned, 5 807 5 808 /* WORD 9 */ 5 809 5 810 2 first_quad fixed bin (18) unsigned unaligned, 5 811 2 last_quad fixed bin (18) unsigned unaligned, 5 812 5 813 /* WORD 10 */ 5 814 5 815 2 options aligned like fortran_options, 5 816 5 817 /* WORDS 11 - 44 */ 5 818 5 819 2 storage_info(17) aligned, 5 820 3 first fixed bin (18) unsigned unaligned, 5 821 3 last fixed bin (18) unsigned unaligned, 5 822 3 next_loc fixed bin (18) aligned, 5 823 5 824 /* WORD 45 */ 5 825 5 826 2 loop_vector_p pointer unaligned, 5 827 5 828 /* WORD 46 */ 5 829 5 830 2 n_loops fixed bin (18) unsigned unaligned, 5 831 2 max_operators fixed bin (18) unsigned unaligned, 5 832 5 833 /* WORD 47 */ 5 834 5 835 2 VLA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 5 836 2 LA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 5 837 /* WORD 48 */ 5 838 5 839 2 max_sym fixed bin (18) aligned; 5 840 5 841 5 842 /* SYMBOL NODE */ 5 843 5 844 dcl 1 symbol aligned based structure, 5 845 5 846 /* WORD 1 */ 5 847 5 848 2 node_type fixed bin (4) unaligned, 5 849 2 data_type fixed bin (4) unaligned unsigned, 5 850 2 operand_type fixed bin (4) unaligned, 5 851 5 852 2 addressing_bits unaligned structure, 5 853 3 is_addressable bit (1), 5 854 3 value_in, 5 855 4 eaq bit (1), 5 856 4 x bit (1), 5 857 3 allocated bit (1), 5 858 3 needs_pointer bit (1), 5 859 3 stack_indirect bit (1), 5 860 3 large_address bit (1), 5 861 3 address_in_base bit (1), 5 862 3 dont_update bit (1), /* for optimizer */ 5 863 3 not_in_storage bit (1), /* for optimizer */ 5 864 3 globally_assigned bit (1), /* for optimizer */ 5 865 5 866 2 bits unaligned structure, 5 867 3 storage_info, 5 868 4 standard_bits, 5 869 5 allocate bit (1), 5 870 5 set bit (1), 5 871 5 referenced bit (1), 5 872 5 passed_as_arg bit (1), 5 873 4 initialed bit (1), /* Allows variable to become a constant. */ 5 874 5 875 3 variable_arglist bit (1), 5 876 3 dummy_arg bit (1), 5 877 3 variable_extents bit (1), 5 878 3 needs_descriptors bit (1), 5 879 3 put_in_symtab bit (1), 5 880 3 by_compiler bit (1), 5 881 5 882 /* WORD 2 */ 5 883 5 884 2 address aligned structure, 5 885 3 base bit (3) unaligned, 5 886 3 offset fixed bin (14) unaligned, 5 887 3 char_num fixed bin (2) unaligned unsigned, 5 888 3 bit_num fixed bin (4) unaligned unsigned, 5 889 3 fill bit (4) unaligned, 5 890 3 inhibit bit (1) unaligned, 5 891 3 ext_base bit (1) unaligned, 5 892 3 tag bit (6) unaligned, 5 893 5 894 /* WORD 3 */ 5 895 5 896 2 units fixed bin (3) unaligned unsigned, 5 897 2 aliasable bit (1) unaligned, 5 898 2 has_constant_value bit (1) unaligned, 5 899 2 new_induction_var bit (1) unaligned, 5 900 2 reloc_hold bit (6) unaligned, 5 901 2 reloc bit (6) unaligned, 5 902 2 addr_hold bit (18) unaligned, 5 903 5 904 /* WORD 4 */ 5 905 5 906 2 next_symbol fixed bin (18) unsigned unaligned, 5 907 2 hash_chain fixed bin (18) unsigned unaligned, 5 908 5 909 /* WORD 5 */ 5 910 5 911 2 ext_attributes unaligned structure, 5 912 3 VLA bit (1), /* symbol is Very large Element */ 5 913 3 LA bit (1), /* symbol is Large Element */ 5 914 3 pad bit (18-2), 5 915 5 916 2 loop_ref_count fixed bin (17) unaligned, 5 917 5 918 /* WORD 6 */ 5 919 5 920 2 location fixed bin (24) aligned, 5 921 5 922 /* WORD 7 */ 5 923 5 924 2 v_length fixed bin (18) unsigned unaligned, 5 925 2 general fixed bin (18) unsigned unaligned, 5 926 5 927 /* WORD 8 */ 5 928 5 929 2 parent fixed bin (18) unsigned unaligned, 5 930 2 next_member fixed bin (18) unsigned unaligned, 5 931 5 932 /* WORD 9 */ 5 933 5 934 2 attributes aligned structure, 5 935 3 mode_bits unaligned structure, 5 936 4 char_size fixed bin (20) unsigned, 5 937 4 mode, 5 938 5 integer bit (1), 5 939 5 real bit (1), 5 940 5 double_precision bit (1), 5 941 5 complex bit (1), 5 942 5 logical bit (1), 5 943 5 character bit (1), 5 944 5 label_value bit (1), 5 945 5 entry_value bit (1), 5 946 5 947 3 misc_attributes unaligned structure, 5 948 4 function bit (1), 5 949 4 subroutine bit (1), 5 950 4 entry_point bit (1), 5 951 4 external bit (1), 5 952 4 builtin bit (1), 5 953 4 stmnt_func bit (1), 5 954 4 namelist bit (1), 5 955 4 dimensioned bit (1), 5 956 5 957 /* WORD 10 */ 5 958 5 959 3 storage_class unaligned structure, 5 960 4 automatic bit (1), 5 961 4 static bit (1), 5 962 4 in_common bit (1), 5 963 4 equivalenced bit (1), 5 964 4 parameter bit (1), 5 965 4 constant bit (1), /* If external or entry_point. */ 5 966 4 named_constant bit (1), 5 967 5 968 3 variable bit (1) unaligned, 5 969 3 in_equiv_stmnt bit (1) unaligned, 5 970 3 star_extents bit (1) unaligned, 5 971 3 descriptor bit (1) unaligned, 5 972 2 pad bit (25) unaligned, 5 973 5 974 /* WORD 11 */ 5 975 5 976 2 dimension fixed bin (18) unsigned unaligned, /* Bounds may be added after symbol is declared. */ 5 977 2 initial fixed bin (18) unsigned unaligned, 5 978 5 979 /* WORD 12 */ 5 980 5 981 2 runtime bit (18) unaligned, 5 982 2 name_length fixed bin (17) unaligned, 5 983 5 984 /* WORD 13 */ 5 985 5 986 2 coordinate fixed bin (17) unaligned, /* used by loop optimizer */ 5 987 2 element_size fixed bin (17) unaligned, 5 988 5 989 /* WORD 14 */ 5 990 5 991 2 secondary pointer unaligned, /* used by loop optimizer */ 5 992 5 993 /* WORD 15 */ 5 994 5 995 2 offset fixed bin (24) aligned, 5 996 5 997 /* WORDS 16 - n. This field is variable in length. */ 5 998 5 999 2 name char(allocate_symbol_name refer (symbol.name_length)) aligned; 5 1000 5 1001 5 1002 5 1003 /* TEMPORARY NODE -- Must be same size as ARRAY REF NODE. */ 5 1004 5 1005 dcl 1 temporary aligned based structure, 5 1006 5 1007 /* WORD 1 */ 5 1008 5 1009 2 node_type fixed bin (4) unaligned, 5 1010 2 data_type fixed bin (4) unaligned unsigned, 5 1011 2 operand_type fixed bin (4) unaligned, 5 1012 5 1013 2 addressing_bits unaligned structure, 5 1014 3 is_addressable bit (1), 5 1015 3 value_in, 5 1016 4 eaq bit (1), 5 1017 4 x bit (1), 5 1018 3 allocated bit (1), 5 1019 3 needs_pointer bit (1), 5 1020 3 stack_indirect bit (1), 5 1021 3 large_address bit (1), 5 1022 3 address_in_base bit (1), 5 1023 3 dont_update bit (1), /* for optimizer */ 5 1024 3 not_in_storage bit (1), /* for optimizer */ 5 1025 3 globally_assigned bit (1), /* for optimizer */ 5 1026 5 1027 2 bits unaligned structure, 5 1028 3 standard_bits, 5 1029 4 allocate bit (1), 5 1030 4 set bit (1), 5 1031 4 referenced bit (1), 5 1032 4 passed_as_arg bit (1), 5 1033 5 1034 3 variable_length bit (1), 5 1035 5 1036 3 fill bit (1), /* can be used */ 5 1037 5 1038 3 invariant bit (1), /* must line up with array_ref node */ 5 1039 3 irreducible bit (1), /* .. */ 5 1040 3 used_across_loops bit (1), /* .. */ 5 1041 3 frozen_for_do bit (1), 5 1042 3 used_as_subscript bit (1), 5 1043 5 1044 /* WORD 2 */ 5 1045 5 1046 2 address aligned structure, 5 1047 3 base bit (3) unaligned, 5 1048 3 offset fixed bin (14) unaligned, 5 1049 3 char_num fixed bin (2) unaligned unsigned, 5 1050 3 bit_num fixed bin (4) unaligned unsigned, 5 1051 3 fill bit (4) unaligned, 5 1052 3 inhibit bit (1) unaligned, 5 1053 3 ext_base bit (1) unaligned, 5 1054 3 tag bit (6) unaligned, 5 1055 5 1056 /* WORD 3 */ 5 1057 5 1058 2 units fixed bin (3) unaligned unsigned, 5 1059 2 fill bit (3) unaligned, 5 1060 2 reloc_hold bit (6) unaligned, 5 1061 2 reloc bit (6) unaligned, 5 1062 2 addr_hold bit (18) unaligned, 5 1063 5 1064 /* WORD 4 */ 5 1065 5 1066 2 next fixed bin (18) unsigned unaligned, 5 1067 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay array_ref.loop_end_fu_pos */ 5 1068 5 1069 /* WORD 5 */ 5 1070 5 1071 2 pad fixed bin (18) unsigned unaligned, 5 1072 2 loop_ref_count fixed bin (17) unaligned, 5 1073 5 1074 /* WORD 6 */ 5 1075 5 1076 2 location fixed bin (24) aligned, 5 1077 5 1078 /* WORD 7*/ 5 1079 5 1080 2 ref_count fixed bin (17) unaligned, /* must overlay array_ref.ref_count */ 5 1081 2 output_by fixed bin (18) unsigned unal, /* must overlay array_ref.output_by */ 5 1082 5 1083 /* WORD 8 */ 5 1084 5 1085 2 size fixed bin (24) aligned, /* size in words */ 5 1086 5 1087 /* WORD 9 */ 5 1088 5 1089 2 start_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.start_input_to */ 5 1090 2 end_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.end_input_to */ 5 1091 5 1092 /* WORD 10 */ 5 1093 5 1094 2 ref_count_copy fixed bin (17) unaligned, /* must overlay array_ref.ref_count_copy */ 5 1095 2 ms_ref_count fixed bin (17) unaligned, /* counts occurances in saved machine states */ 5 1096 5 1097 /* WORD 11 */ 5 1098 5 1099 2 length fixed bin (24) aligned; /* length in characters */ 5 1100 5 1101 /* END fort_nodes.incl.pl1 */ 402 6 1 /* BEGIN fort_listing_nodes.incl.pl1 */ 6 2 6 3 /* Created: 30 August 1976, David Levin 6 4* 6 5*Last Modified: 9 October 1978, Paul Smee 6 6**/ 6 7 6 8 dcl 1 cross_reference(261120) aligned structure based(cref_base), 6 9 2 symbol fixed bin (18) unsigned unaligned, 6 10 2 line_no fixed bin(17) unaligned; 6 11 6 12 dcl 1 listing_info aligned structure based(cur_listing), 6 13 2 subprogram fixed bin (18) unsigned, 6 14 2 next fixed bin (18) unsigned, 6 15 2 first_line fixed bin (18) unsigned, 6 16 2 last_line fixed bin (18) unsigned, 6 17 2 first_cref fixed bin (18) unsigned, 6 18 2 last_cref fixed bin (18) unsigned, 6 19 2 first_error fixed bin (18) unsigned, 6 20 2 last_error fixed bin (18) unsigned; 6 21 6 22 dcl listing_seg(0:261119) fixed bin based(listing_base); 6 23 6 24 dcl 1 error_text aligned structure based, 6 25 2 next fixed bin (18) unsigned, 6 26 2 length fixed bin, 6 27 2 string char(error_text_length refer(error_text.length)) aligned; 6 28 6 29 dcl error_text_length fixed bin; 6 30 6 31 dcl 1 source_list (130560) aligned structure based (source_line_base), 6 32 2 file_number fixed bin (8) unaligned, 6 33 2 line_start fixed bin (21) unsigned unaligned, 6 34 2 unused_bits bit (6) unaligned, 6 35 2 line_length fixed bin (18) unsigned unaligned, 6 36 2 line_number_in_file fixed bin (18) unsigned unaligned; 6 37 6 38 /* END fort_listing_nodes.incl.pl1 */ 403 7 1 /* BEGIN INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 7 2 7 3 7 4 /****^ HISTORY COMMENTS: 7 5* 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), 7 6* audit(86-09-11,Martinson), install(86-11-12,MR12.0-1208): 7 7* Added pascal_string_type_dtype descriptor type. Its number is 87. 7 8* Objects of this type are PASCAL string types. 7 9* 2) change(88-09-20,WAAnderson), approve(88-09-20,MCR7952), 7 10* audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184): 7 11* Added the new C types. 7 12* END HISTORY COMMENTS */ 7 13 7 14 /* This include file defines mnemonic names for the Multics 7 15* standard descriptor types, using both pl1 and cobol terminology. 7 16* PG 780613 7 17* JRD 790530 7 18* JRD 791016 7 19* MBW 810731 7 20* TGO 830614 Add hex types. 7 21* Modified June 83 JMAthane to add PASCAL data types 7 22* TGO 840120 Add float dec extended and generic, float binary generic 7 23**/ 7 24 7 25 dcl (real_fix_bin_1_dtype init (1), 7 26 real_fix_bin_2_dtype init (2), 7 27 real_flt_bin_1_dtype init (3), 7 28 real_flt_bin_2_dtype init (4), 7 29 cplx_fix_bin_1_dtype init (5), 7 30 cplx_fix_bin_2_dtype init (6), 7 31 cplx_flt_bin_1_dtype init (7), 7 32 cplx_flt_bin_2_dtype init (8), 7 33 real_fix_dec_9bit_ls_dtype init (9), 7 34 real_flt_dec_9bit_dtype init (10), 7 35 cplx_fix_dec_9bit_ls_dtype init (11), 7 36 cplx_flt_dec_9bit_dtype init (12), 7 37 pointer_dtype init (13), 7 38 offset_dtype init (14), 7 39 label_dtype init (15), 7 40 entry_dtype init (16), 7 41 structure_dtype init (17), 7 42 area_dtype init (18), 7 43 bit_dtype init (19), 7 44 varying_bit_dtype init (20), 7 45 char_dtype init (21), 7 46 varying_char_dtype init (22), 7 47 file_dtype init (23), 7 48 real_fix_dec_9bit_ls_overp_dtype init (29), 7 49 real_fix_dec_9bit_ts_overp_dtype init (30), 7 50 real_fix_bin_1_uns_dtype init (33), 7 51 real_fix_bin_2_uns_dtype init (34), 7 52 real_fix_dec_9bit_uns_dtype init (35), 7 53 real_fix_dec_9bit_ts_dtype init (36), 7 54 real_fix_dec_4bit_uns_dtype init (38), /* digit-aligned */ 7 55 real_fix_dec_4bit_ts_dtype init (39), /* byte-aligned */ 7 56 real_fix_dec_4bit_bytealigned_uns_dtype init (40), /* COBOL */ 7 57 real_fix_dec_4bit_ls_dtype init (41), /* digit-aligned */ 7 58 real_flt_dec_4bit_dtype init (42), /* digit-aligned */ 7 59 real_fix_dec_4bit_bytealigned_ls_dtype init (43), 7 60 real_flt_dec_4bit_bytealigned_dtype init (44), 7 61 cplx_fix_dec_4bit_bytealigned_ls_dtype init (45), 7 62 cplx_flt_dec_4bit_bytealigned_dtype init (46), 7 63 real_flt_hex_1_dtype init (47), 7 64 real_flt_hex_2_dtype init (48), 7 65 cplx_flt_hex_1_dtype init (49), 7 66 cplx_flt_hex_2_dtype init (50), 7 67 c_typeref_dtype init (54), 7 68 c_enum_dtype init (55), 7 69 c_enum_const_dtype init (56), 7 70 c_union_dtype init (57), 7 71 algol68_straight_dtype init (59), 7 72 algol68_format_dtype init (60), 7 73 algol68_array_descriptor_dtype init (61), 7 74 algol68_union_dtype init (62), 7 75 7 76 cobol_comp_6_dtype init (1), 7 77 cobol_comp_7_dtype init (1), 7 78 cobol_display_ls_dtype init (9), 7 79 cobol_structure_dtype init (17), 7 80 cobol_char_string_dtype init (21), 7 81 cobol_display_ls_overp_dtype init (29), 7 82 cobol_display_ts_overp_dtype init (30), 7 83 cobol_display_uns_dtype init (35), 7 84 cobol_display_ts_dtype init (36), 7 85 cobol_comp_8_uns_dtype init (38), /* digit aligned */ 7 86 cobol_comp_5_ts_dtype init (39), /* byte aligned */ 7 87 cobol_comp_5_uns_dtype init (40), 7 88 cobol_comp_8_ls_dtype init (41), /* digit aligned */ 7 89 real_flt_dec_extended_dtype init (81), /* 9-bit exponent */ 7 90 cplx_flt_dec_extended_dtype init (82), /* 9-bit exponent */ 7 91 real_flt_dec_generic_dtype init (83), /* generic float decimal */ 7 92 cplx_flt_dec_generic_dtype init (84), 7 93 real_flt_bin_generic_dtype init (85), /* generic float binary */ 7 94 cplx_flt_bin_generic_dtype init (86)) fixed bin internal static options (constant); 7 95 7 96 dcl (ft_integer_dtype init (1), 7 97 ft_real_dtype init (3), 7 98 ft_double_dtype init (4), 7 99 ft_complex_dtype init (7), 7 100 ft_complex_double_dtype init (8), 7 101 ft_external_dtype init (16), 7 102 ft_logical_dtype init (19), 7 103 ft_char_dtype init (21), 7 104 ft_hex_real_dtype init (47), 7 105 ft_hex_double_dtype init (48), 7 106 ft_hex_complex_dtype init (49), 7 107 ft_hex_complex_double_dtype init (50) 7 108 ) fixed bin internal static options (constant); 7 109 7 110 dcl (algol68_short_int_dtype init (1), 7 111 algol68_int_dtype init (1), 7 112 algol68_long_int_dtype init (2), 7 113 algol68_real_dtype init (3), 7 114 algol68_long_real_dtype init (4), 7 115 algol68_compl_dtype init (7), 7 116 algol68_long_compl_dtype init (8), 7 117 algol68_bits_dtype init (19), 7 118 algol68_bool_dtype init (19), 7 119 algol68_char_dtype init (21), 7 120 algol68_byte_dtype init (21), 7 121 algol68_struct_struct_char_dtype init (22), 7 122 algol68_struct_struct_bool_dtype init (20) 7 123 ) fixed bin internal static options (constant); 7 124 7 125 dcl (label_constant_runtime_dtype init (24), 7 126 int_entry_runtime_dtype init (25), 7 127 ext_entry_runtime_dtype init (26), 7 128 ext_procedure_runtime_dtype init (27), 7 129 picture_runtime_dtype init (63) 7 130 ) fixed bin internal static options (constant); 7 131 7 132 dcl (pascal_integer_dtype init (1), 7 133 pascal_real_dtype init (4), 7 134 pascal_label_dtype init (24), 7 135 pascal_internal_procedure_dtype init (25), 7 136 pascal_exportable_procedure_dtype init (26), 7 137 pascal_imported_procedure_dtype init (27), 7 138 pascal_typed_pointer_type_dtype init (64), 7 139 pascal_char_dtype init (65), 7 140 pascal_boolean_dtype init (66), 7 141 pascal_record_file_type_dtype init (67), 7 142 pascal_record_type_dtype init (68), 7 143 pascal_set_dtype init (69), 7 144 pascal_enumerated_type_dtype init (70), 7 145 pascal_enumerated_type_element_dtype init (71), 7 146 pascal_enumerated_type_instance_dtype init (72), 7 147 pascal_user_defined_type_dtype init (73), 7 148 pascal_user_defined_type_instance_dtype init (74), 7 149 pascal_text_file_dtype init (75), 7 150 pascal_procedure_type_dtype init (76), 7 151 pascal_variable_formal_parameter_dtype init (77), 7 152 pascal_value_formal_parameter_dtype init (78), 7 153 pascal_entry_formal_parameter_dtype init (79), 7 154 pascal_parameter_procedure_dtype init (80), 7 155 pascal_string_type_dtype init (87)) fixed bin int static options (constant); 7 156 7 157 7 158 /* END INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 404 405 406 parse_ptr = q; 407 shared_ptr = p; 408 409 polish_base = shared_structure.polish_base; 410 operand_base = shared_structure.operand_base; 411 object_base = shared_structure.object_base; 412 413 if shared_structure.options.map then do; 414 cref_base = shared_structure.cref_base; 415 source_line_base = shared_structure.source_line_base; 416 listing_base = shared_structure.listing_base; 417 end; 418 419 polish_max_len = shared_structure.polish_max_len; 420 object_max_len = shared_structure.object_max_len; 421 max_array_size.char = sys_info$max_seg_size; 422 call set_max_array_size; 423 call parse_source (source_info_ptr); 424 return; 425 426 set_max_array_size: 427 procedure; 428 429 if shared_structure.options.VLA_auto then 430 max_array_size.auto = max_fixed_bin_24; 431 else 432 max_array_size.auto = sys_info$max_seg_size; 433 if shared_structure.options.VLA_parm then 434 max_array_size.parm = max_fixed_bin_24; 435 else 436 max_array_size.parm = sys_info$max_seg_size; 437 if shared_structure.options.VLA_static then 438 max_array_size.static = max_fixed_bin_24; 439 else 440 max_array_size.static = sys_info$max_seg_size; 441 if shared_structure.options.VLC then 442 max_array_size.common = max_fixed_bin_24; 443 else 444 max_array_size.common = sys_info$max_seg_size; 445 return; 446 end; 447 8 1 /* BEGIN fort_utilities.incl.pl1 */ 8 2 8 3 /* Created: October 1977, Richard Barnes 8 4* 8 5* Modified: 8 6* 22 May 1978, DSL - add create_constant. 8 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 8 8* 13 Dec 1978, PES - Get create_node from include file, rather than copy. 8 9**/ 8 10 9 1 /* BEGIN fort_create_node.incl.pl1 */ 9 2 9 3 /* Created: October 1977, Richard Barnes 9 4* 9 5* Modified: 9 6* 22 May 1978, DSL - add create_constant. 9 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 9 8* 13 Dec 1978, PES - changes for large common and arrays. 9 9**/ 9 10 create_node: proc(type,length) returns(fixed bin (18)); 9 11 9 12 dcl length fixed bin; 9 13 dcl offset fixed bin(18); 9 14 dcl type fixed bin(4); 9 15 dcl storage(length) fixed bin aligned based; 9 16 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 9 17 dcl (addr,char,ltrim,unspec) builtin; 9 18 9 19 9 20 if (length + next_free_operand) < operand_max_len 9 21 then do; 9 22 offset = next_free_operand; 9 23 next_free_operand = next_free_operand + length; 9 24 unspec(addr(x(offset)) -> storage) = "0"b; 9 25 addr(x(offset)) -> node.node_type = type; 9 26 return(offset); 9 27 end; 9 28 else do; 9 29 call print_message(407, "operand region", ltrim(char(operand_max_len))); /* FATAL */ 9 30 end; 9 31 9 32 end create_node; 9 33 9 34 /* END fort_create_node.incl.pl1 */ 8 11 8 12 8 13 create_constant: proc(data_type,value) returns(fixed bin (18)); 8 14 8 15 dcl (data_type,a_data_type) fixed bin(4); /* data type of constant */ 8 16 dcl (value,a_value) bit(72) aligned; /* value of constant */ 8 17 8 18 dcl addr builtin; 8 19 dcl binary builtin; 8 20 dcl bool builtin; 8 21 dcl char builtin; 8 22 dcl data_size fixed bin(17); 8 23 dcl decimal builtin; 8 24 dcl hash_index fixed bin; 8 25 dcl hash_table(0:hash_table_size-1) fixed bin(35) aligned based(operand_base); 8 26 dcl hash_table_size fixed bin int static options(constant) init(211); 8 27 dcl hbound builtin; 8 28 dcl ltrim builtin; 8 29 dcl mod builtin; 8 30 dcl mod_2_sum bit(36) aligned; 8 31 dcl node_offset fixed bin; 8 32 dcl node_ptr pointer; 8 33 dcl size builtin; 8 34 dcl v_array(2) bit(36) aligned based(addr(a_value)); 8 35 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 8 36 10 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 10 2 10 3 /* This include file defines the relocation bits as bit (6) entities. See 10 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 10 5 10 6 dcl ( rc_a initial("000000"b), /* absolute */ 10 7 rc_t initial("010000"b), /* text */ 10 8 rc_nt initial("010001"b), /* negative text */ 10 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 10 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 10 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 10 12 rc_dp initial("010101"b), /* def section */ 10 13 rc_s initial("010110"b), /* symbol segment */ 10 14 rc_ns initial("010111"b), /* negative symbol */ 10 15 rc_is18 initial("011000"b), /* internal static 18 */ 10 16 rc_is15 initial("011001"b), /* internal static 15 */ 10 17 rc_lb initial("011000"b), /* link block */ 10 18 rc_nlb initial("011001"b), /* negative link block */ 10 19 rc_sr initial("011010"b), /* self relative */ 10 20 rc_e initial("011111"b)) /* escape */ 10 21 bit(6) int static options(constant); 10 22 10 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 8 37 8 38 8 39 8 40 a_data_type = data_type; 8 41 a_value = value; 8 42 8 43 if a_data_type = char_mode | a_data_type <= 0 | a_data_type > hbound(data_type_size,1) 8 44 then do; 8 45 call print_message(452, ltrim(char(decimal(a_data_type,12)))); /* cannot create the node */ 8 46 end; 8 47 else data_size = data_type_size(a_data_type); 8 48 8 49 if data_size = 1 8 50 then do; 8 51 mod_2_sum = v_array(1); 8 52 v_array(2) = "0"b; 8 53 end; 8 54 else mod_2_sum = bool(v_array(1),v_array(2),"0110"b); 8 55 8 56 8 57 hash_index = mod(binary(mod_2_sum,35),hash_table_size); 8 58 8 59 /* Search the hash table for the constant. */ 8 60 8 61 node_offset = hash_table(hash_index); 8 62 do while(node_offset > 0); /* search the entire bucket */ 8 63 node_ptr = addr(x(node_offset)); 8 64 8 65 if node_ptr -> constant.value = a_value /* must be same value */ 8 66 then if node_ptr -> node.data_type = a_data_type /* and same data type */ 8 67 then return(node_offset); 8 68 8 69 node_offset = node_ptr -> node.hash_chain; /* NB - pointer remains pointing at last item in bucket */ 8 70 end; 8 71 8 72 /* a new constant node must be created */ 8 73 8 74 node_offset = create_node(constant_node, size(constant)); 8 75 8 76 if hash_table(hash_index) = 0 /* Is this the first item in the bucket? */ 8 77 then hash_table(hash_index) = node_offset; /* yes */ 8 78 else node_ptr -> node.hash_chain = node_offset; /* no, add it to the end */ 8 79 8 80 node_ptr = addr(x(node_offset)); 8 81 node_ptr -> constant.data_type = a_data_type; 8 82 node_ptr -> constant.operand_type = constant_type; 8 83 node_ptr -> constant.is_addressable = "1"b; 8 84 node_ptr -> constant.reloc = rc_t; 8 85 node_ptr -> constant.value = a_value; 8 86 8 87 constant_info(data_size).constant_count = constant_info(data_size).constant_count + 1; 8 88 8 89 if constant_info(data_size).first_constant = 0 /* Is this the first item of this size? */ 8 90 then constant_info(data_size).first_constant = node_offset; /* yes */ 8 91 else addr(x(constant_info(data_size).last_constant)) -> constant.next_constant = node_offset; /* no, add it */ 8 92 8 93 constant_info(data_size).last_constant = node_offset; 8 94 8 95 return(node_offset); 8 96 8 97 end create_constant; 8 98 8 99 /* END fort_utilities.incl.pl1 */ 448 449 450 parse_source: 451 procedure (src_info_ptr); 452 453 /* Program Specifications (parse_source) 454* 455* Inputs 456* 457* Output 458* 459* Description - This routine parses one or more source segment and produces 460* the intermediate representation. Before each subprogram is parsed, 461* all local work areas are reinitialized. This includes the operand table (or symbol table), 462* the segment containing the intermediate representation of each statement, etc. 463* 464* Each symbol table is independent except there is a single thread which runs through 465* all symbols in all segments compiled. There are similar threads for constants and labels. 466* 467* Each subprogram compiled produces a block of independent intermediate text. This text is 468* preceded by a header which indicates subprogram name and type, and some switches. One switch 469* indicates whether or not the intermediate text should be skipped or compiled. This switch 470* will be used primarily to prevent the compilation of more than one subprogram with the 471* same name. 472* 473**/ 474 475 dcl COLON_BEFORE_ASSIGN bit (1) aligned; 476 dcl BEGIN_DO_LOOP fixed bin (18) static options (constant) init (-1); 477 declare CURRENT_VALUE fixed binary (18) internal static options (constant) initial (1); 478 dcl DECLARED bit (5) aligned int static options (constant) init ("0"b); 479 dcl DIGIT char (10) aligned int static options (constant) init ("0123456789"); 480 declare END_DO_LOOP fixed binary (18) internal static options (constant) initial (-2); 481 declare END_DO_LOOP_SIZE fixed binary (18) internal static options (constant) initial (1); 482 dcl END_DO_RANGE bit (1) aligned; 483 dcl FALSE bit (1) aligned int static options (constant) init ("0"b); 484 dcl GOTO_REF bit (5) aligned int static options (constant) init ("10101"b); 485 dcl GOTO_TARGET bit (5) aligned int static options (constant) init ("11101"b); 486 dcl INIT bit (5) aligned int static options (constant) init ("00001"b); 487 declare INITIAL_EXPRESSION fixed binary (18) internal static options (constant) initial (2); 488 dcl NO_NAME char (8) unaligned int static options (constant) init (""); 489 dcl NOT_SET bit (1) int static options (constant) init ("0"b); 490 dcl NULL_STRING char (0) int static options (constant) init (""); 491 dcl ONE fixed bin (18) int static options (constant) init (1); 492 dcl OS (0:operand_max_len - 1) bit (36) aligned based (operand_base); 493 dcl PASSED bit (5) aligned int static options (constant) init ("10110"b); 494 dcl REF bit (5) aligned int static options (constant) init ("10100"b); 495 dcl SECOND_EQUALS bit (1) aligned; 496 dcl SET bit (5) aligned int static options (constant) init ("11100"b); 497 dcl SET_ATTR bit (1) int static options (constant) init ("1"b); 498 dcl SI fixed bin (18); 499 dcl SKIP fixed bin (18) static options (constant) init (0); 500 dcl SUBSCRIPTED_VAR fixed bin (18) static options (constant) init (-4); 501 dcl SUBSCRIPTED_SUBSTR fixed bin (18) static options (constant) init (-5); 502 dcl SUBSTR fixed bin (18) static options (constant) init (-3); 503 declare SYMBOL_INDEX fixed binary (18) internal static options (constant) initial (1); 504 dcl TRUE bit (1) aligned int static options (constant) init ("1"b); 505 dcl ZERO bit (1) aligned int static options (constant) init ("0"b); 506 dcl max_char_var_length fixed bin (21) internal static options (constant) init (131071); 507 508 dcl abs builtin; 509 dcl addr builtin; 510 dcl after_subprogram fixed bin (18) int static options (constant) init (11); 511 dcl all_attributes bit (47) aligned int static options (constant) 512 init ("11111111111111111111111111111111111111111111111"b); 513 dcl allow_star_after bit (1) aligned; 514 dcl alphabetic char (52) aligned int static options (constant) 515 init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"); 516 dcl alternate_return_index fixed bin (18); 517 dcl any_label bit (2) aligned int static options (constant) init ("00"b); 518 dcl arg_type bit (36) aligned; 519 dcl asf_attribute bit (47) aligned int static options (constant) 520 init ("00000000000000000000000000000000010000000000000"b); 521 dcl asf_conflicts bit (47) aligned int static options (constant) 522 init ("00000000000000000000000000111111111111111110000"b); 523 dcl asf_definition fixed bin (18) int static options (constant) init (28); 524 dcl assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 525 dcl assignment_statement fixed bin (18) int static options (constant) init (60); 526 dcl assignment_statement_index fixed bin (18); 527 declare asterisk_seen bit (1) aligned; 528 dcl attr_table (0:6) bit (47) aligned int static options (constant) 529 init ("00000000000000000000000000000000000000000000000"b, 530 "00000000000000000000100000000000000000000000000"b, "00000000000000000000010000000000000000000000000"b, 531 "00000000000000000000001000000000000000000000000"b, "00000000000000000000000100000000000000000000000"b, 532 "00000000000000000000000010000000000000000000000"b, "00000000000000000000000001000000000000000000000"b); 533 dcl attributes bit (47) aligned; 534 dcl auto_attribute bit (47) aligned int static options (constant) 535 init ("00000000000000000000000000000000000010000001000"b); 536 dcl b72_one bit (72) aligned int static options (constant) 537 init ("100000000000000000000000000000000000000000000000000000000000000000000000"b); 538 dcl b72_zero bit (72) aligned int static options (constant) 539 init ("000000000000000000000000000000000000000000000000000000000000000000000000"b); 540 dcl bad_type fixed bin (18); 541 dcl based_bit_72 bit (72) aligned based; 542 dcl based_char char (8) aligned based; 543 dcl based_integer fixed bin (35) based; 544 dcl based_real (2) float bin (27) based aligned; 545 dcl based_words (512) bit (36) aligned based; 546 dcl before builtin; 547 dcl begin_char fixed bin (18); 548 dcl bif_conflicts bit (47) aligned int static options (constant) 549 init ("11111111111111111111000011111110011111111111000"b); 550 dcl binary builtin; 551 dcl bit builtin; 552 dcl bit_mask (4) bit (36) aligned int static options (constant) 553 init ("111111111000000000000000000000000000"b, "111111111111111111000000000000000000"b, 554 "111111111111111111111111111000000000"b, "111111111111111111111111111111111111"b); 555 dcl bit_value bit (9) aligned; 556 dcl bypass_first_pending_entry bit (1); 557 dcl card_image bit (1) aligned; 558 dcl char builtin; 559 dcl char_index fixed bin (20); 560 dcl char_siz fixed bin (18); 561 dcl char_temp char (1320) aligned; /* Refer to procedure "create_format" before changing. */ 562 dcl char_type fixed bin (18); 563 dcl char_value char (1) aligned based (addr (bit_value)); 564 dcl code fixed bin (35); 565 dcl common_name char (256) varying; 566 dcl common_storage bit (3) aligned int static options (constant) init ("001"b); 567 dcl const_index fixed bin (18); 568 dcl const_count fixed bin (18); 569 dcl constant_type (6) bit (9) aligned int static options (constant) 570 init ("001100110"b, "001100111"b, "001101000"b, "001101001"b, "001000010"b, "001000001"b); 571 dcl continuation_line fixed bin (18) int static options (constant) init (2); 572 dcl copy builtin; 573 dcl count fixed bin (18); 574 dcl cp_count fixed bin (18); 575 dcl cp_label_count fixed bin (18); 576 dcl cur_paren fixed bin (18); 577 dcl cur_segment fixed bin (18); 578 dcl cur_stmnt_ptr pointer; 579 dcl current_character char (1) aligned; 580 dcl current_parameter fixed bin (18); 581 dcl current_token fixed bin (18); 582 dcl decimal builtin; 583 dcl decode_statement fixed bin (18) int static options (constant) init (44); 584 dcl default_char_size fixed bin (10); 585 dcl default_table (52) bit (47) aligned; 586 declare default_unit_specifier fixed binary (18); 587 dcl defined fixed bin (18); 588 dcl dim_attr bit (47) aligned int static options (constant) 589 init ("00000000000000000000000000000000000100000001000"b); 590 dcl dim_conflicts bit (47) aligned int static options (constant) 591 init ("00000000000000000000000000111111111100000110000"b); 592 dcl dim builtin; 593 dcl digits fixed bin (18) int static options (constant) init (3); 594 dcl divide builtin; 595 dcl do_index fixed bin (18); 596 dcl do_info (8) fixed bin (18); 597 dcl do_level fixed bin (18); 598 dcl do_statement fixed bin (18) int static options (constant) init (61); 599 dcl dp pointer; 600 dcl (E_start, E_finish) fixed bin; 601 dcl E_token fixed bin; 602 dcl elseif_statement fixed bin (18) int static options (constant) init (30); 603 dcl else_statement fixed bin (18) int static options (constant) init (31); 604 dcl end_char fixed bin (18); 605 dcl end_line fixed bin (18) int static options (constant) init (64); 606 dcl end_of_line fixed bin (18); 607 dcl end_possible bit (1) aligned; 608 dcl entry_point_conflicts bit (47) aligned int static options (constant) 609 init ("00000000000000000000000000111111111111111111000"b); 610 dcl entry_value bit (47) aligned int static options (constant) 611 init ("00000000000000000000000000000001000000000000000"b); 612 dcl entry_value_conflicts bit (47) aligned int static options (constant) 613 init ("00000000000000000000000000110010011111110111000"b); 614 declare equivalence_statement fixed bin (18) int static options (constant) init (14); 615 dcl equiv_conflicts bit (47) aligned int static options (constant) 616 init ("00000000000000000000000000111111111000001110000"b); 617 dcl error bit (1); 618 dcl error_code fixed bin (35); 619 dcl executable_label bit (2) aligned int static options (constant) init ("01"b); 620 dcl ext_attributes bit (47) aligned int static options (constant) 621 init ("00000000000000000000000000000001000000000000000"b); 622 dcl ext_conflicts bit (47) aligned int static options (constant) 623 init ("00000000000000000000000000111111111111110111000"b); 624 dcl fast_lookup char (24) unaligned defined (full_name); 625 dcl fields_specified bit (72) aligned; 626 dcl file_number fixed bin (8) init (0); 627 dcl file_number_pic picture "zzz-"; 628 dcl file_stack_depth fixed bin (17); 629 dcl first_mode_keyword fixed bin (18) int static options (constant) init (15); 630 dcl first_time bit (1) aligned; 631 dcl first_token fixed bin (18); 632 dcl first_word fixed bin (18); 633 dcl fixed builtin; 634 dcl fold_option bit (1) aligned; 635 dcl force_symtab_entry fixed bin (2) int static options (constant) init (2); 636 dcl format_label bit (2) aligned int static options (constant) init ("10"b); 637 dcl format_label_attributes bit (47) aligned int static options (constant) 638 init ("00000000000000000000000001000000000001000001000"b); 639 dcl fort_defaults_$global ext entry (ptr, fixed bin, ptr, entry); 640 dcl fort_defaults_$check_global_args ext entry (ptr, ptr, entry); 641 dcl fort_defaults_$init_shared_vars external entry (ptr); 642 dcl fort_defaults_$option ext entry (ptr, fixed bin, ptr, ptr, ptr, bit (1) aligned, bit (1) aligned, entry); 643 dcl fort_defaults_$set ext entry (ptr, ptr); 644 645 declare fort_eval_parm ext entry (ptr, char (*), fixed bin (35)); 646 dcl free_chain fixed bin (18); 647 dcl from_data_parser bit (1) aligned; 648 dcl full_name char (256) unaligned; 649 dcl func_conflicts bit (47) aligned int static options (constant) 650 init ("00000000000000000000000000110110111111110111000"b); 651 dcl func_ref_attribute bit (47) aligned int static options (constant) 652 init ("00000000000000000000000000001001000000000000000"b); 653 dcl function_attribute bit (47) aligned int static options (constant) 654 init ("00000000000000000000000000001010000000000100000"b); 655 declare function_statement fixed binary (18) internal static options (constant) initial (4); 656 dcl general_format_parse_ entry (char (1320) aligned, char (4096) aligned, bit (1) aligned, fixed bin (35)); 657 dcl hash_table (0:210) fixed bin (18); 658 dcl have_auto_option bit (1) aligned; 659 dcl have_auto_stmnt bit (1) aligned; 660 dcl have_save_stmnt bit (1) aligned; 661 dcl have_static_option bit (1) aligned; 662 dcl have_subscript bit (1); 663 dcl hbound builtin; 664 dcl i fixed bin (18); 665 dcl ignore_bits bit (36) aligned; 666 dcl ignore_octal_value bit (72) aligned; 667 dcl ignore_symtab_entry fixed bin (2) int static options (constant) init (0); 668 dcl ignore_value fixed bin (18); 669 dcl impossible_align bit (2) aligned int static options (constant) init ("11"b); 670 dcl impossible_class (0:7) bit (1) aligned int static options (constant) init ((3) (1)"0"b, "1"b, "0"b, (3) (1)"1"b); 671 dcl in_list bit (1) aligned; 672 dcl in_stmnt bit (1) aligned; 673 dcl index builtin; 674 dcl indx fixed bin (18); 675 declare indx_type fixed binary (18); 676 dcl initial_line fixed bin (18) int static options (constant) init (1); 677 dcl inx fixed binary; 678 declare io_control_type fixed binary (4); 679 dcl jnx fixed binary; 680 dcl keyword_index fixed bin (18); 681 dcl label_args bit (1) aligned; 682 dcl label_hash_table (0:210) fixed bin (18); 683 dcl label_ptr fixed bin (18); 684 dcl last_cur_statement fixed bin (18); 685 dcl last_do fixed bin (18); 686 dcl last_element fixed bin (18); 687 dcl last_mode_keyword fixed bin (18) int static options (constant) init (20); 688 dcl last_namelist fixed bin (18); 689 dcl last_namelist_word_offset fixed bin (18); 690 dcl last_paren_parsed fixed bin (18); 691 dcl last_source_line fixed bin (18); 692 dcl last_statement fixed bin (18); 693 dcl last_statement_type fixed bin (18); 694 dcl last_token fixed bin (18); 695 dcl lbound builtin; 696 dcl length builtin; 697 dcl letters fixed bin (18) int static options (constant) init (1); 698 dcl line_number fixed bin (18); 699 dcl line_number_pic picture "zzzzz9"; 700 dcl line_numbered_text bit (1) aligned; 701 dcl locate_symtab_entry fixed bin (2) int static options (constant) init (1); 702 dcl logical_if_statement bit (1) aligned; 703 dcl local_attributes bit (47) aligned; 704 dcl ltrim builtin; 705 dcl main_attr bit (47) aligned int static options (constant) init ("000000000000000000010000000000100000"b); 706 dcl max builtin; 707 dcl max_arglist fixed bin (18) int static options (constant) init (63); 708 dcl max_stack fixed bin (18); 709 dcl member_attr bit (47) aligned int static options (constant) 710 init ("00000000000000000000000000000000000000110001000"b); 711 dcl member_conflicts bit (47) aligned int static options (constant) 712 init ("00000000000000000000000000111111111011101110000"b); 713 dcl min builtin; 714 dcl mod builtin; 715 dcl mode_defined bit (52) aligned; 716 dcl mode_type fixed bin (4); 717 dcl must_have_label bit (1) aligned; 718 dcl named_constant_ptr pointer; 719 dcl named_constant_ptr_valid bit (1) aligned; 720 dcl named_const_attr bit (47) aligned int static options (constant) 721 init ("00000000000000000000000000000000000000000010000"b); 722 dcl named_const_conflicts bit (47) aligned int static options (constant) 723 init ("00000000000000000000000000111111111111111111101"b); 724 dcl namelist_attr bit (47) aligned int static options (constant) 725 init ("00000000000000000000000000000000001000000000000"b); 726 dcl need_comma bit (1) aligned; 727 declare need_ref bit (1) aligned; 728 dcl new fixed bin (18); 729 dcl next_line_index fixed bin (20); 730 dcl next_statement_label fixed bin (18); 731 dcl next_token bit (9) aligned; 732 dcl no_attributes bit (47) aligned int static options (constant) 733 init ("00000000000000000000000000000000000000000000000"b); 734 dcl no_more_source fixed bin (18) int static options (constant) init (0); 735 declare not_found bit (1) aligned; 736 dcl null builtin; 737 dcl number_of_dims fixed bin; 738 dcl number_of_subs fixed bin; 739 dcl old fixed bin (18); 740 dcl op_code fixed bin; 741 dcl 1 other_segment_info aligned like compiler_source_info; 742 dcl out_of_sequence fixed bin (18) int static options (constant) init (63); 743 dcl p fixed bin (18); 744 dcl param_attr bit (47) aligned int static options (constant) 745 init ("00000000000000000000000000000000000000001000000"b); 746 dcl param_conflicts bit (47) aligned int static options (constant) 747 init ("00000000000000000000000000111110111011110110000"b); 748 dcl param_ptr pointer; 749 dcl param_variable_attrs bit (47) aligned int static options (constant) 750 init ("00000000000000000000000000000000000000001001000"b); 751 dcl parameter_statement fixed bin (18) int static options (constant) init (24); 752 dcl paren_array (660) fixed bin (18); 753 dcl paren_count fixed bin (18); 754 dcl 01 pending_entry (50) aligned, 755 02 entry_symbol fixed bin (18), 756 02 entry_stmnt bit (36 * size (statement)); 757 dcl pending_entry_cnt fixed bin; 758 dcl produce_listing bit (1) aligned; 759 dcl put_in_map bit (9) aligned int static options (constant) init ("100000000"b); 760 dcl put_in_profile bit (9) aligned int static options (constant) init ("110000000"b); 761 dcl reset_stack (max_stack) bit (36) aligned based (object_base); 762 dcl return_value fixed bin (18); 763 dcl return_value_param fixed bin (18); 764 dcl round builtin; 765 dcl rtrim builtin; 766 dcl save_attributes bit (47) aligned int static options (constant) 767 init ("00000000000000000000000000000000000001000001000"b); 768 dcl save_conflicts bit (47) aligned int static options (constant) 769 init ("00000000000000000000000000111111111011111110000"b); 770 dcl save_current_token fixed bin (18); 771 dcl saved_number_of_crefs fixed bin (18); 772 dcl scalar_conflicts bit (47) aligned int static options (constant) 773 init ("00000000000000000000000000111111111100000110000"b); 774 dcl search builtin; 775 dcl seg_ptr pointer; 776 dcl seg_chain_end_ptr pointer; 777 dcl sign bit (9) aligned; /* Refer to proc "convert_integer_constant" before using. */ 778 dcl size builtin; 779 dcl source_info pointer; 780 dcl source_len fixed bin (21); 781 dcl source_ptr pointer; 782 dcl src_info_ptr pointer; 783 dcl stack (0:sys_info$max_seg_size - 1) fixed bin (18) based (object_base); 784 dcl stack_base fixed bin (18); 785 dcl stack_index fixed bin (18); 786 dcl start_of_expression fixed bin (18); 787 dcl start_of_node fixed bin (18); 788 dcl statement_info bit (36 * size (statement)) aligned; 789 dcl statement_label fixed bin (18); 790 dcl statement_length fixed bin (18); 791 dcl statement_offset fixed bin (20); 792 dcl statement_type fixed bin (18); 793 dcl string builtin; 794 dcl st_copy char (1320) aligned; 795 dcl st_lbl_type bit (2) aligned; 796 dcl sub_ptr pointer; 797 dcl subprogram_attributes bit (47) aligned; 798 dcl subprogram_conflicts bit (47) aligned; 799 dcl subprogram_op fixed bin; 800 dcl subprogram_symbol fixed bin (18); 801 dcl subroutine_attributes bit (47) aligned int static options (constant) 802 init ("00000000000000000000000000000110000000000100000"b); 803 dcl subroutine_conflicts bit (47) aligned int static options (constant) 804 init ("11111111111111111111111111111010111111110111000"b); 805 dcl subroutine_reference bit (47) aligned int static options (constant) 806 init ("00000000000000000000000000000101000000000000000"b); 807 dcl subs_list (0:7) fixed bin (18); 808 dcl subscript fixed bin (24); 809 dcl substr builtin; 810 dcl symbol_index fixed bin (18); 811 dcl symbol_length fixed bin (18); 812 dcl symp pointer; 813 dcl temp pointer; 814 dcl token bit (9) aligned; 815 dcl token_length fixed bin (18); 816 dcl token_offset fixed bin (18); 817 dcl translate builtin; 818 dcl type_conflicts bit (47) aligned int static options (constant) 819 init ("11111111111111111111111111110100011000000110000"b); 820 dcl type_of_line fixed bin (18); 821 dcl unknown_statement fixed bin (18) int static options (constant) init (62); 822 dcl unspec builtin; 823 dcl v_length_attributes bit (47) aligned int static options (constant) 824 init ("00000000000000000000100000000000000010000001000"b); 825 dcl value_0 fixed bin (18); 826 dcl value_1 fixed bin (18); 827 dcl value_7 fixed bin (18); 828 dcl variable_attributes bit (47) aligned int static options (constant) 829 init ("00000000000000000000000000000000000000000001000"b); 830 dcl variable_conflicts bit (47) aligned int static options (constant) 831 init ("00000000000000000000000000111111111000000110000"b); 832 dcl verify builtin; 833 dcl word_offset fixed bin (18); 834 dcl work bit (72) aligned; 835 836 dcl 1 do_blockif_stack (50) aligned, 837 2 label_ptr fixed binary (18), 838 2 clauses fixed binary (18), 839 2 count_op fixed binary (18), 840 2 line_number fixed binary (18), 841 2 do_loop bit (1) aligned, 842 2 else_seen bit (1) aligned; 843 844 dcl 1 word_align aligned based, 845 2 based_double float bin (63) unaligned; 846 847 dcl 1 token_list (1000) aligned, 848 2 type bit (9) unaligned, 849 2 pad bit (9) unaligned, 850 2 offset fixed bin (18) unaligned unsigned, 851 2 length fixed bin (10) aligned; 852 853 dcl 1 constant_array (500) aligned, 854 2 prec fixed bin (8) unaligned, 855 2 scale fixed bin (8) unaligned, 856 2 exponent fixed bin (8) unaligned, 857 2 length fixed bin (8) unaligned; 858 859 dcl 1 file_stack (0:32) aligned, 860 2 fs_seg_ptr ptr, /* ptr to source_node for segment. */ 861 2 fs_source_ptr ptr, /* ptr to base of source segment. */ 862 2 fs_end_of_line fixed bin (21), /* offset of end of current line in source seg. */ 863 2 fs_source_length fixed bin (21), /* length in chars of source segment. */ 864 2 fs_line_number fixed bin (18), /* line number in source segment. */ 865 2 fs_file_number fixed bin (8); /* file number of source segment. */ 866 867 dcl 1 token_structure aligned based (addr (st_copy)), 868 2 pad char (token_offset) unaligned, 869 2 token_string char (token_length) unaligned; 870 871 dcl 1 format_structure aligned based (addr (st_copy)), 872 2 pad char (6) unaligned, 873 2 format_string char (statement_length - 6) unaligned; 874 875 dcl 1 paren_info (100) aligned structure, 876 2 chain fixed bin (18), 877 2 position fixed bin (18), 878 2 begin_index fixed bin (18), 879 2 implied_loop bit (1); 880 11 1 /* BEGIN INCLUDE FILE ... fort_parameter.incl.pl1 */ 11 2 11 3 /* Created: August 1980, MEP 11 4* 11 5* Modified: 24 March 1981, MEP = Enlarge structure to carry some of thearguments in the call. 11 6**/ 11 7 declare 1 parameter aligned based, 11 8 2 desired_data_type fixed binary (4) unaligned, 11 9 /* IN - result converted to this if ^= 0 */ 11 10 2 result_data_type fixed binary (4) unaligned, 11 11 /* OUT - if no conversion requested, the data_type */ 11 12 2 rounding bit (1) unaligned, /* IN - rounding/trunc flag */ 11 13 2 start_of_polish fixed binary (18) unaligned, 11 14 /* IN - offset of first polish for expression */ 11 15 2 end_of_polish fixed binary (18) unaligned, 11 16 /* IN - offset of last_polish + 1 */ 11 17 2 stack_index fixed binary (18) unaligned, 11 18 /* IN - next free spot in stack, work area above this */ 11 19 2 max_stack fixed binary (18) unaligned, 11 20 /* IN/OUT - stack high water mark */ 11 21 2 result_location fixed binary (18) unaligned, 11 22 /* OUT - if error_code ^= 0, OS offset constant node */ 11 23 2 shared_pointer pointer; /* IN - pointer to shared globals structure */ 11 24 11 25 /* END INCLUDE FILE ... fort_parameter.incl.pl1 */ 881 882 883 declare 1 parameter_info aligned like parameter; 884 885 dcl 1 io_bits unaligned structure, 12 1 /* BEGIN INCLUDE FILE fortran_job_bits.incl.pl1 */ 12 2 12 3 /****^ *********************************************************** 12 4* * * 12 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 12 6* * * 12 7* *********************************************************** */ 12 8 12 9 12 10 /****^ HISTORY COMMENTS: 12 11* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 12 12* install(86-07-28,MR12.0-1105): 12 13* Fix fortran bug 454. 12 14* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 12 15* install(87-08-06,MR12.1-1069): 12 16* Implemented SCP 6315: fortran error-handling argument. 12 17* END HISTORY COMMENTS */ 12 18 12 19 12 20 /* Modified: 12 21* May 15 1987 by R. Waters - SCP 6315 added debug_io bit. 12 22* May 23 1985 by B.Wong - 454: document internal file mode. 12 23* March 28 1984 by M. Mabey to install HFP support. 12 24* May 11 1980 by Marshall Presser to add ansi_77 bit 12 25* July 13 1979 by C R Davis to add fold bit. 12 26* May 17 1977 by David Levin to extend control_type field and add iostat_var 12 27**/ 12 28 12 29 2 job_bits unaligned structure, 12 30 3 error_label bit(1), /* if err= supplied in statement. */ 12 31 3 end_label bit(1), /* if end= supplied in statement. */ 12 32 3 read bit(1), /* if not control stmnt then read if true, write if false. */ 12 33 3 format bit(2), /* list directed-"00"b, unfmt-"01"b, fmt-"10"b, namelist-"11"b */ 12 34 3 mode bit(2), /* seq-"00"b, direct access-"01"b, string io-"10"b, internal file-"11"b */ 12 35 3 list bit(1), /* if I/O transmission includes a list. */ 12 36 3 control_type bit(4), /* see fortran_io_consts.incl.pl1 for meanings */ 12 37 3 mbz bit(1), /* to allow expansion of control_type. MUST BE ZERO */ 12 38 3 iostat_var bit(1), /* if iostat= supplied in statement */ 12 39 3 debug_io bit(1), /* if user wants cu_$cl called after an io error */ 12 40 3 reserved bit(3), /* used to be bit (4) but I stole one for debug_io. Hope they're not important :-) */ 12 41 12 42 /* the following two fields are generated at runtime */ 12 43 12 44 3 have_input bit(1), /* if buffer contains a printable input record. */ 12 45 3 end_of_input bit(1), /* if user has terminated list-dir input */ 12 46 12 47 3 fold bit (1), /* if symbol names have been folded to lower case */ 12 48 3 ansi_77 bit(1), /* if source has been compiled in ansii77 mode */ 12 49 3 hfp bit(1), /* if hex floating point math is to be used */ 12 50 3 pad bit(13), 12 51 12 52 /* END fortran_job_bits.incl.pl1 */ 12 53 886 887 dummy fixed bin (18); 888 13 1 /* BEGIN format_tables.incl.pl1 */ 13 2 13 3 /****^ HISTORY COMMENTS: 13 4* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter): 13 5* Fix fortran bug 122. 13 6* END HISTORY COMMENTS */ 13 7 13 8 /* format: style2 */ 13 9 /* 13 10* Modified: 13 11* 27 Nov 85, RW 122 - Changed fmt_len from fixed bin (11) to 13 12* fixed bin (12) unsigned. 13 13* 19 Oct 82, TO - Added 'd_format'. 13 14* 27-31 July 1981, MEP - Changed names of format_desc_bit fields, and added names of new formats. 13 15* 23 May 1978, DSL - Change precision of scalars to fixed bin(8). 13 16* Modified: March 1978, DSL - to implement new runtime format 13 17* modified: June 1976, by D Levin 13 18* 13 19* This include file defines the internal representation of format specifications for fortran. */ 13 20 13 21 13 22 /* number of array elements required to represent a format specification */ 13 23 13 24 /* format: off */ 13 25 dcl increment_table (0:29) fixed bin internal static options (constant) 13 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); 13 27 /* i f e l d o g r a h x t p ( ) / : " E tr bz bn s sp ss */ 13 28 13 29 /* format: on */ 13 30 /* actual representation of a format statement */ 13 31 13 32 dcl 1 runtime_format based aligned structure, 13 33 2 header_word unaligned structure, 13 34 3 version bit (6), /* current version is fmt_parse_ver1 */ 13 35 3 last_left_paren fixed bin (11), /* position at which to repeat the spec */ 13 36 3 format_desc_bits structure, 13 37 4 anyitems bit (1), /* ON if format contains a field descriptor */ 13 38 4 list_directed bit (1), /* ON if format specifies list directed format */ 13 39 4 skip_line_numbers 13 40 bit (1), /* ON if format specifies skiping line numbers */ 13 41 4 contains_hollerith 13 42 bit (1), /* ON if format contains hollerith fields */ 13 43 4 suppress_newline 13 44 bit (1), /* ON if final new_line not wanted */ 13 45 4 pad bit (1), 13 46 3 fmt_len fixed bin (12) unsigned,/* length of format, in chars */ 13 47 2 fmt (1023) bit (36); /* encoded format specs */ 13 48 13 49 dcl 1 old_format aligned based structure, 13 50 2 header_word like runtime_format.header_word unaligned structure, 13 51 2 fmt (1022) fixed bin (17) unaligned; 13 52 13 53 dcl 1 format aligned based, 13 54 2 long_format bit (1) unaligned, 13 55 2 spec fixed bin (7) unaligned, 13 56 2 rep_factor fixed bin (8) unaligned, 13 57 2 width fixed bin (8) unaligned, 13 58 2 precision fixed bin (8) unaligned; 13 59 13 60 dcl 1 long_format aligned based, 13 61 2 long_format bit (1) unaligned, 13 62 2 spec fixed bin (7) unaligned, 13 63 2 exponent fixed bin (9) unsigned unaligned, 13 64 2 rep_factor fixed bin (17) unaligned, 13 65 2 width fixed bin (17) unaligned, 13 66 2 precision fixed bin (17) unaligned; 13 67 13 68 13 69 /* error message overlay */ 13 70 13 71 dcl 1 format_error aligned based structure, 13 72 2 input_length fixed bin, 13 73 2 error_message char (128); 13 74 13 75 13 76 /* named constants for format specifications */ 13 77 13 78 dcl ( 13 79 a_format init (10), 13 80 bn_format init (25), 13 81 bz_format init (26), 13 82 d_format init (4), 13 83 e_format init (2), 13 84 extended_i_format init (22), 13 85 g_format init (6), 13 86 i_format init (0), 13 87 s_format init (27), 13 88 sp_format init (28), 13 89 ss_format init (29), 13 90 t_format init (13), 13 91 tr_format init (21), 13 92 end_of_format init (20), 13 93 hollerith_field init (11), 13 94 quoted_string init (19) 13 95 ) fixed bin int static options (constant); 13 96 13 97 dcl fmt_parse_ver1 bit (6) aligned int static options (constant) init ("110000"b); 13 98 dcl max_value fixed bin (8) int static options (constant) init (255); 13 99 dcl chars_per_word fixed bin (8) int static options (constant) init (4); 13 100 dcl chars_per_halfword fixed bin (8) int static options (constant) init (2); 13 101 13 102 /* END format_tables.incl.pl1 */ 889 890 891 /* format: off */ 892 dcl 1 statement_attributes 893 (64) aligned structure internal static options (constant), 894 2 statement_label_type 895 bit (2) unaligned /* Stmnt label is: executable, format, non-executable */ 896 init ( 897 (28) (1)"11"b, /* 1-28 */ 898 "01"b, /* 29 */ 899 (3) (1)"01"b, /* 30-32 */ 900 (4) (1)"01"b, /* 33-36 */ 901 "10"b, "11"b, /* 37&38 */ 902 (7) (1)"01"b, /* 39-45 */ 903 "11"b, /* 46 */ 904 (17) (1)"01"b, /* 47-63 */ 905 "11"b), /* 64 */ 906 2 ok_second_statement 907 bit (1) unaligned /* On if legal second stmnt for logical if stmnt. */ 908 init ( 909 (28) (1)"0"b, /* 1-28 */ 910 "1"b, /* 29 */ 911 (3) (1)"0"b, /* 30-32 */ 912 (4) (1)"1"b, /* 33-36 */ 913 "0"b, "0"b, /* 37&38 */ 914 (7) (1)"1"b, /* 39-45 */ 915 "0"b, /* 46 */ 916 (14) (1)"1"b, /* 47-60 */ 917 "0"b, "1"b, "1"b, "0"b), /* 61-64 */ 918 2 need_label bit (1) unaligned /* On if FOLLOWING stmnt must have a label. */ 919 init ( 920 (28) (1)"0"b, /* 1-28 */ 921 "1"b, /* 29 */ 922 (3) (1)"0"b, /* 30-32 */ 923 "1"b, /* 33 */ 924 (5) (1)"0"b, /* 34-38 */ 925 "1"b, /* 39 */ 926 (7) (1)"0"b, /* 40-46 */ 927 "1"b, /* 47 */ 928 (5) (1)"0"b, /* 48-52 */ 929 "1"b, /* 53 */ 930 (11) (1)"0"b), /* 54-64 */ 931 2 cant_be_reached bit (1) unaligned /* On if THIS statement is not reached by block if */ 932 init ( 933 (29) (1)"1"b, /* 1-29 */ 934 (3) (1)"0"b, /* 30-32 */ 935 (32) (1)"1"b), /* 33-64 */ 936 937 2 cant_ref_label bit (1) unaligned /* ON if label on this statment cant be referenced */ 938 init ( 939 (29) (1)"0"b, /* 1 -29 */ 940 (2) (1)"1"b, /* 30-31 */ 941 (33) (1)"0"b), /* 32-64 */ 942 2 reserved bit (12) unaligned init ((64) (1)""b), 943 /* Unused. */ 944 2 first_keyword fixed bin (18) unaligned unsigned 945 /* Beginning of program section for this stmnt. */ 946 init ( 947 (11) 11, /* 1-11 */ 948 (50) 12, /* 12-61 */ 949 (3) 0); /* 62-64 */ 950 951 /* format: on */ 952 /* Keyword character strings. */ 953 954 dcl keyword_table (64) char (28) varying internal static options (constant) 955 init ("program", "blockdata", "subroutine", "function", "integerfunction", "realfunction", 956 "doubleprecisionfunction", "complexfunction", "logicalfunction", "characterfunction", "implicit", 957 "dimension", "common", "equivalence", "integer", "real", "doubleprecision", "complex", "logical", 958 "character", "external", "intrinsic", "namelist", "parameter", "library", "save", "automatic", 959 "statement func. definition", "if", "elseif", "else", "endif", "goto", "call", "continue", "write", 960 "format", "data", "return", "rewind", "endfile", "read", "encode", "decode", "print", "entry", "stop", 961 "pause", "assign", "punch", "input", "backspace", "chain", "closefile", "margin", "openfile", "open", 962 "close", "inquire", "assignment", "do", "UNKNOWN", "SEQUENCE ERROR", "end"); 963 964 /* Statement Key Label Ok Need 1st 965* Type Len Type 2nd Label Key 966* 967* 1 Program 7 Un . No No 11 968* 2 Block Data 9 Un . No No 11 969* 3 Subroutine 10 Un . No No 11 970* 4 Function 8 Un . No No 11 = function_statement 971* 5 Integer Function 15 Un . No No 11 972* 6 Real Function 12 Un . No No 11 973* 7 Double Precision Function 23 Un . No No 11 974* 8 Complex Function 15 Un . No No 11 975* 9 Logical Function 15 Un . No No 11 976* 10 Character Function 17 Un . No No 11 977* 11 Implicit 8 Un . No No 11 = after_subprogram 978* 12 Dimension 9 Un . No No 12 979* 13 Common 6 Un . No No 12 980* 14 Equivalence 11 Un . No No 12 = equivalence_statement 981* 15 Integer 7 Un . No No 12 = first_mode_keyword 982* 16 Real 4 Un . No No 12 983* 17 Double Precision 15 Un . No No 12 984* 18 Complex 7 Un . No No 12 985* 19 Logical 7 Un . No No 12 986* 20 Character 9 Un . No No 12 = last_mode_keyword 987* 21 External 8 Un . No No 12 988* 22 Intrinsic 9 Un . No No 12 989* 23 Namelist 8 Un . No No 12 990* 24 Parameter 9 Un . No No 12 = parameter_statement 991* 25 Library 7 Un . No No 12 992* 26 Save 4 Un . No No 12 993* 27 Automatic 9 Un . No No 12 994* 28 Statement Function Def 0 Un . No No 12 = asf_definition 995* 29 If (Arithmetic) 2 Ex . Yes Yes 12 996* 30 Elseif 6 Un . No No 12 = elseif_statement 997* 31 Else 4 Un . No No 12 = else_statement 998* 32 Endif 5 Un . No No 12 999* 33 Goto 4 Ex . Yes Yes 12 1000* 34 Call 4 Ex . Yes No 12 1001* 35 Continue 8 Ex . Yes No 12 1002* 36 Write 5 Ex . Yes No 12 1003* 37 Format 6 Fmt . No No 12 1004* 38 Data 4 Un . No No 12 1005* 39 Return 6 Ex . Yes Yes 12 1006* 40 Rewind 6 Ex . Yes No 12 1007* 41 Endfile 7 Ex . Yes No 12 1008* 42 Read 4 Ex . Yes No 12 1009* 43 Encode 6 Ex . Yes No 12 1010* 44 Decode 6 Ex . Yes No 12 = decode_statement 1011* 45 Print 5 Ex . Yes No 12 1012* 46 Entry 5 Un . No No 12 1013* 47 Stop 4 Ex . Yes Yes 12 1014* 48 Pause 5 Ex . Yes No 12 1015* 49 Assign To 6 Ex . Yes No 12 1016* 50 Punch 5 Ex . Yes No 12 1017* 51 Input 5 Ex . Yes No 12 1018* 52 Backspace 9 Ex . Yes No 12 1019* 53 Chain 5 Ex . Yes Yes 12 1020* 54 Closefile 9 Ex . Yes No 12 1021* 55 Margin 6 Ex . Yes No 12 1022* 56 Openfile 8 Ex . Yes No 12 1023* 57 Open 4 Ex . Yes No 12 1024* 58 Close 5 Ex . Yes No 12 1025* 59 Inquire 7 Ex . Yes No 12 1026* 60 Assignment 0 Ex . Yes No 12 = assignment_statement 1027* 61 Do 2 Ex . No No 12 = do_statement 1028* 62 Unknown 0 Ex . Yes No 0 = unknown_statement 1029* 63 Out of Sequence 0 Ex . Yes No 0 = out_of_sequence 1030* 64 End 0 Un . No No 0 = end_line 1031**/ 1032 1033 1034 dcl 1 expression aligned based structure, 1035 2 storage_info like symbol.storage_info unaligned, 1036 /* currently 5 bits */ 1037 2 allow_array_name bit (1) unaligned, 1038 2 reset_arg_bit bit (1) unaligned, 1039 2 needs_descriptors bit (1) unaligned, 1040 2 not_scalar_ref unaligned structure, 1041 3 subscripted_ref bit (1) unaligned, 1042 3 array_name bit (1) unaligned, 1043 3 not_simple_ref bit (1) unaligned, 1044 3 substring_ref bit (1) unaligned, 1045 2 not_constant bit (1) unaligned, 1046 2 no_assumed_size_array bit (1) unaligned; 1047 1048 /* format: off */ 1049 /* L E G E N D 1050* IN = set by caller to parse_expression 1051* OUT = set by parse_expression 1052* 1053* allocate (IN) 1054* |set (IN) 1055* | referenced (IN) 1056* | |passed_as_arg (IN - OUT) 1057* | | initialed (IN) 1058* | | |allow_array_name (IN) 1059* | | | reset_arg_bit (IN) 1060* | | | |needs_descriptors (IN) 1061* | | | | subscripted_ref (OUT) 1062* | | | | |array_name (OUT) 1063* | | | | | not_simple_ref (OUT) 1064* | | | | | |substring_ref (OUT) 1065* | | | | | | not_constant (OUT) 1066* | | | | | | |no_assumed_size_array (IN) 1067* |||||||||||||| 1068* |||||||||||||| 1069* Constant Names |||||||||||||| 1070* vvvvvvvvvvvvvv */ 1071 declare ( 1072 any_expression init ("101000000000000000000000000000000000"b), 1073 set_reference init ("111000000000000000000000000000000000"b), 1074 input_element init ("111001000000010000000000000000000000"b), 1075 output_element init ("101001000000010000000000000000000000"b), 1076 string_target init ("111001000000010000000000000000000000"b), 1077 string_source init ("101001000000010000000000000000000000"b), 1078 arg_list_expr init ("101101100000000000000000000000000000"b), 1079 darg_list_expr init ("101101110000000000000000000000000000"b), 1080 simple_reference init ("101000000000000000000000000000000000"b), 1081 format_reference init ("101001000000010000000000000000000000"b), 1082 set_no_symbol_bits init ("000000000000000000000000000000000000"b) 1083 ) bit (36) aligned int static options (constant); 1084 1085 /* format: on */ 1086 1087 dcl out bit (36) aligned; /* for return value */ 1088 14 1 /* BEGIN INCLUDE FILE ... compiler_source_info.incl.pl1 */ 14 2 /* coded in 1973 by B. Wolman */ 14 3 /* modified 12/75 by M. Weaver to include more source info */ 14 4 /* modified 12/76 by M. Weaver to include still more source info (version 2) */ 14 5 14 6 dcl 1 compiler_source_info aligned based, 14 7 2 version fixed bin, 14 8 2 given_ename char (32) var, 14 9 2 dirname char (168) var, 14 10 2 segname char (32) var, 14 11 2 date_time_modified fixed bin (71), 14 12 2 unique_id bit (36), 14 13 2 input_lng fixed bin (21), 14 14 2 input_pointer ptr; 14 15 14 16 dcl compiler_source_info_version_2 fixed bin static init (2) options (constant); 14 17 14 18 /* END INCLUDE FILE ... compiler_source_info.incl.pl1 */ 1089 15 1 /* BEGIN fortran_io_consts.incl.pl1 - various constants for fortran I/O */ 15 2 15 3 /* Modified: 15 4* 24 Oct 81, MEP added inquire_opr, deleted unused_9 (op_9) 15 5* 1 Oct 1981 - MEP internal file 15 6* 17 June 1981 - MEP for ansi77 i/o enhancements 15 7**/ 15 8 declare 15 9 (list_directed initial("00"b), 15 10 unformatted initial("01"b), 15 11 formatted initial("10"b), 15 12 namelist initial("11"b), 15 13 15 14 sequential_access initial("00"b), 15 15 direct_access initial("01"b), 15 16 string_io initial("10"b), 15 17 internal_file initial("11"b) )bit(2) aligned internal static options(constant); 15 18 15 19 dcl (write_opr initial(1), 15 20 old_endfile_opr initial(2), 15 21 read_opr initial(3), 15 22 rewind_opr initial(4), 15 23 op_5 initial(5), 15 24 closefile_opr initial(6), 15 25 close_opr initial(7), 15 26 backspace_opr initial(8), 15 27 inquire_opr initial(9), 15 28 openfile_opr initial(10), 15 29 open_opr initial(11), 15 30 margin_opr initial(12), 15 31 op_13 initial(13), 15 32 endfile_opr initial(14)) fixed bin(4) int static options(constant); 15 33 15 34 dcl (stream_file init("001"b), 15 35 record_file init("010"b), 15 36 blocked_file init("011"b), 15 37 binary_file init("100"b) ) bit(3) aligned int static options(constant); 15 38 15 39 dcl (undefined init(-1), 15 40 nonexistent init(0), 15 41 unstructured init(1), 15 42 sequential init(2), 15 43 blocked init(3), 15 44 indexed init(4), 15 45 binary_stream init(5) ) fixed bin int static options(constant); 15 46 15 47 /* This is the list of fields of the fields_specified word. It is used to check for duplication in the parse, and 15 48* is positionally importan for the code generator, fortran_io, and pl1_operators. */ 15 49 15 50 dcl (status_field init(1), 15 51 io_switch_field init(2), 15 52 attach_desc_field init(3), 15 53 filename_field init(4), 15 54 mode_field init(5), 15 55 access_field init(6), 15 56 form_field init(7), 15 57 recl_field init (8), 15 58 binarystream_field init (9), 15 59 prompt_field init (10), 15 60 carriage_field init (11), 15 61 defer_field init (12), 15 62 blank_field init (13), 15 63 units_field init (14), 15 64 fmt_field init (15), 15 65 rec_field init (16), 15 66 exist_field init (17), 15 67 opened_field init (18), 15 68 number_field init (19), 15 69 named_field init (20), 15 70 name_field init (21), 15 71 sequential_field init (22), 15 72 formatted_field init (23), 15 73 unformatted_field init (24), 15 74 nextrec_field init (25), 15 75 direct_field init (26) ) fixed bin int static options(constant); 15 76 15 77 /* The following masks indicate the valid keywords and fields known to the i/o routines: 15 78* read: unit, fmt, iostat, err, end, rec. 15 79* write: unit, fmt, iostat, err, end. 15 80* open: unit, iostat, err, file, status, access, form, recl, blank, status, ioswitch, 15 81* attach, mode, binarystream, prompt, carriage, defer. 15 82* close: unit, iostat, err, status. 15 83* inquire: unit _x_o_r file, iostat, err, exist, opened, number, named, name, access, sequential, direct, 15 84* form, formatted, unformatted, recl, nextrec, blank. 15 85* */ 15 86 declare (open_keyword_mask init ("111111111111100000000000000000000000"b), 15 87 valid_open_keyword init ("111111111111110000000000000000000000"b), 15 88 valid_read_keyword init ("000000000000011100000000000000000000"b), 15 89 valid_write_keyword init ("000000000000011000000000000000000000"b), 15 90 valid_close_keyword init ("100000000000010000000000000000000000"b), 15 91 valid_inquire_keyword init("000100000000010011111111110000000000"b)) 15 92 bit (36) aligned internal static options (constant); 15 93 /* END fortran_io_consts.incl.pl1 */ 1090 1091 1092 /* THE PARSE PHASE BEGINS HERE. */ 1093 1094 /* Initialize constants used by the entire phase. */ 1095 1096 addr (work) -> based_integer = 0; 1097 value_0 = create_constant (int_mode, work); 1098 default_unit_specifier = value_0; 1099 addr (work) -> based_integer = 1; 1100 value_1 = create_constant (int_mode, work); 1101 value_7 = 0; 1102 1103 cur_segment = 0; /* Used to chain the source nodes. */ 1104 first_segment = 0; /* Head of source node chain. */ 1105 number_of_source_segments = 0; 1106 number_of_lines = 0; /* count total number of lines parsed */ 1107 last_source_line = 0; /* insures comments print with following program unit */ 1108 profile_size = 0; /* counts number of profile entries required */ 1109 unnamed_block_data_subprogram = 0; /* keep track of whether or not one was compiled */ 1110 from_data_parser = FALSE; /* Used by get_next_token to suppress error msgs. */ 1111 1112 free_chain = 0; /* Free initial "nodes". */ 1113 max_stack = 0; /* Number of words used in stack. */ 1114 file_stack_depth = 0; /* Current include file nesting depth. */ 1115 shared_structure.incl_count = -1; /* Count of include files used in this compilation. */ 1116 1117 subprogram_op = main_op; 1118 subprogram_attributes = main_attr; 1119 subprogram_conflicts = all_attributes; 1120 1121 sign = ZERO; /* Refer to procedure "convert_integer_constant" for explanation. */ 1122 1123 options.namelist_used = FALSE; 1124 line_numbered_text = shared_structure.options.has_line_numbers; 1125 produce_listing = string (shared_structure.options.listing) ^= ZERO; 1126 parameter_info.shared_pointer = shared_ptr; 1127 1128 /* the following makes a template for the statement node */ 1129 1130 unspec (statement_info) = ZERO; 1131 addr (statement_info) -> statement.op_code = stat_op; 1132 addr (statement_info) -> statement.next = (18)"0"b; 1133 addr (statement_info) -> statement.location = (18)"1"b; 1134 addr (statement_info) -> statement.statement = "00001"b; 1135 1136 /* SEGMENT LOOP. THIS LOOP IS EXECUTED ONCE FOR EACH SOURCE SEGMENT. */ 1137 1138 source_info = src_info_ptr; /* Copy input argument. */ 1139 source_ptr = source_info -> compiler_source_info.input_pointer; 1140 /* Points to source segment. */ 1141 1142 shared_structure.source_file_number, shared_structure.source_line_number = 0; 1143 do while (source_ptr ^= null); 1144 1145 source_len = source_info -> compiler_source_info.input_lng; 1146 1147 /* Build source node and save segment info. */ 1148 1149 shared_structure.incl_count = shared_structure.incl_count + 1; 1150 1151 addr (statement_info) -> statement.file = shared_structure.incl_count; 1152 1153 number_of_source_segments = number_of_source_segments + 1; 1154 1155 if source_info -> compiler_source_info.segname = "" then 1156 i = 63 - divide (length (source_info -> compiler_source_info.dirname), chars_per_word, 17, 0); 1157 i = 63 1158 - 1159 divide (length (source_info -> compiler_source_info.dirname) 1160 + length (source_info -> compiler_source_info.segname), chars_per_word, 17, 0); 1161 1162 indx = create_node (source_node, size (source) - i); 1163 /* Pathname cannot be made longer. */ 1164 1165 shared_structure.source_node_offset (incl_count) = indx; 1166 shared_structure.incl_len (incl_count) = source_len; 1167 shared_structure.incl_ptr (incl_count) = source_ptr; 1168 1169 if cur_segment = 0 then 1170 first_segment = indx; 1171 else 1172 seg_ptr -> source.next = indx; 1173 1174 cur_segment = indx; 1175 seg_chain_end_ptr, seg_ptr = addr (OS (cur_segment)); 1176 1177 seg_ptr -> source.pathname = source_info -> compiler_source_info.dirname; 1178 if source_info -> compiler_source_info.segname ^= "" then do; 1179 seg_ptr -> source.pathname = seg_ptr -> source.pathname || ">"; 1180 seg_ptr -> source.pathname = 1181 seg_ptr -> source.pathname || source_info -> compiler_source_info.segname; 1182 end; 1183 1184 seg_ptr -> source.uid = source_info -> compiler_source_info.unique_id; 1185 seg_ptr -> source.dtm = source_info -> compiler_source_info.date_time_modified; 1186 1187 /* Initialize the lex and get the first significant character in the segment. */ 1188 1189 call statement_lex$initialize; /* Sets "type_of_line", subr_options, segment_options */ 1190 1191 if type_of_line = no_more_source /* Abort if segment contains no statements. */ 1192 then do; 1193 call print_message (1); /* segment contains no source code */ 1194 end; 1195 1196 /* SUBPROGRAM LOOP. EXECUTED ONCE FOR EACH SUBPROGRAM. */ 1197 1198 do while (type_of_line ^= no_more_source); 1199 1200 /* INITIALIZATION REQUIRED FOR EACH SUBPROGRAM. */ 1201 1202 /* Build a subprogram header for the subprogram's attributes. */ 1203 1204 cur_subprogram = create_node (subprogram_node, size (subprogram)); 1205 sub_ptr = addr (OS (cur_subprogram)); 1206 1207 if last_subprogram ^= 0 /* Chain this header in with the others. */ 1208 then do; 1209 sub_ptr -> previous_subprogram = last_subprogram; 1210 addr (OS (last_subprogram)) -> next_subprogram = cur_subprogram; 1211 end; 1212 else 1213 first_subprogram = cur_subprogram; 1214 last_subprogram = cur_subprogram; 1215 1216 if seg_ptr -> source.initial_subprogram = 0 1217 /* Set field as needed. */ 1218 then 1219 seg_ptr -> source.initial_subprogram = cur_subprogram; 1220 1221 sub_ptr -> first_polish = next_free_polish; 1222 sub_ptr -> subprogram.options = subr_options; 1223 last_statement = -1; /* No previous statement. */ 1224 subprogram_op = 0; /* Not a function or subroutine yet. */ 1225 alternate_return_index = 0; /* argument to implement alternate return */ 1226 1227 1228 /* If a listing is to be produced, build the listing_info node */ 1229 1230 if produce_listing then do; 1231 listing_info.next = next_free_listing; 1232 /* build forward chain */ 1233 1234 cur_listing = addr (listing_seg (next_free_listing)); 1235 /* point to new node */ 1236 unspec (listing_info) = ZERO; /* initialize the node */ 1237 next_free_listing = next_free_listing + size (listing_info); 1238 1239 listing_info.subprogram = cur_subprogram; 1240 1241 listing_info.first_cref = number_of_crefs + 1; 1242 listing_info.first_line = last_source_line + 1; 1243 end; 1244 1245 1246 /* Initialize symbol and label hash tables, and zero count of compiler generated symbols. */ 1247 1248 unspec (hash_table) = ZERO; 1249 unspec (label_hash_table) = ZERO; 1250 cp_count = 0; /* Count of compiler generated names. */ 1251 cp_label_count = 0; /* Count of compiler labels. */ 1252 1253 have_auto_stmnt = FALSE; /* information about storage class statements */ 1254 have_save_stmnt = FALSE; 1255 1256 /* Set up the default mode tables. The letters i thru n are integer. All others are real. */ 1257 1258 do i = 1 to 8; /* The letters a thru h in each case. */ 1259 default_table (i) = attr_table (real_mode); 1260 default_table (i + 26) = attr_table (real_mode); 1261 end; 1262 do i = 9 to 14; /* The letters i thru n in each case. */ 1263 default_table (i) = attr_table (int_mode); 1264 default_table (i + 26) = attr_table (int_mode); 1265 end; 1266 do i = 15 to 26; /* The letters o thru z in each case. */ 1267 default_table (i) = attr_table (real_mode); 1268 default_table (i + 26) = attr_table (real_mode); 1269 end; 1270 1271 mode_defined = ZERO; /* Nothing defined by the user. */ 1272 1273 /* Initialize the parse of a subprogram. */ 1274 1275 must_have_label = FALSE; /* Label not required for first executable statement. */ 1276 assignment_statement_index = asf_definition; 1277 /* First apparent asgn stmnt might be st.func.def. */ 1278 bypass_first_pending_entry = FALSE; /* No need to bypass main entry. */ 1279 pending_entry_cnt = 0; /* No entries pending. */ 1280 keyword_index = 1; /* First statement may be anything. */ 1281 do_index = 0; /* Reset do loop stack. */ 1282 stack_index = lbound (stack, 1); /* Stack is initially empty. */ 1283 1284 stack_base = stack_index; /* lex first statement separately because of special case below. */ 1285 1286 call statement_lex (statement_type); /* Lex the first statement of a subprogram. */ 1287 1288 /* Function statements of the form "mode*k function" look like mode statements 1289* to the statement recognizer. Decide if initial mode st is really a func st. */ 1290 1291 allow_star_after = TRUE; /* Allow either form of function statement. */ 1292 1293 if statement_type >= first_mode_keyword & statement_type <= last_mode_keyword 1294 /* a mode st */ 1295 then 1296 if token_list (first_token).type = asterisk & first_token + 2 <= last_token then do; 1297 if token_list (first_token + 2).type = ident then 1298 if substr (st_copy, token_list (first_token + 2).offset + 1, 8) = "function" then do; 1299 1300 /* Set stmnt type = function_statement + mode. Delete "function" chars. */ 1301 1302 statement_type = function_statement + (statement_type - first_mode_keyword + 1); 1303 call split_token (8, first_token + 2, TRUE); 1304 allow_star_after = FALSE; 1305 /* "*k" field must precede func name. */ 1306 end; 1307 else 1308 ; 1309 else /* process potential character *(*) function */ 1310 if token_list (first_token + 1).type = left_parn 1311 & token_list (first_token + 2).type = asterisk 1312 & token_list (first_token + 3).type = right_parn 1313 & token_list (first_token + 4).type = ident & first_token + 4 <= last_token then 1314 if substr (st_copy, token_list (first_token + 4).offset + 1, 8) = "function" then do; 1315 1316 /* re-build the list as if we read 'CHARACTER FUNCTION f*(*) */ 1317 /* list looked like: (referenced to first_token) */ 1318 /* token -2 -1 0 1 2 3 4 */ 1319 /* ----- ----- * ( * ) FUNCTIONvar */ 1320 /* and moves to be: (FUNCTION is deleted) */ 1321 /* token -2 -1 0 1 2 3 4 */ 1322 /* ----- ----- var * ( * ) */ 1323 1324 /* Set stmnt type = function_statement + mode. Delete "function" chars. */ 1325 1326 statement_type = function_statement + (statement_type - first_mode_keyword + 1); 1327 1328 call split_token (8, first_token + 4, TRUE); 1329 1330 token_list (first_token + 0) = token_list (first_token + 4); 1331 token_list (first_token + 4) = token_list (first_token + 3); 1332 token_list (first_token + 3) = token_list (first_token + 2); 1333 token_list (first_token + 2) = token_list (first_token + 1); 1334 token_list (first_token + 1) = token_list (first_token + 3); 1335 end; 1336 end; 1337 1338 /* The first statement of a program unit specifies the type of subprogram. An end line at this point is 1339* legal. If the first statement is not a subroutine, function, or block data statement, 1340* then this is a main program and a "main statement" must be manufactured. */ 1341 1342 if statement_type >= after_subprogram then do; 1343 main_entry_point_name = default_main_entry_point_name; 1344 call build_main_program (build_symbol ((main_entry_point_name), main_attr, SET)); 1345 end; 1346 1347 /* STATEMENT LOOP. EXECUTED ONCE FOR EACH STATEMENT OF A SUBPROGRAM, EXCEPT THE END LINE. */ 1348 /* Note - a subprogram consisting of only an end_line is diagnosed above. */ 1349 1350 do while (statement_type ^= end_line); 1351 1352 /* This removes some statement types from look up at appropriate time. */ 1353 1354 if first_keyword (statement_type) > keyword_index then 1355 keyword_index = first_keyword (statement_type); 1356 /* "Shorten" the keyword list. */ 1357 1358 /* Initialize for statement label processing. */ 1359 1360 END_DO_RANGE = FALSE; /* This stmnt is not the terminal stmnt of a do loop. */ 1361 st_lbl_type = statement_label_type (statement_type); 1362 1363 /* If this is the first executable statement, inhibit future recognition of s.f. defs. 1364* Also, if any s.f. defs. have been parsed, emit a label to prevent the 1365* execution of the s.f. defs. by erroneous means. */ 1366 1367 if st_lbl_type = executable_label then 1368 if assignment_statement_index ^= assignment_statement then 1369 call finish_sf_defs; 1370 1371 /* If the next statement is executable and there are any entries pending, 1372* process them now. */ 1373 1374 if st_lbl_type = executable_label & pending_entry_cnt > 0 then 1375 call process_pending_entries; 1376 1377 /* Process statement label. "statement_label" is set by statement_lex; to zero if no label or value of label. 1378* All statement labels are entered in the label table. Only executable labels are checked when looking for 1379* the end of a do loop. Only executable stmnts are checked for missing labels. i.e. - the first executable 1380* statement after an unconditional transfer of control. */ 1381 1382 if statement_label ^= 0 then do; 1383 statement_label = enter_label (st_lbl_type, statement_label, SET); 1384 addr (OS (statement_label)) -> label.not_referencable = 1385 statement_attributes.cant_ref_label (statement_type); 1386 1387 if produce_listing /* mark cref node as a defining ref */ 1388 then do; 1389 if ^(addr (OS (statement_label)) -> label.referenced) then 1390 cross_reference (number_of_crefs - 1).line_no = 1391 -cross_reference (number_of_crefs - 1).line_no; 1392 else 1393 cross_reference (number_of_crefs).line_no = 1394 -cross_reference (number_of_crefs).line_no; 1395 end; 1396 1397 if st_lbl_type = executable_label then do; 1398 END_DO_RANGE = "0"b; 1399 1400 /* check if this terminates any do loops 1401* if so insure proper nesting of do loops and block if's and pop stack to terinating level */ 1402 1403 do inx = do_index to 1 by -1 while (^END_DO_RANGE); 1404 if do_blockif_stack (inx).do_loop then 1405 END_DO_RANGE = statement_label = do_blockif_stack (inx).label_ptr; 1406 if END_DO_RANGE then 1407 do jnx = do_index to inx + 1 by -1; 1408 if do_blockif_stack (jnx).do_loop then 1409 call print_message (183, do_blockif_stack (jnx).label_ptr); 1410 else 1411 call print_message (184, 1412 ltrim (char (do_blockif_stack (jnx).line_number))); 1413 end; 1414 end; 1415 1416 if END_DO_RANGE then 1417 do_index = inx + 1; 1418 must_have_label = need_label (statement_type); 1419 /* Reset need for label on following stmnt. */ 1420 1421 call emit_operand (statement_label); 1422 /* Emit label operand and label operator. */ 1423 call emit_operator (label_op); 1424 end; 1425 end; 1426 else if st_lbl_type = executable_label then do; 1427 /* Executable stmnt without label */ 1428 if must_have_label & statement_attributes.cant_be_reached (statement_type) then 1429 call print_message (5); /* statement cannot be referenced */ 1430 must_have_label = need_label (statement_type); 1431 end; 1432 1433 /* Reset global variables modified by the stmnt parsers. */ 1434 1435 logical_if_statement = FALSE; /* Statement is not a logical if statement. */ 1436 stack_base = stack_index; /* Stack can only grow by resetting stack_base. */ 1437 current_token = first_token - 1; /* First token of stmnt is next not current. */ 1438 go to parser (statement_type); /* Actually case(statement_type) */ 1439 1440 /* Input conditions true for all statement parsers: 1441* 1. values of token, token_offset, and token_length are invalid at entry; parsers must get first token by 1442* incrementing current_token; (i.e. - get_next_token(TRUE, ...)) 1443* 2. value of "statement_type" is valid when parser is entered; 1444* 3. value of "statement_label" is valid when parser is entered (pointer to label operand for statement label); 1445* 1446* Output requirements for each statement parser: 1447* 1. parser must position after last token processed to allow test for extraneous text; 1448**/ 1449 1450 /* End of case(statement_type) */ 1451 1452 1453 missing_identifier: 1454 call print_message (10, err_string ()); 1455 go to statement_parse_abort; 1456 1457 missing_right_paren: 1458 call print_message (11, err_string ()); 1459 go to statement_parse_abort; 1460 1461 missing_slash: 1462 call print_message (13, err_string ()); 1463 go to statement_parse_abort; 1464 1465 missing_left_paren: 1466 call print_message (22, err_string ()); 1467 go to statement_parse_abort; 1468 1469 missing_comma: 1470 call print_message (26, err_string ()); 1471 go to statement_parse_abort; 1472 1473 missing_equals_sign: 1474 call print_message (49, err_string ()); 1475 go to statement_parse_abort; 1476 1477 missing_label: 1478 call print_message (23, err_string ()); 1479 go to statement_parse_abort; 1480 1481 missing_keyword: 1482 call print_message (40, err_string ()); 1483 go to statement_parse_abort; 1484 invalid_keyword: 1485 call print_message (66, err_string (), keyword_table (statement_type)); 1486 go to statement_parse_abort; 1487 1488 invalid_substring: 1489 call print_message (195); 1490 go to statement_parse_abort; 1491 1492 parse_done: /* Check for extraneous text in statement. */ 1493 if current_token <= last_token then 1494 if token = right_parn /* be more explicit if parenthesis */ 1495 then 1496 call print_message (90); 1497 else 1498 call print_message (6, keyword_table (statement_type)); 1499 /* extra text */ 1500 1501 statement_parse_abort: /* If stmnt was a logical if, an exit operator must be emitted. */ 1502 if logical_if_statement then do; 1503 call emit_operator (exit_op); 1504 end; 1505 1506 /* If current stmnt terminates a do loop, emit exit operators for each loop which is terminated, 1507* but not if there is a block if seperating them */ 1508 1509 if END_DO_RANGE then 1510 do do_index = do_index to 1 by -1 1511 while (do_blockif_stack (do_index).do_loop 1512 & statement_label = do_blockif_stack (do_index).label_ptr); 1513 call emit_operator (exit_op); 1514 end; 1515 1516 /* Lex the next statement in the subprogram. Reexecute the loop if it is not an end_line. */ 1517 1518 stack_index = stack_base; /* Insure validity of what is on the stack. */ 1519 last_statement_type = statement_type; 1520 call statement_lex (statement_type); 1521 end; /* END OF STATEMENT LOOP. */ 1522 1523 /* The following code is executed after a subprogram is completely parsed. */ 1524 1525 cur_statement = -1; /* Suppress line number in error msgs. */ 1526 1527 /* Check for main program, subroutine, function, or entry point without executable code. */ 1528 1529 if sub_ptr -> subprogram_type ^= block_data 1530 & (assignment_statement_index ^= assignment_statement | pending_entry_cnt > 0) then 1531 call process_pending_entries; 1532 1533 /* Terminate all unended do loops and block ifs for the code generator. */ 1534 1535 do i = do_index to 1 by -1; 1536 if do_blockif_stack (i).do_loop then do; 1537 call emit_operator (exit_op); 1538 call print_message (8, do_blockif_stack (i).label_ptr); 1539 end; 1540 else do; 1541 call emit_operator (item_op); 1542 call emit_operator (eol_op); 1543 call print_message (178, ltrim (char (do_blockif_stack (i).line_number))); 1544 end; 1545 end; 1546 1547 /* Generate a return stmnt if control would pass thru to end_line. Then generate an endunit operator. */ 1548 1549 if ^must_have_label & sub_ptr -> subprogram_type ^= block_data then do; 1550 profile_size = profile_size + 1; 1551 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 1552 1553 call emit_return_op; 1554 call emit_statement_op (addr (statement_info)); 1555 /* NOT in profile or map */ 1556 end; 1557 1558 call emit_operator (endunit_op); 1559 1560 /* Indicate default storage class to storage allocator. */ 1561 1562 if ^have_auto_stmnt & ^have_save_stmnt then do; 1563 if have_auto_option | have_static_option then 1564 sub_ptr -> default_is.static = have_static_option; 1565 else 1566 sub_ptr -> default_is.static = shared_structure.options.user_options.static_storage; 1567 end; 1568 1569 sub_ptr -> default_is.auto = ^sub_ptr -> default_is.static; 1570 1571 /* Save offset of last emitted halfword. */ 1572 1573 sub_ptr -> last_polish = next_free_polish - 1; 1574 1575 1576 call declaration_processor; 1577 1578 1579 /* For listings, finish up the listing_info node */ 1580 1581 if produce_listing then do; 1582 listing_info.last_cref = number_of_crefs; 1583 last_source_line = number_of_lines;/* insures comments following endline are printed */ 1584 end; 1585 1586 /* Get first significant character of next subprogram, if such exists. */ 1587 1588 call statement_lex$get_next_subprogram; /* Sets "type_of_line". */ 1589 end; /* END OF SUBPROGRAM LOOP. */ 1590 1591 /* The following code is executed after all subprograms in the current source segment have been parsed. */ 1592 1593 source_info = addr (other_segment_info); /* use separate area for second thru nth segments */ 1594 1595 call get_next_source_seg (source_info); /* Returns new source info ptr or null. */ 1596 1597 if source_info = null then 1598 source_ptr = null; 1599 else 1600 source_ptr = source_info -> compiler_source_info.input_pointer; 1601 end; /* END OF SEGMENT LOOP. */ 1602 1603 /* if there is an entry name chain, insure it is separate from the symbol table */ 1604 1605 if last_entry_name ^= 0 then 1606 addr (OS (last_entry_name)) -> symbol.next_symbol = 0; 1607 call check_entry_duplication; /* Ensure no dups */ 1608 1609 /* Zero the object segment. */ 1610 1611 unspec (reset_stack) = ZERO; 1612 return; 1613 1614 /* BEGIN ext_parse section - PARSE - split 82-03-29 T. Oke */ 1615 /* Modification History: 1616* 1617*83-02-10 HH - Install LA/VLA support. 1618*82-06-28 TO. Change INQUIRE keyword "filename=" to "file=" to conform to 1619* standard. 1620*82-05-03 TO. Implement star_extent functions. 1621*82-05-03 TO. Start on multiply_check option catching. 1622*82-04-19 TO, Fix bug 287 in declaration_processor - create named_constant if 1623* static or automatic variable fit limits. Stolen from optimizer. 1624*82-04-05 TO, Fix bug 306 in get_equiv_var, by correctly throwing back a header 1625* node if equivalence cannot be made. 1626* */ 1627 1628 /* BEGIN case(statement_type) */ 1629 1630 /* Case Program 1631* 1632*Syntax: 1633* 1634*Polish: 1635* 1636*Notes: If present, must be the first statement in the source segment. 1637**/ 1638 1639 parser (1): 1640 string (cur_stmnt_ptr -> statement.bits) = put_in_map; 1641 1642 call get_next_token (force_symtab_entry, subprogram_symbol); 1643 if token ^= ident then 1644 go to missing_identifier; 1645 1646 call build_main_program (subprogram_symbol); 1647 current_token = current_token + 1; 1648 go to parse_done; 1649 1650 /* Case Block Data 1651* 1652*Syntax: [ ] 1653* 1654*Polish: 1655* 1656*Notes: 1657* sub_ptr points to subprogram header node in polish 1658* subprogram_op, etc unchanged 1659* common_name used to hold the name (or "unnamed name) of sub_prog 1660* it is also used in the parsing of common statements. 1661**/ 1662 parser (2): 1663 call emit_operator (block_data_op); 1664 1665 call get_next_token (ignore_symtab_entry, ignore_value); 1666 1667 if token = EOS_token then do; 1668 if unnamed_block_data_subprogram ^= 0 then 1669 call print_message (15); /* duplicate unnamed block data subprograms */ 1670 unnamed_block_data_subprogram = cur_subprogram; 1671 common_name = unnamed_block_data_subprg_name; 1672 end; 1673 else if token = ident then do; 1674 common_name = token_string; 1675 current_token = current_token + 1; 1676 end; 1677 else 1678 goto missing_identifier; 1679 1680 sub_ptr -> subprogram_type = block_data; 1681 SI, sub_ptr -> subprogram.symbol = build_symbol (common_name, no_attributes, SET); 1682 1683 /* if named block data, then indicate it's a user defined name. build symbol assumes compiler generated names */ 1684 1685 if common_name ^= unnamed_block_data_subprg_name then 1686 addr (OS (SI)) -> symbol.by_compiler = FALSE; 1687 1688 go to parse_done; 1689 1690 1691 /* Case Subroutine 1692* 1693*Syntax: [ ( [ ] ) ] 1694* 1695*Polish: [ ] 1696* 1697*Notes: 1698* subprogram_attributes same as a subroutine 1699* subprogram_conflicts any and all attributes 1700* subprogram_op subroutine opr 1701**/ 1702 parser (3): 1703 string (cur_stmnt_ptr -> statement.bits) = put_in_map; 1704 1705 call get_next_token (force_symtab_entry, subprogram_symbol); 1706 if token ^= ident then 1707 go to missing_identifier; 1708 1709 /* set fields in subprogram node */ 1710 1711 sub_ptr -> subprogram_type = subroutine; 1712 sub_ptr -> subprogram.symbol = subprogram_symbol; 1713 1714 /* set global variables for parameter list parse and entry statement parse */ 1715 1716 subprogram_op = subr_op; /* This symbol and its entries are subroutines. */ 1717 subprogram_attributes = subroutine_attributes; 1718 subprogram_conflicts = all_attributes; 1719 return_value_param = 0; /* used if label args are in parameter list */ 1720 1721 call parse_parameter_list (subprogram_symbol); /* emits all polish for stmnt and parses param list */ 1722 go to parse_done; 1723 1724 1725 /* Case Function 1726* 1727*Syntax: [ [ <*> ] ] ( [ ] ) 1728* 1729*Polish: ... 1730* 1731*Notes: 1732* includes return value parameter 1733**/ 1734 parser (4): 1735 parser (5): 1736 parser (6): 1737 parser (7): 1738 parser (8): 1739 parser (9): 1740 parser (10): 1741 string (cur_stmnt_ptr -> statement.bits) = put_in_map; 1742 attributes = attr_table (statement_type - function_statement); 1743 1744 /* if mode keyword is provided, set function data type */ 1745 1746 if statement_type = function_statement then 1747 allow_star_after = FALSE; /* mode not specified, so "*k" is invalid */ 1748 else if ^allow_star_after /* i.e., "*k" must appear before name */ 1749 then 1750 call get_mode_size (statement_type - function_statement, (default_char_size), attributes, asterisk_seen); 1751 1752 /* get name of function */ 1753 1754 call get_next_token (force_symtab_entry, return_value); 1755 if token ^= ident then 1756 go to missing_identifier; 1757 1758 /* if alternate form is possible, check for "*k" */ 1759 1760 if allow_star_after then 1761 call get_mode_size (statement_type - function_statement, (default_char_size), attributes, asterisk_seen); 1762 1763 /* function return value will be in hash table. Set accumulated attributes. */ 1764 1765 attributes = attributes | auto_attribute; /* force auto storage for return value */ 1766 if declare_symbol (return_value, attributes, all_attributes, DECLARED) then 1767 ; /* Error is impossible */ 1768 1769 /* function name is not in hash table */ 1770 1771 subprogram_symbol = build_symbol (substr (full_name, 1, symbol_length), no_attributes, SET); 1772 addr (OS (subprogram_symbol)) -> symbol.by_compiler = FALSE; 1773 /* treat as user symbol */ 1774 1775 /* function return value parameter */ 1776 /* do a little work on this to handle character*(*) functions. */ 1777 1778 /* if the attributes of the symbol indexed by "return_value" have star_extents 1779* then set them here too, and set the return_value as being stack_indirect. */ 1780 1781 return_value_param = build_symbol ((NO_NAME), param_variable_attrs, SET); 1782 if addr (OS (return_value)) -> symbol.star_extents then do; 1783 sub_ptr -> subprogram.star_extent_function = "1"b; 1784 addr (OS (return_value)) -> symbol.stack_indirect = "1"b; 1785 addr (OS (return_value_param)) -> symbol.star_extents = "1"b; 1786 addr (OS (subprogram_symbol)) -> symbol.star_extents = "1"b; 1787 end; 1788 1789 /* set fields in subprogram node */ 1790 1791 sub_ptr -> subprogram_type = function; 1792 sub_ptr -> subprogram.symbol = subprogram_symbol; 1793 1794 /* set global variables for parameter list and entry statement parsers */ 1795 1796 subprogram_op = func_op; 1797 subprogram_attributes = function_attribute; 1798 subprogram_conflicts = entry_point_conflicts; 1799 1800 call parse_parameter_list (subprogram_symbol); /* emits all polish for stmnt and parses param list */ 1801 1802 go to parse_done; 1803 1804 1805 /* Case Implicit 1806* 1807*Syntax: 1808* 1809*Polish: 1810* 1811*Notes: 1812**/ 1813 parser (11): /* Parse each mode range separately. */ 1814 in_stmnt = TRUE; 1815 do while (in_stmnt); 1816 1817 /* Get mode type and build attribute bit string. */ 1818 1819 call get_next_token (ignore_symtab_entry, ignore_value); 1820 if token ^= ident then 1821 go to missing_keyword; 1822 1823 if length (fast_lookup) - symbol_length > 0 /* pad with blanks when necessary */ 1824 then 1825 substr (fast_lookup, symbol_length + 1, length (fast_lookup) - symbol_length) = NULL_STRING; 1826 1827 do i = first_mode_keyword to last_mode_keyword while (keyword_table (i) ^= fast_lookup); 1828 end; 1829 1830 if i > last_mode_keyword then 1831 go to invalid_keyword; 1832 1833 attributes = attr_table (i - first_mode_keyword + 1); 1834 call get_mode_size (i - first_mode_keyword + 1, (default_char_size), attributes, asterisk_seen); 1835 1836 /* Parse letter range(s). */ 1837 1838 call get_next_token$operator; /* Get left parenthesis. */ 1839 if token ^= left_parn then 1840 go to missing_left_paren; 1841 1842 in_list = TRUE; 1843 do while (in_list); 1844 1845 /* get the first, or only letter in the range */ 1846 1847 call get_next_token (ignore_symtab_entry, ignore_value); 1848 if token ^= ident | symbol_length ^= 1 then do; 1849 call print_message (45, err_string ()); 1850 go to statement_parse_abort; 1851 end; 1852 1853 begin_char, end_char = index (alphabetic, substr (full_name, 1, 1)); 1854 1855 /* there is a second letter if the first is followed by a hyphen */ 1856 1857 call get_next_token$operator; /* get comma, right paren, or hyphen (minus) */ 1858 if token = minus then do; 1859 call get_next_token (ignore_symtab_entry, ignore_value); 1860 if token ^= ident | symbol_length ^= 1 then do; 1861 call print_message (45, err_string ()); 1862 go to statement_parse_abort; 1863 end; 1864 1865 end_char = index (alphabetic, substr (full_name, 1, 1)); 1866 1867 /* insure the range specified is valid */ 1868 1869 if end_char < begin_char then do; 1870 call print_message (46); /* chars wrong order */ 1871 go to statement_parse_abort; 1872 end; 1873 1874 if divide (begin_char - 1, 26, 17, 0) ^= divide (end_char - 1, 26, 17, 0) then do; 1875 call print_message (47); 1876 go to statement_parse_abort; 1877 end; 1878 1879 call get_next_token$operator; /* get comma or right paren */ 1880 end; 1881 1882 /* regardless of how we got the range, see if it's been used before */ 1883 1884 if substr (mode_defined, begin_char, end_char - begin_char + 1) ^= ZERO then 1885 call print_message (129); 1886 1887 substr (mode_defined, begin_char, end_char - begin_char + 1) = (26)"1"b; 1888 1889 /* set range to desired type */ 1890 1891 do i = begin_char to end_char; 1892 default_table (i) = attributes; 1893 end; 1894 if token ^= comma then 1895 in_list = FALSE; 1896 end; 1897 if token ^= right_parn then 1898 go to missing_right_paren; 1899 1900 call get_next_token$operator; /* get comma or eos */ 1901 if token ^= comma then 1902 in_stmnt = FALSE; 1903 end; 1904 go to parse_done; 1905 1906 1907 /* Case Dimension 1908* 1909*Syntax: 1910* 1911*Polish: 1912* 1913*Notes: 1914**/ 1915 parser (12): 1916 in_list = TRUE; 1917 do while (in_list); 1918 call get_next_token (force_symtab_entry, SI); 1919 if token ^= ident then 1920 go to missing_identifier; 1921 1922 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 1923 then 1924 call print_message (140, SI, (keyword_table (statement_type))); 1925 1926 call get_next_token$operator; /* get left paren */ 1927 if token ^= left_parn then 1928 go to missing_left_paren; 1929 1930 call get_bounds (SI); 1931 if token ^= comma then 1932 in_list = FALSE; 1933 end; 1934 go to parse_done; 1935 1936 1937 /* Case Common 1938* 1939*Syntax: [ / [ ] / ] [ / [ ] / ] ... 1940* 1941*Polish: 1942* 1943*Notes: 1944* common_name 8 (?)-character name of common block, also used in block_data statement parse 1945* in_stmnt on while parsing a common block list; off if current list not followed by another list 1946* SI passes output from get_next_token to other subroutines 1947* indx word offset of current common block header node 1948* in_list on while conditions for loop still hold 1949**/ 1950 parser (13): 1951 call get_next_token (force_symtab_entry, SI); /* Get slash or first member of list. */ 1952 1953 in_stmnt = TRUE; /* Indicates more text left to parse. */ 1954 do while (in_stmnt); /* Loop for each common list. */ 1955 1956 /* Get common block name. */ 1957 1958 if token = slash /* Name is given explicitly. */ 1959 then do; 1960 call get_next_token (ignore_symtab_entry, ignore_value); 1961 /* Get slash or block name. */ 1962 1963 if token ^= ident then 1964 go to missing_identifier; 1965 common_name = substr (full_name, 1, symbol_length); 1966 /* save block name */ 1967 1968 call get_next_token$operator; /* Get slash. */ 1969 1970 if token ^= slash then 1971 go to missing_slash; 1972 1973 call get_next_token (force_symtab_entry, SI); 1974 /* Get first member of list. */ 1975 end; 1976 else if token = concat /* Two slashes in a row */ 1977 then do; 1978 common_name = blank_common_name; 1979 call get_next_token (force_symtab_entry, SI); 1980 end; 1981 else 1982 common_name = blank_common_name; /* initial common name is omitted */ 1983 1984 /* Find header node if already defined or create a new one. */ 1985 1986 indx = sub_ptr -> common_chain; /* Get head of list. */ 1987 if indx = 0 then do; 1988 1989 /* create a header node for this common block and thread into chain */ 1990 1991 indx = build_common_block (common_name); 1992 sub_ptr -> common_chain = indx; 1993 end; 1994 1995 else do; /* List is not empty. */ 1996 in_list = TRUE; 1997 do while (in_list); /* Search the list. */ 1998 if addr (OS (indx)) -> header.block_name = common_name then 1999 in_list = FALSE; /* Found old block. */ 2000 else if addr (OS (indx)) -> header.next_header = 0 then do; 2001 /* End of list and not found. Create a new header node. */ 2002 in_list = FALSE; /* Indicate end of search. */ 2003 2004 addr (OS (indx)) -> header.next_header = build_common_block (common_name); 2005 indx = addr (OS (indx)) -> header.next_header; 2006 end; 2007 2008 else 2009 indx = addr (OS (indx)) -> header.next_header; 2010 end; 2011 end; 2012 2013 2014 /* If needed, generate cross reference nodes */ 2015 2016 if produce_listing then 2017 call generate_cross_ref (indx); 2018 2019 2020 /* Parse common block list. */ 2021 2022 in_list = TRUE; 2023 do while (in_list); 2024 if token ^= ident then 2025 go to missing_identifier; 2026 2027 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2028 then 2029 call print_message (140, SI, (keyword_table (statement_type))); 2030 2031 if declare_symbol (SI, member_attr, member_conflicts, DECLARED) then do; 2032 2033 /* Thread new member into common block list. */ 2034 2035 if addr (OS (indx)) -> header.last_element = 0 then 2036 addr (OS (indx)) -> header.first_element = SI; 2037 else 2038 addr (OS (addr (OS (indx)) -> header.last_element)) -> symbol.next_member = SI; 2039 addr (OS (indx)) -> header.last_element = SI; 2040 2041 addr (OS (SI)) -> symbol.parent = indx; 2042 2043 /* insure it is initialized only in a block data subprogram */ 2044 2045 if addr (OS (SI)) -> symbol.initialed then 2046 if sub_ptr -> subprogram_type = block_data then 2047 string (addr (OS (indx)) -> header.storage_info) = 2048 string (addr (OS (indx)) -> header.storage_info) 2049 | string (addr (OS (SI)) -> symbol.storage_info); 2050 else 2051 call print_message (80, SI); 2052 end; 2053 2054 else 2055 call print_message (20, SI, indx); /* Cannot be in this common block. */ 2056 2057 /* Process member bound, next member, or end of list. */ 2058 2059 call get_next_token$operator; /* Get left paren, comma, or slash. */ 2060 if token = left_parn then 2061 call get_bounds (SI); 2062 2063 if token = comma then do; 2064 call get_next_token (force_symtab_entry, SI); 2065 /* Get next member of list. */ 2066 if token = slash | token = concat then 2067 in_list = FALSE; 2068 end; 2069 else 2070 in_list = FALSE; 2071 end; 2072 if token ^= slash & token ^= concat then 2073 in_stmnt = FALSE; 2074 end; 2075 go to parse_done; 2076 2077 2078 /* Case Equivalence 2079* 2080*Syntax: 2081* 2082*Polish: 2083* 2084*Notes: 2085* 78.06.20 - Parse has been changed so that symbol.equivalenced DOES NOT imply that symbol.parent 2086* is valid. symbol.equivalenced may be TRUE while symbol.parent equals zero. 2087* 2088* Automatic storage is equivalence conflict. 2089**/ 2090 parser (14): 2091 in_stmnt = TRUE; 2092 do while (in_stmnt); 2093 call get_next_token$operator; /* get left paren */ 2094 if token ^= left_parn then 2095 go to missing_left_paren; 2096 2097 if token_list (current_token + 2).type = right_parn then do; 2098 call print_message (28); /* at least two required in group */ 2099 go to statement_parse_abort; 2100 end; 2101 2102 call stack_operand ((cur_statement)); /* For error messages. */ 2103 2104 in_list = TRUE; 2105 do while (in_list); 2106 call get_next_token (force_symtab_entry, SI); 2107 if token ^= ident then 2108 go to missing_identifier; 2109 2110 E_token = SI; 2111 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2112 then 2113 call print_message (140, SI, (keyword_table (statement_type))); 2114 else 2115 addr (OS (SI)) -> symbol.in_equiv_stmnt, addr (OS (SI)) -> symbol.equivalenced, 2116 /* mark as equiv'd */ 2117 addr (OS (SI)) -> symbol.variable = TRUE; 2118 /* must remain a variable */ 2119 2120 call stack_operand (SI); 2121 2122 call get_next_token$paren_operator; /* get comma, left paren, substring left paren, or right paren */ 2123 2124 if token = left_parn | token = substr_left_parn then do; 2125 2126 if token = left_parn /* Parse subscripts */ 2127 then 2128 call stack_operand (get_constant_offset (SI, FALSE)); 2129 /* inhibit variable subscripts */ 2130 2131 if token = substr_left_parn /* Parse substring */ 2132 then do; 2133 if ^subr_options.ansi_77 then do; 2134 call print_message (154); 2135 goto statement_parse_abort; 2136 end; 2137 call stack_operand (0); 2138 2139 call get_next_token (ignore_symtab_entry, SI); 2140 if token = dec_int then do; 2141 E_start = binary (addr (st_copy) -> token_structure.token_string, 17); 2142 2143 /* Check the constant start is in range */ 2144 if (E_start < 1) then 2145 call print_message (155, SI, "Start has a length < 1."); 2146 else if (E_start > addr (OS (E_token)) -> symbol.char_size + 1) then 2147 call print_message (155, SI, "Start > length."); 2148 else 2149 call stack_operand (E_start - 1); 2150 2151 call get_next_token$operator; 2152 if token = colon then do; 2153 2154 call get_next_token (ignore_symtab_entry, SI); 2155 if token = dec_int then do; 2156 E_finish = binary (addr (st_copy) -> token_structure.token_string); 2157 2158 /* Check if the constant finish is in range */ 2159 if (E_finish < E_start) then 2160 call print_message (155, SI, "Finish < start."); 2161 if (E_finish > addr (OS (E_token)) -> symbol.char_size + 1) then 2162 call print_message (155, SI, "Finish > length."); 2163 call get_next_token$operator; 2164 end; 2165 else if token ^= right_parn then 2166 go to invalid_substring; 2167 end; 2168 else 2169 go to invalid_substring; 2170 call get_next_token$operator; 2171 end; 2172 else if token = colon then do; 2173 E_start = 1; 2174 call stack_operand (E_start - 1); 2175 call get_next_token (ignore_symtab_entry, SI); 2176 if token = dec_int then do; 2177 E_finish = binary (addr (st_copy) -> token_structure.token_string); 2178 /* Check if the constant finish is in range */ 2179 if (E_finish < 1) then 2180 call print_message (155, SI, "Finish < 1."); 2181 if (E_finish > addr (OS (E_token)) -> symbol.char_size + 1) then 2182 call print_message (155, SI, "Finish > length."); 2183 call get_next_token$operator; 2184 end; 2185 else if token ^= right_parn then 2186 go to invalid_substring; 2187 call get_next_token$operator; 2188 end; 2189 else 2190 go to invalid_substring; 2191 end; 2192 else 2193 call stack_operand (0); 2194 end; 2195 else do; 2196 call stack_operand (0); 2197 call stack_operand (0); 2198 end; 2199 2200 if token ^= comma then 2201 in_list = FALSE; 2202 end; 2203 2204 if token ^= right_parn then 2205 go to missing_right_paren; 2206 2207 call stack_operator (-1); /* End of equivalence group. */ 2208 stack_base = stack_index; /* Prevent the info from being lost. */ 2209 2210 call get_next_token$operator; /* get comma or eos */ 2211 if token ^= comma then 2212 in_stmnt = FALSE; 2213 end; 2214 go to parse_done; 2215 2216 2217 /* Case Character, Complex, Double Precision, Integer, Logical, Real 2218* 2219*Syntax: [ * k ] [ * k ] [ ( d1 , ... dn ) ] ... [ / / ] ... 2220* 2221*Polish: [ ] 2222* where 2223* is the number of halfwords in 2224* is the code representing the data specifications. 2225* 2226*Notes: 2227* mode_type mode, or data type, specified by this statement 2228* in_stmnt on if data specifications are encountered; otherwise off 2229* char_siz used only for char stmnt; global char size to be used 2230* attributes attributes to be aplied to the variable being declared 2231* SI passes output from get_next_token to other subroutines 2232**/ 2233 parser (15): 2234 parser (16): 2235 parser (17): 2236 parser (18): 2237 parser (19): 2238 parser (20): 2239 mode_type = statement_type - first_mode_keyword + 1; 2240 /* Convert stmnt type to mode. */ 2241 first_word = 0; /* No "nodes" generated by data specs. */ 2242 char_siz = default_char_size; /* Only used if mode is character. */ 2243 attributes = attr_table (mode_type); 2244 call get_mode_size (mode_type, char_siz, attributes, asterisk_seen); 2245 /* Get the global mode for this statement. */ 2246 2247 in_list = TRUE; 2248 do while (in_list); /* Loop thru variable list. */ 2249 call get_next_token (force_symtab_entry, SI);/* Get variable name. */ 2250 if token ^= ident then 2251 go to missing_identifier; 2252 2253 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2254 then 2255 call print_message (140, SI, (keyword_table (statement_type))); 2256 2257 local_attributes = attributes; 2258 call get_mode_size ((mode_type), (char_siz), local_attributes, asterisk_seen); 2259 /* Get local attributes, but save global ones. */ 2260 2261 call stack_operand (SI); /* Stack it in case of data specifications. */ 2262 2263 call get_next_token$operator; /* Get left paren, slash, comma, or eos. */ 2264 2265 if token = left_parn then do; 2266 call get_bounds (SI); /* Declaring bounds in mode stmnt. */ 2267 if ^asterisk_seen & mode_type = char_mode then do; 2268 current_token = current_token - 1; 2269 call get_mode_size ((mode_type), (char_siz), local_attributes, asterisk_seen); 2270 call get_next_token$operator; 2271 end; 2272 end /* left_parn */; 2273 if ^declare_symbol (SI, local_attributes, type_conflicts, DECLARED) then 2274 call print_message (30, keyword_table (statement_type), SI); 2275 2276 if token = slash then 2277 call parse_data; /* Data spec in mode stmnt. */ 2278 2279 if token ^= comma then 2280 in_list = FALSE; /* If no comma, list is done. */ 2281 end; 2282 2283 /* If data specs generated "nodes" in polish, must indicate how many halfwords are used. */ 2284 if first_word ^= 0 then 2285 polish_string (first_word) = next_free_polish - first_word - 1; 2286 2287 go to parse_done; 2288 2289 2290 /* Case External 2291* 2292*Syntax: 2293* 2294*Polish: 2295* 2296*Notes: 2297**/ 2298 parser (21): 2299 in_list = TRUE; 2300 do while (in_list); 2301 call get_next_token (force_symtab_entry, SI); 2302 if token ^= ident then 2303 go to missing_identifier; 2304 2305 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2306 then 2307 call print_message (140, SI, (keyword_table (statement_type))); 2308 2309 /* In ansi66 mode, builtin functions may be declared in external statements */ 2310 2311 if ^(sub_ptr -> subprogram.options.ansi_77) & (builtin_lookup (SI, NOT_SET)) then do; 2312 if ^declare_symbol (SI, no_attributes, bif_conflicts, DECLARED) then 2313 call print_message (30, keyword_table (statement_type), SI); 2314 if (builtin_lookup (SI, SET_ATTR)) then do; 2315 call get_next_token$operator; 2316 in_list = (token = comma); 2317 end; 2318 end; 2319 else do; 2320 if ^declare_symbol (SI, ext_attributes, ext_conflicts, DECLARED) then 2321 call print_message (30, keyword_table (statement_type), SI); 2322 2323 call get_next_token$operator; /* get comma, left paren, or eos */ 2324 2325 /* the name may optionally be followed by "(descriptors)" */ 2326 2327 if token = left_parn then do; 2328 call get_next_token (ignore_symtab_entry, ignore_value); 2329 /* get "descriptors" */ 2330 if token ^= ident | substr (full_name, 1, symbol_length) ^= "descriptors" then do; 2331 call print_message (044, "descriptors", err_string ()); 2332 go to statement_parse_abort; 2333 end; 2334 2335 call get_next_token$operator; /* get right paren */ 2336 if token ^= right_parn then 2337 go to missing_right_paren; 2338 2339 addr (OS (SI)) -> symbol.needs_descriptors = TRUE; 2340 addr (OS (SI)) -> symbol.variable_arglist = TRUE; 2341 call get_next_token$operator; /* get comma or eos */ 2342 end; 2343 2344 if token ^= comma then 2345 in_list = FALSE; 2346 end; 2347 end; 2348 go to parse_done; 2349 2350 /* Case Intrinsic 2351* 2352*Syntax: [,] where in a builtin function name 2353* 2354*Polish: None 2355* 2356*Notes: Check to see name is not referenced and no declaration conflicts. 2357* 2358**/ 2359 parser (22): 2360 in_list = TRUE; 2361 do while (in_list); 2362 call get_next_token (force_symtab_entry, SI); 2363 if token ^= ident then 2364 goto missing_identifier; 2365 2366 if addr (OS (SI)) -> symbol.referenced /* symbol previously used */ 2367 then 2368 call print_message (140, SI, (keyword_table (statement_type))); 2369 2370 if ^declare_symbol (SI, no_attributes, bif_conflicts, DECLARED) then 2371 call print_message (30, keyword_table (statement_type), SI); 2372 2373 if ^builtin_lookup (SI, SET_ATTR) /* name is not recognized as a builtin */ 2374 then 2375 call print_message (93, SI); 2376 2377 call get_next_token$operator; /* get comma or EOS */ 2378 in_list = (token = comma); 2379 end /* in_list loop */; 2380 goto parse_done; 2381 2382 /* Case Namelist 2383* 2384*Syntax: 2385* 2386*Polish: 2387* 2388*Notes: 2389* Not Audited. 2390**/ 2391 parser (23): 2392 call get_next_token$operator; /* get slash */ 2393 if token ^= slash then 2394 go to missing_slash; 2395 2396 in_stmnt = TRUE; 2397 do while (in_stmnt); 2398 call get_next_token (force_symtab_entry, SI); 2399 if token ^= ident then 2400 go to missing_identifier; 2401 2402 if ^declare_symbol (SI, namelist_attr, all_attributes, DECLARED) then do; 2403 if last_statement_type = statement_type & last_namelist = SI then do; 2404 word_offset = last_namelist_word_offset; 2405 next_free_polish = cur_statement; 2406 cur_statement = last_cur_statement; 2407 end; 2408 else 2409 call print_message (30, keyword_table (statement_type), SI); 2410 end; 2411 else do; 2412 call emit_operator (increment_polish_op); 2413 call emit_count (word_offset); 2414 polish_string (word_offset) = 0; /* count will always be correct */ 2415 addr (OS (SI)) -> symbol.initial = word_offset; 2416 end; 2417 2418 last_namelist = SI; 2419 last_namelist_word_offset = word_offset; 2420 2421 call get_next_token$operator; /* get slash */ 2422 if token ^= slash then 2423 go to missing_slash; 2424 2425 in_list = TRUE; 2426 do while (in_list); 2427 call get_next_token (force_symtab_entry, SI); 2428 if token ^= ident then 2429 go to missing_identifier; 2430 2431 if ^declare_symbol (SI, variable_attributes, variable_conflicts, REF) then 2432 call print_message (10, SI); 2433 2434 call emit_operand (SI); /* list is saved in the polish */ 2435 polish_string (word_offset) = polish_string (word_offset) + 1; 2436 /* keep count accurate */ 2437 2438 call get_next_token$operator; /* get comma, slash, or eos */ 2439 if token ^= comma then 2440 in_list = FALSE; 2441 end; 2442 if token ^= slash then 2443 in_stmnt = FALSE; 2444 end; 2445 go to parse_done; 2446 2447 2448 /* Case Parameter 2449* 2450*Syntax: 2451* 2452*Polish: 2453* 2454*Notes: 2455* Not Audited. 2456**/ 2457 parser (24): 2458 call get_next_token (force_symtab_entry, SI); 2459 in_list = TRUE; 2460 2461 /* To de-implement the old style PARAMETER statement, delete the block of 2462* code at old_parameter_stmt, and replace the following statement with: 2463* 2464* if token ^= left_parn then go to missing_left_paren; 2465* 2466**/ 2467 2468 if token ^= left_parn then 2469 go to old_parameter_statement; 2470 2471 /* New style parameter statement. Using parse_expression, while round-about 2472* insures consistency of expression interpretation with what would be done 2473* at run-time. 2474**/ 2475 2476 parameter_info.start_of_polish = next_free_polish; 2477 2478 do while (in_list); 2479 call get_next_token (force_symtab_entry, SI); 2480 if token ^= ident then 2481 go to missing_identifier; 2482 2483 if ^declare_symbol (SI, named_const_attr, named_const_conflicts, DECLARED) then do; 2484 call print_message (30, "named constant", SI); 2485 SI = 0; /* indicates an error. */ 2486 end; 2487 current_parameter = SI; 2488 2489 call get_next_token$operator; /* get equals */ 2490 if token ^= assign then 2491 go to missing_equals_sign; 2492 2493 call get_next_token (force_symtab_entry, SI); 2494 2495 call parse_expression (any_expression, SI, ignore_bits); 2496 2497 if current_parameter > 0 then do; 2498 call assign_data_type (current_parameter); 2499 2500 param_ptr = addr (OS (current_parameter)); 2501 parameter_info.stack_index = stack_index; 2502 parameter_info.max_stack = max_stack; 2503 parameter_info.desired_data_type = index (string (param_ptr -> symbol.mode), "1"b); 2504 parameter_info.end_of_polish = next_free_polish - 1; 2505 parameter_info.rounding = subr_options.do_rounding; 2506 2507 call fort_eval_parm (addr (parameter_info), (param_ptr -> symbol.name), error_code); 2508 max_stack = parameter_info.max_stack; 2509 2510 if error_code = 0 then do; 2511 2512 /* non-star-extent character parameters require different treatment, since the string must be padded or truncated 2513* or padded with blanks to make it of the declared length */ 2514 2515 if param_ptr -> symbol.mode.character then do; 2516 2517 /* for star extent stuff, set the length to the length of the calculated string, otherwise pad on the right 2518* with blanks or truncated to set to declared length */ 2519 2520 if param_ptr -> symbol.star_extents then do; 2521 param_ptr -> symbol.initial = parameter_info.result_location; 2522 param_ptr -> symbol.star_extents = "0"b; 2523 param_ptr -> symbol.mode_bits.char_size = 2524 addr (OS (parameter_info.result_location)) -> char_constant.length - 1; 2525 end; 2526 else do; 2527 param_ptr -> symbol.initial = 2528 create_char_constant ( 2529 substr (addr (OS (parameter_info.result_location)) -> char_constant.value 2530 || copy (" ", max_char_length), 1, param_ptr -> symbol.mode_bits.char_size + 1)); 2531 end; 2532 end /* character parameters */; 2533 2534 else do; 2535 param_ptr -> symbol.initial = parameter_info.result_location; 2536 end /* non_character params */; 2537 2538 end /* error_code = 0 */; 2539 2540 else do; 2541 param_ptr -> symbol.initial = 0; 2542 end /* non_zero error_codes */; 2543 2544 2545 end; 2546 2547 next_free_polish = parameter_info.start_of_polish; 2548 2549 if token ^= comma then 2550 in_list = FALSE; 2551 end; 2552 2553 if token ^= right_parn then 2554 go to missing_right_paren; 2555 current_token = current_token + 1; /* Skip over the right paren. */ 2556 2557 go to parse_done; 2558 2559 old_parameter_statement: 2560 first_time = TRUE; 2561 2562 do while (in_list); 2563 if ^first_time then 2564 call get_next_token (force_symtab_entry, SI); 2565 first_time = FALSE; 2566 2567 if token ^= ident then 2568 go to missing_identifier; 2569 2570 if ^declare_symbol (SI, named_const_attr, all_attributes, DECLARED) then do; 2571 call print_message (30, "named constant", SI); 2572 SI = 0; /* indicates an error */ 2573 end; 2574 2575 call get_next_token$operator; /* get equals */ 2576 if token ^= assign then 2577 go to missing_equals_sign; 2578 2579 call get_next_token (ignore_symtab_entry, const_index); 2580 /* get constant or sign */ 2581 2582 call parse_a_constant (FALSE, const_index, ignore_octal_value); 2583 /* FALSE= octal is invalid */ 2584 2585 if SI > 0 then 2586 addr (OS (SI)) -> symbol.initial = const_index; 2587 /* store it only if valid */ 2588 2589 call get_next_token$operator; /* get comma or eos */ 2590 if token ^= comma then 2591 in_list = FALSE; 2592 end; 2593 go to parse_done; 2594 2595 2596 /* Case Library 2597* 2598*Syntax: 2599* 2600*Polish: 2601* 2602*Notes: 2603**/ 2604 parser (25): 2605 call get_next_token (ignore_symtab_entry, const_index); 2606 2607 if token ^= char_string then do; 2608 call print_message (53, err_string ()); /* missing char ref */ 2609 go to statement_parse_abort; 2610 end; 2611 2612 if options.compile_only /* If compiling, call our own routine. */ 2613 then 2614 call add_to_lib_list (addr (OS (const_index)) -> char_constant.value, code); 2615 else 2616 call add_to_lib_list_run (addr (OS (const_index)) -> char_constant.value, code); 2617 2618 if code ^= 0 then 2619 call print_message (54); /* illegal pathname */ 2620 current_token = current_token + 1; 2621 go to parse_done; 2622 2623 2624 /* Case Save 2625* 2626*Syntax: | [,] 2627* where save-element is an array-name, a variable-name, or /common-block-name/ 2628* 2629*Polish: None 2630* 2631*Notes: This statement serves to set the save attributes for a symbol. 2632**/ 2633 parser (26): /* Save statements and automatic statements cannot co-exist in a program unit. */ 2634 if have_auto_stmnt then do; 2635 call print_message (38); 2636 go to statement_parse_abort; 2637 end; 2638 2639 /* If there is no list, this is a global save statement. */ 2640 2641 if current_token >= last_token then do; 2642 if have_save_stmnt then 2643 call print_message (33); /* global save must be only save stmnt */ 2644 else 2645 sub_ptr -> default_is.static = TRUE; 2646 2647 have_save_stmnt = TRUE; 2648 2649 current_token = current_token + 1; 2650 go to parse_done; 2651 end; 2652 2653 /* Particular save statement may not follow global one. */ 2654 2655 if sub_ptr -> default_is.static then 2656 call print_message (33); /* global save statement already encountered */ 2657 else 2658 sub_ptr -> default_is.auto = TRUE; 2659 2660 have_save_stmnt = TRUE; 2661 2662 /* Parse list of variable names. */ 2663 2664 in_list = TRUE; 2665 do while (in_list); 2666 call get_next_token (force_symtab_entry, SI); 2667 2668 /* if this is a common-block-name, add a header if not there already. header.first_element will be zero */ 2669 2670 if token = slash then do; 2671 call get_next_token (ignore_symtab_entry, ignore_value); 2672 if token ^= ident then 2673 goto missing_identifier; 2674 common_name = substr (full_name, 1, symbol_length); 2675 not_found = TRUE; 2676 indx = sub_ptr -> common_chain; 2677 2678 do while (indx ^= 0 & not_found); 2679 if substr (addr (OS (indx)) -> header.block_name, 1, symbol_length) = common_name then 2680 not_found = FALSE; 2681 else 2682 indx = addr (OS (indx)) -> header.next_header; 2683 end /* search loop for common-block-name */; 2684 2685 /* if not found, then add the header to the end of the chain of headers (or to the start if this is the first header). */ 2686 2687 if not_found then do; 2688 SI = build_common_block (common_name); 2689 if sub_ptr -> common_chain = 0 then 2690 sub_ptr -> common_chain = SI; 2691 else 2692 addr (OS (indx)) -> header.next_header = SI; 2693 end; 2694 call get_next_token$operator; 2695 if token ^= slash then 2696 goto missing_slash; 2697 end; 2698 else if token ^= ident then 2699 go to missing_identifier; 2700 2701 else do; 2702 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2703 then 2704 call print_message (140, SI, (keyword_table (statement_type))); 2705 2706 if ^declare_symbol (SI, save_attributes, save_conflicts, DECLARED) then 2707 call print_message (30, keyword_table (statement_type), SI); 2708 end; 2709 call get_next_token$operator; /* get comma or eos */ 2710 if token ^= comma then 2711 in_list = FALSE; 2712 end; 2713 go to parse_done; 2714 2715 2716 /* Case Automatic 2717* 2718*Syntax: 2719* 2720*Polish: non_executable {increment_polish_op} 2721* 2722*Notes: 2723* Not audited. 2724**/ 2725 parser (27): /* save and automatic statements cannot co-exist in a single program unit */ 2726 if have_save_stmnt then do; 2727 call print_message (38); 2728 go to statement_parse_abort; 2729 end; 2730 2731 have_auto_stmnt = TRUE; 2732 sub_ptr -> default_is.static = TRUE; 2733 2734 2735 in_list = TRUE; 2736 do while (in_list); /* Loop thru variable list. */ 2737 call get_next_token (force_symtab_entry, SI);/* Get variable name. */ 2738 if token ^= ident then 2739 go to missing_identifier; 2740 2741 if addr (OS (SI)) -> symbol.referenced /* Symbol has already been used */ 2742 then 2743 call print_message (140, SI, (keyword_table (statement_type))); 2744 2745 if ^declare_symbol (SI, auto_attribute, save_conflicts, DECLARED) then 2746 call print_message (30, keyword_table (statement_type), SI); 2747 2748 call stack_operand (SI); /* Stack it in case of data specifications. */ 2749 2750 call get_next_token$operator; /* Get left paren or comma. */ 2751 2752 if token = left_parn then 2753 call get_bounds (SI); /* Declaring bounds in automatic stmnt. */ 2754 2755 if token ^= comma then 2756 in_list = FALSE; /* If no comma, list is done. */ 2757 end; 2758 2759 go to parse_done; 2760 2761 2762 /* Case Statement Function Definition 2763* 2764*Syntax: 2765* 2766*Polish: 2767* 2768*Notes: 2769* label_ptr set in parse loop to point to stmnt's label node 2770* SI st func name 2771* indx arg as provided by user 2772* new arg used by compiler 2773* old previous member of hash chain for indx 2774**/ 2775 parser (28): 2776 saved_number_of_crefs = number_of_crefs; 2777 2778 call get_next_token (force_symtab_entry, SI); 2779 if token ^= ident then 2780 go to missing_identifier; 2781 2782 if token_list (current_token + 1).type = left_parn & ^COLON_BEFORE_ASSIGN then 2783 if declare_symbol (SI, asf_attribute, asf_conflicts, DECLARED) then do; 2784 2785 profile_size = profile_size + 1; /* profile entry required by this statement */ 2786 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 2787 2788 current_token = current_token + 1; 2789 2790 /* The statement function definition (sfd) will now be placed in the polish string 2791* using the expression parser. The fields, symbol.initial and symbol.dimension, 2792* are used to store the offset of the first word of the sfd and the offset of 2793* the first word after the sfd. If the sf is not referenced, these values are 2794* used to "remove" the sfd from the polish string. */ 2795 2796 addr (OS (SI)) -> symbol.initial = next_free_polish; 2797 /* offset of first word. */ 2798 2799 call emit_operand (SI); 2800 call emit_operator (sf_def_op); 2801 last_element = 0; 2802 count = 0; 2803 2804 /* if the next token is a right_paren, then an empty arg list, no need to scan */ 2805 in_list = (token_list (current_token + 1).type ^= right_parn); 2806 if ^in_list then 2807 call get_next_token$operator; 2808 2809 do while (in_list); 2810 call get_next_token (locate_symtab_entry, indx); 2811 if token ^= ident then 2812 go to missing_identifier; 2813 2814 count = count + 1; 2815 2816 if indx = 0 then 2817 call find_symbol_index (symbol_length, new, force_symtab_entry, old); 2818 else do; 2819 call find_symbol_index (symbol_length, indx, force_symtab_entry, old); 2820 new = build_symbol (substr (full_name, 1, symbol_length), 2821 unspec (addr (OS (indx)) -> symbol.mode_bits), DECLARED); 2822 addr (OS (new)) -> symbol.hash_chain = indx; 2823 2824 if old > hbound (hash_table, 1) then 2825 addr (OS (old)) -> symbol.hash_chain = new; 2826 else 2827 hash_table (old) = new; 2828 end; 2829 2830 if ^declare_symbol (new, auto_attribute, variable_conflicts, DECLARED) then 2831 call print_message (30, keyword_table (statement_type), new); 2832 /* conflicting attr. */ 2833 2834 addr (OS (new)) -> symbol.parent = old; 2835 addr (OS (new)) -> symbol.general = last_element; 2836 2837 addr (OS (new)) -> symbol.by_compiler = TRUE; 2838 /* flag as special symbol */ 2839 addr (OS (new)) -> symbol.dummy_arg = TRUE; 2840 /* flag as stmnt func param */ 2841 2842 if last_element = 0 then 2843 addr (OS (SI)) -> symbol.next_member = new; 2844 else 2845 addr (OS (last_element)) -> symbol.next_member = new; 2846 last_element = new; 2847 2848 call get_next_token$operator; /* get comma or right paren */ 2849 if token ^= comma then 2850 in_list = FALSE; 2851 end; 2852 if token ^= right_parn then 2853 go to missing_right_paren; 2854 2855 call get_next_token$operator; /* get equals */ 2856 if token ^= assign then 2857 go to missing_equals_sign; 2858 2859 call get_next_token (force_symtab_entry, indx); 2860 call parse_expression (any_expression, indx, ignore_bits); 2861 2862 do i = last_element repeat addr (OS (i)) -> symbol.general while (i ^= 0); 2863 if ^addr (OS (i)) -> symbol.referenced 2864 /* Check for unused parameter. */ 2865 then do; 2866 addr (OS (i)) -> symbol.allocate = TRUE; 2867 call print_message (68, i, SI); 2868 end; 2869 2870 old = addr (OS (i)) -> symbol.parent; 2871 2872 if old > hbound (hash_table, 1) then 2873 addr (OS (old)) -> symbol.hash_chain = addr (OS (i)) -> symbol.hash_chain; 2874 else 2875 hash_table (old) = addr (OS (i)) -> symbol.hash_chain; 2876 2877 addr (OS (i)) -> symbol.parent = SI; 2878 end; 2879 2880 call emit_operator (exit_op); 2881 2882 addr (OS (SI)) -> symbol.dimension = next_free_polish; 2883 /* offset of 1st word after sfd */ 2884 2885 if count > 511 then do; 2886 call print_message (55, 511 - bias); 2887 /* implementation restriction */ 2888 count = 511; 2889 end; 2890 2891 addr (OS (SI)) -> symbol.char_size = count; 2892 2893 go to parse_done; 2894 end; 2895 2896 /* Control passes this point only if the statement cannot be an asf def. Stmnt becomes an assignment. */ 2897 2898 call finish_sf_defs; /* End of sf defs. Emit by-pass label. */ 2899 2900 /* Process all pending entries now. */ 2901 if pending_entry_cnt > 0 then 2902 call process_pending_entries; 2903 2904 current_token = first_token - 1; 2905 number_of_crefs = saved_number_of_crefs; 2906 2907 if statement_label ^= 0 then do; 2908 string (addr (OS (statement_label)) -> label.usage) = executable_label; 2909 call emit_operand (statement_label); 2910 call emit_operator (label_op); 2911 end; 2912 2913 statement_type = assignment_statement; 2914 keyword_index = first_keyword (assignment_statement); 2915 2916 /* assignment statement parse code must follow. */ 2917 2918 2919 /* Case Assignment 2920* 2921*Syntax: 2922* 2923*Polish: 2924* 2925*Notes: 2926**/ 2927 parser (60): 2928 profile_size = profile_size + 1; /* profile entry required by this statement */ 2929 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 2930 2931 call get_next_token (force_symtab_entry, SI); 2932 2933 /* test for the assignment being to the typeless function "fld". This is the 2934*only builtin function that can appear on the left hand side of an equal sign */ 2935 2936 if (addr (OS (SI)) -> symbol.name = "fld" & ^addr (OS (SI)) -> symbol.dimensioned 2937 & token_list (current_token + 1).type = left_parn & ^addr (OS (SI)) -> symbol.mode.character) then do; 2938 call get_next_token (force_symtab_entry, SI);/* swallow left paren */ 2939 call get_next_token (force_symtab_entry, SI); 2940 do i = 1 to 2; 2941 call parse_expression (any_expression, SI, ignore_bits); 2942 if token ^= comma then 2943 go to missing_comma; 2944 call get_next_token (force_symtab_entry, SI); 2945 end; 2946 call parse_expression (set_reference, SI, ignore_bits); 2947 if token ^= right_parn then 2948 go to missing_right_paren; 2949 call get_next_token (force_symtab_entry, SI); 2950 if token ^= assign then 2951 go to missing_equals_sign; 2952 call get_next_token (force_symtab_entry, SI); 2953 call parse_expression (any_expression, SI, ignore_bits); 2954 call emit_operator (lhs_fld_op); 2955 go to parse_done; 2956 end; 2957 call parse_expression (set_reference, SI, ignore_bits); 2958 if token ^= assign then 2959 go to missing_equals_sign; 2960 2961 call get_next_token (force_symtab_entry, SI); 2962 call parse_expression (any_expression, SI, ignore_bits); 2963 call emit_operator (assign_op); 2964 go to parse_done; 2965 2966 /* Case Elseif 2967* 2968*Syntax: elseif then 2969* 2970*Polish: 2971* 2972*Notes: Must check for proper nesting, but in most ways this is much like 2973*the parsing of block if's, so we parse it the same way. A new statement is 2974*created for the logical expression and else_if_op for the benefit of profiling 2975*and setting breakpoints. 2976* 2977**/ 2978 2979 parser (30): /* this stmnt NOT in profile or map */ 2980 call emit_operator (item_op); /* elseif's terminate previous block ifs */ 2981 call emit_statement_op (cur_stmnt_ptr); /* make new statement for if part */ 2982 /* fall through to if parser */ 2983 2984 /* Case If 2985* 2986*Syntax: if 2987* ::= 2988* ::= 2989* ::= then 2990* 2991*Polish: 2992* 2993*Notes: 2994**/ 2995 2996 parser (29): 2997 profile_size = profile_size + 1; /* profile entry required by this statement */ 2998 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 2999 3000 /* Parse if statement expression. */ 3001 3002 call get_next_token$operator; /* Get left paren. */ 3003 if token ^= left_parn then 3004 go to missing_left_paren; 3005 3006 call get_next_token (force_symtab_entry, SI); /* Get first token of expression. */ 3007 call parse_expression (any_expression, SI, ignore_bits); 3008 if token ^= right_parn then 3009 go to missing_right_paren; 3010 3011 call get_next_token (ignore_symtab_entry, ignore_value); 3012 /* Get integer, comma, or statement keyword. */ 3013 3014 /* Arithmetic-if statement if integer or comma, and not an ELSEIF. */ 3015 3016 if statement_type ^= elseif_statement & (token = dec_int | token = comma) then do; 3017 if END_DO_RANGE & ^logical_if_statement then 3018 call print_message (16, keyword_table (statement_type)); 3019 /* cannot terminate do loop */ 3020 3021 /* Parse three target labels. */ 3022 3023 do i = 1 to 3; 3024 if token = dec_int /* label is given */ 3025 then do; 3026 call emit_operand (enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF)); 3027 call get_next_token$operator; /* get comma or eos */ 3028 end; 3029 3030 else if token = comma | token = EOS_token 3031 /* label is omitted */ 3032 then do; 3033 must_have_label = FALSE; 3034 call emit_count (ignore_value); 3035 end; 3036 3037 else 3038 go to missing_label; /* syntax error */ 3039 3040 /* Commas must appear between the labels, even if the labels are omitted. */ 3041 3042 if i < 3 then do; 3043 if token ^= comma then 3044 go to missing_comma; 3045 3046 call get_next_token$label (ignore_symtab_entry, ignore_value); 3047 end; 3048 end; 3049 call emit_operator (jump_arithmetic_op); 3050 go to parse_done; 3051 end; 3052 3053 /* Parse logical-if, block-if, and else-if statements. */ 3054 3055 if logical_if_statement then 3056 call print_message (42, "logical if"); /* illegal second statement */ 3057 3058 /* distinguish between logical if's and (block if's and else if's) */ 3059 3060 logical_if_statement = 3061 statement_type ^= elseif_statement & (SECOND_EQUALS | substr (full_name, 1, token_length) ^= "then"); 3062 must_have_label = FALSE; 3063 3064 if logical_if_statement then do; 3065 if SECOND_EQUALS then 3066 statement_type = assignment_statement; 3067 else 3068 call statement_lex$recognize_statement (statement_type); 3069 /* Get second stmnt type. */ 3070 3071 call emit_operator (jump_logical_op); 3072 3073 if ^ok_second_statement (statement_type) then 3074 call print_message (42, keyword_table (statement_type)); 3075 /* illegal second statement */ 3076 3077 /* Now process the second statement. In order to make the profile option work usefully, a second 3078* stat_op will be generated in the polish. This allows separated counts for the if statement and 3079* its then clause. */ 3080 3081 call emit_statement_op (cur_stmnt_ptr); 3082 3083 profile_size = profile_size + 1; /* profile entry required by this statement */ 3084 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3085 3086 current_token = current_token - 1; /* Backup lex for all parsers. */ 3087 go to parser (statement_type); 3088 end /* logical_if_statement */; 3089 3090 else do; /* else if and block if */ 3091 if END_DO_RANGE then 3092 call print_message (16, keyword_table (statement_type)); 3093 3094 if substr (full_name, 1, token_length) ^= "then" 3095 /* required keyword */ 3096 then 3097 call print_message (179, "then", keyword_table (statement_type)); 3098 3099 else if statement_type = elseif_statement then do; 3100 current_token = current_token + 1; 3101 3102 /* elseif must be nested in blockif's not do loops, peel off erroneous do's */ 3103 3104 do do_index = do_index to 1 by -1 while (do_blockif_stack (do_index).do_loop); 3105 call print_message (182, do_blockif_stack (do_index).label_ptr, keyword_table (statement_type)); 3106 end; 3107 3108 if do_index = 0 /* insure that elseif follows a if at same level */ 3109 then 3110 call print_message (180, keyword_table (statement_type)); 3111 3112 else if do_blockif_stack (do_index).else_seen 3113 /* cant follow else on same level */ 3114 then 3115 call print_message (181, keyword_table (statement_type)); 3116 3117 else do; 3118 call emit_operator (else_if_op); 3119 do_blockif_stack (do_index).clauses = do_blockif_stack (do_index).clauses + 1; 3120 end; 3121 end; 3122 else do; 3123 if do_index = hbound (do_blockif_stack, 1) 3124 /* stack oflo */ 3125 then 3126 call print_message (27, hbound (do_blockif_stack, 1) - bias); 3127 else do; /* block if */ 3128 current_token = current_token + 1; 3129 call emit_count (word_offset); 3130 call emit_operator (block_if_op); 3131 3132 /* pop up the do_blockif_stack and set values */ 3133 3134 do_index = do_index + 1; 3135 do_blockif_stack (do_index).do_loop = "0"b; 3136 do_blockif_stack (do_index).clauses = 1; 3137 do_blockif_stack (do_index).line_number = line_number - 1; 3138 do_blockif_stack (do_index).count_op = word_offset; 3139 do_blockif_stack (do_index).else_seen = "0"b; 3140 end; 3141 end; 3142 end /* block_if and else if */; 3143 goto parse_done; 3144 3145 /* Case Else 3146* 3147*Syntax: else 3148* 3149*Polish: 3150* 3151*Notes: An else clause if valid iff it exists within a block_if and is nested properly 3152* within the do_blockif_stack, nor can it be the object of a GOTO . 3153**/ 3154 /* Case Endif 3155* 3156*Syntax: endif 3157* 3158*Polish: 3159* 3160*Notes: In addition to checking for the nesting of the block_if's and the do loops, the endif 3161* must also properly set the count in the count_op emitted by the block_if 3162**/ 3163 3164 parser (31): 3165 parser (32): 3166 profile_size = profile_size + 1; /* profile entry required by these statements */ 3167 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3168 current_token = current_token + 1; 3169 3170 if END_DO_RANGE then 3171 call print_message (16, keyword_table (statement_type)); 3172 3173 do do_index = do_index to 1 by -1 while (do_blockif_stack (do_index).do_loop); 3174 call print_message (182, do_blockif_stack (do_index).label_ptr, keyword_table (statement_type)); 3175 end; 3176 3177 if do_index = 0 /* nesting check */ 3178 then 3179 call print_message (180, keyword_table (statement_type)); 3180 3181 else if statement_type = else_statement then do; 3182 if do_blockif_stack (do_index).else_seen /* cant have > 1 else at same level */ 3183 then 3184 call print_message (181, keyword_table (statement_type)); 3185 else do; 3186 call emit_operator (item_op); 3187 call emit_operator (else_op); 3188 do_blockif_stack (do_index).clauses = do_blockif_stack (do_index).clauses + 1; 3189 do_blockif_stack (do_index).else_seen = "1"b; 3190 end; 3191 end; 3192 3193 else do; /* endif statement */ 3194 call emit_operator (item_op); 3195 call emit_operator (eol_op); 3196 3197 /* having come to the end of the blockif, set count operator reserved by the block if and pop stack */ 3198 3199 polish_string (do_blockif_stack (do_index).count_op) = do_blockif_stack (do_index).clauses - bias; 3200 do_index = do_index - 1; 3201 end; 3202 3203 goto parse_done; 3204 3205 /* Case Goto 3206* 3207*Syntax: 3208* 3209*Polish: 3210**/ 3211 parser (33): 3212 profile_size = profile_size + 1; /* profile entry required by this statement */ 3213 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3214 3215 if END_DO_RANGE & ^logical_if_statement then 3216 call print_message (16, keyword_table (statement_type)); 3217 /* cannot terminate do loop */ 3218 3219 /* First token of statement determines type of goto. */ 3220 3221 call get_next_token$label (force_symtab_entry, SI); 3222 /* Get label, name, or left paren. */ 3223 3224 if token = dec_int /* UNCONDITIONAL GOTO */ 3225 then do; 3226 call emit_operand (enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF)); 3227 call emit_operator (jump_op); 3228 current_token = current_token + 1; 3229 end; 3230 3231 else if token = ident /* ASSIGNED GOTO */ 3232 then do; 3233 if token_list (current_token + 1).type ^= left_parn then do; 3234 call parse_expression (simple_reference, SI, out); 3235 3236 if addr (out) -> expression.not_simple_ref 3237 /* must check result ourselves */ 3238 then 3239 call print_message (143, SI); 3240 end; 3241 else do; /* Let parse expression do its trick */ 3242 token_list (current_token + 1).type = comma; 3243 /* Tell a white lie */ 3244 call parse_expression (simple_reference, SI, out); 3245 if addr (out) -> expression.not_simple_ref then 3246 call print_message (143, SI); 3247 token, token_list (current_token).type = left_parn; 3248 end; 3249 3250 call emit_operator (jump_assigned_op); 3251 3252 if token = comma then do; 3253 call get_next_token$operator; /* get left paren */ 3254 if token ^= left_parn then 3255 go to missing_left_paren; 3256 end; 3257 3258 if token = left_parn then do; 3259 call scan_label_list (FALSE); /* Returns pointing to right paren. */ 3260 current_token = current_token + 1; 3261 end; 3262 end; 3263 3264 else if token = left_parn /* COMPUTED GOTO */ 3265 then do; 3266 call scan_label_list (TRUE); /* Returns pointing to right paren. */ 3267 call get_next_token (force_symtab_entry, SI); 3268 if token = comma then 3269 call get_next_token (force_symtab_entry, SI); 3270 call parse_expression (any_expression, SI, ignore_bits); 3271 call emit_operator (exit_op); 3272 must_have_label = FALSE; /* label not required after computed goto */ 3273 end; 3274 3275 else do; /* syntax error */ 3276 call print_message (41, err_string ()); /* missing int, ident, or left paren */ 3277 go to statement_parse_abort; 3278 end; 3279 go to parse_done; 3280 3281 3282 /* Case Call 3283* 3284*Syntax: [ ( [ ] ) ] 3285* 3286*Polish: [ ] 3287* 3288*Notes: 3289* SI passes output from get_next_token to parse_expr 3290**/ 3291 parser (34): 3292 profile_size = profile_size + 1; /* profile entry required by this statement */ 3293 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3294 3295 call get_next_token (force_symtab_entry, SI); /* Get subroutine name. */ 3296 if token ^= ident then 3297 go to missing_identifier; 3298 3299 if ^declare_symbol (SI, subroutine_reference, subroutine_conflicts, REF) then 3300 call print_message (21, SI); 3301 3302 /* if the arg list contains label constants, must initialize alt ret value */ 3303 3304 if label_args then do; 3305 if alternate_return_index = 0 /* first ref so create it */ 3306 then 3307 alternate_return_index = build_symbol ((NO_NAME), auto_attribute | attr_table (int_mode), PASSED); 3308 3309 call emit_operand (alternate_return_index); 3310 call emit_operand (value_0); 3311 call emit_operator (assign_op); 3312 end; 3313 3314 /* emit polish for a call statement */ 3315 3316 call emit_operand (SI); 3317 call emit_count (word_offset); 3318 call emit_operator (call_op); 3319 3320 /* parse the argument list */ 3321 3322 call get_next_token$operator; /* Get left paren or eos. */ 3323 3324 if token = left_parn then do; 3325 count = 0; 3326 3327 if addr (OS (SI)) -> symbol.needs_descriptors then 3328 arg_type = darg_list_expr; 3329 else 3330 arg_type = arg_list_expr; 3331 3332 in_list = (token_list (current_token + 1).type ^= right_parn); 3333 if ^in_list then 3334 call get_next_token$operator; 3335 3336 do while (in_list); 3337 call get_next_token (force_symtab_entry, indx); 3338 /* Get next argument. expression or label const */ 3339 3340 if token = label_const then do; 3341 call stack_operand (indx); 3342 call get_next_token$operator; /* get comma or right paren */ 3343 end; 3344 else do; 3345 call parse_expression (arg_type, indx, ignore_bits); 3346 call emit_operator (item_op); 3347 count = count + 1; 3348 end; 3349 3350 if token ^= comma then 3351 in_list = FALSE; 3352 end; 3353 3354 if token ^= right_parn then 3355 go to missing_right_paren; 3356 current_token = current_token + 1; /* skip over paren */ 3357 3358 /* if there are label args, include alt ret value in arg list */ 3359 3360 if label_args then do; 3361 call emit_operand (alternate_return_index); 3362 call emit_operator (item_op); 3363 count = count + 1; 3364 end; 3365 3366 /* check number of arguments and update count word */ 3367 3368 if count > max_arglist then 3369 call print_message (138, max_arglist - bias, SI); 3370 3371 polish_string (word_offset) = count - bias; 3372 end; 3373 3374 call emit_operator (eol_op); /* terminate call arg list */ 3375 3376 /* alternate return is implemented as computed goto */ 3377 3378 if stack_index - stack_base > 0 then do; 3379 call emit_halfword ((stack_index - stack_base) - bias); 3380 /* count of labels */ 3381 call emit_operator (jump_computed_op); 3382 3383 do i = stack_base to stack_index - 1; /* copy the labels into the polish */ 3384 call emit_operand (stack (i)); 3385 call emit_operator (item_op); 3386 end; 3387 call emit_operator (eol_op); /* end of the list */ 3388 3389 call emit_operand (alternate_return_index); /* computed goto expression */ 3390 call emit_operator (exit_op); /* end of expression */ 3391 end; 3392 go to parse_done; 3393 3394 3395 /* Case Continue 3396* 3397*Syntax: 3398* 3399*Polish: 3400* 3401*Notes: 3402**/ 3403 parser (35): 3404 profile_size = profile_size + 1; /* profile entry required by this statement */ 3405 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3406 3407 current_token = current_token + 1; 3408 go to parse_done; 3409 3410 3411 /* Case Write 3412* 3413*Syntax: 3414* 3415*Polish: 3416* 3417*Notes: 3418**/ 3419 parser (36): 3420 profile_size = profile_size + 1; /* profile entry required by this statement */ 3421 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3422 3423 call parse_io (FALSE); 3424 go to parse_done; 3425 3426 3427 /* Case Format 3428* 3429*Syntax: 3430* 3431*Polish: 3432* 3433*Notes: 3434**/ 3435 parser (37): 3436 if statement_label = 0 then 3437 call print_message (37); /* format statement without label */ 3438 3439 call create_format (format_string, statement_label); 3440 current_token = last_token + 1; 3441 go to parse_done; 3442 3443 3444 /* Case Data 3445* 3446*Syntax: 3447* 3448*Polish: 3449* 3450*Notes: 3451* The stack is built up with a series of "nodes", which are then interpreted by parse_data as it works its way 3452* through the list of data elements. The first word of each node determines what type of node it is. A node may 3453* be any of the following: 3454* 3455* (1) a scalar variable node, which corresponds to the appearance of a scalar variable in the target list. 3456* It consists of a single word containing the index of the symbol node of the variable. 3457* 3458* (2) an array name node, which corresponds to the appearance of an array name in the target list. It 3459* consists of a single word containing the index of the symbol node of the array. 3460* 3461* (3) a BEGIN_DO_LOOP node, which corresponds to the start of an implied do-loop in the target list. It 3462* consists of 8 or more words. The first word contains BEGIN_DO_LOOP, the code for this type of node. The 3463* second word contains the index of the symbol node for the index variable of the loop. The remaining words 3464* contain the Polish for the initial, final and increment expressions of the loop. The first word of each 3465* expression is not part of the Polish, but rather the count of the number of following words which are the 3466* Polish. The Polish is slightly nonstandard in that a variable (which must be an index of a containing 3467* implied loop) is represented by a negative value whose absolute value is the index in the stack of the 3468* symbol node index of the BEGIN_DO_LOOP node for the implied loop having the variable as its index. (Note 3469* that 'parse_data' will keep the current value of the loop index in that same location.) 3470* 3471* (4) an END_DO_LOOP node, which corresponds to the end of an implied do-loop in the target list. It 3472* consists of a single word containing END_DO_LOOP, the code for this type of node. 3473* 3474* (5) a SUBSTRING node, which corresponds to a substring of a variable in the target list. It consists 3475* of 6 or more words. The first contains SUBSTR, the code for this type of node. The second contains 3476* the index of the symbol node for the variable. The remaining words contain the Polish (in the same 3477* format as the expressions in a BEGIN_DO_LOOP node) for the start and finish positions of the substring. 3478* 3479* (6) a SUBSCRIPTED_VAR node, which corresponds to a subscripted variable in the target list. It 3480* consists of 6 or more words. The first contains SUBSCRIPTED_VAR, the code for this type of node. 3481* The second contains the index of the symbol node for the variable. The remaining words contain the 3482* Polish for the subscript expressions, in the same format as the expressions in a BEGIN_DO_LOOP node. 3483* 3484* (7) a SUBSCRIPTED_SUBSTR node, which corresponds to a substring of a subscripted variable in the target 3485* list. It consists of 10 or more words. The first contains SUBSCRIPTED_SUBSTR, the code for this type 3486* of node. The second contains the index of the symbol node for the variable. The remaining words contain 3487* the Polish for the subscript expressions, followed by the Polish for the start and finish positions of the 3488* substring. 3489* 3490* (8) a SKIP node, which corresponds to a substring, subscripted variable or subscripted substring 3491* in the target list in which an error was detected. It consists of a single word containing SKIP, 3492* the code for this type of node. 3493* 3494* Note that the codes for node types (3) through (8) above are less than or equal to zero so that they can be 3495* distinguished from node types (1) and (2), which are always positive. 3496**/ 3497 parser (38): 3498 first_word = 0; /* No "nodes" generated by data specs. */ 3499 last_paren_parsed = 0; /* indicates no pre-scan has occurred */ 3500 3501 /* Parse each set of variables and constants separately. */ 3502 3503 in_stmnt = TRUE; 3504 do while (in_stmnt); 3505 3506 do_level = 0; /* no implied do loops encountered */ 3507 last_do = 0; /* ditto */ 3508 3509 /* Parse variables, subscripted references, and implied do loops. */ 3510 3511 in_list = TRUE; 3512 do while (in_list); 3513 3514 /* Parse left paren or variable. */ 3515 3516 call get_next_token (force_symtab_entry, SI); 3517 3518 /* left paren must delimit an implied do loop */ 3519 3520 if token = left_parn then 3521 if is_implied_loop () then do; 3522 save_current_token = current_token; 3523 /* remember current token position */ 3524 current_token = paren_info (cur_paren).begin_index; 3525 /* move up to loop code */ 3526 3527 call stack_operator (BEGIN_DO_LOOP); 3528 /* stack begin loop operator */ 3529 if do_level = hbound (do_info, 1) then do; 3530 call print_message (89, hbound (do_info, 1) - bias); 3531 /* do loop nesting is too deep */ 3532 go to statement_parse_abort; 3533 end; 3534 else 3535 do_info (do_level + 1) = stack_index; 3536 /* stack pointer to do loop info */ 3537 3538 /* process new do loop index variable */ 3539 3540 call get_next_token (force_symtab_entry, indx); 3541 if token ^= ident then 3542 go to missing_identifier; 3543 3544 do i = 1 to do_level; /* check for reused index variable */ 3545 if stack (do_info (i)) = indx then do; 3546 call print_message (18, indx); 3547 /* reused loop index */ 3548 go to statement_parse_abort; 3549 end; 3550 end; 3551 3552 call stack_operand (indx); /* stack loop index variable */ 3553 3554 /* index must be scalar integer variable */ 3555 3556 if addr (OS (indx)) -> symbol.dimensioned then 3557 call print_message (141, indx); 3558 else if (unspec (addr (OS (indx)) -> symbol.attributes) & scalar_conflicts) ^= ZERO then 3559 call print_message (141, indx); 3560 else do; 3561 call assign_data_type (indx); 3562 if ^addr (OS (indx)) -> symbol.integer then 3563 call print_message (141, indx); 3564 end; 3565 3566 call get_next_token$operator; 3567 3568 /* get equals */ 3569 if token ^= assign then 3570 go to missing_equals_sign; 3571 3572 /* Get and stack the initial, final and increment expressions. */ 3573 start_of_expression = stack_index; 3574 call get_data_statement_expression; 3575 if stack (start_of_expression) = 0 then 3576 goto statement_parse_abort; 3577 if token ^= comma then 3578 go to missing_comma; 3579 start_of_expression = stack_index; 3580 call get_data_statement_expression; 3581 if stack (start_of_expression) = 0 then 3582 goto statement_parse_abort; 3583 if token = comma then do; 3584 start_of_expression = stack_index; 3585 call get_data_statement_expression; 3586 if stack (start_of_expression) = 0 then 3587 goto statement_parse_abort; 3588 end; 3589 else do; /* Assume increment of 1. */ 3590 call stack_operand (1); 3591 call stack_operand (value_1); 3592 end; 3593 3594 if token ^= right_parn then 3595 go to missing_right_paren; 3596 3597 paren_info (cur_paren).position = current_token; 3598 /* remember end of loop code */ 3599 current_token = save_current_token; 3600 /* restore scan to proper position */ 3601 3602 last_do = cur_paren; 3603 do_level = do_level + 1; /* put this implied loop on stack */ 3604 end /* is implied do_loop */; 3605 3606 else do /* not implied do_loop */; 3607 call print_message (34); /* syntax error in do loop */ 3608 go to statement_parse_abort; 3609 end; 3610 3611 else do /* not a left_parn */; 3612 if token ^= ident then 3613 go to missing_identifier; 3614 3615 call get_next_token$paren_operator;/* Get left paren, comma, or slash. */ 3616 3617 /* Stack variable, substring, subscripted variable, or subscripted substring reference. */ 3618 3619 symp = addr (OS (SI)); 3620 if token = left_parn | token = substr_left_parn then do; 3621 /* substr, subscripted variable or subscripted substring */ 3622 error = FALSE; 3623 start_of_node = stack_index; 3624 if token = substr_left_parn then do; 3625 call stack_operand (SUBSTR); 3626 call stack_operand (SI); 3627 end; 3628 else do; 3629 call stack_operand (SUBSCRIPTED_VAR); 3630 call stack_operand (SI); 3631 dp = null; 3632 number_of_dims, number_of_subs = 0; 3633 if ^symp -> symbol.dimensioned then do; 3634 call print_message (76, SI); 3635 error = TRUE; 3636 end; 3637 else if symp -> symbol.variable_extents then do; 3638 call print_message (77, SI); 3639 error = TRUE; 3640 end; 3641 else do; 3642 dp = addr (OS (symp -> symbol.dimension)); 3643 number_of_dims = dp -> dimension.number_of_dims; 3644 end; 3645 3646 have_subscript = TRUE; 3647 do while (have_subscript); 3648 number_of_subs = number_of_subs + 1; 3649 start_of_expression = stack_index; 3650 call get_data_statement_expression; 3651 if stack (start_of_expression) = 0 then 3652 error = TRUE; 3653 else if number_of_subs <= number_of_dims & stack (start_of_expression) = 1 3654 & stack (start_of_expression + 1) > last_assigned_op then do; 3655 /* Verify constant subscript is in range. */ 3656 subscript = 3657 addr (addr (OS (stack (start_of_expression + 1))) -> constant.value) 3658 -> based_integer; 3659 if subscript < dp -> dimension.lower_bound (number_of_subs) then do; 3660 call print_message (78, subscript - bias, "lower", SI); 3661 error = TRUE; 3662 end; 3663 else if subscript > dp -> dimension.upper_bound (number_of_subs) then do; 3664 call print_message (78, subscript - bias, "upper", SI); 3665 error = TRUE; 3666 end; 3667 end; 3668 if token ^= comma then 3669 have_subscript = FALSE; 3670 end; 3671 if token ^= right_parn then 3672 goto missing_right_paren; 3673 if number_of_subs ^= number_of_dims & number_of_dims ^= 0 then do; 3674 call print_message (79, SI, "the wrong number of"); 3675 error = TRUE; 3676 end; 3677 call get_next_token$paren_operator; 3678 /* Next token must be an operator. */ 3679 end; 3680 if token = substr_left_parn then do; 3681 /* Parse substring start and finish. */ 3682 if stack (start_of_node) = SUBSCRIPTED_VAR then 3683 stack (start_of_node) = SUBSCRIPTED_SUBSTR; 3684 if ^subr_options.ansi_77 then do; 3685 call print_message (154); 3686 error = TRUE; 3687 end; 3688 if symp -> symbol.character then 3689 char_siz = symp -> symbol.char_size + 1; 3690 else do; 3691 char_siz = 0; 3692 call print_message (159, SI); 3693 error = TRUE; 3694 end; 3695 3696 inx = 1; 3697 if token_list (current_token + 1).type = colon then do; 3698 call stack_operand (1); 3699 call stack_operand (value_1); 3700 end; 3701 else do; 3702 start_of_expression = stack_index; 3703 call get_data_statement_expression; 3704 if token ^= colon then do; 3705 call print_message (102, err_string ()); 3706 goto statement_parse_abort; 3707 end; 3708 if stack (start_of_expression) = 0 then 3709 error = TRUE; 3710 else if stack (start_of_expression) = 1 3711 & stack (start_of_expression + 1) > last_assigned_op then do; 3712 /* Check that constant index is in range. */ 3713 inx = addr (addr (OS (stack (start_of_expression + 1))) -> constant.value) 3714 -> based_integer; 3715 if inx < 1 then do; 3716 call print_message (155, SI, "start < 1"); 3717 error = TRUE; 3718 end; 3719 else if inx > char_siz & char_siz ^= 0 then do; 3720 call print_message (155, SI, "start > length"); 3721 error = TRUE; 3722 end; 3723 end; 3724 end; 3725 if token_list (current_token + 1).type = right_parn then do; 3726 call stack_operand (1); 3727 addr (work) -> based_integer = char_siz; 3728 call stack_operand (create_constant (int_mode, work)); 3729 end; 3730 else do; 3731 start_of_expression = stack_index; 3732 call get_data_statement_expression; 3733 if token ^= right_parn then 3734 goto missing_right_paren; 3735 if stack (start_of_expression) = 0 then 3736 error = TRUE; 3737 else if stack (start_of_expression) = 1 3738 & stack (start_of_expression + 1) > last_assigned_op then do; 3739 /* Check that constant finish is in range. */ 3740 jnx = addr (addr (OS (stack (start_of_expression + 1))) -> constant.value) 3741 -> based_integer; 3742 3743 if jnx < inx then do; 3744 call print_message (155, SI, "finish < start"); 3745 error = TRUE; 3746 end; 3747 else if jnx > char_siz & char_siz ^= 0 then do; 3748 call print_message (155, SI, "finish > length"); 3749 error = TRUE; 3750 end; 3751 end; 3752 end; 3753 call get_next_token$operator; 3754 /* Next token must be an operator. */ 3755 end; 3756 if error then do; 3757 stack (start_of_node) = SKIP; 3758 stack_index = start_of_node + 1; 3759 end; 3760 end; 3761 else do /* ident with no parn */; 3762 call stack_operand (SI); 3763 end; 3764 3765 /* comma, end of loop, or end of list must follow reference */ 3766 3767 need_comma = TRUE; 3768 do while (need_comma & in_list); 3769 3770 if token ^= comma then 3771 in_list = FALSE; 3772 else if last_do > 0 & current_token = paren_info (last_do).begin_index then do; 3773 current_token = paren_info (last_do).position; 3774 /* skip over loop code */ 3775 last_do = paren_info (last_do).chain; 3776 /* step up to containing loop */ 3777 do_level = do_level - 1; 3778 3779 call stack_operand (END_DO_LOOP); 3780 /* end of implied loop */ 3781 3782 call get_next_token$operator; 3783 /* get comma or slash */ 3784 end; 3785 else 3786 need_comma = FALSE; 3787 end /* need_comma & in_list */; 3788 end /* not left paren */; 3789 end /* loop to parse all list elements */; 3790 3791 if token ^= slash then 3792 go to missing_slash; 3793 3794 /* Parse constant list. */ 3795 3796 call parse_data; 3797 3798 if token ^= comma then 3799 in_stmnt = FALSE; 3800 end /* do while (in_stmnt) */; 3801 3802 /* If data specs generated "nodes" in polish, must indicate how many halfwords are used. */ 3803 3804 if first_word ^= 0 then 3805 polish_string (first_word) = next_free_polish - first_word - 1; 3806 go to parse_done; 3807 3808 3809 /* Case Return 3810* 3811*Syntax: 3812* 3813*Polish: 3814* 3815*Notes: 3816**/ 3817 parser (39): 3818 profile_size = profile_size + 1; /* profile entry required by this statement */ 3819 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3820 3821 if END_DO_RANGE & ^logical_if_statement /* ends a loop only as part of logical if */ 3822 then 3823 call print_message (16, keyword_table (statement_type)); 3824 /* cannot terminate do loop */ 3825 3826 if sub_ptr -> subprogram_type = main_program then 3827 call print_message (17, keyword_table (statement_type)); 3828 /* return stmnt illegal in main */ 3829 3830 /* if subroutine and text follows keyword, assume alternate return statement */ 3831 3832 call get_next_token (force_symtab_entry, SI); 3833 3834 if subprogram_op = subr_op & token ^= EOS_token then do; 3835 if return_value_param = 0 /* first ref so create it */ 3836 then 3837 return_value_param = build_symbol ((NO_NAME), param_variable_attrs | attr_table (int_mode), REF); 3838 3839 call emit_operand (return_value_param); 3840 call parse_expression (any_expression, SI, ignore_bits); 3841 call emit_operator (assign_op); 3842 end; 3843 3844 call emit_return_op; 3845 go to parse_done; 3846 3847 3848 /* Case Backspace, Rewind, Endfile 3849* 3850*Syntax: | (...) 3851* ::= [unit] = u | iostat = ios | err = s 3852*Polish: [ ] 3853* [ ] 3854* 3855*Notes: 3856* need_PS indicates presence of an I/O statement 3857* SI passes output from get_next_token to parse_expr 3858* at most one iostat or err and exactly 1 unit specifier 3859**/ 3860 parser (40): /* rewind */ 3861 op_code = rewind_op; 3862 io_control_type = rewind_opr; 3863 goto rewind_endfile_backspace; 3864 3865 parser (41): /* endfile */ 3866 op_code = endfile_op; 3867 io_control_type = endfile_opr; 3868 goto rewind_endfile_backspace; 3869 3870 parser (52): /* backspace */ 3871 op_code = backspace_op; 3872 io_control_type = backspace_opr; 3873 goto rewind_endfile_backspace; 3874 3875 rewind_endfile_backspace: 3876 profile_size = profile_size + 1; /* profile entry required by this statement */ 3877 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3878 3879 /* Initialize and then begin the parse */ 3880 3881 fields_specified = ZERO; 3882 string (io_bits) = ZERO; 3883 io_bits.control_type = bit (binary (io_control_type, 4, 0), 4); 3884 io_bits.fold = subr_options.fold; 3885 io_bits.ansi_77 = subr_options.ansi_77; 3886 io_bits.hfp = subr_options.hfp; 3887 io_bits.debug_io = subr_options.debug_io; 3888 count = 0; 3889 3890 call get_next_token (force_symtab_entry, SI); /* Get first token of the expr. */ 3891 if token = left_parn /* Keyword driven */ 3892 then do; 3893 in_list = TRUE; 3894 do while (in_list); 3895 call get_next_token (ignore_symtab_entry, ignore_value); 3896 3897 /* if next token is an equals sign, then this may be a true keyword driven value, 3898* otherwise it's the expression defining UNIT or some sort of syntactic error */ 3899 count = count + 1; 3900 if token_list (current_token + 1).type = assign then do; 3901 if token ^= ident then 3902 goto missing_keyword; 3903 else if substr (full_name, 1, symbol_length) = "err" then 3904 call parse_error_label; 3905 else if substr (full_name, 1, symbol_length) = "iostat" then 3906 call parse_iostat_var; 3907 else if substr (full_name, 1, symbol_length) = "unit" then 3908 call parse_unit_specifier (FALSE, FALSE); 3909 /* asterisk forbidden */ 3910 else 3911 goto invalid_keyword; 3912 end; 3913 else do; 3914 3915 /* no keyword, UNIT = assumed (if first element in list ) */ 3916 3917 if count = 1 then 3918 call parse_unit_specifier$no_keyword (FALSE, FALSE); 3919 else 3920 goto missing_identifier; 3921 end /* no keyword */; 3922 in_list = (token = comma); 3923 end /* looping over list */; 3924 3925 if token ^= right_parn then 3926 goto missing_right_paren; 3927 if ^substr (fields_specified, units_field, 1) then 3928 call print_message (31, keyword_table (statement_type), "unit"); 3929 current_token = current_token + 1; 3930 end /* then clause */; 3931 3932 else 3933 call parse_expression (any_expression, SI, ignore_bits); 3934 call emit_operand (create_constant (int_mode, string (io_bits))); 3935 call emit_operator ((op_code)); 3936 sub_ptr -> need_PS = TRUE; 3937 go to parse_done; 3938 3939 3940 /* Case Read 3941* 3942*Syntax: 3943* 3944*Polish: 3945* 3946*Notes: 3947**/ 3948 parser (42): 3949 profile_size = profile_size + 1; /* profile entry required by this statement */ 3950 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3951 3952 if token_list (current_token + 1).type = left_parn then 3953 call parse_io (TRUE); 3954 else 3955 call parse_implied_io (TRUE, value_0, TRUE); 3956 go to parse_done; 3957 3958 3959 /* Case Decode, Encode - get and put string 3960* 3961*Syntax: 3962* 3963*Polish: 3964* 3965*Notes: 3966**/ 3967 parser (43): 3968 parser (44): 3969 profile_size = profile_size + 1; /* profile entry required by this statement */ 3970 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 3971 3972 call get_next_token$operator; /* Get left paren. */ 3973 if token ^= left_parn then 3974 go to missing_left_paren; 3975 3976 /* Set up control string. */ 3977 3978 string (io_bits) = FALSE; 3979 io_bits.read = statement_type = decode_statement; 3980 io_bits.fold = subr_options.fold; 3981 io_bits.ansi_77 = subr_options.ansi_77; 3982 io_bits.hfp = subr_options.hfp; 3983 io_bits.debug_io = subr_options.debug_io; 3984 3985 fields_specified = ZERO; 3986 sub_ptr -> need_PS = TRUE; /* Indicate presence of an I/O statement. */ 3987 3988 /* Parse the string reference. */ 3989 3990 call get_next_token (force_symtab_entry, SI); 3991 if token ^= ident then 3992 go to missing_identifier; 3993 3994 /* get_internal_file builds the polish for stmnt. parameter indicates it is being called from encode/decode */ 3995 3996 call set_data_fields (SI); 3997 call get_internal_file (TRUE); 3998 3999 /* Process format and err=l fields. */ 4000 4001 if token ^= comma then 4002 go to missing_comma; 4003 4004 call parse_io_options; /* io_bits.format may change. */ 4005 if io_bits.format = unformatted /* string io may not be unformatted */ 4006 then 4007 call print_message (31, keyword_table (statement_type), "format"); 4008 call parse_io_list; 4009 go to parse_done; 4010 4011 4012 /* Case Print 4013* 4014*Syntax: 4015* 4016*Polish: 4017* 4018*Notes: 4019**/ 4020 parser (45): 4021 profile_size = profile_size + 1; /* profile entry required by this statement */ 4022 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4023 4024 call parse_implied_io (FALSE, value_0, TRUE); 4025 go to parse_done; 4026 4027 4028 /* Case Entry 4029* 4030*Syntax: 4031* 4032*Polish: 4033* 4034*Notes: 4035* Not Audited -- not for first release. 4036**/ 4037 parser (46): 4038 string (cur_stmnt_ptr -> statement.bits) = put_in_map; 4039 4040 /* tell code generator there are multiple entry points */ 4041 4042 sub_ptr -> subprogram.multiple_entry = TRUE; 4043 4044 if sub_ptr -> subprogram_type = main_program then 4045 call print_message (35, keyword_table (statement_type)); 4046 /* entry invalid in main program */ 4047 4048 call get_next_token (force_symtab_entry, SI); 4049 if token ^= ident then 4050 go to missing_identifier; 4051 4052 /* if entry in function, data type must agree with main entry point */ 4053 4054 if subprogram_op = func_op then do; 4055 call assign_data_type (return_value); /* make sure main e.p. has data type, too */ 4056 call assign_data_type (SI); 4057 4058 if (unspec (addr (OS (SI)) -> symbol.mode_bits) ^= unspec (addr (OS (return_value)) -> symbol.mode_bits)) 4059 then 4060 call print_message (125, SI, subprogram_symbol); 4061 end; 4062 4063 call parse_parameter_list (SI); /* parses param list */ 4064 4065 if pending_entry_cnt = 1 then 4066 bypass_first_pending_entry = ^must_have_label; 4067 must_have_label = FALSE; /* statement following entry stmt never needs label */ 4068 4069 go to parse_done; 4070 4071 4072 /* Case Pause, Stop 4073* 4074*Syntax: 4075* 4076*Polish: 4077* 4078*Notes: 4079**/ 4080 parser (47): /* Stop Statement */ 4081 op_code = stop_op; 4082 go to stop_pause_common; 4083 4084 parser (48): /* Pause Statement */ 4085 op_code = pause_op; 4086 4087 stop_pause_common: 4088 profile_size = profile_size + 1; /* profile entry required by this statement */ 4089 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4090 4091 if END_DO_RANGE & ^logical_if_statement then 4092 call print_message (16, keyword_table (statement_type)); 4093 /* cannot terminate do loop */ 4094 4095 call get_next_token (locate_symtab_entry, indx); 4096 4097 if token = char_string then do; 4098 current_token = current_token + 1; 4099 end; 4100 else if token = dec_int then do; 4101 indx = create_char_constant (token_string); 4102 current_token = current_token + 1; 4103 end; 4104 else do; 4105 indx = create_char_constant (NULL_STRING); 4106 end; 4107 call emit_operand (indx); 4108 call emit_operator ((op_code)); 4109 go to parse_done; 4110 4111 4112 /* Case Assign To 4113* 4114*Syntax: 4115* 4116*Polish: 4117* 4118*Notes: 4119**/ 4120 parser (49): 4121 profile_size = profile_size + 1; /* profile entry required by this statement */ 4122 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4123 4124 call get_next_token$label (ignore_symtab_entry, ignore_value); 4125 if token ^= dec_int then 4126 go to missing_label; 4127 4128 call emit_operand (enter_label (any_label, (addr (work) -> based_integer), GOTO_REF)); 4129 call get_next_token (ignore_symtab_entry, ignore_value); 4130 if token ^= ident then do; 4131 call print_message (44, "to", err_string ());/* missing keyword */ 4132 go to statement_parse_abort; 4133 end; 4134 4135 if substr (fast_lookup, 1, 2) ^= "to" then do; 4136 call print_message (44, "to", err_string ());/* missing keyword */ 4137 go to statement_parse_abort; 4138 end; 4139 4140 call split_token (2, current_token, TRUE); 4141 current_token = current_token - 1; /* Get the token again. */ 4142 call get_next_token (force_symtab_entry, SI); 4143 4144 call parse_expression (set_reference, SI, ignore_bits); 4145 call emit_operator (assign_label_op); 4146 go to parse_done; 4147 4148 4149 /* Case Punch 4150* 4151*Syntax: 4152* 4153*Polish: 4154* 4155*Notes: 4156**/ 4157 parser (50): 4158 profile_size = profile_size + 1; /* profile entry required by this statement */ 4159 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4160 4161 if is_fast then 4162 go to parser (unknown_statement); 4163 4164 if value_7 = 0 then do; 4165 addr (work) -> based_integer = 7; 4166 value_7 = create_constant (int_mode, work); 4167 end; 4168 4169 call parse_implied_io (FALSE, value_7, FALSE); 4170 go to parse_done; 4171 4172 4173 /* Case Input 4174* 4175*Syntax: 4176* 4177*Polish: 4178* 4179*Notes: 4180**/ 4181 parser (51): 4182 profile_size = profile_size + 1; /* profile entry required by this statement */ 4183 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4184 4185 call parse_implied_io (TRUE, value_0, TRUE); 4186 go to parse_done; 4187 4188 4189 /* Case Chain */ 4190 parser (53): 4191 profile_size = profile_size + 1; /* profile entry required by this statement */ 4192 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4193 4194 call get_next_token (force_symtab_entry, SI); 4195 4196 call parse_expression (any_expression, SI, ignore_bits); 4197 4198 if token = comma then do; 4199 in_stmnt = TRUE; 4200 call get_next_token (ignore_symtab_entry, ignore_value); 4201 if token ^= ident then 4202 go to missing_keyword; 4203 4204 end; 4205 else 4206 in_stmnt = FALSE; 4207 4208 if in_stmnt & substr (fast_lookup, 1, 6) = "system" then do; 4209 call split_token (6, current_token, TRUE); 4210 current_token = current_token - 1; /* Get the token again. */ 4211 call get_next_token (force_symtab_entry, SI); 4212 4213 call parse_expression (any_expression, SI, ignore_bits); 4214 4215 if token = comma then do; 4216 in_stmnt = TRUE; 4217 call get_next_token (ignore_symtab_entry, ignore_value); 4218 if token ^= ident then do; 4219 call print_message (44, "with", err_string ()); 4220 /* missing keyword */ 4221 go to statement_parse_abort; 4222 end; 4223 4224 end; 4225 else 4226 in_stmnt = FALSE; 4227 end; 4228 else 4229 call emit_operand (create_char_constant ("fortran")); 4230 4231 call emit_count (word_offset); 4232 call emit_operator (chain_op); 4233 4234 if in_stmnt then 4235 if substr (fast_lookup, 1, 4) = "with" then do; 4236 call split_token (4, current_token, TRUE); 4237 current_token = current_token - 1; 4238 count = 0; 4239 in_list = TRUE; 4240 do while (in_list); 4241 call get_next_token (force_symtab_entry, SI); 4242 call parse_expression (any_expression, SI, ignore_bits); 4243 count = count + 1; 4244 if token ^= comma then 4245 in_list = FALSE; 4246 4247 call emit_operator (item_op); 4248 end; 4249 polish_string (word_offset) = count - bias; 4250 end; 4251 else 4252 current_token = current_token - 1; 4253 4254 call emit_operator (eol_op); 4255 go to parse_done; 4256 4257 4258 /* Case Closefile 4259* 4260*Syntax: 4261* 4262*Polish: 4263* 4264*Notes: 4265* need_PS indicates presence of an I/O statement 4266* SI passes output from get_next_token to parse_expr 4267**/ 4268 parser (54): 4269 profile_size = profile_size + 1; /* profile entry required by this statement */ 4270 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4271 4272 call get_next_token (force_symtab_entry, SI); /* Get first token of the expr. */ 4273 call parse_expression (any_expression, SI, ignore_bits); 4274 call emit_operator (closefile_op); 4275 sub_ptr -> need_PS = TRUE; 4276 go to parse_done; 4277 4278 4279 /* Case Margin 4280* 4281*Syntax: 4282* 4283*Polish: 4284* 4285*Notes: 4286**/ 4287 parser (55): 4288 profile_size = profile_size + 1; /* profile entry required by this statement */ 4289 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4290 4291 call get_next_token (force_symtab_entry, SI); 4292 call parse_expression (any_expression, SI, ignore_bits); 4293 if token ^= comma then 4294 go to missing_comma; 4295 4296 call get_next_token (force_symtab_entry, SI); 4297 call parse_expression (any_expression, SI, ignore_bits); 4298 call emit_operator (margin_op); 4299 sub_ptr -> need_PS = TRUE; 4300 go to parse_done; 4301 4302 4303 /* Case Openfile 4304* 4305*Syntax: 4306* 4307*Polish: 4308* 4309*Notes: 4310**/ 4311 parser (56): 4312 profile_size = profile_size + 1; /* profile entry required by this statement */ 4313 string (cur_stmnt_ptr -> statement.bits) = put_in_profile; 4314 4315 call get_next_token (force_symtab_entry, SI); 4316 sub_ptr -> need_PS = TRUE; 4317 call parse_expression (any_expression, SI, ignore_bits); 4318 if token ^= comma then 4319 go to missing_comma; 4320 4321 call get_next_token (force_symtab_entry, SI); 4322 4323 call parse_expression (any_expression, SI, ignore_bits); 4324 4325 if token = comma then do; 4326 call get_next_token (force_symtab_entry, SI); 4327 4328 call parse_expression (any_expression, SI, ignore_bits); 4329 4330 end; 4331 else 4332 call emit_operand (create_char_constant ("terminal")); 4333 call emit_operator (openfile_op); 4334 go to parse_done; 4335 4336 4337 /* Case Open 4338* 4339*Syntax: open (