COMPILATION LISTING OF SEGMENT new_fortran Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Bull, Phx. Az., Sys-M Compiled on: 08/06/87 1058.6 mst Thu Options: optimize map 1 /* ****************************************************** 2* * * 3* * Copyright, (C) Honeywell Limited, 1983 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* ****************************************************** */ 9 10 /* format: style3,^delnl,linecom */ 11 new_fortran: 12 proc; 13 fortran: 14 entry; 15 ft: 16 entry; 17 18 /* Modified: 19* 12 Jul 83, MM - 380: Prevent -check from truncating existing object 20* segments. 21* 12 Jul 83, MM - Prevent -version from displaying the version twice. 22* 12 Jul 83, MM - 379: Change argument handling to use fort_defaults_. 23* 10 May 83, RG - 174: Allow source to be an archive component. 24* 31 Jan 83, HH - Install LA/VLA support. 25* 17 December 1982, TO - Add "long_profile" option. 26* 21 June 1982, TO - Conform to MPM standards with: 27* "-nstrg", "-nsubr", "-ckmpy", "-nckmpy", "-ntb". 28* 3 April 1982, TO - Conform to mr10 info seg with: 29* "-no_strg", "-no_subrg", "-ck_mpy" and "-no_ck_mpy". 30* 28 May 1982, TO - Make "-check_multiply", "-stringrange", 31* "-subscriptrange" defaults for ansi77 with no optimize. 32* 28 May 1982, TO - Add controls "-nsubrg", "-nstrg", 33* "-no_stringrange", "-no_subscriptrange". 34* 3 May 1982, TO - Add "-check_multiply" and "-no_check_multiply". 35* 3 May 1982, TO - Add "-table" as default if not optimizing. 36* 3 May 1982, TO - Add "-no_table"/"-ntb" option. 37* 3 May 1982, TO - Add "-auto_zero"/"-no_auto_zero". 38* 1 Apr 1982, TO - fix bug 205. 39* 1 Apr 1982, TO - fix bug 259. 40* 26 Sep 1980, CRD - use new cu_$arg_count with code. 41* 26 Feb 1979, PES - add -version and -no_version control args. 42* 06 Nov 1979, SRH - arguments made non-positional. 43* 13 Sep 1979, PES - add -ansi66/-ansi77 control args. Default to 66. 44* fix usage message. 45* 12 Jul 1979, PES - Make -relocatable the default. Add -non_relocatable. 46* 07 Apr 1979, RAB - Make -time_ot NOT imply -time 47* 18 Dec 1978, PES - Make auto_zero the default. Broken by change of 29 Nov. 48* 30 Nov 1978, PES - Add undocumented control args -truncate and -round. 49* 29 Nov 1978, PES - Changes to control arguments for MR7.0--Remove -consolidate and -super, 50* add -safe_ot and -top_down, change -optimize to include -consolidate -super. 51* 27 Sep 1978, PES - Don't announce compiler until after all checking of command line is done 52* and it is known that fort_ will be invoked. 53* 27 Jul 1978, PES - Remove simple and full control arguments (introduced as special optimizer 54* control arguments). 55* 13 Jun 1978, DSL - Implement v2 opt features; set bit count of obj seg to zero if compilation 56* fails; have special optimizer control args also set optimize bit. 57* 18 May 1978, DSL - Print name of given entry name if compilation fails. 58* 26 Jan 1978, RAB - add special loop optimizer control_args. 59* 30 Aug 1977, DSL - implement fortran_severity_. 60* 10 Feb 1977, DSL - add -optimize (-ot); use temp seg if user specifies -check 61* instead of real obj seg. 62* 09 Dec 1976, DSL - Standardize the listing options; change -rel to -rlc; 63* use new version of compiler_source_info.incl.pl1; ref fort_version_info$greeting. 64* 30 Aug 1976, DSL - to allow new listing options. 65**/ 66 67 dcl acl_ptr pointer; 68 dcl archive_$get_component 69 entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35)); 70 dcl arg_count fixed bin; 71 dcl arg_error bit (1) aligned init ("0"b); 72 dcl arg_len fixed bin; 73 dcl arg_list_ptr ptr; 74 dcl arg_no fixed bin; 75 dcl arg_pt pointer; 76 dcl arg_string char (arg_len) based (arg_pt); 77 dcl binary_file (1:o_len) bit (36) aligned based; 78 dcl cleanup condition; 79 dcl code fixed bin (35); 80 dcl com_err_ entry options (variable); 81 dcl compiler_suffix char (7) int static options (constant) init ("fortran"); 82 dcl cu_$arg_count entry (fixed bin, fixed bin (35)); 83 dcl cu_$arg_list_ptr entry (ptr); 84 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); 85 dcl cu_$make_entry_value 86 entry (pointer, entry); 87 dcl comp_name char (32); 88 dcl dir_name char (256); 89 dcl ent_binary_name char (256); 90 dcl ent_name char (66); 91 dcl error_table_$badopt fixed bin (35) ext static; 92 dcl error_table_$entlong 93 fixed bin (35) ext static; 94 dcl error_table_$pathlong 95 fixed bin (35) ext static; 96 dcl find_source_file_ entry (char (*), char (*), char (*), ptr, fixed bin (24), fixed bin (35)); 97 dcl fort_ entry (ptr, ptr, fixed bin (19), ptr, ptr, entry, entry, fixed bin (35)); 98 dcl fort_defaults_$check_args 99 entry (ptr, aligned bit (1)); 100 dcl fort_defaults_$argument 101 entry (ptr, fixed bin, fixed bin, ptr, ptr, aligned bit (1)); 102 dcl fort_defaults_$set entry (ptr, ptr); 103 dcl fort_version_info$greeting 104 char (16) aligned ext static; 105 dcl fort_version_info$version_number 106 char (16) aligned ext static; 107 dcl fortran_severity_ fixed bin (35) ext static; 108 dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); 109 dcl get_pdir_ entry returns (char (168)); 110 dcl get_wdir_ entry returns (char (168)); 111 dcl got_path bit (1) aligned init ("0"b); 112 dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), 113 fixed bin, ptr, fixed bin (35)); 114 dcl hcs_$terminate_noname 115 entry (pointer, fixed bin (35)); 116 dcl ioa_ entry options (variable); 117 dcl len fixed bin (24); 118 dcl library_entry entry variable; 119 dcl next_source_seg_entry 120 entry variable; 121 dcl o_len fixed bin (19); 122 dcl o_ptr pointer; 123 dcl p_array (1) ptr; /* used in calls to (get release)_temp_segments_ */ 124 dcl path char (path_len) based (path_pt) unaligned; 125 dcl path_len fixed bin; 126 dcl path_pt pointer; 127 dcl program_name char (11) int static options (constant) init ("new_fortran"); 128 dcl release_temp_segments_ 129 entry (char (*), dim (*) ptr, fixed bin (35)); 130 dcl src_ptr pointer; 131 dcl translator_info_$component_get_source_info 132 entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned, 133 fixed bin (35)); 134 dcl tssi_$clean_up_segment 135 entry (ptr); 136 dcl tssi_$finish_segment 137 entry (ptr, fixed bin (24), bit (36), ptr, fixed bin (35)); 138 dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); 139 dcl 1 csi aligned like compiler_source_info; 140 dcl 1 fo aligned like fortran_options; 141 dcl 1 fd aligned like fortran_declared; 142 dcl (addr, 143 baseno, 144 divide, 145 index, 146 length, 147 null, 148 rtrim, 149 string, 150 substr, 151 unspec) builtin; 1 1 /* BEGIN INCLUDE FILE ... compiler_source_info.incl.pl1 */ 1 2 /* coded in 1973 by B. Wolman */ 1 3 /* modified 12/75 by M. Weaver to include more source info */ 1 4 /* modified 12/76 by M. Weaver to include still more source info (version 2) */ 1 5 1 6 dcl 1 compiler_source_info aligned based, 1 7 2 version fixed bin, 1 8 2 given_ename char (32) var, 1 9 2 dirname char (168) var, 1 10 2 segname char (32) var, 1 11 2 date_time_modified fixed bin (71), 1 12 2 unique_id bit (36), 1 13 2 input_lng fixed bin (21), 1 14 2 input_pointer ptr; 1 15 1 16 dcl compiler_source_info_version_2 fixed bin static init (2) options (constant); 1 17 1 18 /* END INCLUDE FILE ... compiler_source_info.incl.pl1 */ 152 2 1 /* BEGIN INCLUDE FILE fort_options.incl.pl1 */ 2 2 2 3 /****^ *********************************************************** 2 4* * * 2 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 2 6* * * 2 7* *********************************************************** */ 2 8 2 9 /****^ HISTORY COMMENTS: 2 10* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 2 11* install(86-07-28,MR12.0-1105): 2 12* Fix fortran bug 473. 2 13* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 2 14* install(87-08-06,MR12.1-1069): 2 15* Implemented SCP 6315: fortran error-handling argument. 2 16* END HISTORY COMMENTS */ 2 17 2 18 2 19 /* 2 20* Modified: 12 May 87 by RWaters added debug_io 2 21* Modified: 19 February 1986 by B. Wong & A. Ginter - 473.a: Correct 2 22* comments and size of pad field in fort_declared 2 23* and pad out dfast and fast bit masks to two words. 2 24* Modified: 09 October 1985 by B. Wong - 473: add VLA_auto, VLA_static, 2 25* VLA_parm, VLC, LA_auto, and LA_static. Remove VLA and LA. 2 26* Modified: 28 March 1984 by M. Mabey - Install HFP support. 2 27* Modified: 21 September 1983 by M. Mabey - correct size of pad field in fortran_declared. 2 28* Modified: 16 May 1983 by M. Mabey - add fortran_declared 2 29* Modified: 18 December 1982 by T. Oke - Add 'long_profile'. 2 30* Modified: 22 September 1982 by T. Oke - add VLA and LA 2 31* Modified: 3 May 1982 by T. Oke - add check_multiply 2 32* Modified: 06/24/81 by S. Herbst - add do_rounding & auto_zero to fast_mask and dfast_mask 2 33* Modified: 26 February 1980 by C R Davis - add fast_mask, fix dfast_mask. 2 34* Modified: 31 January 1980 by C R Davis - add stringrange. 2 35* Modified: 13 September 1979 by Paul E. Smee--add ansi_77. 2 36* Modified: 05 December 1978 by Paul E. Smee--add do_rounding, auto_zero. 2 37* Modified: 25 January 1978 by Richard A. Barnes for the loop optimizer 2 38**/ 2 39 2 40 declare 2 41 2 42 1 fortran_options aligned based, 2 43 2 use_library bit (1) unaligned, /* (1) ON if library statements will be parsed */ 2 44 2 optimize bit (1) unaligned, /* (2) ON if optimized code is to be produced */ 2 45 2 time bit (1) unaligned, /* (3) ON for compile timing */ 2 46 2 source_format unaligned, 2 47 3 has_line_numbers bit (1) unaligned, /* (4) ON if each line begins with a line number */ 2 48 3 fold bit (1) unaligned, /* (5) ON if variable names are to be folded to lowercase */ 2 49 3 card bit (1) unaligned, /* (6) ON for card format */ 2 50 3 convert bit (1) unaligned, /* (7) ON for card format to be converted */ 2 51 2 listing unaligned, 2 52 3 source bit (1) unaligned, /* (8) ON for listing of numbered source */ 2 53 3 symbol bit (1) unaligned, /* (9) ON for listing with symbol map */ 2 54 3 map bit (1) unaligned, /* (10) ON for listing with statement map */ 2 55 3 list bit (1) unaligned, /* (11) ON for listing with assembler instructions */ 2 56 2 error_messages unaligned, 2 57 3 brief bit (1) unaligned, /* (12) ON for brief error messages */ 2 58 3 severity fixed bin (3), /* (13-16) suppresses messages below this severity */ 2 59 2 debugging unaligned, 2 60 3 subscriptrange bit (1) unaligned, /* (17) ON for subscript range checking */ 2 61 3 stringrange bit (1) unaligned, /* (18) ON for string range checking */ 2 62 3 brief_table bit (1) unaligned, /* (19) ON for statement table */ 2 63 3 table bit (1) unaligned, /* (20) ON for statement and symbol table */ 2 64 3 profile bit (1) unaligned, /* (21) ON to generate code to meter statements */ 2 65 3 check bit (1) unaligned, /* (22) ON for syntactic and semantic checking only */ 2 66 2 system_debugging unaligned, 2 67 3 stop_after_cg bit (1) unaligned, /* (23) ON if debug stop after code generator */ 2 68 3 stop_after_parse bit (1) unaligned, /* (24) ON if debug stop after parse */ 2 69 2 relocatable bit (1) unaligned, /* (25) ON if relocatable object segment generated */ 2 70 2 optimizing unaligned, 2 71 3 time_optimizer bit (1) unaligned, /* (26) ON if timings for optimizer requested */ 2 72 /* (27) ON if optimizer can loosen safety constraints */ 2 73 3 ignore_articulation_blocks bit (1) unaligned, 2 74 3 consolidate bit(1) unaligned, /* (28) ON if optimizer should run consolidation phase */ 2 75 2 do_rounding bit(1) unaligned, /* (29) ON if floating point round should be used */ 2 76 2 auto_zero bit(1) unaligned, /* (30) ON if auto storage should be zeroed when allocated */ 2 77 2 ansi_77 bit (1) unaligned, /* (31) ON if ansi77 rules are to be followed */ 2 78 2 check_multiply bit (1) unaligned, /* (32) ON if check integer multiply extent */ 2 79 2 VLA_auto bit (1) unaligned, /* (33) ON if auto VLA's being done */ 2 80 2 VLA_parm bit (1) unaligned, /* (34) ON if parm VLA's being done */ 2 81 2 VLA_static bit (1) unaligned, /* (35) ON if static VLA's being done */ 2 82 2 VLC bit (1) unaligned, /* (36) ON if VLC's being done */ 2 83 2 LA_auto bit (1) unaligned, /* (1) ON if auto LA's being done */ 2 84 2 LA_static bit (1) unaligned, /* (2) ON if static LA's being done */ 2 85 2 long_profile bit (1) unaligned, /* (3) ON to generate long_profile */ 2 86 2 static_storage bit (1) unaligned, /* (4) ON if static storage */ 2 87 2 hfp bit (1) unaligned, /* (5) ON if using hex floating point math */ 2 88 2 debug_io bit (1) unaligned, /* (6) */ 2 89 2 pad bit(30) unaligned; /* (7-36) Pad bits */ 2 90 2 91 declare 2 92 2 93 1 fortran_declared aligned based, 2 94 2 ansi66 bit(1) unaligned, /* (1) First word */ 2 95 2 ansi77 bit(1) unaligned, /* (2) */ 2 96 2 auto bit(1) unaligned, /* (3) */ 2 97 2 auto_zero bit(1) unaligned, /* (4) */ 2 98 2 brief bit(1) unaligned, /* (5) */ 2 99 2 binary_floating_point bit(1) unaligned, /* (6) */ 2 100 2 brief_table bit(1) unaligned, /* (7) */ 2 101 2 card bit(1) unaligned, /* (8) */ 2 102 2 check bit(1) unaligned, /* (9) */ 2 103 2 check_multiply bit(1) unaligned, /* (10) */ 2 104 2 consolidate bit(1) unaligned, /* (11) */ 2 105 2 debug bit(1) unaligned, /* (12) */ 2 106 2 debug_cg bit(1) unaligned, /* (13) */ 2 107 2 debug_io bit(1) unaligned, /* (14) */ 2 108 2 default_full bit(1) unaligned, /* (15) */ 2 109 2 default_safe bit(1) unaligned, /* (16) */ 2 110 2 fold bit(1) unaligned, /* (17) */ 2 111 2 free bit(1) unaligned, /* (18) */ 2 112 2 full_optimize bit(1) unaligned, /* (19) */ 2 113 2 hexadecimal_floating_point bit(1) unaligned, 2 114 /* (20) */ 2 115 2 la_auto bit(1) unaligned, /* (21) */ 2 116 2 la_static bit(1) unaligned, /* (22) */ 2 117 2 large_array bit(1) unaligned, /* (23) */ 2 118 2 line_numbers bit(1) unaligned, /* (24) */ 2 119 2 list bit(1) unaligned, /* (25) */ 2 120 2 long bit(1) unaligned, /* (26) */ 2 121 2 long_profile bit(1) unaligned, /* (27) */ 2 122 2 map bit(1) unaligned, /* (28) */ 2 123 2 no_auto_zero bit(1) unaligned, /* (29) */ 2 124 2 no_check bit(1) unaligned, /* (30) */ 2 125 2 no_fold bit(1) unaligned, /* (31) */ 2 126 2 no_large_array bit(1) unaligned, /* (32) */ 2 127 2 no_line_numbers bit(1) unaligned, /* (33) */ 2 128 2 no_map bit(1) unaligned, /* (34) */ 2 129 2 no_optimize bit(1) unaligned, /* (35) */ 2 130 2 no_check_multiply bit(1) unaligned, /* (36) */ 2 131 2 no_debug_io bit(1) unal, /* (1) Second Word */ 2 132 2 no_stringrange bit(1) unaligned, /* (2) */ 2 133 2 no_subscriptrange bit(1) unaligned, /* (3) */ 2 134 2 no_table bit(1) unaligned, /* (4) */ 2 135 2 no_very_large_array bit(1) unaligned, /* (5) */ 2 136 2 no_vla_parm bit(1) unaligned, /* (6) */ 2 137 2 no_version bit(1) unaligned, /* (7) */ 2 138 2 non_relocatable bit(1) unaligned, /* (8) */ 2 139 2 optimize bit(1) unaligned, /* (9) */ 2 140 2 profile bit(1) unaligned, /* (10) */ 2 141 2 relocatable bit(1) unaligned, /* (11) */ 2 142 2 round bit(1) unaligned, /* (12) */ 2 143 2 safe_optimize bit(1) unaligned, /* (13) */ 2 144 2 severity fixed bin(3) unaligned, /* (14-16) */ 2 145 2 static bit(1) unaligned, /* (17) */ 2 146 2 stringrange bit(1) unaligned, /* (18) */ 2 147 2 subscriptrange bit(1) unaligned, /* (19) */ 2 148 2 table bit(1) unaligned, /* (20) */ 2 149 2 time bit(1) unaligned, /* (21) */ 2 150 2 time_ot bit(1) unaligned, /* (22) */ 2 151 2 top_down bit(1) unaligned, /* (23) */ 2 152 2 truncate bit(1) unaligned, /* (24) */ 2 153 2 version bit(1) unaligned, /* (25) */ 2 154 2 very_large_array bit(1) unaligned, /* (26) */ 2 155 2 very_large_common bit(1) unaligned, /* (27) */ 2 156 2 vla_auto bit(1) unaligned, /* (28) */ 2 157 2 vla_parm bit(1) unaligned, /* (29) */ 2 158 2 vla_static bit(1) unaligned, /* (30) */ 2 159 2 pad bit(6) unaligned; /* (31-36) */ 2 160 2 161 2 162 declare /* Options used by DFAST */ 2 163 2 164 dfast_mask bit (72) internal static options (constant) initial ("100110000000000010100000000011"b); 2 165 /* use_library, has_line_numbers, fold, subscriptrange, brief_table */ 2 166 2 167 2 168 declare /* Options used by FAST */ 2 169 2 170 fast_mask bit (72) internal static options (constant) initial ("000100000000000010100000000011"b); 2 171 /* has_line_numbers, subscriptrange, brief_table */ 2 172 2 173 /* END INCLUDE FILE fort_options.incl.pl1 */ 153 154 155 fortran_severity_ = 5; /* initialize ext static status word */ 156 157 /* the following initializations affect the cleanup handler */ 158 159 acl_ptr = null; /* There is no ACL list to clean up */ 160 o_ptr = null; /* There is no object segment to terminate */ 161 src_ptr = null; /* There is no source segment to terminate */ 162 163 /* Set the default fortran options */ 164 unspec (fd) = "0"b; 165 unspec (fo) = "0"b; 166 fo.auto_zero = "1"b; 167 fo.do_rounding = "1"b; 168 fo.relocatable = "1"b; 169 170 /* get options */ 171 172 call cu_$arg_count (arg_count, code); 173 if code ^= 0 174 then do; 175 call com_err_ (code, program_name); 176 return; 177 end; 178 179 if arg_count = 0 180 then do; 181 call com_err_ (0, program_name, "Usage: new_fortran source_path {-control_args}"); 182 return; 183 end; 184 185 call cu_$arg_list_ptr (arg_list_ptr); /* get pointer to arguments for fort_defaults_ */ 186 187 do arg_no = 1 to arg_count; 188 189 call cu_$arg_ptr (arg_no, arg_pt, arg_len, code); 190 191 if code ^= 0 192 then do; 193 call com_err_ (code, program_name, "While processing ""^a"".", arg_string); 194 arg_error = "1"b; 195 end; 196 197 else if index (arg_string, "-") ^= 1 198 then if got_path 199 then do; 200 call com_err_ (0, program_name, "Hyphen missing from ^a.", arg_string); 201 arg_error = "1"b; 202 end; 203 else do; 204 got_path = "1"b; 205 path_pt = arg_pt; 206 path_len = arg_len; 207 end; 208 else call fort_defaults_$argument (arg_pt, arg_len, arg_no, arg_list_ptr, addr (fd), arg_error); 209 end; /* loop thru arguments */ 210 211 if ^got_path 212 then if arg_count > 1 | ^fd.version 213 then do; 214 call com_err_ (0, program_name, "User has not supplied a source segment path name."); 215 arg_error = "1"b; 216 end; 217 else do; 218 call identify_version; 219 return; 220 end; 221 222 call fort_defaults_$check_args (addr (fd), arg_error); 223 call fort_defaults_$set (addr (fd), addr (fo)); 224 225 if arg_error 226 then do; 227 if fd.version 228 then call identify_version; 229 return; 230 end; 231 232 /* find the source */ 233 234 call find_source_file_ (path, compiler_suffix, ent_name, src_ptr, len, code); 235 if src_ptr = null 236 then do; 237 call com_err_ (code, program_name, "^a", path); 238 if fd.version 239 then call identify_version; 240 return; 241 end; 242 243 /* store entry name as given by the user in structure for the compiler */ 244 245 csi.given_ename = before (ent_name, "." || compiler_suffix); 246 247 /* establish a clean up handler */ 248 249 on condition (cleanup) 250 begin; 251 call truncate (); 252 end; 253 254 p_array (1), acl_ptr = null (); 255 ent_binary_name = csi.given_ename; 256 dir_name = get_wdir_ (); 257 call hcs_$initiate_count (dir_name, ent_binary_name, "", (0), 1, o_ptr, code); 258 259 if baseno (src_ptr) = baseno (o_ptr) 260 then do; 261 call com_err_ (0, program_name, 262 "Source and object segment are the same segment."); 263 o_ptr, acl_ptr = null (); 264 go to abort; 265 end; 266 call hcs_$terminate_noname (o_ptr, code); 267 268 /* get pointer to temporary object segment or just temp seg (for -check option) */ 269 270 call get_temp_segments_ (program_name, p_array, code); 271 if code ^= 0 272 then do; 273 call com_err_ (code, program_name, "Getting temp seg for compiler."); 274 go to abort; 275 end; 276 o_ptr = p_array (1); 277 278 /* get actual pathname, unique id, and date time modified; store in structure for compiler. */ 279 280 call translator_info_$component_get_source_info (src_ptr, dir_name, ent_name, comp_name, 281 csi.date_time_modified, csi.unique_id, code); 282 if code ^= 0 283 then do; 284 call com_err_ (code, program_name, ent_name); 285 go to abort; 286 end; 287 288 /* Set segname to "" and the entire pathname is put into dirname */ 289 csi.dirname = rtrim (dir_name, "> ") || ">" || rtrim (ent_name); 290 if comp_name ^= "" 291 then if length (csi.dirname) + length (rtrim (comp_name)) - length (".archive") + 1 > maxlength (csi.dirname) 292 then do; 293 call com_err_ (error_table_$pathlong, program_name, "^a::^a", before (csi.dirname, ".archive"), 294 comp_name); 295 goto abort; 296 end; 297 else csi.dirname = before (csi.dirname, ".archive") || "::" || rtrim (comp_name); 298 csi.segname = ""; 299 300 csi.input_lng = divide (len + 8, 9, 21, 0); /* Convert length to chars. */ 301 csi.input_pointer = src_ptr; 302 303 csi.version = compiler_source_info_version_2; 304 305 306 /* CALL THE COMPILER */ 307 308 call cu_$make_entry_value (null (), next_source_seg_entry); 309 call cu_$make_entry_value (null (), library_entry); 310 311 /* announce the compiler */ 312 313 if ^fd.no_version 314 then call identify_version; 315 316 fortran_severity_ = 0; /* For call to the compiler. it sets actual severity */ 317 318 call fort_ (addr (csi), o_ptr, o_len, addr (fo), addr (fd), next_source_seg_entry, library_entry, code); 319 320 if code ^= 0 321 then call com_err_ (code, program_name, "^a.fortran", csi.given_ename); 322 else if ^fo.check 323 then do; 324 325 /* Create the object segment, and copy the binary. */ 326 327 dir_name = get_wdir_ (); 328 call tssi_$get_segment (dir_name, ent_binary_name, o_ptr, acl_ptr, code); 329 if o_ptr = null /* cannot create binary */ 330 then do; 331 call com_err_ (code, program_name, "Cannot create ^a in working directory.", 332 ent_binary_name); 333 dir_name = get_pdir_ (); 334 call tssi_$get_segment (dir_name, ent_binary_name, o_ptr, acl_ptr, code); 335 336 if o_ptr = null 337 then do; 338 call com_err_ (code, program_name, "Cannot create ^a in process directory.", 339 ent_binary_name); 340 go to abort; 341 end; 342 else call com_err_ (0, program_name, "^a created in process_directory.", ent_binary_name); 343 end; 344 unspec (o_ptr -> binary_file) = unspec (p_array (1) -> binary_file); 345 end; 346 347 /* clean up and return */ 348 abort: 349 if src_ptr ^= null 350 then call hcs_$terminate_noname (src_ptr, code); 351 352 if o_ptr ^= null & o_ptr ^= p_array (1) 353 then call tssi_$finish_segment (o_ptr, o_len * 36, "1100"b, acl_ptr, code); 354 if p_array (1) ^= null 355 then call release_temp_segments_ (program_name, p_array, code); 356 return; 357 358 identify_version: 359 procedure (); 360 361 call ioa_ (rtrim (fort_version_info$greeting) || substr (fort_version_info$version_number, 10)); 362 return; 363 end; 364 365 366 truncate: 367 procedure; /* cleans up after to compiler */ 368 369 if src_ptr ^= null 370 then call hcs_$terminate_noname (src_ptr, code); 371 src_ptr = null; 372 373 if p_array (1) ^= null () 374 then call release_temp_segments_ (program_name, p_array, code); 375 376 if acl_ptr ^= null 377 then call tssi_$clean_up_segment (acl_ptr); 378 379 acl_ptr, o_ptr = null (); 380 end /* truncate */; 381 end /* new fortran */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 08/06/87 1047.7 new_fortran.pl1 >spec>install>MR12.1-1069>new_fortran.pl1 152 1 03/10/77 1345.4 compiler_source_info.incl.pl1 >ldd>include>compiler_source_info.incl.pl1 153 2 08/06/87 1045.4 fort_options.incl.pl1 >spec>install>MR12.1-1069>fort_options.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. acl_ptr 000100 automatic pointer dcl 67 set ref 159* 254* 263* 328* 334* 352* 376 376* 379* addr builtin function dcl 142 ref 208 208 222 222 223 223 223 223 318 318 318 318 318 318 arg_count 000102 automatic fixed bin(17,0) dcl 70 set ref 172* 179 187 211 arg_error 000103 automatic bit(1) initial dcl 71 set ref 71* 194* 201* 208* 215* 222* 225 arg_len 000104 automatic fixed bin(17,0) dcl 72 set ref 189* 193 193 197 200 200 206 208* arg_list_ptr 000106 automatic pointer dcl 73 set ref 185* 208* arg_no 000110 automatic fixed bin(17,0) dcl 74 set ref 187* 189* 208* arg_pt 000112 automatic pointer dcl 75 set ref 189* 193 197 200 205 208* arg_string based char unaligned dcl 76 set ref 193* 197 200* auto_zero 0(29) 000506 automatic bit(1) level 2 packed unaligned dcl 140 set ref 166* baseno builtin function dcl 142 ref 259 259 binary_file based bit(36) array dcl 77 set ref 344* 344 check 0(21) 000506 automatic bit(1) level 3 packed unaligned dcl 140 set ref 322 cleanup 000114 stack reference condition dcl 78 ref 249 code 000122 automatic fixed bin(35,0) dcl 79 set ref 172* 173 175* 189* 191 193* 234* 237* 257* 266* 270* 271 273* 280* 282 284* 318* 320 320* 328* 331* 334* 338* 348* 352* 354* 369* 373* com_err_ 000010 constant entry external dcl 80 ref 175 181 193 200 214 237 261 273 284 293 320 331 338 342 comp_name 000123 automatic char(32) unaligned dcl 87 set ref 280* 290 290 293* 297 compiler_source_info based structure level 1 dcl 1-6 compiler_source_info_version_2 constant fixed bin(17,0) initial dcl 1-16 ref 303 compiler_suffix 000004 constant char(7) initial unaligned dcl 81 set ref 234* 245 csi 000402 automatic structure level 1 dcl 139 set ref 318 318 cu_$arg_count 000012 constant entry external dcl 82 ref 172 cu_$arg_list_ptr 000014 constant entry external dcl 83 ref 185 cu_$arg_ptr 000016 constant entry external dcl 84 ref 189 cu_$make_entry_value 000020 constant entry external dcl 85 ref 308 309 date_time_modified 76 000402 automatic fixed bin(71,0) level 2 dcl 139 set ref 280* debugging 0(16) 000506 automatic structure level 2 packed unaligned dcl 140 dir_name 000133 automatic char(256) unaligned dcl 88 set ref 256* 257* 280* 289 327* 328* 333* 334* dirname 12 000402 automatic varying char(168) level 2 dcl 139 set ref 289* 290 290 293 293 297* 297 divide builtin function dcl 142 ref 300 do_rounding 0(28) 000506 automatic bit(1) level 2 packed unaligned dcl 140 set ref 167* ent_binary_name 000233 automatic char(256) unaligned dcl 89 set ref 255* 257* 328* 331* 334* 338* 342* ent_name 000333 automatic char(66) unaligned dcl 90 set ref 234* 245 280* 284* 289 error_table_$pathlong 000022 external static fixed bin(35,0) dcl 94 set ref 293* fd 000510 automatic structure level 1 dcl 141 set ref 164* 208 208 222 222 223 223 318 318 find_source_file_ 000024 constant entry external dcl 96 ref 234 fo 000506 automatic structure level 1 dcl 140 set ref 165* 223 223 318 318 fort_ 000026 constant entry external dcl 97 ref 318 fort_defaults_$argument 000032 constant entry external dcl 100 ref 208 fort_defaults_$check_args 000030 constant entry external dcl 98 ref 222 fort_defaults_$set 000034 constant entry external dcl 102 ref 223 fort_version_info$greeting 000036 external static char(16) dcl 103 ref 361 fort_version_info$version_number 000040 external static char(16) dcl 105 ref 361 fortran_declared based structure level 1 dcl 2-91 fortran_options based structure level 1 dcl 2-40 fortran_severity_ 000042 external static fixed bin(35,0) dcl 107 set ref 155* 316* get_pdir_ 000046 constant entry external dcl 109 ref 333 get_temp_segments_ 000044 constant entry external dcl 108 ref 270 get_wdir_ 000050 constant entry external dcl 110 ref 256 327 given_ename 1 000402 automatic varying char(32) level 2 dcl 139 set ref 245* 255 320* got_path 000354 automatic bit(1) initial dcl 111 set ref 111* 197 204* 211 hcs_$initiate_count 000052 constant entry external dcl 112 ref 257 hcs_$terminate_noname 000054 constant entry external dcl 114 ref 266 348 369 index builtin function dcl 142 ref 197 input_lng 101 000402 automatic fixed bin(21,0) level 2 dcl 139 set ref 300* input_pointer 102 000402 automatic pointer level 2 dcl 139 set ref 301* ioa_ 000056 constant entry external dcl 116 ref 361 len 000355 automatic fixed bin(24,0) dcl 117 set ref 234* 300 length builtin function dcl 142 ref 290 290 290 library_entry 000356 automatic entry variable dcl 118 set ref 309* 318* next_source_seg_entry 000362 automatic entry variable dcl 119 set ref 308* 318* no_version 1(06) 000510 automatic bit(1) level 2 packed unaligned dcl 141 set ref 313 null builtin function dcl 142 ref 159 160 161 235 254 263 308 308 309 309 329 336 348 352 354 369 371 373 376 379 o_len 000366 automatic fixed bin(19,0) dcl 121 set ref 318* 344 344 352 o_ptr 000370 automatic pointer dcl 122 set ref 160* 257* 259 263* 266* 276* 318* 328* 329 334* 336 344 352 352 352* 379* p_array 000372 automatic pointer array dcl 123 set ref 254* 270* 276 344 352 354 354* 373 373* path based char unaligned dcl 124 set ref 234* 237* path_len 000374 automatic fixed bin(17,0) dcl 125 set ref 206* 234 234 237 237 path_pt 000376 automatic pointer dcl 126 set ref 205* 234 237 program_name 000000 constant char(11) initial unaligned dcl 127 set ref 175* 181* 193* 200* 214* 237* 261* 270* 273* 284* 293* 320* 331* 338* 342* 354* 373* release_temp_segments_ 000060 constant entry external dcl 128 ref 354 373 relocatable 0(24) 000506 automatic bit(1) level 2 packed unaligned dcl 140 set ref 168* rtrim builtin function dcl 142 ref 289 289 290 297 361 segname 65 000402 automatic varying char(32) level 2 dcl 139 set ref 298* src_ptr 000400 automatic pointer dcl 130 set ref 161* 234* 235 259 280* 301 348 348* 369 369* 371* substr builtin function dcl 142 ref 361 translator_info_$component_get_source_info 000062 constant entry external dcl 131 ref 280 tssi_$clean_up_segment 000064 constant entry external dcl 134 ref 376 tssi_$finish_segment 000066 constant entry external dcl 136 ref 352 tssi_$get_segment 000070 constant entry external dcl 138 ref 328 334 unique_id 100 000402 automatic bit(36) level 2 dcl 139 set ref 280* unspec builtin function dcl 142 set ref 164* 165* 344* 344 version 1(25) 000510 automatic bit(1) level 2 in structure "fd" packed unaligned dcl 141 in procedure "new_fortran" set ref 211 227 238 version 000402 automatic fixed bin(17,0) level 2 in structure "csi" dcl 139 in procedure "new_fortran" set ref 303* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. archive_$get_component 000000 constant entry external dcl 68 dfast_mask internal static bit(72) initial unaligned dcl 2-162 error_table_$badopt external static fixed bin(35,0) dcl 91 error_table_$entlong external static fixed bin(35,0) dcl 92 fast_mask internal static bit(72) initial unaligned dcl 2-168 string builtin function dcl 142 NAMES DECLARED BY EXPLICIT CONTEXT. abort 002120 constant label dcl 348 ref 264 274 285 295 340 fortran 000226 constant entry external dcl 13 ft 000236 constant entry external dcl 15 identify_version 002217 constant entry internal dcl 358 ref 218 227 238 313 new_fortran 000216 constant entry external dcl 11 truncate 002264 constant entry internal dcl 366 ref 251 NAMES DECLARED BY CONTEXT OR IMPLICATION. before builtin function ref 245 293 293 297 maxlength builtin function ref 290 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3122 3214 2555 3132 Length 3504 2555 72 253 344 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME new_fortran 488 external procedure is an external procedure. on unit on line 249 92 on unit identify_version internal procedure shares stack frame of external procedure new_fortran. truncate internal procedure shares stack frame of on unit on line 249. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME new_fortran 000100 acl_ptr new_fortran 000102 arg_count new_fortran 000103 arg_error new_fortran 000104 arg_len new_fortran 000106 arg_list_ptr new_fortran 000110 arg_no new_fortran 000112 arg_pt new_fortran 000122 code new_fortran 000123 comp_name new_fortran 000133 dir_name new_fortran 000233 ent_binary_name new_fortran 000333 ent_name new_fortran 000354 got_path new_fortran 000355 len new_fortran 000356 library_entry new_fortran 000362 next_source_seg_entry new_fortran 000366 o_len new_fortran 000370 o_ptr new_fortran 000372 p_array new_fortran 000374 path_len new_fortran 000376 path_pt new_fortran 000400 src_ptr new_fortran 000402 csi new_fortran 000506 fo new_fortran 000510 fd new_fortran THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out return_mac enable_op shorten_stack ext_entry int_entry set_chars_eis index_before_cs THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ cu_$arg_count cu_$arg_list_ptr cu_$arg_ptr cu_$make_entry_value find_source_file_ fort_ fort_defaults_$argument fort_defaults_$check_args fort_defaults_$set get_pdir_ get_temp_segments_ get_wdir_ hcs_$initiate_count hcs_$terminate_noname ioa_ release_temp_segments_ translator_info_$component_get_source_info tssi_$clean_up_segment tssi_$finish_segment tssi_$get_segment THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$pathlong fort_version_info$greeting fort_version_info$version_number fortran_severity_ LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 71 000211 111 000212 11 000215 13 000224 15 000234 155 000244 159 000247 160 000251 161 000252 164 000253 165 000256 166 000260 167 000262 168 000264 172 000266 173 000276 175 000300 176 000315 179 000316 181 000320 182 000345 185 000346 187 000355 189 000365 191 000402 193 000404 194 000437 195 000441 197 000442 200 000460 201 000514 202 000516 204 000517 205 000521 206 000522 207 000524 208 000525 209 000550 211 000552 214 000562 215 000607 216 000611 218 000612 219 000613 222 000614 223 000627 225 000644 227 000647 229 000653 234 000654 235 000714 237 000720 238 000752 240 000756 245 000757 249 001000 251 001014 252 001015 254 001016 255 001021 256 001025 257 001037 259 001102 261 001111 263 001136 264 001141 266 001142 270 001153 271 001174 273 001176 274 001222 276 001223 280 001225 282 001266 284 001270 285 001311 289 001312 290 001370 293 001413 295 001463 297 001465 298 001526 300 001530 301 001534 303 001536 308 001540 309 001553 313 001566 316 001572 318 001574 320 001626 322 001662 327 001665 328 001677 329 001726 331 001732 333 001762 334 001774 336 002023 338 002027 340 002057 342 002060 344 002111 348 002120 352 002135 354 002171 356 002216 358 002217 361 002220 362 002262 366 002264 369 002265 371 002303 373 002306 376 002332 379 002346 380 002352 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved