1/* com.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995-1998 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5This file is part of GNU Fortran. 6 7GNU Fortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Fortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Fortran; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 2002111-1307, USA. 21 22 Related Modules: 23 None 24 25 Description: 26 Contains compiler-specific functions. 27 28 Modifications: 29*/ 30 31/* Understanding this module means understanding the interface between 32 the g77 front end and the gcc back end (or, perhaps, some other 33 back end). In here are the functions called by the front end proper 34 to notify whatever back end is in place about certain things, and 35 also the back-end-specific functions. It's a bear to deal with, so 36 lately I've been trying to simplify things, especially with regard 37 to the gcc-back-end-specific stuff. 38 39 Building expressions generally seems quite easy, but building decls 40 has been challenging and is undergoing revision. gcc has several 41 kinds of decls: 42 43 TYPE_DECL -- a type (int, float, struct, function, etc.) 44 CONST_DECL -- a constant of some type other than function 45 LABEL_DECL -- a variable or a constant? 46 PARM_DECL -- an argument to a function (a variable that is a dummy) 47 RESULT_DECL -- the return value of a function (a variable) 48 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.) 49 FUNCTION_DECL -- a function (either the actual function or an extern ref) 50 FIELD_DECL -- a field in a struct or union (goes into types) 51 52 g77 has a set of functions that somewhat parallels the gcc front end 53 when it comes to building decls: 54 55 Internal Function (one we define, not just declare as extern): 56 int yes; 57 yes = suspend_momentary (); 58 if (is_nested) push_f_function_context (); 59 start_function (get_identifier ("function_name"), function_type, 60 is_nested, is_public); 61 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it; 62 store_parm_decls (is_main_program); 63 ffecom_start_compstmt (); 64 // for stmts and decls inside function, do appropriate things; 65 ffecom_end_compstmt (); 66 finish_function (is_nested); 67 if (is_nested) pop_f_function_context (); 68 if (is_nested) resume_momentary (yes); 69 70 Everything Else: 71 int yes; 72 tree d; 73 tree init; 74 yes = suspend_momentary (); 75 // fill in external, public, static, &c for decl, and 76 // set DECL_INITIAL to error_mark_node if going to initialize 77 // set is_top_level TRUE only if not at top level and decl 78 // must go in top level (i.e. not within current function decl context) 79 d = start_decl (decl, is_top_level); 80 init = ...; // if have initializer 81 finish_decl (d, init, is_top_level); 82 resume_momentary (yes); 83 84*/ 85 86/* Include files. */ 87 88#include "proj.h" 89#if FFECOM_targetCURRENT == FFECOM_targetGCC 90#include "flags.j" 91#include "rtl.j" 92#include "toplev.j" 93#include "tree.j" 94#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */ 95#include "convert.j" 96#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 97 98#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */ 99 100/* BEGIN stuff from gcc/cccp.c. */ 101 102/* The following symbols should be autoconfigured: 103 HAVE_FCNTL_H 104 HAVE_STDLIB_H 105 HAVE_SYS_TIME_H 106 HAVE_UNISTD_H 107 STDC_HEADERS 108 TIME_WITH_SYS_TIME 109 In the mean time, we'll get by with approximations based 110 on existing GCC configuration symbols. */ 111 112#ifdef POSIX 113# ifndef HAVE_STDLIB_H 114# define HAVE_STDLIB_H 1 115# endif 116# ifndef HAVE_UNISTD_H 117# define HAVE_UNISTD_H 1 118# endif 119# ifndef STDC_HEADERS 120# define STDC_HEADERS 1 121# endif 122#endif /* defined (POSIX) */ 123 124#if defined (POSIX) || (defined (USG) && !defined (VMS)) 125# ifndef HAVE_FCNTL_H 126# define HAVE_FCNTL_H 1 127# endif 128#endif 129 130#ifndef RLIMIT_STACK 131# include <time.h> 132#else 133# if TIME_WITH_SYS_TIME 134# include <sys/time.h> 135# include <time.h> 136# else 137# if HAVE_SYS_TIME_H 138# include <sys/time.h> 139# else 140# include <time.h> 141# endif 142# endif 143# include <sys/resource.h> 144#endif 145 146#if HAVE_FCNTL_H 147# include <fcntl.h> 148#endif 149 150/* This defines "errno" properly for VMS, and gives us EACCES. */ 151#include <errno.h> 152 153#if HAVE_STDLIB_H 154# include <stdlib.h> 155#else 156char *getenv (); 157#endif 158 159#if HAVE_UNISTD_H 160# include <unistd.h> 161#endif 162 163/* VMS-specific definitions */ 164#ifdef VMS 165#include <descrip.h> 166#define O_RDONLY 0 /* Open arg for Read/Only */ 167#define O_WRONLY 1 /* Open arg for Write/Only */ 168#define read(fd,buf,size) VMS_read (fd,buf,size) 169#define write(fd,buf,size) VMS_write (fd,buf,size) 170#define open(fname,mode,prot) VMS_open (fname,mode,prot) 171#define fopen(fname,mode) VMS_fopen (fname,mode) 172#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile) 173#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt) 174#define fstat(fd,stbuf) VMS_fstat (fd,stbuf) 175static int VMS_fstat (), VMS_stat (); 176static char * VMS_strncat (); 177static int VMS_read (); 178static int VMS_write (); 179static int VMS_open (); 180static FILE * VMS_fopen (); 181static FILE * VMS_freopen (); 182static void hack_vms_include_specification (); 183typedef struct { unsigned :16, :16, :16; } vms_ino_t; 184#define ino_t vms_ino_t 185#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */ 186#ifdef __GNUC__ 187#define BSTRING /* VMS/GCC supplies the bstring routines */ 188#endif /* __GNUC__ */ 189#endif /* VMS */ 190 191#ifndef O_RDONLY 192#define O_RDONLY 0 193#endif 194 195/* END stuff from gcc/cccp.c. */ 196 197#define FFECOM_DETERMINE_TYPES 1 /* for com.h */ 198#include "com.h" 199#include "bad.h" 200#include "bld.h" 201#include "equiv.h" 202#include "expr.h" 203#include "implic.h" 204#include "info.h" 205#include "malloc.h" 206#include "src.h" 207#include "st.h" 208#include "storag.h" 209#include "symbol.h" 210#include "target.h" 211#include "top.h" 212#include "type.h" 213 214/* Externals defined here. */ 215 216#if FFECOM_targetCURRENT == FFECOM_targetGCC 217 218/* tree.h declares a bunch of stuff that it expects the front end to 219 define. Here are the definitions, which in the C front end are 220 found in the file c-decl.c. */ 221 222tree integer_zero_node; 223tree integer_one_node; 224tree null_pointer_node; 225tree error_mark_node; 226tree void_type_node; 227tree integer_type_node; 228tree unsigned_type_node; 229tree char_type_node; 230tree current_function_decl; 231 232/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c 233 reference it. */ 234 235char *language_string = "GNU F77"; 236 237/* Stream for reading from the input file. */ 238FILE *finput; 239 240/* These definitions parallel those in c-decl.c so that code from that 241 module can be used pretty much as is. Much of these defs aren't 242 otherwise used, i.e. by g77 code per se, except some of them are used 243 to build some of them that are. The ones that are global (i.e. not 244 "static") are those that ste.c and such might use (directly 245 or by using com macros that reference them in their definitions). */ 246 247static tree short_integer_type_node; 248tree long_integer_type_node; 249static tree long_long_integer_type_node; 250 251static tree short_unsigned_type_node; 252static tree long_unsigned_type_node; 253static tree long_long_unsigned_type_node; 254 255static tree unsigned_char_type_node; 256static tree signed_char_type_node; 257 258static tree float_type_node; 259static tree double_type_node; 260static tree complex_float_type_node; 261tree complex_double_type_node; 262static tree long_double_type_node; 263static tree complex_integer_type_node; 264static tree complex_long_double_type_node; 265 266tree string_type_node; 267 268static tree double_ftype_double; 269static tree float_ftype_float; 270static tree ldouble_ftype_ldouble; 271 272/* The rest of these are inventions for g77, though there might be 273 similar things in the C front end. As they are found, these 274 inventions should be renamed to be canonical. Note that only 275 the ones currently required to be global are so. */ 276 277static tree ffecom_tree_fun_type_void; 278static tree ffecom_tree_ptr_to_fun_type_void; 279 280tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */ 281tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */ 282tree ffecom_integer_one_node; /* " */ 283tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype]; 284 285/* _fun_type things are the f2c-specific versions. For -fno-f2c, 286 just use build_function_type and build_pointer_type on the 287 appropriate _tree_type array element. */ 288 289static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; 290static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; 291static tree ffecom_tree_subr_type; 292static tree ffecom_tree_ptr_to_subr_type; 293static tree ffecom_tree_blockdata_type; 294 295static tree ffecom_tree_xargc_; 296 297ffecomSymbol ffecom_symbol_null_ 298= 299{ 300 NULL_TREE, 301 NULL_TREE, 302 NULL_TREE, 303 NULL_TREE, 304 false 305}; 306ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE; 307ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE; 308 309int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype]; 310tree ffecom_f2c_integer_type_node; 311tree ffecom_f2c_ptr_to_integer_type_node; 312tree ffecom_f2c_address_type_node; 313tree ffecom_f2c_real_type_node; 314tree ffecom_f2c_ptr_to_real_type_node; 315tree ffecom_f2c_doublereal_type_node; 316tree ffecom_f2c_complex_type_node; 317tree ffecom_f2c_doublecomplex_type_node; 318tree ffecom_f2c_longint_type_node; 319tree ffecom_f2c_logical_type_node; 320tree ffecom_f2c_flag_type_node; 321tree ffecom_f2c_ftnlen_type_node; 322tree ffecom_f2c_ftnlen_zero_node; 323tree ffecom_f2c_ftnlen_one_node; 324tree ffecom_f2c_ftnlen_two_node; 325tree ffecom_f2c_ptr_to_ftnlen_type_node; 326tree ffecom_f2c_ftnint_type_node; 327tree ffecom_f2c_ptr_to_ftnint_type_node; 328#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 329 330/* Simple definitions and enumerations. */ 331 332#ifndef FFECOM_sizeMAXSTACKITEM 333#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things 334 larger than this # bytes 335 off stack if possible. */ 336#endif 337 338/* For systems that have large enough stacks, they should define 339 this to 0, and here, for ease of use later on, we just undefine 340 it if it is 0. */ 341 342#if FFECOM_sizeMAXSTACKITEM == 0 343#undef FFECOM_sizeMAXSTACKITEM 344#endif 345 346typedef enum 347 { 348 FFECOM_rttypeVOID_, 349 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */ 350 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */ 351 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */ 352 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */ 353 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */ 354 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */ 355 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */ 356 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */ 357 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */ 358 FFECOM_rttypeDOUBLE_, /* C's `double' type. */ 359 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */ 360 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */ 361 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */ 362 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */ 363 FFECOM_rttype_ 364 } ffecomRttype_; 365 366/* Internal typedefs. */ 367 368#if FFECOM_targetCURRENT == FFECOM_targetGCC 369typedef struct _ffecom_concat_list_ ffecomConcatList_; 370#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 371 372/* Private include files. */ 373 374 375/* Internal structure definitions. */ 376 377#if FFECOM_targetCURRENT == FFECOM_targetGCC 378struct _ffecom_concat_list_ 379 { 380 ffebld *exprs; 381 int count; 382 int max; 383 ffetargetCharacterSize minlen; 384 ffetargetCharacterSize maxlen; 385 }; 386#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 387 388/* Static functions (internal). */ 389 390#if FFECOM_targetCURRENT == FFECOM_targetGCC 391static tree ffecom_arglist_expr_ (const char *argstring, ffebld args); 392static tree ffecom_widest_expr_type_ (ffebld list); 393static bool ffecom_overlap_ (tree dest_decl, tree dest_offset, 394 tree dest_size, tree source_tree, 395 ffebld source, bool scalar_arg); 396static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest, 397 tree args, tree callee_commons, 398 bool scalar_args); 399static tree ffecom_build_f2c_string_ (int i, const char *s); 400static tree ffecom_call_ (tree fn, ffeinfoKindtype kt, 401 bool is_f2c_complex, tree type, 402 tree args, tree dest_tree, 403 ffebld dest, bool *dest_used, 404 tree callee_commons, bool scalar_args, tree hook); 405static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, 406 bool is_f2c_complex, tree type, 407 ffebld left, ffebld right, 408 tree dest_tree, ffebld dest, 409 bool *dest_used, tree callee_commons, 410 bool scalar_args, tree hook); 411static void ffecom_char_args_x_ (tree *xitem, tree *length, 412 ffebld expr, bool with_null); 413static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy); 414static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s); 415static ffecomConcatList_ 416 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, 417 ffebld expr, 418 ffetargetCharacterSize max); 419static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist); 420static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr, 421 ffetargetCharacterSize max); 422static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type, 423 ffesymbol member, tree member_type, 424 ffetargetOffset offset); 425static void ffecom_do_entry_ (ffesymbol fn, int entrynum); 426static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 427 bool *dest_used, bool assignp, bool widenp); 428static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 429 ffebld dest, bool *dest_used); 430static tree ffecom_expr_power_integer_ (ffebld expr); 431static void ffecom_expr_transform_ (ffebld expr); 432static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name); 433static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, 434 int code); 435static ffeglobal ffecom_finish_global_ (ffeglobal global); 436static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s); 437static tree ffecom_get_appended_identifier_ (char us, const char *text); 438static tree ffecom_get_external_identifier_ (ffesymbol s); 439static tree ffecom_get_identifier_ (const char *text); 440static tree ffecom_gen_sfuncdef_ (ffesymbol s, 441 ffeinfoBasictype bt, 442 ffeinfoKindtype kt); 443static const char *ffecom_gfrt_args_ (ffecomGfrt ix); 444static tree ffecom_gfrt_tree_ (ffecomGfrt ix); 445static tree ffecom_init_zero_ (tree decl); 446static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, 447 tree *maybe_tree); 448static tree ffecom_intrinsic_len_ (ffebld expr); 449static void ffecom_let_char_ (tree dest_tree, 450 tree dest_length, 451 ffetargetCharacterSize dest_size, 452 ffebld source); 453static void ffecom_make_gfrt_ (ffecomGfrt ix); 454static void ffecom_member_phase1_ (ffestorag mst, ffestorag st); 455#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING 456static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); 457#endif 458static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, 459 ffebld source); 460static void ffecom_push_dummy_decls_ (ffebld dumlist, 461 bool stmtfunc); 462static void ffecom_start_progunit_ (void); 463static ffesymbol ffecom_sym_transform_ (ffesymbol s); 464static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s); 465static void ffecom_transform_common_ (ffesymbol s); 466static void ffecom_transform_equiv_ (ffestorag st); 467static tree ffecom_transform_namelist_ (ffesymbol s); 468static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, 469 tree t); 470static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset, 471 tree *size, tree tree); 472static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right, 473 tree dest_tree, ffebld dest, 474 bool *dest_used, tree hook); 475static tree ffecom_type_localvar_ (ffesymbol s, 476 ffeinfoBasictype bt, 477 ffeinfoKindtype kt); 478static tree ffecom_type_namelist_ (void); 479#if 0 480static tree ffecom_type_permanent_copy_ (tree t); 481#endif 482static tree ffecom_type_vardesc_ (void); 483static tree ffecom_vardesc_ (ffebld expr); 484static tree ffecom_vardesc_array_ (ffesymbol s); 485static tree ffecom_vardesc_dims_ (ffesymbol s); 486static tree ffecom_convert_narrow_ (tree type, tree expr); 487static tree ffecom_convert_widen_ (tree type, tree expr); 488#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 489 490/* These are static functions that parallel those found in the C front 491 end and thus have the same names. */ 492 493#if FFECOM_targetCURRENT == FFECOM_targetGCC 494static tree bison_rule_compstmt_ (void); 495static void bison_rule_pushlevel_ (void); 496static tree builtin_function (const char *name, tree type, 497 enum built_in_function function_code, 498 const char *library_name); 499static void delete_block (tree block); 500static int duplicate_decls (tree newdecl, tree olddecl); 501static void finish_decl (tree decl, tree init, bool is_top_level); 502static void finish_function (int nested); 503static char *lang_printable_name (tree decl, int v); 504static tree lookup_name_current_level (tree name); 505static struct binding_level *make_binding_level (void); 506static void pop_f_function_context (void); 507static void push_f_function_context (void); 508static void push_parm_decl (tree parm); 509static tree pushdecl_top_level (tree decl); 510static int kept_level_p (void); 511static tree storedecls (tree decls); 512static void store_parm_decls (int is_main_program); 513static tree start_decl (tree decl, bool is_top_level); 514static void start_function (tree name, tree type, int nested, int public); 515#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 516#if FFECOM_GCC_INCLUDE 517static void ffecom_file_ (char *name); 518static void ffecom_initialize_char_syntax_ (void); 519static void ffecom_close_include_ (FILE *f); 520static int ffecom_decode_include_option_ (char *spec); 521static FILE *ffecom_open_include_ (char *name, ffewhereLine l, 522 ffewhereColumn c); 523#endif /* FFECOM_GCC_INCLUDE */ 524 525/* Static objects accessed by functions in this module. */ 526 527static ffesymbol ffecom_primary_entry_ = NULL; 528static ffesymbol ffecom_nested_entry_ = NULL; 529static ffeinfoKind ffecom_primary_entry_kind_; 530static bool ffecom_primary_entry_is_proc_; 531#if FFECOM_targetCURRENT == FFECOM_targetGCC 532static tree ffecom_outer_function_decl_; 533static tree ffecom_previous_function_decl_; 534static tree ffecom_which_entrypoint_decl_; 535static tree ffecom_float_zero_ = NULL_TREE; 536static tree ffecom_float_half_ = NULL_TREE; 537static tree ffecom_double_zero_ = NULL_TREE; 538static tree ffecom_double_half_ = NULL_TREE; 539static tree ffecom_func_result_;/* For functions. */ 540static tree ffecom_func_length_;/* For CHARACTER fns. */ 541static ffebld ffecom_list_blockdata_; 542static ffebld ffecom_list_common_; 543static ffebld ffecom_master_arglist_; 544static ffeinfoBasictype ffecom_master_bt_; 545static ffeinfoKindtype ffecom_master_kt_; 546static ffetargetCharacterSize ffecom_master_size_; 547static int ffecom_num_fns_ = 0; 548static int ffecom_num_entrypoints_ = 0; 549static bool ffecom_is_altreturning_ = FALSE; 550static tree ffecom_multi_type_node_; 551static tree ffecom_multi_retval_; 552static tree 553 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype]; 554static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */ 555static bool ffecom_doing_entry_ = FALSE; 556static bool ffecom_transform_only_dummies_ = FALSE; 557static int ffecom_typesize_pointer_; 558static int ffecom_typesize_integer1_; 559 560/* Holds pointer-to-function expressions. */ 561 562static tree ffecom_gfrt_[FFECOM_gfrt] 563= 564{ 565#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE, 566#include "com-rt.def" 567#undef DEFGFRT 568}; 569 570/* Holds the external names of the functions. */ 571 572static const char *ffecom_gfrt_name_[FFECOM_gfrt] 573= 574{ 575#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME, 576#include "com-rt.def" 577#undef DEFGFRT 578}; 579 580/* Whether the function returns. */ 581 582static bool ffecom_gfrt_volatile_[FFECOM_gfrt] 583= 584{ 585#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE, 586#include "com-rt.def" 587#undef DEFGFRT 588}; 589 590/* Whether the function returns type complex. */ 591 592static bool ffecom_gfrt_complex_[FFECOM_gfrt] 593= 594{ 595#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX, 596#include "com-rt.def" 597#undef DEFGFRT 598}; 599 600/* Type code for the function return value. */ 601 602static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt] 603= 604{ 605#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE, 606#include "com-rt.def" 607#undef DEFGFRT 608}; 609 610/* String of codes for the function's arguments. */ 611 612static const char *ffecom_gfrt_argstring_[FFECOM_gfrt] 613= 614{ 615#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS, 616#include "com-rt.def" 617#undef DEFGFRT 618}; 619#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 620 621/* Internal macros. */ 622 623#if FFECOM_targetCURRENT == FFECOM_targetGCC 624 625/* We let tm.h override the types used here, to handle trivial differences 626 such as the choice of unsigned int or long unsigned int for size_t. 627 When machines start needing nontrivial differences in the size type, 628 it would be best to do something here to figure out automatically 629 from other information what type to use. */ 630 631#ifndef SIZE_TYPE 632#define SIZE_TYPE "long unsigned int" 633#endif 634 635#define ffecom_concat_list_count_(catlist) ((catlist).count) 636#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)]) 637#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen) 638#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen) 639 640#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE) 641#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE) 642 643/* For each binding contour we allocate a binding_level structure 644 * which records the names defined in that contour. 645 * Contours include: 646 * 0) the global one 647 * 1) one for each function definition, 648 * where internal declarations of the parameters appear. 649 * 650 * The current meaning of a name can be found by searching the levels from 651 * the current one out to the global one. 652 */ 653 654/* Note that the information in the `names' component of the global contour 655 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */ 656 657struct binding_level 658 { 659 /* A chain of _DECL nodes for all variables, constants, functions, 660 and typedef types. These are in the reverse of the order supplied. 661 */ 662 tree names; 663 664 /* For each level (except not the global one), 665 a chain of BLOCK nodes for all the levels 666 that were entered and exited one level down. */ 667 tree blocks; 668 669 /* The BLOCK node for this level, if one has been preallocated. 670 If 0, the BLOCK is allocated (if needed) when the level is popped. */ 671 tree this_block; 672 673 /* The binding level which this one is contained in (inherits from). */ 674 struct binding_level *level_chain; 675 676 /* 0: no ffecom_prepare_* functions called at this level yet; 677 1: ffecom_prepare* functions called, except not ffecom_prepare_end; 678 2: ffecom_prepare_end called. */ 679 int prep_state; 680 }; 681 682#define NULL_BINDING_LEVEL (struct binding_level *) NULL 683 684/* The binding level currently in effect. */ 685 686static struct binding_level *current_binding_level; 687 688/* A chain of binding_level structures awaiting reuse. */ 689 690static struct binding_level *free_binding_level; 691 692/* The outermost binding level, for names of file scope. 693 This is created when the compiler is started and exists 694 through the entire run. */ 695 696static struct binding_level *global_binding_level; 697 698/* Binding level structures are initialized by copying this one. */ 699 700static struct binding_level clear_binding_level 701= 702{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0}; 703 704/* Language-dependent contents of an identifier. */ 705 706struct lang_identifier 707 { 708 struct tree_identifier ignore; 709 tree global_value, local_value, label_value; 710 bool invented; 711 }; 712 713/* Macros for access to language-specific slots in an identifier. */ 714/* Each of these slots contains a DECL node or null. */ 715 716/* This represents the value which the identifier has in the 717 file-scope namespace. */ 718#define IDENTIFIER_GLOBAL_VALUE(NODE) \ 719 (((struct lang_identifier *)(NODE))->global_value) 720/* This represents the value which the identifier has in the current 721 scope. */ 722#define IDENTIFIER_LOCAL_VALUE(NODE) \ 723 (((struct lang_identifier *)(NODE))->local_value) 724/* This represents the value which the identifier has as a label in 725 the current label scope. */ 726#define IDENTIFIER_LABEL_VALUE(NODE) \ 727 (((struct lang_identifier *)(NODE))->label_value) 728/* This is nonzero if the identifier was "made up" by g77 code. */ 729#define IDENTIFIER_INVENTED(NODE) \ 730 (((struct lang_identifier *)(NODE))->invented) 731 732/* In identifiers, C uses the following fields in a special way: 733 TREE_PUBLIC to record that there was a previous local extern decl. 734 TREE_USED to record that such a decl was used. 735 TREE_ADDRESSABLE to record that the address of such a decl was used. */ 736 737/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function 738 that have names. Here so we can clear out their names' definitions 739 at the end of the function. */ 740 741static tree named_labels; 742 743/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */ 744 745static tree shadowed_labels; 746 747#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 748 749/* Return the subscript expression, modified to do range-checking. 750 751 `array' is the array to be checked against. 752 `element' is the subscript expression to check. 753 `dim' is the dimension number (starting at 0). 754 `total_dims' is the total number of dimensions (0 for CHARACTER substring). 755*/ 756 757static tree 758ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, 759 char *array_name) 760{ 761 tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); 762 tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array)); 763 tree cond; 764 tree die; 765 tree args; 766 767 if (element == error_mark_node) 768 return element; 769 770 if (TREE_TYPE (low) != TREE_TYPE (element)) 771 { 772 if (TYPE_PRECISION (TREE_TYPE (low)) 773 > TYPE_PRECISION (TREE_TYPE (element))) 774 element = convert (TREE_TYPE (low), element); 775 else 776 { 777 low = convert (TREE_TYPE (element), low); 778 if (high) 779 high = convert (TREE_TYPE (element), high); 780 } 781 } 782 783 element = ffecom_save_tree (element); 784 cond = ffecom_2 (LE_EXPR, integer_type_node, 785 low, 786 element); 787 if (high) 788 { 789 cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, 790 cond, 791 ffecom_2 (LE_EXPR, integer_type_node, 792 element, 793 high)); 794 } 795 796 { 797 int len; 798 char *proc; 799 char *var; 800 tree arg3; 801 tree arg2; 802 tree arg1; 803 tree arg4; 804 805 switch (total_dims) 806 { 807 case 0: 808 var = xmalloc (strlen (array_name) + 20); 809 sprintf (&var[0], "%s[%s-substring]", 810 array_name, 811 dim ? "end" : "start"); 812 len = strlen (var) + 1; 813 break; 814 815 case 1: 816 len = strlen (array_name) + 1; 817 var = array_name; 818 break; 819 820 default: 821 var = xmalloc (strlen (array_name) + 40); 822 sprintf (&var[0], "%s[subscript-%d-of-%d]", 823 array_name, 824 dim + 1, total_dims); 825 len = strlen (var) + 1; 826 break; 827 } 828 829 arg1 = build_string (len, var); 830 831 if (total_dims != 1) 832 free (var); 833 834 TREE_TYPE (arg1) 835 = build_type_variant (build_array_type (char_type_node, 836 build_range_type 837 (integer_type_node, 838 integer_one_node, 839 build_int_2 (len, 0))), 840 1, 0); 841 TREE_CONSTANT (arg1) = 1; 842 TREE_STATIC (arg1) = 1; 843 arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)), 844 arg1); 845 846 /* s_rnge adds one to the element to print it, so bias against 847 that -- want to print a faithful *subscript* value. */ 848 arg2 = convert (ffecom_f2c_ftnint_type_node, 849 ffecom_2 (MINUS_EXPR, 850 TREE_TYPE (element), 851 element, 852 convert (TREE_TYPE (element), 853 integer_one_node))); 854 855 proc = xmalloc ((len = strlen (input_filename) 856 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl)) 857 + 2)); 858 859 sprintf (&proc[0], "%s/%s", 860 input_filename, 861 IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); 862 arg3 = build_string (len, proc); 863 864 free (proc); 865 866 TREE_TYPE (arg3) 867 = build_type_variant (build_array_type (char_type_node, 868 build_range_type 869 (integer_type_node, 870 integer_one_node, 871 build_int_2 (len, 0))), 872 1, 0); 873 TREE_CONSTANT (arg3) = 1; 874 TREE_STATIC (arg3) = 1; 875 arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)), 876 arg3); 877 878 arg4 = convert (ffecom_f2c_ftnint_type_node, 879 build_int_2 (lineno, 0)); 880 881 arg1 = build_tree_list (NULL_TREE, arg1); 882 arg2 = build_tree_list (NULL_TREE, arg2); 883 arg3 = build_tree_list (NULL_TREE, arg3); 884 arg4 = build_tree_list (NULL_TREE, arg4); 885 TREE_CHAIN (arg3) = arg4; 886 TREE_CHAIN (arg2) = arg3; 887 TREE_CHAIN (arg1) = arg2; 888 889 args = arg1; 890 } 891 die = ffecom_call_gfrt (FFECOM_gfrtRANGE, 892 args, NULL_TREE); 893 TREE_SIDE_EFFECTS (die) = 1; 894 895 element = ffecom_3 (COND_EXPR, 896 TREE_TYPE (element), 897 cond, 898 element, 899 die); 900 901 return element; 902} 903 904/* Return the computed element of an array reference. 905 906 `item' is NULL_TREE, or the transformed pointer to the array. 907 `expr' is the original opARRAYREF expression, which is transformed 908 if `item' is NULL_TREE. 909 `want_ptr' is non-zero if a pointer to the element, instead of 910 the element itself, is to be returned. */ 911 912static tree 913ffecom_arrayref_ (tree item, ffebld expr, int want_ptr) 914{ 915 ffebld dims[FFECOM_dimensionsMAX]; 916 int i; 917 int total_dims; 918 int flatten = ffe_is_flatten_arrays (); 919 int need_ptr; 920 tree array; 921 tree element; 922 tree tree_type; 923 tree tree_type_x; 924 char *array_name; 925 ffetype type; 926 ffebld list; 927 928 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER) 929 array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr))); 930 else 931 array_name = "[expr?]"; 932 933 /* Build up ARRAY_REFs in reverse order (since we're column major 934 here in Fortran land). */ 935 936 for (i = 0, list = ffebld_right (expr); 937 list != NULL; 938 ++i, list = ffebld_trail (list)) 939 { 940 dims[i] = ffebld_head (list); 941 type = ffeinfo_type (ffebld_basictype (dims[i]), 942 ffebld_kindtype (dims[i])); 943 if (! flatten 944 && ffecom_typesize_pointer_ > ffecom_typesize_integer1_ 945 && ffetype_size (type) > ffecom_typesize_integer1_) 946 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit 947 pointers and 32-bit integers. Do the full 64-bit pointer 948 arithmetic, for codes using arrays for nonstandard heap-like 949 work. */ 950 flatten = 1; 951 } 952 953 total_dims = i; 954 955 need_ptr = want_ptr || flatten; 956 957 if (! item) 958 { 959 if (need_ptr) 960 item = ffecom_ptr_to_expr (ffebld_left (expr)); 961 else 962 item = ffecom_expr (ffebld_left (expr)); 963 964 if (item == error_mark_node) 965 return item; 966 967 if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING 968 && ! mark_addressable (item)) 969 return error_mark_node; 970 } 971 972 if (item == error_mark_node) 973 return item; 974 975 if (need_ptr) 976 { 977 tree min; 978 979 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); 980 i >= 0; 981 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) 982 { 983 min = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); 984 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); 985 if (ffe_is_subscript_check ()) 986 element = ffecom_subscript_check_ (array, element, i, total_dims, 987 array_name); 988 if (element == error_mark_node) 989 return element; 990 991 /* Widen integral arithmetic as desired while preserving 992 signedness. */ 993 tree_type = TREE_TYPE (element); 994 tree_type_x = tree_type; 995 if (tree_type 996 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT 997 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) 998 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); 999 1000 if (TREE_TYPE (min) != tree_type_x) 1001 min = convert (tree_type_x, min); 1002 if (TREE_TYPE (element) != tree_type_x) 1003 element = convert (tree_type_x, element); 1004 1005 item = ffecom_2 (PLUS_EXPR, 1006 build_pointer_type (TREE_TYPE (array)), 1007 item, 1008 size_binop (MULT_EXPR, 1009 size_in_bytes (TREE_TYPE (array)), 1010 fold (build (MINUS_EXPR, 1011 tree_type_x, 1012 element, 1013 min)))); 1014 } 1015 if (! want_ptr) 1016 { 1017 item = ffecom_1 (INDIRECT_REF, 1018 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), 1019 item); 1020 } 1021 } 1022 else 1023 { 1024 for (--i; 1025 i >= 0; 1026 --i) 1027 { 1028 array = TYPE_MAIN_VARIANT (TREE_TYPE (item)); 1029 1030 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); 1031 if (ffe_is_subscript_check ()) 1032 element = ffecom_subscript_check_ (array, element, i, total_dims, 1033 array_name); 1034 if (element == error_mark_node) 1035 return element; 1036 1037 /* Widen integral arithmetic as desired while preserving 1038 signedness. */ 1039 tree_type = TREE_TYPE (element); 1040 tree_type_x = tree_type; 1041 if (tree_type 1042 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT 1043 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) 1044 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); 1045 1046 element = convert (tree_type_x, element); 1047 1048 item = ffecom_2 (ARRAY_REF, 1049 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), 1050 item, 1051 element); 1052 } 1053 } 1054 1055 return item; 1056} 1057 1058/* This is like gcc's stabilize_reference -- in fact, most of the code 1059 comes from that -- but it handles the situation where the reference 1060 is going to have its subparts picked at, and it shouldn't change 1061 (or trigger extra invocations of functions in the subtrees) due to 1062 this. save_expr is a bit overzealous, because we don't need the 1063 entire thing calculated and saved like a temp. So, for DECLs, no 1064 change is needed, because these are stable aggregates, and ARRAY_REF 1065 and such might well be stable too, but for things like calculations, 1066 we do need to calculate a snapshot of a value before picking at it. */ 1067 1068#if FFECOM_targetCURRENT == FFECOM_targetGCC 1069static tree 1070ffecom_stabilize_aggregate_ (tree ref) 1071{ 1072 tree result; 1073 enum tree_code code = TREE_CODE (ref); 1074 1075 switch (code) 1076 { 1077 case VAR_DECL: 1078 case PARM_DECL: 1079 case RESULT_DECL: 1080 /* No action is needed in this case. */ 1081 return ref; 1082 1083 case NOP_EXPR: 1084 case CONVERT_EXPR: 1085 case FLOAT_EXPR: 1086 case FIX_TRUNC_EXPR: 1087 case FIX_FLOOR_EXPR: 1088 case FIX_ROUND_EXPR: 1089 case FIX_CEIL_EXPR: 1090 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0))); 1091 break; 1092 1093 case INDIRECT_REF: 1094 result = build_nt (INDIRECT_REF, 1095 stabilize_reference_1 (TREE_OPERAND (ref, 0))); 1096 break; 1097 1098 case COMPONENT_REF: 1099 result = build_nt (COMPONENT_REF, 1100 stabilize_reference (TREE_OPERAND (ref, 0)), 1101 TREE_OPERAND (ref, 1)); 1102 break; 1103 1104 case BIT_FIELD_REF: 1105 result = build_nt (BIT_FIELD_REF, 1106 stabilize_reference (TREE_OPERAND (ref, 0)), 1107 stabilize_reference_1 (TREE_OPERAND (ref, 1)), 1108 stabilize_reference_1 (TREE_OPERAND (ref, 2))); 1109 break; 1110 1111 case ARRAY_REF: 1112 result = build_nt (ARRAY_REF, 1113 stabilize_reference (TREE_OPERAND (ref, 0)), 1114 stabilize_reference_1 (TREE_OPERAND (ref, 1))); 1115 break; 1116 1117 case COMPOUND_EXPR: 1118 result = build_nt (COMPOUND_EXPR, 1119 stabilize_reference_1 (TREE_OPERAND (ref, 0)), 1120 stabilize_reference (TREE_OPERAND (ref, 1))); 1121 break; 1122 1123 case RTL_EXPR: 1124 result = build1 (INDIRECT_REF, TREE_TYPE (ref), 1125 save_expr (build1 (ADDR_EXPR, 1126 build_pointer_type (TREE_TYPE (ref)), 1127 ref))); 1128 break; 1129 1130 1131 default: 1132 return save_expr (ref); 1133 1134 case ERROR_MARK: 1135 return error_mark_node; 1136 } 1137 1138 TREE_TYPE (result) = TREE_TYPE (ref); 1139 TREE_READONLY (result) = TREE_READONLY (ref); 1140 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref); 1141 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); 1142 TREE_RAISES (result) = TREE_RAISES (ref); 1143 1144 return result; 1145} 1146#endif 1147 1148/* A rip-off of gcc's convert.c convert_to_complex function, 1149 reworked to handle complex implemented as C structures 1150 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */ 1151 1152#if FFECOM_targetCURRENT == FFECOM_targetGCC 1153static tree 1154ffecom_convert_to_complex_ (tree type, tree expr) 1155{ 1156 register enum tree_code form = TREE_CODE (TREE_TYPE (expr)); 1157 tree subtype; 1158 1159 assert (TREE_CODE (type) == RECORD_TYPE); 1160 1161 subtype = TREE_TYPE (TYPE_FIELDS (type)); 1162 1163 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE) 1164 { 1165 expr = convert (subtype, expr); 1166 return ffecom_2 (COMPLEX_EXPR, type, expr, 1167 convert (subtype, integer_zero_node)); 1168 } 1169 1170 if (form == RECORD_TYPE) 1171 { 1172 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))); 1173 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype)) 1174 return expr; 1175 else 1176 { 1177 expr = save_expr (expr); 1178 return ffecom_2 (COMPLEX_EXPR, 1179 type, 1180 convert (subtype, 1181 ffecom_1 (REALPART_EXPR, 1182 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), 1183 expr)), 1184 convert (subtype, 1185 ffecom_1 (IMAGPART_EXPR, 1186 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), 1187 expr))); 1188 } 1189 } 1190 1191 if (form == POINTER_TYPE || form == REFERENCE_TYPE) 1192 error ("pointer value used where a complex was expected"); 1193 else 1194 error ("aggregate value used where a complex was expected"); 1195 1196 return ffecom_2 (COMPLEX_EXPR, type, 1197 convert (subtype, integer_zero_node), 1198 convert (subtype, integer_zero_node)); 1199} 1200#endif 1201 1202/* Like gcc's convert(), but crashes if widening might happen. */ 1203 1204#if FFECOM_targetCURRENT == FFECOM_targetGCC 1205static tree 1206ffecom_convert_narrow_ (type, expr) 1207 tree type, expr; 1208{ 1209 register tree e = expr; 1210 register enum tree_code code = TREE_CODE (type); 1211 1212 if (type == TREE_TYPE (e) 1213 || TREE_CODE (e) == ERROR_MARK) 1214 return e; 1215 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) 1216 return fold (build1 (NOP_EXPR, type, e)); 1217 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK 1218 || code == ERROR_MARK) 1219 return error_mark_node; 1220 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) 1221 { 1222 assert ("void value not ignored as it ought to be" == NULL); 1223 return error_mark_node; 1224 } 1225 assert (code != VOID_TYPE); 1226 if ((code != RECORD_TYPE) 1227 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) 1228 assert ("converting COMPLEX to REAL" == NULL); 1229 assert (code != ENUMERAL_TYPE); 1230 if (code == INTEGER_TYPE) 1231 { 1232 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE 1233 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))) 1234 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE 1235 && (TYPE_PRECISION (type) 1236 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e)))))); 1237 return fold (convert_to_integer (type, e)); 1238 } 1239 if (code == POINTER_TYPE) 1240 { 1241 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); 1242 return fold (convert_to_pointer (type, e)); 1243 } 1244 if (code == REAL_TYPE) 1245 { 1246 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); 1247 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))); 1248 return fold (convert_to_real (type, e)); 1249 } 1250 if (code == COMPLEX_TYPE) 1251 { 1252 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); 1253 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); 1254 return fold (convert_to_complex (type, e)); 1255 } 1256 if (code == RECORD_TYPE) 1257 { 1258 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); 1259 /* Check that at least the first field name agrees. */ 1260 assert (DECL_NAME (TYPE_FIELDS (type)) 1261 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); 1262 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) 1263 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); 1264 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) 1265 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) 1266 return e; 1267 return fold (ffecom_convert_to_complex_ (type, e)); 1268 } 1269 1270 assert ("conversion to non-scalar type requested" == NULL); 1271 return error_mark_node; 1272} 1273#endif 1274 1275/* Like gcc's convert(), but crashes if narrowing might happen. */ 1276 1277#if FFECOM_targetCURRENT == FFECOM_targetGCC 1278static tree 1279ffecom_convert_widen_ (type, expr) 1280 tree type, expr; 1281{ 1282 register tree e = expr; 1283 register enum tree_code code = TREE_CODE (type); 1284 1285 if (type == TREE_TYPE (e) 1286 || TREE_CODE (e) == ERROR_MARK) 1287 return e; 1288 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) 1289 return fold (build1 (NOP_EXPR, type, e)); 1290 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK 1291 || code == ERROR_MARK) 1292 return error_mark_node; 1293 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) 1294 { 1295 assert ("void value not ignored as it ought to be" == NULL); 1296 return error_mark_node; 1297 } 1298 assert (code != VOID_TYPE); 1299 if ((code != RECORD_TYPE) 1300 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) 1301 assert ("narrowing COMPLEX to REAL" == NULL); 1302 assert (code != ENUMERAL_TYPE); 1303 if (code == INTEGER_TYPE) 1304 { 1305 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE 1306 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))) 1307 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE 1308 && (TYPE_PRECISION (type) 1309 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e)))))); 1310 return fold (convert_to_integer (type, e)); 1311 } 1312 if (code == POINTER_TYPE) 1313 { 1314 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); 1315 return fold (convert_to_pointer (type, e)); 1316 } 1317 if (code == REAL_TYPE) 1318 { 1319 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); 1320 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))); 1321 return fold (convert_to_real (type, e)); 1322 } 1323 if (code == COMPLEX_TYPE) 1324 { 1325 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); 1326 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); 1327 return fold (convert_to_complex (type, e)); 1328 } 1329 if (code == RECORD_TYPE) 1330 { 1331 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); 1332 /* Check that at least the first field name agrees. */ 1333 assert (DECL_NAME (TYPE_FIELDS (type)) 1334 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); 1335 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) 1336 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); 1337 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) 1338 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) 1339 return e; 1340 return fold (ffecom_convert_to_complex_ (type, e)); 1341 } 1342 1343 assert ("conversion to non-scalar type requested" == NULL); 1344 return error_mark_node; 1345} 1346#endif 1347 1348/* Handles making a COMPLEX type, either the standard 1349 (but buggy?) gbe way, or the safer (but less elegant?) 1350 f2c way. */ 1351 1352#if FFECOM_targetCURRENT == FFECOM_targetGCC 1353static tree 1354ffecom_make_complex_type_ (tree subtype) 1355{ 1356 tree type; 1357 tree realfield; 1358 tree imagfield; 1359 1360 if (ffe_is_emulate_complex ()) 1361 { 1362 type = make_node (RECORD_TYPE); 1363 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype); 1364 imagfield = ffecom_decl_field (type, realfield, "i", subtype); 1365 TYPE_FIELDS (type) = realfield; 1366 layout_type (type); 1367 } 1368 else 1369 { 1370 type = make_node (COMPLEX_TYPE); 1371 TREE_TYPE (type) = subtype; 1372 layout_type (type); 1373 } 1374 1375 return type; 1376} 1377#endif 1378 1379/* Chooses either the gbe or the f2c way to build a 1380 complex constant. */ 1381 1382#if FFECOM_targetCURRENT == FFECOM_targetGCC 1383static tree 1384ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart) 1385{ 1386 tree bothparts; 1387 1388 if (ffe_is_emulate_complex ()) 1389 { 1390 bothparts = build_tree_list (TYPE_FIELDS (type), realpart); 1391 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart); 1392 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts); 1393 } 1394 else 1395 { 1396 bothparts = build_complex (type, realpart, imagpart); 1397 } 1398 1399 return bothparts; 1400} 1401#endif 1402 1403#if FFECOM_targetCURRENT == FFECOM_targetGCC 1404static tree 1405ffecom_arglist_expr_ (const char *c, ffebld expr) 1406{ 1407 tree list; 1408 tree *plist = &list; 1409 tree trail = NULL_TREE; /* Append char length args here. */ 1410 tree *ptrail = &trail; 1411 tree length; 1412 ffebld exprh; 1413 tree item; 1414 bool ptr = FALSE; 1415 tree wanted = NULL_TREE; 1416 static char zed[] = "0"; 1417 1418 if (c == NULL) 1419 c = &zed[0]; 1420 1421 while (expr != NULL) 1422 { 1423 if (*c != '\0') 1424 { 1425 ptr = FALSE; 1426 if (*c == '&') 1427 { 1428 ptr = TRUE; 1429 ++c; 1430 } 1431 switch (*(c++)) 1432 { 1433 case '\0': 1434 ptr = TRUE; 1435 wanted = NULL_TREE; 1436 break; 1437 1438 case 'a': 1439 assert (ptr); 1440 wanted = NULL_TREE; 1441 break; 1442 1443 case 'c': 1444 wanted = ffecom_f2c_complex_type_node; 1445 break; 1446 1447 case 'd': 1448 wanted = ffecom_f2c_doublereal_type_node; 1449 break; 1450 1451 case 'e': 1452 wanted = ffecom_f2c_doublecomplex_type_node; 1453 break; 1454 1455 case 'f': 1456 wanted = ffecom_f2c_real_type_node; 1457 break; 1458 1459 case 'i': 1460 wanted = ffecom_f2c_integer_type_node; 1461 break; 1462 1463 case 'j': 1464 wanted = ffecom_f2c_longint_type_node; 1465 break; 1466 1467 default: 1468 assert ("bad argstring code" == NULL); 1469 wanted = NULL_TREE; 1470 break; 1471 } 1472 } 1473 1474 exprh = ffebld_head (expr); 1475 if (exprh == NULL) 1476 wanted = NULL_TREE; 1477 1478 if ((wanted == NULL_TREE) 1479 || (ptr 1480 && (TYPE_MODE 1481 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))] 1482 [ffeinfo_kindtype (ffebld_info (exprh))]) 1483 == TYPE_MODE (wanted)))) 1484 *plist 1485 = build_tree_list (NULL_TREE, 1486 ffecom_arg_ptr_to_expr (exprh, 1487 &length)); 1488 else 1489 { 1490 item = ffecom_arg_expr (exprh, &length); 1491 item = ffecom_convert_widen_ (wanted, item); 1492 if (ptr) 1493 { 1494 item = ffecom_1 (ADDR_EXPR, 1495 build_pointer_type (TREE_TYPE (item)), 1496 item); 1497 } 1498 *plist 1499 = build_tree_list (NULL_TREE, 1500 item); 1501 } 1502 1503 plist = &TREE_CHAIN (*plist); 1504 expr = ffebld_trail (expr); 1505 if (length != NULL_TREE) 1506 { 1507 *ptrail = build_tree_list (NULL_TREE, length); 1508 ptrail = &TREE_CHAIN (*ptrail); 1509 } 1510 } 1511 1512 /* We've run out of args in the call; if the implementation expects 1513 more, supply null pointers for them, which the implementation can 1514 check to see if an arg was omitted. */ 1515 1516 while (*c != '\0' && *c != '0') 1517 { 1518 if (*c == '&') 1519 ++c; 1520 else 1521 assert ("missing arg to run-time routine!" == NULL); 1522 1523 switch (*(c++)) 1524 { 1525 case '\0': 1526 case 'a': 1527 case 'c': 1528 case 'd': 1529 case 'e': 1530 case 'f': 1531 case 'i': 1532 case 'j': 1533 break; 1534 1535 default: 1536 assert ("bad arg string code" == NULL); 1537 break; 1538 } 1539 *plist 1540 = build_tree_list (NULL_TREE, 1541 null_pointer_node); 1542 plist = &TREE_CHAIN (*plist); 1543 } 1544 1545 *plist = trail; 1546 1547 return list; 1548} 1549#endif 1550 1551#if FFECOM_targetCURRENT == FFECOM_targetGCC 1552static tree 1553ffecom_widest_expr_type_ (ffebld list) 1554{ 1555 ffebld item; 1556 ffebld widest = NULL; 1557 ffetype type; 1558 ffetype widest_type = NULL; 1559 tree t; 1560 1561 for (; list != NULL; list = ffebld_trail (list)) 1562 { 1563 item = ffebld_head (list); 1564 if (item == NULL) 1565 continue; 1566 if ((widest != NULL) 1567 && (ffeinfo_basictype (ffebld_info (item)) 1568 != ffeinfo_basictype (ffebld_info (widest)))) 1569 continue; 1570 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)), 1571 ffeinfo_kindtype (ffebld_info (item))); 1572 if ((widest == FFEINFO_kindtypeNONE) 1573 || (ffetype_size (type) 1574 > ffetype_size (widest_type))) 1575 { 1576 widest = item; 1577 widest_type = type; 1578 } 1579 } 1580 1581 assert (widest != NULL); 1582 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))] 1583 [ffeinfo_kindtype (ffebld_info (widest))]; 1584 assert (t != NULL_TREE); 1585 return t; 1586} 1587#endif 1588 1589/* Check whether a partial overlap between two expressions is possible. 1590 1591 Can *starting* to write a portion of expr1 change the value 1592 computed (perhaps already, *partially*) by expr2? 1593 1594 Currently, this is a concern only for a COMPLEX expr1. But if it 1595 isn't in COMMON or local EQUIVALENCE, since we don't support 1596 aliasing of arguments, it isn't a concern. */ 1597 1598static bool 1599ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2) 1600{ 1601 ffesymbol sym; 1602 ffestorag st; 1603 1604 switch (ffebld_op (expr1)) 1605 { 1606 case FFEBLD_opSYMTER: 1607 sym = ffebld_symter (expr1); 1608 break; 1609 1610 case FFEBLD_opARRAYREF: 1611 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER) 1612 return FALSE; 1613 sym = ffebld_symter (ffebld_left (expr1)); 1614 break; 1615 1616 default: 1617 return FALSE; 1618 } 1619 1620 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON 1621 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL 1622 || ! (st = ffesymbol_storage (sym)) 1623 || ! ffestorag_parent (st))) 1624 return FALSE; 1625 1626 /* It's in COMMON or local EQUIVALENCE. */ 1627 1628 return TRUE; 1629} 1630 1631/* Check whether dest and source might overlap. ffebld versions of these 1632 might or might not be passed, will be NULL if not. 1633 1634 The test is really whether source_tree is modifiable and, if modified, 1635 might overlap destination such that the value(s) in the destination might 1636 change before it is finally modified. dest_* are the canonized 1637 destination itself. */ 1638 1639#if FFECOM_targetCURRENT == FFECOM_targetGCC 1640static bool 1641ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size, 1642 tree source_tree, ffebld source UNUSED, 1643 bool scalar_arg) 1644{ 1645 tree source_decl; 1646 tree source_offset; 1647 tree source_size; 1648 tree t; 1649 1650 if (source_tree == NULL_TREE) 1651 return FALSE; 1652 1653 switch (TREE_CODE (source_tree)) 1654 { 1655 case ERROR_MARK: 1656 case IDENTIFIER_NODE: 1657 case INTEGER_CST: 1658 case REAL_CST: 1659 case COMPLEX_CST: 1660 case STRING_CST: 1661 case CONST_DECL: 1662 case VAR_DECL: 1663 case RESULT_DECL: 1664 case FIELD_DECL: 1665 case MINUS_EXPR: 1666 case MULT_EXPR: 1667 case TRUNC_DIV_EXPR: 1668 case CEIL_DIV_EXPR: 1669 case FLOOR_DIV_EXPR: 1670 case ROUND_DIV_EXPR: 1671 case TRUNC_MOD_EXPR: 1672 case CEIL_MOD_EXPR: 1673 case FLOOR_MOD_EXPR: 1674 case ROUND_MOD_EXPR: 1675 case RDIV_EXPR: 1676 case EXACT_DIV_EXPR: 1677 case FIX_TRUNC_EXPR: 1678 case FIX_CEIL_EXPR: 1679 case FIX_FLOOR_EXPR: 1680 case FIX_ROUND_EXPR: 1681 case FLOAT_EXPR: 1682 case EXPON_EXPR: 1683 case NEGATE_EXPR: 1684 case MIN_EXPR: 1685 case MAX_EXPR: 1686 case ABS_EXPR: 1687 case FFS_EXPR: 1688 case LSHIFT_EXPR: 1689 case RSHIFT_EXPR: 1690 case LROTATE_EXPR: 1691 case RROTATE_EXPR: 1692 case BIT_IOR_EXPR: 1693 case BIT_XOR_EXPR: 1694 case BIT_AND_EXPR: 1695 case BIT_ANDTC_EXPR: 1696 case BIT_NOT_EXPR: 1697 case TRUTH_ANDIF_EXPR: 1698 case TRUTH_ORIF_EXPR: 1699 case TRUTH_AND_EXPR: 1700 case TRUTH_OR_EXPR: 1701 case TRUTH_XOR_EXPR: 1702 case TRUTH_NOT_EXPR: 1703 case LT_EXPR: 1704 case LE_EXPR: 1705 case GT_EXPR: 1706 case GE_EXPR: 1707 case EQ_EXPR: 1708 case NE_EXPR: 1709 case COMPLEX_EXPR: 1710 case CONJ_EXPR: 1711 case REALPART_EXPR: 1712 case IMAGPART_EXPR: 1713 case LABEL_EXPR: 1714 case COMPONENT_REF: 1715 return FALSE; 1716 1717 case COMPOUND_EXPR: 1718 return ffecom_overlap_ (dest_decl, dest_offset, dest_size, 1719 TREE_OPERAND (source_tree, 1), NULL, 1720 scalar_arg); 1721 1722 case MODIFY_EXPR: 1723 return ffecom_overlap_ (dest_decl, dest_offset, dest_size, 1724 TREE_OPERAND (source_tree, 0), NULL, 1725 scalar_arg); 1726 1727 case CONVERT_EXPR: 1728 case NOP_EXPR: 1729 case NON_LVALUE_EXPR: 1730 case PLUS_EXPR: 1731 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) 1732 return TRUE; 1733 1734 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset, 1735 source_tree); 1736 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); 1737 break; 1738 1739 case COND_EXPR: 1740 return 1741 ffecom_overlap_ (dest_decl, dest_offset, dest_size, 1742 TREE_OPERAND (source_tree, 1), NULL, 1743 scalar_arg) 1744 || ffecom_overlap_ (dest_decl, dest_offset, dest_size, 1745 TREE_OPERAND (source_tree, 2), NULL, 1746 scalar_arg); 1747 1748 1749 case ADDR_EXPR: 1750 ffecom_tree_canonize_ref_ (&source_decl, &source_offset, 1751 &source_size, 1752 TREE_OPERAND (source_tree, 0)); 1753 break; 1754 1755 case PARM_DECL: 1756 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) 1757 return TRUE; 1758 1759 source_decl = source_tree; 1760 source_offset = size_zero_node; 1761 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); 1762 break; 1763 1764 case SAVE_EXPR: 1765 case REFERENCE_EXPR: 1766 case PREDECREMENT_EXPR: 1767 case PREINCREMENT_EXPR: 1768 case POSTDECREMENT_EXPR: 1769 case POSTINCREMENT_EXPR: 1770 case INDIRECT_REF: 1771 case ARRAY_REF: 1772 case CALL_EXPR: 1773 default: 1774 return TRUE; 1775 } 1776 1777 /* Come here when source_decl, source_offset, and source_size filled 1778 in appropriately. */ 1779 1780 if (source_decl == NULL_TREE) 1781 return FALSE; /* No decl involved, so no overlap. */ 1782 1783 if (source_decl != dest_decl) 1784 return FALSE; /* Different decl, no overlap. */ 1785 1786 if (TREE_CODE (dest_size) == ERROR_MARK) 1787 return TRUE; /* Assignment into entire assumed-size 1788 array? Shouldn't happen.... */ 1789 1790 t = ffecom_2 (LE_EXPR, integer_type_node, 1791 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset), 1792 dest_offset, 1793 convert (TREE_TYPE (dest_offset), 1794 dest_size)), 1795 convert (TREE_TYPE (dest_offset), 1796 source_offset)); 1797 1798 if (integer_onep (t)) 1799 return FALSE; /* Destination precedes source. */ 1800 1801 if (!scalar_arg 1802 || (source_size == NULL_TREE) 1803 || (TREE_CODE (source_size) == ERROR_MARK) 1804 || integer_zerop (source_size)) 1805 return TRUE; /* No way to tell if dest follows source. */ 1806 1807 t = ffecom_2 (LE_EXPR, integer_type_node, 1808 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset), 1809 source_offset, 1810 convert (TREE_TYPE (source_offset), 1811 source_size)), 1812 convert (TREE_TYPE (source_offset), 1813 dest_offset)); 1814 1815 if (integer_onep (t)) 1816 return FALSE; /* Destination follows source. */ 1817 1818 return TRUE; /* Destination and source overlap. */ 1819} 1820#endif 1821 1822/* Check whether dest might overlap any of a list of arguments or is 1823 in a COMMON area the callee might know about (and thus modify). */ 1824 1825#if FFECOM_targetCURRENT == FFECOM_targetGCC 1826static bool 1827ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED, 1828 tree args, tree callee_commons, 1829 bool scalar_args) 1830{ 1831 tree arg; 1832 tree dest_decl; 1833 tree dest_offset; 1834 tree dest_size; 1835 1836 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size, 1837 dest_tree); 1838 1839 if (dest_decl == NULL_TREE) 1840 return FALSE; /* Seems unlikely! */ 1841 1842 /* If the decl cannot be determined reliably, or if its in COMMON 1843 and the callee isn't known to not futz with COMMON via other 1844 means, overlap might happen. */ 1845 1846 if ((TREE_CODE (dest_decl) == ERROR_MARK) 1847 || ((callee_commons != NULL_TREE) 1848 && TREE_PUBLIC (dest_decl))) 1849 return TRUE; 1850 1851 for (; args != NULL_TREE; args = TREE_CHAIN (args)) 1852 { 1853 if (((arg = TREE_VALUE (args)) != NULL_TREE) 1854 && ffecom_overlap_ (dest_decl, dest_offset, dest_size, 1855 arg, NULL, scalar_args)) 1856 return TRUE; 1857 } 1858 1859 return FALSE; 1860} 1861#endif 1862 1863/* Build a string for a variable name as used by NAMELIST. This means that 1864 if we're using the f2c library, we build an uppercase string, since 1865 f2c does this. */ 1866 1867#if FFECOM_targetCURRENT == FFECOM_targetGCC 1868static tree 1869ffecom_build_f2c_string_ (int i, const char *s) 1870{ 1871 if (!ffe_is_f2c_library ()) 1872 return build_string (i, s); 1873 1874 { 1875 char *tmp; 1876 const char *p; 1877 char *q; 1878 char space[34]; 1879 tree t; 1880 1881 if (((size_t) i) > ARRAY_SIZE (space)) 1882 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i); 1883 else 1884 tmp = &space[0]; 1885 1886 for (p = s, q = tmp; *p != '\0'; ++p, ++q) 1887 *q = ffesrc_toupper (*p); 1888 *q = '\0'; 1889 1890 t = build_string (i, tmp); 1891 1892 if (((size_t) i) > ARRAY_SIZE (space)) 1893 malloc_kill_ks (malloc_pool_image (), tmp, i); 1894 1895 return t; 1896 } 1897} 1898 1899#endif 1900/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for 1901 type to just get whatever the function returns), handling the 1902 f2c value-returning convention, if required, by prepending 1903 to the arglist a pointer to a temporary to receive the return value. */ 1904 1905#if FFECOM_targetCURRENT == FFECOM_targetGCC 1906static tree 1907ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 1908 tree type, tree args, tree dest_tree, 1909 ffebld dest, bool *dest_used, tree callee_commons, 1910 bool scalar_args, tree hook) 1911{ 1912 tree item; 1913 tree tempvar; 1914 1915 if (dest_used != NULL) 1916 *dest_used = FALSE; 1917 1918 if (is_f2c_complex) 1919 { 1920 if ((dest_used == NULL) 1921 || (dest == NULL) 1922 || (ffeinfo_basictype (ffebld_info (dest)) 1923 != FFEINFO_basictypeCOMPLEX) 1924 || (ffeinfo_kindtype (ffebld_info (dest)) != kt) 1925 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type)) 1926 || ffecom_args_overlapping_ (dest_tree, dest, args, 1927 callee_commons, 1928 scalar_args)) 1929 { 1930#ifdef HOHO 1931 tempvar = ffecom_make_tempvar (ffecom_tree_type 1932 [FFEINFO_basictypeCOMPLEX][kt], 1933 FFETARGET_charactersizeNONE, 1934 -1); 1935#else 1936 tempvar = hook; 1937 assert (tempvar); 1938#endif 1939 } 1940 else 1941 { 1942 *dest_used = TRUE; 1943 tempvar = dest_tree; 1944 type = NULL_TREE; 1945 } 1946 1947 item 1948 = build_tree_list (NULL_TREE, 1949 ffecom_1 (ADDR_EXPR, 1950 build_pointer_type (TREE_TYPE (tempvar)), 1951 tempvar)); 1952 TREE_CHAIN (item) = args; 1953 1954 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, 1955 item, NULL_TREE); 1956 1957 if (tempvar != dest_tree) 1958 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar); 1959 } 1960 else 1961 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, 1962 args, NULL_TREE); 1963 1964 if ((type != NULL_TREE) && (TREE_TYPE (item) != type)) 1965 item = ffecom_convert_narrow_ (type, item); 1966 1967 return item; 1968} 1969#endif 1970 1971/* Given two arguments, transform them and make a call to the given 1972 function via ffecom_call_. */ 1973 1974#if FFECOM_targetCURRENT == FFECOM_targetGCC 1975static tree 1976ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 1977 tree type, ffebld left, ffebld right, 1978 tree dest_tree, ffebld dest, bool *dest_used, 1979 tree callee_commons, bool scalar_args, tree hook) 1980{ 1981 tree left_tree; 1982 tree right_tree; 1983 tree left_length; 1984 tree right_length; 1985 1986 left_tree = ffecom_arg_ptr_to_expr (left, &left_length); 1987 right_tree = ffecom_arg_ptr_to_expr (right, &right_length); 1988 1989 left_tree = build_tree_list (NULL_TREE, left_tree); 1990 right_tree = build_tree_list (NULL_TREE, right_tree); 1991 TREE_CHAIN (left_tree) = right_tree; 1992 1993 if (left_length != NULL_TREE) 1994 { 1995 left_length = build_tree_list (NULL_TREE, left_length); 1996 TREE_CHAIN (right_tree) = left_length; 1997 } 1998 1999 if (right_length != NULL_TREE) 2000 { 2001 right_length = build_tree_list (NULL_TREE, right_length); 2002 if (left_length != NULL_TREE) 2003 TREE_CHAIN (left_length) = right_length; 2004 else 2005 TREE_CHAIN (right_tree) = right_length; 2006 } 2007 2008 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree, 2009 dest_tree, dest, dest_used, callee_commons, 2010 scalar_args, hook); 2011} 2012#endif 2013 2014/* Return ptr/length args for char subexpression 2015 2016 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF 2017 subexpressions by constructing the appropriate trees for the ptr-to- 2018 character-text and length-of-character-text arguments in a calling 2019 sequence. 2020 2021 Note that if with_null is TRUE, and the expression is an opCONTER, 2022 a null byte is appended to the string. */ 2023 2024#if FFECOM_targetCURRENT == FFECOM_targetGCC 2025static void 2026ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 2027{ 2028 tree item; 2029 tree high; 2030 ffetargetCharacter1 val; 2031 ffetargetCharacterSize newlen; 2032 2033 switch (ffebld_op (expr)) 2034 { 2035 case FFEBLD_opCONTER: 2036 val = ffebld_constant_character1 (ffebld_conter (expr)); 2037 newlen = ffetarget_length_character1 (val); 2038 if (with_null) 2039 { 2040 /* Begin FFETARGET-NULL-KLUDGE. */ 2041 if (newlen != 0) 2042 ++newlen; 2043 } 2044 *length = build_int_2 (newlen, 0); 2045 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 2046 high = build_int_2 (newlen, 0); 2047 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; 2048 item = build_string (newlen, 2049 ffetarget_text_character1 (val)); 2050 /* End FFETARGET-NULL-KLUDGE. */ 2051 TREE_TYPE (item) 2052 = build_type_variant 2053 (build_array_type 2054 (char_type_node, 2055 build_range_type 2056 (ffecom_f2c_ftnlen_type_node, 2057 ffecom_f2c_ftnlen_one_node, 2058 high)), 2059 1, 0); 2060 TREE_CONSTANT (item) = 1; 2061 TREE_STATIC (item) = 1; 2062 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), 2063 item); 2064 break; 2065 2066 case FFEBLD_opSYMTER: 2067 { 2068 ffesymbol s = ffebld_symter (expr); 2069 2070 item = ffesymbol_hook (s).decl_tree; 2071 if (item == NULL_TREE) 2072 { 2073 s = ffecom_sym_transform_ (s); 2074 item = ffesymbol_hook (s).decl_tree; 2075 } 2076 if (ffesymbol_kind (s) == FFEINFO_kindENTITY) 2077 { 2078 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) 2079 *length = ffesymbol_hook (s).length_tree; 2080 else 2081 { 2082 *length = build_int_2 (ffesymbol_size (s), 0); 2083 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 2084 } 2085 } 2086 else if (item == error_mark_node) 2087 *length = error_mark_node; 2088 else 2089 /* FFEINFO_kindFUNCTION. */ 2090 *length = NULL_TREE; 2091 if (!ffesymbol_hook (s).addr 2092 && (item != error_mark_node)) 2093 item = ffecom_1 (ADDR_EXPR, 2094 build_pointer_type (TREE_TYPE (item)), 2095 item); 2096 } 2097 break; 2098 2099 case FFEBLD_opARRAYREF: 2100 { 2101 ffecom_char_args_ (&item, length, ffebld_left (expr)); 2102 2103 if (item == error_mark_node || *length == error_mark_node) 2104 { 2105 item = *length = error_mark_node; 2106 break; 2107 } 2108 2109 item = ffecom_arrayref_ (item, expr, 1); 2110 } 2111 break; 2112 2113 case FFEBLD_opSUBSTR: 2114 { 2115 ffebld start; 2116 ffebld end; 2117 ffebld thing = ffebld_right (expr); 2118 tree start_tree; 2119 tree end_tree; 2120 char *char_name; 2121 ffebld left_symter; 2122 tree array; 2123 2124 assert (ffebld_op (thing) == FFEBLD_opITEM); 2125 start = ffebld_head (thing); 2126 thing = ffebld_trail (thing); 2127 assert (ffebld_trail (thing) == NULL); 2128 end = ffebld_head (thing); 2129 2130 /* Determine name for pretty-printing range-check errors. */ 2131 for (left_symter = ffebld_left (expr); 2132 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF; 2133 left_symter = ffebld_left (left_symter)) 2134 ; 2135 if (ffebld_op (left_symter) == FFEBLD_opSYMTER) 2136 char_name = ffesymbol_text (ffebld_symter (left_symter)); 2137 else 2138 char_name = "[expr?]"; 2139 2140 ffecom_char_args_ (&item, length, ffebld_left (expr)); 2141 2142 if (item == error_mark_node || *length == error_mark_node) 2143 { 2144 item = *length = error_mark_node; 2145 break; 2146 } 2147 2148 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); 2149 2150 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */ 2151 2152 if (start == NULL) 2153 { 2154 if (end == NULL) 2155 ; 2156 else 2157 { 2158 end_tree = ffecom_expr (end); 2159 if (ffe_is_subscript_check ()) 2160 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, 2161 char_name); 2162 end_tree = convert (ffecom_f2c_ftnlen_type_node, 2163 end_tree); 2164 2165 if (end_tree == error_mark_node) 2166 { 2167 item = *length = error_mark_node; 2168 break; 2169 } 2170 2171 *length = end_tree; 2172 } 2173 } 2174 else 2175 { 2176 start_tree = ffecom_expr (start); 2177 if (ffe_is_subscript_check ()) 2178 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0, 2179 char_name); 2180 start_tree = convert (ffecom_f2c_ftnlen_type_node, 2181 start_tree); 2182 2183 if (start_tree == error_mark_node) 2184 { 2185 item = *length = error_mark_node; 2186 break; 2187 } 2188 2189 start_tree = ffecom_save_tree (start_tree); 2190 2191 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item), 2192 item, 2193 ffecom_2 (MINUS_EXPR, 2194 TREE_TYPE (start_tree), 2195 start_tree, 2196 ffecom_f2c_ftnlen_one_node)); 2197 2198 if (end == NULL) 2199 { 2200 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 2201 ffecom_f2c_ftnlen_one_node, 2202 ffecom_2 (MINUS_EXPR, 2203 ffecom_f2c_ftnlen_type_node, 2204 *length, 2205 start_tree)); 2206 } 2207 else 2208 { 2209 end_tree = ffecom_expr (end); 2210 if (ffe_is_subscript_check ()) 2211 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, 2212 char_name); 2213 end_tree = convert (ffecom_f2c_ftnlen_type_node, 2214 end_tree); 2215 2216 if (end_tree == error_mark_node) 2217 { 2218 item = *length = error_mark_node; 2219 break; 2220 } 2221 2222 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 2223 ffecom_f2c_ftnlen_one_node, 2224 ffecom_2 (MINUS_EXPR, 2225 ffecom_f2c_ftnlen_type_node, 2226 end_tree, start_tree)); 2227 } 2228 } 2229 } 2230 break; 2231 2232 case FFEBLD_opFUNCREF: 2233 { 2234 ffesymbol s = ffebld_symter (ffebld_left (expr)); 2235 tree tempvar; 2236 tree args; 2237 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr)); 2238 ffecomGfrt ix; 2239 2240 if (size == FFETARGET_charactersizeNONE) 2241 /* ~~Kludge alert! This should someday be fixed. */ 2242 size = 24; 2243 2244 *length = build_int_2 (size, 0); 2245 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 2246 2247 if (ffeinfo_where (ffebld_info (ffebld_left (expr))) 2248 == FFEINFO_whereINTRINSIC) 2249 { 2250 if (size == 1) 2251 { 2252 /* Invocation of an intrinsic returning CHARACTER*1. */ 2253 item = ffecom_expr_intrinsic_ (expr, NULL_TREE, 2254 NULL, NULL); 2255 break; 2256 } 2257 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr))); 2258 assert (ix != FFECOM_gfrt); 2259 item = ffecom_gfrt_tree_ (ix); 2260 } 2261 else 2262 { 2263 ix = FFECOM_gfrt; 2264 item = ffesymbol_hook (s).decl_tree; 2265 if (item == NULL_TREE) 2266 { 2267 s = ffecom_sym_transform_ (s); 2268 item = ffesymbol_hook (s).decl_tree; 2269 } 2270 if (item == error_mark_node) 2271 { 2272 item = *length = error_mark_node; 2273 break; 2274 } 2275 2276 if (!ffesymbol_hook (s).addr) 2277 item = ffecom_1_fn (item); 2278 } 2279 2280#ifdef HOHO 2281 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE); 2282#else 2283 tempvar = ffebld_nonter_hook (expr); 2284 assert (tempvar); 2285#endif 2286 tempvar = ffecom_1 (ADDR_EXPR, 2287 build_pointer_type (TREE_TYPE (tempvar)), 2288 tempvar); 2289 2290 args = build_tree_list (NULL_TREE, tempvar); 2291 2292 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */ 2293 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr)); 2294 else 2295 { 2296 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length); 2297 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) 2298 { 2299 TREE_CHAIN (TREE_CHAIN (args)) 2300 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix), 2301 ffebld_right (expr)); 2302 } 2303 else 2304 { 2305 TREE_CHAIN (TREE_CHAIN (args)) 2306 = ffecom_list_ptr_to_expr (ffebld_right (expr)); 2307 } 2308 } 2309 2310 item = ffecom_3s (CALL_EXPR, 2311 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))), 2312 item, args, NULL_TREE); 2313 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, 2314 tempvar); 2315 } 2316 break; 2317 2318 case FFEBLD_opCONVERT: 2319 2320 ffecom_char_args_ (&item, length, ffebld_left (expr)); 2321 2322 if (item == error_mark_node || *length == error_mark_node) 2323 { 2324 item = *length = error_mark_node; 2325 break; 2326 } 2327 2328 if ((ffebld_size_known (ffebld_left (expr)) 2329 == FFETARGET_charactersizeNONE) 2330 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr)))) 2331 { /* Possible blank-padding needed, copy into 2332 temporary. */ 2333 tree tempvar; 2334 tree args; 2335 tree newlen; 2336 2337#ifdef HOHO 2338 tempvar = ffecom_make_tempvar (char_type_node, 2339 ffebld_size (expr), -1); 2340#else 2341 tempvar = ffebld_nonter_hook (expr); 2342 assert (tempvar); 2343#endif 2344 tempvar = ffecom_1 (ADDR_EXPR, 2345 build_pointer_type (TREE_TYPE (tempvar)), 2346 tempvar); 2347 2348 newlen = build_int_2 (ffebld_size (expr), 0); 2349 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node; 2350 2351 args = build_tree_list (NULL_TREE, tempvar); 2352 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item); 2353 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen); 2354 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args))) 2355 = build_tree_list (NULL_TREE, *length); 2356 2357 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE); 2358 TREE_SIDE_EFFECTS (item) = 1; 2359 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item), 2360 tempvar); 2361 *length = newlen; 2362 } 2363 else 2364 { /* Just truncate the length. */ 2365 *length = build_int_2 (ffebld_size (expr), 0); 2366 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 2367 } 2368 break; 2369 2370 default: 2371 assert ("bad op for single char arg expr" == NULL); 2372 item = NULL_TREE; 2373 break; 2374 } 2375 2376 *xitem = item; 2377} 2378#endif 2379 2380/* Check the size of the type to be sure it doesn't overflow the 2381 "portable" capacities of the compiler back end. `dummy' types 2382 can generally overflow the normal sizes as long as the computations 2383 themselves don't overflow. A particular target of the back end 2384 must still enforce its size requirements, though, and the back 2385 end takes care of this in stor-layout.c. */ 2386 2387#if FFECOM_targetCURRENT == FFECOM_targetGCC 2388static tree 2389ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy) 2390{ 2391 if (TREE_CODE (type) == ERROR_MARK) 2392 return type; 2393 2394 if (TYPE_SIZE (type) == NULL_TREE) 2395 return type; 2396 2397 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST) 2398 return type; 2399 2400 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0) 2401 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0)) 2402 || TREE_OVERFLOW (TYPE_SIZE (type))))) 2403 { 2404 ffebad_start (FFEBAD_ARRAY_LARGE); 2405 ffebad_string (ffesymbol_text (s)); 2406 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); 2407 ffebad_finish (); 2408 2409 return error_mark_node; 2410 } 2411 2412 return type; 2413} 2414#endif 2415 2416/* Builds a length argument (PARM_DECL). Also wraps type in an array type 2417 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if 2418 known, length_arg if not known (FFETARGET_charactersizeNONE). */ 2419 2420#if FFECOM_targetCURRENT == FFECOM_targetGCC 2421static tree 2422ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s) 2423{ 2424 ffetargetCharacterSize sz = ffesymbol_size (s); 2425 tree highval; 2426 tree tlen; 2427 tree type = *xtype; 2428 2429 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) 2430 tlen = NULL_TREE; /* A statement function, no length passed. */ 2431 else 2432 { 2433 if (ffesymbol_where (s) == FFEINFO_whereDUMMY) 2434 tlen = ffecom_get_invented_identifier ("__g77_length_%s", 2435 ffesymbol_text (s), -1); 2436 else 2437 tlen = ffecom_get_invented_identifier ("__g77_%s", 2438 "length", -1); 2439 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node); 2440#if BUILT_FOR_270 2441 DECL_ARTIFICIAL (tlen) = 1; 2442#endif 2443 } 2444 2445 if (sz == FFETARGET_charactersizeNONE) 2446 { 2447 assert (tlen != NULL_TREE); 2448 highval = variable_size (tlen); 2449 } 2450 else 2451 { 2452 highval = build_int_2 (sz, 0); 2453 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node; 2454 } 2455 2456 type = build_array_type (type, 2457 build_range_type (ffecom_f2c_ftnlen_type_node, 2458 ffecom_f2c_ftnlen_one_node, 2459 highval)); 2460 2461 *xtype = type; 2462 return tlen; 2463} 2464 2465#endif 2466/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs 2467 2468 ffecomConcatList_ catlist; 2469 ffebld expr; // expr of CHARACTER basictype. 2470 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max 2471 catlist = ffecom_concat_list_gather_(catlist,expr,max); 2472 2473 Scans expr for character subexpressions, updates and returns catlist 2474 accordingly. */ 2475 2476#if FFECOM_targetCURRENT == FFECOM_targetGCC 2477static ffecomConcatList_ 2478ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr, 2479 ffetargetCharacterSize max) 2480{ 2481 ffetargetCharacterSize sz; 2482 2483recurse: /* :::::::::::::::::::: */ 2484 2485 if (expr == NULL) 2486 return catlist; 2487 2488 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max)) 2489 return catlist; /* Don't append any more items. */ 2490 2491 switch (ffebld_op (expr)) 2492 { 2493 case FFEBLD_opCONTER: 2494 case FFEBLD_opSYMTER: 2495 case FFEBLD_opARRAYREF: 2496 case FFEBLD_opFUNCREF: 2497 case FFEBLD_opSUBSTR: 2498 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand 2499 if they don't need to preserve it. */ 2500 if (catlist.count == catlist.max) 2501 { /* Make a (larger) list. */ 2502 ffebld *newx; 2503 int newmax; 2504 2505 newmax = (catlist.max == 0) ? 8 : catlist.max * 2; 2506 newx = malloc_new_ks (malloc_pool_image (), "catlist", 2507 newmax * sizeof (newx[0])); 2508 if (catlist.max != 0) 2509 { 2510 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0])); 2511 malloc_kill_ks (malloc_pool_image (), catlist.exprs, 2512 catlist.max * sizeof (newx[0])); 2513 } 2514 catlist.max = newmax; 2515 catlist.exprs = newx; 2516 } 2517 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE) 2518 catlist.minlen += sz; 2519 else 2520 ++catlist.minlen; /* Not true for F90; can be 0 length. */ 2521 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE) 2522 catlist.maxlen = sz; 2523 else 2524 catlist.maxlen += sz; 2525 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max)) 2526 { /* This item overlaps (or is beyond) the end 2527 of the destination. */ 2528 switch (ffebld_op (expr)) 2529 { 2530 case FFEBLD_opCONTER: 2531 case FFEBLD_opSYMTER: 2532 case FFEBLD_opARRAYREF: 2533 case FFEBLD_opFUNCREF: 2534 case FFEBLD_opSUBSTR: 2535 /* ~~Do useful truncations here. */ 2536 break; 2537 2538 default: 2539 assert ("op changed or inconsistent switches!" == NULL); 2540 break; 2541 } 2542 } 2543 catlist.exprs[catlist.count++] = expr; 2544 return catlist; 2545 2546 case FFEBLD_opPAREN: 2547 expr = ffebld_left (expr); 2548 goto recurse; /* :::::::::::::::::::: */ 2549 2550 case FFEBLD_opCONCATENATE: 2551 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max); 2552 expr = ffebld_right (expr); 2553 goto recurse; /* :::::::::::::::::::: */ 2554 2555#if 0 /* Breaks passing small actual arg to larger 2556 dummy arg of sfunc */ 2557 case FFEBLD_opCONVERT: 2558 expr = ffebld_left (expr); 2559 { 2560 ffetargetCharacterSize cmax; 2561 2562 cmax = catlist.len + ffebld_size_known (expr); 2563 2564 if ((max == FFETARGET_charactersizeNONE) || (max > cmax)) 2565 max = cmax; 2566 } 2567 goto recurse; /* :::::::::::::::::::: */ 2568#endif 2569 2570 case FFEBLD_opANY: 2571 return catlist; 2572 2573 default: 2574 assert ("bad op in _gather_" == NULL); 2575 return catlist; 2576 } 2577} 2578 2579#endif 2580/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs 2581 2582 ffecomConcatList_ catlist; 2583 ffecom_concat_list_kill_(catlist); 2584 2585 Anything allocated within the list info is deallocated. */ 2586 2587#if FFECOM_targetCURRENT == FFECOM_targetGCC 2588static void 2589ffecom_concat_list_kill_ (ffecomConcatList_ catlist) 2590{ 2591 if (catlist.max != 0) 2592 malloc_kill_ks (malloc_pool_image (), catlist.exprs, 2593 catlist.max * sizeof (catlist.exprs[0])); 2594} 2595 2596#endif 2597/* Make list of concatenated string exprs. 2598 2599 Returns a flattened list of concatenated subexpressions given a 2600 tree of such expressions. */ 2601 2602#if FFECOM_targetCURRENT == FFECOM_targetGCC 2603static ffecomConcatList_ 2604ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max) 2605{ 2606 ffecomConcatList_ catlist; 2607 2608 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0; 2609 return ffecom_concat_list_gather_ (catlist, expr, max); 2610} 2611 2612#endif 2613 2614/* Provide some kind of useful info on member of aggregate area, 2615 since current g77/gcc technology does not provide debug info 2616 on these members. */ 2617 2618#if FFECOM_targetCURRENT == FFECOM_targetGCC 2619static void 2620ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member, 2621 tree member_type UNUSED, ffetargetOffset offset) 2622{ 2623 tree value; 2624 tree decl; 2625 int len; 2626 char *buff; 2627 char space[120]; 2628#if 0 2629 tree type_id; 2630 2631 for (type_id = member_type; 2632 TREE_CODE (type_id) != IDENTIFIER_NODE; 2633 ) 2634 { 2635 switch (TREE_CODE (type_id)) 2636 { 2637 case INTEGER_TYPE: 2638 case REAL_TYPE: 2639 type_id = TYPE_NAME (type_id); 2640 break; 2641 2642 case ARRAY_TYPE: 2643 case COMPLEX_TYPE: 2644 type_id = TREE_TYPE (type_id); 2645 break; 2646 2647 default: 2648 assert ("no IDENTIFIER_NODE for type!" == NULL); 2649 type_id = error_mark_node; 2650 break; 2651 } 2652 } 2653#endif 2654 2655 if (ffecom_transform_only_dummies_ 2656 || !ffe_is_debug_kludge ()) 2657 return; /* Can't do this yet, maybe later. */ 2658 2659 len = 60 2660 + strlen (aggr_type) 2661 + IDENTIFIER_LENGTH (DECL_NAME (aggr)); 2662#if 0 2663 + IDENTIFIER_LENGTH (type_id); 2664#endif 2665 2666 if (((size_t) len) >= ARRAY_SIZE (space)) 2667 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1); 2668 else 2669 buff = &space[0]; 2670 2671 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes", 2672 aggr_type, 2673 IDENTIFIER_POINTER (DECL_NAME (aggr)), 2674 (long int) offset); 2675 2676 value = build_string (len, buff); 2677 TREE_TYPE (value) 2678 = build_type_variant (build_array_type (char_type_node, 2679 build_range_type 2680 (integer_type_node, 2681 integer_one_node, 2682 build_int_2 (strlen (buff), 0))), 2683 1, 0); 2684 decl = build_decl (VAR_DECL, 2685 ffecom_get_identifier_ (ffesymbol_text (member)), 2686 TREE_TYPE (value)); 2687 TREE_CONSTANT (decl) = 1; 2688 TREE_STATIC (decl) = 1; 2689 DECL_INITIAL (decl) = error_mark_node; 2690 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */ 2691 decl = start_decl (decl, FALSE); 2692 finish_decl (decl, value, FALSE); 2693 2694 if (buff != &space[0]) 2695 malloc_kill_ks (malloc_pool_image (), buff, len + 1); 2696} 2697#endif 2698 2699/* ffecom_do_entry_ -- Do compilation of a particular entrypoint 2700 2701 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself 2702 int i; // entry# for this entrypoint (used by master fn) 2703 ffecom_do_entrypoint_(s,i); 2704 2705 Makes a public entry point that calls our private master fn (already 2706 compiled). */ 2707 2708#if FFECOM_targetCURRENT == FFECOM_targetGCC 2709static void 2710ffecom_do_entry_ (ffesymbol fn, int entrynum) 2711{ 2712 ffebld item; 2713 tree type; /* Type of function. */ 2714 tree multi_retval; /* Var holding return value (union). */ 2715 tree result; /* Var holding result. */ 2716 ffeinfoBasictype bt; 2717 ffeinfoKindtype kt; 2718 ffeglobal g; 2719 ffeglobalType gt; 2720 bool charfunc; /* All entry points return same type 2721 CHARACTER. */ 2722 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */ 2723 bool multi; /* Master fn has multiple return types. */ 2724 bool altreturning = FALSE; /* This entry point has alternate returns. */ 2725 int yes; 2726 int old_lineno = lineno; 2727 char *old_input_filename = input_filename; 2728 2729 input_filename = ffesymbol_where_filename (fn); 2730 lineno = ffesymbol_where_filelinenum (fn); 2731 2732 /* c-parse.y indeed does call suspend_momentary and not only ignores the 2733 return value, but also never calls resume_momentary, when starting an 2734 outer function (see "fndef:", "setspecs:", and so on). So g77 does the 2735 same thing. It shouldn't be a problem since start_function calls 2736 temporary_allocation, but it might be necessary. If it causes a problem 2737 here, then maybe there's a bug lurking in gcc. NOTE: This identical 2738 comment appears twice in thist file. */ 2739 2740 suspend_momentary (); 2741 2742 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */ 2743 2744 switch (ffecom_primary_entry_kind_) 2745 { 2746 case FFEINFO_kindFUNCTION: 2747 2748 /* Determine actual return type for function. */ 2749 2750 gt = FFEGLOBAL_typeFUNC; 2751 bt = ffesymbol_basictype (fn); 2752 kt = ffesymbol_kindtype (fn); 2753 if (bt == FFEINFO_basictypeNONE) 2754 { 2755 ffeimplic_establish_symbol (fn); 2756 if (ffesymbol_funcresult (fn) != NULL) 2757 ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); 2758 bt = ffesymbol_basictype (fn); 2759 kt = ffesymbol_kindtype (fn); 2760 } 2761 2762 if (bt == FFEINFO_basictypeCHARACTER) 2763 charfunc = TRUE, cmplxfunc = FALSE; 2764 else if ((bt == FFEINFO_basictypeCOMPLEX) 2765 && ffesymbol_is_f2c (fn)) 2766 charfunc = FALSE, cmplxfunc = TRUE; 2767 else 2768 charfunc = cmplxfunc = FALSE; 2769 2770 if (charfunc) 2771 type = ffecom_tree_fun_type_void; 2772 else if (ffesymbol_is_f2c (fn)) 2773 type = ffecom_tree_fun_type[bt][kt]; 2774 else 2775 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); 2776 2777 if ((type == NULL_TREE) 2778 || (TREE_TYPE (type) == NULL_TREE)) 2779 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ 2780 2781 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE); 2782 break; 2783 2784 case FFEINFO_kindSUBROUTINE: 2785 gt = FFEGLOBAL_typeSUBR; 2786 bt = FFEINFO_basictypeNONE; 2787 kt = FFEINFO_kindtypeNONE; 2788 if (ffecom_is_altreturning_) 2789 { /* Am _I_ altreturning? */ 2790 for (item = ffesymbol_dummyargs (fn); 2791 item != NULL; 2792 item = ffebld_trail (item)) 2793 { 2794 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR) 2795 { 2796 altreturning = TRUE; 2797 break; 2798 } 2799 } 2800 if (altreturning) 2801 type = ffecom_tree_subr_type; 2802 else 2803 type = ffecom_tree_fun_type_void; 2804 } 2805 else 2806 type = ffecom_tree_fun_type_void; 2807 charfunc = FALSE; 2808 cmplxfunc = FALSE; 2809 multi = FALSE; 2810 break; 2811 2812 default: 2813 assert ("say what??" == NULL); 2814 /* Fall through. */ 2815 case FFEINFO_kindANY: 2816 gt = FFEGLOBAL_typeANY; 2817 bt = FFEINFO_basictypeNONE; 2818 kt = FFEINFO_kindtypeNONE; 2819 type = error_mark_node; 2820 charfunc = FALSE; 2821 cmplxfunc = FALSE; 2822 multi = FALSE; 2823 break; 2824 } 2825 2826 /* build_decl uses the current lineno and input_filename to set the decl 2827 source info. So, I've putzed with ffestd and ffeste code to update that 2828 source info to point to the appropriate statement just before calling 2829 ffecom_do_entrypoint (which calls this fn). */ 2830 2831 start_function (ffecom_get_external_identifier_ (fn), 2832 type, 2833 0, /* nested/inline */ 2834 1); /* TREE_PUBLIC */ 2835 2836 if (((g = ffesymbol_global (fn)) != NULL) 2837 && ((ffeglobal_type (g) == gt) 2838 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) 2839 { 2840 ffeglobal_set_hook (g, current_function_decl); 2841 } 2842 2843 /* Reset args in master arg list so they get retransitioned. */ 2844 2845 for (item = ffecom_master_arglist_; 2846 item != NULL; 2847 item = ffebld_trail (item)) 2848 { 2849 ffebld arg; 2850 ffesymbol s; 2851 2852 arg = ffebld_head (item); 2853 if (ffebld_op (arg) != FFEBLD_opSYMTER) 2854 continue; /* Alternate return or some such thing. */ 2855 s = ffebld_symter (arg); 2856 ffesymbol_hook (s).decl_tree = NULL_TREE; 2857 ffesymbol_hook (s).length_tree = NULL_TREE; 2858 } 2859 2860 /* Build dummy arg list for this entry point. */ 2861 2862 yes = suspend_momentary (); 2863 2864 if (charfunc || cmplxfunc) 2865 { /* Prepend arg for where result goes. */ 2866 tree type; 2867 tree length; 2868 2869 if (charfunc) 2870 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; 2871 else 2872 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; 2873 2874 result = ffecom_get_invented_identifier ("__g77_%s", 2875 "result", -1); 2876 2877 /* Make length arg _and_ enhance type info for CHAR arg itself. */ 2878 2879 if (charfunc) 2880 length = ffecom_char_enhance_arg_ (&type, fn); 2881 else 2882 length = NULL_TREE; /* Not ref'd if !charfunc. */ 2883 2884 type = build_pointer_type (type); 2885 result = build_decl (PARM_DECL, result, type); 2886 2887 push_parm_decl (result); 2888 ffecom_func_result_ = result; 2889 2890 if (charfunc) 2891 { 2892 push_parm_decl (length); 2893 ffecom_func_length_ = length; 2894 } 2895 } 2896 else 2897 result = DECL_RESULT (current_function_decl); 2898 2899 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE); 2900 2901 resume_momentary (yes); 2902 2903 store_parm_decls (0); 2904 2905 ffecom_start_compstmt (); 2906 /* Disallow temp vars at this level. */ 2907 current_binding_level->prep_state = 2; 2908 2909 /* Make local var to hold return type for multi-type master fn. */ 2910 2911 if (multi) 2912 { 2913 yes = suspend_momentary (); 2914 2915 multi_retval = ffecom_get_invented_identifier ("__g77_%s", 2916 "multi_retval", -1); 2917 multi_retval = build_decl (VAR_DECL, multi_retval, 2918 ffecom_multi_type_node_); 2919 multi_retval = start_decl (multi_retval, FALSE); 2920 finish_decl (multi_retval, NULL_TREE, FALSE); 2921 2922 resume_momentary (yes); 2923 } 2924 else 2925 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */ 2926 2927 /* Here we emit the actual code for the entry point. */ 2928 2929 { 2930 ffebld list; 2931 ffebld arg; 2932 ffesymbol s; 2933 tree arglist = NULL_TREE; 2934 tree *plist = &arglist; 2935 tree prepend; 2936 tree call; 2937 tree actarg; 2938 tree master_fn; 2939 2940 /* Prepare actual arg list based on master arg list. */ 2941 2942 for (list = ffecom_master_arglist_; 2943 list != NULL; 2944 list = ffebld_trail (list)) 2945 { 2946 arg = ffebld_head (list); 2947 if (ffebld_op (arg) != FFEBLD_opSYMTER) 2948 continue; 2949 s = ffebld_symter (arg); 2950 if (ffesymbol_hook (s).decl_tree == NULL_TREE 2951 || ffesymbol_hook (s).decl_tree == error_mark_node) 2952 actarg = null_pointer_node; /* We don't have this arg. */ 2953 else 2954 actarg = ffesymbol_hook (s).decl_tree; 2955 *plist = build_tree_list (NULL_TREE, actarg); 2956 plist = &TREE_CHAIN (*plist); 2957 } 2958 2959 /* This code appends the length arguments for character 2960 variables/arrays. */ 2961 2962 for (list = ffecom_master_arglist_; 2963 list != NULL; 2964 list = ffebld_trail (list)) 2965 { 2966 arg = ffebld_head (list); 2967 if (ffebld_op (arg) != FFEBLD_opSYMTER) 2968 continue; 2969 s = ffebld_symter (arg); 2970 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) 2971 continue; /* Only looking for CHARACTER arguments. */ 2972 if (ffesymbol_kind (s) != FFEINFO_kindENTITY) 2973 continue; /* Only looking for variables and arrays. */ 2974 if (ffesymbol_hook (s).length_tree == NULL_TREE 2975 || ffesymbol_hook (s).length_tree == error_mark_node) 2976 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */ 2977 else 2978 actarg = ffesymbol_hook (s).length_tree; 2979 *plist = build_tree_list (NULL_TREE, actarg); 2980 plist = &TREE_CHAIN (*plist); 2981 } 2982 2983 /* Prepend character-value return info to actual arg list. */ 2984 2985 if (charfunc) 2986 { 2987 prepend = build_tree_list (NULL_TREE, ffecom_func_result_); 2988 TREE_CHAIN (prepend) 2989 = build_tree_list (NULL_TREE, ffecom_func_length_); 2990 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist; 2991 arglist = prepend; 2992 } 2993 2994 /* Prepend multi-type return value to actual arg list. */ 2995 2996 if (multi) 2997 { 2998 prepend 2999 = build_tree_list (NULL_TREE, 3000 ffecom_1 (ADDR_EXPR, 3001 build_pointer_type (TREE_TYPE (multi_retval)), 3002 multi_retval)); 3003 TREE_CHAIN (prepend) = arglist; 3004 arglist = prepend; 3005 } 3006 3007 /* Prepend my entry-point number to the actual arg list. */ 3008 3009 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0)); 3010 TREE_CHAIN (prepend) = arglist; 3011 arglist = prepend; 3012 3013 /* Build the call to the master function. */ 3014 3015 master_fn = ffecom_1_fn (ffecom_previous_function_decl_); 3016 call = ffecom_3s (CALL_EXPR, 3017 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))), 3018 master_fn, arglist, NULL_TREE); 3019 3020 /* Decide whether the master function is a function or subroutine, and 3021 handle the return value for my entry point. */ 3022 3023 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) 3024 && !altreturning)) 3025 { 3026 expand_expr_stmt (call); 3027 expand_null_return (); 3028 } 3029 else if (multi && cmplxfunc) 3030 { 3031 expand_expr_stmt (call); 3032 result 3033 = ffecom_1 (INDIRECT_REF, 3034 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), 3035 result); 3036 result = ffecom_modify (NULL_TREE, result, 3037 ffecom_2 (COMPONENT_REF, TREE_TYPE (result), 3038 multi_retval, 3039 ffecom_multi_fields_[bt][kt])); 3040 expand_expr_stmt (result); 3041 expand_null_return (); 3042 } 3043 else if (multi) 3044 { 3045 expand_expr_stmt (call); 3046 result 3047 = ffecom_modify (NULL_TREE, result, 3048 convert (TREE_TYPE (result), 3049 ffecom_2 (COMPONENT_REF, 3050 ffecom_tree_type[bt][kt], 3051 multi_retval, 3052 ffecom_multi_fields_[bt][kt]))); 3053 expand_return (result); 3054 } 3055 else if (cmplxfunc) 3056 { 3057 result 3058 = ffecom_1 (INDIRECT_REF, 3059 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), 3060 result); 3061 result = ffecom_modify (NULL_TREE, result, call); 3062 expand_expr_stmt (result); 3063 expand_null_return (); 3064 } 3065 else 3066 { 3067 result = ffecom_modify (NULL_TREE, 3068 result, 3069 convert (TREE_TYPE (result), 3070 call)); 3071 expand_return (result); 3072 } 3073 3074 clear_momentary (); 3075 } 3076 3077 ffecom_end_compstmt (); 3078 3079 finish_function (0); 3080 3081 lineno = old_lineno; 3082 input_filename = old_input_filename; 3083 3084 ffecom_doing_entry_ = FALSE; 3085} 3086 3087#endif 3088/* Transform expr into gcc tree with possible destination 3089 3090 Recursive descent on expr while making corresponding tree nodes and 3091 attaching type info and such. If destination supplied and compatible 3092 with temporary that would be made in certain cases, temporary isn't 3093 made, destination used instead, and dest_used flag set TRUE. */ 3094 3095#if FFECOM_targetCURRENT == FFECOM_targetGCC 3096static tree 3097ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 3098 bool *dest_used, bool assignp, bool widenp) 3099{ 3100 tree item; 3101 tree list; 3102 tree args; 3103 ffeinfoBasictype bt; 3104 ffeinfoKindtype kt; 3105 tree t; 3106 tree dt; /* decl_tree for an ffesymbol. */ 3107 tree tree_type, tree_type_x; 3108 tree left, right; 3109 ffesymbol s; 3110 enum tree_code code; 3111 3112 assert (expr != NULL); 3113 3114 if (dest_used != NULL) 3115 *dest_used = FALSE; 3116 3117 bt = ffeinfo_basictype (ffebld_info (expr)); 3118 kt = ffeinfo_kindtype (ffebld_info (expr)); 3119 tree_type = ffecom_tree_type[bt][kt]; 3120 3121 /* Widen integral arithmetic as desired while preserving signedness. */ 3122 tree_type_x = NULL_TREE; 3123 if (widenp && tree_type 3124 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT 3125 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) 3126 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); 3127 3128 switch (ffebld_op (expr)) 3129 { 3130 case FFEBLD_opACCTER: 3131 { 3132 ffebitCount i; 3133 ffebit bits = ffebld_accter_bits (expr); 3134 ffetargetOffset source_offset = 0; 3135 ffetargetOffset dest_offset = ffebld_accter_pad (expr); 3136 tree purpose; 3137 3138 assert (dest_offset == 0 3139 || (bt == FFEINFO_basictypeCHARACTER 3140 && kt == FFEINFO_kindtypeCHARACTER1)); 3141 3142 list = item = NULL; 3143 for (;;) 3144 { 3145 ffebldConstantUnion cu; 3146 ffebitCount length; 3147 bool value; 3148 ffebldConstantArray ca = ffebld_accter (expr); 3149 3150 ffebit_test (bits, source_offset, &value, &length); 3151 if (length == 0) 3152 break; 3153 3154 if (value) 3155 { 3156 for (i = 0; i < length; ++i) 3157 { 3158 cu = ffebld_constantarray_get (ca, bt, kt, 3159 source_offset + i); 3160 3161 t = ffecom_constantunion (&cu, bt, kt, tree_type); 3162 3163 if (i == 0 3164 && dest_offset != 0) 3165 purpose = build_int_2 (dest_offset, 0); 3166 else 3167 purpose = NULL_TREE; 3168 3169 if (list == NULL_TREE) 3170 list = item = build_tree_list (purpose, t); 3171 else 3172 { 3173 TREE_CHAIN (item) = build_tree_list (purpose, t); 3174 item = TREE_CHAIN (item); 3175 } 3176 } 3177 } 3178 source_offset += length; 3179 dest_offset += length; 3180 } 3181 } 3182 3183 item = build_int_2 ((ffebld_accter_size (expr) 3184 + ffebld_accter_pad (expr)) - 1, 0); 3185 ffebit_kill (ffebld_accter_bits (expr)); 3186 TREE_TYPE (item) = ffecom_integer_type_node; 3187 item 3188 = build_array_type 3189 (tree_type, 3190 build_range_type (ffecom_integer_type_node, 3191 ffecom_integer_zero_node, 3192 item)); 3193 list = build (CONSTRUCTOR, item, NULL_TREE, list); 3194 TREE_CONSTANT (list) = 1; 3195 TREE_STATIC (list) = 1; 3196 return list; 3197 3198 case FFEBLD_opARRTER: 3199 { 3200 ffetargetOffset i; 3201 3202 list = NULL_TREE; 3203 if (ffebld_arrter_pad (expr) == 0) 3204 item = NULL_TREE; 3205 else 3206 { 3207 assert (bt == FFEINFO_basictypeCHARACTER 3208 && kt == FFEINFO_kindtypeCHARACTER1); 3209 3210 /* Becomes PURPOSE first time through loop. */ 3211 item = build_int_2 (ffebld_arrter_pad (expr), 0); 3212 } 3213 3214 for (i = 0; i < ffebld_arrter_size (expr); ++i) 3215 { 3216 ffebldConstantUnion cu 3217 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i); 3218 3219 t = ffecom_constantunion (&cu, bt, kt, tree_type); 3220 3221 if (list == NULL_TREE) 3222 /* Assume item is PURPOSE first time through loop. */ 3223 list = item = build_tree_list (item, t); 3224 else 3225 { 3226 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); 3227 item = TREE_CHAIN (item); 3228 } 3229 } 3230 } 3231 3232 item = build_int_2 ((ffebld_arrter_size (expr) 3233 + ffebld_arrter_pad (expr)) - 1, 0); 3234 TREE_TYPE (item) = ffecom_integer_type_node; 3235 item 3236 = build_array_type 3237 (tree_type, 3238 build_range_type (ffecom_integer_type_node, 3239 ffecom_integer_zero_node, 3240 item)); 3241 list = build (CONSTRUCTOR, item, NULL_TREE, list); 3242 TREE_CONSTANT (list) = 1; 3243 TREE_STATIC (list) = 1; 3244 return list; 3245 3246 case FFEBLD_opCONTER: 3247 assert (ffebld_conter_pad (expr) == 0); 3248 item 3249 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)), 3250 bt, kt, tree_type); 3251 return item; 3252 3253 case FFEBLD_opSYMTER: 3254 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE) 3255 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE)) 3256 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */ 3257 s = ffebld_symter (expr); 3258 t = ffesymbol_hook (s).decl_tree; 3259 3260 if (assignp) 3261 { /* ASSIGN'ed-label expr. */ 3262 if (ffe_is_ugly_assign ()) 3263 { 3264 /* User explicitly wants ASSIGN'ed variables to be at the same 3265 memory address as the variables when used in non-ASSIGN 3266 contexts. That can make old, arcane, non-standard code 3267 work, but don't try to do it when a pointer wouldn't fit 3268 in the normal variable (take other approach, and warn, 3269 instead). */ 3270 3271 if (t == NULL_TREE) 3272 { 3273 s = ffecom_sym_transform_ (s); 3274 t = ffesymbol_hook (s).decl_tree; 3275 assert (t != NULL_TREE); 3276 } 3277 3278 if (t == error_mark_node) 3279 return t; 3280 3281 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t))) 3282 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) 3283 { 3284 if (ffesymbol_hook (s).addr) 3285 t = ffecom_1 (INDIRECT_REF, 3286 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); 3287 return t; 3288 } 3289 3290 if (ffesymbol_hook (s).assign_tree == NULL_TREE) 3291 { 3292 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling", 3293 FFEBAD_severityWARNING); 3294 ffebad_string (ffesymbol_text (s)); 3295 ffebad_here (0, ffesymbol_where_line (s), 3296 ffesymbol_where_column (s)); 3297 ffebad_finish (); 3298 } 3299 } 3300 3301 /* Don't use the normal variable's tree for ASSIGN, though mark 3302 it as in the system header (housekeeping). Use an explicit, 3303 specially created sibling that is known to be wide enough 3304 to hold pointers to labels. */ 3305 3306 if (t != NULL_TREE 3307 && TREE_CODE (t) == VAR_DECL) 3308 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */ 3309 3310 t = ffesymbol_hook (s).assign_tree; 3311 if (t == NULL_TREE) 3312 { 3313 s = ffecom_sym_transform_assign_ (s); 3314 t = ffesymbol_hook (s).assign_tree; 3315 assert (t != NULL_TREE); 3316 } 3317 } 3318 else 3319 { 3320 if (t == NULL_TREE) 3321 { 3322 s = ffecom_sym_transform_ (s); 3323 t = ffesymbol_hook (s).decl_tree; 3324 assert (t != NULL_TREE); 3325 } 3326 if (ffesymbol_hook (s).addr) 3327 t = ffecom_1 (INDIRECT_REF, 3328 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); 3329 } 3330 return t; 3331 3332 case FFEBLD_opARRAYREF: 3333 return ffecom_arrayref_ (NULL_TREE, expr, 0); 3334 3335 case FFEBLD_opUPLUS: 3336 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3337 return ffecom_1 (NOP_EXPR, tree_type, left); 3338 3339 case FFEBLD_opPAREN: 3340 /* ~~~Make sure Fortran rules respected here */ 3341 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3342 return ffecom_1 (NOP_EXPR, tree_type, left); 3343 3344 case FFEBLD_opUMINUS: 3345 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3346 if (tree_type_x) 3347 { 3348 tree_type = tree_type_x; 3349 left = convert (tree_type, left); 3350 } 3351 return ffecom_1 (NEGATE_EXPR, tree_type, left); 3352 3353 case FFEBLD_opADD: 3354 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3355 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); 3356 if (tree_type_x) 3357 { 3358 tree_type = tree_type_x; 3359 left = convert (tree_type, left); 3360 right = convert (tree_type, right); 3361 } 3362 return ffecom_2 (PLUS_EXPR, tree_type, left, right); 3363 3364 case FFEBLD_opSUBTRACT: 3365 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3366 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); 3367 if (tree_type_x) 3368 { 3369 tree_type = tree_type_x; 3370 left = convert (tree_type, left); 3371 right = convert (tree_type, right); 3372 } 3373 return ffecom_2 (MINUS_EXPR, tree_type, left, right); 3374 3375 case FFEBLD_opMULTIPLY: 3376 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3377 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); 3378 if (tree_type_x) 3379 { 3380 tree_type = tree_type_x; 3381 left = convert (tree_type, left); 3382 right = convert (tree_type, right); 3383 } 3384 return ffecom_2 (MULT_EXPR, tree_type, left, right); 3385 3386 case FFEBLD_opDIVIDE: 3387 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); 3388 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); 3389 if (tree_type_x) 3390 { 3391 tree_type = tree_type_x; 3392 left = convert (tree_type, left); 3393 right = convert (tree_type, right); 3394 } 3395 return ffecom_tree_divide_ (tree_type, left, right, 3396 dest_tree, dest, dest_used, 3397 ffebld_nonter_hook (expr)); 3398 3399 case FFEBLD_opPOWER: 3400 { 3401 ffebld left = ffebld_left (expr); 3402 ffebld right = ffebld_right (expr); 3403 ffecomGfrt code; 3404 ffeinfoKindtype rtkt; 3405 ffeinfoKindtype ltkt; 3406 3407 switch (ffeinfo_basictype (ffebld_info (right))) 3408 { 3409 case FFEINFO_basictypeINTEGER: 3410 if (1 || optimize) 3411 { 3412 item = ffecom_expr_power_integer_ (expr); 3413 if (item != NULL_TREE) 3414 return item; 3415 } 3416 3417 rtkt = FFEINFO_kindtypeINTEGER1; 3418 switch (ffeinfo_basictype (ffebld_info (left))) 3419 { 3420 case FFEINFO_basictypeINTEGER: 3421 if ((ffeinfo_kindtype (ffebld_info (left)) 3422 == FFEINFO_kindtypeINTEGER4) 3423 || (ffeinfo_kindtype (ffebld_info (right)) 3424 == FFEINFO_kindtypeINTEGER4)) 3425 { 3426 code = FFECOM_gfrtPOW_QQ; 3427 ltkt = FFEINFO_kindtypeINTEGER4; 3428 rtkt = FFEINFO_kindtypeINTEGER4; 3429 } 3430 else 3431 { 3432 code = FFECOM_gfrtPOW_II; 3433 ltkt = FFEINFO_kindtypeINTEGER1; 3434 } 3435 break; 3436 3437 case FFEINFO_basictypeREAL: 3438 if (ffeinfo_kindtype (ffebld_info (left)) 3439 == FFEINFO_kindtypeREAL1) 3440 { 3441 code = FFECOM_gfrtPOW_RI; 3442 ltkt = FFEINFO_kindtypeREAL1; 3443 } 3444 else 3445 { 3446 code = FFECOM_gfrtPOW_DI; 3447 ltkt = FFEINFO_kindtypeREAL2; 3448 } 3449 break; 3450 3451 case FFEINFO_basictypeCOMPLEX: 3452 if (ffeinfo_kindtype (ffebld_info (left)) 3453 == FFEINFO_kindtypeREAL1) 3454 { 3455 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ 3456 ltkt = FFEINFO_kindtypeREAL1; 3457 } 3458 else 3459 { 3460 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */ 3461 ltkt = FFEINFO_kindtypeREAL2; 3462 } 3463 break; 3464 3465 default: 3466 assert ("bad pow_*i" == NULL); 3467 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ 3468 ltkt = FFEINFO_kindtypeREAL1; 3469 break; 3470 } 3471 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt) 3472 left = ffeexpr_convert (left, NULL, NULL, 3473 ffeinfo_basictype (ffebld_info (left)), 3474 ltkt, 0, 3475 FFETARGET_charactersizeNONE, 3476 FFEEXPR_contextLET); 3477 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt) 3478 right = ffeexpr_convert (right, NULL, NULL, 3479 FFEINFO_basictypeINTEGER, 3480 rtkt, 0, 3481 FFETARGET_charactersizeNONE, 3482 FFEEXPR_contextLET); 3483 break; 3484 3485 case FFEINFO_basictypeREAL: 3486 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) 3487 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL, 3488 FFEINFO_kindtypeREALDOUBLE, 0, 3489 FFETARGET_charactersizeNONE, 3490 FFEEXPR_contextLET); 3491 if (ffeinfo_kindtype (ffebld_info (right)) 3492 == FFEINFO_kindtypeREAL1) 3493 right = ffeexpr_convert (right, NULL, NULL, 3494 FFEINFO_basictypeREAL, 3495 FFEINFO_kindtypeREALDOUBLE, 0, 3496 FFETARGET_charactersizeNONE, 3497 FFEEXPR_contextLET); 3498 code = FFECOM_gfrtPOW_DD; 3499 break; 3500 3501 case FFEINFO_basictypeCOMPLEX: 3502 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) 3503 left = ffeexpr_convert (left, NULL, NULL, 3504 FFEINFO_basictypeCOMPLEX, 3505 FFEINFO_kindtypeREALDOUBLE, 0, 3506 FFETARGET_charactersizeNONE, 3507 FFEEXPR_contextLET); 3508 if (ffeinfo_kindtype (ffebld_info (right)) 3509 == FFEINFO_kindtypeREAL1) 3510 right = ffeexpr_convert (right, NULL, NULL, 3511 FFEINFO_basictypeCOMPLEX, 3512 FFEINFO_kindtypeREALDOUBLE, 0, 3513 FFETARGET_charactersizeNONE, 3514 FFEEXPR_contextLET); 3515 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */ 3516 break; 3517 3518 default: 3519 assert ("bad pow_x*" == NULL); 3520 code = FFECOM_gfrtPOW_II; 3521 break; 3522 } 3523 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code), 3524 ffecom_gfrt_kindtype (code), 3525 (ffe_is_f2c_library () 3526 && ffecom_gfrt_complex_[code]), 3527 tree_type, left, right, 3528 dest_tree, dest, dest_used, 3529 NULL_TREE, FALSE, 3530 ffebld_nonter_hook (expr)); 3531 } 3532 3533 case FFEBLD_opNOT: 3534 switch (bt) 3535 { 3536 case FFEINFO_basictypeLOGICAL: 3537 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr))); 3538 return convert (tree_type, item); 3539 3540 case FFEINFO_basictypeINTEGER: 3541 return ffecom_1 (BIT_NOT_EXPR, tree_type, 3542 ffecom_expr (ffebld_left (expr))); 3543 3544 default: 3545 assert ("NOT bad basictype" == NULL); 3546 /* Fall through. */ 3547 case FFEINFO_basictypeANY: 3548 return error_mark_node; 3549 } 3550 break; 3551 3552 case FFEBLD_opFUNCREF: 3553 assert (ffeinfo_basictype (ffebld_info (expr)) 3554 != FFEINFO_basictypeCHARACTER); 3555 /* Fall through. */ 3556 case FFEBLD_opSUBRREF: 3557 if (ffeinfo_where (ffebld_info (ffebld_left (expr))) 3558 == FFEINFO_whereINTRINSIC) 3559 { /* Invocation of an intrinsic. */ 3560 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest, 3561 dest_used); 3562 return item; 3563 } 3564 s = ffebld_symter (ffebld_left (expr)); 3565 dt = ffesymbol_hook (s).decl_tree; 3566 if (dt == NULL_TREE) 3567 { 3568 s = ffecom_sym_transform_ (s); 3569 dt = ffesymbol_hook (s).decl_tree; 3570 } 3571 if (dt == error_mark_node) 3572 return dt; 3573 3574 if (ffesymbol_hook (s).addr) 3575 item = dt; 3576 else 3577 item = ffecom_1_fn (dt); 3578 3579 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) 3580 args = ffecom_list_expr (ffebld_right (expr)); 3581 else 3582 args = ffecom_list_ptr_to_expr (ffebld_right (expr)); 3583 3584 if (args == error_mark_node) 3585 return error_mark_node; 3586 3587 item = ffecom_call_ (item, kt, 3588 ffesymbol_is_f2c (s) 3589 && (bt == FFEINFO_basictypeCOMPLEX) 3590 && (ffesymbol_where (s) 3591 != FFEINFO_whereCONSTANT), 3592 tree_type, 3593 args, 3594 dest_tree, dest, dest_used, 3595 error_mark_node, FALSE, 3596 ffebld_nonter_hook (expr)); 3597 TREE_SIDE_EFFECTS (item) = 1; 3598 return item; 3599 3600 case FFEBLD_opAND: 3601 switch (bt) 3602 { 3603 case FFEINFO_basictypeLOGICAL: 3604 item 3605 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, 3606 ffecom_truth_value (ffecom_expr (ffebld_left (expr))), 3607 ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); 3608 return convert (tree_type, item); 3609 3610 case FFEINFO_basictypeINTEGER: 3611 return ffecom_2 (BIT_AND_EXPR, tree_type, 3612 ffecom_expr (ffebld_left (expr)), 3613 ffecom_expr (ffebld_right (expr))); 3614 3615 default: 3616 assert ("AND bad basictype" == NULL); 3617 /* Fall through. */ 3618 case FFEINFO_basictypeANY: 3619 return error_mark_node; 3620 } 3621 break; 3622 3623 case FFEBLD_opOR: 3624 switch (bt) 3625 { 3626 case FFEINFO_basictypeLOGICAL: 3627 item 3628 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, 3629 ffecom_truth_value (ffecom_expr (ffebld_left (expr))), 3630 ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); 3631 return convert (tree_type, item); 3632 3633 case FFEINFO_basictypeINTEGER: 3634 return ffecom_2 (BIT_IOR_EXPR, tree_type, 3635 ffecom_expr (ffebld_left (expr)), 3636 ffecom_expr (ffebld_right (expr))); 3637 3638 default: 3639 assert ("OR bad basictype" == NULL); 3640 /* Fall through. */ 3641 case FFEINFO_basictypeANY: 3642 return error_mark_node; 3643 } 3644 break; 3645 3646 case FFEBLD_opXOR: 3647 case FFEBLD_opNEQV: 3648 switch (bt) 3649 { 3650 case FFEINFO_basictypeLOGICAL: 3651 item 3652 = ffecom_2 (NE_EXPR, integer_type_node, 3653 ffecom_expr (ffebld_left (expr)), 3654 ffecom_expr (ffebld_right (expr))); 3655 return convert (tree_type, ffecom_truth_value (item)); 3656 3657 case FFEINFO_basictypeINTEGER: 3658 return ffecom_2 (BIT_XOR_EXPR, tree_type, 3659 ffecom_expr (ffebld_left (expr)), 3660 ffecom_expr (ffebld_right (expr))); 3661 3662 default: 3663 assert ("XOR/NEQV bad basictype" == NULL); 3664 /* Fall through. */ 3665 case FFEINFO_basictypeANY: 3666 return error_mark_node; 3667 } 3668 break; 3669 3670 case FFEBLD_opEQV: 3671 switch (bt) 3672 { 3673 case FFEINFO_basictypeLOGICAL: 3674 item 3675 = ffecom_2 (EQ_EXPR, integer_type_node, 3676 ffecom_expr (ffebld_left (expr)), 3677 ffecom_expr (ffebld_right (expr))); 3678 return convert (tree_type, ffecom_truth_value (item)); 3679 3680 case FFEINFO_basictypeINTEGER: 3681 return 3682 ffecom_1 (BIT_NOT_EXPR, tree_type, 3683 ffecom_2 (BIT_XOR_EXPR, tree_type, 3684 ffecom_expr (ffebld_left (expr)), 3685 ffecom_expr (ffebld_right (expr)))); 3686 3687 default: 3688 assert ("EQV bad basictype" == NULL); 3689 /* Fall through. */ 3690 case FFEINFO_basictypeANY: 3691 return error_mark_node; 3692 } 3693 break; 3694 3695 case FFEBLD_opCONVERT: 3696 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY) 3697 return error_mark_node; 3698 3699 switch (bt) 3700 { 3701 case FFEINFO_basictypeLOGICAL: 3702 case FFEINFO_basictypeINTEGER: 3703 case FFEINFO_basictypeREAL: 3704 return convert (tree_type, ffecom_expr (ffebld_left (expr))); 3705 3706 case FFEINFO_basictypeCOMPLEX: 3707 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 3708 { 3709 case FFEINFO_basictypeINTEGER: 3710 case FFEINFO_basictypeLOGICAL: 3711 case FFEINFO_basictypeREAL: 3712 item = ffecom_expr (ffebld_left (expr)); 3713 if (item == error_mark_node) 3714 return error_mark_node; 3715 /* convert() takes care of converting to the subtype first, 3716 at least in gcc-2.7.2. */ 3717 item = convert (tree_type, item); 3718 return item; 3719 3720 case FFEINFO_basictypeCOMPLEX: 3721 return convert (tree_type, ffecom_expr (ffebld_left (expr))); 3722 3723 default: 3724 assert ("CONVERT COMPLEX bad basictype" == NULL); 3725 /* Fall through. */ 3726 case FFEINFO_basictypeANY: 3727 return error_mark_node; 3728 } 3729 break; 3730 3731 default: 3732 assert ("CONVERT bad basictype" == NULL); 3733 /* Fall through. */ 3734 case FFEINFO_basictypeANY: 3735 return error_mark_node; 3736 } 3737 break; 3738 3739 case FFEBLD_opLT: 3740 code = LT_EXPR; 3741 goto relational; /* :::::::::::::::::::: */ 3742 3743 case FFEBLD_opLE: 3744 code = LE_EXPR; 3745 goto relational; /* :::::::::::::::::::: */ 3746 3747 case FFEBLD_opEQ: 3748 code = EQ_EXPR; 3749 goto relational; /* :::::::::::::::::::: */ 3750 3751 case FFEBLD_opNE: 3752 code = NE_EXPR; 3753 goto relational; /* :::::::::::::::::::: */ 3754 3755 case FFEBLD_opGT: 3756 code = GT_EXPR; 3757 goto relational; /* :::::::::::::::::::: */ 3758 3759 case FFEBLD_opGE: 3760 code = GE_EXPR; 3761 3762 relational: /* :::::::::::::::::::: */ 3763 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 3764 { 3765 case FFEINFO_basictypeLOGICAL: 3766 case FFEINFO_basictypeINTEGER: 3767 case FFEINFO_basictypeREAL: 3768 item = ffecom_2 (code, integer_type_node, 3769 ffecom_expr (ffebld_left (expr)), 3770 ffecom_expr (ffebld_right (expr))); 3771 return convert (tree_type, item); 3772 3773 case FFEINFO_basictypeCOMPLEX: 3774 assert (code == EQ_EXPR || code == NE_EXPR); 3775 { 3776 tree real_type; 3777 tree arg1 = ffecom_expr (ffebld_left (expr)); 3778 tree arg2 = ffecom_expr (ffebld_right (expr)); 3779 3780 if (arg1 == error_mark_node || arg2 == error_mark_node) 3781 return error_mark_node; 3782 3783 arg1 = ffecom_save_tree (arg1); 3784 arg2 = ffecom_save_tree (arg2); 3785 3786 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE) 3787 { 3788 real_type = TREE_TYPE (TREE_TYPE (arg1)); 3789 assert (real_type == TREE_TYPE (TREE_TYPE (arg2))); 3790 } 3791 else 3792 { 3793 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1))); 3794 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2)))); 3795 } 3796 3797 item 3798 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, 3799 ffecom_2 (EQ_EXPR, integer_type_node, 3800 ffecom_1 (REALPART_EXPR, real_type, arg1), 3801 ffecom_1 (REALPART_EXPR, real_type, arg2)), 3802 ffecom_2 (EQ_EXPR, integer_type_node, 3803 ffecom_1 (IMAGPART_EXPR, real_type, arg1), 3804 ffecom_1 (IMAGPART_EXPR, real_type, 3805 arg2))); 3806 if (code == EQ_EXPR) 3807 item = ffecom_truth_value (item); 3808 else 3809 item = ffecom_truth_value_invert (item); 3810 return convert (tree_type, item); 3811 } 3812 3813 case FFEINFO_basictypeCHARACTER: 3814 { 3815 ffebld left = ffebld_left (expr); 3816 ffebld right = ffebld_right (expr); 3817 tree left_tree; 3818 tree right_tree; 3819 tree left_length; 3820 tree right_length; 3821 3822 /* f2c run-time functions do the implicit blank-padding for us, 3823 so we don't usually have to implement blank-padding ourselves. 3824 (The exception is when we pass an argument to a separately 3825 compiled statement function -- if we know the arg is not the 3826 same length as the dummy, we must truncate or extend it. If 3827 we "inline" statement functions, that necessity goes away as 3828 well.) 3829 3830 Strip off the CONVERT operators that blank-pad. (Truncation by 3831 CONVERT shouldn't happen here, but it can happen in 3832 assignments.) */ 3833 3834 while (ffebld_op (left) == FFEBLD_opCONVERT) 3835 left = ffebld_left (left); 3836 while (ffebld_op (right) == FFEBLD_opCONVERT) 3837 right = ffebld_left (right); 3838 3839 left_tree = ffecom_arg_ptr_to_expr (left, &left_length); 3840 right_tree = ffecom_arg_ptr_to_expr (right, &right_length); 3841 3842 if (left_tree == error_mark_node || left_length == error_mark_node 3843 || right_tree == error_mark_node 3844 || right_length == error_mark_node) 3845 return error_mark_node; 3846 3847 if ((ffebld_size_known (left) == 1) 3848 && (ffebld_size_known (right) == 1)) 3849 { 3850 left_tree 3851 = ffecom_1 (INDIRECT_REF, 3852 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), 3853 left_tree); 3854 right_tree 3855 = ffecom_1 (INDIRECT_REF, 3856 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), 3857 right_tree); 3858 3859 item 3860 = ffecom_2 (code, integer_type_node, 3861 ffecom_2 (ARRAY_REF, 3862 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), 3863 left_tree, 3864 integer_one_node), 3865 ffecom_2 (ARRAY_REF, 3866 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), 3867 right_tree, 3868 integer_one_node)); 3869 } 3870 else 3871 { 3872 item = build_tree_list (NULL_TREE, left_tree); 3873 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree); 3874 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE, 3875 left_length); 3876 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) 3877 = build_tree_list (NULL_TREE, right_length); 3878 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE); 3879 item = ffecom_2 (code, integer_type_node, 3880 item, 3881 convert (TREE_TYPE (item), 3882 integer_zero_node)); 3883 } 3884 item = convert (tree_type, item); 3885 } 3886 3887 return item; 3888 3889 default: 3890 assert ("relational bad basictype" == NULL); 3891 /* Fall through. */ 3892 case FFEINFO_basictypeANY: 3893 return error_mark_node; 3894 } 3895 break; 3896 3897 case FFEBLD_opPERCENT_LOC: 3898 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list); 3899 return convert (tree_type, item); 3900 3901 case FFEBLD_opITEM: 3902 case FFEBLD_opSTAR: 3903 case FFEBLD_opBOUNDS: 3904 case FFEBLD_opREPEAT: 3905 case FFEBLD_opLABTER: 3906 case FFEBLD_opLABTOK: 3907 case FFEBLD_opIMPDO: 3908 case FFEBLD_opCONCATENATE: 3909 case FFEBLD_opSUBSTR: 3910 default: 3911 assert ("bad op" == NULL); 3912 /* Fall through. */ 3913 case FFEBLD_opANY: 3914 return error_mark_node; 3915 } 3916 3917#if 1 3918 assert ("didn't think anything got here anymore!!" == NULL); 3919#else 3920 switch (ffebld_arity (expr)) 3921 { 3922 case 2: 3923 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); 3924 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr)); 3925 if (TREE_OPERAND (item, 0) == error_mark_node 3926 || TREE_OPERAND (item, 1) == error_mark_node) 3927 return error_mark_node; 3928 break; 3929 3930 case 1: 3931 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); 3932 if (TREE_OPERAND (item, 0) == error_mark_node) 3933 return error_mark_node; 3934 break; 3935 3936 default: 3937 break; 3938 } 3939 3940 return fold (item); 3941#endif 3942} 3943 3944#endif 3945/* Returns the tree that does the intrinsic invocation. 3946 3947 Note: this function applies only to intrinsics returning 3948 CHARACTER*1 or non-CHARACTER results, and to intrinsic 3949 subroutines. */ 3950 3951#if FFECOM_targetCURRENT == FFECOM_targetGCC 3952static tree 3953ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 3954 ffebld dest, bool *dest_used) 3955{ 3956 tree expr_tree; 3957 tree saved_expr1; /* For those who need it. */ 3958 tree saved_expr2; /* For those who need it. */ 3959 ffeinfoBasictype bt; 3960 ffeinfoKindtype kt; 3961 tree tree_type; 3962 tree arg1_type; 3963 tree real_type; /* REAL type corresponding to COMPLEX. */ 3964 tree tempvar; 3965 ffebld list = ffebld_right (expr); /* List of (some) args. */ 3966 ffebld arg1; /* For handy reference. */ 3967 ffebld arg2; 3968 ffebld arg3; 3969 ffeintrinImp codegen_imp; 3970 ffecomGfrt gfrt; 3971 3972 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER); 3973 3974 if (dest_used != NULL) 3975 *dest_used = FALSE; 3976 3977 bt = ffeinfo_basictype (ffebld_info (expr)); 3978 kt = ffeinfo_kindtype (ffebld_info (expr)); 3979 tree_type = ffecom_tree_type[bt][kt]; 3980 3981 if (list != NULL) 3982 { 3983 arg1 = ffebld_head (list); 3984 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY) 3985 return error_mark_node; 3986 if ((list = ffebld_trail (list)) != NULL) 3987 { 3988 arg2 = ffebld_head (list); 3989 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY) 3990 return error_mark_node; 3991 if ((list = ffebld_trail (list)) != NULL) 3992 { 3993 arg3 = ffebld_head (list); 3994 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY) 3995 return error_mark_node; 3996 } 3997 else 3998 arg3 = NULL; 3999 } 4000 else 4001 arg2 = arg3 = NULL; 4002 } 4003 else 4004 arg1 = arg2 = arg3 = NULL; 4005 4006 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3 4007 args. This is used by the MAX/MIN expansions. */ 4008 4009 if (arg1 != NULL) 4010 arg1_type = ffecom_tree_type 4011 [ffeinfo_basictype (ffebld_info (arg1))] 4012 [ffeinfo_kindtype (ffebld_info (arg1))]; 4013 else 4014 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs 4015 here. */ 4016 4017 /* There are several ways for each of the cases in the following switch 4018 statements to exit (from simplest to use to most complicated): 4019 4020 break; (when expr_tree == NULL) 4021 4022 A standard call is made to the specific intrinsic just as if it had been 4023 passed in as a dummy procedure and called as any old procedure. This 4024 method can produce slower code but in some cases it's the easiest way for 4025 now. However, if a (presumably faster) direct call is available, 4026 that is used, so this is the easiest way in many more cases now. 4027 4028 gfrt = FFECOM_gfrtWHATEVER; 4029 break; 4030 4031 gfrt contains the gfrt index of a library function to call, passing the 4032 argument(s) by value rather than by reference. Used when a more 4033 careful choice of library function is needed than that provided 4034 by the vanilla `break;'. 4035 4036 return expr_tree; 4037 4038 The expr_tree has been completely set up and is ready to be returned 4039 as is. No further actions are taken. Use this when the tree is not 4040 in the simple form for one of the arity_n labels. */ 4041 4042 /* For info on how the switch statement cases were written, see the files 4043 enclosed in comments below the switch statement. */ 4044 4045 codegen_imp = ffebld_symter_implementation (ffebld_left (expr)); 4046 gfrt = ffeintrin_gfrt_direct (codegen_imp); 4047 if (gfrt == FFECOM_gfrt) 4048 gfrt = ffeintrin_gfrt_indirect (codegen_imp); 4049 4050 switch (codegen_imp) 4051 { 4052 case FFEINTRIN_impABS: 4053 case FFEINTRIN_impCABS: 4054 case FFEINTRIN_impCDABS: 4055 case FFEINTRIN_impDABS: 4056 case FFEINTRIN_impIABS: 4057 if (ffeinfo_basictype (ffebld_info (arg1)) 4058 == FFEINFO_basictypeCOMPLEX) 4059 { 4060 if (kt == FFEINFO_kindtypeREAL1) 4061 gfrt = FFECOM_gfrtCABS; 4062 else if (kt == FFEINFO_kindtypeREAL2) 4063 gfrt = FFECOM_gfrtCDABS; 4064 break; 4065 } 4066 return ffecom_1 (ABS_EXPR, tree_type, 4067 convert (tree_type, ffecom_expr (arg1))); 4068 4069 case FFEINTRIN_impACOS: 4070 case FFEINTRIN_impDACOS: 4071 break; 4072 4073 case FFEINTRIN_impAIMAG: 4074 case FFEINTRIN_impDIMAG: 4075 case FFEINTRIN_impIMAGPART: 4076 if (TREE_CODE (arg1_type) == COMPLEX_TYPE) 4077 arg1_type = TREE_TYPE (arg1_type); 4078 else 4079 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); 4080 4081 return 4082 convert (tree_type, 4083 ffecom_1 (IMAGPART_EXPR, arg1_type, 4084 ffecom_expr (arg1))); 4085 4086 case FFEINTRIN_impAINT: 4087 case FFEINTRIN_impDINT: 4088#if 0 4089 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */ 4090 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1)); 4091#else /* in the meantime, must use floor to avoid range problems with ints */ 4092 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */ 4093 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); 4094 return 4095 convert (tree_type, 4096 ffecom_3 (COND_EXPR, double_type_node, 4097 ffecom_truth_value 4098 (ffecom_2 (GE_EXPR, integer_type_node, 4099 saved_expr1, 4100 convert (arg1_type, 4101 ffecom_float_zero_))), 4102 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, 4103 build_tree_list (NULL_TREE, 4104 convert (double_type_node, 4105 saved_expr1)), 4106 NULL_TREE), 4107 ffecom_1 (NEGATE_EXPR, double_type_node, 4108 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, 4109 build_tree_list (NULL_TREE, 4110 convert (double_type_node, 4111 ffecom_1 (NEGATE_EXPR, 4112 arg1_type, 4113 saved_expr1))), 4114 NULL_TREE) 4115 )) 4116 ); 4117#endif 4118 4119 case FFEINTRIN_impANINT: 4120 case FFEINTRIN_impDNINT: 4121#if 0 /* This way of doing it won't handle real 4122 numbers of large magnitudes. */ 4123 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); 4124 expr_tree = convert (tree_type, 4125 convert (integer_type_node, 4126 ffecom_3 (COND_EXPR, tree_type, 4127 ffecom_truth_value 4128 (ffecom_2 (GE_EXPR, 4129 integer_type_node, 4130 saved_expr1, 4131 ffecom_float_zero_)), 4132 ffecom_2 (PLUS_EXPR, 4133 tree_type, 4134 saved_expr1, 4135 ffecom_float_half_), 4136 ffecom_2 (MINUS_EXPR, 4137 tree_type, 4138 saved_expr1, 4139 ffecom_float_half_)))); 4140 return expr_tree; 4141#else /* So we instead call floor. */ 4142 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */ 4143 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); 4144 return 4145 convert (tree_type, 4146 ffecom_3 (COND_EXPR, double_type_node, 4147 ffecom_truth_value 4148 (ffecom_2 (GE_EXPR, integer_type_node, 4149 saved_expr1, 4150 convert (arg1_type, 4151 ffecom_float_zero_))), 4152 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, 4153 build_tree_list (NULL_TREE, 4154 convert (double_type_node, 4155 ffecom_2 (PLUS_EXPR, 4156 arg1_type, 4157 saved_expr1, 4158 convert (arg1_type, 4159 ffecom_float_half_)))), 4160 NULL_TREE), 4161 ffecom_1 (NEGATE_EXPR, double_type_node, 4162 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, 4163 build_tree_list (NULL_TREE, 4164 convert (double_type_node, 4165 ffecom_2 (MINUS_EXPR, 4166 arg1_type, 4167 convert (arg1_type, 4168 ffecom_float_half_), 4169 saved_expr1))), 4170 NULL_TREE)) 4171 ) 4172 ); 4173#endif 4174 4175 case FFEINTRIN_impASIN: 4176 case FFEINTRIN_impDASIN: 4177 case FFEINTRIN_impATAN: 4178 case FFEINTRIN_impDATAN: 4179 case FFEINTRIN_impATAN2: 4180 case FFEINTRIN_impDATAN2: 4181 break; 4182 4183 case FFEINTRIN_impCHAR: 4184 case FFEINTRIN_impACHAR: 4185#ifdef HOHO 4186 tempvar = ffecom_make_tempvar (char_type_node, 1, -1); 4187#else 4188 tempvar = ffebld_nonter_hook (expr); 4189 assert (tempvar); 4190#endif 4191 { 4192 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar))); 4193 4194 expr_tree = ffecom_modify (tmv, 4195 ffecom_2 (ARRAY_REF, tmv, tempvar, 4196 integer_one_node), 4197 convert (tmv, ffecom_expr (arg1))); 4198 } 4199 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), 4200 expr_tree, 4201 tempvar); 4202 expr_tree = ffecom_1 (ADDR_EXPR, 4203 build_pointer_type (TREE_TYPE (expr_tree)), 4204 expr_tree); 4205 return expr_tree; 4206 4207 case FFEINTRIN_impCMPLX: 4208 case FFEINTRIN_impDCMPLX: 4209 if (arg2 == NULL) 4210 return 4211 convert (tree_type, ffecom_expr (arg1)); 4212 4213 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; 4214 return 4215 ffecom_2 (COMPLEX_EXPR, tree_type, 4216 convert (real_type, ffecom_expr (arg1)), 4217 convert (real_type, 4218 ffecom_expr (arg2))); 4219 4220 case FFEINTRIN_impCOMPLEX: 4221 return 4222 ffecom_2 (COMPLEX_EXPR, tree_type, 4223 ffecom_expr (arg1), 4224 ffecom_expr (arg2)); 4225 4226 case FFEINTRIN_impCONJG: 4227 case FFEINTRIN_impDCONJG: 4228 { 4229 tree arg1_tree; 4230 4231 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; 4232 arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); 4233 return 4234 ffecom_2 (COMPLEX_EXPR, tree_type, 4235 ffecom_1 (REALPART_EXPR, real_type, arg1_tree), 4236 ffecom_1 (NEGATE_EXPR, real_type, 4237 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree))); 4238 } 4239 4240 case FFEINTRIN_impCOS: 4241 case FFEINTRIN_impCCOS: 4242 case FFEINTRIN_impCDCOS: 4243 case FFEINTRIN_impDCOS: 4244 if (bt == FFEINFO_basictypeCOMPLEX) 4245 { 4246 if (kt == FFEINFO_kindtypeREAL1) 4247 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */ 4248 else if (kt == FFEINFO_kindtypeREAL2) 4249 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */ 4250 } 4251 break; 4252 4253 case FFEINTRIN_impCOSH: 4254 case FFEINTRIN_impDCOSH: 4255 break; 4256 4257 case FFEINTRIN_impDBLE: 4258 case FFEINTRIN_impDFLOAT: 4259 case FFEINTRIN_impDREAL: 4260 case FFEINTRIN_impFLOAT: 4261 case FFEINTRIN_impIDINT: 4262 case FFEINTRIN_impIFIX: 4263 case FFEINTRIN_impINT2: 4264 case FFEINTRIN_impINT8: 4265 case FFEINTRIN_impINT: 4266 case FFEINTRIN_impLONG: 4267 case FFEINTRIN_impREAL: 4268 case FFEINTRIN_impSHORT: 4269 case FFEINTRIN_impSNGL: 4270 return convert (tree_type, ffecom_expr (arg1)); 4271 4272 case FFEINTRIN_impDIM: 4273 case FFEINTRIN_impDDIM: 4274 case FFEINTRIN_impIDIM: 4275 saved_expr1 = ffecom_save_tree (convert (tree_type, 4276 ffecom_expr (arg1))); 4277 saved_expr2 = ffecom_save_tree (convert (tree_type, 4278 ffecom_expr (arg2))); 4279 return 4280 ffecom_3 (COND_EXPR, tree_type, 4281 ffecom_truth_value 4282 (ffecom_2 (GT_EXPR, integer_type_node, 4283 saved_expr1, 4284 saved_expr2)), 4285 ffecom_2 (MINUS_EXPR, tree_type, 4286 saved_expr1, 4287 saved_expr2), 4288 convert (tree_type, ffecom_float_zero_)); 4289 4290 case FFEINTRIN_impDPROD: 4291 return 4292 ffecom_2 (MULT_EXPR, tree_type, 4293 convert (tree_type, ffecom_expr (arg1)), 4294 convert (tree_type, ffecom_expr (arg2))); 4295 4296 case FFEINTRIN_impEXP: 4297 case FFEINTRIN_impCDEXP: 4298 case FFEINTRIN_impCEXP: 4299 case FFEINTRIN_impDEXP: 4300 if (bt == FFEINFO_basictypeCOMPLEX) 4301 { 4302 if (kt == FFEINFO_kindtypeREAL1) 4303 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */ 4304 else if (kt == FFEINFO_kindtypeREAL2) 4305 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */ 4306 } 4307 break; 4308 4309 case FFEINTRIN_impICHAR: 4310 case FFEINTRIN_impIACHAR: 4311#if 0 /* The simple approach. */ 4312 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1); 4313 expr_tree 4314 = ffecom_1 (INDIRECT_REF, 4315 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), 4316 expr_tree); 4317 expr_tree 4318 = ffecom_2 (ARRAY_REF, 4319 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), 4320 expr_tree, 4321 integer_one_node); 4322 return convert (tree_type, expr_tree); 4323#else /* The more interesting (and more optimal) approach. */ 4324 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1); 4325 expr_tree = ffecom_3 (COND_EXPR, tree_type, 4326 saved_expr1, 4327 expr_tree, 4328 convert (tree_type, integer_zero_node)); 4329 return expr_tree; 4330#endif 4331 4332 case FFEINTRIN_impINDEX: 4333 break; 4334 4335 case FFEINTRIN_impLEN: 4336#if 0 4337 break; /* The simple approach. */ 4338#else 4339 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */ 4340#endif 4341 4342 case FFEINTRIN_impLGE: 4343 case FFEINTRIN_impLGT: 4344 case FFEINTRIN_impLLE: 4345 case FFEINTRIN_impLLT: 4346 break; 4347 4348 case FFEINTRIN_impLOG: 4349 case FFEINTRIN_impALOG: 4350 case FFEINTRIN_impCDLOG: 4351 case FFEINTRIN_impCLOG: 4352 case FFEINTRIN_impDLOG: 4353 if (bt == FFEINFO_basictypeCOMPLEX) 4354 { 4355 if (kt == FFEINFO_kindtypeREAL1) 4356 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */ 4357 else if (kt == FFEINFO_kindtypeREAL2) 4358 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */ 4359 } 4360 break; 4361 4362 case FFEINTRIN_impLOG10: 4363 case FFEINTRIN_impALOG10: 4364 case FFEINTRIN_impDLOG10: 4365 if (gfrt != FFECOM_gfrt) 4366 break; /* Already picked one, stick with it. */ 4367 4368 if (kt == FFEINFO_kindtypeREAL1) 4369 gfrt = FFECOM_gfrtALOG10; 4370 else if (kt == FFEINFO_kindtypeREAL2) 4371 gfrt = FFECOM_gfrtDLOG10; 4372 break; 4373 4374 case FFEINTRIN_impMAX: 4375 case FFEINTRIN_impAMAX0: 4376 case FFEINTRIN_impAMAX1: 4377 case FFEINTRIN_impDMAX1: 4378 case FFEINTRIN_impMAX0: 4379 case FFEINTRIN_impMAX1: 4380 if (bt != ffeinfo_basictype (ffebld_info (arg1))) 4381 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); 4382 else 4383 arg1_type = tree_type; 4384 expr_tree = ffecom_2 (MAX_EXPR, arg1_type, 4385 convert (arg1_type, ffecom_expr (arg1)), 4386 convert (arg1_type, ffecom_expr (arg2))); 4387 for (; list != NULL; list = ffebld_trail (list)) 4388 { 4389 if ((ffebld_head (list) == NULL) 4390 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) 4391 continue; 4392 expr_tree = ffecom_2 (MAX_EXPR, arg1_type, 4393 expr_tree, 4394 convert (arg1_type, 4395 ffecom_expr (ffebld_head (list)))); 4396 } 4397 return convert (tree_type, expr_tree); 4398 4399 case FFEINTRIN_impMIN: 4400 case FFEINTRIN_impAMIN0: 4401 case FFEINTRIN_impAMIN1: 4402 case FFEINTRIN_impDMIN1: 4403 case FFEINTRIN_impMIN0: 4404 case FFEINTRIN_impMIN1: 4405 if (bt != ffeinfo_basictype (ffebld_info (arg1))) 4406 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); 4407 else 4408 arg1_type = tree_type; 4409 expr_tree = ffecom_2 (MIN_EXPR, arg1_type, 4410 convert (arg1_type, ffecom_expr (arg1)), 4411 convert (arg1_type, ffecom_expr (arg2))); 4412 for (; list != NULL; list = ffebld_trail (list)) 4413 { 4414 if ((ffebld_head (list) == NULL) 4415 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) 4416 continue; 4417 expr_tree = ffecom_2 (MIN_EXPR, arg1_type, 4418 expr_tree, 4419 convert (arg1_type, 4420 ffecom_expr (ffebld_head (list)))); 4421 } 4422 return convert (tree_type, expr_tree); 4423 4424 case FFEINTRIN_impMOD: 4425 case FFEINTRIN_impAMOD: 4426 case FFEINTRIN_impDMOD: 4427 if (bt != FFEINFO_basictypeREAL) 4428 return ffecom_2 (TRUNC_MOD_EXPR, tree_type, 4429 convert (tree_type, ffecom_expr (arg1)), 4430 convert (tree_type, ffecom_expr (arg2))); 4431 4432 if (kt == FFEINFO_kindtypeREAL1) 4433 gfrt = FFECOM_gfrtAMOD; 4434 else if (kt == FFEINFO_kindtypeREAL2) 4435 gfrt = FFECOM_gfrtDMOD; 4436 break; 4437 4438 case FFEINTRIN_impNINT: 4439 case FFEINTRIN_impIDNINT: 4440#if 0 4441 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */ 4442 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1)); 4443#else 4444 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */ 4445 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); 4446 return 4447 convert (ffecom_integer_type_node, 4448 ffecom_3 (COND_EXPR, arg1_type, 4449 ffecom_truth_value 4450 (ffecom_2 (GE_EXPR, integer_type_node, 4451 saved_expr1, 4452 convert (arg1_type, 4453 ffecom_float_zero_))), 4454 ffecom_2 (PLUS_EXPR, arg1_type, 4455 saved_expr1, 4456 convert (arg1_type, 4457 ffecom_float_half_)), 4458 ffecom_2 (MINUS_EXPR, arg1_type, 4459 saved_expr1, 4460 convert (arg1_type, 4461 ffecom_float_half_)))); 4462#endif 4463 4464 case FFEINTRIN_impSIGN: 4465 case FFEINTRIN_impDSIGN: 4466 case FFEINTRIN_impISIGN: 4467 { 4468 tree arg2_tree = ffecom_expr (arg2); 4469 4470 saved_expr1 4471 = ffecom_save_tree 4472 (ffecom_1 (ABS_EXPR, tree_type, 4473 convert (tree_type, 4474 ffecom_expr (arg1)))); 4475 expr_tree 4476 = ffecom_3 (COND_EXPR, tree_type, 4477 ffecom_truth_value 4478 (ffecom_2 (GE_EXPR, integer_type_node, 4479 arg2_tree, 4480 convert (TREE_TYPE (arg2_tree), 4481 integer_zero_node))), 4482 saved_expr1, 4483 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1)); 4484 /* Make sure SAVE_EXPRs get referenced early enough. */ 4485 expr_tree 4486 = ffecom_2 (COMPOUND_EXPR, tree_type, 4487 convert (void_type_node, saved_expr1), 4488 expr_tree); 4489 } 4490 return expr_tree; 4491 4492 case FFEINTRIN_impSIN: 4493 case FFEINTRIN_impCDSIN: 4494 case FFEINTRIN_impCSIN: 4495 case FFEINTRIN_impDSIN: 4496 if (bt == FFEINFO_basictypeCOMPLEX) 4497 { 4498 if (kt == FFEINFO_kindtypeREAL1) 4499 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */ 4500 else if (kt == FFEINFO_kindtypeREAL2) 4501 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */ 4502 } 4503 break; 4504 4505 case FFEINTRIN_impSINH: 4506 case FFEINTRIN_impDSINH: 4507 break; 4508 4509 case FFEINTRIN_impSQRT: 4510 case FFEINTRIN_impCDSQRT: 4511 case FFEINTRIN_impCSQRT: 4512 case FFEINTRIN_impDSQRT: 4513 if (bt == FFEINFO_basictypeCOMPLEX) 4514 { 4515 if (kt == FFEINFO_kindtypeREAL1) 4516 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */ 4517 else if (kt == FFEINFO_kindtypeREAL2) 4518 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */ 4519 } 4520 break; 4521 4522 case FFEINTRIN_impTAN: 4523 case FFEINTRIN_impDTAN: 4524 case FFEINTRIN_impTANH: 4525 case FFEINTRIN_impDTANH: 4526 break; 4527 4528 case FFEINTRIN_impREALPART: 4529 if (TREE_CODE (arg1_type) == COMPLEX_TYPE) 4530 arg1_type = TREE_TYPE (arg1_type); 4531 else 4532 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); 4533 4534 return 4535 convert (tree_type, 4536 ffecom_1 (REALPART_EXPR, arg1_type, 4537 ffecom_expr (arg1))); 4538 4539 case FFEINTRIN_impIAND: 4540 case FFEINTRIN_impAND: 4541 return ffecom_2 (BIT_AND_EXPR, tree_type, 4542 convert (tree_type, 4543 ffecom_expr (arg1)), 4544 convert (tree_type, 4545 ffecom_expr (arg2))); 4546 4547 case FFEINTRIN_impIOR: 4548 case FFEINTRIN_impOR: 4549 return ffecom_2 (BIT_IOR_EXPR, tree_type, 4550 convert (tree_type, 4551 ffecom_expr (arg1)), 4552 convert (tree_type, 4553 ffecom_expr (arg2))); 4554 4555 case FFEINTRIN_impIEOR: 4556 case FFEINTRIN_impXOR: 4557 return ffecom_2 (BIT_XOR_EXPR, tree_type, 4558 convert (tree_type, 4559 ffecom_expr (arg1)), 4560 convert (tree_type, 4561 ffecom_expr (arg2))); 4562 4563 case FFEINTRIN_impLSHIFT: 4564 return ffecom_2 (LSHIFT_EXPR, tree_type, 4565 ffecom_expr (arg1), 4566 convert (integer_type_node, 4567 ffecom_expr (arg2))); 4568 4569 case FFEINTRIN_impRSHIFT: 4570 return ffecom_2 (RSHIFT_EXPR, tree_type, 4571 ffecom_expr (arg1), 4572 convert (integer_type_node, 4573 ffecom_expr (arg2))); 4574 4575 case FFEINTRIN_impNOT: 4576 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1)); 4577 4578 case FFEINTRIN_impBIT_SIZE: 4579 return convert (tree_type, TYPE_SIZE (arg1_type)); 4580 4581 case FFEINTRIN_impBTEST: 4582 { 4583 ffetargetLogical1 true; 4584 ffetargetLogical1 false; 4585 tree true_tree; 4586 tree false_tree; 4587 4588 ffetarget_logical1 (&true, TRUE); 4589 ffetarget_logical1 (&false, FALSE); 4590 if (true == 1) 4591 true_tree = convert (tree_type, integer_one_node); 4592 else 4593 true_tree = convert (tree_type, build_int_2 (true, 0)); 4594 if (false == 0) 4595 false_tree = convert (tree_type, integer_zero_node); 4596 else 4597 false_tree = convert (tree_type, build_int_2 (false, 0)); 4598 4599 return 4600 ffecom_3 (COND_EXPR, tree_type, 4601 ffecom_truth_value 4602 (ffecom_2 (EQ_EXPR, integer_type_node, 4603 ffecom_2 (BIT_AND_EXPR, arg1_type, 4604 ffecom_expr (arg1), 4605 ffecom_2 (LSHIFT_EXPR, arg1_type, 4606 convert (arg1_type, 4607 integer_one_node), 4608 convert (integer_type_node, 4609 ffecom_expr (arg2)))), 4610 convert (arg1_type, 4611 integer_zero_node))), 4612 false_tree, 4613 true_tree); 4614 } 4615 4616 case FFEINTRIN_impIBCLR: 4617 return 4618 ffecom_2 (BIT_AND_EXPR, tree_type, 4619 ffecom_expr (arg1), 4620 ffecom_1 (BIT_NOT_EXPR, tree_type, 4621 ffecom_2 (LSHIFT_EXPR, tree_type, 4622 convert (tree_type, 4623 integer_one_node), 4624 convert (integer_type_node, 4625 ffecom_expr (arg2))))); 4626 4627 case FFEINTRIN_impIBITS: 4628 { 4629 tree arg3_tree = ffecom_save_tree (convert (integer_type_node, 4630 ffecom_expr (arg3))); 4631 tree uns_type 4632 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; 4633 4634 expr_tree 4635 = ffecom_2 (BIT_AND_EXPR, tree_type, 4636 ffecom_2 (RSHIFT_EXPR, tree_type, 4637 ffecom_expr (arg1), 4638 convert (integer_type_node, 4639 ffecom_expr (arg2))), 4640 convert (tree_type, 4641 ffecom_2 (RSHIFT_EXPR, uns_type, 4642 ffecom_1 (BIT_NOT_EXPR, 4643 uns_type, 4644 convert (uns_type, 4645 integer_zero_node)), 4646 ffecom_2 (MINUS_EXPR, 4647 integer_type_node, 4648 TYPE_SIZE (uns_type), 4649 arg3_tree)))); 4650#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH 4651 expr_tree 4652 = ffecom_3 (COND_EXPR, tree_type, 4653 ffecom_truth_value 4654 (ffecom_2 (NE_EXPR, integer_type_node, 4655 arg3_tree, 4656 integer_zero_node)), 4657 expr_tree, 4658 convert (tree_type, integer_zero_node)); 4659#endif 4660 } 4661 return expr_tree; 4662 4663 case FFEINTRIN_impIBSET: 4664 return 4665 ffecom_2 (BIT_IOR_EXPR, tree_type, 4666 ffecom_expr (arg1), 4667 ffecom_2 (LSHIFT_EXPR, tree_type, 4668 convert (tree_type, integer_one_node), 4669 convert (integer_type_node, 4670 ffecom_expr (arg2)))); 4671 4672 case FFEINTRIN_impISHFT: 4673 { 4674 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); 4675 tree arg2_tree = ffecom_save_tree (convert (integer_type_node, 4676 ffecom_expr (arg2))); 4677 tree uns_type 4678 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; 4679 4680 expr_tree 4681 = ffecom_3 (COND_EXPR, tree_type, 4682 ffecom_truth_value 4683 (ffecom_2 (GE_EXPR, integer_type_node, 4684 arg2_tree, 4685 integer_zero_node)), 4686 ffecom_2 (LSHIFT_EXPR, tree_type, 4687 arg1_tree, 4688 arg2_tree), 4689 convert (tree_type, 4690 ffecom_2 (RSHIFT_EXPR, uns_type, 4691 convert (uns_type, arg1_tree), 4692 ffecom_1 (NEGATE_EXPR, 4693 integer_type_node, 4694 arg2_tree)))); 4695#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH 4696 expr_tree 4697 = ffecom_3 (COND_EXPR, tree_type, 4698 ffecom_truth_value 4699 (ffecom_2 (NE_EXPR, integer_type_node, 4700 arg2_tree, 4701 TYPE_SIZE (uns_type))), 4702 expr_tree, 4703 convert (tree_type, integer_zero_node)); 4704#endif 4705 /* Make sure SAVE_EXPRs get referenced early enough. */ 4706 expr_tree 4707 = ffecom_2 (COMPOUND_EXPR, tree_type, 4708 convert (void_type_node, arg1_tree), 4709 ffecom_2 (COMPOUND_EXPR, tree_type, 4710 convert (void_type_node, arg2_tree), 4711 expr_tree)); 4712 } 4713 return expr_tree; 4714 4715 case FFEINTRIN_impISHFTC: 4716 { 4717 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); 4718 tree arg2_tree = ffecom_save_tree (convert (integer_type_node, 4719 ffecom_expr (arg2))); 4720 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type) 4721 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3))); 4722 tree shift_neg; 4723 tree shift_pos; 4724 tree mask_arg1; 4725 tree masked_arg1; 4726 tree uns_type 4727 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; 4728 4729 mask_arg1 4730 = ffecom_2 (LSHIFT_EXPR, tree_type, 4731 ffecom_1 (BIT_NOT_EXPR, tree_type, 4732 convert (tree_type, integer_zero_node)), 4733 arg3_tree); 4734#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH 4735 mask_arg1 4736 = ffecom_3 (COND_EXPR, tree_type, 4737 ffecom_truth_value 4738 (ffecom_2 (NE_EXPR, integer_type_node, 4739 arg3_tree, 4740 TYPE_SIZE (uns_type))), 4741 mask_arg1, 4742 convert (tree_type, integer_zero_node)); 4743#endif 4744 mask_arg1 = ffecom_save_tree (mask_arg1); 4745 masked_arg1 4746 = ffecom_2 (BIT_AND_EXPR, tree_type, 4747 arg1_tree, 4748 ffecom_1 (BIT_NOT_EXPR, tree_type, 4749 mask_arg1)); 4750 masked_arg1 = ffecom_save_tree (masked_arg1); 4751 shift_neg 4752 = ffecom_2 (BIT_IOR_EXPR, tree_type, 4753 convert (tree_type, 4754 ffecom_2 (RSHIFT_EXPR, uns_type, 4755 convert (uns_type, masked_arg1), 4756 ffecom_1 (NEGATE_EXPR, 4757 integer_type_node, 4758 arg2_tree))), 4759 ffecom_2 (LSHIFT_EXPR, tree_type, 4760 arg1_tree, 4761 ffecom_2 (PLUS_EXPR, integer_type_node, 4762 arg2_tree, 4763 arg3_tree))); 4764 shift_pos 4765 = ffecom_2 (BIT_IOR_EXPR, tree_type, 4766 ffecom_2 (LSHIFT_EXPR, tree_type, 4767 arg1_tree, 4768 arg2_tree), 4769 convert (tree_type, 4770 ffecom_2 (RSHIFT_EXPR, uns_type, 4771 convert (uns_type, masked_arg1), 4772 ffecom_2 (MINUS_EXPR, 4773 integer_type_node, 4774 arg3_tree, 4775 arg2_tree)))); 4776 expr_tree 4777 = ffecom_3 (COND_EXPR, tree_type, 4778 ffecom_truth_value 4779 (ffecom_2 (LT_EXPR, integer_type_node, 4780 arg2_tree, 4781 integer_zero_node)), 4782 shift_neg, 4783 shift_pos); 4784 expr_tree 4785 = ffecom_2 (BIT_IOR_EXPR, tree_type, 4786 ffecom_2 (BIT_AND_EXPR, tree_type, 4787 mask_arg1, 4788 arg1_tree), 4789 ffecom_2 (BIT_AND_EXPR, tree_type, 4790 ffecom_1 (BIT_NOT_EXPR, tree_type, 4791 mask_arg1), 4792 expr_tree)); 4793 expr_tree 4794 = ffecom_3 (COND_EXPR, tree_type, 4795 ffecom_truth_value 4796 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, 4797 ffecom_2 (EQ_EXPR, integer_type_node, 4798 ffecom_1 (ABS_EXPR, 4799 integer_type_node, 4800 arg2_tree), 4801 arg3_tree), 4802 ffecom_2 (EQ_EXPR, integer_type_node, 4803 arg2_tree, 4804 integer_zero_node))), 4805 arg1_tree, 4806 expr_tree); 4807 /* Make sure SAVE_EXPRs get referenced early enough. */ 4808 expr_tree 4809 = ffecom_2 (COMPOUND_EXPR, tree_type, 4810 convert (void_type_node, arg1_tree), 4811 ffecom_2 (COMPOUND_EXPR, tree_type, 4812 convert (void_type_node, arg2_tree), 4813 ffecom_2 (COMPOUND_EXPR, tree_type, 4814 convert (void_type_node, 4815 mask_arg1), 4816 ffecom_2 (COMPOUND_EXPR, tree_type, 4817 convert (void_type_node, 4818 masked_arg1), 4819 expr_tree)))); 4820 expr_tree 4821 = ffecom_2 (COMPOUND_EXPR, tree_type, 4822 convert (void_type_node, 4823 arg3_tree), 4824 expr_tree); 4825 } 4826 return expr_tree; 4827 4828 case FFEINTRIN_impLOC: 4829 { 4830 tree arg1_tree = ffecom_expr (arg1); 4831 4832 expr_tree 4833 = convert (tree_type, 4834 ffecom_1 (ADDR_EXPR, 4835 build_pointer_type (TREE_TYPE (arg1_tree)), 4836 arg1_tree)); 4837 } 4838 return expr_tree; 4839 4840 case FFEINTRIN_impMVBITS: 4841 { 4842 tree arg1_tree; 4843 tree arg2_tree; 4844 tree arg3_tree; 4845 ffebld arg4 = ffebld_head (ffebld_trail (list)); 4846 tree arg4_tree; 4847 tree arg4_type; 4848 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list))); 4849 tree arg5_tree; 4850 tree prep_arg1; 4851 tree prep_arg4; 4852 tree arg5_plus_arg3; 4853 4854 arg2_tree = convert (integer_type_node, 4855 ffecom_expr (arg2)); 4856 arg3_tree = ffecom_save_tree (convert (integer_type_node, 4857 ffecom_expr (arg3))); 4858 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4); 4859 arg4_type = TREE_TYPE (arg4_tree); 4860 4861 arg1_tree = ffecom_save_tree (convert (arg4_type, 4862 ffecom_expr (arg1))); 4863 4864 arg5_tree = ffecom_save_tree (convert (integer_type_node, 4865 ffecom_expr (arg5))); 4866 4867 prep_arg1 4868 = ffecom_2 (LSHIFT_EXPR, arg4_type, 4869 ffecom_2 (BIT_AND_EXPR, arg4_type, 4870 ffecom_2 (RSHIFT_EXPR, arg4_type, 4871 arg1_tree, 4872 arg2_tree), 4873 ffecom_1 (BIT_NOT_EXPR, arg4_type, 4874 ffecom_2 (LSHIFT_EXPR, arg4_type, 4875 ffecom_1 (BIT_NOT_EXPR, 4876 arg4_type, 4877 convert 4878 (arg4_type, 4879 integer_zero_node)), 4880 arg3_tree))), 4881 arg5_tree); 4882 arg5_plus_arg3 4883 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type, 4884 arg5_tree, 4885 arg3_tree)); 4886 prep_arg4 4887 = ffecom_2 (LSHIFT_EXPR, arg4_type, 4888 ffecom_1 (BIT_NOT_EXPR, arg4_type, 4889 convert (arg4_type, 4890 integer_zero_node)), 4891 arg5_plus_arg3); 4892#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH 4893 prep_arg4 4894 = ffecom_3 (COND_EXPR, arg4_type, 4895 ffecom_truth_value 4896 (ffecom_2 (NE_EXPR, integer_type_node, 4897 arg5_plus_arg3, 4898 convert (TREE_TYPE (arg5_plus_arg3), 4899 TYPE_SIZE (arg4_type)))), 4900 prep_arg4, 4901 convert (arg4_type, integer_zero_node)); 4902#endif 4903 prep_arg4 4904 = ffecom_2 (BIT_AND_EXPR, arg4_type, 4905 arg4_tree, 4906 ffecom_2 (BIT_IOR_EXPR, arg4_type, 4907 prep_arg4, 4908 ffecom_1 (BIT_NOT_EXPR, arg4_type, 4909 ffecom_2 (LSHIFT_EXPR, arg4_type, 4910 ffecom_1 (BIT_NOT_EXPR, 4911 arg4_type, 4912 convert 4913 (arg4_type, 4914 integer_zero_node)), 4915 arg5_tree)))); 4916 prep_arg1 4917 = ffecom_2 (BIT_IOR_EXPR, arg4_type, 4918 prep_arg1, 4919 prep_arg4); 4920#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH 4921 prep_arg1 4922 = ffecom_3 (COND_EXPR, arg4_type, 4923 ffecom_truth_value 4924 (ffecom_2 (NE_EXPR, integer_type_node, 4925 arg3_tree, 4926 convert (TREE_TYPE (arg3_tree), 4927 integer_zero_node))), 4928 prep_arg1, 4929 arg4_tree); 4930 prep_arg1 4931 = ffecom_3 (COND_EXPR, arg4_type, 4932 ffecom_truth_value 4933 (ffecom_2 (NE_EXPR, integer_type_node, 4934 arg3_tree, 4935 convert (TREE_TYPE (arg3_tree), 4936 TYPE_SIZE (arg4_type)))), 4937 prep_arg1, 4938 arg1_tree); 4939#endif 4940 expr_tree 4941 = ffecom_2s (MODIFY_EXPR, void_type_node, 4942 arg4_tree, 4943 prep_arg1); 4944 /* Make sure SAVE_EXPRs get referenced early enough. */ 4945 expr_tree 4946 = ffecom_2 (COMPOUND_EXPR, void_type_node, 4947 arg1_tree, 4948 ffecom_2 (COMPOUND_EXPR, void_type_node, 4949 arg3_tree, 4950 ffecom_2 (COMPOUND_EXPR, void_type_node, 4951 arg5_tree, 4952 ffecom_2 (COMPOUND_EXPR, void_type_node, 4953 arg5_plus_arg3, 4954 expr_tree)))); 4955 expr_tree 4956 = ffecom_2 (COMPOUND_EXPR, void_type_node, 4957 arg4_tree, 4958 expr_tree); 4959 4960 } 4961 return expr_tree; 4962 4963 case FFEINTRIN_impDERF: 4964 case FFEINTRIN_impERF: 4965 case FFEINTRIN_impDERFC: 4966 case FFEINTRIN_impERFC: 4967 break; 4968 4969 case FFEINTRIN_impIARGC: 4970 /* extern int xargc; i__1 = xargc - 1; */ 4971 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_), 4972 ffecom_tree_xargc_, 4973 convert (TREE_TYPE (ffecom_tree_xargc_), 4974 integer_one_node)); 4975 return expr_tree; 4976 4977 case FFEINTRIN_impSIGNAL_func: 4978 case FFEINTRIN_impSIGNAL_subr: 4979 { 4980 tree arg1_tree; 4981 tree arg2_tree; 4982 tree arg3_tree; 4983 4984 arg1_tree = convert (ffecom_f2c_integer_type_node, 4985 ffecom_expr (arg1)); 4986 arg1_tree = ffecom_1 (ADDR_EXPR, 4987 build_pointer_type (TREE_TYPE (arg1_tree)), 4988 arg1_tree); 4989 4990 /* Pass procedure as a pointer to it, anything else by value. */ 4991 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) 4992 arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); 4993 else 4994 arg2_tree = ffecom_ptr_to_expr (arg2); 4995 arg2_tree = convert (TREE_TYPE (null_pointer_node), 4996 arg2_tree); 4997 4998 if (arg3 != NULL) 4999 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5000 else 5001 arg3_tree = NULL_TREE; 5002 5003 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5004 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5005 TREE_CHAIN (arg1_tree) = arg2_tree; 5006 5007 expr_tree 5008 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5009 ffecom_gfrt_kindtype (gfrt), 5010 FALSE, 5011 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ? 5012 NULL_TREE : 5013 tree_type), 5014 arg1_tree, 5015 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5016 ffebld_nonter_hook (expr)); 5017 5018 if (arg3_tree != NULL_TREE) 5019 expr_tree 5020 = ffecom_modify (NULL_TREE, arg3_tree, 5021 convert (TREE_TYPE (arg3_tree), 5022 expr_tree)); 5023 } 5024 return expr_tree; 5025 5026 case FFEINTRIN_impALARM: 5027 { 5028 tree arg1_tree; 5029 tree arg2_tree; 5030 tree arg3_tree; 5031 5032 arg1_tree = convert (ffecom_f2c_integer_type_node, 5033 ffecom_expr (arg1)); 5034 arg1_tree = ffecom_1 (ADDR_EXPR, 5035 build_pointer_type (TREE_TYPE (arg1_tree)), 5036 arg1_tree); 5037 5038 /* Pass procedure as a pointer to it, anything else by value. */ 5039 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) 5040 arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); 5041 else 5042 arg2_tree = ffecom_ptr_to_expr (arg2); 5043 arg2_tree = convert (TREE_TYPE (null_pointer_node), 5044 arg2_tree); 5045 5046 if (arg3 != NULL) 5047 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5048 else 5049 arg3_tree = NULL_TREE; 5050 5051 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5052 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5053 TREE_CHAIN (arg1_tree) = arg2_tree; 5054 5055 expr_tree 5056 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5057 ffecom_gfrt_kindtype (gfrt), 5058 FALSE, 5059 NULL_TREE, 5060 arg1_tree, 5061 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5062 ffebld_nonter_hook (expr)); 5063 5064 if (arg3_tree != NULL_TREE) 5065 expr_tree 5066 = ffecom_modify (NULL_TREE, arg3_tree, 5067 convert (TREE_TYPE (arg3_tree), 5068 expr_tree)); 5069 } 5070 return expr_tree; 5071 5072 case FFEINTRIN_impCHDIR_subr: 5073 case FFEINTRIN_impFDATE_subr: 5074 case FFEINTRIN_impFGET_subr: 5075 case FFEINTRIN_impFPUT_subr: 5076 case FFEINTRIN_impGETCWD_subr: 5077 case FFEINTRIN_impHOSTNM_subr: 5078 case FFEINTRIN_impSYSTEM_subr: 5079 case FFEINTRIN_impUNLINK_subr: 5080 { 5081 tree arg1_len = integer_zero_node; 5082 tree arg1_tree; 5083 tree arg2_tree; 5084 5085 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); 5086 5087 if (arg2 != NULL) 5088 arg2_tree = ffecom_expr_w (NULL_TREE, arg2); 5089 else 5090 arg2_tree = NULL_TREE; 5091 5092 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5093 arg1_len = build_tree_list (NULL_TREE, arg1_len); 5094 TREE_CHAIN (arg1_tree) = arg1_len; 5095 5096 expr_tree 5097 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5098 ffecom_gfrt_kindtype (gfrt), 5099 FALSE, 5100 NULL_TREE, 5101 arg1_tree, 5102 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5103 ffebld_nonter_hook (expr)); 5104 5105 if (arg2_tree != NULL_TREE) 5106 expr_tree 5107 = ffecom_modify (NULL_TREE, arg2_tree, 5108 convert (TREE_TYPE (arg2_tree), 5109 expr_tree)); 5110 } 5111 return expr_tree; 5112 5113 case FFEINTRIN_impEXIT: 5114 if (arg1 != NULL) 5115 break; 5116 5117 expr_tree = build_tree_list (NULL_TREE, 5118 ffecom_1 (ADDR_EXPR, 5119 build_pointer_type 5120 (ffecom_integer_type_node), 5121 integer_zero_node)); 5122 5123 return 5124 ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5125 ffecom_gfrt_kindtype (gfrt), 5126 FALSE, 5127 void_type_node, 5128 expr_tree, 5129 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5130 ffebld_nonter_hook (expr)); 5131 5132 case FFEINTRIN_impFLUSH: 5133 if (arg1 == NULL) 5134 gfrt = FFECOM_gfrtFLUSH; 5135 else 5136 gfrt = FFECOM_gfrtFLUSH1; 5137 break; 5138 5139 case FFEINTRIN_impCHMOD_subr: 5140 case FFEINTRIN_impLINK_subr: 5141 case FFEINTRIN_impRENAME_subr: 5142 case FFEINTRIN_impSYMLNK_subr: 5143 { 5144 tree arg1_len = integer_zero_node; 5145 tree arg1_tree; 5146 tree arg2_len = integer_zero_node; 5147 tree arg2_tree; 5148 tree arg3_tree; 5149 5150 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); 5151 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); 5152 if (arg3 != NULL) 5153 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5154 else 5155 arg3_tree = NULL_TREE; 5156 5157 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5158 arg1_len = build_tree_list (NULL_TREE, arg1_len); 5159 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5160 arg2_len = build_tree_list (NULL_TREE, arg2_len); 5161 TREE_CHAIN (arg1_tree) = arg2_tree; 5162 TREE_CHAIN (arg2_tree) = arg1_len; 5163 TREE_CHAIN (arg1_len) = arg2_len; 5164 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5165 ffecom_gfrt_kindtype (gfrt), 5166 FALSE, 5167 NULL_TREE, 5168 arg1_tree, 5169 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5170 ffebld_nonter_hook (expr)); 5171 if (arg3_tree != NULL_TREE) 5172 expr_tree = ffecom_modify (NULL_TREE, arg3_tree, 5173 convert (TREE_TYPE (arg3_tree), 5174 expr_tree)); 5175 } 5176 return expr_tree; 5177 5178 case FFEINTRIN_impLSTAT_subr: 5179 case FFEINTRIN_impSTAT_subr: 5180 { 5181 tree arg1_len = integer_zero_node; 5182 tree arg1_tree; 5183 tree arg2_tree; 5184 tree arg3_tree; 5185 5186 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); 5187 5188 arg2_tree = ffecom_ptr_to_expr (arg2); 5189 5190 if (arg3 != NULL) 5191 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5192 else 5193 arg3_tree = NULL_TREE; 5194 5195 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5196 arg1_len = build_tree_list (NULL_TREE, arg1_len); 5197 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5198 TREE_CHAIN (arg1_tree) = arg2_tree; 5199 TREE_CHAIN (arg2_tree) = arg1_len; 5200 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5201 ffecom_gfrt_kindtype (gfrt), 5202 FALSE, 5203 NULL_TREE, 5204 arg1_tree, 5205 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5206 ffebld_nonter_hook (expr)); 5207 if (arg3_tree != NULL_TREE) 5208 expr_tree = ffecom_modify (NULL_TREE, arg3_tree, 5209 convert (TREE_TYPE (arg3_tree), 5210 expr_tree)); 5211 } 5212 return expr_tree; 5213 5214 case FFEINTRIN_impFGETC_subr: 5215 case FFEINTRIN_impFPUTC_subr: 5216 { 5217 tree arg1_tree; 5218 tree arg2_tree; 5219 tree arg2_len = integer_zero_node; 5220 tree arg3_tree; 5221 5222 arg1_tree = convert (ffecom_f2c_integer_type_node, 5223 ffecom_expr (arg1)); 5224 arg1_tree = ffecom_1 (ADDR_EXPR, 5225 build_pointer_type (TREE_TYPE (arg1_tree)), 5226 arg1_tree); 5227 5228 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); 5229 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5230 5231 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5232 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5233 arg2_len = build_tree_list (NULL_TREE, arg2_len); 5234 TREE_CHAIN (arg1_tree) = arg2_tree; 5235 TREE_CHAIN (arg2_tree) = arg2_len; 5236 5237 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5238 ffecom_gfrt_kindtype (gfrt), 5239 FALSE, 5240 NULL_TREE, 5241 arg1_tree, 5242 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5243 ffebld_nonter_hook (expr)); 5244 expr_tree = ffecom_modify (NULL_TREE, arg3_tree, 5245 convert (TREE_TYPE (arg3_tree), 5246 expr_tree)); 5247 } 5248 return expr_tree; 5249 5250 case FFEINTRIN_impFSTAT_subr: 5251 { 5252 tree arg1_tree; 5253 tree arg2_tree; 5254 tree arg3_tree; 5255 5256 arg1_tree = convert (ffecom_f2c_integer_type_node, 5257 ffecom_expr (arg1)); 5258 arg1_tree = ffecom_1 (ADDR_EXPR, 5259 build_pointer_type (TREE_TYPE (arg1_tree)), 5260 arg1_tree); 5261 5262 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node, 5263 ffecom_ptr_to_expr (arg2)); 5264 5265 if (arg3 == NULL) 5266 arg3_tree = NULL_TREE; 5267 else 5268 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5269 5270 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5271 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5272 TREE_CHAIN (arg1_tree) = arg2_tree; 5273 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5274 ffecom_gfrt_kindtype (gfrt), 5275 FALSE, 5276 NULL_TREE, 5277 arg1_tree, 5278 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5279 ffebld_nonter_hook (expr)); 5280 if (arg3_tree != NULL_TREE) { 5281 expr_tree = ffecom_modify (NULL_TREE, arg3_tree, 5282 convert (TREE_TYPE (arg3_tree), 5283 expr_tree)); 5284 } 5285 } 5286 return expr_tree; 5287 5288 case FFEINTRIN_impKILL_subr: 5289 { 5290 tree arg1_tree; 5291 tree arg2_tree; 5292 tree arg3_tree; 5293 5294 arg1_tree = convert (ffecom_f2c_integer_type_node, 5295 ffecom_expr (arg1)); 5296 arg1_tree = ffecom_1 (ADDR_EXPR, 5297 build_pointer_type (TREE_TYPE (arg1_tree)), 5298 arg1_tree); 5299 5300 arg2_tree = convert (ffecom_f2c_integer_type_node, 5301 ffecom_expr (arg2)); 5302 arg2_tree = ffecom_1 (ADDR_EXPR, 5303 build_pointer_type (TREE_TYPE (arg2_tree)), 5304 arg2_tree); 5305 5306 if (arg3 == NULL) 5307 arg3_tree = NULL_TREE; 5308 else 5309 arg3_tree = ffecom_expr_w (NULL_TREE, arg3); 5310 5311 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5312 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5313 TREE_CHAIN (arg1_tree) = arg2_tree; 5314 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5315 ffecom_gfrt_kindtype (gfrt), 5316 FALSE, 5317 NULL_TREE, 5318 arg1_tree, 5319 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5320 ffebld_nonter_hook (expr)); 5321 if (arg3_tree != NULL_TREE) { 5322 expr_tree = ffecom_modify (NULL_TREE, arg3_tree, 5323 convert (TREE_TYPE (arg3_tree), 5324 expr_tree)); 5325 } 5326 } 5327 return expr_tree; 5328 5329 case FFEINTRIN_impCTIME_subr: 5330 case FFEINTRIN_impTTYNAM_subr: 5331 { 5332 tree arg1_len = integer_zero_node; 5333 tree arg1_tree; 5334 tree arg2_tree; 5335 5336 arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len); 5337 5338 arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ? 5339 ffecom_f2c_longint_type_node : 5340 ffecom_f2c_integer_type_node), 5341 ffecom_expr (arg1)); 5342 arg2_tree = ffecom_1 (ADDR_EXPR, 5343 build_pointer_type (TREE_TYPE (arg2_tree)), 5344 arg2_tree); 5345 5346 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5347 arg1_len = build_tree_list (NULL_TREE, arg1_len); 5348 arg2_tree = build_tree_list (NULL_TREE, arg2_tree); 5349 TREE_CHAIN (arg1_len) = arg2_tree; 5350 TREE_CHAIN (arg1_tree) = arg1_len; 5351 5352 expr_tree 5353 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5354 ffecom_gfrt_kindtype (gfrt), 5355 FALSE, 5356 NULL_TREE, 5357 arg1_tree, 5358 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5359 ffebld_nonter_hook (expr)); 5360 TREE_SIDE_EFFECTS (expr_tree) = 1; 5361 } 5362 return expr_tree; 5363 5364 case FFEINTRIN_impIRAND: 5365 case FFEINTRIN_impRAND: 5366 /* Arg defaults to 0 (normal random case) */ 5367 { 5368 tree arg1_tree; 5369 5370 if (arg1 == NULL) 5371 arg1_tree = ffecom_integer_zero_node; 5372 else 5373 arg1_tree = ffecom_expr (arg1); 5374 arg1_tree = convert (ffecom_f2c_integer_type_node, 5375 arg1_tree); 5376 arg1_tree = ffecom_1 (ADDR_EXPR, 5377 build_pointer_type (TREE_TYPE (arg1_tree)), 5378 arg1_tree); 5379 arg1_tree = build_tree_list (NULL_TREE, arg1_tree); 5380 5381 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5382 ffecom_gfrt_kindtype (gfrt), 5383 FALSE, 5384 ((codegen_imp == FFEINTRIN_impIRAND) ? 5385 ffecom_f2c_integer_type_node : 5386 ffecom_f2c_real_type_node), 5387 arg1_tree, 5388 dest_tree, dest, dest_used, 5389 NULL_TREE, TRUE, 5390 ffebld_nonter_hook (expr)); 5391 } 5392 return expr_tree; 5393 5394 case FFEINTRIN_impFTELL_subr: 5395 case FFEINTRIN_impUMASK_subr: 5396 { 5397 tree arg1_tree; 5398 tree arg2_tree; 5399 5400 arg1_tree = convert (ffecom_f2c_integer_type_node, 5401 ffecom_expr (arg1)); 5402 arg1_tree = ffecom_1 (ADDR_EXPR, 5403 build_pointer_type (TREE_TYPE (arg1_tree)), 5404 arg1_tree); 5405 5406 if (arg2 == NULL) 5407 arg2_tree = NULL_TREE; 5408 else 5409 arg2_tree = ffecom_expr_w (NULL_TREE, arg2); 5410 5411 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5412 ffecom_gfrt_kindtype (gfrt), 5413 FALSE, 5414 NULL_TREE, 5415 build_tree_list (NULL_TREE, arg1_tree), 5416 NULL_TREE, NULL, NULL, NULL_TREE, 5417 TRUE, 5418 ffebld_nonter_hook (expr)); 5419 if (arg2_tree != NULL_TREE) { 5420 expr_tree = ffecom_modify (NULL_TREE, arg2_tree, 5421 convert (TREE_TYPE (arg2_tree), 5422 expr_tree)); 5423 } 5424 } 5425 return expr_tree; 5426 5427 case FFEINTRIN_impCPU_TIME: 5428 case FFEINTRIN_impSECOND_subr: 5429 { 5430 tree arg1_tree; 5431 5432 arg1_tree = ffecom_expr_w (NULL_TREE, arg1); 5433 5434 expr_tree 5435 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5436 ffecom_gfrt_kindtype (gfrt), 5437 FALSE, 5438 NULL_TREE, 5439 NULL_TREE, 5440 NULL_TREE, NULL, NULL, NULL_TREE, TRUE, 5441 ffebld_nonter_hook (expr)); 5442 5443 expr_tree 5444 = ffecom_modify (NULL_TREE, arg1_tree, 5445 convert (TREE_TYPE (arg1_tree), 5446 expr_tree)); 5447 } 5448 return expr_tree; 5449 5450 case FFEINTRIN_impDTIME_subr: 5451 case FFEINTRIN_impETIME_subr: 5452 { 5453 tree arg1_tree; 5454 tree result_tree; 5455 5456 result_tree = ffecom_expr_w (NULL_TREE, arg2); 5457 5458 arg1_tree = ffecom_ptr_to_expr (arg1); 5459 5460 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), 5461 ffecom_gfrt_kindtype (gfrt), 5462 FALSE, 5463 NULL_TREE, 5464 build_tree_list (NULL_TREE, arg1_tree), 5465 NULL_TREE, NULL, NULL, NULL_TREE, 5466 TRUE, 5467 ffebld_nonter_hook (expr)); 5468 expr_tree = ffecom_modify (NULL_TREE, result_tree, 5469 convert (TREE_TYPE (result_tree), 5470 expr_tree)); 5471 } 5472 return expr_tree; 5473 5474 /* Straightforward calls of libf2c routines: */ 5475 case FFEINTRIN_impABORT: 5476 case FFEINTRIN_impACCESS: 5477 case FFEINTRIN_impBESJ0: 5478 case FFEINTRIN_impBESJ1: 5479 case FFEINTRIN_impBESJN: 5480 case FFEINTRIN_impBESY0: 5481 case FFEINTRIN_impBESY1: 5482 case FFEINTRIN_impBESYN: 5483 case FFEINTRIN_impCHDIR_func: 5484 case FFEINTRIN_impCHMOD_func: 5485 case FFEINTRIN_impDATE: 5486 case FFEINTRIN_impDATE_AND_TIME: 5487 case FFEINTRIN_impDBESJ0: 5488 case FFEINTRIN_impDBESJ1: 5489 case FFEINTRIN_impDBESJN: 5490 case FFEINTRIN_impDBESY0: 5491 case FFEINTRIN_impDBESY1: 5492 case FFEINTRIN_impDBESYN: 5493 case FFEINTRIN_impDTIME_func: 5494 case FFEINTRIN_impETIME_func: 5495 case FFEINTRIN_impFGETC_func: 5496 case FFEINTRIN_impFGET_func: 5497 case FFEINTRIN_impFNUM: 5498 case FFEINTRIN_impFPUTC_func: 5499 case FFEINTRIN_impFPUT_func: 5500 case FFEINTRIN_impFSEEK: 5501 case FFEINTRIN_impFSTAT_func: 5502 case FFEINTRIN_impFTELL_func: 5503 case FFEINTRIN_impGERROR: 5504 case FFEINTRIN_impGETARG: 5505 case FFEINTRIN_impGETCWD_func: 5506 case FFEINTRIN_impGETENV: 5507 case FFEINTRIN_impGETGID: 5508 case FFEINTRIN_impGETLOG: 5509 case FFEINTRIN_impGETPID: 5510 case FFEINTRIN_impGETUID: 5511 case FFEINTRIN_impGMTIME: 5512 case FFEINTRIN_impHOSTNM_func: 5513 case FFEINTRIN_impIDATE_unix: 5514 case FFEINTRIN_impIDATE_vxt: 5515 case FFEINTRIN_impIERRNO: 5516 case FFEINTRIN_impISATTY: 5517 case FFEINTRIN_impITIME: 5518 case FFEINTRIN_impKILL_func: 5519 case FFEINTRIN_impLINK_func: 5520 case FFEINTRIN_impLNBLNK: 5521 case FFEINTRIN_impLSTAT_func: 5522 case FFEINTRIN_impLTIME: 5523 case FFEINTRIN_impMCLOCK8: 5524 case FFEINTRIN_impMCLOCK: 5525 case FFEINTRIN_impPERROR: 5526 case FFEINTRIN_impRENAME_func: 5527 case FFEINTRIN_impSECNDS: 5528 case FFEINTRIN_impSECOND_func: 5529 case FFEINTRIN_impSLEEP: 5530 case FFEINTRIN_impSRAND: 5531 case FFEINTRIN_impSTAT_func: 5532 case FFEINTRIN_impSYMLNK_func: 5533 case FFEINTRIN_impSYSTEM_CLOCK: 5534 case FFEINTRIN_impSYSTEM_func: 5535 case FFEINTRIN_impTIME8: 5536 case FFEINTRIN_impTIME_unix: 5537 case FFEINTRIN_impTIME_vxt: 5538 case FFEINTRIN_impUMASK_func: 5539 case FFEINTRIN_impUNLINK_func: 5540 break; 5541 5542 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */ 5543 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */ 5544 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */ 5545 case FFEINTRIN_impNONE: 5546 case FFEINTRIN_imp: /* Hush up gcc warning. */ 5547 fprintf (stderr, "No %s implementation.\n", 5548 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr)))); 5549 assert ("unimplemented intrinsic" == NULL); 5550 return error_mark_node; 5551 } 5552 5553 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */ 5554 5555 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), 5556 ffebld_right (expr)); 5557 5558 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt), 5559 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]), 5560 tree_type, 5561 expr_tree, dest_tree, dest, dest_used, 5562 NULL_TREE, TRUE, 5563 ffebld_nonter_hook (expr)); 5564 5565 /* See bottom of this file for f2c transforms used to determine 5566 many of the above implementations. The info seems to confuse 5567 Emacs's C mode indentation, which is why it's been moved to 5568 the bottom of this source file. */ 5569} 5570 5571#endif 5572/* For power (exponentiation) where right-hand operand is type INTEGER, 5573 generate in-line code to do it the fast way (which, if the operand 5574 is a constant, might just mean a series of multiplies). */ 5575 5576#if FFECOM_targetCURRENT == FFECOM_targetGCC 5577static tree 5578ffecom_expr_power_integer_ (ffebld expr) 5579{ 5580 tree l = ffecom_expr (ffebld_left (expr)); 5581 tree r = ffecom_expr (ffebld_right (expr)); 5582 tree ltype = TREE_TYPE (l); 5583 tree rtype = TREE_TYPE (r); 5584 tree result = NULL_TREE; 5585 5586 if (l == error_mark_node 5587 || r == error_mark_node) 5588 return error_mark_node; 5589 5590 if (TREE_CODE (r) == INTEGER_CST) 5591 { 5592 int sgn = tree_int_cst_sgn (r); 5593 5594 if (sgn == 0) 5595 return convert (ltype, integer_one_node); 5596 5597 if ((TREE_CODE (ltype) == INTEGER_TYPE) 5598 && (sgn < 0)) 5599 { 5600 /* Reciprocal of integer is either 0, -1, or 1, so after 5601 calculating that (which we leave to the back end to do 5602 or not do optimally), don't bother with any multiplying. */ 5603 5604 result = ffecom_tree_divide_ (ltype, 5605 convert (ltype, integer_one_node), 5606 l, 5607 NULL_TREE, NULL, NULL, NULL_TREE); 5608 r = ffecom_1 (NEGATE_EXPR, 5609 rtype, 5610 r); 5611 if ((TREE_INT_CST_LOW (r) & 1) == 0) 5612 result = ffecom_1 (ABS_EXPR, rtype, 5613 result); 5614 } 5615 5616 /* Generate appropriate series of multiplies, preceded 5617 by divide if the exponent is negative. */ 5618 5619 l = save_expr (l); 5620 5621 if (sgn < 0) 5622 { 5623 l = ffecom_tree_divide_ (ltype, 5624 convert (ltype, integer_one_node), 5625 l, 5626 NULL_TREE, NULL, NULL, 5627 ffebld_nonter_hook (expr)); 5628 r = ffecom_1 (NEGATE_EXPR, rtype, r); 5629 assert (TREE_CODE (r) == INTEGER_CST); 5630 5631 if (tree_int_cst_sgn (r) < 0) 5632 { /* The "most negative" number. */ 5633 r = ffecom_1 (NEGATE_EXPR, rtype, 5634 ffecom_2 (RSHIFT_EXPR, rtype, 5635 r, 5636 integer_one_node)); 5637 l = save_expr (l); 5638 l = ffecom_2 (MULT_EXPR, ltype, 5639 l, 5640 l); 5641 } 5642 } 5643 5644 for (;;) 5645 { 5646 if (TREE_INT_CST_LOW (r) & 1) 5647 { 5648 if (result == NULL_TREE) 5649 result = l; 5650 else 5651 result = ffecom_2 (MULT_EXPR, ltype, 5652 result, 5653 l); 5654 } 5655 5656 r = ffecom_2 (RSHIFT_EXPR, rtype, 5657 r, 5658 integer_one_node); 5659 if (integer_zerop (r)) 5660 break; 5661 assert (TREE_CODE (r) == INTEGER_CST); 5662 5663 l = save_expr (l); 5664 l = ffecom_2 (MULT_EXPR, ltype, 5665 l, 5666 l); 5667 } 5668 return result; 5669 } 5670 5671 /* Though rhs isn't a constant, in-line code cannot be expanded 5672 while transforming dummies 5673 because the back end cannot be easily convinced to generate 5674 stores (MODIFY_EXPR), handle temporaries, and so on before 5675 all the appropriate rtx's have been generated for things like 5676 dummy args referenced in rhs -- which doesn't happen until 5677 store_parm_decls() is called (expand_function_start, I believe, 5678 does the actual rtx-stuffing of PARM_DECLs). 5679 5680 So, in this case, let the caller generate the call to the 5681 run-time-library function to evaluate the power for us. */ 5682 5683 if (ffecom_transform_only_dummies_) 5684 return NULL_TREE; 5685 5686 /* Right-hand operand not a constant, expand in-line code to figure 5687 out how to do the multiplies, &c. 5688 5689 The returned expression is expressed this way in GNU C, where l and 5690 r are the "inputs": 5691 5692 ({ typeof (r) rtmp = r; 5693 typeof (l) ltmp = l; 5694 typeof (l) result; 5695 5696 if (rtmp == 0) 5697 result = 1; 5698 else 5699 { 5700 if ((basetypeof (l) == basetypeof (int)) 5701 && (rtmp < 0)) 5702 { 5703 result = ((typeof (l)) 1) / ltmp; 5704 if ((ltmp < 0) && (((-rtmp) & 1) == 0)) 5705 result = -result; 5706 } 5707 else 5708 { 5709 result = 1; 5710 if ((basetypeof (l) != basetypeof (int)) 5711 && (rtmp < 0)) 5712 { 5713 ltmp = ((typeof (l)) 1) / ltmp; 5714 rtmp = -rtmp; 5715 if (rtmp < 0) 5716 { 5717 rtmp = -(rtmp >> 1); 5718 ltmp *= ltmp; 5719 } 5720 } 5721 for (;;) 5722 { 5723 if (rtmp & 1) 5724 result *= ltmp; 5725 if ((rtmp >>= 1) == 0) 5726 break; 5727 ltmp *= ltmp; 5728 } 5729 } 5730 } 5731 result; 5732 }) 5733 5734 Note that some of the above is compile-time collapsable, such as 5735 the first part of the if statements that checks the base type of 5736 l against int. The if statements are phrased that way to suggest 5737 an easy way to generate the if/else constructs here, knowing that 5738 the back end should (and probably does) eliminate the resulting 5739 dead code (either the int case or the non-int case), something 5740 it couldn't do without the redundant phrasing, requiring explicit 5741 dead-code elimination here, which would be kind of difficult to 5742 read. */ 5743 5744 { 5745 tree rtmp; 5746 tree ltmp; 5747 tree divide; 5748 tree basetypeof_l_is_int; 5749 tree se; 5750 tree t; 5751 5752 basetypeof_l_is_int 5753 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); 5754 5755 se = expand_start_stmt_expr (); 5756 5757 ffecom_start_compstmt (); 5758 5759#ifndef HAHA 5760 rtmp = ffecom_make_tempvar ("power_r", rtype, 5761 FFETARGET_charactersizeNONE, -1); 5762 ltmp = ffecom_make_tempvar ("power_l", ltype, 5763 FFETARGET_charactersizeNONE, -1); 5764 result = ffecom_make_tempvar ("power_res", ltype, 5765 FFETARGET_charactersizeNONE, -1); 5766 if (TREE_CODE (ltype) == COMPLEX_TYPE 5767 || TREE_CODE (ltype) == RECORD_TYPE) 5768 divide = ffecom_make_tempvar ("power_div", ltype, 5769 FFETARGET_charactersizeNONE, -1); 5770 else 5771 divide = NULL_TREE; 5772#else /* HAHA */ 5773 { 5774 tree hook; 5775 5776 hook = ffebld_nonter_hook (expr); 5777 assert (hook); 5778 assert (TREE_CODE (hook) == TREE_VEC); 5779 assert (TREE_VEC_LENGTH (hook) == 4); 5780 rtmp = TREE_VEC_ELT (hook, 0); 5781 ltmp = TREE_VEC_ELT (hook, 1); 5782 result = TREE_VEC_ELT (hook, 2); 5783 divide = TREE_VEC_ELT (hook, 3); 5784 if (TREE_CODE (ltype) == COMPLEX_TYPE 5785 || TREE_CODE (ltype) == RECORD_TYPE) 5786 assert (divide); 5787 else 5788 assert (! divide); 5789 } 5790#endif /* HAHA */ 5791 5792 expand_expr_stmt (ffecom_modify (void_type_node, 5793 rtmp, 5794 r)); 5795 expand_expr_stmt (ffecom_modify (void_type_node, 5796 ltmp, 5797 l)); 5798 expand_start_cond (ffecom_truth_value 5799 (ffecom_2 (EQ_EXPR, integer_type_node, 5800 rtmp, 5801 convert (rtype, integer_zero_node))), 5802 0); 5803 expand_expr_stmt (ffecom_modify (void_type_node, 5804 result, 5805 convert (ltype, integer_one_node))); 5806 expand_start_else (); 5807 if (! integer_zerop (basetypeof_l_is_int)) 5808 { 5809 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, 5810 rtmp, 5811 convert (rtype, 5812 integer_zero_node)), 5813 0); 5814 expand_expr_stmt (ffecom_modify (void_type_node, 5815 result, 5816 ffecom_tree_divide_ 5817 (ltype, 5818 convert (ltype, integer_one_node), 5819 ltmp, 5820 NULL_TREE, NULL, NULL, 5821 divide))); 5822 expand_start_cond (ffecom_truth_value 5823 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, 5824 ffecom_2 (LT_EXPR, integer_type_node, 5825 ltmp, 5826 convert (ltype, 5827 integer_zero_node)), 5828 ffecom_2 (EQ_EXPR, integer_type_node, 5829 ffecom_2 (BIT_AND_EXPR, 5830 rtype, 5831 ffecom_1 (NEGATE_EXPR, 5832 rtype, 5833 rtmp), 5834 convert (rtype, 5835 integer_one_node)), 5836 convert (rtype, 5837 integer_zero_node)))), 5838 0); 5839 expand_expr_stmt (ffecom_modify (void_type_node, 5840 result, 5841 ffecom_1 (NEGATE_EXPR, 5842 ltype, 5843 result))); 5844 expand_end_cond (); 5845 expand_start_else (); 5846 } 5847 expand_expr_stmt (ffecom_modify (void_type_node, 5848 result, 5849 convert (ltype, integer_one_node))); 5850 expand_start_cond (ffecom_truth_value 5851 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, 5852 ffecom_truth_value_invert 5853 (basetypeof_l_is_int), 5854 ffecom_2 (LT_EXPR, integer_type_node, 5855 rtmp, 5856 convert (rtype, 5857 integer_zero_node)))), 5858 0); 5859 expand_expr_stmt (ffecom_modify (void_type_node, 5860 ltmp, 5861 ffecom_tree_divide_ 5862 (ltype, 5863 convert (ltype, integer_one_node), 5864 ltmp, 5865 NULL_TREE, NULL, NULL, 5866 divide))); 5867 expand_expr_stmt (ffecom_modify (void_type_node, 5868 rtmp, 5869 ffecom_1 (NEGATE_EXPR, rtype, 5870 rtmp))); 5871 expand_start_cond (ffecom_truth_value 5872 (ffecom_2 (LT_EXPR, integer_type_node, 5873 rtmp, 5874 convert (rtype, integer_zero_node))), 5875 0); 5876 expand_expr_stmt (ffecom_modify (void_type_node, 5877 rtmp, 5878 ffecom_1 (NEGATE_EXPR, rtype, 5879 ffecom_2 (RSHIFT_EXPR, 5880 rtype, 5881 rtmp, 5882 integer_one_node)))); 5883 expand_expr_stmt (ffecom_modify (void_type_node, 5884 ltmp, 5885 ffecom_2 (MULT_EXPR, ltype, 5886 ltmp, 5887 ltmp))); 5888 expand_end_cond (); 5889 expand_end_cond (); 5890 expand_start_loop (1); 5891 expand_start_cond (ffecom_truth_value 5892 (ffecom_2 (BIT_AND_EXPR, rtype, 5893 rtmp, 5894 convert (rtype, integer_one_node))), 5895 0); 5896 expand_expr_stmt (ffecom_modify (void_type_node, 5897 result, 5898 ffecom_2 (MULT_EXPR, ltype, 5899 result, 5900 ltmp))); 5901 expand_end_cond (); 5902 expand_exit_loop_if_false (NULL, 5903 ffecom_truth_value 5904 (ffecom_modify (rtype, 5905 rtmp, 5906 ffecom_2 (RSHIFT_EXPR, 5907 rtype, 5908 rtmp, 5909 integer_one_node)))); 5910 expand_expr_stmt (ffecom_modify (void_type_node, 5911 ltmp, 5912 ffecom_2 (MULT_EXPR, ltype, 5913 ltmp, 5914 ltmp))); 5915 expand_end_loop (); 5916 expand_end_cond (); 5917 if (!integer_zerop (basetypeof_l_is_int)) 5918 expand_end_cond (); 5919 expand_expr_stmt (result); 5920 5921 t = ffecom_end_compstmt (); 5922 5923 result = expand_end_stmt_expr (se); 5924 5925 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */ 5926 5927 if (TREE_CODE (t) == BLOCK) 5928 { 5929 /* Make a BIND_EXPR for the BLOCK already made. */ 5930 result = build (BIND_EXPR, TREE_TYPE (result), 5931 NULL_TREE, result, t); 5932 /* Remove the block from the tree at this point. 5933 It gets put back at the proper place 5934 when the BIND_EXPR is expanded. */ 5935 delete_block (t); 5936 } 5937 else 5938 result = t; 5939 } 5940 5941 return result; 5942} 5943 5944#endif 5945/* ffecom_expr_transform_ -- Transform symbols in expr 5946 5947 ffebld expr; // FFE expression. 5948 ffecom_expr_transform_ (expr); 5949 5950 Recursive descent on expr while transforming any untransformed SYMTERs. */ 5951 5952#if FFECOM_targetCURRENT == FFECOM_targetGCC 5953static void 5954ffecom_expr_transform_ (ffebld expr) 5955{ 5956 tree t; 5957 ffesymbol s; 5958 5959tail_recurse: /* :::::::::::::::::::: */ 5960 5961 if (expr == NULL) 5962 return; 5963 5964 switch (ffebld_op (expr)) 5965 { 5966 case FFEBLD_opSYMTER: 5967 s = ffebld_symter (expr); 5968 t = ffesymbol_hook (s).decl_tree; 5969 if ((t == NULL_TREE) 5970 && ((ffesymbol_kind (s) != FFEINFO_kindNONE) 5971 || ((ffesymbol_where (s) != FFEINFO_whereNONE) 5972 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))) 5973 { 5974 s = ffecom_sym_transform_ (s); 5975 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy, 5976 DIMENSION expr? */ 5977 } 5978 break; /* Ok if (t == NULL) here. */ 5979 5980 case FFEBLD_opITEM: 5981 ffecom_expr_transform_ (ffebld_head (expr)); 5982 expr = ffebld_trail (expr); 5983 goto tail_recurse; /* :::::::::::::::::::: */ 5984 5985 default: 5986 break; 5987 } 5988 5989 switch (ffebld_arity (expr)) 5990 { 5991 case 2: 5992 ffecom_expr_transform_ (ffebld_left (expr)); 5993 expr = ffebld_right (expr); 5994 goto tail_recurse; /* :::::::::::::::::::: */ 5995 5996 case 1: 5997 expr = ffebld_left (expr); 5998 goto tail_recurse; /* :::::::::::::::::::: */ 5999 6000 default: 6001 break; 6002 } 6003 6004 return; 6005} 6006 6007#endif 6008/* Make a type based on info in live f2c.h file. */ 6009 6010#if FFECOM_targetCURRENT == FFECOM_targetGCC 6011static void 6012ffecom_f2c_make_type_ (tree *type, int tcode, const char *name) 6013{ 6014 switch (tcode) 6015 { 6016 case FFECOM_f2ccodeCHAR: 6017 *type = make_signed_type (CHAR_TYPE_SIZE); 6018 break; 6019 6020 case FFECOM_f2ccodeSHORT: 6021 *type = make_signed_type (SHORT_TYPE_SIZE); 6022 break; 6023 6024 case FFECOM_f2ccodeINT: 6025 *type = make_signed_type (INT_TYPE_SIZE); 6026 break; 6027 6028 case FFECOM_f2ccodeLONG: 6029 *type = make_signed_type (LONG_TYPE_SIZE); 6030 break; 6031 6032 case FFECOM_f2ccodeLONGLONG: 6033 *type = make_signed_type (LONG_LONG_TYPE_SIZE); 6034 break; 6035 6036 case FFECOM_f2ccodeCHARPTR: 6037 *type = build_pointer_type (DEFAULT_SIGNED_CHAR 6038 ? signed_char_type_node 6039 : unsigned_char_type_node); 6040 break; 6041 6042 case FFECOM_f2ccodeFLOAT: 6043 *type = make_node (REAL_TYPE); 6044 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE; 6045 layout_type (*type); 6046 break; 6047 6048 case FFECOM_f2ccodeDOUBLE: 6049 *type = make_node (REAL_TYPE); 6050 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE; 6051 layout_type (*type); 6052 break; 6053 6054 case FFECOM_f2ccodeLONGDOUBLE: 6055 *type = make_node (REAL_TYPE); 6056 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE; 6057 layout_type (*type); 6058 break; 6059 6060 case FFECOM_f2ccodeTWOREALS: 6061 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node); 6062 break; 6063 6064 case FFECOM_f2ccodeTWODOUBLEREALS: 6065 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node); 6066 break; 6067 6068 default: 6069 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL); 6070 *type = error_mark_node; 6071 return; 6072 } 6073 6074 pushdecl (build_decl (TYPE_DECL, 6075 ffecom_get_invented_identifier ("__g77_f2c_%s", 6076 name, -1), 6077 *type)); 6078} 6079 6080#endif 6081#if FFECOM_targetCURRENT == FFECOM_targetGCC 6082/* Set the f2c list-directed-I/O code for whatever (integral) type has the 6083 given size. */ 6084 6085static void 6086ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, 6087 int code) 6088{ 6089 int j; 6090 tree t; 6091 6092 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) 6093 if (((t = ffecom_tree_type[bt][j]) != NULL_TREE) 6094 && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size)) 6095 { 6096 assert (code != -1); 6097 ffecom_f2c_typecode_[bt][j] = code; 6098 code = -1; 6099 } 6100} 6101 6102#endif 6103/* Finish up globals after doing all program units in file 6104 6105 Need to handle only uninitialized COMMON areas. */ 6106 6107#if FFECOM_targetCURRENT == FFECOM_targetGCC 6108static ffeglobal 6109ffecom_finish_global_ (ffeglobal global) 6110{ 6111 tree cbtype; 6112 tree cbt; 6113 tree size; 6114 6115 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON) 6116 return global; 6117 6118 if (ffeglobal_common_init (global)) 6119 return global; 6120 6121 cbt = ffeglobal_hook (global); 6122 if ((cbt == NULL_TREE) 6123 || !ffeglobal_common_have_size (global)) 6124 return global; /* No need to make common, never ref'd. */ 6125 6126 suspend_momentary (); 6127 6128 DECL_EXTERNAL (cbt) = 0; 6129 6130 /* Give the array a size now. */ 6131 6132 size = build_int_2 ((ffeglobal_common_size (global) 6133 + ffeglobal_common_pad (global)) - 1, 6134 0); 6135 6136 cbtype = TREE_TYPE (cbt); 6137 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, 6138 integer_zero_node, 6139 size); 6140 if (!TREE_TYPE (size)) 6141 TREE_TYPE (size) = TYPE_DOMAIN (cbtype); 6142 layout_type (cbtype); 6143 6144 cbt = start_decl (cbt, FALSE); 6145 assert (cbt == ffeglobal_hook (global)); 6146 6147 finish_decl (cbt, NULL_TREE, FALSE); 6148 6149 return global; 6150} 6151 6152#endif 6153/* Finish up any untransformed symbols. */ 6154 6155#if FFECOM_targetCURRENT == FFECOM_targetGCC 6156static ffesymbol 6157ffecom_finish_symbol_transform_ (ffesymbol s) 6158{ 6159 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK)) 6160 return s; 6161 6162 /* It's easy to know to transform an untransformed symbol, to make sure 6163 we put out debugging info for it. But COMMON variables, unlike 6164 EQUIVALENCE ones, aren't given declarations in addition to the 6165 tree expressions that specify offsets, because COMMON variables 6166 can be referenced in the outer scope where only dummy arguments 6167 (PARM_DECLs) should really be seen. To be safe, just don't do any 6168 VAR_DECLs for COMMON variables when we transform them for real 6169 use, and therefore we do all the VAR_DECL creating here. */ 6170 6171 if (ffesymbol_hook (s).decl_tree == NULL_TREE) 6172 { 6173 if (ffesymbol_kind (s) != FFEINFO_kindNONE 6174 || (ffesymbol_where (s) != FFEINFO_whereNONE 6175 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC 6176 && ffesymbol_where (s) != FFEINFO_whereDUMMY)) 6177 /* Not transformed, and not CHARACTER*(*), and not a dummy 6178 argument, which can happen only if the entry point names 6179 it "rides in on" are all invalidated for other reasons. */ 6180 s = ffecom_sym_transform_ (s); 6181 } 6182 6183 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON) 6184 && (ffesymbol_hook (s).decl_tree != error_mark_node)) 6185 { 6186#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING 6187 int yes = suspend_momentary (); 6188 6189 /* This isn't working, at least for dbxout. The .s file looks 6190 okay to me (burley), but in gdb 4.9 at least, the variables 6191 appear to reside somewhere outside of the common area, so 6192 it doesn't make sense to mislead anyone by generating the info 6193 on those variables until this is fixed. NOTE: Same problem 6194 with EQUIVALENCE, sadly...see similar #if later. */ 6195 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)), 6196 ffesymbol_storage (s)); 6197 6198 resume_momentary (yes); 6199#endif 6200 } 6201 6202 return s; 6203} 6204 6205#endif 6206/* Append underscore(s) to name before calling get_identifier. "us" 6207 is nonzero if the name already contains an underscore and thus 6208 needs two underscores appended. */ 6209 6210#if FFECOM_targetCURRENT == FFECOM_targetGCC 6211static tree 6212ffecom_get_appended_identifier_ (char us, const char *name) 6213{ 6214 int i; 6215 char *newname; 6216 tree id; 6217 6218 newname = xmalloc ((i = strlen (name)) + 1 6219 + ffe_is_underscoring () 6220 + us); 6221 memcpy (newname, name, i); 6222 newname[i] = '_'; 6223 newname[i + us] = '_'; 6224 newname[i + 1 + us] = '\0'; 6225 id = get_identifier (newname); 6226 6227 free (newname); 6228 6229 return id; 6230} 6231 6232#endif 6233/* Decide whether to append underscore to name before calling 6234 get_identifier. */ 6235 6236#if FFECOM_targetCURRENT == FFECOM_targetGCC 6237static tree 6238ffecom_get_external_identifier_ (ffesymbol s) 6239{ 6240 char us; 6241 const char *name = ffesymbol_text (s); 6242 6243 /* If name is a built-in name, just return it as is. */ 6244 6245 if (!ffe_is_underscoring () 6246 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0) 6247#if FFETARGET_isENFORCED_MAIN_NAME 6248 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0) 6249#else 6250 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) 6251#endif 6252 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0)) 6253 return get_identifier (name); 6254 6255 us = ffe_is_second_underscore () 6256 ? (strchr (name, '_') != NULL) 6257 : 0; 6258 6259 return ffecom_get_appended_identifier_ (us, name); 6260} 6261 6262#endif 6263/* Decide whether to append underscore to internal name before calling 6264 get_identifier. 6265 6266 This is for non-external, top-function-context names only. Transform 6267 identifier so it doesn't conflict with the transformed result 6268 of using a _different_ external name. E.g. if "CALL FOO" is 6269 transformed into "FOO_();", then the variable in "FOO_ = 3" 6270 must be transformed into something that does not conflict, since 6271 these two things should be independent. 6272 6273 The transformation is as follows. If the name does not contain 6274 an underscore, there is no possible conflict, so just return. 6275 If the name does contain an underscore, then transform it just 6276 like we transform an external identifier. */ 6277 6278#if FFECOM_targetCURRENT == FFECOM_targetGCC 6279static tree 6280ffecom_get_identifier_ (const char *name) 6281{ 6282 /* If name does not contain an underscore, just return it as is. */ 6283 6284 if (!ffe_is_underscoring () 6285 || (strchr (name, '_') == NULL)) 6286 return get_identifier (name); 6287 6288 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (), 6289 name); 6290} 6291 6292#endif 6293/* ffecom_gen_sfuncdef_ -- Generate definition of statement function 6294 6295 tree t; 6296 ffesymbol s; // kindFUNCTION, whereIMMEDIATE. 6297 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s), 6298 ffesymbol_kindtype(s)); 6299 6300 Call after setting up containing function and getting trees for all 6301 other symbols. */ 6302 6303#if FFECOM_targetCURRENT == FFECOM_targetGCC 6304static tree 6305ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) 6306{ 6307 ffebld expr = ffesymbol_sfexpr (s); 6308 tree type; 6309 tree func; 6310 tree result; 6311 bool charfunc = (bt == FFEINFO_basictypeCHARACTER); 6312 static bool recurse = FALSE; 6313 int yes; 6314 int old_lineno = lineno; 6315 char *old_input_filename = input_filename; 6316 6317 ffecom_nested_entry_ = s; 6318 6319 /* For now, we don't have a handy pointer to where the sfunc is actually 6320 defined, though that should be easy to add to an ffesymbol. (The 6321 token/where info available might well point to the place where the type 6322 of the sfunc is declared, especially if that precedes the place where 6323 the sfunc itself is defined, which is typically the case.) We should 6324 put out a null pointer rather than point somewhere wrong, but I want to 6325 see how it works at this point. */ 6326 6327 input_filename = ffesymbol_where_filename (s); 6328 lineno = ffesymbol_where_filelinenum (s); 6329 6330 /* Pretransform the expression so any newly discovered things belong to the 6331 outer program unit, not to the statement function. */ 6332 6333 ffecom_expr_transform_ (expr); 6334 6335 /* Make sure no recursive invocation of this fn (a specific case of failing 6336 to pretransform an sfunc's expression, i.e. where its expression 6337 references another untransformed sfunc) happens. */ 6338 6339 assert (!recurse); 6340 recurse = TRUE; 6341 6342 yes = suspend_momentary (); 6343 6344 push_f_function_context (); 6345 6346 if (charfunc) 6347 type = void_type_node; 6348 else 6349 { 6350 type = ffecom_tree_type[bt][kt]; 6351 if (type == NULL_TREE) 6352 type = integer_type_node; /* _sym_exec_transition reports 6353 error. */ 6354 } 6355 6356 start_function (ffecom_get_identifier_ (ffesymbol_text (s)), 6357 build_function_type (type, NULL_TREE), 6358 1, /* nested/inline */ 6359 0); /* TREE_PUBLIC */ 6360 6361 /* We don't worry about COMPLEX return values here, because this is 6362 entirely internal to our code, and gcc has the ability to return COMPLEX 6363 directly as a value. */ 6364 6365 yes = suspend_momentary (); 6366 6367 if (charfunc) 6368 { /* Prepend arg for where result goes. */ 6369 tree type; 6370 6371 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; 6372 6373 result = ffecom_get_invented_identifier ("__g77_%s", 6374 "result", -1); 6375 6376 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ 6377 6378 type = build_pointer_type (type); 6379 result = build_decl (PARM_DECL, result, type); 6380 6381 push_parm_decl (result); 6382 } 6383 else 6384 result = NULL_TREE; /* Not ref'd if !charfunc. */ 6385 6386 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE); 6387 6388 resume_momentary (yes); 6389 6390 store_parm_decls (0); 6391 6392 ffecom_start_compstmt (); 6393 6394 if (expr != NULL) 6395 { 6396 if (charfunc) 6397 { 6398 ffetargetCharacterSize sz = ffesymbol_size (s); 6399 tree result_length; 6400 6401 result_length = build_int_2 (sz, 0); 6402 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; 6403 6404 ffecom_prepare_let_char_ (sz, expr); 6405 6406 ffecom_prepare_end (); 6407 6408 ffecom_let_char_ (result, result_length, sz, expr); 6409 expand_null_return (); 6410 } 6411 else 6412 { 6413 ffecom_prepare_expr (expr); 6414 6415 ffecom_prepare_end (); 6416 6417 expand_return (ffecom_modify (NULL_TREE, 6418 DECL_RESULT (current_function_decl), 6419 ffecom_expr (expr))); 6420 } 6421 6422 clear_momentary (); 6423 } 6424 6425 ffecom_end_compstmt (); 6426 6427 func = current_function_decl; 6428 finish_function (1); 6429 6430 pop_f_function_context (); 6431 6432 resume_momentary (yes); 6433 6434 recurse = FALSE; 6435 6436 lineno = old_lineno; 6437 input_filename = old_input_filename; 6438 6439 ffecom_nested_entry_ = NULL; 6440 6441 return func; 6442} 6443 6444#endif 6445 6446#if FFECOM_targetCURRENT == FFECOM_targetGCC 6447static const char * 6448ffecom_gfrt_args_ (ffecomGfrt ix) 6449{ 6450 return ffecom_gfrt_argstring_[ix]; 6451} 6452 6453#endif 6454#if FFECOM_targetCURRENT == FFECOM_targetGCC 6455static tree 6456ffecom_gfrt_tree_ (ffecomGfrt ix) 6457{ 6458 if (ffecom_gfrt_[ix] == NULL_TREE) 6459 ffecom_make_gfrt_ (ix); 6460 6461 return ffecom_1 (ADDR_EXPR, 6462 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])), 6463 ffecom_gfrt_[ix]); 6464} 6465 6466#endif 6467/* Return initialize-to-zero expression for this VAR_DECL. */ 6468 6469#if FFECOM_targetCURRENT == FFECOM_targetGCC 6470static tree 6471ffecom_init_zero_ (tree decl) 6472{ 6473 tree init; 6474 int incremental = TREE_STATIC (decl); 6475 tree type = TREE_TYPE (decl); 6476 6477 if (incremental) 6478 { 6479 int momentary = suspend_momentary (); 6480 push_obstacks_nochange (); 6481 if (TREE_PERMANENT (decl)) 6482 end_temporary_allocation (); 6483 make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0); 6484 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); 6485 pop_obstacks (); 6486 resume_momentary (momentary); 6487 } 6488 6489 push_momentary (); 6490 6491 if ((TREE_CODE (type) != ARRAY_TYPE) 6492 && (TREE_CODE (type) != RECORD_TYPE) 6493 && (TREE_CODE (type) != UNION_TYPE) 6494 && !incremental) 6495 init = convert (type, integer_zero_node); 6496 else if (!incremental) 6497 { 6498 int momentary = suspend_momentary (); 6499 6500 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE); 6501 TREE_CONSTANT (init) = 1; 6502 TREE_STATIC (init) = 1; 6503 6504 resume_momentary (momentary); 6505 } 6506 else 6507 { 6508 int momentary = suspend_momentary (); 6509 6510 assemble_zeros (int_size_in_bytes (type)); 6511 init = error_mark_node; 6512 6513 resume_momentary (momentary); 6514 } 6515 6516 pop_momentary_nofree (); 6517 6518 return init; 6519} 6520 6521#endif 6522#if FFECOM_targetCURRENT == FFECOM_targetGCC 6523static tree 6524ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, 6525 tree *maybe_tree) 6526{ 6527 tree expr_tree; 6528 tree length_tree; 6529 6530 switch (ffebld_op (arg)) 6531 { 6532 case FFEBLD_opCONTER: /* For F90, check 0-length. */ 6533 if (ffetarget_length_character1 6534 (ffebld_constant_character1 6535 (ffebld_conter (arg))) == 0) 6536 { 6537 *maybe_tree = integer_zero_node; 6538 return convert (tree_type, integer_zero_node); 6539 } 6540 6541 *maybe_tree = integer_one_node; 6542 expr_tree = build_int_2 (*ffetarget_text_character1 6543 (ffebld_constant_character1 6544 (ffebld_conter (arg))), 6545 0); 6546 TREE_TYPE (expr_tree) = tree_type; 6547 return expr_tree; 6548 6549 case FFEBLD_opSYMTER: 6550 case FFEBLD_opARRAYREF: 6551 case FFEBLD_opFUNCREF: 6552 case FFEBLD_opSUBSTR: 6553 ffecom_char_args_ (&expr_tree, &length_tree, arg); 6554 6555 if ((expr_tree == error_mark_node) 6556 || (length_tree == error_mark_node)) 6557 { 6558 *maybe_tree = error_mark_node; 6559 return error_mark_node; 6560 } 6561 6562 if (integer_zerop (length_tree)) 6563 { 6564 *maybe_tree = integer_zero_node; 6565 return convert (tree_type, integer_zero_node); 6566 } 6567 6568 expr_tree 6569 = ffecom_1 (INDIRECT_REF, 6570 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), 6571 expr_tree); 6572 expr_tree 6573 = ffecom_2 (ARRAY_REF, 6574 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), 6575 expr_tree, 6576 integer_one_node); 6577 expr_tree = convert (tree_type, expr_tree); 6578 6579 if (TREE_CODE (length_tree) == INTEGER_CST) 6580 *maybe_tree = integer_one_node; 6581 else /* Must check length at run time. */ 6582 *maybe_tree 6583 = ffecom_truth_value 6584 (ffecom_2 (GT_EXPR, integer_type_node, 6585 length_tree, 6586 ffecom_f2c_ftnlen_zero_node)); 6587 return expr_tree; 6588 6589 case FFEBLD_opPAREN: 6590 case FFEBLD_opCONVERT: 6591 if (ffeinfo_size (ffebld_info (arg)) == 0) 6592 { 6593 *maybe_tree = integer_zero_node; 6594 return convert (tree_type, integer_zero_node); 6595 } 6596 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), 6597 maybe_tree); 6598 6599 case FFEBLD_opCONCATENATE: 6600 { 6601 tree maybe_left; 6602 tree maybe_right; 6603 tree expr_left; 6604 tree expr_right; 6605 6606 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), 6607 &maybe_left); 6608 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg), 6609 &maybe_right); 6610 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, 6611 maybe_left, 6612 maybe_right); 6613 expr_tree = ffecom_3 (COND_EXPR, tree_type, 6614 maybe_left, 6615 expr_left, 6616 expr_right); 6617 return expr_tree; 6618 } 6619 6620 default: 6621 assert ("bad op in ICHAR" == NULL); 6622 return error_mark_node; 6623 } 6624} 6625 6626#endif 6627/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN()) 6628 6629 tree length_arg; 6630 ffebld expr; 6631 length_arg = ffecom_intrinsic_len_ (expr); 6632 6633 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF 6634 subexpressions by constructing the appropriate tree for the 6635 length-of-character-text argument in a calling sequence. */ 6636 6637#if FFECOM_targetCURRENT == FFECOM_targetGCC 6638static tree 6639ffecom_intrinsic_len_ (ffebld expr) 6640{ 6641 ffetargetCharacter1 val; 6642 tree length; 6643 6644 switch (ffebld_op (expr)) 6645 { 6646 case FFEBLD_opCONTER: 6647 val = ffebld_constant_character1 (ffebld_conter (expr)); 6648 length = build_int_2 (ffetarget_length_character1 (val), 0); 6649 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; 6650 break; 6651 6652 case FFEBLD_opSYMTER: 6653 { 6654 ffesymbol s = ffebld_symter (expr); 6655 tree item; 6656 6657 item = ffesymbol_hook (s).decl_tree; 6658 if (item == NULL_TREE) 6659 { 6660 s = ffecom_sym_transform_ (s); 6661 item = ffesymbol_hook (s).decl_tree; 6662 } 6663 if (ffesymbol_kind (s) == FFEINFO_kindENTITY) 6664 { 6665 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) 6666 length = ffesymbol_hook (s).length_tree; 6667 else 6668 { 6669 length = build_int_2 (ffesymbol_size (s), 0); 6670 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; 6671 } 6672 } 6673 else if (item == error_mark_node) 6674 length = error_mark_node; 6675 else /* FFEINFO_kindFUNCTION: */ 6676 length = NULL_TREE; 6677 } 6678 break; 6679 6680 case FFEBLD_opARRAYREF: 6681 length = ffecom_intrinsic_len_ (ffebld_left (expr)); 6682 break; 6683 6684 case FFEBLD_opSUBSTR: 6685 { 6686 ffebld start; 6687 ffebld end; 6688 ffebld thing = ffebld_right (expr); 6689 tree start_tree; 6690 tree end_tree; 6691 6692 assert (ffebld_op (thing) == FFEBLD_opITEM); 6693 start = ffebld_head (thing); 6694 thing = ffebld_trail (thing); 6695 assert (ffebld_trail (thing) == NULL); 6696 end = ffebld_head (thing); 6697 6698 length = ffecom_intrinsic_len_ (ffebld_left (expr)); 6699 6700 if (length == error_mark_node) 6701 break; 6702 6703 if (start == NULL) 6704 { 6705 if (end == NULL) 6706 ; 6707 else 6708 { 6709 length = convert (ffecom_f2c_ftnlen_type_node, 6710 ffecom_expr (end)); 6711 } 6712 } 6713 else 6714 { 6715 start_tree = convert (ffecom_f2c_ftnlen_type_node, 6716 ffecom_expr (start)); 6717 6718 if (start_tree == error_mark_node) 6719 { 6720 length = error_mark_node; 6721 break; 6722 } 6723 6724 if (end == NULL) 6725 { 6726 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 6727 ffecom_f2c_ftnlen_one_node, 6728 ffecom_2 (MINUS_EXPR, 6729 ffecom_f2c_ftnlen_type_node, 6730 length, 6731 start_tree)); 6732 } 6733 else 6734 { 6735 end_tree = convert (ffecom_f2c_ftnlen_type_node, 6736 ffecom_expr (end)); 6737 6738 if (end_tree == error_mark_node) 6739 { 6740 length = error_mark_node; 6741 break; 6742 } 6743 6744 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 6745 ffecom_f2c_ftnlen_one_node, 6746 ffecom_2 (MINUS_EXPR, 6747 ffecom_f2c_ftnlen_type_node, 6748 end_tree, start_tree)); 6749 } 6750 } 6751 } 6752 break; 6753 6754 case FFEBLD_opCONCATENATE: 6755 length 6756 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 6757 ffecom_intrinsic_len_ (ffebld_left (expr)), 6758 ffecom_intrinsic_len_ (ffebld_right (expr))); 6759 break; 6760 6761 case FFEBLD_opFUNCREF: 6762 case FFEBLD_opCONVERT: 6763 length = build_int_2 (ffebld_size (expr), 0); 6764 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; 6765 break; 6766 6767 default: 6768 assert ("bad op for single char arg expr" == NULL); 6769 length = ffecom_f2c_ftnlen_zero_node; 6770 break; 6771 } 6772 6773 assert (length != NULL_TREE); 6774 6775 return length; 6776} 6777 6778#endif 6779/* Handle CHARACTER assignments. 6780 6781 Generates code to do the assignment. Used by ordinary assignment 6782 statement handler ffecom_let_stmt and by statement-function 6783 handler to generate code for a statement function. */ 6784 6785#if FFECOM_targetCURRENT == FFECOM_targetGCC 6786static void 6787ffecom_let_char_ (tree dest_tree, tree dest_length, 6788 ffetargetCharacterSize dest_size, ffebld source) 6789{ 6790 ffecomConcatList_ catlist; 6791 tree source_length; 6792 tree source_tree; 6793 tree expr_tree; 6794 6795 if ((dest_tree == error_mark_node) 6796 || (dest_length == error_mark_node)) 6797 return; 6798 6799 assert (dest_tree != NULL_TREE); 6800 assert (dest_length != NULL_TREE); 6801 6802 /* Source might be an opCONVERT, which just means it is a different size 6803 than the destination. Since the underlying implementation here handles 6804 that (directly or via the s_copy or s_cat run-time-library functions), 6805 we don't need the "convenience" of an opCONVERT that tells us to 6806 truncate or blank-pad, particularly since the resulting implementation 6807 would probably be slower than otherwise. */ 6808 6809 while (ffebld_op (source) == FFEBLD_opCONVERT) 6810 source = ffebld_left (source); 6811 6812 catlist = ffecom_concat_list_new_ (source, dest_size); 6813 switch (ffecom_concat_list_count_ (catlist)) 6814 { 6815 case 0: /* Shouldn't happen, but in case it does... */ 6816 ffecom_concat_list_kill_ (catlist); 6817 source_tree = null_pointer_node; 6818 source_length = ffecom_f2c_ftnlen_zero_node; 6819 expr_tree = build_tree_list (NULL_TREE, dest_tree); 6820 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); 6821 TREE_CHAIN (TREE_CHAIN (expr_tree)) 6822 = build_tree_list (NULL_TREE, dest_length); 6823 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) 6824 = build_tree_list (NULL_TREE, source_length); 6825 6826 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); 6827 TREE_SIDE_EFFECTS (expr_tree) = 1; 6828 6829 expand_expr_stmt (expr_tree); 6830 6831 return; 6832 6833 case 1: /* The (fairly) easy case. */ 6834 ffecom_char_args_ (&source_tree, &source_length, 6835 ffecom_concat_list_expr_ (catlist, 0)); 6836 ffecom_concat_list_kill_ (catlist); 6837 assert (source_tree != NULL_TREE); 6838 assert (source_length != NULL_TREE); 6839 6840 if ((source_tree == error_mark_node) 6841 || (source_length == error_mark_node)) 6842 return; 6843 6844 if (dest_size == 1) 6845 { 6846 dest_tree 6847 = ffecom_1 (INDIRECT_REF, 6848 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE 6849 (dest_tree))), 6850 dest_tree); 6851 dest_tree 6852 = ffecom_2 (ARRAY_REF, 6853 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE 6854 (dest_tree))), 6855 dest_tree, 6856 integer_one_node); 6857 source_tree 6858 = ffecom_1 (INDIRECT_REF, 6859 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE 6860 (source_tree))), 6861 source_tree); 6862 source_tree 6863 = ffecom_2 (ARRAY_REF, 6864 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE 6865 (source_tree))), 6866 source_tree, 6867 integer_one_node); 6868 6869 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree); 6870 6871 expand_expr_stmt (expr_tree); 6872 6873 return; 6874 } 6875 6876 expr_tree = build_tree_list (NULL_TREE, dest_tree); 6877 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); 6878 TREE_CHAIN (TREE_CHAIN (expr_tree)) 6879 = build_tree_list (NULL_TREE, dest_length); 6880 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) 6881 = build_tree_list (NULL_TREE, source_length); 6882 6883 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); 6884 TREE_SIDE_EFFECTS (expr_tree) = 1; 6885 6886 expand_expr_stmt (expr_tree); 6887 6888 return; 6889 6890 default: /* Must actually concatenate things. */ 6891 break; 6892 } 6893 6894 /* Heavy-duty concatenation. */ 6895 6896 { 6897 int count = ffecom_concat_list_count_ (catlist); 6898 int i; 6899 tree lengths; 6900 tree items; 6901 tree length_array; 6902 tree item_array; 6903 tree citem; 6904 tree clength; 6905 6906#ifdef HOHO 6907 length_array 6908 = lengths 6909 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, 6910 FFETARGET_charactersizeNONE, count, TRUE); 6911 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node, 6912 FFETARGET_charactersizeNONE, 6913 count, TRUE); 6914#else 6915 { 6916 tree hook; 6917 6918 hook = ffebld_nonter_hook (source); 6919 assert (hook); 6920 assert (TREE_CODE (hook) == TREE_VEC); 6921 assert (TREE_VEC_LENGTH (hook) == 2); 6922 length_array = lengths = TREE_VEC_ELT (hook, 0); 6923 item_array = items = TREE_VEC_ELT (hook, 1); 6924 } 6925#endif 6926 6927 for (i = 0; i < count; ++i) 6928 { 6929 ffecom_char_args_ (&citem, &clength, 6930 ffecom_concat_list_expr_ (catlist, i)); 6931 if ((citem == error_mark_node) 6932 || (clength == error_mark_node)) 6933 { 6934 ffecom_concat_list_kill_ (catlist); 6935 return; 6936 } 6937 6938 items 6939 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), 6940 ffecom_modify (void_type_node, 6941 ffecom_2 (ARRAY_REF, 6942 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), 6943 item_array, 6944 build_int_2 (i, 0)), 6945 citem), 6946 items); 6947 lengths 6948 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), 6949 ffecom_modify (void_type_node, 6950 ffecom_2 (ARRAY_REF, 6951 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), 6952 length_array, 6953 build_int_2 (i, 0)), 6954 clength), 6955 lengths); 6956 } 6957 6958 expr_tree = build_tree_list (NULL_TREE, dest_tree); 6959 TREE_CHAIN (expr_tree) 6960 = build_tree_list (NULL_TREE, 6961 ffecom_1 (ADDR_EXPR, 6962 build_pointer_type (TREE_TYPE (items)), 6963 items)); 6964 TREE_CHAIN (TREE_CHAIN (expr_tree)) 6965 = build_tree_list (NULL_TREE, 6966 ffecom_1 (ADDR_EXPR, 6967 build_pointer_type (TREE_TYPE (lengths)), 6968 lengths)); 6969 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) 6970 = build_tree_list 6971 (NULL_TREE, 6972 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, 6973 convert (ffecom_f2c_ftnlen_type_node, 6974 build_int_2 (count, 0)))); 6975 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) 6976 = build_tree_list (NULL_TREE, dest_length); 6977 6978 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE); 6979 TREE_SIDE_EFFECTS (expr_tree) = 1; 6980 6981 expand_expr_stmt (expr_tree); 6982 } 6983 6984 ffecom_concat_list_kill_ (catlist); 6985} 6986 6987#endif 6988/* ffecom_make_gfrt_ -- Make initial info for run-time routine 6989 6990 ffecomGfrt ix; 6991 ffecom_make_gfrt_(ix); 6992 6993 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL 6994 for the indicated run-time routine (ix). */ 6995 6996#if FFECOM_targetCURRENT == FFECOM_targetGCC 6997static void 6998ffecom_make_gfrt_ (ffecomGfrt ix) 6999{ 7000 tree t; 7001 tree ttype; 7002 7003 push_obstacks_nochange (); 7004 end_temporary_allocation (); 7005 7006 switch (ffecom_gfrt_type_[ix]) 7007 { 7008 case FFECOM_rttypeVOID_: 7009 ttype = void_type_node; 7010 break; 7011 7012 case FFECOM_rttypeVOIDSTAR_: 7013 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */ 7014 break; 7015 7016 case FFECOM_rttypeFTNINT_: 7017 ttype = ffecom_f2c_ftnint_type_node; 7018 break; 7019 7020 case FFECOM_rttypeINTEGER_: 7021 ttype = ffecom_f2c_integer_type_node; 7022 break; 7023 7024 case FFECOM_rttypeLONGINT_: 7025 ttype = ffecom_f2c_longint_type_node; 7026 break; 7027 7028 case FFECOM_rttypeLOGICAL_: 7029 ttype = ffecom_f2c_logical_type_node; 7030 break; 7031 7032 case FFECOM_rttypeREAL_F2C_: 7033 ttype = double_type_node; 7034 break; 7035 7036 case FFECOM_rttypeREAL_GNU_: 7037 ttype = float_type_node; 7038 break; 7039 7040 case FFECOM_rttypeCOMPLEX_F2C_: 7041 ttype = void_type_node; 7042 break; 7043 7044 case FFECOM_rttypeCOMPLEX_GNU_: 7045 ttype = ffecom_f2c_complex_type_node; 7046 break; 7047 7048 case FFECOM_rttypeDOUBLE_: 7049 ttype = double_type_node; 7050 break; 7051 7052 case FFECOM_rttypeDOUBLEREAL_: 7053 ttype = ffecom_f2c_doublereal_type_node; 7054 break; 7055 7056 case FFECOM_rttypeDBLCMPLX_F2C_: 7057 ttype = void_type_node; 7058 break; 7059 7060 case FFECOM_rttypeDBLCMPLX_GNU_: 7061 ttype = ffecom_f2c_doublecomplex_type_node; 7062 break; 7063 7064 case FFECOM_rttypeCHARACTER_: 7065 ttype = void_type_node; 7066 break; 7067 7068 default: 7069 ttype = NULL; 7070 assert ("bad rttype" == NULL); 7071 break; 7072 } 7073 7074 ttype = build_function_type (ttype, NULL_TREE); 7075 t = build_decl (FUNCTION_DECL, 7076 get_identifier (ffecom_gfrt_name_[ix]), 7077 ttype); 7078 DECL_EXTERNAL (t) = 1; 7079 TREE_PUBLIC (t) = 1; 7080 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; 7081 7082 t = start_decl (t, TRUE); 7083 7084 finish_decl (t, NULL_TREE, TRUE); 7085 7086 resume_temporary_allocation (); 7087 pop_obstacks (); 7088 7089 ffecom_gfrt_[ix] = t; 7090} 7091 7092#endif 7093/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ 7094 7095#if FFECOM_targetCURRENT == FFECOM_targetGCC 7096static void 7097ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) 7098{ 7099 ffesymbol s = ffestorag_symbol (st); 7100 7101 if (ffesymbol_namelisted (s)) 7102 ffecom_member_namelisted_ = TRUE; 7103} 7104 7105#endif 7106/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare 7107 the member so debugger will see it. Otherwise nobody should be 7108 referencing the member. */ 7109 7110#if FFECOM_targetCURRENT == FFECOM_targetGCC 7111#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING 7112static void 7113ffecom_member_phase2_ (ffestorag mst, ffestorag st) 7114{ 7115 ffesymbol s; 7116 tree t; 7117 tree mt; 7118 tree type; 7119 7120 if ((mst == NULL) 7121 || ((mt = ffestorag_hook (mst)) == NULL) 7122 || (mt == error_mark_node)) 7123 return; 7124 7125 if ((st == NULL) 7126 || ((s = ffestorag_symbol (st)) == NULL)) 7127 return; 7128 7129 type = ffecom_type_localvar_ (s, 7130 ffesymbol_basictype (s), 7131 ffesymbol_kindtype (s)); 7132 if (type == error_mark_node) 7133 return; 7134 7135 t = build_decl (VAR_DECL, 7136 ffecom_get_identifier_ (ffesymbol_text (s)), 7137 type); 7138 7139 TREE_STATIC (t) = TREE_STATIC (mt); 7140 DECL_INITIAL (t) = NULL_TREE; 7141 TREE_ASM_WRITTEN (t) = 1; 7142 7143 DECL_RTL (t) 7144 = gen_rtx (MEM, TYPE_MODE (type), 7145 plus_constant (XEXP (DECL_RTL (mt), 0), 7146 ffestorag_modulo (mst) 7147 + ffestorag_offset (st) 7148 - ffestorag_offset (mst))); 7149 7150 t = start_decl (t, FALSE); 7151 7152 finish_decl (t, NULL_TREE, FALSE); 7153} 7154 7155#endif 7156#endif 7157/* Prepare source expression for assignment into a destination perhaps known 7158 to be of a specific size. */ 7159 7160static void 7161ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source) 7162{ 7163 ffecomConcatList_ catlist; 7164 int count; 7165 int i; 7166 tree ltmp; 7167 tree itmp; 7168 tree tempvar = NULL_TREE; 7169 7170 while (ffebld_op (source) == FFEBLD_opCONVERT) 7171 source = ffebld_left (source); 7172 7173 catlist = ffecom_concat_list_new_ (source, dest_size); 7174 count = ffecom_concat_list_count_ (catlist); 7175 7176 if (count >= 2) 7177 { 7178 ltmp 7179 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node, 7180 FFETARGET_charactersizeNONE, count); 7181 itmp 7182 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node, 7183 FFETARGET_charactersizeNONE, count); 7184 7185 tempvar = make_tree_vec (2); 7186 TREE_VEC_ELT (tempvar, 0) = ltmp; 7187 TREE_VEC_ELT (tempvar, 1) = itmp; 7188 } 7189 7190 for (i = 0; i < count; ++i) 7191 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i)); 7192 7193 ffecom_concat_list_kill_ (catlist); 7194 7195 if (tempvar) 7196 { 7197 ffebld_nonter_set_hook (source, tempvar); 7198 current_binding_level->prep_state = 1; 7199 } 7200} 7201 7202/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order 7203 7204 Ignores STAR (alternate-return) dummies. All other get exec-transitioned 7205 (which generates their trees) and then their trees get push_parm_decl'd. 7206 7207 The second arg is TRUE if the dummies are for a statement function, in 7208 which case lengths are not pushed for character arguments (since they are 7209 always known by both the caller and the callee, though the code allows 7210 for someday permitting CHAR*(*) stmtfunc dummies). */ 7211 7212#if FFECOM_targetCURRENT == FFECOM_targetGCC 7213static void 7214ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc) 7215{ 7216 ffebld dummy; 7217 ffebld dumlist; 7218 ffesymbol s; 7219 tree parm; 7220 7221 ffecom_transform_only_dummies_ = TRUE; 7222 7223 /* First push the parms corresponding to actual dummy "contents". */ 7224 7225 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) 7226 { 7227 dummy = ffebld_head (dumlist); 7228 switch (ffebld_op (dummy)) 7229 { 7230 case FFEBLD_opSTAR: 7231 case FFEBLD_opANY: 7232 continue; /* Forget alternate returns. */ 7233 7234 default: 7235 break; 7236 } 7237 assert (ffebld_op (dummy) == FFEBLD_opSYMTER); 7238 s = ffebld_symter (dummy); 7239 parm = ffesymbol_hook (s).decl_tree; 7240 if (parm == NULL_TREE) 7241 { 7242 s = ffecom_sym_transform_ (s); 7243 parm = ffesymbol_hook (s).decl_tree; 7244 assert (parm != NULL_TREE); 7245 } 7246 if (parm != error_mark_node) 7247 push_parm_decl (parm); 7248 } 7249 7250 /* Then, for CHARACTER dummies, push the parms giving their lengths. */ 7251 7252 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) 7253 { 7254 dummy = ffebld_head (dumlist); 7255 switch (ffebld_op (dummy)) 7256 { 7257 case FFEBLD_opSTAR: 7258 case FFEBLD_opANY: 7259 continue; /* Forget alternate returns, they mean 7260 NOTHING! */ 7261 7262 default: 7263 break; 7264 } 7265 s = ffebld_symter (dummy); 7266 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) 7267 continue; /* Only looking for CHARACTER arguments. */ 7268 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE)) 7269 continue; /* Stmtfunc arg with known size needs no 7270 length param. */ 7271 if (ffesymbol_kind (s) != FFEINFO_kindENTITY) 7272 continue; /* Only looking for variables and arrays. */ 7273 parm = ffesymbol_hook (s).length_tree; 7274 assert (parm != NULL_TREE); 7275 if (parm != error_mark_node) 7276 push_parm_decl (parm); 7277 } 7278 7279 ffecom_transform_only_dummies_ = FALSE; 7280} 7281 7282#endif 7283/* ffecom_start_progunit_ -- Beginning of program unit 7284 7285 Does GNU back end stuff necessary to teach it about the start of its 7286 equivalent of a Fortran program unit. */ 7287 7288#if FFECOM_targetCURRENT == FFECOM_targetGCC 7289static void 7290ffecom_start_progunit_ () 7291{ 7292 ffesymbol fn = ffecom_primary_entry_; 7293 ffebld arglist; 7294 tree id; /* Identifier (name) of function. */ 7295 tree type; /* Type of function. */ 7296 tree result; /* Result of function. */ 7297 ffeinfoBasictype bt; 7298 ffeinfoKindtype kt; 7299 ffeglobal g; 7300 ffeglobalType gt; 7301 ffeglobalType egt = FFEGLOBAL_type; 7302 bool charfunc; 7303 bool cmplxfunc; 7304 bool altentries = (ffecom_num_entrypoints_ != 0); 7305 bool multi 7306 = altentries 7307 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) 7308 && (ffecom_master_bt_ == FFEINFO_basictypeNONE); 7309 bool main_program = FALSE; 7310 int old_lineno = lineno; 7311 char *old_input_filename = input_filename; 7312 int yes; 7313 7314 assert (fn != NULL); 7315 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); 7316 7317 input_filename = ffesymbol_where_filename (fn); 7318 lineno = ffesymbol_where_filelinenum (fn); 7319 7320 /* c-parse.y indeed does call suspend_momentary and not only ignores the 7321 return value, but also never calls resume_momentary, when starting an 7322 outer function (see "fndef:", "setspecs:", and so on). So g77 does the 7323 same thing. It shouldn't be a problem since start_function calls 7324 temporary_allocation, but it might be necessary. If it causes a problem 7325 here, then maybe there's a bug lurking in gcc. NOTE: This identical 7326 comment appears twice in thist file. */ 7327 7328 suspend_momentary (); 7329 7330 switch (ffecom_primary_entry_kind_) 7331 { 7332 case FFEINFO_kindPROGRAM: 7333 main_program = TRUE; 7334 gt = FFEGLOBAL_typeMAIN; 7335 bt = FFEINFO_basictypeNONE; 7336 kt = FFEINFO_kindtypeNONE; 7337 type = ffecom_tree_fun_type_void; 7338 charfunc = FALSE; 7339 cmplxfunc = FALSE; 7340 break; 7341 7342 case FFEINFO_kindBLOCKDATA: 7343 gt = FFEGLOBAL_typeBDATA; 7344 bt = FFEINFO_basictypeNONE; 7345 kt = FFEINFO_kindtypeNONE; 7346 type = ffecom_tree_fun_type_void; 7347 charfunc = FALSE; 7348 cmplxfunc = FALSE; 7349 break; 7350 7351 case FFEINFO_kindFUNCTION: 7352 gt = FFEGLOBAL_typeFUNC; 7353 egt = FFEGLOBAL_typeEXT; 7354 bt = ffesymbol_basictype (fn); 7355 kt = ffesymbol_kindtype (fn); 7356 if (bt == FFEINFO_basictypeNONE) 7357 { 7358 ffeimplic_establish_symbol (fn); 7359 if (ffesymbol_funcresult (fn) != NULL) 7360 ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); 7361 bt = ffesymbol_basictype (fn); 7362 kt = ffesymbol_kindtype (fn); 7363 } 7364 7365 if (multi) 7366 charfunc = cmplxfunc = FALSE; 7367 else if (bt == FFEINFO_basictypeCHARACTER) 7368 charfunc = TRUE, cmplxfunc = FALSE; 7369 else if ((bt == FFEINFO_basictypeCOMPLEX) 7370 && ffesymbol_is_f2c (fn) 7371 && !altentries) 7372 charfunc = FALSE, cmplxfunc = TRUE; 7373 else 7374 charfunc = cmplxfunc = FALSE; 7375 7376 if (multi || charfunc) 7377 type = ffecom_tree_fun_type_void; 7378 else if (ffesymbol_is_f2c (fn) && !altentries) 7379 type = ffecom_tree_fun_type[bt][kt]; 7380 else 7381 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); 7382 7383 if ((type == NULL_TREE) 7384 || (TREE_TYPE (type) == NULL_TREE)) 7385 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ 7386 break; 7387 7388 case FFEINFO_kindSUBROUTINE: 7389 gt = FFEGLOBAL_typeSUBR; 7390 egt = FFEGLOBAL_typeEXT; 7391 bt = FFEINFO_basictypeNONE; 7392 kt = FFEINFO_kindtypeNONE; 7393 if (ffecom_is_altreturning_) 7394 type = ffecom_tree_subr_type; 7395 else 7396 type = ffecom_tree_fun_type_void; 7397 charfunc = FALSE; 7398 cmplxfunc = FALSE; 7399 break; 7400 7401 default: 7402 assert ("say what??" == NULL); 7403 /* Fall through. */ 7404 case FFEINFO_kindANY: 7405 gt = FFEGLOBAL_typeANY; 7406 bt = FFEINFO_basictypeNONE; 7407 kt = FFEINFO_kindtypeNONE; 7408 type = error_mark_node; 7409 charfunc = FALSE; 7410 cmplxfunc = FALSE; 7411 break; 7412 } 7413 7414 if (altentries) 7415 { 7416 id = ffecom_get_invented_identifier ("__g77_masterfun_%s", 7417 ffesymbol_text (fn), 7418 -1); 7419 } 7420#if FFETARGET_isENFORCED_MAIN 7421 else if (main_program) 7422 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME); 7423#endif 7424 else 7425 id = ffecom_get_external_identifier_ (fn); 7426 7427 start_function (id, 7428 type, 7429 0, /* nested/inline */ 7430 !altentries); /* TREE_PUBLIC */ 7431 7432 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */ 7433 7434 if (!altentries 7435 && ((g = ffesymbol_global (fn)) != NULL) 7436 && ((ffeglobal_type (g) == gt) 7437 || (ffeglobal_type (g) == egt))) 7438 { 7439 ffeglobal_set_hook (g, current_function_decl); 7440 } 7441 7442 yes = suspend_momentary (); 7443 7444 /* Arg handling needs exec-transitioned ffesymbols to work with. But 7445 exec-transitioning needs current_function_decl to be filled in. So we 7446 do these things in two phases. */ 7447 7448 if (altentries) 7449 { /* 1st arg identifies which entrypoint. */ 7450 ffecom_which_entrypoint_decl_ 7451 = build_decl (PARM_DECL, 7452 ffecom_get_invented_identifier ("__g77_%s", 7453 "which_entrypoint", 7454 -1), 7455 integer_type_node); 7456 push_parm_decl (ffecom_which_entrypoint_decl_); 7457 } 7458 7459 if (charfunc 7460 || cmplxfunc 7461 || multi) 7462 { /* Arg for result (return value). */ 7463 tree type; 7464 tree length; 7465 7466 if (charfunc) 7467 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; 7468 else if (cmplxfunc) 7469 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; 7470 else 7471 type = ffecom_multi_type_node_; 7472 7473 result = ffecom_get_invented_identifier ("__g77_%s", 7474 "result", -1); 7475 7476 /* Make length arg _and_ enhance type info for CHAR arg itself. */ 7477 7478 if (charfunc) 7479 length = ffecom_char_enhance_arg_ (&type, fn); 7480 else 7481 length = NULL_TREE; /* Not ref'd if !charfunc. */ 7482 7483 type = build_pointer_type (type); 7484 result = build_decl (PARM_DECL, result, type); 7485 7486 push_parm_decl (result); 7487 if (multi) 7488 ffecom_multi_retval_ = result; 7489 else 7490 ffecom_func_result_ = result; 7491 7492 if (charfunc) 7493 { 7494 push_parm_decl (length); 7495 ffecom_func_length_ = length; 7496 } 7497 } 7498 7499 if (ffecom_primary_entry_is_proc_) 7500 { 7501 if (altentries) 7502 arglist = ffecom_master_arglist_; 7503 else 7504 arglist = ffesymbol_dummyargs (fn); 7505 ffecom_push_dummy_decls_ (arglist, FALSE); 7506 } 7507 7508 resume_momentary (yes); 7509 7510 if (TREE_CODE (current_function_decl) != ERROR_MARK) 7511 store_parm_decls (main_program ? 1 : 0); 7512 7513 ffecom_start_compstmt (); 7514 /* Disallow temp vars at this level. */ 7515 current_binding_level->prep_state = 2; 7516 7517 lineno = old_lineno; 7518 input_filename = old_input_filename; 7519 7520 /* This handles any symbols still untransformed, in case -g specified. 7521 This used to be done in ffecom_finish_progunit, but it turns out to 7522 be necessary to do it here so that statement functions are 7523 expanded before code. But don't bother for BLOCK DATA. */ 7524 7525 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) 7526 ffesymbol_drive (ffecom_finish_symbol_transform_); 7527} 7528 7529#endif 7530/* ffecom_sym_transform_ -- Transform FFE sym into backend sym 7531 7532 ffesymbol s; 7533 ffecom_sym_transform_(s); 7534 7535 The ffesymbol_hook info for s is updated with appropriate backend info 7536 on the symbol. */ 7537 7538#if FFECOM_targetCURRENT == FFECOM_targetGCC 7539static ffesymbol 7540ffecom_sym_transform_ (ffesymbol s) 7541{ 7542 tree t; /* Transformed thingy. */ 7543 tree tlen; /* Length if CHAR*(*). */ 7544 bool addr; /* Is t the address of the thingy? */ 7545 ffeinfoBasictype bt; 7546 ffeinfoKindtype kt; 7547 ffeglobal g; 7548 int yes; 7549 int old_lineno = lineno; 7550 char *old_input_filename = input_filename; 7551 7552 /* Must ensure special ASSIGN variables are declared at top of outermost 7553 block, else they'll end up in the innermost block when their first 7554 ASSIGN is seen, which leaves them out of scope when they're the 7555 subject of a GOTO or I/O statement. 7556 7557 We make this variable even if -fugly-assign. Just let it go unused, 7558 in case it turns out there are cases where we really want to use this 7559 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */ 7560 7561 if (! ffecom_transform_only_dummies_ 7562 && ffesymbol_assigned (s) 7563 && ! ffesymbol_hook (s).assign_tree) 7564 s = ffecom_sym_transform_assign_ (s); 7565 7566 if (ffesymbol_sfdummyparent (s) == NULL) 7567 { 7568 input_filename = ffesymbol_where_filename (s); 7569 lineno = ffesymbol_where_filelinenum (s); 7570 } 7571 else 7572 { 7573 ffesymbol sf = ffesymbol_sfdummyparent (s); 7574 7575 input_filename = ffesymbol_where_filename (sf); 7576 lineno = ffesymbol_where_filelinenum (sf); 7577 } 7578 7579 bt = ffeinfo_basictype (ffebld_info (s)); 7580 kt = ffeinfo_kindtype (ffebld_info (s)); 7581 7582 t = NULL_TREE; 7583 tlen = NULL_TREE; 7584 addr = FALSE; 7585 7586 switch (ffesymbol_kind (s)) 7587 { 7588 case FFEINFO_kindNONE: 7589 switch (ffesymbol_where (s)) 7590 { 7591 case FFEINFO_whereDUMMY: /* Subroutine or function. */ 7592 assert (ffecom_transform_only_dummies_); 7593 7594 /* Before 0.4, this could be ENTITY/DUMMY, but see 7595 ffestu_sym_end_transition -- no longer true (in particular, if 7596 it could be an ENTITY, it _will_ be made one, so that 7597 possibility won't come through here). So we never make length 7598 arg for CHARACTER type. */ 7599 7600 t = build_decl (PARM_DECL, 7601 ffecom_get_identifier_ (ffesymbol_text (s)), 7602 ffecom_tree_ptr_to_subr_type); 7603#if BUILT_FOR_270 7604 DECL_ARTIFICIAL (t) = 1; 7605#endif 7606 addr = TRUE; 7607 break; 7608 7609 case FFEINFO_whereGLOBAL: /* Subroutine or function. */ 7610 assert (!ffecom_transform_only_dummies_); 7611 7612 if (((g = ffesymbol_global (s)) != NULL) 7613 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) 7614 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) 7615 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) 7616 && (ffeglobal_hook (g) != NULL_TREE) 7617 && ffe_is_globals ()) 7618 { 7619 t = ffeglobal_hook (g); 7620 break; 7621 } 7622 7623 push_obstacks_nochange (); 7624 end_temporary_allocation (); 7625 7626 t = build_decl (FUNCTION_DECL, 7627 ffecom_get_external_identifier_ (s), 7628 ffecom_tree_subr_type); /* Assume subr. */ 7629 DECL_EXTERNAL (t) = 1; 7630 TREE_PUBLIC (t) = 1; 7631 7632 t = start_decl (t, FALSE); 7633 finish_decl (t, NULL_TREE, FALSE); 7634 7635 if ((g != NULL) 7636 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) 7637 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) 7638 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) 7639 ffeglobal_set_hook (g, t); 7640 7641 resume_temporary_allocation (); 7642 pop_obstacks (); 7643 7644 break; 7645 7646 default: 7647 assert ("NONE where unexpected" == NULL); 7648 /* Fall through. */ 7649 case FFEINFO_whereANY: 7650 break; 7651 } 7652 break; 7653 7654 case FFEINFO_kindENTITY: 7655 switch (ffeinfo_where (ffesymbol_info (s))) 7656 { 7657 7658 case FFEINFO_whereCONSTANT: 7659 /* ~~Debugging info needed? */ 7660 assert (!ffecom_transform_only_dummies_); 7661 t = error_mark_node; /* Shouldn't ever see this in expr. */ 7662 break; 7663 7664 case FFEINFO_whereLOCAL: 7665 assert (!ffecom_transform_only_dummies_); 7666 7667 { 7668 ffestorag st = ffesymbol_storage (s); 7669 tree type; 7670 7671 if ((st != NULL) 7672 && (ffestorag_size (st) == 0)) 7673 { 7674 t = error_mark_node; 7675 break; 7676 } 7677 7678 yes = suspend_momentary (); 7679 type = ffecom_type_localvar_ (s, bt, kt); 7680 resume_momentary (yes); 7681 7682 if (type == error_mark_node) 7683 { 7684 t = error_mark_node; 7685 break; 7686 } 7687 7688 if ((st != NULL) 7689 && (ffestorag_parent (st) != NULL)) 7690 { /* Child of EQUIVALENCE parent. */ 7691 ffestorag est; 7692 tree et; 7693 int yes; 7694 ffetargetOffset offset; 7695 7696 est = ffestorag_parent (st); 7697 ffecom_transform_equiv_ (est); 7698 7699 et = ffestorag_hook (est); 7700 assert (et != NULL_TREE); 7701 7702 if (! TREE_STATIC (et)) 7703 put_var_into_stack (et); 7704 7705 yes = suspend_momentary (); 7706 7707 offset = ffestorag_modulo (est) 7708 + ffestorag_offset (ffesymbol_storage (s)) 7709 - ffestorag_offset (est); 7710 7711 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset); 7712 7713 /* (t_type *) (((char *) &et) + offset) */ 7714 7715 t = convert (string_type_node, /* (char *) */ 7716 ffecom_1 (ADDR_EXPR, 7717 build_pointer_type (TREE_TYPE (et)), 7718 et)); 7719 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), 7720 t, 7721 build_int_2 (offset, 0)); 7722 t = convert (build_pointer_type (type), 7723 t); 7724 TREE_CONSTANT (t) = staticp (et); 7725 7726 addr = TRUE; 7727 7728 resume_momentary (yes); 7729 } 7730 else 7731 { 7732 tree initexpr; 7733 bool init = ffesymbol_is_init (s); 7734 7735 yes = suspend_momentary (); 7736 7737 t = build_decl (VAR_DECL, 7738 ffecom_get_identifier_ (ffesymbol_text (s)), 7739 type); 7740 7741 if (init 7742 || ffesymbol_namelisted (s) 7743#ifdef FFECOM_sizeMAXSTACKITEM 7744 || ((st != NULL) 7745 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)) 7746#endif 7747 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) 7748 && (ffecom_primary_entry_kind_ 7749 != FFEINFO_kindBLOCKDATA) 7750 && (ffesymbol_is_save (s) || ffe_is_saveall ()))) 7751 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE); 7752 else 7753 TREE_STATIC (t) = 0; /* No need to make static. */ 7754 7755 if (init || ffe_is_init_local_zero ()) 7756 DECL_INITIAL (t) = error_mark_node; 7757 7758 /* Keep -Wunused from complaining about var if it 7759 is used as sfunc arg or DATA implied-DO. */ 7760 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG) 7761 DECL_IN_SYSTEM_HEADER (t) = 1; 7762 7763 t = start_decl (t, FALSE); 7764 7765 if (init) 7766 { 7767 if (ffesymbol_init (s) != NULL) 7768 initexpr = ffecom_expr (ffesymbol_init (s)); 7769 else 7770 initexpr = ffecom_init_zero_ (t); 7771 } 7772 else if (ffe_is_init_local_zero ()) 7773 initexpr = ffecom_init_zero_ (t); 7774 else 7775 initexpr = NULL_TREE; /* Not ref'd if !init. */ 7776 7777 finish_decl (t, initexpr, FALSE); 7778 7779 if ((st != NULL) && (DECL_SIZE (t) != error_mark_node)) 7780 { 7781 tree size_tree; 7782 7783 size_tree = size_binop (CEIL_DIV_EXPR, 7784 DECL_SIZE (t), 7785 size_int (BITS_PER_UNIT)); 7786 assert (TREE_INT_CST_HIGH (size_tree) == 0); 7787 assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st)); 7788 } 7789 7790 resume_momentary (yes); 7791 } 7792 } 7793 break; 7794 7795 case FFEINFO_whereRESULT: 7796 assert (!ffecom_transform_only_dummies_); 7797 7798 if (bt == FFEINFO_basictypeCHARACTER) 7799 { /* Result is already in list of dummies, use 7800 it (& length). */ 7801 t = ffecom_func_result_; 7802 tlen = ffecom_func_length_; 7803 addr = TRUE; 7804 break; 7805 } 7806 if ((ffecom_num_entrypoints_ == 0) 7807 && (bt == FFEINFO_basictypeCOMPLEX) 7808 && (ffesymbol_is_f2c (ffecom_primary_entry_))) 7809 { /* Result is already in list of dummies, use 7810 it. */ 7811 t = ffecom_func_result_; 7812 addr = TRUE; 7813 break; 7814 } 7815 if (ffecom_func_result_ != NULL_TREE) 7816 { 7817 t = ffecom_func_result_; 7818 break; 7819 } 7820 if ((ffecom_num_entrypoints_ != 0) 7821 && (ffecom_master_bt_ == FFEINFO_basictypeNONE)) 7822 { 7823 yes = suspend_momentary (); 7824 7825 assert (ffecom_multi_retval_ != NULL_TREE); 7826 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_, 7827 ffecom_multi_retval_); 7828 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt], 7829 t, ffecom_multi_fields_[bt][kt]); 7830 7831 resume_momentary (yes); 7832 break; 7833 } 7834 7835 yes = suspend_momentary (); 7836 7837 t = build_decl (VAR_DECL, 7838 ffecom_get_identifier_ (ffesymbol_text (s)), 7839 ffecom_tree_type[bt][kt]); 7840 TREE_STATIC (t) = 0; /* Put result on stack. */ 7841 t = start_decl (t, FALSE); 7842 finish_decl (t, NULL_TREE, FALSE); 7843 7844 ffecom_func_result_ = t; 7845 7846 resume_momentary (yes); 7847 break; 7848 7849 case FFEINFO_whereDUMMY: 7850 { 7851 tree type; 7852 ffebld dl; 7853 ffebld dim; 7854 tree low; 7855 tree high; 7856 tree old_sizes; 7857 bool adjustable = FALSE; /* Conditionally adjustable? */ 7858 7859 type = ffecom_tree_type[bt][kt]; 7860 if (ffesymbol_sfdummyparent (s) != NULL) 7861 { 7862 if (current_function_decl == ffecom_outer_function_decl_) 7863 { /* Exec transition before sfunc 7864 context; get it later. */ 7865 break; 7866 } 7867 t = ffecom_get_identifier_ (ffesymbol_text 7868 (ffesymbol_sfdummyparent (s))); 7869 } 7870 else 7871 t = ffecom_get_identifier_ (ffesymbol_text (s)); 7872 7873 assert (ffecom_transform_only_dummies_); 7874 7875 old_sizes = get_pending_sizes (); 7876 put_pending_sizes (old_sizes); 7877 7878 if (bt == FFEINFO_basictypeCHARACTER) 7879 tlen = ffecom_char_enhance_arg_ (&type, s); 7880 type = ffecom_check_size_overflow_ (s, type, TRUE); 7881 7882 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) 7883 { 7884 if (type == error_mark_node) 7885 break; 7886 7887 dim = ffebld_head (dl); 7888 assert (ffebld_op (dim) == FFEBLD_opBOUNDS); 7889 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_) 7890 low = ffecom_integer_one_node; 7891 else 7892 low = ffecom_expr (ffebld_left (dim)); 7893 assert (ffebld_right (dim) != NULL); 7894 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR) 7895 || ffecom_doing_entry_) 7896 { 7897 /* Used to just do high=low. But for ffecom_tree_ 7898 canonize_ref_, it probably is important to correctly 7899 assess the size. E.g. given COMPLEX C(*),CFUNC and 7900 C(2)=CFUNC(C), overlap can happen, while it can't 7901 for, say, C(1)=CFUNC(C(2)). */ 7902 /* Even more recently used to set to INT_MAX, but that 7903 broke when some overflow checking went into the back 7904 end. Now we just leave the upper bound unspecified. */ 7905 high = NULL; 7906 } 7907 else 7908 high = ffecom_expr (ffebld_right (dim)); 7909 7910 /* Determine whether array is conditionally adjustable, 7911 to decide whether back-end magic is needed. 7912 7913 Normally the front end uses the back-end function 7914 variable_size to wrap SAVE_EXPR's around expressions 7915 affecting the size/shape of an array so that the 7916 size/shape info doesn't change during execution 7917 of the compiled code even though variables and 7918 functions referenced in those expressions might. 7919 7920 variable_size also makes sure those saved expressions 7921 get evaluated immediately upon entry to the 7922 compiled procedure -- the front end normally doesn't 7923 have to worry about that. 7924 7925 However, there is a problem with this that affects 7926 g77's implementation of entry points, and that is 7927 that it is _not_ true that each invocation of the 7928 compiled procedure is permitted to evaluate 7929 array size/shape info -- because it is possible 7930 that, for some invocations, that info is invalid (in 7931 which case it is "promised" -- i.e. a violation of 7932 the Fortran standard -- that the compiled code 7933 won't reference the array or its size/shape 7934 during that particular invocation). 7935 7936 To phrase this in C terms, consider this gcc function: 7937 7938 void foo (int *n, float (*a)[*n]) 7939 { 7940 // a is "pointer to array ...", fyi. 7941 } 7942 7943 Suppose that, for some invocations, it is permitted 7944 for a caller of foo to do this: 7945 7946 foo (NULL, NULL); 7947 7948 Now the _written_ code for foo can take such a call 7949 into account by either testing explicitly for whether 7950 (a == NULL) || (n == NULL) -- presumably it is 7951 not permitted to reference *a in various fashions 7952 if (n == NULL) I suppose -- or it can avoid it by 7953 looking at other info (other arguments, static/global 7954 data, etc.). 7955 7956 However, this won't work in gcc 2.5.8 because it'll 7957 automatically emit the code to save the "*n" 7958 expression, which'll yield a NULL dereference for 7959 the "foo (NULL, NULL)" call, something the code 7960 for foo cannot prevent. 7961 7962 g77 definitely needs to avoid executing such 7963 code anytime the pointer to the adjustable array 7964 is NULL, because even if its bounds expressions 7965 don't have any references to possible "absent" 7966 variables like "*n" -- say all variable references 7967 are to COMMON variables, i.e. global (though in C, 7968 local static could actually make sense) -- the 7969 expressions could yield other run-time problems 7970 for allowably "dead" values in those variables. 7971 7972 For example, let's consider a more complicated 7973 version of foo: 7974 7975 extern int i; 7976 extern int j; 7977 7978 void foo (float (*a)[i/j]) 7979 { 7980 ... 7981 } 7982 7983 The above is (essentially) quite valid for Fortran 7984 but, again, for a call like "foo (NULL);", it is 7985 permitted for i and j to be undefined when the 7986 call is made. If j happened to be zero, for 7987 example, emitting the code to evaluate "i/j" 7988 could result in a run-time error. 7989 7990 Offhand, though I don't have my F77 or F90 7991 standards handy, it might even be valid for a 7992 bounds expression to contain a function reference, 7993 in which case I doubt it is permitted for an 7994 implementation to invoke that function in the 7995 Fortran case involved here (invocation of an 7996 alternate ENTRY point that doesn't have the adjustable 7997 array as one of its arguments). 7998 7999 So, the code that the compiler would normally emit 8000 to preevaluate the size/shape info for an 8001 adjustable array _must not_ be executed at run time 8002 in certain cases. Specifically, for Fortran, 8003 the case is when the pointer to the adjustable 8004 array == NULL. (For gnu-ish C, it might be nice 8005 for the source code itself to specify an expression 8006 that, if TRUE, inhibits execution of the code. Or 8007 reverse the sense for elegance.) 8008 8009 (Note that g77 could use a different test than NULL, 8010 actually, since it happens to always pass an 8011 integer to the called function that specifies which 8012 entry point is being invoked. Hmm, this might 8013 solve the next problem.) 8014 8015 One way a user could, I suppose, write "foo" so 8016 it works is to insert COND_EXPR's for the 8017 size/shape info so the dangerous stuff isn't 8018 actually done, as in: 8019 8020 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n]) 8021 { 8022 ... 8023 } 8024 8025 The next problem is that the front end needs to 8026 be able to tell the back end about the array's 8027 decl _before_ it tells it about the conditional 8028 expression to inhibit evaluation of size/shape info, 8029 as shown above. 8030 8031 To solve this, the front end needs to be able 8032 to give the back end the expression to inhibit 8033 generation of the preevaluation code _after_ 8034 it makes the decl for the adjustable array. 8035 8036 Until then, the above example using the COND_EXPR 8037 doesn't pass muster with gcc because the "(a == NULL)" 8038 part has a reference to "a", which is still 8039 undefined at that point. 8040 8041 g77 will therefore use a different mechanism in the 8042 meantime. */ 8043 8044 if (!adjustable 8045 && ((TREE_CODE (low) != INTEGER_CST) 8046 || (high && TREE_CODE (high) != INTEGER_CST))) 8047 adjustable = TRUE; 8048 8049#if 0 /* Old approach -- see below. */ 8050 if (TREE_CODE (low) != INTEGER_CST) 8051 low = ffecom_3 (COND_EXPR, integer_type_node, 8052 ffecom_adjarray_passed_ (s), 8053 low, 8054 ffecom_integer_zero_node); 8055 8056 if (high && TREE_CODE (high) != INTEGER_CST) 8057 high = ffecom_3 (COND_EXPR, integer_type_node, 8058 ffecom_adjarray_passed_ (s), 8059 high, 8060 ffecom_integer_zero_node); 8061#endif 8062 8063 /* ~~~gcc/stor-layout.c (layout_type) should do this, 8064 probably. Fixes 950302-1.f. */ 8065 8066 if (TREE_CODE (low) != INTEGER_CST) 8067 low = variable_size (low); 8068 8069 /* ~~~Similarly, this fixes dumb0.f. The C front end 8070 does this, which is why dumb0.c would work. */ 8071 8072 if (high && TREE_CODE (high) != INTEGER_CST) 8073 high = variable_size (high); 8074 8075 type 8076 = build_array_type 8077 (type, 8078 build_range_type (ffecom_integer_type_node, 8079 low, high)); 8080 type = ffecom_check_size_overflow_ (s, type, TRUE); 8081 } 8082 8083 if (type == error_mark_node) 8084 { 8085 t = error_mark_node; 8086 break; 8087 } 8088 8089 if ((ffesymbol_sfdummyparent (s) == NULL) 8090 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) 8091 { 8092 type = build_pointer_type (type); 8093 addr = TRUE; 8094 } 8095 8096 t = build_decl (PARM_DECL, t, type); 8097#if BUILT_FOR_270 8098 DECL_ARTIFICIAL (t) = 1; 8099#endif 8100 8101 /* If this arg is present in every entry point's list of 8102 dummy args, then we're done. */ 8103 8104 if (ffesymbol_numentries (s) 8105 == (ffecom_num_entrypoints_ + 1)) 8106 break; 8107 8108#if 1 8109 8110 /* If variable_size in stor-layout has been called during 8111 the above, then get_pending_sizes should have the 8112 yet-to-be-evaluated saved expressions pending. 8113 Make the whole lot of them get emitted, conditionally 8114 on whether the array decl ("t" above) is not NULL. */ 8115 8116 { 8117 tree sizes = get_pending_sizes (); 8118 tree tem; 8119 8120 for (tem = sizes; 8121 tem != old_sizes; 8122 tem = TREE_CHAIN (tem)) 8123 { 8124 tree temv = TREE_VALUE (tem); 8125 8126 if (sizes == tem) 8127 sizes = temv; 8128 else 8129 sizes 8130 = ffecom_2 (COMPOUND_EXPR, 8131 TREE_TYPE (sizes), 8132 temv, 8133 sizes); 8134 } 8135 8136 if (sizes != tem) 8137 { 8138 sizes 8139 = ffecom_3 (COND_EXPR, 8140 TREE_TYPE (sizes), 8141 ffecom_2 (NE_EXPR, 8142 integer_type_node, 8143 t, 8144 null_pointer_node), 8145 sizes, 8146 convert (TREE_TYPE (sizes), 8147 integer_zero_node)); 8148 sizes = ffecom_save_tree (sizes); 8149 8150 sizes 8151 = tree_cons (NULL_TREE, sizes, tem); 8152 } 8153 8154 if (sizes) 8155 put_pending_sizes (sizes); 8156 } 8157 8158#else 8159#if 0 8160 if (adjustable 8161 && (ffesymbol_numentries (s) 8162 != ffecom_num_entrypoints_ + 1)) 8163 DECL_SOMETHING (t) 8164 = ffecom_2 (NE_EXPR, integer_type_node, 8165 t, 8166 null_pointer_node); 8167#else 8168#if 0 8169 if (adjustable 8170 && (ffesymbol_numentries (s) 8171 != ffecom_num_entrypoints_ + 1)) 8172 { 8173 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED); 8174 ffebad_here (0, ffesymbol_where_line (s), 8175 ffesymbol_where_column (s)); 8176 ffebad_string (ffesymbol_text (s)); 8177 ffebad_finish (); 8178 } 8179#endif 8180#endif 8181#endif 8182 } 8183 break; 8184 8185 case FFEINFO_whereCOMMON: 8186 { 8187 ffesymbol cs; 8188 ffeglobal cg; 8189 tree ct; 8190 ffestorag st = ffesymbol_storage (s); 8191 tree type; 8192 int yes; 8193 8194 cs = ffesymbol_common (s); /* The COMMON area itself. */ 8195 if (st != NULL) /* Else not laid out. */ 8196 { 8197 ffecom_transform_common_ (cs); 8198 st = ffesymbol_storage (s); 8199 } 8200 8201 yes = suspend_momentary (); 8202 8203 type = ffecom_type_localvar_ (s, bt, kt); 8204 8205 cg = ffesymbol_global (cs); /* The global COMMON info. */ 8206 if ((cg == NULL) 8207 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON)) 8208 ct = NULL_TREE; 8209 else 8210 ct = ffeglobal_hook (cg); /* The common area's tree. */ 8211 8212 if ((ct == NULL_TREE) 8213 || (st == NULL) 8214 || (type == error_mark_node)) 8215 t = error_mark_node; 8216 else 8217 { 8218 ffetargetOffset offset; 8219 ffestorag cst; 8220 8221 cst = ffestorag_parent (st); 8222 assert (cst == ffesymbol_storage (cs)); 8223 8224 offset = ffestorag_modulo (cst) 8225 + ffestorag_offset (st) 8226 - ffestorag_offset (cst); 8227 8228 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset); 8229 8230 /* (t_type *) (((char *) &ct) + offset) */ 8231 8232 t = convert (string_type_node, /* (char *) */ 8233 ffecom_1 (ADDR_EXPR, 8234 build_pointer_type (TREE_TYPE (ct)), 8235 ct)); 8236 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), 8237 t, 8238 build_int_2 (offset, 0)); 8239 t = convert (build_pointer_type (type), 8240 t); 8241 TREE_CONSTANT (t) = 1; 8242 8243 addr = TRUE; 8244 } 8245 8246 resume_momentary (yes); 8247 } 8248 break; 8249 8250 case FFEINFO_whereIMMEDIATE: 8251 case FFEINFO_whereGLOBAL: 8252 case FFEINFO_whereFLEETING: 8253 case FFEINFO_whereFLEETING_CADDR: 8254 case FFEINFO_whereFLEETING_IADDR: 8255 case FFEINFO_whereINTRINSIC: 8256 case FFEINFO_whereCONSTANT_SUBOBJECT: 8257 default: 8258 assert ("ENTITY where unheard of" == NULL); 8259 /* Fall through. */ 8260 case FFEINFO_whereANY: 8261 t = error_mark_node; 8262 break; 8263 } 8264 break; 8265 8266 case FFEINFO_kindFUNCTION: 8267 switch (ffeinfo_where (ffesymbol_info (s))) 8268 { 8269 case FFEINFO_whereLOCAL: /* Me. */ 8270 assert (!ffecom_transform_only_dummies_); 8271 t = current_function_decl; 8272 break; 8273 8274 case FFEINFO_whereGLOBAL: 8275 assert (!ffecom_transform_only_dummies_); 8276 8277 if (((g = ffesymbol_global (s)) != NULL) 8278 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) 8279 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) 8280 && (ffeglobal_hook (g) != NULL_TREE) 8281 && ffe_is_globals ()) 8282 { 8283 t = ffeglobal_hook (g); 8284 break; 8285 } 8286 8287 push_obstacks_nochange (); 8288 end_temporary_allocation (); 8289 8290 if (ffesymbol_is_f2c (s) 8291 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) 8292 t = ffecom_tree_fun_type[bt][kt]; 8293 else 8294 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); 8295 8296 t = build_decl (FUNCTION_DECL, 8297 ffecom_get_external_identifier_ (s), 8298 t); 8299 DECL_EXTERNAL (t) = 1; 8300 TREE_PUBLIC (t) = 1; 8301 8302 t = start_decl (t, FALSE); 8303 finish_decl (t, NULL_TREE, FALSE); 8304 8305 if ((g != NULL) 8306 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) 8307 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) 8308 ffeglobal_set_hook (g, t); 8309 8310 resume_temporary_allocation (); 8311 pop_obstacks (); 8312 8313 break; 8314 8315 case FFEINFO_whereDUMMY: 8316 assert (ffecom_transform_only_dummies_); 8317 8318 if (ffesymbol_is_f2c (s) 8319 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) 8320 t = ffecom_tree_ptr_to_fun_type[bt][kt]; 8321 else 8322 t = build_pointer_type 8323 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE)); 8324 8325 t = build_decl (PARM_DECL, 8326 ffecom_get_identifier_ (ffesymbol_text (s)), 8327 t); 8328#if BUILT_FOR_270 8329 DECL_ARTIFICIAL (t) = 1; 8330#endif 8331 addr = TRUE; 8332 break; 8333 8334 case FFEINFO_whereCONSTANT: /* Statement function. */ 8335 assert (!ffecom_transform_only_dummies_); 8336 t = ffecom_gen_sfuncdef_ (s, bt, kt); 8337 break; 8338 8339 case FFEINFO_whereINTRINSIC: 8340 assert (!ffecom_transform_only_dummies_); 8341 break; /* Let actual references generate their 8342 decls. */ 8343 8344 default: 8345 assert ("FUNCTION where unheard of" == NULL); 8346 /* Fall through. */ 8347 case FFEINFO_whereANY: 8348 t = error_mark_node; 8349 break; 8350 } 8351 break; 8352 8353 case FFEINFO_kindSUBROUTINE: 8354 switch (ffeinfo_where (ffesymbol_info (s))) 8355 { 8356 case FFEINFO_whereLOCAL: /* Me. */ 8357 assert (!ffecom_transform_only_dummies_); 8358 t = current_function_decl; 8359 break; 8360 8361 case FFEINFO_whereGLOBAL: 8362 assert (!ffecom_transform_only_dummies_); 8363 8364 if (((g = ffesymbol_global (s)) != NULL) 8365 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) 8366 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) 8367 && (ffeglobal_hook (g) != NULL_TREE) 8368 && ffe_is_globals ()) 8369 { 8370 t = ffeglobal_hook (g); 8371 break; 8372 } 8373 8374 push_obstacks_nochange (); 8375 end_temporary_allocation (); 8376 8377 t = build_decl (FUNCTION_DECL, 8378 ffecom_get_external_identifier_ (s), 8379 ffecom_tree_subr_type); 8380 DECL_EXTERNAL (t) = 1; 8381 TREE_PUBLIC (t) = 1; 8382 8383 t = start_decl (t, FALSE); 8384 finish_decl (t, NULL_TREE, FALSE); 8385 8386 if ((g != NULL) 8387 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) 8388 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) 8389 ffeglobal_set_hook (g, t); 8390 8391 resume_temporary_allocation (); 8392 pop_obstacks (); 8393 8394 break; 8395 8396 case FFEINFO_whereDUMMY: 8397 assert (ffecom_transform_only_dummies_); 8398 8399 t = build_decl (PARM_DECL, 8400 ffecom_get_identifier_ (ffesymbol_text (s)), 8401 ffecom_tree_ptr_to_subr_type); 8402#if BUILT_FOR_270 8403 DECL_ARTIFICIAL (t) = 1; 8404#endif 8405 addr = TRUE; 8406 break; 8407 8408 case FFEINFO_whereINTRINSIC: 8409 assert (!ffecom_transform_only_dummies_); 8410 break; /* Let actual references generate their 8411 decls. */ 8412 8413 default: 8414 assert ("SUBROUTINE where unheard of" == NULL); 8415 /* Fall through. */ 8416 case FFEINFO_whereANY: 8417 t = error_mark_node; 8418 break; 8419 } 8420 break; 8421 8422 case FFEINFO_kindPROGRAM: 8423 switch (ffeinfo_where (ffesymbol_info (s))) 8424 { 8425 case FFEINFO_whereLOCAL: /* Me. */ 8426 assert (!ffecom_transform_only_dummies_); 8427 t = current_function_decl; 8428 break; 8429 8430 case FFEINFO_whereCOMMON: 8431 case FFEINFO_whereDUMMY: 8432 case FFEINFO_whereGLOBAL: 8433 case FFEINFO_whereRESULT: 8434 case FFEINFO_whereFLEETING: 8435 case FFEINFO_whereFLEETING_CADDR: 8436 case FFEINFO_whereFLEETING_IADDR: 8437 case FFEINFO_whereIMMEDIATE: 8438 case FFEINFO_whereINTRINSIC: 8439 case FFEINFO_whereCONSTANT: 8440 case FFEINFO_whereCONSTANT_SUBOBJECT: 8441 default: 8442 assert ("PROGRAM where unheard of" == NULL); 8443 /* Fall through. */ 8444 case FFEINFO_whereANY: 8445 t = error_mark_node; 8446 break; 8447 } 8448 break; 8449 8450 case FFEINFO_kindBLOCKDATA: 8451 switch (ffeinfo_where (ffesymbol_info (s))) 8452 { 8453 case FFEINFO_whereLOCAL: /* Me. */ 8454 assert (!ffecom_transform_only_dummies_); 8455 t = current_function_decl; 8456 break; 8457 8458 case FFEINFO_whereGLOBAL: 8459 assert (!ffecom_transform_only_dummies_); 8460 8461 push_obstacks_nochange (); 8462 end_temporary_allocation (); 8463 8464 t = build_decl (FUNCTION_DECL, 8465 ffecom_get_external_identifier_ (s), 8466 ffecom_tree_blockdata_type); 8467 DECL_EXTERNAL (t) = 1; 8468 TREE_PUBLIC (t) = 1; 8469 8470 t = start_decl (t, FALSE); 8471 finish_decl (t, NULL_TREE, FALSE); 8472 8473 resume_temporary_allocation (); 8474 pop_obstacks (); 8475 8476 break; 8477 8478 case FFEINFO_whereCOMMON: 8479 case FFEINFO_whereDUMMY: 8480 case FFEINFO_whereRESULT: 8481 case FFEINFO_whereFLEETING: 8482 case FFEINFO_whereFLEETING_CADDR: 8483 case FFEINFO_whereFLEETING_IADDR: 8484 case FFEINFO_whereIMMEDIATE: 8485 case FFEINFO_whereINTRINSIC: 8486 case FFEINFO_whereCONSTANT: 8487 case FFEINFO_whereCONSTANT_SUBOBJECT: 8488 default: 8489 assert ("BLOCKDATA where unheard of" == NULL); 8490 /* Fall through. */ 8491 case FFEINFO_whereANY: 8492 t = error_mark_node; 8493 break; 8494 } 8495 break; 8496 8497 case FFEINFO_kindCOMMON: 8498 switch (ffeinfo_where (ffesymbol_info (s))) 8499 { 8500 case FFEINFO_whereLOCAL: 8501 assert (!ffecom_transform_only_dummies_); 8502 ffecom_transform_common_ (s); 8503 break; 8504 8505 case FFEINFO_whereNONE: 8506 case FFEINFO_whereCOMMON: 8507 case FFEINFO_whereDUMMY: 8508 case FFEINFO_whereGLOBAL: 8509 case FFEINFO_whereRESULT: 8510 case FFEINFO_whereFLEETING: 8511 case FFEINFO_whereFLEETING_CADDR: 8512 case FFEINFO_whereFLEETING_IADDR: 8513 case FFEINFO_whereIMMEDIATE: 8514 case FFEINFO_whereINTRINSIC: 8515 case FFEINFO_whereCONSTANT: 8516 case FFEINFO_whereCONSTANT_SUBOBJECT: 8517 default: 8518 assert ("COMMON where unheard of" == NULL); 8519 /* Fall through. */ 8520 case FFEINFO_whereANY: 8521 t = error_mark_node; 8522 break; 8523 } 8524 break; 8525 8526 case FFEINFO_kindCONSTRUCT: 8527 switch (ffeinfo_where (ffesymbol_info (s))) 8528 { 8529 case FFEINFO_whereLOCAL: 8530 assert (!ffecom_transform_only_dummies_); 8531 break; 8532 8533 case FFEINFO_whereNONE: 8534 case FFEINFO_whereCOMMON: 8535 case FFEINFO_whereDUMMY: 8536 case FFEINFO_whereGLOBAL: 8537 case FFEINFO_whereRESULT: 8538 case FFEINFO_whereFLEETING: 8539 case FFEINFO_whereFLEETING_CADDR: 8540 case FFEINFO_whereFLEETING_IADDR: 8541 case FFEINFO_whereIMMEDIATE: 8542 case FFEINFO_whereINTRINSIC: 8543 case FFEINFO_whereCONSTANT: 8544 case FFEINFO_whereCONSTANT_SUBOBJECT: 8545 default: 8546 assert ("CONSTRUCT where unheard of" == NULL); 8547 /* Fall through. */ 8548 case FFEINFO_whereANY: 8549 t = error_mark_node; 8550 break; 8551 } 8552 break; 8553 8554 case FFEINFO_kindNAMELIST: 8555 switch (ffeinfo_where (ffesymbol_info (s))) 8556 { 8557 case FFEINFO_whereLOCAL: 8558 assert (!ffecom_transform_only_dummies_); 8559 t = ffecom_transform_namelist_ (s); 8560 break; 8561 8562 case FFEINFO_whereNONE: 8563 case FFEINFO_whereCOMMON: 8564 case FFEINFO_whereDUMMY: 8565 case FFEINFO_whereGLOBAL: 8566 case FFEINFO_whereRESULT: 8567 case FFEINFO_whereFLEETING: 8568 case FFEINFO_whereFLEETING_CADDR: 8569 case FFEINFO_whereFLEETING_IADDR: 8570 case FFEINFO_whereIMMEDIATE: 8571 case FFEINFO_whereINTRINSIC: 8572 case FFEINFO_whereCONSTANT: 8573 case FFEINFO_whereCONSTANT_SUBOBJECT: 8574 default: 8575 assert ("NAMELIST where unheard of" == NULL); 8576 /* Fall through. */ 8577 case FFEINFO_whereANY: 8578 t = error_mark_node; 8579 break; 8580 } 8581 break; 8582 8583 default: 8584 assert ("kind unheard of" == NULL); 8585 /* Fall through. */ 8586 case FFEINFO_kindANY: 8587 t = error_mark_node; 8588 break; 8589 } 8590 8591 ffesymbol_hook (s).decl_tree = t; 8592 ffesymbol_hook (s).length_tree = tlen; 8593 ffesymbol_hook (s).addr = addr; 8594 8595 lineno = old_lineno; 8596 input_filename = old_input_filename; 8597 8598 return s; 8599} 8600 8601#endif 8602/* Transform into ASSIGNable symbol. 8603 8604 Symbol has already been transformed, but for whatever reason, the 8605 resulting decl_tree has been deemed not usable for an ASSIGN target. 8606 (E.g. it isn't wide enough to hold a pointer.) So, here we invent 8607 another local symbol of type void * and stuff that in the assign_tree 8608 argument. The F77/F90 standards allow this implementation. */ 8609 8610#if FFECOM_targetCURRENT == FFECOM_targetGCC 8611static ffesymbol 8612ffecom_sym_transform_assign_ (ffesymbol s) 8613{ 8614 tree t; /* Transformed thingy. */ 8615 int yes; 8616 int old_lineno = lineno; 8617 char *old_input_filename = input_filename; 8618 8619 if (ffesymbol_sfdummyparent (s) == NULL) 8620 { 8621 input_filename = ffesymbol_where_filename (s); 8622 lineno = ffesymbol_where_filelinenum (s); 8623 } 8624 else 8625 { 8626 ffesymbol sf = ffesymbol_sfdummyparent (s); 8627 8628 input_filename = ffesymbol_where_filename (sf); 8629 lineno = ffesymbol_where_filelinenum (sf); 8630 } 8631 8632 assert (!ffecom_transform_only_dummies_); 8633 8634 yes = suspend_momentary (); 8635 8636 t = build_decl (VAR_DECL, 8637 ffecom_get_invented_identifier ("__g77_ASSIGN_%s", 8638 ffesymbol_text (s), 8639 -1), 8640 TREE_TYPE (null_pointer_node)); 8641 8642 switch (ffesymbol_where (s)) 8643 { 8644 case FFEINFO_whereLOCAL: 8645 /* Unlike for regular vars, SAVE status is easy to determine for 8646 ASSIGNed vars, since there's no initialization, there's no 8647 effective storage association (so "SAVE J" does not apply to 8648 K even given "EQUIVALENCE (J,K)"), there's no size issue 8649 to worry about, etc. */ 8650 if ((ffesymbol_is_save (s) || ffe_is_saveall ()) 8651 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) 8652 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)) 8653 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */ 8654 else 8655 TREE_STATIC (t) = 0; /* No need to make static. */ 8656 break; 8657 8658 case FFEINFO_whereCOMMON: 8659 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */ 8660 break; 8661 8662 case FFEINFO_whereDUMMY: 8663 /* Note that twinning a DUMMY means the caller won't see 8664 the ASSIGNed value. But both F77 and F90 allow implementations 8665 to do this, i.e. disallow Fortran code that would try and 8666 take advantage of actually putting a label into a variable 8667 via a dummy argument (or any other storage association, for 8668 that matter). */ 8669 TREE_STATIC (t) = 0; 8670 break; 8671 8672 default: 8673 TREE_STATIC (t) = 0; 8674 break; 8675 } 8676 8677 t = start_decl (t, FALSE); 8678 finish_decl (t, NULL_TREE, FALSE); 8679 8680 resume_momentary (yes); 8681 8682 ffesymbol_hook (s).assign_tree = t; 8683 8684 lineno = old_lineno; 8685 input_filename = old_input_filename; 8686 8687 return s; 8688} 8689 8690#endif 8691/* Implement COMMON area in back end. 8692 8693 Because COMMON-based variables can be referenced in the dimension 8694 expressions of dummy (adjustable) arrays, and because dummies 8695 (in the gcc back end) need to be put in the outer binding level 8696 of a function (which has two binding levels, the outer holding 8697 the dummies and the inner holding the other vars), special care 8698 must be taken to handle COMMON areas. 8699 8700 The current strategy is basically to always tell the back end about 8701 the COMMON area as a top-level external reference to just a block 8702 of storage of the master type of that area (e.g. integer, real, 8703 character, whatever -- not a structure). As a distinct action, 8704 if initial values are provided, tell the back end about the area 8705 as a top-level non-external (initialized) area and remember not to 8706 allow further initialization or expansion of the area. Meanwhile, 8707 if no initialization happens at all, tell the back end about 8708 the largest size we've seen declared so the space does get reserved. 8709 (This function doesn't handle all that stuff, but it does some 8710 of the important things.) 8711 8712 Meanwhile, for COMMON variables themselves, just keep creating 8713 references like *((float *) (&common_area + offset)) each time 8714 we reference the variable. In other words, don't make a VAR_DECL 8715 or any kind of component reference (like we used to do before 0.4), 8716 though we might do that as well just for debugging purposes (and 8717 stuff the rtl with the appropriate offset expression). */ 8718 8719#if FFECOM_targetCURRENT == FFECOM_targetGCC 8720static void 8721ffecom_transform_common_ (ffesymbol s) 8722{ 8723 ffestorag st = ffesymbol_storage (s); 8724 ffeglobal g = ffesymbol_global (s); 8725 tree cbt; 8726 tree cbtype; 8727 tree init; 8728 tree high; 8729 bool is_init = ffestorag_is_init (st); 8730 8731 assert (st != NULL); 8732 8733 if ((g == NULL) 8734 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON)) 8735 return; 8736 8737 /* First update the size of the area in global terms. */ 8738 8739 ffeglobal_size_common (s, ffestorag_size (st)); 8740 8741 if (!ffeglobal_common_init (g)) 8742 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */ 8743 8744 cbt = ffeglobal_hook (g); 8745 8746 /* If we already have declared this common block for a previous program 8747 unit, and either we already initialized it or we don't have new 8748 initialization for it, just return what we have without changing it. */ 8749 8750 if ((cbt != NULL_TREE) 8751 && (!is_init 8752 || !DECL_EXTERNAL (cbt))) 8753 return; 8754 8755 /* Process inits. */ 8756 8757 if (is_init) 8758 { 8759 if (ffestorag_init (st) != NULL) 8760 { 8761 ffebld sexp; 8762 8763 /* Set the padding for the expression, so ffecom_expr 8764 knows to insert that many zeros. */ 8765 switch (ffebld_op (sexp = ffestorag_init (st))) 8766 { 8767 case FFEBLD_opCONTER: 8768 ffebld_conter_set_pad (sexp, ffestorag_modulo (st)); 8769 break; 8770 8771 case FFEBLD_opARRTER: 8772 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st)); 8773 break; 8774 8775 case FFEBLD_opACCTER: 8776 ffebld_accter_set_pad (sexp, ffestorag_modulo (st)); 8777 break; 8778 8779 default: 8780 assert ("bad op for cmn init (pad)" == NULL); 8781 break; 8782 } 8783 8784 init = ffecom_expr (sexp); 8785 if (init == error_mark_node) 8786 { /* Hopefully the back end complained! */ 8787 init = NULL_TREE; 8788 if (cbt != NULL_TREE) 8789 return; 8790 } 8791 } 8792 else 8793 init = error_mark_node; 8794 } 8795 else 8796 init = NULL_TREE; 8797 8798 push_obstacks_nochange (); 8799 end_temporary_allocation (); 8800 8801 /* cbtype must be permanently allocated! */ 8802 8803 /* Allocate the MAX of the areas so far, seen filewide. */ 8804 high = build_int_2 ((ffeglobal_common_size (g) 8805 + ffeglobal_common_pad (g)) - 1, 0); 8806 TREE_TYPE (high) = ffecom_integer_type_node; 8807 8808 if (init) 8809 cbtype = build_array_type (char_type_node, 8810 build_range_type (integer_type_node, 8811 integer_zero_node, 8812 high)); 8813 else 8814 cbtype = build_array_type (char_type_node, NULL_TREE); 8815 8816 if (cbt == NULL_TREE) 8817 { 8818 cbt 8819 = build_decl (VAR_DECL, 8820 ffecom_get_external_identifier_ (s), 8821 cbtype); 8822 TREE_STATIC (cbt) = 1; 8823 TREE_PUBLIC (cbt) = 1; 8824 } 8825 else 8826 { 8827 assert (is_init); 8828 TREE_TYPE (cbt) = cbtype; 8829 } 8830 DECL_EXTERNAL (cbt) = init ? 0 : 1; 8831 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE; 8832 8833 cbt = start_decl (cbt, TRUE); 8834 if (ffeglobal_hook (g) != NULL) 8835 assert (cbt == ffeglobal_hook (g)); 8836 8837 assert (!init || !DECL_EXTERNAL (cbt)); 8838 8839 /* Make sure that any type can live in COMMON and be referenced 8840 without getting a bus error. We could pick the most restrictive 8841 alignment of all entities actually placed in the COMMON, but 8842 this seems easy enough. */ 8843 8844 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT; 8845 8846 if (is_init && (ffestorag_init (st) == NULL)) 8847 init = ffecom_init_zero_ (cbt); 8848 8849 finish_decl (cbt, init, TRUE); 8850 8851 if (is_init) 8852 ffestorag_set_init (st, ffebld_new_any ()); 8853 8854 if (init) 8855 { 8856 tree size_tree; 8857 8858 assert (DECL_SIZE (cbt) != NULL_TREE); 8859 assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST); 8860 size_tree = size_binop (CEIL_DIV_EXPR, 8861 DECL_SIZE (cbt), 8862 size_int (BITS_PER_UNIT)); 8863 assert (TREE_INT_CST_HIGH (size_tree) == 0); 8864 assert (TREE_INT_CST_LOW (size_tree) 8865 == ffeglobal_common_size (g) + ffeglobal_common_pad (g)); 8866 } 8867 8868 ffeglobal_set_hook (g, cbt); 8869 8870 ffestorag_set_hook (st, cbt); 8871 8872 resume_temporary_allocation (); 8873 pop_obstacks (); 8874} 8875 8876#endif 8877/* Make master area for local EQUIVALENCE. */ 8878 8879#if FFECOM_targetCURRENT == FFECOM_targetGCC 8880static void 8881ffecom_transform_equiv_ (ffestorag eqst) 8882{ 8883 tree eqt; 8884 tree eqtype; 8885 tree init; 8886 tree high; 8887 bool is_init = ffestorag_is_init (eqst); 8888 int yes; 8889 8890 assert (eqst != NULL); 8891 8892 eqt = ffestorag_hook (eqst); 8893 8894 if (eqt != NULL_TREE) 8895 return; 8896 8897 /* Process inits. */ 8898 8899 if (is_init) 8900 { 8901 if (ffestorag_init (eqst) != NULL) 8902 { 8903 ffebld sexp; 8904 8905 /* Set the padding for the expression, so ffecom_expr 8906 knows to insert that many zeros. */ 8907 switch (ffebld_op (sexp = ffestorag_init (eqst))) 8908 { 8909 case FFEBLD_opCONTER: 8910 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst)); 8911 break; 8912 8913 case FFEBLD_opARRTER: 8914 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst)); 8915 break; 8916 8917 case FFEBLD_opACCTER: 8918 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst)); 8919 break; 8920 8921 default: 8922 assert ("bad op for eqv init (pad)" == NULL); 8923 break; 8924 } 8925 8926 init = ffecom_expr (sexp); 8927 if (init == error_mark_node) 8928 init = NULL_TREE; /* Hopefully the back end complained! */ 8929 } 8930 else 8931 init = error_mark_node; 8932 } 8933 else if (ffe_is_init_local_zero ()) 8934 init = error_mark_node; 8935 else 8936 init = NULL_TREE; 8937 8938 ffecom_member_namelisted_ = FALSE; 8939 ffestorag_drive (ffestorag_list_equivs (eqst), 8940 &ffecom_member_phase1_, 8941 eqst); 8942 8943 yes = suspend_momentary (); 8944 8945 high = build_int_2 ((ffestorag_size (eqst) 8946 + ffestorag_modulo (eqst)) - 1, 0); 8947 TREE_TYPE (high) = ffecom_integer_type_node; 8948 8949 eqtype = build_array_type (char_type_node, 8950 build_range_type (ffecom_integer_type_node, 8951 ffecom_integer_zero_node, 8952 high)); 8953 8954 eqt = build_decl (VAR_DECL, 8955 ffecom_get_invented_identifier ("__g77_equiv_%s", 8956 ffesymbol_text 8957 (ffestorag_symbol 8958 (eqst)), 8959 -1), 8960 eqtype); 8961 DECL_EXTERNAL (eqt) = 0; 8962 if (is_init 8963 || ffecom_member_namelisted_ 8964#ifdef FFECOM_sizeMAXSTACKITEM 8965 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM) 8966#endif 8967 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) 8968 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) 8969 && (ffestorag_is_save (eqst) || ffe_is_saveall ()))) 8970 TREE_STATIC (eqt) = 1; 8971 else 8972 TREE_STATIC (eqt) = 0; 8973 TREE_PUBLIC (eqt) = 0; 8974 DECL_CONTEXT (eqt) = current_function_decl; 8975 if (init) 8976 DECL_INITIAL (eqt) = error_mark_node; 8977 else 8978 DECL_INITIAL (eqt) = NULL_TREE; 8979 8980 eqt = start_decl (eqt, FALSE); 8981 8982 /* Make sure that any type can live in EQUIVALENCE and be referenced 8983 without getting a bus error. We could pick the most restrictive 8984 alignment of all entities actually placed in the EQUIVALENCE, but 8985 this seems easy enough. */ 8986 8987 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT; 8988 8989 if ((!is_init && ffe_is_init_local_zero ()) 8990 || (is_init && (ffestorag_init (eqst) == NULL))) 8991 init = ffecom_init_zero_ (eqt); 8992 8993 finish_decl (eqt, init, FALSE); 8994 8995 if (is_init) 8996 ffestorag_set_init (eqst, ffebld_new_any ()); 8997 8998 { 8999 tree size_tree; 9000 9001 size_tree = size_binop (CEIL_DIV_EXPR, 9002 DECL_SIZE (eqt), 9003 size_int (BITS_PER_UNIT)); 9004 assert (TREE_INT_CST_HIGH (size_tree) == 0); 9005 assert (TREE_INT_CST_LOW (size_tree) 9006 == ffestorag_size (eqst) + ffestorag_modulo (eqst)); 9007 } 9008 9009 ffestorag_set_hook (eqst, eqt); 9010 9011#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING 9012 ffestorag_drive (ffestorag_list_equivs (eqst), 9013 &ffecom_member_phase2_, 9014 eqst); 9015#endif 9016 9017 resume_momentary (yes); 9018} 9019 9020#endif 9021/* Implement NAMELIST in back end. See f2c/format.c for more info. */ 9022 9023#if FFECOM_targetCURRENT == FFECOM_targetGCC 9024static tree 9025ffecom_transform_namelist_ (ffesymbol s) 9026{ 9027 tree nmlt; 9028 tree nmltype = ffecom_type_namelist_ (); 9029 tree nmlinits; 9030 tree nameinit; 9031 tree varsinit; 9032 tree nvarsinit; 9033 tree field; 9034 tree high; 9035 int yes; 9036 int i; 9037 static int mynumber = 0; 9038 9039 yes = suspend_momentary (); 9040 9041 nmlt = build_decl (VAR_DECL, 9042 ffecom_get_invented_identifier ("__g77_namelist_%d", 9043 NULL, mynumber++), 9044 nmltype); 9045 TREE_STATIC (nmlt) = 1; 9046 DECL_INITIAL (nmlt) = error_mark_node; 9047 9048 nmlt = start_decl (nmlt, FALSE); 9049 9050 /* Process inits. */ 9051 9052 i = strlen (ffesymbol_text (s)); 9053 9054 high = build_int_2 (i, 0); 9055 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; 9056 9057 nameinit = ffecom_build_f2c_string_ (i + 1, 9058 ffesymbol_text (s)); 9059 TREE_TYPE (nameinit) 9060 = build_type_variant 9061 (build_array_type 9062 (char_type_node, 9063 build_range_type (ffecom_f2c_ftnlen_type_node, 9064 ffecom_f2c_ftnlen_one_node, 9065 high)), 9066 1, 0); 9067 TREE_CONSTANT (nameinit) = 1; 9068 TREE_STATIC (nameinit) = 1; 9069 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)), 9070 nameinit); 9071 9072 varsinit = ffecom_vardesc_array_ (s); 9073 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)), 9074 varsinit); 9075 TREE_CONSTANT (varsinit) = 1; 9076 TREE_STATIC (varsinit) = 1; 9077 9078 { 9079 ffebld b; 9080 9081 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b)) 9082 ++i; 9083 } 9084 nvarsinit = build_int_2 (i, 0); 9085 TREE_TYPE (nvarsinit) = integer_type_node; 9086 TREE_CONSTANT (nvarsinit) = 1; 9087 TREE_STATIC (nvarsinit) = 1; 9088 9089 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit); 9090 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)), 9091 varsinit); 9092 TREE_CHAIN (TREE_CHAIN (nmlinits)) 9093 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit); 9094 9095 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits); 9096 TREE_CONSTANT (nmlinits) = 1; 9097 TREE_STATIC (nmlinits) = 1; 9098 9099 finish_decl (nmlt, nmlinits, FALSE); 9100 9101 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); 9102 9103 resume_momentary (yes); 9104 9105 return nmlt; 9106} 9107 9108#endif 9109 9110/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is 9111 analyzed on the assumption it is calculating a pointer to be 9112 indirected through. It must return the proper decl and offset, 9113 taking into account different units of measurements for offsets. */ 9114 9115#if FFECOM_targetCURRENT == FFECOM_targetGCC 9116static void 9117ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, 9118 tree t) 9119{ 9120 switch (TREE_CODE (t)) 9121 { 9122 case NOP_EXPR: 9123 case CONVERT_EXPR: 9124 case NON_LVALUE_EXPR: 9125 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); 9126 break; 9127 9128 case PLUS_EXPR: 9129 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); 9130 if ((*decl == NULL_TREE) 9131 || (*decl == error_mark_node)) 9132 break; 9133 9134 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST) 9135 { 9136 /* An offset into COMMON. */ 9137 *offset = size_binop (PLUS_EXPR, 9138 *offset, 9139 TREE_OPERAND (t, 1)); 9140 /* Convert offset (presumably in bytes) into canonical units 9141 (presumably bits). */ 9142 *offset = size_binop (MULT_EXPR, 9143 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))), 9144 *offset); 9145 break; 9146 } 9147 /* Not a COMMON reference, so an unrecognized pattern. */ 9148 *decl = error_mark_node; 9149 break; 9150 9151 case PARM_DECL: 9152 *decl = t; 9153 *offset = bitsize_int (0L, 0L); 9154 break; 9155 9156 case ADDR_EXPR: 9157 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL) 9158 { 9159 /* A reference to COMMON. */ 9160 *decl = TREE_OPERAND (t, 0); 9161 *offset = bitsize_int (0L, 0L); 9162 break; 9163 } 9164 /* Fall through. */ 9165 default: 9166 /* Not a COMMON reference, so an unrecognized pattern. */ 9167 *decl = error_mark_node; 9168 break; 9169 } 9170} 9171#endif 9172 9173/* Given a tree that is possibly intended for use as an lvalue, return 9174 information representing a canonical view of that tree as a decl, an 9175 offset into that decl, and a size for the lvalue. 9176 9177 If there's no applicable decl, NULL_TREE is returned for the decl, 9178 and the other fields are left undefined. 9179 9180 If the tree doesn't fit the recognizable forms, an ERROR_MARK node 9181 is returned for the decl, and the other fields are left undefined. 9182 9183 Otherwise, the decl returned currently is either a VAR_DECL or a 9184 PARM_DECL. 9185 9186 The offset returned is always valid, but of course not necessarily 9187 a constant, and not necessarily converted into the appropriate 9188 type, leaving that up to the caller (so as to avoid that overhead 9189 if the decls being looked at are different anyway). 9190 9191 If the size cannot be determined (e.g. an adjustable array), 9192 an ERROR_MARK node is returned for the size. Otherwise, the 9193 size returned is valid, not necessarily a constant, and not 9194 necessarily converted into the appropriate type as with the 9195 offset. 9196 9197 Note that the offset and size expressions are expressed in the 9198 base storage units (usually bits) rather than in the units of 9199 the type of the decl, because two decls with different types 9200 might overlap but with apparently non-overlapping array offsets, 9201 whereas converting the array offsets to consistant offsets will 9202 reveal the overlap. */ 9203 9204#if FFECOM_targetCURRENT == FFECOM_targetGCC 9205static void 9206ffecom_tree_canonize_ref_ (tree *decl, tree *offset, 9207 tree *size, tree t) 9208{ 9209 /* The default path is to report a nonexistant decl. */ 9210 *decl = NULL_TREE; 9211 9212 if (t == NULL_TREE) 9213 return; 9214 9215 switch (TREE_CODE (t)) 9216 { 9217 case ERROR_MARK: 9218 case IDENTIFIER_NODE: 9219 case INTEGER_CST: 9220 case REAL_CST: 9221 case COMPLEX_CST: 9222 case STRING_CST: 9223 case CONST_DECL: 9224 case PLUS_EXPR: 9225 case MINUS_EXPR: 9226 case MULT_EXPR: 9227 case TRUNC_DIV_EXPR: 9228 case CEIL_DIV_EXPR: 9229 case FLOOR_DIV_EXPR: 9230 case ROUND_DIV_EXPR: 9231 case TRUNC_MOD_EXPR: 9232 case CEIL_MOD_EXPR: 9233 case FLOOR_MOD_EXPR: 9234 case ROUND_MOD_EXPR: 9235 case RDIV_EXPR: 9236 case EXACT_DIV_EXPR: 9237 case FIX_TRUNC_EXPR: 9238 case FIX_CEIL_EXPR: 9239 case FIX_FLOOR_EXPR: 9240 case FIX_ROUND_EXPR: 9241 case FLOAT_EXPR: 9242 case EXPON_EXPR: 9243 case NEGATE_EXPR: 9244 case MIN_EXPR: 9245 case MAX_EXPR: 9246 case ABS_EXPR: 9247 case FFS_EXPR: 9248 case LSHIFT_EXPR: 9249 case RSHIFT_EXPR: 9250 case LROTATE_EXPR: 9251 case RROTATE_EXPR: 9252 case BIT_IOR_EXPR: 9253 case BIT_XOR_EXPR: 9254 case BIT_AND_EXPR: 9255 case BIT_ANDTC_EXPR: 9256 case BIT_NOT_EXPR: 9257 case TRUTH_ANDIF_EXPR: 9258 case TRUTH_ORIF_EXPR: 9259 case TRUTH_AND_EXPR: 9260 case TRUTH_OR_EXPR: 9261 case TRUTH_XOR_EXPR: 9262 case TRUTH_NOT_EXPR: 9263 case LT_EXPR: 9264 case LE_EXPR: 9265 case GT_EXPR: 9266 case GE_EXPR: 9267 case EQ_EXPR: 9268 case NE_EXPR: 9269 case COMPLEX_EXPR: 9270 case CONJ_EXPR: 9271 case REALPART_EXPR: 9272 case IMAGPART_EXPR: 9273 case LABEL_EXPR: 9274 case COMPONENT_REF: 9275 case COMPOUND_EXPR: 9276 case ADDR_EXPR: 9277 return; 9278 9279 case VAR_DECL: 9280 case PARM_DECL: 9281 *decl = t; 9282 *offset = bitsize_int (0L, 0L); 9283 *size = TYPE_SIZE (TREE_TYPE (t)); 9284 return; 9285 9286 case ARRAY_REF: 9287 { 9288 tree array = TREE_OPERAND (t, 0); 9289 tree element = TREE_OPERAND (t, 1); 9290 tree init_offset; 9291 9292 if ((array == NULL_TREE) 9293 || (element == NULL_TREE)) 9294 { 9295 *decl = error_mark_node; 9296 return; 9297 } 9298 9299 ffecom_tree_canonize_ref_ (decl, &init_offset, size, 9300 array); 9301 if ((*decl == NULL_TREE) 9302 || (*decl == error_mark_node)) 9303 return; 9304 9305 *offset = size_binop (MULT_EXPR, 9306 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))), 9307 size_binop (MINUS_EXPR, 9308 element, 9309 TYPE_MIN_VALUE 9310 (TYPE_DOMAIN 9311 (TREE_TYPE (array))))); 9312 9313 *offset = size_binop (PLUS_EXPR, 9314 init_offset, 9315 *offset); 9316 9317 *size = TYPE_SIZE (TREE_TYPE (t)); 9318 return; 9319 } 9320 9321 case INDIRECT_REF: 9322 9323 /* Most of this code is to handle references to COMMON. And so 9324 far that is useful only for calling library functions, since 9325 external (user) functions might reference common areas. But 9326 even calling an external function, it's worthwhile to decode 9327 COMMON references because if not storing into COMMON, we don't 9328 want COMMON-based arguments to gratuitously force use of a 9329 temporary. */ 9330 9331 *size = TYPE_SIZE (TREE_TYPE (t)); 9332 9333 ffecom_tree_canonize_ptr_ (decl, offset, 9334 TREE_OPERAND (t, 0)); 9335 9336 return; 9337 9338 case CONVERT_EXPR: 9339 case NOP_EXPR: 9340 case MODIFY_EXPR: 9341 case NON_LVALUE_EXPR: 9342 case RESULT_DECL: 9343 case FIELD_DECL: 9344 case COND_EXPR: /* More cases than we can handle. */ 9345 case SAVE_EXPR: 9346 case REFERENCE_EXPR: 9347 case PREDECREMENT_EXPR: 9348 case PREINCREMENT_EXPR: 9349 case POSTDECREMENT_EXPR: 9350 case POSTINCREMENT_EXPR: 9351 case CALL_EXPR: 9352 default: 9353 *decl = error_mark_node; 9354 return; 9355 } 9356} 9357#endif 9358 9359/* Do divide operation appropriate to type of operands. */ 9360 9361#if FFECOM_targetCURRENT == FFECOM_targetGCC 9362static tree 9363ffecom_tree_divide_ (tree tree_type, tree left, tree right, 9364 tree dest_tree, ffebld dest, bool *dest_used, 9365 tree hook) 9366{ 9367 if ((left == error_mark_node) 9368 || (right == error_mark_node)) 9369 return error_mark_node; 9370 9371 switch (TREE_CODE (tree_type)) 9372 { 9373 case INTEGER_TYPE: 9374 return ffecom_2 (TRUNC_DIV_EXPR, tree_type, 9375 left, 9376 right); 9377 9378 case COMPLEX_TYPE: 9379 if (! optimize_size) 9380 return ffecom_2 (RDIV_EXPR, tree_type, 9381 left, 9382 right); 9383 { 9384 ffecomGfrt ix; 9385 9386 if (TREE_TYPE (tree_type) 9387 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) 9388 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ 9389 else 9390 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ 9391 9392 left = ffecom_1 (ADDR_EXPR, 9393 build_pointer_type (TREE_TYPE (left)), 9394 left); 9395 left = build_tree_list (NULL_TREE, left); 9396 right = ffecom_1 (ADDR_EXPR, 9397 build_pointer_type (TREE_TYPE (right)), 9398 right); 9399 right = build_tree_list (NULL_TREE, right); 9400 TREE_CHAIN (left) = right; 9401 9402 return ffecom_call_ (ffecom_gfrt_tree_ (ix), 9403 ffecom_gfrt_kindtype (ix), 9404 ffe_is_f2c_library (), 9405 tree_type, 9406 left, 9407 dest_tree, dest, dest_used, 9408 NULL_TREE, TRUE, hook); 9409 } 9410 break; 9411 9412 case RECORD_TYPE: 9413 { 9414 ffecomGfrt ix; 9415 9416 if (TREE_TYPE (TYPE_FIELDS (tree_type)) 9417 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) 9418 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ 9419 else 9420 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ 9421 9422 left = ffecom_1 (ADDR_EXPR, 9423 build_pointer_type (TREE_TYPE (left)), 9424 left); 9425 left = build_tree_list (NULL_TREE, left); 9426 right = ffecom_1 (ADDR_EXPR, 9427 build_pointer_type (TREE_TYPE (right)), 9428 right); 9429 right = build_tree_list (NULL_TREE, right); 9430 TREE_CHAIN (left) = right; 9431 9432 return ffecom_call_ (ffecom_gfrt_tree_ (ix), 9433 ffecom_gfrt_kindtype (ix), 9434 ffe_is_f2c_library (), 9435 tree_type, 9436 left, 9437 dest_tree, dest, dest_used, 9438 NULL_TREE, TRUE, hook); 9439 } 9440 break; 9441 9442 default: 9443 return ffecom_2 (RDIV_EXPR, tree_type, 9444 left, 9445 right); 9446 } 9447} 9448 9449#endif 9450/* Build type info for non-dummy variable. */ 9451 9452#if FFECOM_targetCURRENT == FFECOM_targetGCC 9453static tree 9454ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, 9455 ffeinfoKindtype kt) 9456{ 9457 tree type; 9458 ffebld dl; 9459 ffebld dim; 9460 tree lowt; 9461 tree hight; 9462 9463 type = ffecom_tree_type[bt][kt]; 9464 if (bt == FFEINFO_basictypeCHARACTER) 9465 { 9466 hight = build_int_2 (ffesymbol_size (s), 0); 9467 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node; 9468 9469 type 9470 = build_array_type 9471 (type, 9472 build_range_type (ffecom_f2c_ftnlen_type_node, 9473 ffecom_f2c_ftnlen_one_node, 9474 hight)); 9475 type = ffecom_check_size_overflow_ (s, type, FALSE); 9476 } 9477 9478 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) 9479 { 9480 if (type == error_mark_node) 9481 break; 9482 9483 dim = ffebld_head (dl); 9484 assert (ffebld_op (dim) == FFEBLD_opBOUNDS); 9485 9486 if (ffebld_left (dim) == NULL) 9487 lowt = integer_one_node; 9488 else 9489 lowt = ffecom_expr (ffebld_left (dim)); 9490 9491 if (TREE_CODE (lowt) != INTEGER_CST) 9492 lowt = variable_size (lowt); 9493 9494 assert (ffebld_right (dim) != NULL); 9495 hight = ffecom_expr (ffebld_right (dim)); 9496 9497 if (TREE_CODE (hight) != INTEGER_CST) 9498 hight = variable_size (hight); 9499 9500 type = build_array_type (type, 9501 build_range_type (ffecom_integer_type_node, 9502 lowt, hight)); 9503 type = ffecom_check_size_overflow_ (s, type, FALSE); 9504 } 9505 9506 return type; 9507} 9508 9509#endif 9510/* Build Namelist type. */ 9511 9512#if FFECOM_targetCURRENT == FFECOM_targetGCC 9513static tree 9514ffecom_type_namelist_ () 9515{ 9516 static tree type = NULL_TREE; 9517 9518 if (type == NULL_TREE) 9519 { 9520 static tree namefield, varsfield, nvarsfield; 9521 tree vardesctype; 9522 9523 vardesctype = ffecom_type_vardesc_ (); 9524 9525 push_obstacks_nochange (); 9526 end_temporary_allocation (); 9527 9528 type = make_node (RECORD_TYPE); 9529 9530 vardesctype = build_pointer_type (build_pointer_type (vardesctype)); 9531 9532 namefield = ffecom_decl_field (type, NULL_TREE, "name", 9533 string_type_node); 9534 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype); 9535 nvarsfield = ffecom_decl_field (type, varsfield, "nvars", 9536 integer_type_node); 9537 9538 TYPE_FIELDS (type) = namefield; 9539 layout_type (type); 9540 9541 resume_temporary_allocation (); 9542 pop_obstacks (); 9543 } 9544 9545 return type; 9546} 9547 9548#endif 9549 9550/* Make a copy of a type, assuming caller has switched to the permanent 9551 obstacks and that the type is for an aggregate (array) initializer. */ 9552 9553#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */ 9554static tree 9555ffecom_type_permanent_copy_ (tree t) 9556{ 9557 tree domain; 9558 tree max; 9559 9560 assert (TREE_TYPE (t) != NULL_TREE); 9561 9562 domain = TYPE_DOMAIN (t); 9563 9564 assert (TREE_CODE (t) == ARRAY_TYPE); 9565 assert (TREE_PERMANENT (TREE_TYPE (t))); 9566 assert (TREE_PERMANENT (TREE_TYPE (domain))); 9567 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain))); 9568 9569 max = TYPE_MAX_VALUE (domain); 9570 if (!TREE_PERMANENT (max)) 9571 { 9572 assert (TREE_CODE (max) == INTEGER_CST); 9573 9574 max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max)); 9575 TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain)); 9576 } 9577 9578 return build_array_type (TREE_TYPE (t), 9579 build_range_type (TREE_TYPE (domain), 9580 TYPE_MIN_VALUE (domain), 9581 max)); 9582} 9583#endif 9584 9585/* Build Vardesc type. */ 9586 9587#if FFECOM_targetCURRENT == FFECOM_targetGCC 9588static tree 9589ffecom_type_vardesc_ () 9590{ 9591 static tree type = NULL_TREE; 9592 static tree namefield, addrfield, dimsfield, typefield; 9593 9594 if (type == NULL_TREE) 9595 { 9596 push_obstacks_nochange (); 9597 end_temporary_allocation (); 9598 9599 type = make_node (RECORD_TYPE); 9600 9601 namefield = ffecom_decl_field (type, NULL_TREE, "name", 9602 string_type_node); 9603 addrfield = ffecom_decl_field (type, namefield, "addr", 9604 string_type_node); 9605 dimsfield = ffecom_decl_field (type, addrfield, "dims", 9606 ffecom_f2c_ptr_to_ftnlen_type_node); 9607 typefield = ffecom_decl_field (type, dimsfield, "type", 9608 integer_type_node); 9609 9610 TYPE_FIELDS (type) = namefield; 9611 layout_type (type); 9612 9613 resume_temporary_allocation (); 9614 pop_obstacks (); 9615 } 9616 9617 return type; 9618} 9619 9620#endif 9621 9622#if FFECOM_targetCURRENT == FFECOM_targetGCC 9623static tree 9624ffecom_vardesc_ (ffebld expr) 9625{ 9626 ffesymbol s; 9627 9628 assert (ffebld_op (expr) == FFEBLD_opSYMTER); 9629 s = ffebld_symter (expr); 9630 9631 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE) 9632 { 9633 int i; 9634 tree vardesctype = ffecom_type_vardesc_ (); 9635 tree var; 9636 tree nameinit; 9637 tree dimsinit; 9638 tree addrinit; 9639 tree typeinit; 9640 tree field; 9641 tree varinits; 9642 int yes; 9643 static int mynumber = 0; 9644 9645 yes = suspend_momentary (); 9646 9647 var = build_decl (VAR_DECL, 9648 ffecom_get_invented_identifier ("__g77_vardesc_%d", 9649 NULL, mynumber++), 9650 vardesctype); 9651 TREE_STATIC (var) = 1; 9652 DECL_INITIAL (var) = error_mark_node; 9653 9654 var = start_decl (var, FALSE); 9655 9656 /* Process inits. */ 9657 9658 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) 9659 + 1, 9660 ffesymbol_text (s)); 9661 TREE_TYPE (nameinit) 9662 = build_type_variant 9663 (build_array_type 9664 (char_type_node, 9665 build_range_type (integer_type_node, 9666 integer_one_node, 9667 build_int_2 (i, 0))), 9668 1, 0); 9669 TREE_CONSTANT (nameinit) = 1; 9670 TREE_STATIC (nameinit) = 1; 9671 nameinit = ffecom_1 (ADDR_EXPR, 9672 build_pointer_type (TREE_TYPE (nameinit)), 9673 nameinit); 9674 9675 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit); 9676 9677 dimsinit = ffecom_vardesc_dims_ (s); 9678 9679 if (typeinit == NULL_TREE) 9680 { 9681 ffeinfoBasictype bt = ffesymbol_basictype (s); 9682 ffeinfoKindtype kt = ffesymbol_kindtype (s); 9683 int tc = ffecom_f2c_typecode (bt, kt); 9684 9685 assert (tc != -1); 9686 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0); 9687 } 9688 else 9689 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit); 9690 9691 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)), 9692 nameinit); 9693 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)), 9694 addrinit); 9695 TREE_CHAIN (TREE_CHAIN (varinits)) 9696 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit); 9697 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits))) 9698 = build_tree_list ((field = TREE_CHAIN (field)), typeinit); 9699 9700 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits); 9701 TREE_CONSTANT (varinits) = 1; 9702 TREE_STATIC (varinits) = 1; 9703 9704 finish_decl (var, varinits, FALSE); 9705 9706 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); 9707 9708 resume_momentary (yes); 9709 9710 ffesymbol_hook (s).vardesc_tree = var; 9711 } 9712 9713 return ffesymbol_hook (s).vardesc_tree; 9714} 9715 9716#endif 9717#if FFECOM_targetCURRENT == FFECOM_targetGCC 9718static tree 9719ffecom_vardesc_array_ (ffesymbol s) 9720{ 9721 ffebld b; 9722 tree list; 9723 tree item = NULL_TREE; 9724 tree var; 9725 int i; 9726 int yes; 9727 static int mynumber = 0; 9728 9729 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s); 9730 b != NULL; 9731 b = ffebld_trail (b), ++i) 9732 { 9733 tree t; 9734 9735 t = ffecom_vardesc_ (ffebld_head (b)); 9736 9737 if (list == NULL_TREE) 9738 list = item = build_tree_list (NULL_TREE, t); 9739 else 9740 { 9741 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); 9742 item = TREE_CHAIN (item); 9743 } 9744 } 9745 9746 yes = suspend_momentary (); 9747 9748 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()), 9749 build_range_type (integer_type_node, 9750 integer_one_node, 9751 build_int_2 (i, 0))); 9752 list = build (CONSTRUCTOR, item, NULL_TREE, list); 9753 TREE_CONSTANT (list) = 1; 9754 TREE_STATIC (list) = 1; 9755 9756 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL, 9757 mynumber++); 9758 var = build_decl (VAR_DECL, var, item); 9759 TREE_STATIC (var) = 1; 9760 DECL_INITIAL (var) = error_mark_node; 9761 var = start_decl (var, FALSE); 9762 finish_decl (var, list, FALSE); 9763 9764 resume_momentary (yes); 9765 9766 return var; 9767} 9768 9769#endif 9770#if FFECOM_targetCURRENT == FFECOM_targetGCC 9771static tree 9772ffecom_vardesc_dims_ (ffesymbol s) 9773{ 9774 if (ffesymbol_dims (s) == NULL) 9775 return convert (ffecom_f2c_ptr_to_ftnlen_type_node, 9776 integer_zero_node); 9777 9778 { 9779 ffebld b; 9780 ffebld e; 9781 tree list; 9782 tree backlist; 9783 tree item = NULL_TREE; 9784 tree var; 9785 int yes; 9786 tree numdim; 9787 tree numelem; 9788 tree baseoff = NULL_TREE; 9789 static int mynumber = 0; 9790 9791 numdim = build_int_2 ((int) ffesymbol_rank (s), 0); 9792 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node; 9793 9794 numelem = ffecom_expr (ffesymbol_arraysize (s)); 9795 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node; 9796 9797 list = NULL_TREE; 9798 backlist = NULL_TREE; 9799 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s); 9800 b != NULL; 9801 b = ffebld_trail (b), e = ffebld_trail (e)) 9802 { 9803 tree t; 9804 tree low; 9805 tree back; 9806 9807 if (ffebld_trail (b) == NULL) 9808 t = NULL_TREE; 9809 else 9810 { 9811 t = convert (ffecom_f2c_ftnlen_type_node, 9812 ffecom_expr (ffebld_head (e))); 9813 9814 if (list == NULL_TREE) 9815 list = item = build_tree_list (NULL_TREE, t); 9816 else 9817 { 9818 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); 9819 item = TREE_CHAIN (item); 9820 } 9821 } 9822 9823 if (ffebld_left (ffebld_head (b)) == NULL) 9824 low = ffecom_integer_one_node; 9825 else 9826 low = ffecom_expr (ffebld_left (ffebld_head (b))); 9827 low = convert (ffecom_f2c_ftnlen_type_node, low); 9828 9829 back = build_tree_list (low, t); 9830 TREE_CHAIN (back) = backlist; 9831 backlist = back; 9832 } 9833 9834 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item)) 9835 { 9836 if (TREE_VALUE (item) == NULL_TREE) 9837 baseoff = TREE_PURPOSE (item); 9838 else 9839 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 9840 TREE_PURPOSE (item), 9841 ffecom_2 (MULT_EXPR, 9842 ffecom_f2c_ftnlen_type_node, 9843 TREE_VALUE (item), 9844 baseoff)); 9845 } 9846 9847 /* backlist now dead, along with all TREE_PURPOSEs on it. */ 9848 9849 baseoff = build_tree_list (NULL_TREE, baseoff); 9850 TREE_CHAIN (baseoff) = list; 9851 9852 numelem = build_tree_list (NULL_TREE, numelem); 9853 TREE_CHAIN (numelem) = baseoff; 9854 9855 numdim = build_tree_list (NULL_TREE, numdim); 9856 TREE_CHAIN (numdim) = numelem; 9857 9858 yes = suspend_momentary (); 9859 9860 item = build_array_type (ffecom_f2c_ftnlen_type_node, 9861 build_range_type (integer_type_node, 9862 integer_zero_node, 9863 build_int_2 9864 ((int) ffesymbol_rank (s) 9865 + 2, 0))); 9866 list = build (CONSTRUCTOR, item, NULL_TREE, numdim); 9867 TREE_CONSTANT (list) = 1; 9868 TREE_STATIC (list) = 1; 9869 9870 var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL, 9871 mynumber++); 9872 var = build_decl (VAR_DECL, var, item); 9873 TREE_STATIC (var) = 1; 9874 DECL_INITIAL (var) = error_mark_node; 9875 var = start_decl (var, FALSE); 9876 finish_decl (var, list, FALSE); 9877 9878 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var); 9879 9880 resume_momentary (yes); 9881 9882 return var; 9883 } 9884} 9885 9886#endif 9887/* Essentially does a "fold (build1 (code, type, node))" while checking 9888 for certain housekeeping things. 9889 9890 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use 9891 ffecom_1_fn instead. */ 9892 9893#if FFECOM_targetCURRENT == FFECOM_targetGCC 9894tree 9895ffecom_1 (enum tree_code code, tree type, tree node) 9896{ 9897 tree item; 9898 9899 if ((node == error_mark_node) 9900 || (type == error_mark_node)) 9901 return error_mark_node; 9902 9903 if (code == ADDR_EXPR) 9904 { 9905 if (!mark_addressable (node)) 9906 assert ("can't mark_addressable this node!" == NULL); 9907 } 9908 9909 switch (ffe_is_emulate_complex () ? code : NOP_EXPR) 9910 { 9911 tree realtype; 9912 9913 case REALPART_EXPR: 9914 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node))); 9915 break; 9916 9917 case IMAGPART_EXPR: 9918 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node)))); 9919 break; 9920 9921 9922 case NEGATE_EXPR: 9923 if (TREE_CODE (type) != RECORD_TYPE) 9924 { 9925 item = build1 (code, type, node); 9926 break; 9927 } 9928 node = ffecom_stabilize_aggregate_ (node); 9929 realtype = TREE_TYPE (TYPE_FIELDS (type)); 9930 item = 9931 ffecom_2 (COMPLEX_EXPR, type, 9932 ffecom_1 (NEGATE_EXPR, realtype, 9933 ffecom_1 (REALPART_EXPR, realtype, 9934 node)), 9935 ffecom_1 (NEGATE_EXPR, realtype, 9936 ffecom_1 (IMAGPART_EXPR, realtype, 9937 node))); 9938 break; 9939 9940 default: 9941 item = build1 (code, type, node); 9942 break; 9943 } 9944 9945 if (TREE_SIDE_EFFECTS (node)) 9946 TREE_SIDE_EFFECTS (item) = 1; 9947 if ((code == ADDR_EXPR) && staticp (node)) 9948 TREE_CONSTANT (item) = 1; 9949 return fold (item); 9950} 9951#endif 9952 9953/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except 9954 handles TREE_CODE (node) == FUNCTION_DECL. In particular, 9955 does not set TREE_ADDRESSABLE (because calling an inline 9956 function does not mean the function needs to be separately 9957 compiled). */ 9958 9959#if FFECOM_targetCURRENT == FFECOM_targetGCC 9960tree 9961ffecom_1_fn (tree node) 9962{ 9963 tree item; 9964 tree type; 9965 9966 if (node == error_mark_node) 9967 return error_mark_node; 9968 9969 type = build_type_variant (TREE_TYPE (node), 9970 TREE_READONLY (node), 9971 TREE_THIS_VOLATILE (node)); 9972 item = build1 (ADDR_EXPR, 9973 build_pointer_type (type), node); 9974 if (TREE_SIDE_EFFECTS (node)) 9975 TREE_SIDE_EFFECTS (item) = 1; 9976 if (staticp (node)) 9977 TREE_CONSTANT (item) = 1; 9978 return fold (item); 9979} 9980#endif 9981 9982/* Essentially does a "fold (build (code, type, node1, node2))" while 9983 checking for certain housekeeping things. */ 9984 9985#if FFECOM_targetCURRENT == FFECOM_targetGCC 9986tree 9987ffecom_2 (enum tree_code code, tree type, tree node1, 9988 tree node2) 9989{ 9990 tree item; 9991 9992 if ((node1 == error_mark_node) 9993 || (node2 == error_mark_node) 9994 || (type == error_mark_node)) 9995 return error_mark_node; 9996 9997 switch (ffe_is_emulate_complex () ? code : NOP_EXPR) 9998 { 9999 tree a, b, c, d, realtype; 10000 10001 case CONJ_EXPR: 10002 assert ("no CONJ_EXPR support yet" == NULL); 10003 return error_mark_node; 10004 10005 case COMPLEX_EXPR: 10006 item = build_tree_list (TYPE_FIELDS (type), node1); 10007 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2); 10008 item = build (CONSTRUCTOR, type, NULL_TREE, item); 10009 break; 10010 10011 case PLUS_EXPR: 10012 if (TREE_CODE (type) != RECORD_TYPE) 10013 { 10014 item = build (code, type, node1, node2); 10015 break; 10016 } 10017 node1 = ffecom_stabilize_aggregate_ (node1); 10018 node2 = ffecom_stabilize_aggregate_ (node2); 10019 realtype = TREE_TYPE (TYPE_FIELDS (type)); 10020 item = 10021 ffecom_2 (COMPLEX_EXPR, type, 10022 ffecom_2 (PLUS_EXPR, realtype, 10023 ffecom_1 (REALPART_EXPR, realtype, 10024 node1), 10025 ffecom_1 (REALPART_EXPR, realtype, 10026 node2)), 10027 ffecom_2 (PLUS_EXPR, realtype, 10028 ffecom_1 (IMAGPART_EXPR, realtype, 10029 node1), 10030 ffecom_1 (IMAGPART_EXPR, realtype, 10031 node2))); 10032 break; 10033 10034 case MINUS_EXPR: 10035 if (TREE_CODE (type) != RECORD_TYPE) 10036 { 10037 item = build (code, type, node1, node2); 10038 break; 10039 } 10040 node1 = ffecom_stabilize_aggregate_ (node1); 10041 node2 = ffecom_stabilize_aggregate_ (node2); 10042 realtype = TREE_TYPE (TYPE_FIELDS (type)); 10043 item = 10044 ffecom_2 (COMPLEX_EXPR, type, 10045 ffecom_2 (MINUS_EXPR, realtype, 10046 ffecom_1 (REALPART_EXPR, realtype, 10047 node1), 10048 ffecom_1 (REALPART_EXPR, realtype, 10049 node2)), 10050 ffecom_2 (MINUS_EXPR, realtype, 10051 ffecom_1 (IMAGPART_EXPR, realtype, 10052 node1), 10053 ffecom_1 (IMAGPART_EXPR, realtype, 10054 node2))); 10055 break; 10056 10057 case MULT_EXPR: 10058 if (TREE_CODE (type) != RECORD_TYPE) 10059 { 10060 item = build (code, type, node1, node2); 10061 break; 10062 } 10063 node1 = ffecom_stabilize_aggregate_ (node1); 10064 node2 = ffecom_stabilize_aggregate_ (node2); 10065 realtype = TREE_TYPE (TYPE_FIELDS (type)); 10066 a = save_expr (ffecom_1 (REALPART_EXPR, realtype, 10067 node1)); 10068 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, 10069 node1)); 10070 c = save_expr (ffecom_1 (REALPART_EXPR, realtype, 10071 node2)); 10072 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, 10073 node2)); 10074 item = 10075 ffecom_2 (COMPLEX_EXPR, type, 10076 ffecom_2 (MINUS_EXPR, realtype, 10077 ffecom_2 (MULT_EXPR, realtype, 10078 a, 10079 c), 10080 ffecom_2 (MULT_EXPR, realtype, 10081 b, 10082 d)), 10083 ffecom_2 (PLUS_EXPR, realtype, 10084 ffecom_2 (MULT_EXPR, realtype, 10085 a, 10086 d), 10087 ffecom_2 (MULT_EXPR, realtype, 10088 c, 10089 b))); 10090 break; 10091 10092 case EQ_EXPR: 10093 if ((TREE_CODE (node1) != RECORD_TYPE) 10094 && (TREE_CODE (node2) != RECORD_TYPE)) 10095 { 10096 item = build (code, type, node1, node2); 10097 break; 10098 } 10099 assert (TREE_CODE (node1) == RECORD_TYPE); 10100 assert (TREE_CODE (node2) == RECORD_TYPE); 10101 node1 = ffecom_stabilize_aggregate_ (node1); 10102 node2 = ffecom_stabilize_aggregate_ (node2); 10103 realtype = TREE_TYPE (TYPE_FIELDS (type)); 10104 item = 10105 ffecom_2 (TRUTH_ANDIF_EXPR, type, 10106 ffecom_2 (code, type, 10107 ffecom_1 (REALPART_EXPR, realtype, 10108 node1), 10109 ffecom_1 (REALPART_EXPR, realtype, 10110 node2)), 10111 ffecom_2 (code, type, 10112 ffecom_1 (IMAGPART_EXPR, realtype, 10113 node1), 10114 ffecom_1 (IMAGPART_EXPR, realtype, 10115 node2))); 10116 break; 10117 10118 case NE_EXPR: 10119 if ((TREE_CODE (node1) != RECORD_TYPE) 10120 && (TREE_CODE (node2) != RECORD_TYPE)) 10121 { 10122 item = build (code, type, node1, node2); 10123 break; 10124 } 10125 assert (TREE_CODE (node1) == RECORD_TYPE); 10126 assert (TREE_CODE (node2) == RECORD_TYPE); 10127 node1 = ffecom_stabilize_aggregate_ (node1); 10128 node2 = ffecom_stabilize_aggregate_ (node2); 10129 realtype = TREE_TYPE (TYPE_FIELDS (type)); 10130 item = 10131 ffecom_2 (TRUTH_ORIF_EXPR, type, 10132 ffecom_2 (code, type, 10133 ffecom_1 (REALPART_EXPR, realtype, 10134 node1), 10135 ffecom_1 (REALPART_EXPR, realtype, 10136 node2)), 10137 ffecom_2 (code, type, 10138 ffecom_1 (IMAGPART_EXPR, realtype, 10139 node1), 10140 ffecom_1 (IMAGPART_EXPR, realtype, 10141 node2))); 10142 break; 10143 10144 default: 10145 item = build (code, type, node1, node2); 10146 break; 10147 } 10148 10149 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)) 10150 TREE_SIDE_EFFECTS (item) = 1; 10151 return fold (item); 10152} 10153 10154#endif 10155/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint 10156 10157 ffesymbol s; // the ENTRY point itself 10158 if (ffecom_2pass_advise_entrypoint(s)) 10159 // the ENTRY point has been accepted 10160 10161 Does whatever compiler needs to do when it learns about the entrypoint, 10162 like determine the return type of the master function, count the 10163 number of entrypoints, etc. Returns FALSE if the return type is 10164 not compatible with the return type(s) of other entrypoint(s). 10165 10166 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must 10167 later (after _finish_progunit) be called with the same entrypoint(s) 10168 as passed to this fn for which TRUE was returned. 10169 10170 03-Jan-92 JCB 2.0 10171 Return FALSE if the return type conflicts with previous entrypoints. */ 10172 10173#if FFECOM_targetCURRENT == FFECOM_targetGCC 10174bool 10175ffecom_2pass_advise_entrypoint (ffesymbol entry) 10176{ 10177 ffebld list; /* opITEM. */ 10178 ffebld mlist; /* opITEM. */ 10179 ffebld plist; /* opITEM. */ 10180 ffebld arg; /* ffebld_head(opITEM). */ 10181 ffebld item; /* opITEM. */ 10182 ffesymbol s; /* ffebld_symter(arg). */ 10183 ffeinfoBasictype bt = ffesymbol_basictype (entry); 10184 ffeinfoKindtype kt = ffesymbol_kindtype (entry); 10185 ffetargetCharacterSize size = ffesymbol_size (entry); 10186 bool ok; 10187 10188 if (ffecom_num_entrypoints_ == 0) 10189 { /* First entrypoint, make list of main 10190 arglist's dummies. */ 10191 assert (ffecom_primary_entry_ != NULL); 10192 10193 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_); 10194 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_); 10195 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_); 10196 10197 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_); 10198 list != NULL; 10199 list = ffebld_trail (list)) 10200 { 10201 arg = ffebld_head (list); 10202 if (ffebld_op (arg) != FFEBLD_opSYMTER) 10203 continue; /* Alternate return or some such thing. */ 10204 item = ffebld_new_item (arg, NULL); 10205 if (plist == NULL) 10206 ffecom_master_arglist_ = item; 10207 else 10208 ffebld_set_trail (plist, item); 10209 plist = item; 10210 } 10211 } 10212 10213 /* If necessary, scan entry arglist for alternate returns. Do this scan 10214 apparently redundantly (it's done below to UNIONize the arglists) so 10215 that we don't complain about RETURN 1 if an offending ENTRY is the only 10216 one with an alternate return. */ 10217 10218 if (!ffecom_is_altreturning_) 10219 { 10220 for (list = ffesymbol_dummyargs (entry); 10221 list != NULL; 10222 list = ffebld_trail (list)) 10223 { 10224 arg = ffebld_head (list); 10225 if (ffebld_op (arg) == FFEBLD_opSTAR) 10226 { 10227 ffecom_is_altreturning_ = TRUE; 10228 break; 10229 } 10230 } 10231 } 10232 10233 /* Now check type compatibility. */ 10234 10235 switch (ffecom_master_bt_) 10236 { 10237 case FFEINFO_basictypeNONE: 10238 ok = (bt != FFEINFO_basictypeCHARACTER); 10239 break; 10240 10241 case FFEINFO_basictypeCHARACTER: 10242 ok 10243 = (bt == FFEINFO_basictypeCHARACTER) 10244 && (kt == ffecom_master_kt_) 10245 && (size == ffecom_master_size_); 10246 break; 10247 10248 case FFEINFO_basictypeANY: 10249 return FALSE; /* Just don't bother. */ 10250 10251 default: 10252 if (bt == FFEINFO_basictypeCHARACTER) 10253 { 10254 ok = FALSE; 10255 break; 10256 } 10257 ok = TRUE; 10258 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_)) 10259 { 10260 ffecom_master_bt_ = FFEINFO_basictypeNONE; 10261 ffecom_master_kt_ = FFEINFO_kindtypeNONE; 10262 } 10263 break; 10264 } 10265 10266 if (!ok) 10267 { 10268 ffebad_start (FFEBAD_ENTRY_CONFLICTS); 10269 ffest_ffebad_here_current_stmt (0); 10270 ffebad_finish (); 10271 return FALSE; /* Can't handle entrypoint. */ 10272 } 10273 10274 /* Entrypoint type compatible with previous types. */ 10275 10276 ++ffecom_num_entrypoints_; 10277 10278 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */ 10279 10280 for (list = ffesymbol_dummyargs (entry); 10281 list != NULL; 10282 list = ffebld_trail (list)) 10283 { 10284 arg = ffebld_head (list); 10285 if (ffebld_op (arg) != FFEBLD_opSYMTER) 10286 continue; /* Alternate return or some such thing. */ 10287 s = ffebld_symter (arg); 10288 for (plist = NULL, mlist = ffecom_master_arglist_; 10289 mlist != NULL; 10290 plist = mlist, mlist = ffebld_trail (mlist)) 10291 { /* plist points to previous item for easy 10292 appending of arg. */ 10293 if (ffebld_symter (ffebld_head (mlist)) == s) 10294 break; /* Already have this arg in the master list. */ 10295 } 10296 if (mlist != NULL) 10297 continue; /* Already have this arg in the master list. */ 10298 10299 /* Append this arg to the master list. */ 10300 10301 item = ffebld_new_item (arg, NULL); 10302 if (plist == NULL) 10303 ffecom_master_arglist_ = item; 10304 else 10305 ffebld_set_trail (plist, item); 10306 } 10307 10308 return TRUE; 10309} 10310 10311#endif 10312/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint 10313 10314 ffesymbol s; // the ENTRY point itself 10315 ffecom_2pass_do_entrypoint(s); 10316 10317 Does whatever compiler needs to do to make the entrypoint actually 10318 happen. Must be called for each entrypoint after 10319 ffecom_finish_progunit is called. */ 10320 10321#if FFECOM_targetCURRENT == FFECOM_targetGCC 10322void 10323ffecom_2pass_do_entrypoint (ffesymbol entry) 10324{ 10325 static int mfn_num = 0; 10326 static int ent_num; 10327 10328 if (mfn_num != ffecom_num_fns_) 10329 { /* First entrypoint for this program unit. */ 10330 ent_num = 1; 10331 mfn_num = ffecom_num_fns_; 10332 ffecom_do_entry_ (ffecom_primary_entry_, 0); 10333 } 10334 else 10335 ++ent_num; 10336 10337 --ffecom_num_entrypoints_; 10338 10339 ffecom_do_entry_ (entry, ent_num); 10340} 10341 10342#endif 10343 10344/* Essentially does a "fold (build (code, type, node1, node2))" while 10345 checking for certain housekeeping things. Always sets 10346 TREE_SIDE_EFFECTS. */ 10347 10348#if FFECOM_targetCURRENT == FFECOM_targetGCC 10349tree 10350ffecom_2s (enum tree_code code, tree type, tree node1, 10351 tree node2) 10352{ 10353 tree item; 10354 10355 if ((node1 == error_mark_node) 10356 || (node2 == error_mark_node) 10357 || (type == error_mark_node)) 10358 return error_mark_node; 10359 10360 item = build (code, type, node1, node2); 10361 TREE_SIDE_EFFECTS (item) = 1; 10362 return fold (item); 10363} 10364 10365#endif 10366/* Essentially does a "fold (build (code, type, node1, node2, node3))" while 10367 checking for certain housekeeping things. */ 10368 10369#if FFECOM_targetCURRENT == FFECOM_targetGCC 10370tree 10371ffecom_3 (enum tree_code code, tree type, tree node1, 10372 tree node2, tree node3) 10373{ 10374 tree item; 10375 10376 if ((node1 == error_mark_node) 10377 || (node2 == error_mark_node) 10378 || (node3 == error_mark_node) 10379 || (type == error_mark_node)) 10380 return error_mark_node; 10381 10382 item = build (code, type, node1, node2, node3); 10383 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2) 10384 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3))) 10385 TREE_SIDE_EFFECTS (item) = 1; 10386 return fold (item); 10387} 10388 10389#endif 10390/* Essentially does a "fold (build (code, type, node1, node2, node3))" while 10391 checking for certain housekeeping things. Always sets 10392 TREE_SIDE_EFFECTS. */ 10393 10394#if FFECOM_targetCURRENT == FFECOM_targetGCC 10395tree 10396ffecom_3s (enum tree_code code, tree type, tree node1, 10397 tree node2, tree node3) 10398{ 10399 tree item; 10400 10401 if ((node1 == error_mark_node) 10402 || (node2 == error_mark_node) 10403 || (node3 == error_mark_node) 10404 || (type == error_mark_node)) 10405 return error_mark_node; 10406 10407 item = build (code, type, node1, node2, node3); 10408 TREE_SIDE_EFFECTS (item) = 1; 10409 return fold (item); 10410} 10411 10412#endif 10413 10414/* ffecom_arg_expr -- Transform argument expr into gcc tree 10415 10416 See use by ffecom_list_expr. 10417 10418 If expression is NULL, returns an integer zero tree. If it is not 10419 a CHARACTER expression, returns whatever ffecom_expr 10420 returns and sets the length return value to NULL_TREE. Otherwise 10421 generates code to evaluate the character expression, returns the proper 10422 pointer to the result, but does NOT set the length return value to a tree 10423 that specifies the length of the result. (In other words, the length 10424 variable is always set to NULL_TREE, because a length is never passed.) 10425 10426 21-Dec-91 JCB 1.1 10427 Don't set returned length, since nobody needs it (yet; someday if 10428 we allow CHARACTER*(*) dummies to statement functions, we'll need 10429 it). */ 10430 10431#if FFECOM_targetCURRENT == FFECOM_targetGCC 10432tree 10433ffecom_arg_expr (ffebld expr, tree *length) 10434{ 10435 tree ign; 10436 10437 *length = NULL_TREE; 10438 10439 if (expr == NULL) 10440 return integer_zero_node; 10441 10442 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) 10443 return ffecom_expr (expr); 10444 10445 return ffecom_arg_ptr_to_expr (expr, &ign); 10446} 10447 10448#endif 10449/* Transform expression into constant argument-pointer-to-expression tree. 10450 10451 If the expression can be transformed into a argument-pointer-to-expression 10452 tree that is constant, that is done, and the tree returned. Else 10453 NULL_TREE is returned. 10454 10455 That way, a caller can attempt to provide compile-time initialization 10456 of a variable and, if that fails, *then* choose to start a new block 10457 and resort to using temporaries, as appropriate. */ 10458 10459tree 10460ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length) 10461{ 10462 if (! expr) 10463 return integer_zero_node; 10464 10465 if (ffebld_op (expr) == FFEBLD_opANY) 10466 { 10467 if (length) 10468 *length = error_mark_node; 10469 return error_mark_node; 10470 } 10471 10472 if (ffebld_arity (expr) == 0 10473 && (ffebld_op (expr) != FFEBLD_opSYMTER 10474 || ffebld_where (expr) == FFEINFO_whereCOMMON 10475 || ffebld_where (expr) == FFEINFO_whereGLOBAL 10476 || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) 10477 { 10478 tree t; 10479 10480 t = ffecom_arg_ptr_to_expr (expr, length); 10481 assert (TREE_CONSTANT (t)); 10482 assert (! length || TREE_CONSTANT (*length)); 10483 return t; 10484 } 10485 10486 if (length 10487 && ffebld_size (expr) != FFETARGET_charactersizeNONE) 10488 *length = build_int_2 (ffebld_size (expr), 0); 10489 else if (length) 10490 *length = NULL_TREE; 10491 return NULL_TREE; 10492} 10493 10494/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree 10495 10496 See use by ffecom_list_ptr_to_expr. 10497 10498 If expression is NULL, returns an integer zero tree. If it is not 10499 a CHARACTER expression, returns whatever ffecom_ptr_to_expr 10500 returns and sets the length return value to NULL_TREE. Otherwise 10501 generates code to evaluate the character expression, returns the proper 10502 pointer to the result, AND sets the length return value to a tree that 10503 specifies the length of the result. 10504 10505 If the length argument is NULL, this is a slightly special 10506 case of building a FORMAT expression, that is, an expression that 10507 will be used at run time without regard to length. For the current 10508 implementation, which uses the libf2c library, this means it is nice 10509 to append a null byte to the end of the expression, where feasible, 10510 to make sure any diagnostic about the FORMAT string terminates at 10511 some useful point. 10512 10513 For now, treat %REF(char-expr) as the same as char-expr with a NULL 10514 length argument. This might even be seen as a feature, if a null 10515 byte can always be appended. */ 10516 10517#if FFECOM_targetCURRENT == FFECOM_targetGCC 10518tree 10519ffecom_arg_ptr_to_expr (ffebld expr, tree *length) 10520{ 10521 tree item; 10522 tree ign_length; 10523 ffecomConcatList_ catlist; 10524 10525 if (length != NULL) 10526 *length = NULL_TREE; 10527 10528 if (expr == NULL) 10529 return integer_zero_node; 10530 10531 switch (ffebld_op (expr)) 10532 { 10533 case FFEBLD_opPERCENT_VAL: 10534 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) 10535 return ffecom_expr (ffebld_left (expr)); 10536 { 10537 tree temp_exp; 10538 tree temp_length; 10539 10540 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length); 10541 if (temp_exp == error_mark_node) 10542 return error_mark_node; 10543 10544 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)), 10545 temp_exp); 10546 } 10547 10548 case FFEBLD_opPERCENT_REF: 10549 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) 10550 return ffecom_ptr_to_expr (ffebld_left (expr)); 10551 if (length != NULL) 10552 { 10553 ign_length = NULL_TREE; 10554 length = &ign_length; 10555 } 10556 expr = ffebld_left (expr); 10557 break; 10558 10559 case FFEBLD_opPERCENT_DESCR: 10560 switch (ffeinfo_basictype (ffebld_info (expr))) 10561 { 10562#ifdef PASS_HOLLERITH_BY_DESCRIPTOR 10563 case FFEINFO_basictypeHOLLERITH: 10564#endif 10565 case FFEINFO_basictypeCHARACTER: 10566 break; /* Passed by descriptor anyway. */ 10567 10568 default: 10569 item = ffecom_ptr_to_expr (expr); 10570 if (item != error_mark_node) 10571 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item))); 10572 break; 10573 } 10574 break; 10575 10576 default: 10577 break; 10578 } 10579 10580#ifdef PASS_HOLLERITH_BY_DESCRIPTOR 10581 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH) 10582 && (length != NULL)) 10583 { /* Pass Hollerith by descriptor. */ 10584 ffetargetHollerith h; 10585 10586 assert (ffebld_op (expr) == FFEBLD_opCONTER); 10587 h = ffebld_cu_val_hollerith (ffebld_constant_union 10588 (ffebld_conter (expr))); 10589 *length 10590 = build_int_2 (h.length, 0); 10591 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 10592 } 10593#endif 10594 10595 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) 10596 return ffecom_ptr_to_expr (expr); 10597 10598 assert (ffeinfo_kindtype (ffebld_info (expr)) 10599 == FFEINFO_kindtypeCHARACTER1); 10600 10601 while (ffebld_op (expr) == FFEBLD_opPAREN) 10602 expr = ffebld_left (expr); 10603 10604 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); 10605 switch (ffecom_concat_list_count_ (catlist)) 10606 { 10607 case 0: /* Shouldn't happen, but in case it does... */ 10608 if (length != NULL) 10609 { 10610 *length = ffecom_f2c_ftnlen_zero_node; 10611 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; 10612 } 10613 ffecom_concat_list_kill_ (catlist); 10614 return null_pointer_node; 10615 10616 case 1: /* The (fairly) easy case. */ 10617 if (length == NULL) 10618 ffecom_char_args_with_null_ (&item, &ign_length, 10619 ffecom_concat_list_expr_ (catlist, 0)); 10620 else 10621 ffecom_char_args_ (&item, length, 10622 ffecom_concat_list_expr_ (catlist, 0)); 10623 ffecom_concat_list_kill_ (catlist); 10624 assert (item != NULL_TREE); 10625 return item; 10626 10627 default: /* Must actually concatenate things. */ 10628 break; 10629 } 10630 10631 { 10632 int count = ffecom_concat_list_count_ (catlist); 10633 int i; 10634 tree lengths; 10635 tree items; 10636 tree length_array; 10637 tree item_array; 10638 tree citem; 10639 tree clength; 10640 tree temporary; 10641 tree num; 10642 tree known_length; 10643 ffetargetCharacterSize sz; 10644 10645 sz = ffecom_concat_list_maxlen_ (catlist); 10646 /* ~~Kludge! */ 10647 assert (sz != FFETARGET_charactersizeNONE); 10648 10649#ifdef HOHO 10650 length_array 10651 = lengths 10652 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, 10653 FFETARGET_charactersizeNONE, count, TRUE); 10654 item_array 10655 = items 10656 = ffecom_push_tempvar (ffecom_f2c_address_type_node, 10657 FFETARGET_charactersizeNONE, count, TRUE); 10658 temporary = ffecom_push_tempvar (char_type_node, 10659 sz, -1, TRUE); 10660#else 10661 { 10662 tree hook; 10663 10664 hook = ffebld_nonter_hook (expr); 10665 assert (hook); 10666 assert (TREE_CODE (hook) == TREE_VEC); 10667 assert (TREE_VEC_LENGTH (hook) == 3); 10668 length_array = lengths = TREE_VEC_ELT (hook, 0); 10669 item_array = items = TREE_VEC_ELT (hook, 1); 10670 temporary = TREE_VEC_ELT (hook, 2); 10671 } 10672#endif 10673 10674 known_length = ffecom_f2c_ftnlen_zero_node; 10675 10676 for (i = 0; i < count; ++i) 10677 { 10678 if ((i == count) 10679 && (length == NULL)) 10680 ffecom_char_args_with_null_ (&citem, &clength, 10681 ffecom_concat_list_expr_ (catlist, i)); 10682 else 10683 ffecom_char_args_ (&citem, &clength, 10684 ffecom_concat_list_expr_ (catlist, i)); 10685 if ((citem == error_mark_node) 10686 || (clength == error_mark_node)) 10687 { 10688 ffecom_concat_list_kill_ (catlist); 10689 *length = error_mark_node; 10690 return error_mark_node; 10691 } 10692 10693 items 10694 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), 10695 ffecom_modify (void_type_node, 10696 ffecom_2 (ARRAY_REF, 10697 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), 10698 item_array, 10699 build_int_2 (i, 0)), 10700 citem), 10701 items); 10702 clength = ffecom_save_tree (clength); 10703 if (length != NULL) 10704 known_length 10705 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, 10706 known_length, 10707 clength); 10708 lengths 10709 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), 10710 ffecom_modify (void_type_node, 10711 ffecom_2 (ARRAY_REF, 10712 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), 10713 length_array, 10714 build_int_2 (i, 0)), 10715 clength), 10716 lengths); 10717 } 10718 10719 temporary = ffecom_1 (ADDR_EXPR, 10720 build_pointer_type (TREE_TYPE (temporary)), 10721 temporary); 10722 10723 item = build_tree_list (NULL_TREE, temporary); 10724 TREE_CHAIN (item) 10725 = build_tree_list (NULL_TREE, 10726 ffecom_1 (ADDR_EXPR, 10727 build_pointer_type (TREE_TYPE (items)), 10728 items)); 10729 TREE_CHAIN (TREE_CHAIN (item)) 10730 = build_tree_list (NULL_TREE, 10731 ffecom_1 (ADDR_EXPR, 10732 build_pointer_type (TREE_TYPE (lengths)), 10733 lengths)); 10734 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) 10735 = build_tree_list 10736 (NULL_TREE, 10737 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, 10738 convert (ffecom_f2c_ftnlen_type_node, 10739 build_int_2 (count, 0)))); 10740 num = build_int_2 (sz, 0); 10741 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node; 10742 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) 10743 = build_tree_list (NULL_TREE, num); 10744 10745 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE); 10746 TREE_SIDE_EFFECTS (item) = 1; 10747 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), 10748 item, 10749 temporary); 10750 10751 if (length != NULL) 10752 *length = known_length; 10753 } 10754 10755 ffecom_concat_list_kill_ (catlist); 10756 assert (item != NULL_TREE); 10757 return item; 10758} 10759 10760#endif 10761/* Generate call to run-time function. 10762 10763 The first arg is the GNU Fortran Run-Time function index, the second 10764 arg is the list of arguments to pass to it. Returned is the expression 10765 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the 10766 result (which may be void). */ 10767 10768#if FFECOM_targetCURRENT == FFECOM_targetGCC 10769tree 10770ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook) 10771{ 10772 return ffecom_call_ (ffecom_gfrt_tree_ (ix), 10773 ffecom_gfrt_kindtype (ix), 10774 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], 10775 NULL_TREE, args, NULL_TREE, NULL, 10776 NULL, NULL_TREE, TRUE, hook); 10777} 10778#endif 10779 10780/* Transform constant-union to tree. */ 10781 10782#if FFECOM_targetCURRENT == FFECOM_targetGCC 10783tree 10784ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, 10785 ffeinfoKindtype kt, tree tree_type) 10786{ 10787 tree item; 10788 10789 switch (bt) 10790 { 10791 case FFEINFO_basictypeINTEGER: 10792 { 10793 int val; 10794 10795 switch (kt) 10796 { 10797#if FFETARGET_okINTEGER1 10798 case FFEINFO_kindtypeINTEGER1: 10799 val = ffebld_cu_val_integer1 (*cu); 10800 break; 10801#endif 10802 10803#if FFETARGET_okINTEGER2 10804 case FFEINFO_kindtypeINTEGER2: 10805 val = ffebld_cu_val_integer2 (*cu); 10806 break; 10807#endif 10808 10809#if FFETARGET_okINTEGER3 10810 case FFEINFO_kindtypeINTEGER3: 10811 val = ffebld_cu_val_integer3 (*cu); 10812 break; 10813#endif 10814 10815#if FFETARGET_okINTEGER4 10816 case FFEINFO_kindtypeINTEGER4: 10817 val = ffebld_cu_val_integer4 (*cu); 10818 break; 10819#endif 10820 10821 default: 10822 assert ("bad INTEGER constant kind type" == NULL); 10823 /* Fall through. */ 10824 case FFEINFO_kindtypeANY: 10825 return error_mark_node; 10826 } 10827 item = build_int_2 (val, (val < 0) ? -1 : 0); 10828 TREE_TYPE (item) = tree_type; 10829 } 10830 break; 10831 10832 case FFEINFO_basictypeLOGICAL: 10833 { 10834 int val; 10835 10836 switch (kt) 10837 { 10838#if FFETARGET_okLOGICAL1 10839 case FFEINFO_kindtypeLOGICAL1: 10840 val = ffebld_cu_val_logical1 (*cu); 10841 break; 10842#endif 10843 10844#if FFETARGET_okLOGICAL2 10845 case FFEINFO_kindtypeLOGICAL2: 10846 val = ffebld_cu_val_logical2 (*cu); 10847 break; 10848#endif 10849 10850#if FFETARGET_okLOGICAL3 10851 case FFEINFO_kindtypeLOGICAL3: 10852 val = ffebld_cu_val_logical3 (*cu); 10853 break; 10854#endif 10855 10856#if FFETARGET_okLOGICAL4 10857 case FFEINFO_kindtypeLOGICAL4: 10858 val = ffebld_cu_val_logical4 (*cu); 10859 break; 10860#endif 10861 10862 default: 10863 assert ("bad LOGICAL constant kind type" == NULL); 10864 /* Fall through. */ 10865 case FFEINFO_kindtypeANY: 10866 return error_mark_node; 10867 } 10868 item = build_int_2 (val, (val < 0) ? -1 : 0); 10869 TREE_TYPE (item) = tree_type; 10870 } 10871 break; 10872 10873 case FFEINFO_basictypeREAL: 10874 { 10875 REAL_VALUE_TYPE val; 10876 10877 switch (kt) 10878 { 10879#if FFETARGET_okREAL1 10880 case FFEINFO_kindtypeREAL1: 10881 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu)); 10882 break; 10883#endif 10884 10885#if FFETARGET_okREAL2 10886 case FFEINFO_kindtypeREAL2: 10887 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu)); 10888 break; 10889#endif 10890 10891#if FFETARGET_okREAL3 10892 case FFEINFO_kindtypeREAL3: 10893 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu)); 10894 break; 10895#endif 10896 10897#if FFETARGET_okREAL4 10898 case FFEINFO_kindtypeREAL4: 10899 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu)); 10900 break; 10901#endif 10902 10903 default: 10904 assert ("bad REAL constant kind type" == NULL); 10905 /* Fall through. */ 10906 case FFEINFO_kindtypeANY: 10907 return error_mark_node; 10908 } 10909 item = build_real (tree_type, val); 10910 } 10911 break; 10912 10913 case FFEINFO_basictypeCOMPLEX: 10914 { 10915 REAL_VALUE_TYPE real; 10916 REAL_VALUE_TYPE imag; 10917 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; 10918 10919 switch (kt) 10920 { 10921#if FFETARGET_okCOMPLEX1 10922 case FFEINFO_kindtypeREAL1: 10923 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real); 10924 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary); 10925 break; 10926#endif 10927 10928#if FFETARGET_okCOMPLEX2 10929 case FFEINFO_kindtypeREAL2: 10930 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real); 10931 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary); 10932 break; 10933#endif 10934 10935#if FFETARGET_okCOMPLEX3 10936 case FFEINFO_kindtypeREAL3: 10937 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real); 10938 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary); 10939 break; 10940#endif 10941 10942#if FFETARGET_okCOMPLEX4 10943 case FFEINFO_kindtypeREAL4: 10944 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real); 10945 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary); 10946 break; 10947#endif 10948 10949 default: 10950 assert ("bad REAL constant kind type" == NULL); 10951 /* Fall through. */ 10952 case FFEINFO_kindtypeANY: 10953 return error_mark_node; 10954 } 10955 item = ffecom_build_complex_constant_ (tree_type, 10956 build_real (el_type, real), 10957 build_real (el_type, imag)); 10958 } 10959 break; 10960 10961 case FFEINFO_basictypeCHARACTER: 10962 { /* Happens only in DATA and similar contexts. */ 10963 ffetargetCharacter1 val; 10964 10965 switch (kt) 10966 { 10967#if FFETARGET_okCHARACTER1 10968 case FFEINFO_kindtypeLOGICAL1: 10969 val = ffebld_cu_val_character1 (*cu); 10970 break; 10971#endif 10972 10973 default: 10974 assert ("bad CHARACTER constant kind type" == NULL); 10975 /* Fall through. */ 10976 case FFEINFO_kindtypeANY: 10977 return error_mark_node; 10978 } 10979 item = build_string (ffetarget_length_character1 (val), 10980 ffetarget_text_character1 (val)); 10981 TREE_TYPE (item) 10982 = build_type_variant (build_array_type (char_type_node, 10983 build_range_type 10984 (integer_type_node, 10985 integer_one_node, 10986 build_int_2 10987 (ffetarget_length_character1 10988 (val), 0))), 10989 1, 0); 10990 } 10991 break; 10992 10993 case FFEINFO_basictypeHOLLERITH: 10994 { 10995 ffetargetHollerith h; 10996 10997 h = ffebld_cu_val_hollerith (*cu); 10998 10999 /* If not at least as wide as default INTEGER, widen it. */ 11000 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE) 11001 item = build_string (h.length, h.text); 11002 else 11003 { 11004 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE]; 11005 11006 memcpy (str, h.text, h.length); 11007 memset (&str[h.length], ' ', 11008 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE 11009 - h.length); 11010 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE, 11011 str); 11012 } 11013 TREE_TYPE (item) 11014 = build_type_variant (build_array_type (char_type_node, 11015 build_range_type 11016 (integer_type_node, 11017 integer_one_node, 11018 build_int_2 11019 (h.length, 0))), 11020 1, 0); 11021 } 11022 break; 11023 11024 case FFEINFO_basictypeTYPELESS: 11025 { 11026 ffetargetInteger1 ival; 11027 ffetargetTypeless tless; 11028 ffebad error; 11029 11030 tless = ffebld_cu_val_typeless (*cu); 11031 error = ffetarget_convert_integer1_typeless (&ival, tless); 11032 assert (error == FFEBAD); 11033 11034 item = build_int_2 ((int) ival, 0); 11035 } 11036 break; 11037 11038 default: 11039 assert ("not yet on constant type" == NULL); 11040 /* Fall through. */ 11041 case FFEINFO_basictypeANY: 11042 return error_mark_node; 11043 } 11044 11045 TREE_CONSTANT (item) = 1; 11046 11047 return item; 11048} 11049 11050#endif 11051 11052/* Transform expression into constant tree. 11053 11054 If the expression can be transformed into a tree that is constant, 11055 that is done, and the tree returned. Else NULL_TREE is returned. 11056 11057 That way, a caller can attempt to provide compile-time initialization 11058 of a variable and, if that fails, *then* choose to start a new block 11059 and resort to using temporaries, as appropriate. */ 11060 11061tree 11062ffecom_const_expr (ffebld expr) 11063{ 11064 if (! expr) 11065 return integer_zero_node; 11066 11067 if (ffebld_op (expr) == FFEBLD_opANY) 11068 return error_mark_node; 11069 11070 if (ffebld_arity (expr) == 0 11071 && (ffebld_op (expr) != FFEBLD_opSYMTER 11072#if NEWCOMMON 11073 /* ~~Enable once common/equivalence is handled properly? */ 11074 || ffebld_where (expr) == FFEINFO_whereCOMMON 11075#endif 11076 || ffebld_where (expr) == FFEINFO_whereGLOBAL 11077 || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) 11078 { 11079 tree t; 11080 11081 t = ffecom_expr (expr); 11082 assert (TREE_CONSTANT (t)); 11083 return t; 11084 } 11085 11086 return NULL_TREE; 11087} 11088 11089/* Handy way to make a field in a struct/union. */ 11090 11091#if FFECOM_targetCURRENT == FFECOM_targetGCC 11092tree 11093ffecom_decl_field (tree context, tree prevfield, 11094 const char *name, tree type) 11095{ 11096 tree field; 11097 11098 field = build_decl (FIELD_DECL, get_identifier (name), type); 11099 DECL_CONTEXT (field) = context; 11100 DECL_FRAME_SIZE (field) = 0; 11101 if (prevfield != NULL_TREE) 11102 TREE_CHAIN (prevfield) = field; 11103 11104 return field; 11105} 11106 11107#endif 11108 11109void 11110ffecom_close_include (FILE *f) 11111{ 11112#if FFECOM_GCC_INCLUDE 11113 ffecom_close_include_ (f); 11114#endif 11115} 11116 11117int 11118ffecom_decode_include_option (char *spec) 11119{ 11120#if FFECOM_GCC_INCLUDE 11121 return ffecom_decode_include_option_ (spec); 11122#else 11123 return 1; 11124#endif 11125} 11126 11127/* End a compound statement (block). */ 11128 11129#if FFECOM_targetCURRENT == FFECOM_targetGCC 11130tree 11131ffecom_end_compstmt (void) 11132{ 11133 return bison_rule_compstmt_ (); 11134} 11135#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 11136 11137/* ffecom_end_transition -- Perform end transition on all symbols 11138 11139 ffecom_end_transition(); 11140 11141 Calls ffecom_sym_end_transition for each global and local symbol. */ 11142 11143void 11144ffecom_end_transition () 11145{ 11146#if FFECOM_targetCURRENT == FFECOM_targetGCC 11147 ffebld item; 11148#endif 11149 11150 if (ffe_is_ffedebug ()) 11151 fprintf (dmpout, "; end_stmt_transition\n"); 11152 11153#if FFECOM_targetCURRENT == FFECOM_targetGCC 11154 ffecom_list_blockdata_ = NULL; 11155 ffecom_list_common_ = NULL; 11156#endif 11157 11158 ffesymbol_drive (ffecom_sym_end_transition); 11159 if (ffe_is_ffedebug ()) 11160 { 11161 ffestorag_report (); 11162#if FFECOM_targetCURRENT == FFECOM_targetFFE 11163 ffesymbol_report_all (); 11164#endif 11165 } 11166 11167#if FFECOM_targetCURRENT == FFECOM_targetGCC 11168 ffecom_start_progunit_ (); 11169 11170 for (item = ffecom_list_blockdata_; 11171 item != NULL; 11172 item = ffebld_trail (item)) 11173 { 11174 ffebld callee; 11175 ffesymbol s; 11176 tree dt; 11177 tree t; 11178 tree var; 11179 int yes; 11180 static int number = 0; 11181 11182 callee = ffebld_head (item); 11183 s = ffebld_symter (callee); 11184 t = ffesymbol_hook (s).decl_tree; 11185 if (t == NULL_TREE) 11186 { 11187 s = ffecom_sym_transform_ (s); 11188 t = ffesymbol_hook (s).decl_tree; 11189 } 11190 11191 yes = suspend_momentary (); 11192 11193 dt = build_pointer_type (TREE_TYPE (t)); 11194 11195 var = build_decl (VAR_DECL, 11196 ffecom_get_invented_identifier ("__g77_forceload_%d", 11197 NULL, number++), 11198 dt); 11199 DECL_EXTERNAL (var) = 0; 11200 TREE_STATIC (var) = 1; 11201 TREE_PUBLIC (var) = 0; 11202 DECL_INITIAL (var) = error_mark_node; 11203 TREE_USED (var) = 1; 11204 11205 var = start_decl (var, FALSE); 11206 11207 t = ffecom_1 (ADDR_EXPR, dt, t); 11208 11209 finish_decl (var, t, FALSE); 11210 11211 resume_momentary (yes); 11212 } 11213 11214 /* This handles any COMMON areas that weren't referenced but have, for 11215 example, important initial data. */ 11216 11217 for (item = ffecom_list_common_; 11218 item != NULL; 11219 item = ffebld_trail (item)) 11220 ffecom_transform_common_ (ffebld_symter (ffebld_head (item))); 11221 11222 ffecom_list_common_ = NULL; 11223#endif 11224} 11225 11226/* ffecom_exec_transition -- Perform exec transition on all symbols 11227 11228 ffecom_exec_transition(); 11229 11230 Calls ffecom_sym_exec_transition for each global and local symbol. 11231 Make sure error updating not inhibited. */ 11232 11233void 11234ffecom_exec_transition () 11235{ 11236 bool inhibited; 11237 11238 if (ffe_is_ffedebug ()) 11239 fprintf (dmpout, "; exec_stmt_transition\n"); 11240 11241 inhibited = ffebad_inhibit (); 11242 ffebad_set_inhibit (FALSE); 11243 11244 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */ 11245 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */ 11246 if (ffe_is_ffedebug ()) 11247 { 11248 ffestorag_report (); 11249#if FFECOM_targetCURRENT == FFECOM_targetFFE 11250 ffesymbol_report_all (); 11251#endif 11252 } 11253 11254 if (inhibited) 11255 ffebad_set_inhibit (TRUE); 11256} 11257 11258/* Handle assignment statement. 11259 11260 Convert dest and source using ffecom_expr, then join them 11261 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ 11262 11263#if FFECOM_targetCURRENT == FFECOM_targetGCC 11264void 11265ffecom_expand_let_stmt (ffebld dest, ffebld source) 11266{ 11267 tree dest_tree; 11268 tree dest_length; 11269 tree source_tree; 11270 tree expr_tree; 11271 11272 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER) 11273 { 11274 bool dest_used; 11275 tree assign_temp; 11276 11277 /* This attempts to replicate the test below, but must not be 11278 true when the test below is false. (Always err on the side 11279 of creating unused temporaries, to avoid ICEs.) */ 11280 if (ffebld_op (dest) != FFEBLD_opSYMTER 11281 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree) 11282 && (TREE_CODE (dest_tree) != VAR_DECL 11283 || TREE_ADDRESSABLE (dest_tree)))) 11284 { 11285 ffecom_prepare_expr_ (source, dest); 11286 dest_used = TRUE; 11287 } 11288 else 11289 { 11290 ffecom_prepare_expr_ (source, NULL); 11291 dest_used = FALSE; 11292 } 11293 11294 ffecom_prepare_expr_w (NULL_TREE, dest); 11295 11296 /* For COMPLEX assignment like C1=C2, if partial overlap is possible, 11297 create a temporary through which the assignment is to take place, 11298 since MODIFY_EXPR doesn't handle partial overlap properly. */ 11299 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX 11300 && ffecom_possible_partial_overlap_ (dest, source)) 11301 { 11302 assign_temp = ffecom_make_tempvar ("complex_let", 11303 ffecom_tree_type 11304 [ffebld_basictype (dest)] 11305 [ffebld_kindtype (dest)], 11306 FFETARGET_charactersizeNONE, 11307 -1); 11308 } 11309 else 11310 assign_temp = NULL_TREE; 11311 11312 ffecom_prepare_end (); 11313 11314 dest_tree = ffecom_expr_w (NULL_TREE, dest); 11315 if (dest_tree == error_mark_node) 11316 return; 11317 11318 if ((TREE_CODE (dest_tree) != VAR_DECL) 11319 || TREE_ADDRESSABLE (dest_tree)) 11320 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used, 11321 FALSE, FALSE); 11322 else 11323 { 11324 assert (! dest_used); 11325 dest_used = FALSE; 11326 source_tree = ffecom_expr (source); 11327 } 11328 if (source_tree == error_mark_node) 11329 return; 11330 11331 if (dest_used) 11332 expr_tree = source_tree; 11333 else if (assign_temp) 11334 { 11335#ifdef MOVE_EXPR 11336 /* The back end understands a conceptual move (evaluate source; 11337 store into dest), so use that, in case it can determine 11338 that it is going to use, say, two registers as temporaries 11339 anyway. So don't use the temp (and someday avoid generating 11340 it, once this code starts triggering regularly). */ 11341 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node, 11342 dest_tree, 11343 source_tree); 11344#else 11345 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, 11346 assign_temp, 11347 source_tree); 11348 expand_expr_stmt (expr_tree); 11349 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, 11350 dest_tree, 11351 assign_temp); 11352#endif 11353 } 11354 else 11355 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, 11356 dest_tree, 11357 source_tree); 11358 11359 expand_expr_stmt (expr_tree); 11360 return; 11361 } 11362 11363 ffecom_prepare_let_char_ (ffebld_size_known (dest), source); 11364 ffecom_prepare_expr_w (NULL_TREE, dest); 11365 11366 ffecom_prepare_end (); 11367 11368 ffecom_char_args_ (&dest_tree, &dest_length, dest); 11369 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), 11370 source); 11371} 11372 11373#endif 11374/* ffecom_expr -- Transform expr into gcc tree 11375 11376 tree t; 11377 ffebld expr; // FFE expression. 11378 tree = ffecom_expr(expr); 11379 11380 Recursive descent on expr while making corresponding tree nodes and 11381 attaching type info and such. */ 11382 11383#if FFECOM_targetCURRENT == FFECOM_targetGCC 11384tree 11385ffecom_expr (ffebld expr) 11386{ 11387 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE); 11388} 11389 11390#endif 11391/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ 11392 11393#if FFECOM_targetCURRENT == FFECOM_targetGCC 11394tree 11395ffecom_expr_assign (ffebld expr) 11396{ 11397 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); 11398} 11399 11400#endif 11401/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ 11402 11403#if FFECOM_targetCURRENT == FFECOM_targetGCC 11404tree 11405ffecom_expr_assign_w (ffebld expr) 11406{ 11407 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); 11408} 11409 11410#endif 11411/* Transform expr for use as into read/write tree and stabilize the 11412 reference. Not for use on CHARACTER expressions. 11413 11414 Recursive descent on expr while making corresponding tree nodes and 11415 attaching type info and such. */ 11416 11417#if FFECOM_targetCURRENT == FFECOM_targetGCC 11418tree 11419ffecom_expr_rw (tree type, ffebld expr) 11420{ 11421 assert (expr != NULL); 11422 /* Different target types not yet supported. */ 11423 assert (type == NULL_TREE || type == ffecom_type_expr (expr)); 11424 11425 return stabilize_reference (ffecom_expr (expr)); 11426} 11427 11428#endif 11429/* Transform expr for use as into write tree and stabilize the 11430 reference. Not for use on CHARACTER expressions. 11431 11432 Recursive descent on expr while making corresponding tree nodes and 11433 attaching type info and such. */ 11434 11435#if FFECOM_targetCURRENT == FFECOM_targetGCC 11436tree 11437ffecom_expr_w (tree type, ffebld expr) 11438{ 11439 assert (expr != NULL); 11440 /* Different target types not yet supported. */ 11441 assert (type == NULL_TREE || type == ffecom_type_expr (expr)); 11442 11443 return stabilize_reference (ffecom_expr (expr)); 11444} 11445 11446#endif 11447/* Do global stuff. */ 11448 11449#if FFECOM_targetCURRENT == FFECOM_targetGCC 11450void 11451ffecom_finish_compile () 11452{ 11453 assert (ffecom_outer_function_decl_ == NULL_TREE); 11454 assert (current_function_decl == NULL_TREE); 11455 11456 ffeglobal_drive (ffecom_finish_global_); 11457} 11458 11459#endif 11460/* Public entry point for front end to access finish_decl. */ 11461 11462#if FFECOM_targetCURRENT == FFECOM_targetGCC 11463void 11464ffecom_finish_decl (tree decl, tree init, bool is_top_level) 11465{ 11466 assert (!is_top_level); 11467 finish_decl (decl, init, FALSE); 11468} 11469 11470#endif 11471/* Finish a program unit. */ 11472 11473#if FFECOM_targetCURRENT == FFECOM_targetGCC 11474void 11475ffecom_finish_progunit () 11476{ 11477 ffecom_end_compstmt (); 11478 11479 ffecom_previous_function_decl_ = current_function_decl; 11480 ffecom_which_entrypoint_decl_ = NULL_TREE; 11481 11482 finish_function (0); 11483} 11484 11485#endif 11486/* Wrapper for get_identifier. pattern is sprintf-like, assumed to contain 11487 one %s if text is not NULL, assumed to contain one %d if number is 11488 not -1. If both are assumed, the %s is assumed to precede the %d. */ 11489 11490#if FFECOM_targetCURRENT == FFECOM_targetGCC 11491tree 11492ffecom_get_invented_identifier (const char *pattern, const char *text, 11493 int number) 11494{ 11495 tree decl; 11496 char *nam; 11497 mallocSize lenlen; 11498 char space[66]; 11499 11500 lenlen = 0; 11501 if (text) 11502 lenlen += strlen (text); 11503 if (number != -1) 11504 lenlen += 20; 11505 if (text || number != -1) 11506 { 11507 lenlen += strlen (pattern); 11508 if (lenlen > ARRAY_SIZE (space)) 11509 nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen); 11510 else 11511 nam = &space[0]; 11512 } 11513 else 11514 { 11515 lenlen = 0; 11516 nam = (char *) pattern; 11517 } 11518 11519 if (text == NULL) 11520 { 11521 if (number != -1) 11522 sprintf (&nam[0], pattern, number); 11523 } 11524 else 11525 { 11526 if (number == -1) 11527 sprintf (&nam[0], pattern, text); 11528 else 11529 sprintf (&nam[0], pattern, text, number); 11530 } 11531 11532 decl = get_identifier (nam); 11533 11534 if (lenlen > ARRAY_SIZE (space)) 11535 malloc_kill_ks (malloc_pool_image (), nam, lenlen); 11536 11537 IDENTIFIER_INVENTED (decl) = 1; 11538 11539 return decl; 11540} 11541 11542ffeinfoBasictype 11543ffecom_gfrt_basictype (ffecomGfrt gfrt) 11544{ 11545 assert (gfrt < FFECOM_gfrt); 11546 11547 switch (ffecom_gfrt_type_[gfrt]) 11548 { 11549 case FFECOM_rttypeVOID_: 11550 case FFECOM_rttypeVOIDSTAR_: 11551 return FFEINFO_basictypeNONE; 11552 11553 case FFECOM_rttypeFTNINT_: 11554 return FFEINFO_basictypeINTEGER; 11555 11556 case FFECOM_rttypeINTEGER_: 11557 return FFEINFO_basictypeINTEGER; 11558 11559 case FFECOM_rttypeLONGINT_: 11560 return FFEINFO_basictypeINTEGER; 11561 11562 case FFECOM_rttypeLOGICAL_: 11563 return FFEINFO_basictypeLOGICAL; 11564 11565 case FFECOM_rttypeREAL_F2C_: 11566 case FFECOM_rttypeREAL_GNU_: 11567 return FFEINFO_basictypeREAL; 11568 11569 case FFECOM_rttypeCOMPLEX_F2C_: 11570 case FFECOM_rttypeCOMPLEX_GNU_: 11571 return FFEINFO_basictypeCOMPLEX; 11572 11573 case FFECOM_rttypeDOUBLE_: 11574 case FFECOM_rttypeDOUBLEREAL_: 11575 return FFEINFO_basictypeREAL; 11576 11577 case FFECOM_rttypeDBLCMPLX_F2C_: 11578 case FFECOM_rttypeDBLCMPLX_GNU_: 11579 return FFEINFO_basictypeCOMPLEX; 11580 11581 case FFECOM_rttypeCHARACTER_: 11582 return FFEINFO_basictypeCHARACTER; 11583 11584 default: 11585 return FFEINFO_basictypeANY; 11586 } 11587} 11588 11589ffeinfoKindtype 11590ffecom_gfrt_kindtype (ffecomGfrt gfrt) 11591{ 11592 assert (gfrt < FFECOM_gfrt); 11593 11594 switch (ffecom_gfrt_type_[gfrt]) 11595 { 11596 case FFECOM_rttypeVOID_: 11597 case FFECOM_rttypeVOIDSTAR_: 11598 return FFEINFO_kindtypeNONE; 11599 11600 case FFECOM_rttypeFTNINT_: 11601 return FFEINFO_kindtypeINTEGER1; 11602 11603 case FFECOM_rttypeINTEGER_: 11604 return FFEINFO_kindtypeINTEGER1; 11605 11606 case FFECOM_rttypeLONGINT_: 11607 return FFEINFO_kindtypeINTEGER4; 11608 11609 case FFECOM_rttypeLOGICAL_: 11610 return FFEINFO_kindtypeLOGICAL1; 11611 11612 case FFECOM_rttypeREAL_F2C_: 11613 case FFECOM_rttypeREAL_GNU_: 11614 return FFEINFO_kindtypeREAL1; 11615 11616 case FFECOM_rttypeCOMPLEX_F2C_: 11617 case FFECOM_rttypeCOMPLEX_GNU_: 11618 return FFEINFO_kindtypeREAL1; 11619 11620 case FFECOM_rttypeDOUBLE_: 11621 case FFECOM_rttypeDOUBLEREAL_: 11622 return FFEINFO_kindtypeREAL2; 11623 11624 case FFECOM_rttypeDBLCMPLX_F2C_: 11625 case FFECOM_rttypeDBLCMPLX_GNU_: 11626 return FFEINFO_kindtypeREAL2; 11627 11628 case FFECOM_rttypeCHARACTER_: 11629 return FFEINFO_kindtypeCHARACTER1; 11630 11631 default: 11632 return FFEINFO_kindtypeANY; 11633 } 11634} 11635 11636void 11637ffecom_init_0 () 11638{ 11639 tree endlink; 11640 int i; 11641 int j; 11642 tree t; 11643 tree field; 11644 ffetype type; 11645 ffetype base_type; 11646 11647 /* This block of code comes from the now-obsolete cktyps.c. It checks 11648 whether the compiler environment is buggy in known ways, some of which 11649 would, if not explicitly checked here, result in subtle bugs in g77. */ 11650 11651 if (ffe_is_do_internal_checks ()) 11652 { 11653 static char names[][12] 11654 = 11655 {"bar", "bletch", "foo", "foobar"}; 11656 char *name; 11657 unsigned long ul; 11658 double fl; 11659 11660 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), 11661 (int (*)()) strcmp); 11662 if (name != (char *) &names[2]) 11663 { 11664 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h" 11665 == NULL); 11666 abort (); 11667 } 11668 11669 ul = strtoul ("123456789", NULL, 10); 11670 if (ul != 123456789L) 11671 { 11672 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\ 11673 in proj.h" == NULL); 11674 abort (); 11675 } 11676 11677 fl = atof ("56.789"); 11678 if ((fl < 56.788) || (fl > 56.79)) 11679 { 11680 assert ("atof not type double, fix your #include <stdio.h>" 11681 == NULL); 11682 abort (); 11683 } 11684 } 11685 11686#if FFECOM_GCC_INCLUDE 11687 ffecom_initialize_char_syntax_ (); 11688#endif 11689 11690 ffecom_outer_function_decl_ = NULL_TREE; 11691 current_function_decl = NULL_TREE; 11692 named_labels = NULL_TREE; 11693 current_binding_level = NULL_BINDING_LEVEL; 11694 free_binding_level = NULL_BINDING_LEVEL; 11695 /* Make the binding_level structure for global names. */ 11696 pushlevel (0); 11697 global_binding_level = current_binding_level; 11698 current_binding_level->prep_state = 2; 11699 11700 /* Define `int' and `char' first so that dbx will output them first. */ 11701 11702 integer_type_node = make_signed_type (INT_TYPE_SIZE); 11703 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), 11704 integer_type_node)); 11705 11706 char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); 11707 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), 11708 char_type_node)); 11709 11710 long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); 11711 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), 11712 long_integer_type_node)); 11713 11714 unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE); 11715 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), 11716 unsigned_type_node)); 11717 11718 long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE); 11719 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), 11720 long_unsigned_type_node)); 11721 11722 long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE); 11723 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), 11724 long_long_integer_type_node)); 11725 11726 long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE); 11727 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), 11728 long_long_unsigned_type_node)); 11729 11730 short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE); 11731 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), 11732 short_integer_type_node)); 11733 11734 short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE); 11735 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), 11736 short_unsigned_type_node)); 11737 11738 /* Set the sizetype before we make other types. This *should* be the 11739 first type we create. */ 11740 11741 set_sizetype 11742 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE)))); 11743 ffecom_typesize_pointer_ 11744 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT; 11745 11746 error_mark_node = make_node (ERROR_MARK); 11747 TREE_TYPE (error_mark_node) = error_mark_node; 11748 11749 /* Define both `signed char' and `unsigned char'. */ 11750 signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE); 11751 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), 11752 signed_char_type_node)); 11753 11754 unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); 11755 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), 11756 unsigned_char_type_node)); 11757 11758 float_type_node = make_node (REAL_TYPE); 11759 TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE; 11760 layout_type (float_type_node); 11761 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), 11762 float_type_node)); 11763 11764 double_type_node = make_node (REAL_TYPE); 11765 TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE; 11766 layout_type (double_type_node); 11767 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), 11768 double_type_node)); 11769 11770 long_double_type_node = make_node (REAL_TYPE); 11771 TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE; 11772 layout_type (long_double_type_node); 11773 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), 11774 long_double_type_node)); 11775 11776 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); 11777 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), 11778 complex_integer_type_node)); 11779 11780 complex_float_type_node = ffecom_make_complex_type_ (float_type_node); 11781 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), 11782 complex_float_type_node)); 11783 11784 complex_double_type_node = ffecom_make_complex_type_ (double_type_node); 11785 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), 11786 complex_double_type_node)); 11787 11788 complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node); 11789 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), 11790 complex_long_double_type_node)); 11791 11792 integer_zero_node = build_int_2 (0, 0); 11793 TREE_TYPE (integer_zero_node) = integer_type_node; 11794 integer_one_node = build_int_2 (1, 0); 11795 TREE_TYPE (integer_one_node) = integer_type_node; 11796 11797 size_zero_node = build_int_2 (0, 0); 11798 TREE_TYPE (size_zero_node) = sizetype; 11799 size_one_node = build_int_2 (1, 0); 11800 TREE_TYPE (size_one_node) = sizetype; 11801 11802 void_type_node = make_node (VOID_TYPE); 11803 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), 11804 void_type_node)); 11805 layout_type (void_type_node); /* Uses integer_zero_node */ 11806 /* We are not going to have real types in C with less than byte alignment, 11807 so we might as well not have any types that claim to have it. */ 11808 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; 11809 11810 null_pointer_node = build_int_2 (0, 0); 11811 TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node); 11812 layout_type (TREE_TYPE (null_pointer_node)); 11813 11814 string_type_node = build_pointer_type (char_type_node); 11815 11816 ffecom_tree_fun_type_void 11817 = build_function_type (void_type_node, NULL_TREE); 11818 11819 ffecom_tree_ptr_to_fun_type_void 11820 = build_pointer_type (ffecom_tree_fun_type_void); 11821 11822 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); 11823 11824 float_ftype_float 11825 = build_function_type (float_type_node, 11826 tree_cons (NULL_TREE, float_type_node, endlink)); 11827 11828 double_ftype_double 11829 = build_function_type (double_type_node, 11830 tree_cons (NULL_TREE, double_type_node, endlink)); 11831 11832 ldouble_ftype_ldouble 11833 = build_function_type (long_double_type_node, 11834 tree_cons (NULL_TREE, long_double_type_node, 11835 endlink)); 11836 11837 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) 11838 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) 11839 { 11840 ffecom_tree_type[i][j] = NULL_TREE; 11841 ffecom_tree_fun_type[i][j] = NULL_TREE; 11842 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE; 11843 ffecom_f2c_typecode_[i][j] = -1; 11844 } 11845 11846 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set 11847 to size FLOAT_TYPE_SIZE because they have to be the same size as 11848 REAL, which also is FLOAT_TYPE_SIZE, according to the standard. 11849 Compiler options and other such stuff that change the ways these 11850 types are set should not affect this particular setup. */ 11851 11852 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1] 11853 = t = make_signed_type (FLOAT_TYPE_SIZE); 11854 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"), 11855 t)); 11856 type = ffetype_new (); 11857 base_type = type; 11858 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1, 11859 type); 11860 ffetype_set_ams (type, 11861 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11862 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11863 ffetype_set_star (base_type, 11864 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11865 type); 11866 ffetype_set_kind (base_type, 1, type); 11867 ffecom_typesize_integer1_ = ffetype_size (type); 11868 assert (ffetype_size (type) == sizeof (ffetargetInteger1)); 11869 11870 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1] 11871 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */ 11872 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"), 11873 t)); 11874 11875 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2] 11876 = t = make_signed_type (CHAR_TYPE_SIZE); 11877 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"), 11878 t)); 11879 type = ffetype_new (); 11880 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2, 11881 type); 11882 ffetype_set_ams (type, 11883 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11884 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11885 ffetype_set_star (base_type, 11886 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11887 type); 11888 ffetype_set_kind (base_type, 3, type); 11889 assert (ffetype_size (type) == sizeof (ffetargetInteger2)); 11890 11891 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2] 11892 = t = make_unsigned_type (CHAR_TYPE_SIZE); 11893 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"), 11894 t)); 11895 11896 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3] 11897 = t = make_signed_type (CHAR_TYPE_SIZE * 2); 11898 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"), 11899 t)); 11900 type = ffetype_new (); 11901 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3, 11902 type); 11903 ffetype_set_ams (type, 11904 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11905 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11906 ffetype_set_star (base_type, 11907 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11908 type); 11909 ffetype_set_kind (base_type, 6, type); 11910 assert (ffetype_size (type) == sizeof (ffetargetInteger3)); 11911 11912 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3] 11913 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2); 11914 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"), 11915 t)); 11916 11917 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4] 11918 = t = make_signed_type (FLOAT_TYPE_SIZE * 2); 11919 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"), 11920 t)); 11921 type = ffetype_new (); 11922 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4, 11923 type); 11924 ffetype_set_ams (type, 11925 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11926 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11927 ffetype_set_star (base_type, 11928 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11929 type); 11930 ffetype_set_kind (base_type, 2, type); 11931 assert (ffetype_size (type) == sizeof (ffetargetInteger4)); 11932 11933 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4] 11934 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2); 11935 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"), 11936 t)); 11937 11938#if 0 11939 if (ffe_is_do_internal_checks () 11940 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE 11941 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE 11942 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE 11943 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE) 11944 { 11945 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n", 11946 LONG_TYPE_SIZE); 11947 } 11948#endif 11949 11950 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1] 11951 = t = make_signed_type (FLOAT_TYPE_SIZE); 11952 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"), 11953 t)); 11954 type = ffetype_new (); 11955 base_type = type; 11956 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1, 11957 type); 11958 ffetype_set_ams (type, 11959 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11960 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11961 ffetype_set_star (base_type, 11962 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11963 type); 11964 ffetype_set_kind (base_type, 1, type); 11965 assert (ffetype_size (type) == sizeof (ffetargetLogical1)); 11966 11967 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2] 11968 = t = make_signed_type (CHAR_TYPE_SIZE); 11969 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"), 11970 t)); 11971 type = ffetype_new (); 11972 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2, 11973 type); 11974 ffetype_set_ams (type, 11975 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11976 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11977 ffetype_set_star (base_type, 11978 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11979 type); 11980 ffetype_set_kind (base_type, 3, type); 11981 assert (ffetype_size (type) == sizeof (ffetargetLogical2)); 11982 11983 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3] 11984 = t = make_signed_type (CHAR_TYPE_SIZE * 2); 11985 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"), 11986 t)); 11987 type = ffetype_new (); 11988 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3, 11989 type); 11990 ffetype_set_ams (type, 11991 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 11992 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 11993 ffetype_set_star (base_type, 11994 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 11995 type); 11996 ffetype_set_kind (base_type, 6, type); 11997 assert (ffetype_size (type) == sizeof (ffetargetLogical3)); 11998 11999 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4] 12000 = t = make_signed_type (FLOAT_TYPE_SIZE * 2); 12001 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"), 12002 t)); 12003 type = ffetype_new (); 12004 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4, 12005 type); 12006 ffetype_set_ams (type, 12007 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12008 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12009 ffetype_set_star (base_type, 12010 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 12011 type); 12012 ffetype_set_kind (base_type, 2, type); 12013 assert (ffetype_size (type) == sizeof (ffetargetLogical4)); 12014 12015 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] 12016 = t = make_node (REAL_TYPE); 12017 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE; 12018 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"), 12019 t)); 12020 layout_type (t); 12021 type = ffetype_new (); 12022 base_type = type; 12023 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1, 12024 type); 12025 ffetype_set_ams (type, 12026 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12027 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12028 ffetype_set_star (base_type, 12029 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 12030 type); 12031 ffetype_set_kind (base_type, 1, type); 12032 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] 12033 = FFETARGET_f2cTYREAL; 12034 assert (ffetype_size (type) == sizeof (ffetargetReal1)); 12035 12036 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE] 12037 = t = make_node (REAL_TYPE); 12038 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */ 12039 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"), 12040 t)); 12041 layout_type (t); 12042 type = ffetype_new (); 12043 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, 12044 type); 12045 ffetype_set_ams (type, 12046 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12047 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12048 ffetype_set_star (base_type, 12049 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 12050 type); 12051 ffetype_set_kind (base_type, 2, type); 12052 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2] 12053 = FFETARGET_f2cTYDREAL; 12054 assert (ffetype_size (type) == sizeof (ffetargetReal2)); 12055 12056 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] 12057 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]); 12058 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"), 12059 t)); 12060 type = ffetype_new (); 12061 base_type = type; 12062 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1, 12063 type); 12064 ffetype_set_ams (type, 12065 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12066 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12067 ffetype_set_star (base_type, 12068 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 12069 type); 12070 ffetype_set_kind (base_type, 1, type); 12071 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] 12072 = FFETARGET_f2cTYCOMPLEX; 12073 assert (ffetype_size (type) == sizeof (ffetargetComplex1)); 12074 12075 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE] 12076 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]); 12077 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"), 12078 t)); 12079 type = ffetype_new (); 12080 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE, 12081 type); 12082 ffetype_set_ams (type, 12083 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12084 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12085 ffetype_set_star (base_type, 12086 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, 12087 type); 12088 ffetype_set_kind (base_type, 2, 12089 type); 12090 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2] 12091 = FFETARGET_f2cTYDCOMPLEX; 12092 assert (ffetype_size (type) == sizeof (ffetargetComplex2)); 12093 12094 /* Make function and ptr-to-function types for non-CHARACTER types. */ 12095 12096 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) 12097 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) 12098 { 12099 if ((t = ffecom_tree_type[i][j]) != NULL_TREE) 12100 { 12101 if (i == FFEINFO_basictypeINTEGER) 12102 { 12103 /* Figure out the smallest INTEGER type that can hold 12104 a pointer on this machine. */ 12105 if (GET_MODE_SIZE (TYPE_MODE (t)) 12106 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) 12107 { 12108 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE) 12109 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_])) 12110 > GET_MODE_SIZE (TYPE_MODE (t)))) 12111 ffecom_pointer_kind_ = j; 12112 } 12113 } 12114 else if (i == FFEINFO_basictypeCOMPLEX) 12115 t = void_type_node; 12116 /* For f2c compatibility, REAL functions are really 12117 implemented as DOUBLE PRECISION. */ 12118 else if ((i == FFEINFO_basictypeREAL) 12119 && (j == FFEINFO_kindtypeREAL1)) 12120 t = ffecom_tree_type 12121 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]; 12122 12123 t = ffecom_tree_fun_type[i][j] = build_function_type (t, 12124 NULL_TREE); 12125 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t); 12126 } 12127 } 12128 12129 /* Set up pointer types. */ 12130 12131 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE) 12132 fatal ("no INTEGER type can hold a pointer on this configuration"); 12133 else if (0 && ffe_is_do_internal_checks ()) 12134 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_); 12135 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, 12136 FFEINFO_kindtypeINTEGERDEFAULT), 12137 7, 12138 ffeinfo_type (FFEINFO_basictypeINTEGER, 12139 ffecom_pointer_kind_)); 12140 12141 if (ffe_is_ugly_assign ()) 12142 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */ 12143 else 12144 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT; 12145 if (0 && ffe_is_do_internal_checks ()) 12146 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_); 12147 12148 ffecom_integer_type_node 12149 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]; 12150 ffecom_integer_zero_node = convert (ffecom_integer_type_node, 12151 integer_zero_node); 12152 ffecom_integer_one_node = convert (ffecom_integer_type_node, 12153 integer_one_node); 12154 12155 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional. 12156 Turns out that by TYLONG, runtime/libI77/lio.h really means 12157 "whatever size an ftnint is". For consistency and sanity, 12158 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen 12159 all are INTEGER, which we also make out of whatever back-end 12160 integer type is FLOAT_TYPE_SIZE bits wide. This change, from 12161 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to 12162 accommodate machines like the Alpha. Note that this suggests 12163 f2c and libf2c are missing a distinction perhaps needed on 12164 some machines between "int" and "long int". -- burley 0.5.5 950215 */ 12165 12166 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE, 12167 FFETARGET_f2cTYLONG); 12168 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE, 12169 FFETARGET_f2cTYSHORT); 12170 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE, 12171 FFETARGET_f2cTYINT1); 12172 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE, 12173 FFETARGET_f2cTYQUAD); 12174 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE, 12175 FFETARGET_f2cTYLOGICAL); 12176 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE, 12177 FFETARGET_f2cTYLOGICAL2); 12178 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE, 12179 FFETARGET_f2cTYLOGICAL1); 12180 /* ~~~Not really such a type in libf2c, e.g. I/O support? */ 12181 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE, 12182 FFETARGET_f2cTYQUAD); 12183 12184 /* CHARACTER stuff is all special-cased, so it is not handled in the above 12185 loop. CHARACTER items are built as arrays of unsigned char. */ 12186 12187 ffecom_tree_type[FFEINFO_basictypeCHARACTER] 12188 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node; 12189 type = ffetype_new (); 12190 base_type = type; 12191 ffeinfo_set_type (FFEINFO_basictypeCHARACTER, 12192 FFEINFO_kindtypeCHARACTER1, 12193 type); 12194 ffetype_set_ams (type, 12195 TYPE_ALIGN (t) / BITS_PER_UNIT, 0, 12196 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); 12197 ffetype_set_kind (base_type, 1, type); 12198 assert (ffetype_size (type) 12199 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0])); 12200 12201 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER] 12202 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void; 12203 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER] 12204 [FFEINFO_kindtypeCHARACTER1] 12205 = ffecom_tree_ptr_to_fun_type_void; 12206 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1] 12207 = FFETARGET_f2cTYCHAR; 12208 12209 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY] 12210 = 0; 12211 12212 /* Make multi-return-value type and fields. */ 12213 12214 ffecom_multi_type_node_ = make_node (UNION_TYPE); 12215 12216 field = NULL_TREE; 12217 12218 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) 12219 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) 12220 { 12221 char name[30]; 12222 12223 if (ffecom_tree_type[i][j] == NULL_TREE) 12224 continue; /* Not supported. */ 12225 sprintf (&name[0], "bt_%s_kt_%s", 12226 ffeinfo_basictype_string ((ffeinfoBasictype) i), 12227 ffeinfo_kindtype_string ((ffeinfoKindtype) j)); 12228 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL, 12229 get_identifier (name), 12230 ffecom_tree_type[i][j]); 12231 DECL_CONTEXT (ffecom_multi_fields_[i][j]) 12232 = ffecom_multi_type_node_; 12233 DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0; 12234 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field; 12235 field = ffecom_multi_fields_[i][j]; 12236 } 12237 12238 TYPE_FIELDS (ffecom_multi_type_node_) = field; 12239 layout_type (ffecom_multi_type_node_); 12240 12241 /* Subroutines usually return integer because they might have alternate 12242 returns. */ 12243 12244 ffecom_tree_subr_type 12245 = build_function_type (integer_type_node, NULL_TREE); 12246 ffecom_tree_ptr_to_subr_type 12247 = build_pointer_type (ffecom_tree_subr_type); 12248 ffecom_tree_blockdata_type 12249 = build_function_type (void_type_node, NULL_TREE); 12250 12251 builtin_function ("__builtin_sqrtf", float_ftype_float, 12252 BUILT_IN_FSQRT, "sqrtf"); 12253 builtin_function ("__builtin_fsqrt", double_ftype_double, 12254 BUILT_IN_FSQRT, "sqrt"); 12255 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, 12256 BUILT_IN_FSQRT, "sqrtl"); 12257 builtin_function ("__builtin_sinf", float_ftype_float, 12258 BUILT_IN_SIN, "sinf"); 12259 builtin_function ("__builtin_sin", double_ftype_double, 12260 BUILT_IN_SIN, "sin"); 12261 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, 12262 BUILT_IN_SIN, "sinl"); 12263 builtin_function ("__builtin_cosf", float_ftype_float, 12264 BUILT_IN_COS, "cosf"); 12265 builtin_function ("__builtin_cos", double_ftype_double, 12266 BUILT_IN_COS, "cos"); 12267 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, 12268 BUILT_IN_COS, "cosl"); 12269 12270#if BUILT_FOR_270 12271 pedantic_lvalues = FALSE; 12272#endif 12273 12274 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node, 12275 FFECOM_f2cINTEGER, 12276 "integer"); 12277 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node, 12278 FFECOM_f2cADDRESS, 12279 "address"); 12280 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node, 12281 FFECOM_f2cREAL, 12282 "real"); 12283 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node, 12284 FFECOM_f2cDOUBLEREAL, 12285 "doublereal"); 12286 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node, 12287 FFECOM_f2cCOMPLEX, 12288 "complex"); 12289 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node, 12290 FFECOM_f2cDOUBLECOMPLEX, 12291 "doublecomplex"); 12292 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node, 12293 FFECOM_f2cLONGINT, 12294 "longint"); 12295 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node, 12296 FFECOM_f2cLOGICAL, 12297 "logical"); 12298 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node, 12299 FFECOM_f2cFLAG, 12300 "flag"); 12301 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node, 12302 FFECOM_f2cFTNLEN, 12303 "ftnlen"); 12304 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node, 12305 FFECOM_f2cFTNINT, 12306 "ftnint"); 12307 12308 ffecom_f2c_ftnlen_zero_node 12309 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node); 12310 12311 ffecom_f2c_ftnlen_one_node 12312 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node); 12313 12314 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0); 12315 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node; 12316 12317 ffecom_f2c_ptr_to_ftnlen_type_node 12318 = build_pointer_type (ffecom_f2c_ftnlen_type_node); 12319 12320 ffecom_f2c_ptr_to_ftnint_type_node 12321 = build_pointer_type (ffecom_f2c_ftnint_type_node); 12322 12323 ffecom_f2c_ptr_to_integer_type_node 12324 = build_pointer_type (ffecom_f2c_integer_type_node); 12325 12326 ffecom_f2c_ptr_to_real_type_node 12327 = build_pointer_type (ffecom_f2c_real_type_node); 12328 12329 ffecom_float_zero_ = build_real (float_type_node, dconst0); 12330 ffecom_double_zero_ = build_real (double_type_node, dconst0); 12331 { 12332 REAL_VALUE_TYPE point_5; 12333 12334#ifdef REAL_ARITHMETIC 12335 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2); 12336#else 12337 point_5 = .5; 12338#endif 12339 ffecom_float_half_ = build_real (float_type_node, point_5); 12340 ffecom_double_half_ = build_real (double_type_node, point_5); 12341 } 12342 12343 /* Do "extern int xargc;". */ 12344 12345 ffecom_tree_xargc_ = build_decl (VAR_DECL, 12346 get_identifier ("f__xargc"), 12347 integer_type_node); 12348 DECL_EXTERNAL (ffecom_tree_xargc_) = 1; 12349 TREE_STATIC (ffecom_tree_xargc_) = 1; 12350 TREE_PUBLIC (ffecom_tree_xargc_) = 1; 12351 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE); 12352 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE); 12353 12354#if 0 /* This is being fixed, and seems to be working now. */ 12355 if ((FLOAT_TYPE_SIZE != 32) 12356 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32)) 12357 { 12358 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,", 12359 (int) FLOAT_TYPE_SIZE); 12360 warning ("and pointers are %d bits wide, but g77 doesn't yet work", 12361 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node)))); 12362 warning ("properly unless they all are 32 bits wide."); 12363 warning ("Please keep this in mind before you report bugs. g77 should"); 12364 warning ("support non-32-bit machines better as of version 0.6."); 12365 } 12366#endif 12367 12368#if 0 /* Code in ste.c that would crash has been commented out. */ 12369 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) 12370 < TYPE_PRECISION (string_type_node)) 12371 /* I/O will probably crash. */ 12372 warning ("configuration: char * holds %d bits, but ftnlen only %d", 12373 TYPE_PRECISION (string_type_node), 12374 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)); 12375#endif 12376 12377#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */ 12378 if (TYPE_PRECISION (ffecom_integer_type_node) 12379 < TYPE_PRECISION (string_type_node)) 12380 /* ASSIGN 10 TO I will crash. */ 12381 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\ 12382 ASSIGN statement might fail", 12383 TYPE_PRECISION (string_type_node), 12384 TYPE_PRECISION (ffecom_integer_type_node)); 12385#endif 12386} 12387 12388#endif 12389/* ffecom_init_2 -- Initialize 12390 12391 ffecom_init_2(); */ 12392 12393#if FFECOM_targetCURRENT == FFECOM_targetGCC 12394void 12395ffecom_init_2 () 12396{ 12397 assert (ffecom_outer_function_decl_ == NULL_TREE); 12398 assert (current_function_decl == NULL_TREE); 12399 assert (ffecom_which_entrypoint_decl_ == NULL_TREE); 12400 12401 ffecom_master_arglist_ = NULL; 12402 ++ffecom_num_fns_; 12403 ffecom_primary_entry_ = NULL; 12404 ffecom_is_altreturning_ = FALSE; 12405 ffecom_func_result_ = NULL_TREE; 12406 ffecom_multi_retval_ = NULL_TREE; 12407} 12408 12409#endif 12410/* ffecom_list_expr -- Transform list of exprs into gcc tree 12411 12412 tree t; 12413 ffebld expr; // FFE opITEM list. 12414 tree = ffecom_list_expr(expr); 12415 12416 List of actual args is transformed into corresponding gcc backend list. */ 12417 12418#if FFECOM_targetCURRENT == FFECOM_targetGCC 12419tree 12420ffecom_list_expr (ffebld expr) 12421{ 12422 tree list; 12423 tree *plist = &list; 12424 tree trail = NULL_TREE; /* Append char length args here. */ 12425 tree *ptrail = &trail; 12426 tree length; 12427 12428 while (expr != NULL) 12429 { 12430 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length); 12431 12432 if (texpr == error_mark_node) 12433 return error_mark_node; 12434 12435 *plist = build_tree_list (NULL_TREE, texpr); 12436 plist = &TREE_CHAIN (*plist); 12437 expr = ffebld_trail (expr); 12438 if (length != NULL_TREE) 12439 { 12440 *ptrail = build_tree_list (NULL_TREE, length); 12441 ptrail = &TREE_CHAIN (*ptrail); 12442 } 12443 } 12444 12445 *plist = trail; 12446 12447 return list; 12448} 12449 12450#endif 12451/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree 12452 12453 tree t; 12454 ffebld expr; // FFE opITEM list. 12455 tree = ffecom_list_ptr_to_expr(expr); 12456 12457 List of actual args is transformed into corresponding gcc backend list for 12458 use in calling an external procedure (vs. a statement function). */ 12459 12460#if FFECOM_targetCURRENT == FFECOM_targetGCC 12461tree 12462ffecom_list_ptr_to_expr (ffebld expr) 12463{ 12464 tree list; 12465 tree *plist = &list; 12466 tree trail = NULL_TREE; /* Append char length args here. */ 12467 tree *ptrail = &trail; 12468 tree length; 12469 12470 while (expr != NULL) 12471 { 12472 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length); 12473 12474 if (texpr == error_mark_node) 12475 return error_mark_node; 12476 12477 *plist = build_tree_list (NULL_TREE, texpr); 12478 plist = &TREE_CHAIN (*plist); 12479 expr = ffebld_trail (expr); 12480 if (length != NULL_TREE) 12481 { 12482 *ptrail = build_tree_list (NULL_TREE, length); 12483 ptrail = &TREE_CHAIN (*ptrail); 12484 } 12485 } 12486 12487 *plist = trail; 12488 12489 return list; 12490} 12491 12492#endif 12493/* Obtain gcc's LABEL_DECL tree for label. */ 12494 12495#if FFECOM_targetCURRENT == FFECOM_targetGCC 12496tree 12497ffecom_lookup_label (ffelab label) 12498{ 12499 tree glabel; 12500 12501 if (ffelab_hook (label) == NULL_TREE) 12502 { 12503 char labelname[16]; 12504 12505 switch (ffelab_type (label)) 12506 { 12507 case FFELAB_typeLOOPEND: 12508 case FFELAB_typeNOTLOOP: 12509 case FFELAB_typeENDIF: 12510 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label)); 12511 glabel = build_decl (LABEL_DECL, get_identifier (labelname), 12512 void_type_node); 12513 DECL_CONTEXT (glabel) = current_function_decl; 12514 DECL_MODE (glabel) = VOIDmode; 12515 break; 12516 12517 case FFELAB_typeFORMAT: 12518 push_obstacks_nochange (); 12519 end_temporary_allocation (); 12520 12521 glabel = build_decl (VAR_DECL, 12522 ffecom_get_invented_identifier 12523 ("__g77_format_%d", NULL, 12524 (int) ffelab_value (label)), 12525 build_type_variant (build_array_type 12526 (char_type_node, 12527 NULL_TREE), 12528 1, 0)); 12529 TREE_CONSTANT (glabel) = 1; 12530 TREE_STATIC (glabel) = 1; 12531 DECL_CONTEXT (glabel) = 0; 12532 DECL_INITIAL (glabel) = NULL; 12533 make_decl_rtl (glabel, NULL, 0); 12534 expand_decl (glabel); 12535 12536 resume_temporary_allocation (); 12537 pop_obstacks (); 12538 12539 break; 12540 12541 case FFELAB_typeANY: 12542 glabel = error_mark_node; 12543 break; 12544 12545 default: 12546 assert ("bad label type" == NULL); 12547 glabel = NULL; 12548 break; 12549 } 12550 ffelab_set_hook (label, glabel); 12551 } 12552 else 12553 { 12554 glabel = ffelab_hook (label); 12555 } 12556 12557 return glabel; 12558} 12559 12560#endif 12561/* Stabilizes the arguments. Don't use this if the lhs and rhs come from 12562 a single source specification (as in the fourth argument of MVBITS). 12563 If the type is NULL_TREE, the type of lhs is used to make the type of 12564 the MODIFY_EXPR. */ 12565 12566#if FFECOM_targetCURRENT == FFECOM_targetGCC 12567tree 12568ffecom_modify (tree newtype, tree lhs, 12569 tree rhs) 12570{ 12571 if (lhs == error_mark_node || rhs == error_mark_node) 12572 return error_mark_node; 12573 12574 if (newtype == NULL_TREE) 12575 newtype = TREE_TYPE (lhs); 12576 12577 if (TREE_SIDE_EFFECTS (lhs)) 12578 lhs = stabilize_reference (lhs); 12579 12580 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs); 12581} 12582 12583#endif 12584 12585/* Register source file name. */ 12586 12587void 12588ffecom_file (char *name) 12589{ 12590#if FFECOM_GCC_INCLUDE 12591 ffecom_file_ (name); 12592#endif 12593} 12594 12595/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed 12596 12597 ffestorag st; 12598 ffecom_notify_init_storage(st); 12599 12600 Gets called when all possible units in an aggregate storage area (a LOCAL 12601 with equivalences or a COMMON) have been initialized. The initialization 12602 info either is in ffestorag_init or, if that is NULL, 12603 ffestorag_accretion: 12604 12605 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur 12606 even for an array if the array is one element in length! 12607 12608 ffestorag_accretion will contain an opACCTER. It is much like an 12609 opARRTER except it has an ffebit object in it instead of just a size. 12610 The back end can use the info in the ffebit object, if it wants, to 12611 reduce the amount of actual initialization, but in any case it should 12612 kill the ffebit object when done. Also, set accretion to NULL but 12613 init to a non-NULL value. 12614 12615 After performing initialization, DO NOT set init to NULL, because that'll 12616 tell the front end it is ok for more initialization to happen. Instead, 12617 set init to an opANY expression or some such thing that you can use to 12618 tell that you've already initialized the object. 12619 12620 27-Oct-91 JCB 1.1 12621 Support two-pass FFE. */ 12622 12623void 12624ffecom_notify_init_storage (ffestorag st) 12625{ 12626 ffebld init; /* The initialization expression. */ 12627#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC 12628 ffetargetOffset size; /* The size of the entity. */ 12629 ffetargetAlign pad; /* Its initial padding. */ 12630#endif 12631 12632 if (ffestorag_init (st) == NULL) 12633 { 12634 init = ffestorag_accretion (st); 12635 assert (init != NULL); 12636 ffestorag_set_accretion (st, NULL); 12637 ffestorag_set_accretes (st, 0); 12638 12639#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC 12640 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ 12641 size = ffebld_accter_size (init); 12642 pad = ffebld_accter_pad (init); 12643 ffebit_kill (ffebld_accter_bits (init)); 12644 ffebld_set_op (init, FFEBLD_opARRTER); 12645 ffebld_set_arrter (init, ffebld_accter (init)); 12646 ffebld_arrter_set_size (init, size); 12647 ffebld_arrter_set_pad (init, size); 12648#endif 12649 12650#if FFECOM_TWOPASS 12651 ffestorag_set_init (st, init); 12652#endif 12653 } 12654#if FFECOM_ONEPASS 12655 else 12656 init = ffestorag_init (st); 12657#endif 12658 12659#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */ 12660 ffestorag_set_init (st, ffebld_new_any ()); 12661 12662 if (ffebld_op (init) == FFEBLD_opANY) 12663 return; /* Oh, we already did this! */ 12664 12665#if FFECOM_targetCURRENT == FFECOM_targetFFE 12666 { 12667 ffesymbol s; 12668 12669 if (ffestorag_symbol (st) != NULL) 12670 s = ffestorag_symbol (st); 12671 else 12672 s = ffestorag_typesymbol (st); 12673 12674 fprintf (dmpout, "= initialize_storage \"%s\" ", 12675 (s != NULL) ? ffesymbol_text (s) : "(unnamed)"); 12676 ffebld_dump (init); 12677 fputc ('\n', dmpout); 12678 } 12679#endif 12680 12681#endif /* if FFECOM_ONEPASS */ 12682} 12683 12684/* ffecom_notify_init_symbol -- A symbol is now fully init'ed 12685 12686 ffesymbol s; 12687 ffecom_notify_init_symbol(s); 12688 12689 Gets called when all possible units in a symbol (not placed in COMMON 12690 or involved in EQUIVALENCE, unless it as yet has no ffestorag object) 12691 have been initialized. The initialization info either is in 12692 ffesymbol_init or, if that is NULL, ffesymbol_accretion: 12693 12694 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur 12695 even for an array if the array is one element in length! 12696 12697 ffesymbol_accretion will contain an opACCTER. It is much like an 12698 opARRTER except it has an ffebit object in it instead of just a size. 12699 The back end can use the info in the ffebit object, if it wants, to 12700 reduce the amount of actual initialization, but in any case it should 12701 kill the ffebit object when done. Also, set accretion to NULL but 12702 init to a non-NULL value. 12703 12704 After performing initialization, DO NOT set init to NULL, because that'll 12705 tell the front end it is ok for more initialization to happen. Instead, 12706 set init to an opANY expression or some such thing that you can use to 12707 tell that you've already initialized the object. 12708 12709 27-Oct-91 JCB 1.1 12710 Support two-pass FFE. */ 12711 12712void 12713ffecom_notify_init_symbol (ffesymbol s) 12714{ 12715 ffebld init; /* The initialization expression. */ 12716#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC 12717 ffetargetOffset size; /* The size of the entity. */ 12718 ffetargetAlign pad; /* Its initial padding. */ 12719#endif 12720 12721 if (ffesymbol_storage (s) == NULL) 12722 return; /* Do nothing until COMMON/EQUIVALENCE 12723 possibilities checked. */ 12724 12725 if ((ffesymbol_init (s) == NULL) 12726 && ((init = ffesymbol_accretion (s)) != NULL)) 12727 { 12728 ffesymbol_set_accretion (s, NULL); 12729 ffesymbol_set_accretes (s, 0); 12730 12731#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC 12732 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ 12733 size = ffebld_accter_size (init); 12734 pad = ffebld_accter_pad (init); 12735 ffebit_kill (ffebld_accter_bits (init)); 12736 ffebld_set_op (init, FFEBLD_opARRTER); 12737 ffebld_set_arrter (init, ffebld_accter (init)); 12738 ffebld_arrter_set_size (init, size); 12739 ffebld_arrter_set_pad (init, size); 12740#endif 12741 12742#if FFECOM_TWOPASS 12743 ffesymbol_set_init (s, init); 12744#endif 12745 } 12746#if FFECOM_ONEPASS 12747 else 12748 init = ffesymbol_init (s); 12749#endif 12750 12751#if FFECOM_ONEPASS 12752 ffesymbol_set_init (s, ffebld_new_any ()); 12753 12754 if (ffebld_op (init) == FFEBLD_opANY) 12755 return; /* Oh, we already did this! */ 12756 12757#if FFECOM_targetCURRENT == FFECOM_targetFFE 12758 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s)); 12759 ffebld_dump (init); 12760 fputc ('\n', dmpout); 12761#endif 12762 12763#endif /* if FFECOM_ONEPASS */ 12764} 12765 12766/* ffecom_notify_primary_entry -- Learn which is the primary entry point 12767 12768 ffesymbol s; 12769 ffecom_notify_primary_entry(s); 12770 12771 Gets called when implicit or explicit PROGRAM statement seen or when 12772 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary 12773 global symbol that serves as the entry point. */ 12774 12775void 12776ffecom_notify_primary_entry (ffesymbol s) 12777{ 12778 ffecom_primary_entry_ = s; 12779 ffecom_primary_entry_kind_ = ffesymbol_kind (s); 12780 12781 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) 12782 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)) 12783 ffecom_primary_entry_is_proc_ = TRUE; 12784 else 12785 ffecom_primary_entry_is_proc_ = FALSE; 12786 12787 if (!ffe_is_silent ()) 12788 { 12789 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM) 12790 fprintf (stderr, "%s:\n", ffesymbol_text (s)); 12791 else 12792 fprintf (stderr, " %s:\n", ffesymbol_text (s)); 12793 } 12794 12795#if FFECOM_targetCURRENT == FFECOM_targetGCC 12796 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) 12797 { 12798 ffebld list; 12799 ffebld arg; 12800 12801 for (list = ffesymbol_dummyargs (s); 12802 list != NULL; 12803 list = ffebld_trail (list)) 12804 { 12805 arg = ffebld_head (list); 12806 if (ffebld_op (arg) == FFEBLD_opSTAR) 12807 { 12808 ffecom_is_altreturning_ = TRUE; 12809 break; 12810 } 12811 } 12812 } 12813#endif 12814} 12815 12816FILE * 12817ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) 12818{ 12819#if FFECOM_GCC_INCLUDE 12820 return ffecom_open_include_ (name, l, c); 12821#else 12822 return fopen (name, "r"); 12823#endif 12824} 12825 12826/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front 12827 12828 tree t; 12829 ffebld expr; // FFE expression. 12830 tree = ffecom_ptr_to_expr(expr); 12831 12832 Like ffecom_expr, but sticks address-of in front of most things. */ 12833 12834#if FFECOM_targetCURRENT == FFECOM_targetGCC 12835tree 12836ffecom_ptr_to_expr (ffebld expr) 12837{ 12838 tree item; 12839 ffeinfoBasictype bt; 12840 ffeinfoKindtype kt; 12841 ffesymbol s; 12842 12843 assert (expr != NULL); 12844 12845 switch (ffebld_op (expr)) 12846 { 12847 case FFEBLD_opSYMTER: 12848 s = ffebld_symter (expr); 12849 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) 12850 { 12851 ffecomGfrt ix; 12852 12853 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr)); 12854 assert (ix != FFECOM_gfrt); 12855 if ((item = ffecom_gfrt_[ix]) == NULL_TREE) 12856 { 12857 ffecom_make_gfrt_ (ix); 12858 item = ffecom_gfrt_[ix]; 12859 } 12860 } 12861 else 12862 { 12863 item = ffesymbol_hook (s).decl_tree; 12864 if (item == NULL_TREE) 12865 { 12866 s = ffecom_sym_transform_ (s); 12867 item = ffesymbol_hook (s).decl_tree; 12868 } 12869 } 12870 assert (item != NULL); 12871 if (item == error_mark_node) 12872 return item; 12873 if (!ffesymbol_hook (s).addr) 12874 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), 12875 item); 12876 return item; 12877 12878 case FFEBLD_opARRAYREF: 12879 return ffecom_arrayref_ (NULL_TREE, expr, 1); 12880 12881 case FFEBLD_opCONTER: 12882 12883 bt = ffeinfo_basictype (ffebld_info (expr)); 12884 kt = ffeinfo_kindtype (ffebld_info (expr)); 12885 12886 item = ffecom_constantunion (&ffebld_constant_union 12887 (ffebld_conter (expr)), bt, kt, 12888 ffecom_tree_type[bt][kt]); 12889 if (item == error_mark_node) 12890 return error_mark_node; 12891 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), 12892 item); 12893 return item; 12894 12895 case FFEBLD_opANY: 12896 return error_mark_node; 12897 12898 default: 12899 bt = ffeinfo_basictype (ffebld_info (expr)); 12900 kt = ffeinfo_kindtype (ffebld_info (expr)); 12901 12902 item = ffecom_expr (expr); 12903 if (item == error_mark_node) 12904 return error_mark_node; 12905 12906 /* The back end currently optimizes a bit too zealously for us, in that 12907 we fail JCB001 if the following block of code is omitted. It checks 12908 to see if the transformed expression is a symbol or array reference, 12909 and encloses it in a SAVE_EXPR if that is the case. */ 12910 12911 STRIP_NOPS (item); 12912 if ((TREE_CODE (item) == VAR_DECL) 12913 || (TREE_CODE (item) == PARM_DECL) 12914 || (TREE_CODE (item) == RESULT_DECL) 12915 || (TREE_CODE (item) == INDIRECT_REF) 12916 || (TREE_CODE (item) == ARRAY_REF) 12917 || (TREE_CODE (item) == COMPONENT_REF) 12918#ifdef OFFSET_REF 12919 || (TREE_CODE (item) == OFFSET_REF) 12920#endif 12921 || (TREE_CODE (item) == BUFFER_REF) 12922 || (TREE_CODE (item) == REALPART_EXPR) 12923 || (TREE_CODE (item) == IMAGPART_EXPR)) 12924 { 12925 item = ffecom_save_tree (item); 12926 } 12927 12928 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), 12929 item); 12930 return item; 12931 } 12932 12933 assert ("fall-through error" == NULL); 12934 return error_mark_node; 12935} 12936 12937#endif 12938/* Obtain a temp var with given data type. 12939 12940 size is FFETARGET_charactersizeNONE for a non-CHARACTER type 12941 or >= 0 for a CHARACTER type. 12942 12943 elements is -1 for a scalar or > 0 for an array of type. */ 12944 12945#if FFECOM_targetCURRENT == FFECOM_targetGCC 12946tree 12947ffecom_make_tempvar (const char *commentary, tree type, 12948 ffetargetCharacterSize size, int elements) 12949{ 12950 int yes; 12951 tree t; 12952 static int mynumber; 12953 12954 assert (current_binding_level->prep_state < 2); 12955 12956 if (type == error_mark_node) 12957 return error_mark_node; 12958 12959 yes = suspend_momentary (); 12960 12961 if (size != FFETARGET_charactersizeNONE) 12962 type = build_array_type (type, 12963 build_range_type (ffecom_f2c_ftnlen_type_node, 12964 ffecom_f2c_ftnlen_one_node, 12965 build_int_2 (size, 0))); 12966 if (elements != -1) 12967 type = build_array_type (type, 12968 build_range_type (integer_type_node, 12969 integer_zero_node, 12970 build_int_2 (elements - 1, 12971 0))); 12972 t = build_decl (VAR_DECL, 12973 ffecom_get_invented_identifier ("__g77_%s_%d", 12974 commentary, 12975 mynumber++), 12976 type); 12977 12978 t = start_decl (t, FALSE); 12979 finish_decl (t, NULL_TREE, FALSE); 12980 12981 resume_momentary (yes); 12982 12983 return t; 12984} 12985#endif 12986 12987/* Prepare argument pointer to expression. 12988 12989 Like ffecom_prepare_expr, except for expressions to be evaluated 12990 via ffecom_arg_ptr_to_expr. */ 12991 12992void 12993ffecom_prepare_arg_ptr_to_expr (ffebld expr) 12994{ 12995 /* ~~For now, it seems to be the same thing. */ 12996 ffecom_prepare_expr (expr); 12997 return; 12998} 12999 13000/* End of preparations. */ 13001 13002bool 13003ffecom_prepare_end (void) 13004{ 13005 int prep_state = current_binding_level->prep_state; 13006 13007 assert (prep_state < 2); 13008 current_binding_level->prep_state = 2; 13009 13010 return (prep_state == 1) ? TRUE : FALSE; 13011} 13012 13013/* Prepare expression. 13014 13015 This is called before any code is generated for the current block. 13016 It scans the expression, declares any temporaries that might be needed 13017 during evaluation of the expression, and stores those temporaries in 13018 the appropriate "hook" fields of the expression. `dest', if not NULL, 13019 specifies the destination that ffecom_expr_ will see, in case that 13020 helps avoid generating unused temporaries. 13021 13022 ~~Improve to avoid allocating unused temporaries by taking `dest' 13023 into account vis-a-vis aliasing requirements of complex/character 13024 functions. */ 13025 13026void 13027ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) 13028{ 13029 ffeinfoBasictype bt; 13030 ffeinfoKindtype kt; 13031 ffetargetCharacterSize sz; 13032 tree tempvar = NULL_TREE; 13033 13034 assert (current_binding_level->prep_state < 2); 13035 13036 if (! expr) 13037 return; 13038 13039 bt = ffeinfo_basictype (ffebld_info (expr)); 13040 kt = ffeinfo_kindtype (ffebld_info (expr)); 13041 sz = ffeinfo_size (ffebld_info (expr)); 13042 13043 /* Generate whatever temporaries are needed to represent the result 13044 of the expression. */ 13045 13046 if (bt == FFEINFO_basictypeCHARACTER) 13047 { 13048 while (ffebld_op (expr) == FFEBLD_opPAREN) 13049 expr = ffebld_left (expr); 13050 } 13051 13052 switch (ffebld_op (expr)) 13053 { 13054 default: 13055 /* Don't make temps for SYMTER, CONTER, etc. */ 13056 if (ffebld_arity (expr) == 0) 13057 break; 13058 13059 switch (bt) 13060 { 13061 case FFEINFO_basictypeCOMPLEX: 13062 if (ffebld_op (expr) == FFEBLD_opFUNCREF) 13063 { 13064 ffesymbol s; 13065 13066 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER) 13067 break; 13068 13069 s = ffebld_symter (ffebld_left (expr)); 13070 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT 13071 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC 13072 && ! ffesymbol_is_f2c (s)) 13073 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC 13074 && ! ffe_is_f2c_library ())) 13075 break; 13076 } 13077 else if (ffebld_op (expr) == FFEBLD_opPOWER) 13078 { 13079 /* Requires special treatment. There's no POW_CC function 13080 in libg2c, so POW_ZZ is used, which means we always 13081 need a double-complex temp, not a single-complex. */ 13082 kt = FFEINFO_kindtypeREAL2; 13083 } 13084 else if (ffebld_op (expr) != FFEBLD_opDIVIDE) 13085 /* The other ops don't need temps for complex operands. */ 13086 break; 13087 13088 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C), 13089 REAL(C). See 19990325-0.f, routine `check', for cases. */ 13090 tempvar = ffecom_make_tempvar ("complex", 13091 ffecom_tree_type 13092 [FFEINFO_basictypeCOMPLEX][kt], 13093 FFETARGET_charactersizeNONE, 13094 -1); 13095 break; 13096 13097 case FFEINFO_basictypeCHARACTER: 13098 if (ffebld_op (expr) != FFEBLD_opFUNCREF) 13099 break; 13100 13101 if (sz == FFETARGET_charactersizeNONE) 13102 /* ~~Kludge alert! This should someday be fixed. */ 13103 sz = 24; 13104 13105 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1); 13106 break; 13107 13108 default: 13109 break; 13110 } 13111 break; 13112 13113#ifdef HAHA 13114 case FFEBLD_opPOWER: 13115 { 13116 tree rtype, ltype; 13117 tree rtmp, ltmp, result; 13118 13119 ltype = ffecom_type_expr (ffebld_left (expr)); 13120 rtype = ffecom_type_expr (ffebld_right (expr)); 13121 13122 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1); 13123 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); 13124 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); 13125 13126 tempvar = make_tree_vec (3); 13127 TREE_VEC_ELT (tempvar, 0) = rtmp; 13128 TREE_VEC_ELT (tempvar, 1) = ltmp; 13129 TREE_VEC_ELT (tempvar, 2) = result; 13130 } 13131 break; 13132#endif /* HAHA */ 13133 13134 case FFEBLD_opCONCATENATE: 13135 { 13136 /* This gets special handling, because only one set of temps 13137 is needed for a tree of these -- the tree is treated as 13138 a flattened list of concatenations when generating code. */ 13139 13140 ffecomConcatList_ catlist; 13141 tree ltmp, itmp, result; 13142 int count; 13143 int i; 13144 13145 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); 13146 count = ffecom_concat_list_count_ (catlist); 13147 13148 if (count >= 2) 13149 { 13150 ltmp 13151 = ffecom_make_tempvar ("concat_len", 13152 ffecom_f2c_ftnlen_type_node, 13153 FFETARGET_charactersizeNONE, count); 13154 itmp 13155 = ffecom_make_tempvar ("concat_item", 13156 ffecom_f2c_address_type_node, 13157 FFETARGET_charactersizeNONE, count); 13158 result 13159 = ffecom_make_tempvar ("concat_res", 13160 char_type_node, 13161 ffecom_concat_list_maxlen_ (catlist), 13162 -1); 13163 13164 tempvar = make_tree_vec (3); 13165 TREE_VEC_ELT (tempvar, 0) = ltmp; 13166 TREE_VEC_ELT (tempvar, 1) = itmp; 13167 TREE_VEC_ELT (tempvar, 2) = result; 13168 } 13169 13170 for (i = 0; i < count; ++i) 13171 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, 13172 i)); 13173 13174 ffecom_concat_list_kill_ (catlist); 13175 13176 if (tempvar) 13177 { 13178 ffebld_nonter_set_hook (expr, tempvar); 13179 current_binding_level->prep_state = 1; 13180 } 13181 } 13182 return; 13183 13184 case FFEBLD_opCONVERT: 13185 if (bt == FFEINFO_basictypeCHARACTER 13186 && ((ffebld_size_known (ffebld_left (expr)) 13187 == FFETARGET_charactersizeNONE) 13188 || (ffebld_size_known (ffebld_left (expr)) >= sz))) 13189 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1); 13190 break; 13191 } 13192 13193 if (tempvar) 13194 { 13195 ffebld_nonter_set_hook (expr, tempvar); 13196 current_binding_level->prep_state = 1; 13197 } 13198 13199 /* Prepare subexpressions for this expr. */ 13200 13201 switch (ffebld_op (expr)) 13202 { 13203 case FFEBLD_opPERCENT_LOC: 13204 ffecom_prepare_ptr_to_expr (ffebld_left (expr)); 13205 break; 13206 13207 case FFEBLD_opPERCENT_VAL: 13208 case FFEBLD_opPERCENT_REF: 13209 ffecom_prepare_expr (ffebld_left (expr)); 13210 break; 13211 13212 case FFEBLD_opPERCENT_DESCR: 13213 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr)); 13214 break; 13215 13216 case FFEBLD_opITEM: 13217 { 13218 ffebld item; 13219 13220 for (item = expr; 13221 item != NULL; 13222 item = ffebld_trail (item)) 13223 if (ffebld_head (item) != NULL) 13224 ffecom_prepare_expr (ffebld_head (item)); 13225 } 13226 break; 13227 13228 default: 13229 /* Need to handle character conversion specially. */ 13230 switch (ffebld_arity (expr)) 13231 { 13232 case 2: 13233 ffecom_prepare_expr (ffebld_left (expr)); 13234 ffecom_prepare_expr (ffebld_right (expr)); 13235 break; 13236 13237 case 1: 13238 ffecom_prepare_expr (ffebld_left (expr)); 13239 break; 13240 13241 default: 13242 break; 13243 } 13244 } 13245 13246 return; 13247} 13248 13249/* Prepare expression for reading and writing. 13250 13251 Like ffecom_prepare_expr, except for expressions to be evaluated 13252 via ffecom_expr_rw. */ 13253 13254void 13255ffecom_prepare_expr_rw (tree type, ffebld expr) 13256{ 13257 /* This is all we support for now. */ 13258 assert (type == NULL_TREE || type == ffecom_type_expr (expr)); 13259 13260 /* ~~For now, it seems to be the same thing. */ 13261 ffecom_prepare_expr (expr); 13262 return; 13263} 13264 13265/* Prepare expression for writing. 13266 13267 Like ffecom_prepare_expr, except for expressions to be evaluated 13268 via ffecom_expr_w. */ 13269 13270void 13271ffecom_prepare_expr_w (tree type, ffebld expr) 13272{ 13273 /* This is all we support for now. */ 13274 assert (type == NULL_TREE || type == ffecom_type_expr (expr)); 13275 13276 /* ~~For now, it seems to be the same thing. */ 13277 ffecom_prepare_expr (expr); 13278 return; 13279} 13280 13281/* Prepare expression for returning. 13282 13283 Like ffecom_prepare_expr, except for expressions to be evaluated 13284 via ffecom_return_expr. */ 13285 13286void 13287ffecom_prepare_return_expr (ffebld expr) 13288{ 13289 assert (current_binding_level->prep_state < 2); 13290 13291 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE 13292 && ffecom_is_altreturning_ 13293 && expr != NULL) 13294 ffecom_prepare_expr (expr); 13295} 13296 13297/* Prepare pointer to expression. 13298 13299 Like ffecom_prepare_expr, except for expressions to be evaluated 13300 via ffecom_ptr_to_expr. */ 13301 13302void 13303ffecom_prepare_ptr_to_expr (ffebld expr) 13304{ 13305 /* ~~For now, it seems to be the same thing. */ 13306 ffecom_prepare_expr (expr); 13307 return; 13308} 13309 13310/* Transform expression into constant pointer-to-expression tree. 13311 13312 If the expression can be transformed into a pointer-to-expression tree 13313 that is constant, that is done, and the tree returned. Else NULL_TREE 13314 is returned. 13315 13316 That way, a caller can attempt to provide compile-time initialization 13317 of a variable and, if that fails, *then* choose to start a new block 13318 and resort to using temporaries, as appropriate. */ 13319 13320tree 13321ffecom_ptr_to_const_expr (ffebld expr) 13322{ 13323 if (! expr) 13324 return integer_zero_node; 13325 13326 if (ffebld_op (expr) == FFEBLD_opANY) 13327 return error_mark_node; 13328 13329 if (ffebld_arity (expr) == 0 13330 && (ffebld_op (expr) != FFEBLD_opSYMTER 13331 || ffebld_where (expr) == FFEINFO_whereCOMMON 13332 || ffebld_where (expr) == FFEINFO_whereGLOBAL 13333 || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) 13334 { 13335 tree t; 13336 13337 t = ffecom_ptr_to_expr (expr); 13338 assert (TREE_CONSTANT (t)); 13339 return t; 13340 } 13341 13342 return NULL_TREE; 13343} 13344 13345/* ffecom_return_expr -- Returns return-value expr given alt return expr 13346 13347 tree rtn; // NULL_TREE means use expand_null_return() 13348 ffebld expr; // NULL if no alt return expr to RETURN stmt 13349 rtn = ffecom_return_expr(expr); 13350 13351 Based on the program unit type and other info (like return function 13352 type, return master function type when alternate ENTRY points, 13353 whether subroutine has any alternate RETURN points, etc), returns the 13354 appropriate expression to be returned to the caller, or NULL_TREE 13355 meaning no return value or the caller expects it to be returned somewhere 13356 else (which is handled by other parts of this module). */ 13357 13358#if FFECOM_targetCURRENT == FFECOM_targetGCC 13359tree 13360ffecom_return_expr (ffebld expr) 13361{ 13362 tree rtn; 13363 13364 switch (ffecom_primary_entry_kind_) 13365 { 13366 case FFEINFO_kindPROGRAM: 13367 case FFEINFO_kindBLOCKDATA: 13368 rtn = NULL_TREE; 13369 break; 13370 13371 case FFEINFO_kindSUBROUTINE: 13372 if (!ffecom_is_altreturning_) 13373 rtn = NULL_TREE; /* No alt returns, never an expr. */ 13374 else if (expr == NULL) 13375 rtn = integer_zero_node; 13376 else 13377 rtn = ffecom_expr (expr); 13378 break; 13379 13380 case FFEINFO_kindFUNCTION: 13381 if ((ffecom_multi_retval_ != NULL_TREE) 13382 || (ffesymbol_basictype (ffecom_primary_entry_) 13383 == FFEINFO_basictypeCHARACTER) 13384 || ((ffesymbol_basictype (ffecom_primary_entry_) 13385 == FFEINFO_basictypeCOMPLEX) 13386 && (ffecom_num_entrypoints_ == 0) 13387 && ffesymbol_is_f2c (ffecom_primary_entry_))) 13388 { /* Value is returned by direct assignment 13389 into (implicit) dummy. */ 13390 rtn = NULL_TREE; 13391 break; 13392 } 13393 rtn = ffecom_func_result_; 13394#if 0 13395 /* Spurious error if RETURN happens before first reference! So elide 13396 this code. In particular, for debugging registry, rtn should always 13397 be non-null after all, but TREE_USED won't be set until we encounter 13398 a reference in the code. Perfectly okay (but weird) code that, 13399 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in 13400 this diagnostic for no reason. Have people use -O -Wuninitialized 13401 and leave it to the back end to find obviously weird cases. */ 13402 13403 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid 13404 situation; if the return value has never been referenced, it won't 13405 have a tree under 2pass mode. */ 13406 if ((rtn == NULL_TREE) 13407 || !TREE_USED (rtn)) 13408 { 13409 ffebad_start (FFEBAD_RETURN_VALUE_UNSET); 13410 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_), 13411 ffesymbol_where_column (ffecom_primary_entry_)); 13412 ffebad_string (ffesymbol_text (ffesymbol_funcresult 13413 (ffecom_primary_entry_))); 13414 ffebad_finish (); 13415 } 13416#endif 13417 break; 13418 13419 default: 13420 assert ("bad unit kind" == NULL); 13421 case FFEINFO_kindANY: 13422 rtn = error_mark_node; 13423 break; 13424 } 13425 13426 return rtn; 13427} 13428 13429#endif 13430/* Do save_expr only if tree is not error_mark_node. */ 13431 13432#if FFECOM_targetCURRENT == FFECOM_targetGCC 13433tree 13434ffecom_save_tree (tree t) 13435{ 13436 return save_expr (t); 13437} 13438#endif 13439 13440/* Start a compound statement (block). */ 13441 13442#if FFECOM_targetCURRENT == FFECOM_targetGCC 13443void 13444ffecom_start_compstmt (void) 13445{ 13446 bison_rule_pushlevel_ (); 13447} 13448#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 13449 13450/* Public entry point for front end to access start_decl. */ 13451 13452#if FFECOM_targetCURRENT == FFECOM_targetGCC 13453tree 13454ffecom_start_decl (tree decl, bool is_initialized) 13455{ 13456 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; 13457 return start_decl (decl, FALSE); 13458} 13459 13460#endif 13461/* ffecom_sym_commit -- Symbol's state being committed to reality 13462 13463 ffesymbol s; 13464 ffecom_sym_commit(s); 13465 13466 Does whatever the backend needs when a symbol is committed after having 13467 been backtrackable for a period of time. */ 13468 13469#if FFECOM_targetCURRENT == FFECOM_targetGCC 13470void 13471ffecom_sym_commit (ffesymbol s UNUSED) 13472{ 13473 assert (!ffesymbol_retractable ()); 13474} 13475 13476#endif 13477/* ffecom_sym_end_transition -- Perform end transition on all symbols 13478 13479 ffecom_sym_end_transition(); 13480 13481 Does backend-specific stuff and also calls ffest_sym_end_transition 13482 to do the necessary FFE stuff. 13483 13484 Backtracking is never enabled when this fn is called, so don't worry 13485 about it. */ 13486 13487ffesymbol 13488ffecom_sym_end_transition (ffesymbol s) 13489{ 13490 ffestorag st; 13491 13492 assert (!ffesymbol_retractable ()); 13493 13494 s = ffest_sym_end_transition (s); 13495 13496#if FFECOM_targetCURRENT == FFECOM_targetGCC 13497 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA) 13498 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL)) 13499 { 13500 ffecom_list_blockdata_ 13501 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, 13502 FFEINTRIN_specNONE, 13503 FFEINTRIN_impNONE), 13504 ffecom_list_blockdata_); 13505 } 13506#endif 13507 13508 /* This is where we finally notice that a symbol has partial initialization 13509 and finalize it. */ 13510 13511 if (ffesymbol_accretion (s) != NULL) 13512 { 13513 assert (ffesymbol_init (s) == NULL); 13514 ffecom_notify_init_symbol (s); 13515 } 13516 else if (((st = ffesymbol_storage (s)) != NULL) 13517 && ((st = ffestorag_parent (st)) != NULL) 13518 && (ffestorag_accretion (st) != NULL)) 13519 { 13520 assert (ffestorag_init (st) == NULL); 13521 ffecom_notify_init_storage (st); 13522 } 13523 13524#if FFECOM_targetCURRENT == FFECOM_targetGCC 13525 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON) 13526 && (ffesymbol_where (s) == FFEINFO_whereLOCAL) 13527 && (ffesymbol_storage (s) != NULL)) 13528 { 13529 ffecom_list_common_ 13530 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, 13531 FFEINTRIN_specNONE, 13532 FFEINTRIN_impNONE), 13533 ffecom_list_common_); 13534 } 13535#endif 13536 13537 return s; 13538} 13539 13540/* ffecom_sym_exec_transition -- Perform exec transition on all symbols 13541 13542 ffecom_sym_exec_transition(); 13543 13544 Does backend-specific stuff and also calls ffest_sym_exec_transition 13545 to do the necessary FFE stuff. 13546 13547 See the long-winded description in ffecom_sym_learned for info 13548 on handling the situation where backtracking is inhibited. */ 13549 13550ffesymbol 13551ffecom_sym_exec_transition (ffesymbol s) 13552{ 13553 s = ffest_sym_exec_transition (s); 13554 13555 return s; 13556} 13557 13558/* ffecom_sym_learned -- Initial or more info gained on symbol after exec 13559 13560 ffesymbol s; 13561 s = ffecom_sym_learned(s); 13562 13563 Called when a new symbol is seen after the exec transition or when more 13564 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when 13565 it arrives here is that all its latest info is updated already, so its 13566 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook 13567 field filled in if its gone through here or exec_transition first, and 13568 so on. 13569 13570 The backend probably wants to check ffesymbol_retractable() to see if 13571 backtracking is in effect. If so, the FFE's changes to the symbol may 13572 be retracted (undone) or committed (ratified), at which time the 13573 appropriate ffecom_sym_retract or _commit function will be called 13574 for that function. 13575 13576 If the backend has its own backtracking mechanism, great, use it so that 13577 committal is a simple operation. Though it doesn't make much difference, 13578 I suppose: the reason for tentative symbol evolution in the FFE is to 13579 enable error detection in weird incorrect statements early and to disable 13580 incorrect error detection on a correct statement. The backend is not 13581 likely to introduce any information that'll get involved in these 13582 considerations, so it is probably just fine that the implementation 13583 model for this fn and for _exec_transition is to not do anything 13584 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE 13585 and instead wait until ffecom_sym_commit is called (which it never 13586 will be as long as we're using ambiguity-detecting statement analysis in 13587 the FFE, which we are initially to shake out the code, but don't depend 13588 on this), otherwise go ahead and do whatever is needed. 13589 13590 In essence, then, when this fn and _exec_transition get called while 13591 backtracking is enabled, a general mechanism would be to flag which (or 13592 both) of these were called (and in what order? neat question as to what 13593 might happen that I'm too lame to think through right now) and then when 13594 _commit is called reproduce the original calling sequence, if any, for 13595 the two fns (at which point backtracking will, of course, be disabled). */ 13596 13597ffesymbol 13598ffecom_sym_learned (ffesymbol s) 13599{ 13600 ffestorag_exec_layout (s); 13601 13602 return s; 13603} 13604 13605/* ffecom_sym_retract -- Symbol's state being retracted from reality 13606 13607 ffesymbol s; 13608 ffecom_sym_retract(s); 13609 13610 Does whatever the backend needs when a symbol is retracted after having 13611 been backtrackable for a period of time. */ 13612 13613#if FFECOM_targetCURRENT == FFECOM_targetGCC 13614void 13615ffecom_sym_retract (ffesymbol s UNUSED) 13616{ 13617 assert (!ffesymbol_retractable ()); 13618 13619#if 0 /* GCC doesn't commit any backtrackable sins, 13620 so nothing needed here. */ 13621 switch (ffesymbol_hook (s).state) 13622 { 13623 case 0: /* nothing happened yet. */ 13624 break; 13625 13626 case 1: /* exec transition happened. */ 13627 break; 13628 13629 case 2: /* learned happened. */ 13630 break; 13631 13632 case 3: /* learned then exec. */ 13633 break; 13634 13635 case 4: /* exec then learned. */ 13636 break; 13637 13638 default: 13639 assert ("bad hook state" == NULL); 13640 break; 13641 } 13642#endif 13643} 13644 13645#endif 13646/* Create temporary gcc label. */ 13647 13648#if FFECOM_targetCURRENT == FFECOM_targetGCC 13649tree 13650ffecom_temp_label () 13651{ 13652 tree glabel; 13653 static int mynumber = 0; 13654 13655 glabel = build_decl (LABEL_DECL, 13656 ffecom_get_invented_identifier ("__g77_label_%d", 13657 NULL, 13658 mynumber++), 13659 void_type_node); 13660 DECL_CONTEXT (glabel) = current_function_decl; 13661 DECL_MODE (glabel) = VOIDmode; 13662 13663 return glabel; 13664} 13665 13666#endif 13667/* Return an expression that is usable as an arg in a conditional context 13668 (IF, DO WHILE, .NOT., and so on). 13669 13670 Use the one provided for the back end as of >2.6.0. */ 13671 13672#if FFECOM_targetCURRENT == FFECOM_targetGCC 13673tree 13674ffecom_truth_value (tree expr) 13675{ 13676 return truthvalue_conversion (expr); 13677} 13678 13679#endif 13680/* Return the inversion of a truth value (the inversion of what 13681 ffecom_truth_value builds). 13682 13683 Apparently invert_truthvalue, which is properly in the back end, is 13684 enough for now, so just use it. */ 13685 13686#if FFECOM_targetCURRENT == FFECOM_targetGCC 13687tree 13688ffecom_truth_value_invert (tree expr) 13689{ 13690 return invert_truthvalue (ffecom_truth_value (expr)); 13691} 13692 13693#endif 13694 13695/* Return the tree that is the type of the expression, as would be 13696 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise 13697 transforming the expression, generating temporaries, etc. */ 13698 13699tree 13700ffecom_type_expr (ffebld expr) 13701{ 13702 ffeinfoBasictype bt; 13703 ffeinfoKindtype kt; 13704 tree tree_type; 13705 13706 assert (expr != NULL); 13707 13708 bt = ffeinfo_basictype (ffebld_info (expr)); 13709 kt = ffeinfo_kindtype (ffebld_info (expr)); 13710 tree_type = ffecom_tree_type[bt][kt]; 13711 13712 switch (ffebld_op (expr)) 13713 { 13714 case FFEBLD_opCONTER: 13715 case FFEBLD_opSYMTER: 13716 case FFEBLD_opARRAYREF: 13717 case FFEBLD_opUPLUS: 13718 case FFEBLD_opPAREN: 13719 case FFEBLD_opUMINUS: 13720 case FFEBLD_opADD: 13721 case FFEBLD_opSUBTRACT: 13722 case FFEBLD_opMULTIPLY: 13723 case FFEBLD_opDIVIDE: 13724 case FFEBLD_opPOWER: 13725 case FFEBLD_opNOT: 13726 case FFEBLD_opFUNCREF: 13727 case FFEBLD_opSUBRREF: 13728 case FFEBLD_opAND: 13729 case FFEBLD_opOR: 13730 case FFEBLD_opXOR: 13731 case FFEBLD_opNEQV: 13732 case FFEBLD_opEQV: 13733 case FFEBLD_opCONVERT: 13734 case FFEBLD_opLT: 13735 case FFEBLD_opLE: 13736 case FFEBLD_opEQ: 13737 case FFEBLD_opNE: 13738 case FFEBLD_opGT: 13739 case FFEBLD_opGE: 13740 case FFEBLD_opPERCENT_LOC: 13741 return tree_type; 13742 13743 case FFEBLD_opACCTER: 13744 case FFEBLD_opARRTER: 13745 case FFEBLD_opITEM: 13746 case FFEBLD_opSTAR: 13747 case FFEBLD_opBOUNDS: 13748 case FFEBLD_opREPEAT: 13749 case FFEBLD_opLABTER: 13750 case FFEBLD_opLABTOK: 13751 case FFEBLD_opIMPDO: 13752 case FFEBLD_opCONCATENATE: 13753 case FFEBLD_opSUBSTR: 13754 default: 13755 assert ("bad op for ffecom_type_expr" == NULL); 13756 /* Fall through. */ 13757 case FFEBLD_opANY: 13758 return error_mark_node; 13759 } 13760} 13761 13762/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points 13763 13764 If the PARM_DECL already exists, return it, else create it. It's an 13765 integer_type_node argument for the master function that implements a 13766 subroutine or function with more than one entrypoint and is bound at 13767 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for 13768 first ENTRY statement, and so on). */ 13769 13770#if FFECOM_targetCURRENT == FFECOM_targetGCC 13771tree 13772ffecom_which_entrypoint_decl () 13773{ 13774 assert (ffecom_which_entrypoint_decl_ != NULL_TREE); 13775 13776 return ffecom_which_entrypoint_decl_; 13777} 13778 13779#endif 13780 13781/* The following sections consists of private and public functions 13782 that have the same names and perform roughly the same functions 13783 as counterparts in the C front end. Changes in the C front end 13784 might affect how things should be done here. Only functions 13785 needed by the back end should be public here; the rest should 13786 be private (static in the C sense). Functions needed by other 13787 g77 front-end modules should be accessed by them via public 13788 ffecom_* names, which should themselves call private versions 13789 in this section so the private versions are easy to recognize 13790 when upgrading to a new gcc and finding interesting changes 13791 in the front end. 13792 13793 Functions named after rule "foo:" in c-parse.y are named 13794 "bison_rule_foo_" so they are easy to find. */ 13795 13796#if FFECOM_targetCURRENT == FFECOM_targetGCC 13797 13798static void 13799bison_rule_pushlevel_ () 13800{ 13801 emit_line_note (input_filename, lineno); 13802 pushlevel (0); 13803 clear_last_expr (); 13804 push_momentary (); 13805 expand_start_bindings (0); 13806} 13807 13808static tree 13809bison_rule_compstmt_ () 13810{ 13811 tree t; 13812 int keep = kept_level_p (); 13813 13814 /* Make the temps go away. */ 13815 if (! keep) 13816 current_binding_level->names = NULL_TREE; 13817 13818 emit_line_note (input_filename, lineno); 13819 expand_end_bindings (getdecls (), keep, 0); 13820 t = poplevel (keep, 1, 0); 13821 pop_momentary (); 13822 13823 return t; 13824} 13825 13826/* Return a definition for a builtin function named NAME and whose data type 13827 is TYPE. TYPE should be a function type with argument types. 13828 FUNCTION_CODE tells later passes how to compile calls to this function. 13829 See tree.h for its possible values. 13830 13831 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, 13832 the name to be called if we can't opencode the function. */ 13833 13834static tree 13835builtin_function (const char *name, tree type, 13836 enum built_in_function function_code, 13837 const char *library_name) 13838{ 13839 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); 13840 DECL_EXTERNAL (decl) = 1; 13841 TREE_PUBLIC (decl) = 1; 13842 if (library_name) 13843 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); 13844 make_decl_rtl (decl, NULL_PTR, 1); 13845 pushdecl (decl); 13846 if (function_code != NOT_BUILT_IN) 13847 { 13848 DECL_BUILT_IN (decl) = 1; 13849 DECL_FUNCTION_CODE (decl) = function_code; 13850 } 13851 13852 return decl; 13853} 13854 13855/* Handle when a new declaration NEWDECL 13856 has the same name as an old one OLDDECL 13857 in the same binding contour. 13858 Prints an error message if appropriate. 13859 13860 If safely possible, alter OLDDECL to look like NEWDECL, and return 1. 13861 Otherwise, return 0. */ 13862 13863static int 13864duplicate_decls (tree newdecl, tree olddecl) 13865{ 13866 int types_match = 1; 13867 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL 13868 && DECL_INITIAL (newdecl) != 0); 13869 tree oldtype = TREE_TYPE (olddecl); 13870 tree newtype = TREE_TYPE (newdecl); 13871 13872 if (olddecl == newdecl) 13873 return 1; 13874 13875 if (TREE_CODE (newtype) == ERROR_MARK 13876 || TREE_CODE (oldtype) == ERROR_MARK) 13877 types_match = 0; 13878 13879 /* New decl is completely inconsistent with the old one => 13880 tell caller to replace the old one. 13881 This is always an error except in the case of shadowing a builtin. */ 13882 if (TREE_CODE (olddecl) != TREE_CODE (newdecl)) 13883 return 0; 13884 13885 /* For real parm decl following a forward decl, 13886 return 1 so old decl will be reused. */ 13887 if (types_match && TREE_CODE (newdecl) == PARM_DECL 13888 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl)) 13889 return 1; 13890 13891 /* The new declaration is the same kind of object as the old one. 13892 The declarations may partially match. Print warnings if they don't 13893 match enough. Ultimately, copy most of the information from the new 13894 decl to the old one, and keep using the old one. */ 13895 13896 if (TREE_CODE (olddecl) == FUNCTION_DECL 13897 && DECL_BUILT_IN (olddecl)) 13898 { 13899 /* A function declaration for a built-in function. */ 13900 if (!TREE_PUBLIC (newdecl)) 13901 return 0; 13902 else if (!types_match) 13903 { 13904 /* Accept the return type of the new declaration if same modes. */ 13905 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl)); 13906 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl)); 13907 13908 /* Make sure we put the new type in the same obstack as the old ones. 13909 If the old types are not both in the same obstack, use the 13910 permanent one. */ 13911 if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) 13912 push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); 13913 else 13914 { 13915 push_obstacks_nochange (); 13916 end_temporary_allocation (); 13917 } 13918 13919 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype)) 13920 { 13921 /* Function types may be shared, so we can't just modify 13922 the return type of olddecl's function type. */ 13923 tree newtype 13924 = build_function_type (newreturntype, 13925 TYPE_ARG_TYPES (TREE_TYPE (olddecl))); 13926 13927 types_match = 1; 13928 if (types_match) 13929 TREE_TYPE (olddecl) = newtype; 13930 } 13931 13932 pop_obstacks (); 13933 } 13934 if (!types_match) 13935 return 0; 13936 } 13937 else if (TREE_CODE (olddecl) == FUNCTION_DECL 13938 && DECL_SOURCE_LINE (olddecl) == 0) 13939 { 13940 /* A function declaration for a predeclared function 13941 that isn't actually built in. */ 13942 if (!TREE_PUBLIC (newdecl)) 13943 return 0; 13944 else if (!types_match) 13945 { 13946 /* If the types don't match, preserve volatility indication. 13947 Later on, we will discard everything else about the 13948 default declaration. */ 13949 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); 13950 } 13951 } 13952 13953 /* Copy all the DECL_... slots specified in the new decl 13954 except for any that we copy here from the old type. 13955 13956 Past this point, we don't change OLDTYPE and NEWTYPE 13957 even if we change the types of NEWDECL and OLDDECL. */ 13958 13959 if (types_match) 13960 { 13961 /* Make sure we put the new type in the same obstack as the old ones. 13962 If the old types are not both in the same obstack, use the permanent 13963 one. */ 13964 if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) 13965 push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); 13966 else 13967 { 13968 push_obstacks_nochange (); 13969 end_temporary_allocation (); 13970 } 13971 13972 /* Merge the data types specified in the two decls. */ 13973 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl)) 13974 TREE_TYPE (newdecl) 13975 = TREE_TYPE (olddecl) 13976 = TREE_TYPE (newdecl); 13977 13978 /* Lay the type out, unless already done. */ 13979 if (oldtype != TREE_TYPE (newdecl)) 13980 { 13981 if (TREE_TYPE (newdecl) != error_mark_node) 13982 layout_type (TREE_TYPE (newdecl)); 13983 if (TREE_CODE (newdecl) != FUNCTION_DECL 13984 && TREE_CODE (newdecl) != TYPE_DECL 13985 && TREE_CODE (newdecl) != CONST_DECL) 13986 layout_decl (newdecl, 0); 13987 } 13988 else 13989 { 13990 /* Since the type is OLDDECL's, make OLDDECL's size go with. */ 13991 DECL_SIZE (newdecl) = DECL_SIZE (olddecl); 13992 if (TREE_CODE (olddecl) != FUNCTION_DECL) 13993 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) 13994 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); 13995 } 13996 13997 /* Keep the old rtl since we can safely use it. */ 13998 DECL_RTL (newdecl) = DECL_RTL (olddecl); 13999 14000 /* Merge the type qualifiers. */ 14001 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl) 14002 && !TREE_THIS_VOLATILE (newdecl)) 14003 TREE_THIS_VOLATILE (olddecl) = 0; 14004 if (TREE_READONLY (newdecl)) 14005 TREE_READONLY (olddecl) = 1; 14006 if (TREE_THIS_VOLATILE (newdecl)) 14007 { 14008 TREE_THIS_VOLATILE (olddecl) = 1; 14009 if (TREE_CODE (newdecl) == VAR_DECL) 14010 make_var_volatile (newdecl); 14011 } 14012 14013 /* Keep source location of definition rather than declaration. 14014 Likewise, keep decl at outer scope. */ 14015 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0) 14016 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0)) 14017 { 14018 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl); 14019 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl); 14020 14021 if (DECL_CONTEXT (olddecl) == 0 14022 && TREE_CODE (newdecl) != FUNCTION_DECL) 14023 DECL_CONTEXT (newdecl) = 0; 14024 } 14025 14026 /* Merge the unused-warning information. */ 14027 if (DECL_IN_SYSTEM_HEADER (olddecl)) 14028 DECL_IN_SYSTEM_HEADER (newdecl) = 1; 14029 else if (DECL_IN_SYSTEM_HEADER (newdecl)) 14030 DECL_IN_SYSTEM_HEADER (olddecl) = 1; 14031 14032 /* Merge the initialization information. */ 14033 if (DECL_INITIAL (newdecl) == 0) 14034 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); 14035 14036 /* Merge the section attribute. 14037 We want to issue an error if the sections conflict but that must be 14038 done later in decl_attributes since we are called before attributes 14039 are assigned. */ 14040 if (DECL_SECTION_NAME (newdecl) == NULL_TREE) 14041 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl); 14042 14043#if BUILT_FOR_270 14044 if (TREE_CODE (newdecl) == FUNCTION_DECL) 14045 { 14046 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); 14047 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); 14048 } 14049#endif 14050 14051 pop_obstacks (); 14052 } 14053 /* If cannot merge, then use the new type and qualifiers, 14054 and don't preserve the old rtl. */ 14055 else 14056 { 14057 TREE_TYPE (olddecl) = TREE_TYPE (newdecl); 14058 TREE_READONLY (olddecl) = TREE_READONLY (newdecl); 14059 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl); 14060 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl); 14061 } 14062 14063 /* Merge the storage class information. */ 14064 /* For functions, static overrides non-static. */ 14065 if (TREE_CODE (newdecl) == FUNCTION_DECL) 14066 { 14067 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl); 14068 /* This is since we don't automatically 14069 copy the attributes of NEWDECL into OLDDECL. */ 14070 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); 14071 /* If this clears `static', clear it in the identifier too. */ 14072 if (! TREE_PUBLIC (olddecl)) 14073 TREE_PUBLIC (DECL_NAME (olddecl)) = 0; 14074 } 14075 if (DECL_EXTERNAL (newdecl)) 14076 { 14077 TREE_STATIC (newdecl) = TREE_STATIC (olddecl); 14078 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl); 14079 /* An extern decl does not override previous storage class. */ 14080 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); 14081 } 14082 else 14083 { 14084 TREE_STATIC (olddecl) = TREE_STATIC (newdecl); 14085 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); 14086 } 14087 14088 /* If either decl says `inline', this fn is inline, 14089 unless its definition was passed already. */ 14090 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0) 14091 DECL_INLINE (olddecl) = 1; 14092 DECL_INLINE (newdecl) = DECL_INLINE (olddecl); 14093 14094 /* Get rid of any built-in function if new arg types don't match it 14095 or if we have a function definition. */ 14096 if (TREE_CODE (newdecl) == FUNCTION_DECL 14097 && DECL_BUILT_IN (olddecl) 14098 && (!types_match || new_is_definition)) 14099 { 14100 TREE_TYPE (olddecl) = TREE_TYPE (newdecl); 14101 DECL_BUILT_IN (olddecl) = 0; 14102 } 14103 14104 /* If redeclaring a builtin function, and not a definition, 14105 it stays built in. 14106 Also preserve various other info from the definition. */ 14107 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition) 14108 { 14109 if (DECL_BUILT_IN (olddecl)) 14110 { 14111 DECL_BUILT_IN (newdecl) = 1; 14112 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl); 14113 } 14114 else 14115 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl); 14116 14117 DECL_RESULT (newdecl) = DECL_RESULT (olddecl); 14118 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); 14119 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl); 14120 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl); 14121 } 14122 14123 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL. 14124 But preserve olddecl's DECL_UID. */ 14125 { 14126 register unsigned olddecl_uid = DECL_UID (olddecl); 14127 14128 memcpy ((char *) olddecl + sizeof (struct tree_common), 14129 (char *) newdecl + sizeof (struct tree_common), 14130 sizeof (struct tree_decl) - sizeof (struct tree_common)); 14131 DECL_UID (olddecl) = olddecl_uid; 14132 } 14133 14134 return 1; 14135} 14136 14137/* Finish processing of a declaration; 14138 install its initial value. 14139 If the length of an array type is not known before, 14140 it must be determined now, from the initial value, or it is an error. */ 14141 14142static void 14143finish_decl (tree decl, tree init, bool is_top_level) 14144{ 14145 register tree type = TREE_TYPE (decl); 14146 int was_incomplete = (DECL_SIZE (decl) == 0); 14147 int temporary = allocation_temporary_p (); 14148 bool at_top_level = (current_binding_level == global_binding_level); 14149 bool top_level = is_top_level || at_top_level; 14150 14151 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top 14152 level anyway. */ 14153 assert (!is_top_level || !at_top_level); 14154 14155 if (TREE_CODE (decl) == PARM_DECL) 14156 assert (init == NULL_TREE); 14157 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it 14158 overlaps DECL_ARG_TYPE. */ 14159 else if (init == NULL_TREE) 14160 assert (DECL_INITIAL (decl) == NULL_TREE); 14161 else 14162 assert (DECL_INITIAL (decl) == error_mark_node); 14163 14164 if (init != NULL_TREE) 14165 { 14166 if (TREE_CODE (decl) != TYPE_DECL) 14167 DECL_INITIAL (decl) = init; 14168 else 14169 { 14170 /* typedef foo = bar; store the type of bar as the type of foo. */ 14171 TREE_TYPE (decl) = TREE_TYPE (init); 14172 DECL_INITIAL (decl) = init = 0; 14173 } 14174 } 14175 14176 /* Pop back to the obstack that is current for this binding level. This is 14177 because MAXINDEX, rtl, etc. to be made below must go in the permanent 14178 obstack. But don't discard the temporary data yet. */ 14179 pop_obstacks (); 14180 14181 /* Deduce size of array from initialization, if not already known */ 14182 14183 if (TREE_CODE (type) == ARRAY_TYPE 14184 && TYPE_DOMAIN (type) == 0 14185 && TREE_CODE (decl) != TYPE_DECL) 14186 { 14187 assert (top_level); 14188 assert (was_incomplete); 14189 14190 layout_decl (decl, 0); 14191 } 14192 14193 if (TREE_CODE (decl) == VAR_DECL) 14194 { 14195 if (DECL_SIZE (decl) == NULL_TREE 14196 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) 14197 layout_decl (decl, 0); 14198 14199 if (DECL_SIZE (decl) == NULL_TREE 14200 && (TREE_STATIC (decl) 14201 ? 14202 /* A static variable with an incomplete type is an error if it is 14203 initialized. Also if it is not file scope. Otherwise, let it 14204 through, but if it is not `extern' then it may cause an error 14205 message later. */ 14206 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0) 14207 : 14208 /* An automatic variable with an incomplete type is an error. */ 14209 !DECL_EXTERNAL (decl))) 14210 { 14211 assert ("storage size not known" == NULL); 14212 abort (); 14213 } 14214 14215 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) 14216 && (DECL_SIZE (decl) != 0) 14217 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) 14218 { 14219 assert ("storage size not constant" == NULL); 14220 abort (); 14221 } 14222 } 14223 14224 /* Output the assembler code and/or RTL code for variables and functions, 14225 unless the type is an undefined structure or union. If not, it will get 14226 done when the type is completed. */ 14227 14228 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) 14229 { 14230 rest_of_decl_compilation (decl, NULL, 14231 DECL_CONTEXT (decl) == 0, 14232 0); 14233 14234 if (DECL_CONTEXT (decl) != 0) 14235 { 14236 /* Recompute the RTL of a local array now if it used to be an 14237 incomplete type. */ 14238 if (was_incomplete 14239 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) 14240 { 14241 /* If we used it already as memory, it must stay in memory. */ 14242 TREE_ADDRESSABLE (decl) = TREE_USED (decl); 14243 /* If it's still incomplete now, no init will save it. */ 14244 if (DECL_SIZE (decl) == 0) 14245 DECL_INITIAL (decl) = 0; 14246 expand_decl (decl); 14247 } 14248 /* Compute and store the initial value. */ 14249 if (TREE_CODE (decl) != FUNCTION_DECL) 14250 expand_decl_init (decl); 14251 } 14252 } 14253 else if (TREE_CODE (decl) == TYPE_DECL) 14254 { 14255 rest_of_decl_compilation (decl, NULL_PTR, 14256 DECL_CONTEXT (decl) == 0, 14257 0); 14258 } 14259 14260 /* This test used to include TREE_PERMANENT, however, we have the same 14261 problem with initializers at the function level. Such initializers get 14262 saved until the end of the function on the momentary_obstack. */ 14263 if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) 14264 && temporary 14265 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with 14266 DECL_ARG_TYPE. */ 14267 && TREE_CODE (decl) != PARM_DECL) 14268 { 14269 /* We need to remember that this array HAD an initialization, but 14270 discard the actual temporary nodes, since we can't have a permanent 14271 node keep pointing to them. */ 14272 /* We make an exception for inline functions, since it's normal for a 14273 local extern redeclaration of an inline function to have a copy of 14274 the top-level decl's DECL_INLINE. */ 14275 if ((DECL_INITIAL (decl) != 0) 14276 && (DECL_INITIAL (decl) != error_mark_node)) 14277 { 14278 /* If this is a const variable, then preserve the 14279 initializer instead of discarding it so that we can optimize 14280 references to it. */ 14281 /* This test used to include TREE_STATIC, but this won't be set 14282 for function level initializers. */ 14283 if (TREE_READONLY (decl)) 14284 { 14285 preserve_initializer (); 14286 /* Hack? Set the permanent bit for something that is 14287 permanent, but not on the permenent obstack, so as to 14288 convince output_constant_def to make its rtl on the 14289 permanent obstack. */ 14290 TREE_PERMANENT (DECL_INITIAL (decl)) = 1; 14291 14292 /* The initializer and DECL must have the same (or equivalent 14293 types), but if the initializer is a STRING_CST, its type 14294 might not be on the right obstack, so copy the type 14295 of DECL. */ 14296 TREE_TYPE (DECL_INITIAL (decl)) = type; 14297 } 14298 else 14299 DECL_INITIAL (decl) = error_mark_node; 14300 } 14301 } 14302 14303 /* If requested, warn about definitions of large data objects. */ 14304 14305 if (warn_larger_than 14306 && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) 14307 && !DECL_EXTERNAL (decl)) 14308 { 14309 register tree decl_size = DECL_SIZE (decl); 14310 14311 if (decl_size && TREE_CODE (decl_size) == INTEGER_CST) 14312 { 14313 unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT; 14314 14315 if (units > larger_than_size) 14316 warning_with_decl (decl, "size of `%s' is %u bytes", units); 14317 } 14318 } 14319 14320 /* If we have gone back from temporary to permanent allocation, actually 14321 free the temporary space that we no longer need. */ 14322 if (temporary && !allocation_temporary_p ()) 14323 permanent_allocation (0); 14324 14325 /* At the end of a declaration, throw away any variable type sizes of types 14326 defined inside that declaration. There is no use computing them in the 14327 following function definition. */ 14328 if (current_binding_level == global_binding_level) 14329 get_pending_sizes (); 14330} 14331 14332/* Finish up a function declaration and compile that function 14333 all the way to assembler language output. The free the storage 14334 for the function definition. 14335 14336 This is called after parsing the body of the function definition. 14337 14338 NESTED is nonzero if the function being finished is nested in another. */ 14339 14340static void 14341finish_function (int nested) 14342{ 14343 register tree fndecl = current_function_decl; 14344 14345 assert (fndecl != NULL_TREE); 14346 if (TREE_CODE (fndecl) != ERROR_MARK) 14347 { 14348 if (nested) 14349 assert (DECL_CONTEXT (fndecl) != NULL_TREE); 14350 else 14351 assert (DECL_CONTEXT (fndecl) == NULL_TREE); 14352 } 14353 14354/* TREE_READONLY (fndecl) = 1; 14355 This caused &foo to be of type ptr-to-const-function 14356 which then got a warning when stored in a ptr-to-function variable. */ 14357 14358 poplevel (1, 0, 1); 14359 14360 if (TREE_CODE (fndecl) != ERROR_MARK) 14361 { 14362 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; 14363 14364 /* Must mark the RESULT_DECL as being in this function. */ 14365 14366 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; 14367 14368 /* Obey `register' declarations if `setjmp' is called in this fn. */ 14369 /* Generate rtl for function exit. */ 14370 expand_function_end (input_filename, lineno, 0); 14371 14372 /* So we can tell if jump_optimize sets it to 1. */ 14373 can_reach_end = 0; 14374 14375 /* Run the optimizers and output the assembler code for this function. */ 14376 rest_of_compilation (fndecl); 14377 } 14378 14379 /* Free all the tree nodes making up this function. */ 14380 /* Switch back to allocating nodes permanently until we start another 14381 function. */ 14382 if (!nested) 14383 permanent_allocation (1); 14384 14385 if (TREE_CODE (fndecl) != ERROR_MARK 14386 && !nested 14387 && DECL_SAVED_INSNS (fndecl) == 0) 14388 { 14389 /* Stop pointing to the local nodes about to be freed. */ 14390 /* But DECL_INITIAL must remain nonzero so we know this was an actual 14391 function definition. */ 14392 /* For a nested function, this is done in pop_f_function_context. */ 14393 /* If rest_of_compilation set this to 0, leave it 0. */ 14394 if (DECL_INITIAL (fndecl) != 0) 14395 DECL_INITIAL (fndecl) = error_mark_node; 14396 DECL_ARGUMENTS (fndecl) = 0; 14397 } 14398 14399 if (!nested) 14400 { 14401 /* Let the error reporting routines know that we're outside a function. 14402 For a nested function, this value is used in pop_c_function_context 14403 and then reset via pop_function_context. */ 14404 ffecom_outer_function_decl_ = current_function_decl = NULL; 14405 } 14406} 14407 14408/* Plug-in replacement for identifying the name of a decl and, for a 14409 function, what we call it in diagnostics. For now, "program unit" 14410 should suffice, since it's a bit of a hassle to figure out which 14411 of several kinds of things it is. Note that it could conceivably 14412 be a statement function, which probably isn't really a program unit 14413 per se, but if that comes up, it should be easy to check (being a 14414 nested function and all). */ 14415 14416static char * 14417lang_printable_name (tree decl, int v) 14418{ 14419 /* Just to keep GCC quiet about the unused variable. 14420 In theory, differing values of V should produce different 14421 output. */ 14422 switch (v) 14423 { 14424 default: 14425 if (TREE_CODE (decl) == ERROR_MARK) 14426 return "erroneous code"; 14427 return IDENTIFIER_POINTER (DECL_NAME (decl)); 14428 } 14429} 14430 14431/* g77's function to print out name of current function that caused 14432 an error. */ 14433 14434#if BUILT_FOR_270 14435void 14436lang_print_error_function (file) 14437 char *file; 14438{ 14439 static ffeglobal last_g = NULL; 14440 static ffesymbol last_s = NULL; 14441 ffeglobal g; 14442 ffesymbol s; 14443 const char *kind; 14444 14445 if ((ffecom_primary_entry_ == NULL) 14446 || (ffesymbol_global (ffecom_primary_entry_) == NULL)) 14447 { 14448 g = NULL; 14449 s = NULL; 14450 kind = NULL; 14451 } 14452 else 14453 { 14454 g = ffesymbol_global (ffecom_primary_entry_); 14455 if (ffecom_nested_entry_ == NULL) 14456 { 14457 s = ffecom_primary_entry_; 14458 switch (ffesymbol_kind (s)) 14459 { 14460 case FFEINFO_kindFUNCTION: 14461 kind = "function"; 14462 break; 14463 14464 case FFEINFO_kindSUBROUTINE: 14465 kind = "subroutine"; 14466 break; 14467 14468 case FFEINFO_kindPROGRAM: 14469 kind = "program"; 14470 break; 14471 14472 case FFEINFO_kindBLOCKDATA: 14473 kind = "block-data"; 14474 break; 14475 14476 default: 14477 kind = ffeinfo_kind_message (ffesymbol_kind (s)); 14478 break; 14479 } 14480 } 14481 else 14482 { 14483 s = ffecom_nested_entry_; 14484 kind = "statement function"; 14485 } 14486 } 14487 14488 if ((last_g != g) || (last_s != s)) 14489 { 14490 if (file) 14491 fprintf (stderr, "%s: ", file); 14492 14493 if (s == NULL) 14494 fprintf (stderr, "Outside of any program unit:\n"); 14495 else 14496 { 14497 const char *name = ffesymbol_text (s); 14498 14499 fprintf (stderr, "In %s `%s':\n", kind, name); 14500 } 14501 14502 last_g = g; 14503 last_s = s; 14504 } 14505} 14506#endif 14507 14508/* Similar to `lookup_name' but look only at current binding level. */ 14509 14510static tree 14511lookup_name_current_level (tree name) 14512{ 14513 register tree t; 14514 14515 if (current_binding_level == global_binding_level) 14516 return IDENTIFIER_GLOBAL_VALUE (name); 14517 14518 if (IDENTIFIER_LOCAL_VALUE (name) == 0) 14519 return 0; 14520 14521 for (t = current_binding_level->names; t; t = TREE_CHAIN (t)) 14522 if (DECL_NAME (t) == name) 14523 break; 14524 14525 return t; 14526} 14527 14528/* Create a new `struct binding_level'. */ 14529 14530static struct binding_level * 14531make_binding_level () 14532{ 14533 /* NOSTRICT */ 14534 return (struct binding_level *) xmalloc (sizeof (struct binding_level)); 14535} 14536 14537/* Save and restore the variables in this file and elsewhere 14538 that keep track of the progress of compilation of the current function. 14539 Used for nested functions. */ 14540 14541struct f_function 14542{ 14543 struct f_function *next; 14544 tree named_labels; 14545 tree shadowed_labels; 14546 struct binding_level *binding_level; 14547}; 14548 14549struct f_function *f_function_chain; 14550 14551/* Restore the variables used during compilation of a C function. */ 14552 14553static void 14554pop_f_function_context () 14555{ 14556 struct f_function *p = f_function_chain; 14557 tree link; 14558 14559 /* Bring back all the labels that were shadowed. */ 14560 for (link = shadowed_labels; link; link = TREE_CHAIN (link)) 14561 if (DECL_NAME (TREE_VALUE (link)) != 0) 14562 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) 14563 = TREE_VALUE (link); 14564 14565 if (current_function_decl != error_mark_node 14566 && DECL_SAVED_INSNS (current_function_decl) == 0) 14567 { 14568 /* Stop pointing to the local nodes about to be freed. */ 14569 /* But DECL_INITIAL must remain nonzero so we know this was an actual 14570 function definition. */ 14571 DECL_INITIAL (current_function_decl) = error_mark_node; 14572 DECL_ARGUMENTS (current_function_decl) = 0; 14573 } 14574 14575 pop_function_context (); 14576 14577 f_function_chain = p->next; 14578 14579 named_labels = p->named_labels; 14580 shadowed_labels = p->shadowed_labels; 14581 current_binding_level = p->binding_level; 14582 14583 free (p); 14584} 14585 14586/* Save and reinitialize the variables 14587 used during compilation of a C function. */ 14588 14589static void 14590push_f_function_context () 14591{ 14592 struct f_function *p 14593 = (struct f_function *) xmalloc (sizeof (struct f_function)); 14594 14595 push_function_context (); 14596 14597 p->next = f_function_chain; 14598 f_function_chain = p; 14599 14600 p->named_labels = named_labels; 14601 p->shadowed_labels = shadowed_labels; 14602 p->binding_level = current_binding_level; 14603} 14604 14605static void 14606push_parm_decl (tree parm) 14607{ 14608 int old_immediate_size_expand = immediate_size_expand; 14609 14610 /* Don't try computing parm sizes now -- wait till fn is called. */ 14611 14612 immediate_size_expand = 0; 14613 14614 push_obstacks_nochange (); 14615 14616 /* Fill in arg stuff. */ 14617 14618 DECL_ARG_TYPE (parm) = TREE_TYPE (parm); 14619 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm); 14620 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */ 14621 14622 parm = pushdecl (parm); 14623 14624 immediate_size_expand = old_immediate_size_expand; 14625 14626 finish_decl (parm, NULL_TREE, FALSE); 14627} 14628 14629/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */ 14630 14631static tree 14632pushdecl_top_level (x) 14633 tree x; 14634{ 14635 register tree t; 14636 register struct binding_level *b = current_binding_level; 14637 register tree f = current_function_decl; 14638 14639 current_binding_level = global_binding_level; 14640 current_function_decl = NULL_TREE; 14641 t = pushdecl (x); 14642 current_binding_level = b; 14643 current_function_decl = f; 14644 return t; 14645} 14646 14647/* Store the list of declarations of the current level. 14648 This is done for the parameter declarations of a function being defined, 14649 after they are modified in the light of any missing parameters. */ 14650 14651static tree 14652storedecls (decls) 14653 tree decls; 14654{ 14655 return current_binding_level->names = decls; 14656} 14657 14658/* Store the parameter declarations into the current function declaration. 14659 This is called after parsing the parameter declarations, before 14660 digesting the body of the function. 14661 14662 For an old-style definition, modify the function's type 14663 to specify at least the number of arguments. */ 14664 14665static void 14666store_parm_decls (int is_main_program UNUSED) 14667{ 14668 register tree fndecl = current_function_decl; 14669 14670 if (fndecl == error_mark_node) 14671 return; 14672 14673 /* This is a chain of PARM_DECLs from old-style parm declarations. */ 14674 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ())); 14675 14676 /* Initialize the RTL code for the function. */ 14677 14678 init_function_start (fndecl, input_filename, lineno); 14679 14680 /* Set up parameters and prepare for return, for the function. */ 14681 14682 expand_function_start (fndecl, 0); 14683} 14684 14685static tree 14686start_decl (tree decl, bool is_top_level) 14687{ 14688 register tree tem; 14689 bool at_top_level = (current_binding_level == global_binding_level); 14690 bool top_level = is_top_level || at_top_level; 14691 14692 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top 14693 level anyway. */ 14694 assert (!is_top_level || !at_top_level); 14695 14696 /* The corresponding pop_obstacks is in finish_decl. */ 14697 push_obstacks_nochange (); 14698 14699 if (DECL_INITIAL (decl) != NULL_TREE) 14700 { 14701 assert (DECL_INITIAL (decl) == error_mark_node); 14702 assert (!DECL_EXTERNAL (decl)); 14703 } 14704 else if (top_level) 14705 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1); 14706 14707 /* For Fortran, we by default put things in .common when possible. */ 14708 DECL_COMMON (decl) = 1; 14709 14710 /* Add this decl to the current binding level. TEM may equal DECL or it may 14711 be a previous decl of the same name. */ 14712 if (is_top_level) 14713 tem = pushdecl_top_level (decl); 14714 else 14715 tem = pushdecl (decl); 14716 14717 /* For a local variable, define the RTL now. */ 14718 if (!top_level 14719 /* But not if this is a duplicate decl and we preserved the rtl from the 14720 previous one (which may or may not happen). */ 14721 && DECL_RTL (tem) == 0) 14722 { 14723 if (TYPE_SIZE (TREE_TYPE (tem)) != 0) 14724 expand_decl (tem); 14725 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE 14726 && DECL_INITIAL (tem) != 0) 14727 expand_decl (tem); 14728 } 14729 14730 if (DECL_INITIAL (tem) != NULL_TREE) 14731 { 14732 /* When parsing and digesting the initializer, use temporary storage. 14733 Do this even if we will ignore the value. */ 14734 if (at_top_level) 14735 temporary_allocation (); 14736 } 14737 14738 return tem; 14739} 14740 14741/* Create the FUNCTION_DECL for a function definition. 14742 DECLSPECS and DECLARATOR are the parts of the declaration; 14743 they describe the function's name and the type it returns, 14744 but twisted together in a fashion that parallels the syntax of C. 14745 14746 This function creates a binding context for the function body 14747 as well as setting up the FUNCTION_DECL in current_function_decl. 14748 14749 Returns 1 on success. If the DECLARATOR is not suitable for a function 14750 (it defines a datum instead), we return 0, which tells 14751 yyparse to report a parse error. 14752 14753 NESTED is nonzero for a function nested within another function. */ 14754 14755static void 14756start_function (tree name, tree type, int nested, int public) 14757{ 14758 tree decl1; 14759 tree restype; 14760 int old_immediate_size_expand = immediate_size_expand; 14761 14762 named_labels = 0; 14763 shadowed_labels = 0; 14764 14765 /* Don't expand any sizes in the return type of the function. */ 14766 immediate_size_expand = 0; 14767 14768 if (nested) 14769 { 14770 assert (!public); 14771 assert (current_function_decl != NULL_TREE); 14772 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE); 14773 } 14774 else 14775 { 14776 assert (current_function_decl == NULL_TREE); 14777 } 14778 14779 if (TREE_CODE (type) == ERROR_MARK) 14780 decl1 = current_function_decl = error_mark_node; 14781 else 14782 { 14783 decl1 = build_decl (FUNCTION_DECL, 14784 name, 14785 type); 14786 TREE_PUBLIC (decl1) = public ? 1 : 0; 14787 if (nested) 14788 DECL_INLINE (decl1) = 1; 14789 TREE_STATIC (decl1) = 1; 14790 DECL_EXTERNAL (decl1) = 0; 14791 14792 announce_function (decl1); 14793 14794 /* Make the init_value nonzero so pushdecl knows this is not tentative. 14795 error_mark_node is replaced below (in poplevel) with the BLOCK. */ 14796 DECL_INITIAL (decl1) = error_mark_node; 14797 14798 /* Record the decl so that the function name is defined. If we already have 14799 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */ 14800 14801 current_function_decl = pushdecl (decl1); 14802 } 14803 14804 if (!nested) 14805 ffecom_outer_function_decl_ = current_function_decl; 14806 14807 pushlevel (0); 14808 current_binding_level->prep_state = 2; 14809 14810 if (TREE_CODE (current_function_decl) != ERROR_MARK) 14811 { 14812 make_function_rtl (current_function_decl); 14813 14814 restype = TREE_TYPE (TREE_TYPE (current_function_decl)); 14815 DECL_RESULT (current_function_decl) 14816 = build_decl (RESULT_DECL, NULL_TREE, restype); 14817 } 14818 14819 if (!nested) 14820 /* Allocate further tree nodes temporarily during compilation of this 14821 function only. */ 14822 temporary_allocation (); 14823 14824 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK)) 14825 TREE_ADDRESSABLE (current_function_decl) = 1; 14826 14827 immediate_size_expand = old_immediate_size_expand; 14828} 14829 14830/* Here are the public functions the GNU back end needs. */ 14831 14832tree 14833convert (type, expr) 14834 tree type, expr; 14835{ 14836 register tree e = expr; 14837 register enum tree_code code = TREE_CODE (type); 14838 14839 if (type == TREE_TYPE (e) 14840 || TREE_CODE (e) == ERROR_MARK) 14841 return e; 14842 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) 14843 return fold (build1 (NOP_EXPR, type, e)); 14844 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK 14845 || code == ERROR_MARK) 14846 return error_mark_node; 14847 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) 14848 { 14849 assert ("void value not ignored as it ought to be" == NULL); 14850 return error_mark_node; 14851 } 14852 if (code == VOID_TYPE) 14853 return build1 (CONVERT_EXPR, type, e); 14854 if ((code != RECORD_TYPE) 14855 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) 14856 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))), 14857 e); 14858 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) 14859 return fold (convert_to_integer (type, e)); 14860 if (code == POINTER_TYPE) 14861 return fold (convert_to_pointer (type, e)); 14862 if (code == REAL_TYPE) 14863 return fold (convert_to_real (type, e)); 14864 if (code == COMPLEX_TYPE) 14865 return fold (convert_to_complex (type, e)); 14866 if (code == RECORD_TYPE) 14867 return fold (ffecom_convert_to_complex_ (type, e)); 14868 14869 assert ("conversion to non-scalar type requested" == NULL); 14870 return error_mark_node; 14871} 14872 14873/* integrate_decl_tree calls this function, but since we don't use the 14874 DECL_LANG_SPECIFIC field, this is a no-op. */ 14875 14876void 14877copy_lang_decl (node) 14878 tree node UNUSED; 14879{ 14880} 14881 14882/* Return the list of declarations of the current level. 14883 Note that this list is in reverse order unless/until 14884 you nreverse it; and when you do nreverse it, you must 14885 store the result back using `storedecls' or you will lose. */ 14886 14887tree 14888getdecls () 14889{ 14890 return current_binding_level->names; 14891} 14892 14893/* Nonzero if we are currently in the global binding level. */ 14894 14895int 14896global_bindings_p () 14897{ 14898 return current_binding_level == global_binding_level; 14899} 14900 14901/* Print an error message for invalid use of an incomplete type. 14902 VALUE is the expression that was used (or 0 if that isn't known) 14903 and TYPE is the type that was invalid. */ 14904 14905void 14906incomplete_type_error (value, type) 14907 tree value UNUSED; 14908 tree type; 14909{ 14910 if (TREE_CODE (type) == ERROR_MARK) 14911 return; 14912 14913 assert ("incomplete type?!?" == NULL); 14914} 14915 14916void 14917init_decl_processing () 14918{ 14919 malloc_init (); 14920 ffe_init_0 (); 14921} 14922 14923char * 14924init_parse (filename) 14925 char *filename; 14926{ 14927#if BUILT_FOR_270 14928 extern void (*print_error_function) (char *); 14929#endif 14930 14931 /* Open input file. */ 14932 if (filename == 0 || !strcmp (filename, "-")) 14933 { 14934 finput = stdin; 14935 filename = "stdin"; 14936 } 14937 else 14938 finput = fopen (filename, "r"); 14939 if (finput == 0) 14940 pfatal_with_name (filename); 14941 14942#ifdef IO_BUFFER_SIZE 14943 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); 14944#endif 14945 14946 /* Make identifier nodes long enough for the language-specific slots. */ 14947 set_identifier_size (sizeof (struct lang_identifier)); 14948 decl_printable_name = lang_printable_name; 14949#if BUILT_FOR_270 14950 print_error_function = lang_print_error_function; 14951#endif 14952 14953 return filename; 14954} 14955 14956void 14957finish_parse () 14958{ 14959 fclose (finput); 14960} 14961 14962/* Delete the node BLOCK from the current binding level. 14963 This is used for the block inside a stmt expr ({...}) 14964 so that the block can be reinserted where appropriate. */ 14965 14966static void 14967delete_block (block) 14968 tree block; 14969{ 14970 tree t; 14971 if (current_binding_level->blocks == block) 14972 current_binding_level->blocks = TREE_CHAIN (block); 14973 for (t = current_binding_level->blocks; t;) 14974 { 14975 if (TREE_CHAIN (t) == block) 14976 TREE_CHAIN (t) = TREE_CHAIN (block); 14977 else 14978 t = TREE_CHAIN (t); 14979 } 14980 TREE_CHAIN (block) = NULL; 14981 /* Clear TREE_USED which is always set by poplevel. 14982 The flag is set again if insert_block is called. */ 14983 TREE_USED (block) = 0; 14984} 14985 14986void 14987insert_block (block) 14988 tree block; 14989{ 14990 TREE_USED (block) = 1; 14991 current_binding_level->blocks 14992 = chainon (current_binding_level->blocks, block); 14993} 14994 14995int 14996lang_decode_option (argc, argv) 14997 int argc; 14998 char **argv; 14999{ 15000 return ffe_decode_option (argc, argv); 15001} 15002 15003/* used by print-tree.c */ 15004 15005void 15006lang_print_xnode (file, node, indent) 15007 FILE *file UNUSED; 15008 tree node UNUSED; 15009 int indent UNUSED; 15010{ 15011} 15012 15013void 15014lang_finish () 15015{ 15016 ffe_terminate_0 (); 15017 15018 if (ffe_is_ffedebug ()) 15019 malloc_pool_display (malloc_pool_image ()); 15020} 15021 15022char * 15023lang_identify () 15024{ 15025 return "f77"; 15026} 15027 15028void 15029lang_init_options () 15030{ 15031 /* Set default options for Fortran. */ 15032 flag_move_all_movables = 1; 15033 flag_reduce_all_givs = 1; 15034 flag_argument_noalias = 2; 15035 flag_errno_math = 0; 15036 flag_complex_divide_method = 1; 15037} 15038 15039void 15040lang_init () 15041{ 15042 /* If the file is output from cpp, it should contain a first line 15043 `# 1 "real-filename"', and the current design of gcc (toplev.c 15044 in particular and the way it sets up information relied on by 15045 INCLUDE) requires that we read this now, and store the 15046 "real-filename" info in master_input_filename. Ask the lexer 15047 to try doing this. */ 15048 ffelex_hash_kludge (finput); 15049} 15050 15051int 15052mark_addressable (exp) 15053 tree exp; 15054{ 15055 register tree x = exp; 15056 while (1) 15057 switch (TREE_CODE (x)) 15058 { 15059 case ADDR_EXPR: 15060 case COMPONENT_REF: 15061 case ARRAY_REF: 15062 x = TREE_OPERAND (x, 0); 15063 break; 15064 15065 case CONSTRUCTOR: 15066 TREE_ADDRESSABLE (x) = 1; 15067 return 1; 15068 15069 case VAR_DECL: 15070 case CONST_DECL: 15071 case PARM_DECL: 15072 case RESULT_DECL: 15073 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) 15074 && DECL_NONLOCAL (x)) 15075 { 15076 if (TREE_PUBLIC (x)) 15077 { 15078 assert ("address of global register var requested" == NULL); 15079 return 0; 15080 } 15081 assert ("address of register variable requested" == NULL); 15082 } 15083 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) 15084 { 15085 if (TREE_PUBLIC (x)) 15086 { 15087 assert ("address of global register var requested" == NULL); 15088 return 0; 15089 } 15090 assert ("address of register var requested" == NULL); 15091 } 15092 put_var_into_stack (x); 15093 15094 /* drops in */ 15095 case FUNCTION_DECL: 15096 TREE_ADDRESSABLE (x) = 1; 15097#if 0 /* poplevel deals with this now. */ 15098 if (DECL_CONTEXT (x) == 0) 15099 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; 15100#endif 15101 15102 default: 15103 return 1; 15104 } 15105} 15106 15107/* If DECL has a cleanup, build and return that cleanup here. 15108 This is a callback called by expand_expr. */ 15109 15110tree 15111maybe_build_cleanup (decl) 15112 tree decl UNUSED; 15113{ 15114 /* There are no cleanups in Fortran. */ 15115 return NULL_TREE; 15116} 15117 15118/* Exit a binding level. 15119 Pop the level off, and restore the state of the identifier-decl mappings 15120 that were in effect when this level was entered. 15121 15122 If KEEP is nonzero, this level had explicit declarations, so 15123 and create a "block" (a BLOCK node) for the level 15124 to record its declarations and subblocks for symbol table output. 15125 15126 If FUNCTIONBODY is nonzero, this level is the body of a function, 15127 so create a block as if KEEP were set and also clear out all 15128 label names. 15129 15130 If REVERSE is nonzero, reverse the order of decls before putting 15131 them into the BLOCK. */ 15132 15133tree 15134poplevel (keep, reverse, functionbody) 15135 int keep; 15136 int reverse; 15137 int functionbody; 15138{ 15139 register tree link; 15140 /* The chain of decls was accumulated in reverse order. 15141 Put it into forward order, just for cleanliness. */ 15142 tree decls; 15143 tree subblocks = current_binding_level->blocks; 15144 tree block = 0; 15145 tree decl; 15146 int block_previously_created; 15147 15148 /* Get the decls in the order they were written. 15149 Usually current_binding_level->names is in reverse order. 15150 But parameter decls were previously put in forward order. */ 15151 15152 if (reverse) 15153 current_binding_level->names 15154 = decls = nreverse (current_binding_level->names); 15155 else 15156 decls = current_binding_level->names; 15157 15158 /* Output any nested inline functions within this block 15159 if they weren't already output. */ 15160 15161 for (decl = decls; decl; decl = TREE_CHAIN (decl)) 15162 if (TREE_CODE (decl) == FUNCTION_DECL 15163 && ! TREE_ASM_WRITTEN (decl) 15164 && DECL_INITIAL (decl) != 0 15165 && TREE_ADDRESSABLE (decl)) 15166 { 15167 /* If this decl was copied from a file-scope decl 15168 on account of a block-scope extern decl, 15169 propagate TREE_ADDRESSABLE to the file-scope decl. 15170 15171 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is 15172 true, since then the decl goes through save_for_inline_copying. */ 15173 if (DECL_ABSTRACT_ORIGIN (decl) != 0 15174 && DECL_ABSTRACT_ORIGIN (decl) != decl) 15175 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; 15176 else if (DECL_SAVED_INSNS (decl) != 0) 15177 { 15178 push_function_context (); 15179 output_inline_function (decl); 15180 pop_function_context (); 15181 } 15182 } 15183 15184 /* If there were any declarations or structure tags in that level, 15185 or if this level is a function body, 15186 create a BLOCK to record them for the life of this function. */ 15187 15188 block = 0; 15189 block_previously_created = (current_binding_level->this_block != 0); 15190 if (block_previously_created) 15191 block = current_binding_level->this_block; 15192 else if (keep || functionbody) 15193 block = make_node (BLOCK); 15194 if (block != 0) 15195 { 15196 BLOCK_VARS (block) = decls; 15197 BLOCK_SUBBLOCKS (block) = subblocks; 15198 remember_end_note (block); 15199 } 15200 15201 /* In each subblock, record that this is its superior. */ 15202 15203 for (link = subblocks; link; link = TREE_CHAIN (link)) 15204 BLOCK_SUPERCONTEXT (link) = block; 15205 15206 /* Clear out the meanings of the local variables of this level. */ 15207 15208 for (link = decls; link; link = TREE_CHAIN (link)) 15209 { 15210 if (DECL_NAME (link) != 0) 15211 { 15212 /* If the ident. was used or addressed via a local extern decl, 15213 don't forget that fact. */ 15214 if (DECL_EXTERNAL (link)) 15215 { 15216 if (TREE_USED (link)) 15217 TREE_USED (DECL_NAME (link)) = 1; 15218 if (TREE_ADDRESSABLE (link)) 15219 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1; 15220 } 15221 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0; 15222 } 15223 } 15224 15225 /* If the level being exited is the top level of a function, 15226 check over all the labels, and clear out the current 15227 (function local) meanings of their names. */ 15228 15229 if (functionbody) 15230 { 15231 /* If this is the top level block of a function, 15232 the vars are the function's parameters. 15233 Don't leave them in the BLOCK because they are 15234 found in the FUNCTION_DECL instead. */ 15235 15236 BLOCK_VARS (block) = 0; 15237 } 15238 15239 /* Pop the current level, and free the structure for reuse. */ 15240 15241 { 15242 register struct binding_level *level = current_binding_level; 15243 current_binding_level = current_binding_level->level_chain; 15244 15245 level->level_chain = free_binding_level; 15246 free_binding_level = level; 15247 } 15248 15249 /* Dispose of the block that we just made inside some higher level. */ 15250 if (functionbody 15251 && current_function_decl != error_mark_node) 15252 DECL_INITIAL (current_function_decl) = block; 15253 else if (block) 15254 { 15255 if (!block_previously_created) 15256 current_binding_level->blocks 15257 = chainon (current_binding_level->blocks, block); 15258 } 15259 /* If we did not make a block for the level just exited, 15260 any blocks made for inner levels 15261 (since they cannot be recorded as subblocks in that level) 15262 must be carried forward so they will later become subblocks 15263 of something else. */ 15264 else if (subblocks) 15265 current_binding_level->blocks 15266 = chainon (current_binding_level->blocks, subblocks); 15267 15268 if (block) 15269 TREE_USED (block) = 1; 15270 return block; 15271} 15272 15273void 15274print_lang_decl (file, node, indent) 15275 FILE *file UNUSED; 15276 tree node UNUSED; 15277 int indent UNUSED; 15278{ 15279} 15280 15281void 15282print_lang_identifier (file, node, indent) 15283 FILE *file; 15284 tree node; 15285 int indent; 15286{ 15287 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4); 15288 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); 15289} 15290 15291void 15292print_lang_statistics () 15293{ 15294} 15295 15296void 15297print_lang_type (file, node, indent) 15298 FILE *file UNUSED; 15299 tree node UNUSED; 15300 int indent UNUSED; 15301{ 15302} 15303 15304/* Record a decl-node X as belonging to the current lexical scope. 15305 Check for errors (such as an incompatible declaration for the same 15306 name already seen in the same scope). 15307 15308 Returns either X or an old decl for the same name. 15309 If an old decl is returned, it may have been smashed 15310 to agree with what X says. */ 15311 15312tree 15313pushdecl (x) 15314 tree x; 15315{ 15316 register tree t; 15317 register tree name = DECL_NAME (x); 15318 register struct binding_level *b = current_binding_level; 15319 15320 if ((TREE_CODE (x) == FUNCTION_DECL) 15321 && (DECL_INITIAL (x) == 0) 15322 && DECL_EXTERNAL (x)) 15323 DECL_CONTEXT (x) = NULL_TREE; 15324 else 15325 DECL_CONTEXT (x) = current_function_decl; 15326 15327 if (name) 15328 { 15329 if (IDENTIFIER_INVENTED (name)) 15330 { 15331#if BUILT_FOR_270 15332 DECL_ARTIFICIAL (x) = 1; 15333#endif 15334 DECL_IN_SYSTEM_HEADER (x) = 1; 15335 } 15336 15337 t = lookup_name_current_level (name); 15338 15339 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE)); 15340 15341 /* Don't push non-parms onto list for parms until we understand 15342 why we're doing this and whether it works. */ 15343 15344 assert ((b == global_binding_level) 15345 || !ffecom_transform_only_dummies_ 15346 || TREE_CODE (x) == PARM_DECL); 15347 15348 if ((t != NULL_TREE) && duplicate_decls (x, t)) 15349 return t; 15350 15351 /* If we are processing a typedef statement, generate a whole new 15352 ..._TYPE node (which will be just an variant of the existing 15353 ..._TYPE node with identical properties) and then install the 15354 TYPE_DECL node generated to represent the typedef name as the 15355 TYPE_NAME of this brand new (duplicate) ..._TYPE node. 15356 15357 The whole point here is to end up with a situation where each and every 15358 ..._TYPE node the compiler creates will be uniquely associated with 15359 AT MOST one node representing a typedef name. This way, even though 15360 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL 15361 (i.e. "typedef name") nodes very early on, later parts of the 15362 compiler can always do the reverse translation and get back the 15363 corresponding typedef name. For example, given: 15364 15365 typedef struct S MY_TYPE; MY_TYPE object; 15366 15367 Later parts of the compiler might only know that `object' was of type 15368 `struct S' if it were not for code just below. With this code 15369 however, later parts of the compiler see something like: 15370 15371 struct S' == struct S typedef struct S' MY_TYPE; struct S' object; 15372 15373 And they can then deduce (from the node for type struct S') that the 15374 original object declaration was: 15375 15376 MY_TYPE object; 15377 15378 Being able to do this is important for proper support of protoize, and 15379 also for generating precise symbolic debugging information which 15380 takes full account of the programmer's (typedef) vocabulary. 15381 15382 Obviously, we don't want to generate a duplicate ..._TYPE node if the 15383 TYPE_DECL node that we are now processing really represents a 15384 standard built-in type. 15385 15386 Since all standard types are effectively declared at line zero in the 15387 source file, we can easily check to see if we are working on a 15388 standard type by checking the current value of lineno. */ 15389 15390 if (TREE_CODE (x) == TYPE_DECL) 15391 { 15392 if (DECL_SOURCE_LINE (x) == 0) 15393 { 15394 if (TYPE_NAME (TREE_TYPE (x)) == 0) 15395 TYPE_NAME (TREE_TYPE (x)) = x; 15396 } 15397 else if (TREE_TYPE (x) != error_mark_node) 15398 { 15399 tree tt = TREE_TYPE (x); 15400 15401 tt = build_type_copy (tt); 15402 TYPE_NAME (tt) = x; 15403 TREE_TYPE (x) = tt; 15404 } 15405 } 15406 15407 /* This name is new in its binding level. Install the new declaration 15408 and return it. */ 15409 if (b == global_binding_level) 15410 IDENTIFIER_GLOBAL_VALUE (name) = x; 15411 else 15412 IDENTIFIER_LOCAL_VALUE (name) = x; 15413 } 15414 15415 /* Put decls on list in reverse order. We will reverse them later if 15416 necessary. */ 15417 TREE_CHAIN (x) = b->names; 15418 b->names = x; 15419 15420 return x; 15421} 15422 15423/* Nonzero if the current level needs to have a BLOCK made. */ 15424 15425static int 15426kept_level_p () 15427{ 15428 tree decl; 15429 15430 for (decl = current_binding_level->names; 15431 decl; 15432 decl = TREE_CHAIN (decl)) 15433 { 15434 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL 15435 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl))) 15436 /* Currently, there aren't supposed to be non-artificial names 15437 at other than the top block for a function -- they're 15438 believed to always be temps. But it's wise to check anyway. */ 15439 return 1; 15440 } 15441 return 0; 15442} 15443 15444/* Enter a new binding level. 15445 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, 15446 not for that of tags. */ 15447 15448void 15449pushlevel (tag_transparent) 15450 int tag_transparent; 15451{ 15452 register struct binding_level *newlevel = NULL_BINDING_LEVEL; 15453 15454 assert (! tag_transparent); 15455 15456 if (current_binding_level == global_binding_level) 15457 { 15458 named_labels = 0; 15459 } 15460 15461 /* Reuse or create a struct for this binding level. */ 15462 15463 if (free_binding_level) 15464 { 15465 newlevel = free_binding_level; 15466 free_binding_level = free_binding_level->level_chain; 15467 } 15468 else 15469 { 15470 newlevel = make_binding_level (); 15471 } 15472 15473 /* Add this level to the front of the chain (stack) of levels that 15474 are active. */ 15475 15476 *newlevel = clear_binding_level; 15477 newlevel->level_chain = current_binding_level; 15478 current_binding_level = newlevel; 15479} 15480 15481/* Set the BLOCK node for the innermost scope 15482 (the one we are currently in). */ 15483 15484void 15485set_block (block) 15486 register tree block; 15487{ 15488 current_binding_level->this_block = block; 15489} 15490 15491/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */ 15492 15493/* Can't 'yydebug' a front end not generated by yacc/bison! */ 15494 15495void 15496set_yydebug (value) 15497 int value; 15498{ 15499 if (value) 15500 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n"); 15501} 15502 15503tree 15504signed_or_unsigned_type (unsignedp, type) 15505 int unsignedp; 15506 tree type; 15507{ 15508 tree type2; 15509 15510 if (! INTEGRAL_TYPE_P (type)) 15511 return type; 15512 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) 15513 return unsignedp ? unsigned_char_type_node : signed_char_type_node; 15514 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) 15515 return unsignedp ? unsigned_type_node : integer_type_node; 15516 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) 15517 return unsignedp ? short_unsigned_type_node : short_integer_type_node; 15518 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) 15519 return unsignedp ? long_unsigned_type_node : long_integer_type_node; 15520 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) 15521 return (unsignedp ? long_long_unsigned_type_node 15522 : long_long_integer_type_node); 15523 15524 type2 = type_for_size (TYPE_PRECISION (type), unsignedp); 15525 if (type2 == NULL_TREE) 15526 return type; 15527 15528 return type2; 15529} 15530 15531tree 15532signed_type (type) 15533 tree type; 15534{ 15535 tree type1 = TYPE_MAIN_VARIANT (type); 15536 ffeinfoKindtype kt; 15537 tree type2; 15538 15539 if (type1 == unsigned_char_type_node || type1 == char_type_node) 15540 return signed_char_type_node; 15541 if (type1 == unsigned_type_node) 15542 return integer_type_node; 15543 if (type1 == short_unsigned_type_node) 15544 return short_integer_type_node; 15545 if (type1 == long_unsigned_type_node) 15546 return long_integer_type_node; 15547 if (type1 == long_long_unsigned_type_node) 15548 return long_long_integer_type_node; 15549#if 0 /* gcc/c-* files only */ 15550 if (type1 == unsigned_intDI_type_node) 15551 return intDI_type_node; 15552 if (type1 == unsigned_intSI_type_node) 15553 return intSI_type_node; 15554 if (type1 == unsigned_intHI_type_node) 15555 return intHI_type_node; 15556 if (type1 == unsigned_intQI_type_node) 15557 return intQI_type_node; 15558#endif 15559 15560 type2 = type_for_size (TYPE_PRECISION (type1), 0); 15561 if (type2 != NULL_TREE) 15562 return type2; 15563 15564 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) 15565 { 15566 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; 15567 15568 if (type1 == type2) 15569 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; 15570 } 15571 15572 return type; 15573} 15574 15575/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, 15576 or validate its data type for an `if' or `while' statement or ?..: exp. 15577 15578 This preparation consists of taking the ordinary 15579 representation of an expression expr and producing a valid tree 15580 boolean expression describing whether expr is nonzero. We could 15581 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), 15582 but we optimize comparisons, &&, ||, and !. 15583 15584 The resulting type should always be `integer_type_node'. */ 15585 15586tree 15587truthvalue_conversion (expr) 15588 tree expr; 15589{ 15590 if (TREE_CODE (expr) == ERROR_MARK) 15591 return expr; 15592 15593#if 0 /* This appears to be wrong for C++. */ 15594 /* These really should return error_mark_node after 2.4 is stable. 15595 But not all callers handle ERROR_MARK properly. */ 15596 switch (TREE_CODE (TREE_TYPE (expr))) 15597 { 15598 case RECORD_TYPE: 15599 error ("struct type value used where scalar is required"); 15600 return integer_zero_node; 15601 15602 case UNION_TYPE: 15603 error ("union type value used where scalar is required"); 15604 return integer_zero_node; 15605 15606 case ARRAY_TYPE: 15607 error ("array type value used where scalar is required"); 15608 return integer_zero_node; 15609 15610 default: 15611 break; 15612 } 15613#endif /* 0 */ 15614 15615 switch (TREE_CODE (expr)) 15616 { 15617 /* It is simpler and generates better code to have only TRUTH_*_EXPR 15618 or comparison expressions as truth values at this level. */ 15619#if 0 15620 case COMPONENT_REF: 15621 /* A one-bit unsigned bit-field is already acceptable. */ 15622 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) 15623 && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) 15624 return expr; 15625 break; 15626#endif 15627 15628 case EQ_EXPR: 15629 /* It is simpler and generates better code to have only TRUTH_*_EXPR 15630 or comparison expressions as truth values at this level. */ 15631#if 0 15632 if (integer_zerop (TREE_OPERAND (expr, 1))) 15633 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0); 15634#endif 15635 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: 15636 case TRUTH_ANDIF_EXPR: 15637 case TRUTH_ORIF_EXPR: 15638 case TRUTH_AND_EXPR: 15639 case TRUTH_OR_EXPR: 15640 case TRUTH_XOR_EXPR: 15641 TREE_TYPE (expr) = integer_type_node; 15642 return expr; 15643 15644 case ERROR_MARK: 15645 return expr; 15646 15647 case INTEGER_CST: 15648 return integer_zerop (expr) ? integer_zero_node : integer_one_node; 15649 15650 case REAL_CST: 15651 return real_zerop (expr) ? integer_zero_node : integer_one_node; 15652 15653 case ADDR_EXPR: 15654 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) 15655 return build (COMPOUND_EXPR, integer_type_node, 15656 TREE_OPERAND (expr, 0), integer_one_node); 15657 else 15658 return integer_one_node; 15659 15660 case COMPLEX_EXPR: 15661 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) 15662 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), 15663 integer_type_node, 15664 truthvalue_conversion (TREE_OPERAND (expr, 0)), 15665 truthvalue_conversion (TREE_OPERAND (expr, 1))); 15666 15667 case NEGATE_EXPR: 15668 case ABS_EXPR: 15669 case FLOAT_EXPR: 15670 case FFS_EXPR: 15671 /* These don't change whether an object is non-zero or zero. */ 15672 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 15673 15674 case LROTATE_EXPR: 15675 case RROTATE_EXPR: 15676 /* These don't change whether an object is zero or non-zero, but 15677 we can't ignore them if their second arg has side-effects. */ 15678 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) 15679 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1), 15680 truthvalue_conversion (TREE_OPERAND (expr, 0))); 15681 else 15682 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 15683 15684 case COND_EXPR: 15685 /* Distribute the conversion into the arms of a COND_EXPR. */ 15686 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0), 15687 truthvalue_conversion (TREE_OPERAND (expr, 1)), 15688 truthvalue_conversion (TREE_OPERAND (expr, 2)))); 15689 15690 case CONVERT_EXPR: 15691 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, 15692 since that affects how `default_conversion' will behave. */ 15693 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE 15694 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) 15695 break; 15696 /* fall through... */ 15697 case NOP_EXPR: 15698 /* If this is widening the argument, we can ignore it. */ 15699 if (TYPE_PRECISION (TREE_TYPE (expr)) 15700 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) 15701 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 15702 break; 15703 15704 case MINUS_EXPR: 15705 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize 15706 this case. */ 15707 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT 15708 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE) 15709 break; 15710 /* fall through... */ 15711 case BIT_XOR_EXPR: 15712 /* This and MINUS_EXPR can be changed into a comparison of the 15713 two objects. */ 15714 if (TREE_TYPE (TREE_OPERAND (expr, 0)) 15715 == TREE_TYPE (TREE_OPERAND (expr, 1))) 15716 return ffecom_2 (NE_EXPR, integer_type_node, 15717 TREE_OPERAND (expr, 0), 15718 TREE_OPERAND (expr, 1)); 15719 return ffecom_2 (NE_EXPR, integer_type_node, 15720 TREE_OPERAND (expr, 0), 15721 fold (build1 (NOP_EXPR, 15722 TREE_TYPE (TREE_OPERAND (expr, 0)), 15723 TREE_OPERAND (expr, 1)))); 15724 15725 case BIT_AND_EXPR: 15726 if (integer_onep (TREE_OPERAND (expr, 1))) 15727 return expr; 15728 break; 15729 15730 case MODIFY_EXPR: 15731#if 0 /* No such thing in Fortran. */ 15732 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR) 15733 warning ("suggest parentheses around assignment used as truth value"); 15734#endif 15735 break; 15736 15737 default: 15738 break; 15739 } 15740 15741 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) 15742 return (ffecom_2 15743 ((TREE_SIDE_EFFECTS (expr) 15744 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), 15745 integer_type_node, 15746 truthvalue_conversion (ffecom_1 (REALPART_EXPR, 15747 TREE_TYPE (TREE_TYPE (expr)), 15748 expr)), 15749 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR, 15750 TREE_TYPE (TREE_TYPE (expr)), 15751 expr)))); 15752 15753 return ffecom_2 (NE_EXPR, integer_type_node, 15754 expr, 15755 convert (TREE_TYPE (expr), integer_zero_node)); 15756} 15757 15758tree 15759type_for_mode (mode, unsignedp) 15760 enum machine_mode mode; 15761 int unsignedp; 15762{ 15763 int i; 15764 int j; 15765 tree t; 15766 15767 if (mode == TYPE_MODE (integer_type_node)) 15768 return unsignedp ? unsigned_type_node : integer_type_node; 15769 15770 if (mode == TYPE_MODE (signed_char_type_node)) 15771 return unsignedp ? unsigned_char_type_node : signed_char_type_node; 15772 15773 if (mode == TYPE_MODE (short_integer_type_node)) 15774 return unsignedp ? short_unsigned_type_node : short_integer_type_node; 15775 15776 if (mode == TYPE_MODE (long_integer_type_node)) 15777 return unsignedp ? long_unsigned_type_node : long_integer_type_node; 15778 15779 if (mode == TYPE_MODE (long_long_integer_type_node)) 15780 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; 15781 15782 if (mode == TYPE_MODE (float_type_node)) 15783 return float_type_node; 15784 15785 if (mode == TYPE_MODE (double_type_node)) 15786 return double_type_node; 15787 15788 if (mode == TYPE_MODE (build_pointer_type (char_type_node))) 15789 return build_pointer_type (char_type_node); 15790 15791 if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) 15792 return build_pointer_type (integer_type_node); 15793 15794 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) 15795 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) 15796 { 15797 if (((t = ffecom_tree_type[i][j]) != NULL_TREE) 15798 && (mode == TYPE_MODE (t))) 15799 { 15800 if ((i == FFEINFO_basictypeINTEGER) && unsignedp) 15801 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j]; 15802 else 15803 return t; 15804 } 15805 } 15806 15807 return 0; 15808} 15809 15810tree 15811type_for_size (bits, unsignedp) 15812 unsigned bits; 15813 int unsignedp; 15814{ 15815 ffeinfoKindtype kt; 15816 tree type_node; 15817 15818 if (bits == TYPE_PRECISION (integer_type_node)) 15819 return unsignedp ? unsigned_type_node : integer_type_node; 15820 15821 if (bits == TYPE_PRECISION (signed_char_type_node)) 15822 return unsignedp ? unsigned_char_type_node : signed_char_type_node; 15823 15824 if (bits == TYPE_PRECISION (short_integer_type_node)) 15825 return unsignedp ? short_unsigned_type_node : short_integer_type_node; 15826 15827 if (bits == TYPE_PRECISION (long_integer_type_node)) 15828 return unsignedp ? long_unsigned_type_node : long_integer_type_node; 15829 15830 if (bits == TYPE_PRECISION (long_long_integer_type_node)) 15831 return (unsignedp ? long_long_unsigned_type_node 15832 : long_long_integer_type_node); 15833 15834 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) 15835 { 15836 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; 15837 15838 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node))) 15839 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt] 15840 : type_node; 15841 } 15842 15843 return 0; 15844} 15845 15846tree 15847unsigned_type (type) 15848 tree type; 15849{ 15850 tree type1 = TYPE_MAIN_VARIANT (type); 15851 ffeinfoKindtype kt; 15852 tree type2; 15853 15854 if (type1 == signed_char_type_node || type1 == char_type_node) 15855 return unsigned_char_type_node; 15856 if (type1 == integer_type_node) 15857 return unsigned_type_node; 15858 if (type1 == short_integer_type_node) 15859 return short_unsigned_type_node; 15860 if (type1 == long_integer_type_node) 15861 return long_unsigned_type_node; 15862 if (type1 == long_long_integer_type_node) 15863 return long_long_unsigned_type_node; 15864#if 0 /* gcc/c-* files only */ 15865 if (type1 == intDI_type_node) 15866 return unsigned_intDI_type_node; 15867 if (type1 == intSI_type_node) 15868 return unsigned_intSI_type_node; 15869 if (type1 == intHI_type_node) 15870 return unsigned_intHI_type_node; 15871 if (type1 == intQI_type_node) 15872 return unsigned_intQI_type_node; 15873#endif 15874 15875 type2 = type_for_size (TYPE_PRECISION (type1), 1); 15876 if (type2 != NULL_TREE) 15877 return type2; 15878 15879 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) 15880 { 15881 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; 15882 15883 if (type1 == type2) 15884 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; 15885 } 15886 15887 return type; 15888} 15889 15890#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ 15891 15892#if FFECOM_GCC_INCLUDE 15893 15894/* From gcc/cccp.c, the code to handle -I. */ 15895 15896/* Skip leading "./" from a directory name. 15897 This may yield the empty string, which represents the current directory. */ 15898 15899static const char * 15900skip_redundant_dir_prefix (const char *dir) 15901{ 15902 while (dir[0] == '.' && dir[1] == '/') 15903 for (dir += 2; *dir == '/'; dir++) 15904 continue; 15905 if (dir[0] == '.' && !dir[1]) 15906 dir++; 15907 return dir; 15908} 15909 15910/* The file_name_map structure holds a mapping of file names for a 15911 particular directory. This mapping is read from the file named 15912 FILE_NAME_MAP_FILE in that directory. Such a file can be used to 15913 map filenames on a file system with severe filename restrictions, 15914 such as DOS. The format of the file name map file is just a series 15915 of lines with two tokens on each line. The first token is the name 15916 to map, and the second token is the actual name to use. */ 15917 15918struct file_name_map 15919{ 15920 struct file_name_map *map_next; 15921 char *map_from; 15922 char *map_to; 15923}; 15924 15925#define FILE_NAME_MAP_FILE "header.gcc" 15926 15927/* Current maximum length of directory names in the search path 15928 for include files. (Altered as we get more of them.) */ 15929 15930static int max_include_len = 0; 15931 15932struct file_name_list 15933 { 15934 struct file_name_list *next; 15935 char *fname; 15936 /* Mapping of file names for this directory. */ 15937 struct file_name_map *name_map; 15938 /* Non-zero if name_map is valid. */ 15939 int got_name_map; 15940 }; 15941 15942static struct file_name_list *include = NULL; /* First dir to search */ 15943static struct file_name_list *last_include = NULL; /* Last in chain */ 15944 15945/* I/O buffer structure. 15946 The `fname' field is nonzero for source files and #include files 15947 and for the dummy text used for -D and -U. 15948 It is zero for rescanning results of macro expansion 15949 and for expanding macro arguments. */ 15950#define INPUT_STACK_MAX 400 15951static struct file_buf { 15952 char *fname; 15953 /* Filename specified with #line command. */ 15954 char *nominal_fname; 15955 /* Record where in the search path this file was found. 15956 For #include_next. */ 15957 struct file_name_list *dir; 15958 ffewhereLine line; 15959 ffewhereColumn column; 15960} instack[INPUT_STACK_MAX]; 15961 15962static int last_error_tick = 0; /* Incremented each time we print it. */ 15963static int input_file_stack_tick = 0; /* Incremented when status changes. */ 15964 15965/* Current nesting level of input sources. 15966 `instack[indepth]' is the level currently being read. */ 15967static int indepth = -1; 15968 15969typedef struct file_buf FILE_BUF; 15970 15971typedef unsigned char U_CHAR; 15972 15973/* table to tell if char can be part of a C identifier. */ 15974U_CHAR is_idchar[256]; 15975/* table to tell if char can be first char of a c identifier. */ 15976U_CHAR is_idstart[256]; 15977/* table to tell if c is horizontal space. */ 15978U_CHAR is_hor_space[256]; 15979/* table to tell if c is horizontal or vertical space. */ 15980static U_CHAR is_space[256]; 15981 15982#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0) 15983#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0) 15984 15985/* Nonzero means -I- has been seen, 15986 so don't look for #include "foo" the source-file directory. */ 15987static int ignore_srcdir; 15988 15989#ifndef INCLUDE_LEN_FUDGE 15990#define INCLUDE_LEN_FUDGE 0 15991#endif 15992 15993static void append_include_chain (struct file_name_list *first, 15994 struct file_name_list *last); 15995static FILE *open_include_file (char *filename, 15996 struct file_name_list *searchptr); 15997static void print_containing_files (ffebadSeverity sev); 15998static const char *skip_redundant_dir_prefix (const char *); 15999static char *read_filename_string (int ch, FILE *f); 16000static struct file_name_map *read_name_map (const char *dirname); 16001 16002/* Append a chain of `struct file_name_list's 16003 to the end of the main include chain. 16004 FIRST is the beginning of the chain to append, and LAST is the end. */ 16005 16006static void 16007append_include_chain (first, last) 16008 struct file_name_list *first, *last; 16009{ 16010 struct file_name_list *dir; 16011 16012 if (!first || !last) 16013 return; 16014 16015 if (include == 0) 16016 include = first; 16017 else 16018 last_include->next = first; 16019 16020 for (dir = first; ; dir = dir->next) { 16021 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE; 16022 if (len > max_include_len) 16023 max_include_len = len; 16024 if (dir == last) 16025 break; 16026 } 16027 16028 last->next = NULL; 16029 last_include = last; 16030} 16031 16032/* Try to open include file FILENAME. SEARCHPTR is the directory 16033 being tried from the include file search path. This function maps 16034 filenames on file systems based on information read by 16035 read_name_map. */ 16036 16037static FILE * 16038open_include_file (filename, searchptr) 16039 char *filename; 16040 struct file_name_list *searchptr; 16041{ 16042 register struct file_name_map *map; 16043 register char *from; 16044 char *p, *dir; 16045 16046 if (searchptr && ! searchptr->got_name_map) 16047 { 16048 searchptr->name_map = read_name_map (searchptr->fname 16049 ? searchptr->fname : "."); 16050 searchptr->got_name_map = 1; 16051 } 16052 16053 /* First check the mapping for the directory we are using. */ 16054 if (searchptr && searchptr->name_map) 16055 { 16056 from = filename; 16057 if (searchptr->fname) 16058 from += strlen (searchptr->fname) + 1; 16059 for (map = searchptr->name_map; map; map = map->map_next) 16060 { 16061 if (! strcmp (map->map_from, from)) 16062 { 16063 /* Found a match. */ 16064 return fopen (map->map_to, "r"); 16065 } 16066 } 16067 } 16068 16069 /* Try to find a mapping file for the particular directory we are 16070 looking in. Thus #include <sys/types.h> will look up sys/types.h 16071 in /usr/include/header.gcc and look up types.h in 16072 /usr/include/sys/header.gcc. */ 16073 p = rindex (filename, '/'); 16074#ifdef DIR_SEPARATOR 16075 if (! p) p = rindex (filename, DIR_SEPARATOR); 16076 else { 16077 char *tmp = rindex (filename, DIR_SEPARATOR); 16078 if (tmp != NULL && tmp > p) p = tmp; 16079 } 16080#endif 16081 if (! p) 16082 p = filename; 16083 if (searchptr 16084 && searchptr->fname 16085 && strlen (searchptr->fname) == (size_t) (p - filename) 16086 && ! strncmp (searchptr->fname, filename, (int) (p - filename))) 16087 { 16088 /* FILENAME is in SEARCHPTR, which we've already checked. */ 16089 return fopen (filename, "r"); 16090 } 16091 16092 if (p == filename) 16093 { 16094 from = filename; 16095 map = read_name_map ("."); 16096 } 16097 else 16098 { 16099 dir = (char *) xmalloc (p - filename + 1); 16100 memcpy (dir, filename, p - filename); 16101 dir[p - filename] = '\0'; 16102 from = p + 1; 16103 map = read_name_map (dir); 16104 free (dir); 16105 } 16106 for (; map; map = map->map_next) 16107 if (! strcmp (map->map_from, from)) 16108 return fopen (map->map_to, "r"); 16109 16110 return fopen (filename, "r"); 16111} 16112 16113/* Print the file names and line numbers of the #include 16114 commands which led to the current file. */ 16115 16116static void 16117print_containing_files (ffebadSeverity sev) 16118{ 16119 FILE_BUF *ip = NULL; 16120 int i; 16121 int first = 1; 16122 const char *str1; 16123 const char *str2; 16124 16125 /* If stack of files hasn't changed since we last printed 16126 this info, don't repeat it. */ 16127 if (last_error_tick == input_file_stack_tick) 16128 return; 16129 16130 for (i = indepth; i >= 0; i--) 16131 if (instack[i].fname != NULL) { 16132 ip = &instack[i]; 16133 break; 16134 } 16135 16136 /* Give up if we don't find a source file. */ 16137 if (ip == NULL) 16138 return; 16139 16140 /* Find the other, outer source files. */ 16141 for (i--; i >= 0; i--) 16142 if (instack[i].fname != NULL) 16143 { 16144 ip = &instack[i]; 16145 if (first) 16146 { 16147 first = 0; 16148 str1 = "In file included"; 16149 } 16150 else 16151 { 16152 str1 = "... ..."; 16153 } 16154 16155 if (i == 1) 16156 str2 = ":"; 16157 else 16158 str2 = ""; 16159 16160 ffebad_start_msg ("%A from %B at %0%C", sev); 16161 ffebad_here (0, ip->line, ip->column); 16162 ffebad_string (str1); 16163 ffebad_string (ip->nominal_fname); 16164 ffebad_string (str2); 16165 ffebad_finish (); 16166 } 16167 16168 /* Record we have printed the status as of this time. */ 16169 last_error_tick = input_file_stack_tick; 16170} 16171 16172/* Read a space delimited string of unlimited length from a stdio 16173 file. */ 16174 16175static char * 16176read_filename_string (ch, f) 16177 int ch; 16178 FILE *f; 16179{ 16180 char *alloc, *set; 16181 int len; 16182 16183 len = 20; 16184 set = alloc = xmalloc (len + 1); 16185 if (! is_space[ch]) 16186 { 16187 *set++ = ch; 16188 while ((ch = getc (f)) != EOF && ! is_space[ch]) 16189 { 16190 if (set - alloc == len) 16191 { 16192 len *= 2; 16193 alloc = xrealloc (alloc, len + 1); 16194 set = alloc + len / 2; 16195 } 16196 *set++ = ch; 16197 } 16198 } 16199 *set = '\0'; 16200 ungetc (ch, f); 16201 return alloc; 16202} 16203 16204/* Read the file name map file for DIRNAME. */ 16205 16206static struct file_name_map * 16207read_name_map (dirname) 16208 const char *dirname; 16209{ 16210 /* This structure holds a linked list of file name maps, one per 16211 directory. */ 16212 struct file_name_map_list 16213 { 16214 struct file_name_map_list *map_list_next; 16215 char *map_list_name; 16216 struct file_name_map *map_list_map; 16217 }; 16218 static struct file_name_map_list *map_list; 16219 register struct file_name_map_list *map_list_ptr; 16220 char *name; 16221 FILE *f; 16222 size_t dirlen; 16223 int separator_needed; 16224 16225 dirname = skip_redundant_dir_prefix (dirname); 16226 16227 for (map_list_ptr = map_list; map_list_ptr; 16228 map_list_ptr = map_list_ptr->map_list_next) 16229 if (! strcmp (map_list_ptr->map_list_name, dirname)) 16230 return map_list_ptr->map_list_map; 16231 16232 map_list_ptr = ((struct file_name_map_list *) 16233 xmalloc (sizeof (struct file_name_map_list))); 16234 map_list_ptr->map_list_name = xstrdup (dirname); 16235 map_list_ptr->map_list_map = NULL; 16236 16237 dirlen = strlen (dirname); 16238 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; 16239 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2); 16240 strcpy (name, dirname); 16241 name[dirlen] = '/'; 16242 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE); 16243 f = fopen (name, "r"); 16244 free (name); 16245 if (!f) 16246 map_list_ptr->map_list_map = NULL; 16247 else 16248 { 16249 int ch; 16250 16251 while ((ch = getc (f)) != EOF) 16252 { 16253 char *from, *to; 16254 struct file_name_map *ptr; 16255 16256 if (is_space[ch]) 16257 continue; 16258 from = read_filename_string (ch, f); 16259 while ((ch = getc (f)) != EOF && is_hor_space[ch]) 16260 ; 16261 to = read_filename_string (ch, f); 16262 16263 ptr = ((struct file_name_map *) 16264 xmalloc (sizeof (struct file_name_map))); 16265 ptr->map_from = from; 16266 16267 /* Make the real filename absolute. */ 16268 if (*to == '/') 16269 ptr->map_to = to; 16270 else 16271 { 16272 ptr->map_to = xmalloc (dirlen + strlen (to) + 2); 16273 strcpy (ptr->map_to, dirname); 16274 ptr->map_to[dirlen] = '/'; 16275 strcpy (ptr->map_to + dirlen + separator_needed, to); 16276 free (to); 16277 } 16278 16279 ptr->map_next = map_list_ptr->map_list_map; 16280 map_list_ptr->map_list_map = ptr; 16281 16282 while ((ch = getc (f)) != '\n') 16283 if (ch == EOF) 16284 break; 16285 } 16286 fclose (f); 16287 } 16288 16289 map_list_ptr->map_list_next = map_list; 16290 map_list = map_list_ptr; 16291 16292 return map_list_ptr->map_list_map; 16293} 16294 16295static void 16296ffecom_file_ (char *name) 16297{ 16298 FILE_BUF *fp; 16299 16300 /* Do partial setup of input buffer for the sake of generating 16301 early #line directives (when -g is in effect). */ 16302 16303 fp = &instack[++indepth]; 16304 memset ((char *) fp, 0, sizeof (FILE_BUF)); 16305 if (name == NULL) 16306 name = ""; 16307 fp->nominal_fname = fp->fname = name; 16308} 16309 16310/* Initialize syntactic classifications of characters. */ 16311 16312static void 16313ffecom_initialize_char_syntax_ () 16314{ 16315 register int i; 16316 16317 /* 16318 * Set up is_idchar and is_idstart tables. These should be 16319 * faster than saying (is_alpha (c) || c == '_'), etc. 16320 * Set up these things before calling any routines tthat 16321 * refer to them. 16322 */ 16323 for (i = 'a'; i <= 'z'; i++) { 16324 is_idchar[i - 'a' + 'A'] = 1; 16325 is_idchar[i] = 1; 16326 is_idstart[i - 'a' + 'A'] = 1; 16327 is_idstart[i] = 1; 16328 } 16329 for (i = '0'; i <= '9'; i++) 16330 is_idchar[i] = 1; 16331 is_idchar['_'] = 1; 16332 is_idstart['_'] = 1; 16333 16334 /* horizontal space table */ 16335 is_hor_space[' '] = 1; 16336 is_hor_space['\t'] = 1; 16337 is_hor_space['\v'] = 1; 16338 is_hor_space['\f'] = 1; 16339 is_hor_space['\r'] = 1; 16340 16341 is_space[' '] = 1; 16342 is_space['\t'] = 1; 16343 is_space['\v'] = 1; 16344 is_space['\f'] = 1; 16345 is_space['\n'] = 1; 16346 is_space['\r'] = 1; 16347} 16348 16349static void 16350ffecom_close_include_ (FILE *f) 16351{ 16352 fclose (f); 16353 16354 indepth--; 16355 input_file_stack_tick++; 16356 16357 ffewhere_line_kill (instack[indepth].line); 16358 ffewhere_column_kill (instack[indepth].column); 16359} 16360 16361static int 16362ffecom_decode_include_option_ (char *spec) 16363{ 16364 struct file_name_list *dirtmp; 16365 16366 if (! ignore_srcdir && !strcmp (spec, "-")) 16367 ignore_srcdir = 1; 16368 else 16369 { 16370 dirtmp = (struct file_name_list *) 16371 xmalloc (sizeof (struct file_name_list)); 16372 dirtmp->next = 0; /* New one goes on the end */ 16373 if (spec[0] != 0) 16374 dirtmp->fname = spec; 16375 else 16376 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'"); 16377 dirtmp->got_name_map = 0; 16378 append_include_chain (dirtmp, dirtmp); 16379 } 16380 return 1; 16381} 16382 16383/* Open INCLUDEd file. */ 16384 16385static FILE * 16386ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) 16387{ 16388 char *fbeg = name; 16389 size_t flen = strlen (fbeg); 16390 struct file_name_list *search_start = include; /* Chain of dirs to search */ 16391 struct file_name_list dsp[1]; /* First in chain, if #include "..." */ 16392 struct file_name_list *searchptr = 0; 16393 char *fname; /* Dynamically allocated fname buffer */ 16394 FILE *f; 16395 FILE_BUF *fp; 16396 16397 if (flen == 0) 16398 return NULL; 16399 16400 dsp[0].fname = NULL; 16401 16402 /* If -I- was specified, don't search current dir, only spec'd ones. */ 16403 if (!ignore_srcdir) 16404 { 16405 for (fp = &instack[indepth]; fp >= instack; fp--) 16406 { 16407 int n; 16408 char *ep; 16409 char *nam; 16410 16411 if ((nam = fp->nominal_fname) != NULL) 16412 { 16413 /* Found a named file. Figure out dir of the file, 16414 and put it in front of the search list. */ 16415 dsp[0].next = search_start; 16416 search_start = dsp; 16417#ifndef VMS 16418 ep = rindex (nam, '/'); 16419#ifdef DIR_SEPARATOR 16420 if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR); 16421 else { 16422 char *tmp = rindex (nam, DIR_SEPARATOR); 16423 if (tmp != NULL && tmp > ep) ep = tmp; 16424 } 16425#endif 16426#else /* VMS */ 16427 ep = rindex (nam, ']'); 16428 if (ep == NULL) ep = rindex (nam, '>'); 16429 if (ep == NULL) ep = rindex (nam, ':'); 16430 if (ep != NULL) ep++; 16431#endif /* VMS */ 16432 if (ep != NULL) 16433 { 16434 n = ep - nam; 16435 dsp[0].fname = (char *) xmalloc (n + 1); 16436 strncpy (dsp[0].fname, nam, n); 16437 dsp[0].fname[n] = '\0'; 16438 if (n + INCLUDE_LEN_FUDGE > max_include_len) 16439 max_include_len = n + INCLUDE_LEN_FUDGE; 16440 } 16441 else 16442 dsp[0].fname = NULL; /* Current directory */ 16443 dsp[0].got_name_map = 0; 16444 break; 16445 } 16446 } 16447 } 16448 16449 /* Allocate this permanently, because it gets stored in the definitions 16450 of macros. */ 16451 fname = xmalloc (max_include_len + flen + 4); 16452 /* + 2 above for slash and terminating null. */ 16453 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED 16454 for g77 yet). */ 16455 16456 /* If specified file name is absolute, just open it. */ 16457 16458 if (*fbeg == '/' 16459#ifdef DIR_SEPARATOR 16460 || *fbeg == DIR_SEPARATOR 16461#endif 16462 ) 16463 { 16464 strncpy (fname, (char *) fbeg, flen); 16465 fname[flen] = 0; 16466 f = open_include_file (fname, NULL_PTR); 16467 } 16468 else 16469 { 16470 f = NULL; 16471 16472 /* Search directory path, trying to open the file. 16473 Copy each filename tried into FNAME. */ 16474 16475 for (searchptr = search_start; searchptr; searchptr = searchptr->next) 16476 { 16477 if (searchptr->fname) 16478 { 16479 /* The empty string in a search path is ignored. 16480 This makes it possible to turn off entirely 16481 a standard piece of the list. */ 16482 if (searchptr->fname[0] == 0) 16483 continue; 16484 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname)); 16485 if (fname[0] && fname[strlen (fname) - 1] != '/') 16486 strcat (fname, "/"); 16487 fname[strlen (fname) + flen] = 0; 16488 } 16489 else 16490 fname[0] = 0; 16491 16492 strncat (fname, fbeg, flen); 16493#ifdef VMS 16494 /* Change this 1/2 Unix 1/2 VMS file specification into a 16495 full VMS file specification */ 16496 if (searchptr->fname && (searchptr->fname[0] != 0)) 16497 { 16498 /* Fix up the filename */ 16499 hack_vms_include_specification (fname); 16500 } 16501 else 16502 { 16503 /* This is a normal VMS filespec, so use it unchanged. */ 16504 strncpy (fname, (char *) fbeg, flen); 16505 fname[flen] = 0; 16506#if 0 /* Not for g77. */ 16507 /* if it's '#include filename', add the missing .h */ 16508 if (index (fname, '.') == NULL) 16509 strcat (fname, ".h"); 16510#endif 16511 } 16512#endif /* VMS */ 16513 f = open_include_file (fname, searchptr); 16514#ifdef EACCES 16515 if (f == NULL && errno == EACCES) 16516 { 16517 print_containing_files (FFEBAD_severityWARNING); 16518 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable", 16519 FFEBAD_severityWARNING); 16520 ffebad_string (fname); 16521 ffebad_here (0, l, c); 16522 ffebad_finish (); 16523 } 16524#endif 16525 if (f != NULL) 16526 break; 16527 } 16528 } 16529 16530 if (f == NULL) 16531 { 16532 /* A file that was not found. */ 16533 16534 strncpy (fname, (char *) fbeg, flen); 16535 fname[flen] = 0; 16536 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE)); 16537 ffebad_start (FFEBAD_OPEN_INCLUDE); 16538 ffebad_here (0, l, c); 16539 ffebad_string (fname); 16540 ffebad_finish (); 16541 } 16542 16543 if (dsp[0].fname != NULL) 16544 free (dsp[0].fname); 16545 16546 if (f == NULL) 16547 return NULL; 16548 16549 if (indepth >= (INPUT_STACK_MAX - 1)) 16550 { 16551 print_containing_files (FFEBAD_severityFATAL); 16552 ffebad_start_msg ("At %0, INCLUDE nesting too deep", 16553 FFEBAD_severityFATAL); 16554 ffebad_string (fname); 16555 ffebad_here (0, l, c); 16556 ffebad_finish (); 16557 return NULL; 16558 } 16559 16560 instack[indepth].line = ffewhere_line_use (l); 16561 instack[indepth].column = ffewhere_column_use (c); 16562 16563 fp = &instack[indepth + 1]; 16564 memset ((char *) fp, 0, sizeof (FILE_BUF)); 16565 fp->nominal_fname = fp->fname = fname; 16566 fp->dir = searchptr; 16567 16568 indepth++; 16569 input_file_stack_tick++; 16570 16571 return f; 16572} 16573#endif /* FFECOM_GCC_INCLUDE */ 16574 16575/**INDENT* (Do not reformat this comment even with -fca option.) 16576 Data-gathering files: Given the source file listed below, compiled with 16577 f2c I obtained the output file listed after that, and from the output 16578 file I derived the above code. 16579 16580-------- (begin input file to f2c) 16581 implicit none 16582 character*10 A1,A2 16583 complex C1,C2 16584 integer I1,I2 16585 real R1,R2 16586 double precision D1,D2 16587C 16588 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) 16589c / 16590 call fooI(I1/I2) 16591 call fooR(R1/I1) 16592 call fooD(D1/I1) 16593 call fooC(C1/I1) 16594 call fooR(R1/R2) 16595 call fooD(R1/D1) 16596 call fooD(D1/D2) 16597 call fooD(D1/R1) 16598 call fooC(C1/C2) 16599 call fooC(C1/R1) 16600 call fooZ(C1/D1) 16601c ** 16602 call fooI(I1**I2) 16603 call fooR(R1**I1) 16604 call fooD(D1**I1) 16605 call fooC(C1**I1) 16606 call fooR(R1**R2) 16607 call fooD(R1**D1) 16608 call fooD(D1**D2) 16609 call fooD(D1**R1) 16610 call fooC(C1**C2) 16611 call fooC(C1**R1) 16612 call fooZ(C1**D1) 16613c FFEINTRIN_impABS 16614 call fooR(ABS(R1)) 16615c FFEINTRIN_impACOS 16616 call fooR(ACOS(R1)) 16617c FFEINTRIN_impAIMAG 16618 call fooR(AIMAG(C1)) 16619c FFEINTRIN_impAINT 16620 call fooR(AINT(R1)) 16621c FFEINTRIN_impALOG 16622 call fooR(ALOG(R1)) 16623c FFEINTRIN_impALOG10 16624 call fooR(ALOG10(R1)) 16625c FFEINTRIN_impAMAX0 16626 call fooR(AMAX0(I1,I2)) 16627c FFEINTRIN_impAMAX1 16628 call fooR(AMAX1(R1,R2)) 16629c FFEINTRIN_impAMIN0 16630 call fooR(AMIN0(I1,I2)) 16631c FFEINTRIN_impAMIN1 16632 call fooR(AMIN1(R1,R2)) 16633c FFEINTRIN_impAMOD 16634 call fooR(AMOD(R1,R2)) 16635c FFEINTRIN_impANINT 16636 call fooR(ANINT(R1)) 16637c FFEINTRIN_impASIN 16638 call fooR(ASIN(R1)) 16639c FFEINTRIN_impATAN 16640 call fooR(ATAN(R1)) 16641c FFEINTRIN_impATAN2 16642 call fooR(ATAN2(R1,R2)) 16643c FFEINTRIN_impCABS 16644 call fooR(CABS(C1)) 16645c FFEINTRIN_impCCOS 16646 call fooC(CCOS(C1)) 16647c FFEINTRIN_impCEXP 16648 call fooC(CEXP(C1)) 16649c FFEINTRIN_impCHAR 16650 call fooA(CHAR(I1)) 16651c FFEINTRIN_impCLOG 16652 call fooC(CLOG(C1)) 16653c FFEINTRIN_impCONJG 16654 call fooC(CONJG(C1)) 16655c FFEINTRIN_impCOS 16656 call fooR(COS(R1)) 16657c FFEINTRIN_impCOSH 16658 call fooR(COSH(R1)) 16659c FFEINTRIN_impCSIN 16660 call fooC(CSIN(C1)) 16661c FFEINTRIN_impCSQRT 16662 call fooC(CSQRT(C1)) 16663c FFEINTRIN_impDABS 16664 call fooD(DABS(D1)) 16665c FFEINTRIN_impDACOS 16666 call fooD(DACOS(D1)) 16667c FFEINTRIN_impDASIN 16668 call fooD(DASIN(D1)) 16669c FFEINTRIN_impDATAN 16670 call fooD(DATAN(D1)) 16671c FFEINTRIN_impDATAN2 16672 call fooD(DATAN2(D1,D2)) 16673c FFEINTRIN_impDCOS 16674 call fooD(DCOS(D1)) 16675c FFEINTRIN_impDCOSH 16676 call fooD(DCOSH(D1)) 16677c FFEINTRIN_impDDIM 16678 call fooD(DDIM(D1,D2)) 16679c FFEINTRIN_impDEXP 16680 call fooD(DEXP(D1)) 16681c FFEINTRIN_impDIM 16682 call fooR(DIM(R1,R2)) 16683c FFEINTRIN_impDINT 16684 call fooD(DINT(D1)) 16685c FFEINTRIN_impDLOG 16686 call fooD(DLOG(D1)) 16687c FFEINTRIN_impDLOG10 16688 call fooD(DLOG10(D1)) 16689c FFEINTRIN_impDMAX1 16690 call fooD(DMAX1(D1,D2)) 16691c FFEINTRIN_impDMIN1 16692 call fooD(DMIN1(D1,D2)) 16693c FFEINTRIN_impDMOD 16694 call fooD(DMOD(D1,D2)) 16695c FFEINTRIN_impDNINT 16696 call fooD(DNINT(D1)) 16697c FFEINTRIN_impDPROD 16698 call fooD(DPROD(R1,R2)) 16699c FFEINTRIN_impDSIGN 16700 call fooD(DSIGN(D1,D2)) 16701c FFEINTRIN_impDSIN 16702 call fooD(DSIN(D1)) 16703c FFEINTRIN_impDSINH 16704 call fooD(DSINH(D1)) 16705c FFEINTRIN_impDSQRT 16706 call fooD(DSQRT(D1)) 16707c FFEINTRIN_impDTAN 16708 call fooD(DTAN(D1)) 16709c FFEINTRIN_impDTANH 16710 call fooD(DTANH(D1)) 16711c FFEINTRIN_impEXP 16712 call fooR(EXP(R1)) 16713c FFEINTRIN_impIABS 16714 call fooI(IABS(I1)) 16715c FFEINTRIN_impICHAR 16716 call fooI(ICHAR(A1)) 16717c FFEINTRIN_impIDIM 16718 call fooI(IDIM(I1,I2)) 16719c FFEINTRIN_impIDNINT 16720 call fooI(IDNINT(D1)) 16721c FFEINTRIN_impINDEX 16722 call fooI(INDEX(A1,A2)) 16723c FFEINTRIN_impISIGN 16724 call fooI(ISIGN(I1,I2)) 16725c FFEINTRIN_impLEN 16726 call fooI(LEN(A1)) 16727c FFEINTRIN_impLGE 16728 call fooL(LGE(A1,A2)) 16729c FFEINTRIN_impLGT 16730 call fooL(LGT(A1,A2)) 16731c FFEINTRIN_impLLE 16732 call fooL(LLE(A1,A2)) 16733c FFEINTRIN_impLLT 16734 call fooL(LLT(A1,A2)) 16735c FFEINTRIN_impMAX0 16736 call fooI(MAX0(I1,I2)) 16737c FFEINTRIN_impMAX1 16738 call fooI(MAX1(R1,R2)) 16739c FFEINTRIN_impMIN0 16740 call fooI(MIN0(I1,I2)) 16741c FFEINTRIN_impMIN1 16742 call fooI(MIN1(R1,R2)) 16743c FFEINTRIN_impMOD 16744 call fooI(MOD(I1,I2)) 16745c FFEINTRIN_impNINT 16746 call fooI(NINT(R1)) 16747c FFEINTRIN_impSIGN 16748 call fooR(SIGN(R1,R2)) 16749c FFEINTRIN_impSIN 16750 call fooR(SIN(R1)) 16751c FFEINTRIN_impSINH 16752 call fooR(SINH(R1)) 16753c FFEINTRIN_impSQRT 16754 call fooR(SQRT(R1)) 16755c FFEINTRIN_impTAN 16756 call fooR(TAN(R1)) 16757c FFEINTRIN_impTANH 16758 call fooR(TANH(R1)) 16759c FFEINTRIN_imp_CMPLX_C 16760 call fooC(cmplx(C1,C2)) 16761c FFEINTRIN_imp_CMPLX_D 16762 call fooZ(cmplx(D1,D2)) 16763c FFEINTRIN_imp_CMPLX_I 16764 call fooC(cmplx(I1,I2)) 16765c FFEINTRIN_imp_CMPLX_R 16766 call fooC(cmplx(R1,R2)) 16767c FFEINTRIN_imp_DBLE_C 16768 call fooD(dble(C1)) 16769c FFEINTRIN_imp_DBLE_D 16770 call fooD(dble(D1)) 16771c FFEINTRIN_imp_DBLE_I 16772 call fooD(dble(I1)) 16773c FFEINTRIN_imp_DBLE_R 16774 call fooD(dble(R1)) 16775c FFEINTRIN_imp_INT_C 16776 call fooI(int(C1)) 16777c FFEINTRIN_imp_INT_D 16778 call fooI(int(D1)) 16779c FFEINTRIN_imp_INT_I 16780 call fooI(int(I1)) 16781c FFEINTRIN_imp_INT_R 16782 call fooI(int(R1)) 16783c FFEINTRIN_imp_REAL_C 16784 call fooR(real(C1)) 16785c FFEINTRIN_imp_REAL_D 16786 call fooR(real(D1)) 16787c FFEINTRIN_imp_REAL_I 16788 call fooR(real(I1)) 16789c FFEINTRIN_imp_REAL_R 16790 call fooR(real(R1)) 16791c 16792c FFEINTRIN_imp_INT_D: 16793c 16794c FFEINTRIN_specIDINT 16795 call fooI(IDINT(D1)) 16796c 16797c FFEINTRIN_imp_INT_R: 16798c 16799c FFEINTRIN_specIFIX 16800 call fooI(IFIX(R1)) 16801c FFEINTRIN_specINT 16802 call fooI(INT(R1)) 16803c 16804c FFEINTRIN_imp_REAL_D: 16805c 16806c FFEINTRIN_specSNGL 16807 call fooR(SNGL(D1)) 16808c 16809c FFEINTRIN_imp_REAL_I: 16810c 16811c FFEINTRIN_specFLOAT 16812 call fooR(FLOAT(I1)) 16813c FFEINTRIN_specREAL 16814 call fooR(REAL(I1)) 16815c 16816 end 16817-------- (end input file to f2c) 16818 16819-------- (begin output from providing above input file as input to: 16820-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ 16821-------- -e "s:^#.*$::g"') 16822 16823// -- translated by f2c (version 19950223). 16824 You must link the resulting object file with the libraries: 16825 -lf2c -lm (in that order) 16826// 16827 16828 16829// f2c.h -- Standard Fortran to C header file // 16830 16831/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." 16832 16833 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // 16834 16835 16836 16837 16838// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // 16839// we assume short, float are OK // 16840typedef long int // long int // integer; 16841typedef char *address; 16842typedef short int shortint; 16843typedef float real; 16844typedef double doublereal; 16845typedef struct { real r, i; } complex; 16846typedef struct { doublereal r, i; } doublecomplex; 16847typedef long int // long int // logical; 16848typedef short int shortlogical; 16849typedef char logical1; 16850typedef char integer1; 16851// typedef long long longint; // // system-dependent // 16852 16853 16854 16855 16856// Extern is for use with -E // 16857 16858 16859 16860 16861// I/O stuff // 16862 16863 16864 16865 16866 16867 16868 16869 16870typedef long int // int or long int // flag; 16871typedef long int // int or long int // ftnlen; 16872typedef long int // int or long int // ftnint; 16873 16874 16875//external read, write// 16876typedef struct 16877{ flag cierr; 16878 ftnint ciunit; 16879 flag ciend; 16880 char *cifmt; 16881 ftnint cirec; 16882} cilist; 16883 16884//internal read, write// 16885typedef struct 16886{ flag icierr; 16887 char *iciunit; 16888 flag iciend; 16889 char *icifmt; 16890 ftnint icirlen; 16891 ftnint icirnum; 16892} icilist; 16893 16894//open// 16895typedef struct 16896{ flag oerr; 16897 ftnint ounit; 16898 char *ofnm; 16899 ftnlen ofnmlen; 16900 char *osta; 16901 char *oacc; 16902 char *ofm; 16903 ftnint orl; 16904 char *oblnk; 16905} olist; 16906 16907//close// 16908typedef struct 16909{ flag cerr; 16910 ftnint cunit; 16911 char *csta; 16912} cllist; 16913 16914//rewind, backspace, endfile// 16915typedef struct 16916{ flag aerr; 16917 ftnint aunit; 16918} alist; 16919 16920// inquire // 16921typedef struct 16922{ flag inerr; 16923 ftnint inunit; 16924 char *infile; 16925 ftnlen infilen; 16926 ftnint *inex; //parameters in standard's order// 16927 ftnint *inopen; 16928 ftnint *innum; 16929 ftnint *innamed; 16930 char *inname; 16931 ftnlen innamlen; 16932 char *inacc; 16933 ftnlen inacclen; 16934 char *inseq; 16935 ftnlen inseqlen; 16936 char *indir; 16937 ftnlen indirlen; 16938 char *infmt; 16939 ftnlen infmtlen; 16940 char *inform; 16941 ftnint informlen; 16942 char *inunf; 16943 ftnlen inunflen; 16944 ftnint *inrecl; 16945 ftnint *innrec; 16946 char *inblank; 16947 ftnlen inblanklen; 16948} inlist; 16949 16950 16951 16952union Multitype { // for multiple entry points // 16953 integer1 g; 16954 shortint h; 16955 integer i; 16956 // longint j; // 16957 real r; 16958 doublereal d; 16959 complex c; 16960 doublecomplex z; 16961 }; 16962 16963typedef union Multitype Multitype; 16964 16965typedef long Long; // No longer used; formerly in Namelist // 16966 16967struct Vardesc { // for Namelist // 16968 char *name; 16969 char *addr; 16970 ftnlen *dims; 16971 int type; 16972 }; 16973typedef struct Vardesc Vardesc; 16974 16975struct Namelist { 16976 char *name; 16977 Vardesc **vars; 16978 int nvars; 16979 }; 16980typedef struct Namelist Namelist; 16981 16982 16983 16984 16985 16986 16987 16988 16989// procedure parameter types for -A and -C++ // 16990 16991 16992 16993 16994typedef int // Unknown procedure type // (*U_fp)(); 16995typedef shortint (*J_fp)(); 16996typedef integer (*I_fp)(); 16997typedef real (*R_fp)(); 16998typedef doublereal (*D_fp)(), (*E_fp)(); 16999typedef // Complex // void (*C_fp)(); 17000typedef // Double Complex // void (*Z_fp)(); 17001typedef logical (*L_fp)(); 17002typedef shortlogical (*K_fp)(); 17003typedef // Character // void (*H_fp)(); 17004typedef // Subroutine // int (*S_fp)(); 17005 17006// E_fp is for real functions when -R is not specified // 17007typedef void C_f; // complex function // 17008typedef void H_f; // character function // 17009typedef void Z_f; // double complex function // 17010typedef doublereal E_f; // real function with -R not specified // 17011 17012// undef any lower-case symbols that your C compiler predefines, e.g.: // 17013 17014 17015// (No such symbols should be defined in a strict ANSI C compiler. 17016 We can avoid trouble with f2c-translated code by using 17017 gcc -ansi [-traditional].) // 17018 17019 17020 17021 17022 17023 17024 17025 17026 17027 17028 17029 17030 17031 17032 17033 17034 17035 17036 17037 17038 17039 17040 17041// Main program // MAIN__() 17042{ 17043 // System generated locals // 17044 integer i__1; 17045 real r__1, r__2; 17046 doublereal d__1, d__2; 17047 complex q__1; 17048 doublecomplex z__1, z__2, z__3; 17049 logical L__1; 17050 char ch__1[1]; 17051 17052 // Builtin functions // 17053 void c_div(); 17054 integer pow_ii(); 17055 double pow_ri(), pow_di(); 17056 void pow_ci(); 17057 double pow_dd(); 17058 void pow_zz(); 17059 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), 17060 asin(), atan(), atan2(), c_abs(); 17061 void c_cos(), c_exp(), c_log(), r_cnjg(); 17062 double cos(), cosh(); 17063 void c_sin(), c_sqrt(); 17064 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), 17065 d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); 17066 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); 17067 logical l_ge(), l_gt(), l_le(), l_lt(); 17068 integer i_nint(); 17069 double r_sign(); 17070 17071 // Local variables // 17072 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), 17073 fool_(), fooz_(), getem_(); 17074 static char a1[10], a2[10]; 17075 static complex c1, c2; 17076 static doublereal d1, d2; 17077 static integer i1, i2; 17078 static real r1, r2; 17079 17080 17081 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); 17082// / // 17083 i__1 = i1 / i2; 17084 fooi_(&i__1); 17085 r__1 = r1 / i1; 17086 foor_(&r__1); 17087 d__1 = d1 / i1; 17088 food_(&d__1); 17089 d__1 = (doublereal) i1; 17090 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; 17091 fooc_(&q__1); 17092 r__1 = r1 / r2; 17093 foor_(&r__1); 17094 d__1 = r1 / d1; 17095 food_(&d__1); 17096 d__1 = d1 / d2; 17097 food_(&d__1); 17098 d__1 = d1 / r1; 17099 food_(&d__1); 17100 c_div(&q__1, &c1, &c2); 17101 fooc_(&q__1); 17102 q__1.r = c1.r / r1, q__1.i = c1.i / r1; 17103 fooc_(&q__1); 17104 z__1.r = c1.r / d1, z__1.i = c1.i / d1; 17105 fooz_(&z__1); 17106// ** // 17107 i__1 = pow_ii(&i1, &i2); 17108 fooi_(&i__1); 17109 r__1 = pow_ri(&r1, &i1); 17110 foor_(&r__1); 17111 d__1 = pow_di(&d1, &i1); 17112 food_(&d__1); 17113 pow_ci(&q__1, &c1, &i1); 17114 fooc_(&q__1); 17115 d__1 = (doublereal) r1; 17116 d__2 = (doublereal) r2; 17117 r__1 = pow_dd(&d__1, &d__2); 17118 foor_(&r__1); 17119 d__2 = (doublereal) r1; 17120 d__1 = pow_dd(&d__2, &d1); 17121 food_(&d__1); 17122 d__1 = pow_dd(&d1, &d2); 17123 food_(&d__1); 17124 d__2 = (doublereal) r1; 17125 d__1 = pow_dd(&d1, &d__2); 17126 food_(&d__1); 17127 z__2.r = c1.r, z__2.i = c1.i; 17128 z__3.r = c2.r, z__3.i = c2.i; 17129 pow_zz(&z__1, &z__2, &z__3); 17130 q__1.r = z__1.r, q__1.i = z__1.i; 17131 fooc_(&q__1); 17132 z__2.r = c1.r, z__2.i = c1.i; 17133 z__3.r = r1, z__3.i = 0.; 17134 pow_zz(&z__1, &z__2, &z__3); 17135 q__1.r = z__1.r, q__1.i = z__1.i; 17136 fooc_(&q__1); 17137 z__2.r = c1.r, z__2.i = c1.i; 17138 z__3.r = d1, z__3.i = 0.; 17139 pow_zz(&z__1, &z__2, &z__3); 17140 fooz_(&z__1); 17141// FFEINTRIN_impABS // 17142 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; 17143 foor_(&r__1); 17144// FFEINTRIN_impACOS // 17145 r__1 = acos(r1); 17146 foor_(&r__1); 17147// FFEINTRIN_impAIMAG // 17148 r__1 = r_imag(&c1); 17149 foor_(&r__1); 17150// FFEINTRIN_impAINT // 17151 r__1 = r_int(&r1); 17152 foor_(&r__1); 17153// FFEINTRIN_impALOG // 17154 r__1 = log(r1); 17155 foor_(&r__1); 17156// FFEINTRIN_impALOG10 // 17157 r__1 = r_lg10(&r1); 17158 foor_(&r__1); 17159// FFEINTRIN_impAMAX0 // 17160 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; 17161 foor_(&r__1); 17162// FFEINTRIN_impAMAX1 // 17163 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; 17164 foor_(&r__1); 17165// FFEINTRIN_impAMIN0 // 17166 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; 17167 foor_(&r__1); 17168// FFEINTRIN_impAMIN1 // 17169 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; 17170 foor_(&r__1); 17171// FFEINTRIN_impAMOD // 17172 r__1 = r_mod(&r1, &r2); 17173 foor_(&r__1); 17174// FFEINTRIN_impANINT // 17175 r__1 = r_nint(&r1); 17176 foor_(&r__1); 17177// FFEINTRIN_impASIN // 17178 r__1 = asin(r1); 17179 foor_(&r__1); 17180// FFEINTRIN_impATAN // 17181 r__1 = atan(r1); 17182 foor_(&r__1); 17183// FFEINTRIN_impATAN2 // 17184 r__1 = atan2(r1, r2); 17185 foor_(&r__1); 17186// FFEINTRIN_impCABS // 17187 r__1 = c_abs(&c1); 17188 foor_(&r__1); 17189// FFEINTRIN_impCCOS // 17190 c_cos(&q__1, &c1); 17191 fooc_(&q__1); 17192// FFEINTRIN_impCEXP // 17193 c_exp(&q__1, &c1); 17194 fooc_(&q__1); 17195// FFEINTRIN_impCHAR // 17196 *(unsigned char *)&ch__1[0] = i1; 17197 fooa_(ch__1, 1L); 17198// FFEINTRIN_impCLOG // 17199 c_log(&q__1, &c1); 17200 fooc_(&q__1); 17201// FFEINTRIN_impCONJG // 17202 r_cnjg(&q__1, &c1); 17203 fooc_(&q__1); 17204// FFEINTRIN_impCOS // 17205 r__1 = cos(r1); 17206 foor_(&r__1); 17207// FFEINTRIN_impCOSH // 17208 r__1 = cosh(r1); 17209 foor_(&r__1); 17210// FFEINTRIN_impCSIN // 17211 c_sin(&q__1, &c1); 17212 fooc_(&q__1); 17213// FFEINTRIN_impCSQRT // 17214 c_sqrt(&q__1, &c1); 17215 fooc_(&q__1); 17216// FFEINTRIN_impDABS // 17217 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; 17218 food_(&d__1); 17219// FFEINTRIN_impDACOS // 17220 d__1 = acos(d1); 17221 food_(&d__1); 17222// FFEINTRIN_impDASIN // 17223 d__1 = asin(d1); 17224 food_(&d__1); 17225// FFEINTRIN_impDATAN // 17226 d__1 = atan(d1); 17227 food_(&d__1); 17228// FFEINTRIN_impDATAN2 // 17229 d__1 = atan2(d1, d2); 17230 food_(&d__1); 17231// FFEINTRIN_impDCOS // 17232 d__1 = cos(d1); 17233 food_(&d__1); 17234// FFEINTRIN_impDCOSH // 17235 d__1 = cosh(d1); 17236 food_(&d__1); 17237// FFEINTRIN_impDDIM // 17238 d__1 = d_dim(&d1, &d2); 17239 food_(&d__1); 17240// FFEINTRIN_impDEXP // 17241 d__1 = exp(d1); 17242 food_(&d__1); 17243// FFEINTRIN_impDIM // 17244 r__1 = r_dim(&r1, &r2); 17245 foor_(&r__1); 17246// FFEINTRIN_impDINT // 17247 d__1 = d_int(&d1); 17248 food_(&d__1); 17249// FFEINTRIN_impDLOG // 17250 d__1 = log(d1); 17251 food_(&d__1); 17252// FFEINTRIN_impDLOG10 // 17253 d__1 = d_lg10(&d1); 17254 food_(&d__1); 17255// FFEINTRIN_impDMAX1 // 17256 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; 17257 food_(&d__1); 17258// FFEINTRIN_impDMIN1 // 17259 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; 17260 food_(&d__1); 17261// FFEINTRIN_impDMOD // 17262 d__1 = d_mod(&d1, &d2); 17263 food_(&d__1); 17264// FFEINTRIN_impDNINT // 17265 d__1 = d_nint(&d1); 17266 food_(&d__1); 17267// FFEINTRIN_impDPROD // 17268 d__1 = (doublereal) r1 * r2; 17269 food_(&d__1); 17270// FFEINTRIN_impDSIGN // 17271 d__1 = d_sign(&d1, &d2); 17272 food_(&d__1); 17273// FFEINTRIN_impDSIN // 17274 d__1 = sin(d1); 17275 food_(&d__1); 17276// FFEINTRIN_impDSINH // 17277 d__1 = sinh(d1); 17278 food_(&d__1); 17279// FFEINTRIN_impDSQRT // 17280 d__1 = sqrt(d1); 17281 food_(&d__1); 17282// FFEINTRIN_impDTAN // 17283 d__1 = tan(d1); 17284 food_(&d__1); 17285// FFEINTRIN_impDTANH // 17286 d__1 = tanh(d1); 17287 food_(&d__1); 17288// FFEINTRIN_impEXP // 17289 r__1 = exp(r1); 17290 foor_(&r__1); 17291// FFEINTRIN_impIABS // 17292 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; 17293 fooi_(&i__1); 17294// FFEINTRIN_impICHAR // 17295 i__1 = *(unsigned char *)a1; 17296 fooi_(&i__1); 17297// FFEINTRIN_impIDIM // 17298 i__1 = i_dim(&i1, &i2); 17299 fooi_(&i__1); 17300// FFEINTRIN_impIDNINT // 17301 i__1 = i_dnnt(&d1); 17302 fooi_(&i__1); 17303// FFEINTRIN_impINDEX // 17304 i__1 = i_indx(a1, a2, 10L, 10L); 17305 fooi_(&i__1); 17306// FFEINTRIN_impISIGN // 17307 i__1 = i_sign(&i1, &i2); 17308 fooi_(&i__1); 17309// FFEINTRIN_impLEN // 17310 i__1 = i_len(a1, 10L); 17311 fooi_(&i__1); 17312// FFEINTRIN_impLGE // 17313 L__1 = l_ge(a1, a2, 10L, 10L); 17314 fool_(&L__1); 17315// FFEINTRIN_impLGT // 17316 L__1 = l_gt(a1, a2, 10L, 10L); 17317 fool_(&L__1); 17318// FFEINTRIN_impLLE // 17319 L__1 = l_le(a1, a2, 10L, 10L); 17320 fool_(&L__1); 17321// FFEINTRIN_impLLT // 17322 L__1 = l_lt(a1, a2, 10L, 10L); 17323 fool_(&L__1); 17324// FFEINTRIN_impMAX0 // 17325 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; 17326 fooi_(&i__1); 17327// FFEINTRIN_impMAX1 // 17328 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; 17329 fooi_(&i__1); 17330// FFEINTRIN_impMIN0 // 17331 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; 17332 fooi_(&i__1); 17333// FFEINTRIN_impMIN1 // 17334 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; 17335 fooi_(&i__1); 17336// FFEINTRIN_impMOD // 17337 i__1 = i1 % i2; 17338 fooi_(&i__1); 17339// FFEINTRIN_impNINT // 17340 i__1 = i_nint(&r1); 17341 fooi_(&i__1); 17342// FFEINTRIN_impSIGN // 17343 r__1 = r_sign(&r1, &r2); 17344 foor_(&r__1); 17345// FFEINTRIN_impSIN // 17346 r__1 = sin(r1); 17347 foor_(&r__1); 17348// FFEINTRIN_impSINH // 17349 r__1 = sinh(r1); 17350 foor_(&r__1); 17351// FFEINTRIN_impSQRT // 17352 r__1 = sqrt(r1); 17353 foor_(&r__1); 17354// FFEINTRIN_impTAN // 17355 r__1 = tan(r1); 17356 foor_(&r__1); 17357// FFEINTRIN_impTANH // 17358 r__1 = tanh(r1); 17359 foor_(&r__1); 17360// FFEINTRIN_imp_CMPLX_C // 17361 r__1 = c1.r; 17362 r__2 = c2.r; 17363 q__1.r = r__1, q__1.i = r__2; 17364 fooc_(&q__1); 17365// FFEINTRIN_imp_CMPLX_D // 17366 z__1.r = d1, z__1.i = d2; 17367 fooz_(&z__1); 17368// FFEINTRIN_imp_CMPLX_I // 17369 r__1 = (real) i1; 17370 r__2 = (real) i2; 17371 q__1.r = r__1, q__1.i = r__2; 17372 fooc_(&q__1); 17373// FFEINTRIN_imp_CMPLX_R // 17374 q__1.r = r1, q__1.i = r2; 17375 fooc_(&q__1); 17376// FFEINTRIN_imp_DBLE_C // 17377 d__1 = (doublereal) c1.r; 17378 food_(&d__1); 17379// FFEINTRIN_imp_DBLE_D // 17380 d__1 = d1; 17381 food_(&d__1); 17382// FFEINTRIN_imp_DBLE_I // 17383 d__1 = (doublereal) i1; 17384 food_(&d__1); 17385// FFEINTRIN_imp_DBLE_R // 17386 d__1 = (doublereal) r1; 17387 food_(&d__1); 17388// FFEINTRIN_imp_INT_C // 17389 i__1 = (integer) c1.r; 17390 fooi_(&i__1); 17391// FFEINTRIN_imp_INT_D // 17392 i__1 = (integer) d1; 17393 fooi_(&i__1); 17394// FFEINTRIN_imp_INT_I // 17395 i__1 = i1; 17396 fooi_(&i__1); 17397// FFEINTRIN_imp_INT_R // 17398 i__1 = (integer) r1; 17399 fooi_(&i__1); 17400// FFEINTRIN_imp_REAL_C // 17401 r__1 = c1.r; 17402 foor_(&r__1); 17403// FFEINTRIN_imp_REAL_D // 17404 r__1 = (real) d1; 17405 foor_(&r__1); 17406// FFEINTRIN_imp_REAL_I // 17407 r__1 = (real) i1; 17408 foor_(&r__1); 17409// FFEINTRIN_imp_REAL_R // 17410 r__1 = r1; 17411 foor_(&r__1); 17412 17413// FFEINTRIN_imp_INT_D: // 17414 17415// FFEINTRIN_specIDINT // 17416 i__1 = (integer) d1; 17417 fooi_(&i__1); 17418 17419// FFEINTRIN_imp_INT_R: // 17420 17421// FFEINTRIN_specIFIX // 17422 i__1 = (integer) r1; 17423 fooi_(&i__1); 17424// FFEINTRIN_specINT // 17425 i__1 = (integer) r1; 17426 fooi_(&i__1); 17427 17428// FFEINTRIN_imp_REAL_D: // 17429 17430// FFEINTRIN_specSNGL // 17431 r__1 = (real) d1; 17432 foor_(&r__1); 17433 17434// FFEINTRIN_imp_REAL_I: // 17435 17436// FFEINTRIN_specFLOAT // 17437 r__1 = (real) i1; 17438 foor_(&r__1); 17439// FFEINTRIN_specREAL // 17440 r__1 = (real) i1; 17441 foor_(&r__1); 17442 17443} // MAIN__ // 17444 17445-------- (end output file from f2c) 17446 17447*/ 17448