/*
$Id$
Copyright 1989-2016 MINES ParisTech
This file is part of PIPS.
PIPS is free software: you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
any later version.
PIPS is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.
See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with PIPS. If not, see .
*/
#ifdef HAVE_CONFIG_H
#include "pips_config.h"
#endif
/*
Symbol table initialization with Fortran operators, commands and
intrinsics
More information is provided in effects/effects.c
Remi Triolet
Modifications :
---------------
- add intrinsics according to Fortran standard Table 5, pp. 15.22-15-25,
Francois Irigoin, 02/06/90
- add .SEQ. to handle ranges outside of arrays [pj]
- add intrinsic DFLOAT. bc. 13/1/96.
- add pseudo-intrinsics SUBSTR and ASSIGN_SUBSTR to handle strings,
FI, 25/12/96
- Fortran specification conformant typing of expressions...
Molka Becher (MB), June 2010
- Check of C intrinsics already added
- Add of missing C intrinsics according to ISO/IEC 9899:TC2
- Add of functions handling long double type and long double complex type
Molka Becher (MB), June 2010
- Check of C intrinsics already added
- Add of missing C intrinsics according to ISO/IEC 9899:TC2
- Add of functions handling long double type and long double complex type
Bugs:
-----
- intrinsics are not properly typed
*/
#include
#include
#include
#include
#include "linear.h"
#include "genC.h"
#include "ri.h"
#include "ri-util.h"
#include "database.h"
#include "bootstrap.h"
#include "misc.h"
#include "pipsdbm.h"
#include "parser_private.h"
#include "constants.h"
#include "resources.h"
#include "properties.h"
#define LOCAL static
#undef make_entity
/* Working with hash_table of basic
*/
#define GET_TYPE(h, e) ((basic)hash_get(h, (char*)(e)))
#define PUT_TYPE(h, e, b) hash_put(h, (char*)(e), (char*)(b))
/* Function in type_checker.c */
extern expression
insert_cast(basic cast, basic from, expression exp, type_context_p);
extern expression
cast_constant(expression exp_constant, basic to_basic,
type_context_p context);
extern bool
check_loop_range(range, hash_table);
extern void
type_loop_range(basic, range, type_context_p);
void CreateAreas()
{
make_entity(AddPackageToName(TOP_LEVEL_MODULE_NAME,
DYNAMIC_AREA_LOCAL_NAME),
make_type(is_type_area, make_area(0, NIL)),
make_storage(is_storage_rom, UU),
make_value(is_value_unknown, UU),
ABSTRACT_LOCATION|ENTITY_DYNAMIC_AREA);
make_entity(AddPackageToName(TOP_LEVEL_MODULE_NAME,
STATIC_AREA_LOCAL_NAME),
make_type(is_type_area, make_area(0, NIL)),
make_storage(is_storage_rom, UU),
make_value(is_value_unknown, UU),
ABSTRACT_LOCATION|ENTITY_STATIC_AREA);
}
static void CreateLogicalUnits()
{
/* First a dummy function - close to C one "crt0()" - in order to
- link the next entity to its ram
- make an unbounded dimension for this entity
*/
entity ent = entity_undefined;
entity luns = entity_undefined;
sequence s = make_sequence(NIL);
code c = make_code(NIL, strdup(""), s, NIL, make_language_unknown());
code_initializations(c) = s;
ent = make_entity(AddPackageToName(TOP_LEVEL_MODULE_NAME,
IO_EFFECTS_PACKAGE_NAME),
make_type(is_type_functional,
make_functional(NIL,make_type(is_type_void,
NIL))),
make_storage(is_storage_rom, UU),
make_value(is_value_code, c),
DEFAULT_ENTITY_KIND);
set_current_module_entity(ent);
make_entity(AddPackageToName(IO_EFFECTS_PACKAGE_NAME,
STATIC_AREA_LOCAL_NAME),
make_type(is_type_area, make_area(0, NIL)),
make_storage(is_storage_rom, UU),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE|ABSTRACT_LOCATION|ENTITY_STATIC_AREA);
/* GO: entity for io logical units: It is an array which*/
make_entity(AddPackageToName(IO_EFFECTS_PACKAGE_NAME,
IO_EFFECTS_ARRAY_NAME),
MakeTypeArray(make_basic_int(IO_EFFECTS_UNIT_SPECIFIER_LENGTH),
CONS(DIMENSION,
make_dimension
(int_to_expression(0),
/*
MakeNullaryCall
(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME))
*/
int_to_expression(2000),
NIL),
NIL)),
/* make_storage(is_storage_ram,
make_ram(entity_undefined, DynamicArea, 0, NIL))
*/
make_storage(is_storage_ram,
make_ram(ent,
FindEntity(IO_EFFECTS_PACKAGE_NAME,
STATIC_AREA_LOCAL_NAME),
0, NIL)),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE);
/* GO: entity for io logical units: It is an array which*/
make_entity(AddPackageToName(IO_EFFECTS_PACKAGE_NAME,
IO_EOF_ARRAY_NAME),
MakeTypeArray(make_basic_logical(IO_EFFECTS_UNIT_SPECIFIER_LENGTH),
CONS(DIMENSION,
make_dimension
(int_to_expression(0),
/*
MakeNullaryCall
(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME))
*/
int_to_expression(2000),
NIL),
NIL)),
/* make_storage(is_storage_ram,
make_ram(entity_undefined, DynamicArea, 0, NIL))
*/
make_storage(is_storage_ram,
make_ram(ent,
FindEntity(IO_EFFECTS_PACKAGE_NAME,
STATIC_AREA_LOCAL_NAME),
0, NIL)),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE);
/* GO: entity for io logical units: It is an array which*/
luns = make_entity(AddPackageToName(IO_EFFECTS_PACKAGE_NAME,
IO_ERROR_ARRAY_NAME),
MakeTypeArray(make_basic_logical(IO_EFFECTS_UNIT_SPECIFIER_LENGTH),
CONS(DIMENSION,
make_dimension
(int_to_expression(0),
/*
* MakeNullaryCall
* (CreateIntrinsic(UNBOUNDED_DIMENSION_NAME))
*/
int_to_expression(2000),
NIL),
NIL)),
/* make_storage(is_storage_ram,
* make_ram(entity_undefined, DynamicArea, 0, NIL))
*/
make_storage(is_storage_ram,
make_ram(ent,
FindEntity(IO_EFFECTS_PACKAGE_NAME,
STATIC_AREA_LOCAL_NAME),
0, NIL)),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE);
reset_current_module_entity();
add_abstract_state_variable(luns);
}
/* added to handle xxxrandxxx functions. Amira Mensi and then
generalized for other hidden libc variables
*/
static entity CreateAbstractStateVariable(string pn, string vn)
{
/* First a dummy function - close to C one "crt0()" - in order to
- link the next entity to its ram
- make an unbounded dimension for this entity
*/
entity ent = FindEntity(TOP_LEVEL_MODULE_NAME, pn);
entity as = entity_undefined;
sequence s = make_sequence(NIL);
code c = make_code(NIL, strdup(""), s, NIL, make_language_unknown());
code_initializations(c) = s;
if(entity_undefined_p(ent)) {
ent = make_entity(AddPackageToName(TOP_LEVEL_MODULE_NAME,
pn),
make_type(is_type_functional,
make_functional(NIL,make_type(is_type_void,
NIL))),
make_storage(is_storage_rom, UU),
make_value(is_value_code, c),
DEFAULT_ENTITY_KIND);
set_current_module_entity(ent);
make_entity(AddPackageToName(pn,
STATIC_AREA_LOCAL_NAME),
make_type(is_type_area, make_area(0, NIL)),
make_storage(is_storage_rom, UU),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE|ABSTRACT_LOCATION|ENTITY_STATIC_AREA);
}
else
set_current_module_entity(ent);
/* entity for random seed or other abstract states like heap: It is
an unsigned int. */
as = make_entity(AddPackageToName(pn, vn),
make_scalar_integer_type(DEFAULT_INTEGER_TYPE_SIZE),
/* make_storage(is_storage_ram,
make_ram(entity_undefined, DynamicArea, 0, NIL))
*/
make_storage(is_storage_ram,
make_ram(ent,
FindEntity(pn,
STATIC_AREA_LOCAL_NAME),
0, NIL)),
make_value(is_value_unknown, UU),
EFFECTS_PACKAGE);
reset_current_module_entity();
return as;
}
// added to handle xxxrandxxx functions.Amira Mensi
static void CreateRandomSeed()
{
entity as =
CreateAbstractStateVariable(RAND_EFFECTS_PACKAGE_NAME, RAND_GEN_EFFECTS_NAME);
//add_thread_safe_variable(as);
add_abstract_state_variable(as);
}
// added to handle time functions
static void CreateTimeSeed()
{
entity as =
CreateAbstractStateVariable(TIME_EFFECTS_PACKAGE_NAME, TIME_EFFECTS_VARIABLE_NAME);
add_abstract_state_variable(as);
entity asb =
CreateAbstractStateVariable(TIME_EFFECTS_PACKAGE_NAME, TIME_EFFECTS_BUFFER_NAME);
add_abstract_state_variable(asb);
}
static void CreateHeapAbstractState()
{
entity as =
CreateAbstractStateVariable(MALLOC_EFFECTS_PACKAGE_NAME, MALLOC_EFFECTS_NAME);
add_thread_safe_variable(as);
add_abstract_state_variable(as);
}
//Molka Becher : Added to handle Memmove function.
static void CreateMemmoveAbstractState()
{
entity as =
CreateAbstractStateVariable(MEMMOVE_EFFECTS_PACKAGE_NAME, MEMMOVE_EFFECTS_NAME);
add_thread_safe_variable(as);
add_abstract_state_variable(as);
}
static list
make_parameter_list(int n, parameter (* mkprm)(void))
{
list l = NIL;
if (n < (INT_MAX))
{
int i = n;
while (i-- > 0)
{
l = CONS(PARAMETER, mkprm(), l);
}
}
else
{
/* varargs */
parameter p = mkprm();
type pt = copy_type(parameter_type(p));
type v = make_type(is_type_varargs, pt);
parameter vp = make_parameter(v, make_mode(is_mode_reference, UU), make_dummy_unknown());
l = CONS(PARAMETER, vp, l);
free_parameter(p);
}
return l;
}
/* The default intrinsic type is a functional type with n overloaded
* arguments returning an overloaded result if the arity is known.
* If the arity is unknown, the default intrinsic type is a 0-ary
* functional type returning an overloaded result.
*/
static type
default_intrinsic_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
return t;
}
static type
overloaded_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
overloaded_to_real_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeRealResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
overloaded_to_double_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoubleprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
overloaded_to_longdouble_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeQuadprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
overloaded_to_complex_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeComplexResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
overloaded_to_doublecomplex_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoublecomplexResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
//static type
//overloaded_to_longdoublecomplex_type(int n) /* MB */
/*{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongDoublecomplexResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}*/
static type
overloaded_to_logical_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLogicalResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
/* to handle BTEST function which takes integer as parameter and
returns logical. Amira Mensi */
static type
integer_to_logical_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLogicalResult());
functional_parameters(ft) =
make_parameter_list(n, MakeIntegerParameter);
t = make_type(is_type_functional, ft);
return t;
}
/* Why do we make these functions static and keep them here instead of
populating ri-util/type.c? */
static type integer_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeIntegerParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type unsigned_integer_to_void_pointer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeVoidPointerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeUnsignedIntegerParameter);
t = make_type(is_type_functional, ft);
return t;
}
/* Can be used for C or Fortran functions. E.g. abort() */
static type void_to_void_type(int n __attribute__ ((unused)))
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, make_type_void(NIL));
functional_parameters(ft) =
CONS(PARAMETER, make_parameter(make_type_void(NIL),
make_mode_value(), // not
// significant
// for void...
make_dummy_unknown()), NIL);
t = make_type(is_type_functional, ft);
pips_assert("t is consistent", type_consistent_p(t));
return t;
}
/* C only because of pointer. e.g. atexit() */
static type void_to_void_to_int_pointer_type(int n __attribute__ ((unused)))
{
type t = type_undefined;
functional ft = functional_undefined;
type vtv = void_to_void_type(0);
type vtvp = type_to_pointer_type(vtv);
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
CONS(PARAMETER, make_parameter(vtvp,
make_mode_value(), // not
// significant
// for void...
make_dummy_unknown()), NIL);
t = make_type(is_type_functional, ft);
pips_assert("t is consistent", type_consistent_p(t));
return t;
}
/* C only because of pointer. e.g. atof() */
static type char_pointer_to_double_type(int n __attribute__ ((unused)))
{
type t = type_undefined;
functional ft = functional_undefined;
type cp = MakeCharacterResult();
//type cp = type_to_pointer_type(c);
type d = MakeDoubleprecisionResult();
variable_qualifiers(type_variable(cp))
= CONS(QUALIFIER, make_qualifier_const(), NIL);
ft = make_functional(NIL, d);
functional_parameters(ft) =
CONS(PARAMETER, make_parameter(cp,
make_mode_value(), // not
// significant
// for void...
make_dummy_unknown()), NIL);
t = make_type(is_type_functional, ft);
pips_assert("t is consistent", type_consistent_p(t));
return t;
}
static type integer_to_real_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeRealResult());
functional_parameters(ft) = make_parameter_list(n, MakeIntegerParameter);
t = make_type(is_type_functional, ft);
return t;
}
/*
static type
integer_to_double_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoubleprecisionResult());
functional_parameters(ft) = make_parameter_list(n, MakeIntegerParameter);
t = make_type(is_type_functional, ft);
return t;
}
*/
static type
real_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) = make_parameter_list(n, MakeRealParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
real_to_real_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeRealResult());
functional_parameters(ft) = make_parameter_list(n, MakeRealParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
real_to_double_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoubleprecisionResult());
functional_parameters(ft) = make_parameter_list(n, MakeRealParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
real_to_longinteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongIntegerResult());
functional_parameters(ft) = make_parameter_list(n, MakeRealParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
real_to_longlonginteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongLongIntegerResult());
functional_parameters(ft) = make_parameter_list(n, MakeRealParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
double_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
double_to_longinteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
double_to_longlonginteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longinteger_to_longinteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longlonginteger_to_longlonginteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
/*
static type
double_to_real_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeRealResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
// t = make_type(is_type_functional, ft);
return t;
}
*/
static type
double_to_double_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoubleprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoubleprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdouble_to_integer_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeQuadprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdouble_to_longinteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeQuadprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdouble_to_longlonginteger_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongLongIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeQuadprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdouble_to_longdouble_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeQuadprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeQuadprecisionParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
complex_to_real_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeRealResult());
functional_parameters(ft) = make_parameter_list(n, MakeComplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
doublecomplex_to_double_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoubleprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoublecomplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
complex_to_complex_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeComplexResult());
functional_parameters(ft) = make_parameter_list(n, MakeComplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
doublecomplex_to_doublecomplex_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeDoublecomplexResult());
functional_parameters(ft) =
make_parameter_list(n, MakeDoublecomplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdoublecomplex_to_longdoublecomplex_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLongDoublecomplexResult());
functional_parameters(ft) =
make_parameter_list(n, MakeLongDoublecomplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
longdoublecomplex_to_longdouble_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeQuadprecisionResult());
functional_parameters(ft) =
make_parameter_list(n, MakeLongDoublecomplexParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
character_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeCharacterParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
character_to_logical_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLogicalResult());
functional_parameters(ft) =
make_parameter_list(n, MakeCharacterParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
character_to_character_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeCharacterResult());
functional_parameters(ft) =
make_parameter_list(n, MakeCharacterParameter);
t = make_type(is_type_functional, ft);
return t;
}
static type
substring_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeCharacterResult());
functional_parameters(ft) =
CONS(PARAMETER, MakeIntegerParameter(), NIL);
functional_parameters(ft) =
CONS(PARAMETER, MakeIntegerParameter(),
functional_parameters(ft));
functional_parameters(ft) =
CONS(PARAMETER, MakeCharacterParameter(),
functional_parameters(ft));
t = make_type(is_type_functional, ft);
pips_assert("valid arity", (int)gen_length(functional_parameters(ft))==n);
return t;
}
static type
assign_substring_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeCharacterResult());
functional_parameters(ft) =
CONS(PARAMETER, MakeCharacterParameter(), NIL);
functional_parameters(ft) =
CONS(PARAMETER, MakeIntegerParameter(),
functional_parameters(ft));
functional_parameters(ft) =
CONS(PARAMETER, MakeIntegerParameter(),
functional_parameters(ft));
functional_parameters(ft) =
CONS(PARAMETER, MakeCharacterParameter(),
functional_parameters(ft));
t = make_type(is_type_functional, ft);
pips_assert("valid arity", (int)gen_length(functional_parameters(ft))==n);
return t;
}
static type
logical_to_logical_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeLogicalResult());
functional_parameters(ft) = make_parameter_list(n, MakeCharacterParameter);
t = make_type(is_type_functional, ft);
return t;
}
/***************************** TYPE A CALL FUNCTIONS **********************/
/*****************************************************************************
* Typing range of loop to the type of index loop.
* This range is already verified
*/
void type_loop_range(basic index, range r, type_context_p context)
{
basic lower, upper, incr;
lower = GET_TYPE(context->types, range_lower(r));
upper = GET_TYPE(context->types, range_upper(r));
incr = GET_TYPE(context->types, range_increment(r));
if(!basic_equal_p(index, lower))
{
range_lower(r) = insert_cast(index, lower, range_lower(r), context);
}
if(!basic_equal_p(index, upper))
{
range_upper(r) = insert_cast(index, upper, range_upper(r), context);
}
if(!basic_equal_p(index, incr))
{
range_increment(r) = insert_cast(index, incr, range_increment(r), context);
}
}
/**************************************************************************
* Convert a constant from INT to REAL
* e.g: REAL(10) --> 10.0
*/
static call convert_constant_from_int_to_real(call c)
{
char s[255];
strcpy(s, entity_local_name(call_function(c)));
strcat(s,".0E0");
return make_call(make_constant_entity((string)s,
is_basic_float, REAL_LENGTH),
NIL);
}
/* INT -> DOUBLE
* e.g: DBLE(10) => 10.0
*/
static call convert_constant_from_int_to_double(call c)
{
char s[255];
strcpy(s, entity_local_name(call_function(c)));
strcat(s,".0D0");
return make_call(make_constant_entity((string)s,
is_basic_float, DOUBLE_LENGTH),
NIL);
}
/* REAL -> INT
* e.g: INT(-5.9E2) => -590
*/
static call convert_constant_from_real_to_int(call c)
{
long l;
float r;
char s[255];
sscanf(entity_local_name(call_function(c)), "%f",&r);
l = (long)r;
sprintf(s, "%ld", l);
return make_call(make_constant_entity((string)s, is_basic_int, INT_LENGTH),
NIL);
}
/* REAL -> DOUBLE
* e.g: DBLE(-5.9E-2) => -5.9D-2
*/
static call convert_constant_from_real_to_double(call c)
{
char s[255];
int i, len;
strcpy(s, entity_local_name(call_function(c)));
len = strlen(s);
for(i = 0; i < len; i++)
{
if (s[i]=='E' || s[i]=='e')
{
s[i]='D';
break;
}
}
/* There is not E, e.g: 5.496 */
if (i == len)
{
strcat(s,"D0");
}
return make_call(make_constant_entity((string)s,
is_basic_float, DOUBLE_LENGTH),
NIL);
}
/* DOUBLE -> REAL
* e.g: REAL(-5.9D-2) => -5.9E-2
*/
static call convert_constant_from_double_to_real(call c)
{
char s[255];
int i, len;
strcpy(s, entity_local_name(call_function(c)));
len = strlen(s);
for(i = 0; i < len; i++)
{
if (s[i]=='D' || s[i]=='d')
{
s[i]='E';
break;
}
}
/* There is not D, e.g: 5.496 */
if (i == len)
{
strcat(s,"E0");
}
return make_call(make_constant_entity((string)s,
is_basic_float, REAL_LENGTH),
NIL);
}
/* DOUBLE -> INT
* e.g: INT(-5.9D2) => -590
*/
static call convert_constant_from_double_to_int(call c)
{
call c_result, c_real = convert_constant_from_double_to_real(c);
c_result = convert_constant_from_real_to_int(c_real);
free_call(c_real);
return c_result;
}
/* REAL -> COMPLEX
* e.g: CMPLX(-5.9E5) => (-5.9E5, 0.0)
*/
static call convert_constant_from_real_to_complex(call c)
{
expression exp_real, exp_imag;
call c_imag;
list args;
exp_real = make_expression(make_syntax(is_syntax_call, copy_call(c)),
normalized_undefined);
c_imag = make_call(make_constant_entity("0.0E0",
is_basic_float, REAL_LENGTH),
NIL);
exp_imag = make_expression(make_syntax(is_syntax_call, c_imag),
normalized_undefined);
args = CONS(EXPRESSION, exp_real, CONS(EXPRESSION, exp_imag, NIL));
/* Conversion explicit */
if (get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS"))
{
return make_call(CreateIntrinsic(CMPLX_GENERIC_CONVERSION_NAME), args);
}
/* Conversion inplicit */
return make_call(CreateIntrinsic(IMPLIED_COMPLEX_NAME), args);
}
/* DOUBLE -> COMPLEX
* e.g: CMPLX(-5.9D5) => (-5.9E5, 0.0)
*/
static call convert_constant_from_double_to_complex(call c)
{
call c_result, c_real = convert_constant_from_double_to_real(c);
c_result = convert_constant_from_real_to_complex(c_real);
free_call(c_real);
return c_result;
}
/* INT -> COMPLEX
* e.g: CMPLX(-5) => (-5.0, 0.0)
*/
static call convert_constant_from_int_to_complex(call c)
{
call c_result, c_real = convert_constant_from_int_to_real(c);
c_result = convert_constant_from_real_to_complex(c_real);
free_call(c_real);
return c_result;
}
/* DOUBLE -> DCOMPLEX
* e.g: DCMPLX(-5.9D5) => (-5.9D5, 0.0)
*/
static call convert_constant_from_double_to_dcomplex(call c)
{
expression exp_real, exp_imag;
call c_imag;
list args;
exp_real = make_expression(make_syntax(is_syntax_call, copy_call(c)),
normalized_undefined);
c_imag = make_call(make_constant_entity("0.0D0",
is_basic_float, DOUBLE_LENGTH),
NIL);
exp_imag = make_expression(make_syntax(is_syntax_call, c_imag),
normalized_undefined);
args = CONS(EXPRESSION, exp_real, CONS(EXPRESSION, exp_imag, NIL));
/* Conversion explicit */
if (get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS"))
{
return make_call(CreateIntrinsic(DCMPLX_GENERIC_CONVERSION_NAME), args);
}
/* Conversion inplicit */
return make_call(CreateIntrinsic(IMPLIED_DCOMPLEX_NAME), args);
}
/* REAL -> DCOMPLEX
* e.g: DCMPLX(-5.9E5) => (-5.9D5, 0.0D0)
*/
static call convert_constant_from_real_to_dcomplex(call c)
{
call c_result, c_double = convert_constant_from_real_to_double(c);
c_result = convert_constant_from_double_to_dcomplex(c_double);
free_call(c_double);
return c_result;
}
/* INT -> DCOMPLEX
* e.g: DCMPLX(-5) => (-5D0, 0.0D0)
*/
static call convert_constant_from_int_to_dcomplex(call c)
{
call c_result, c_double = convert_constant_from_int_to_double(c);
c_result = convert_constant_from_double_to_dcomplex(c_double);
free_call(c_double);
return c_result;
}
/*****************************************************************************
* Convert constant C to basic naming to_basic
*/
call convert_constant(call c, basic to_basic)
{
basic b;
entity function_called = call_function(c);
if(entity_constant_p(function_called))
{
b = entity_basic(function_called);
if(basic_equal_p(b, to_basic))
{
//return NULL;
return copy_call(c);
}
else if (basic_int_p(b))
{
/* INT -> REAL */
if (basic_float_p(to_basic) && basic_float(to_basic)==4)
{
return convert_constant_from_int_to_real(c);
}
/* INT -> DOUBLE */
if (basic_float_p(to_basic) && basic_float(to_basic)==8)
{
return convert_constant_from_int_to_double(c);
}
/* INT -> COMPLEX */
if (basic_complex_p(to_basic) && basic_complex(to_basic)==8)
{
return convert_constant_from_int_to_complex(c);
}
/* INT -> DCOMPLEX */
if (basic_complex_p(to_basic) && basic_complex(to_basic)==16)
{
return convert_constant_from_int_to_dcomplex(c);
}
}
else if (basic_float_p(b) && basic_float(b)==4)
{
/* REAL -> INT */
if (basic_int_p(to_basic))
{
return convert_constant_from_real_to_int(c);
}
/* REAL -> DOUBLE */
else if (basic_float_p(to_basic) && basic_float(to_basic)==8)
{
return convert_constant_from_real_to_double(c);
}
/* REAL -> COMPLEX */
else if (basic_complex_p(to_basic) && basic_complex(to_basic)==8)
{
return convert_constant_from_real_to_complex(c);
}
/* REAL -> DCOMPLEX */
else if (basic_complex_p(to_basic) && basic_complex(to_basic)==16)
{
return convert_constant_from_real_to_dcomplex(c);
}
}
else if (basic_float_p(b) && basic_float(b)==8)
{
/* DOUBLE -> INT */
if (basic_int_p(to_basic))
{
return convert_constant_from_double_to_int(c);
}
/* DOUBLE -> REAL */
else if (basic_float_p(to_basic) && basic_float(to_basic)==4)
{
return convert_constant_from_double_to_real(c);
}
/* DOUBLE -> COMPLEX */
else if (basic_complex_p(to_basic) && basic_complex(to_basic)==8)
{
return convert_constant_from_double_to_complex(c);
}
/* DOUBLE -> DCOMPLEX */
else if (basic_complex_p(to_basic) && basic_complex(to_basic)==16)
{
return convert_constant_from_double_to_dcomplex(c);
}
}
}
return NULL;
}
/*****************************************************************************
* Cast an expression constant to the basic to_basic.
* Return true if OK
*/
expression
cast_constant(expression exp_constant, basic to_basic, type_context_p context)
{
entity function_called;
call c;
basic b = NULL;
expression exp, exp_real, exp_imag, exp_real2, exp_imag2;
syntax s = expression_syntax(exp_constant);
if(syntax_call_p(s))
{
function_called = call_function(syntax_call(s));
if(entity_constant_p(function_called))
{
/* Convert if necessary */
c = convert_constant(syntax_call(s), to_basic);
if (c != NULL)
{
context->number_of_simplication++;
return make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
}
else if(ENTITY_UNARY_MINUS_P(function_called))
{
exp = cast_constant(EXPRESSION(CAR(call_arguments(syntax_call(s)))),
to_basic, context);
if (exp != NULL)
{
c = make_call(copy_entity(function_called),
CONS(EXPRESSION, exp, NIL));
return make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
}
else if(ENTITY_IMPLIED_CMPLX_P(function_called) ||
ENTITY_CONVERSION_CMPLX_P(function_called) ||
ENTITY_IMPLIED_DCMPLX_P(function_called) ||
ENTITY_CONVERSION_DCMPLX_P(function_called))
{
exp_real = EXPRESSION(CAR(call_arguments(syntax_call(s))));
/* Two arguments, with imagine party */
if (CDR(call_arguments(syntax_call(s))) != NIL )
{
exp_imag = EXPRESSION(CAR(CDR(call_arguments(syntax_call(s)))));
}
/* One argument, no imagine party */
else
{
exp_imag = NULL;
}
if (!basic_complex_p(to_basic))
{
return cast_constant(exp_real, to_basic, context);
}
/* DCOMPLEX -> COMPLEX */
else if (basic_complex(to_basic) == 8 &&
(ENTITY_IMPLIED_DCMPLX_P(function_called) ||
ENTITY_CONVERSION_DCMPLX_P(function_called)))
{
b = make_basic_float(4);
if ((exp_real2 = cast_constant(exp_real, b, context)) == NULL)
{
exp_real2 = exp_real;
}
if (exp_imag != NULL)
{
if ((exp_imag2 = cast_constant(exp_imag, b, context)) == NULL)
{
exp_imag2 = exp_imag;
}
}
else
{
c = make_call(make_constant_entity("0.0E0", is_basic_float,
REAL_LENGTH),
NIL);
exp_imag2 = make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
/* Conversion implicit */
if (!get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS") &&
ENTITY_IMPLIED_DCMPLX_P(function_called))
{
c = make_call(CreateIntrinsic(IMPLIED_COMPLEX_NAME),
CONS(EXPRESSION, exp_real2,
CONS(EXPRESSION, exp_imag2, NIL)));
}
/* Conversion explicit */
else
{
c = make_call(CreateIntrinsic(CMPLX_GENERIC_CONVERSION_NAME),
CONS(EXPRESSION, exp_real2,
CONS(EXPRESSION, exp_imag2, NIL)));
}
return make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
/* COMPLEX -> DCOMPLEX */
else if (basic_complex(to_basic) == 16 &&
(ENTITY_IMPLIED_CMPLX_P(function_called) ||
ENTITY_CONVERSION_CMPLX_P(function_called)))
{
b = make_basic_float(8);
if ((exp_real2 = cast_constant(exp_real, b, context)) == NULL)
{
exp_real2 = exp_real;
}
if (exp_imag != NULL)
{
if ((exp_imag2 = cast_constant(exp_imag, b, context)) == NULL)
{
exp_imag2 = exp_imag;
}
}
else
{
c = make_call(make_constant_entity("0.0D0", is_basic_float,
DOUBLE_LENGTH),
NIL);
exp_imag2 = make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
/* Conversion implicit */
if (!get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS") &&
ENTITY_IMPLIED_CMPLX_P(function_called))
{
c = make_call(CreateIntrinsic(IMPLIED_DCOMPLEX_NAME),
CONS(EXPRESSION, exp_real2,
CONS(EXPRESSION, exp_imag2, NIL)));
}
/* Conversion explicit */
else
{
c = make_call(CreateIntrinsic(DCMPLX_GENERIC_CONVERSION_NAME),
CONS(EXPRESSION, exp_real2,
CONS(EXPRESSION, exp_imag2, NIL)));
}
return make_expression(make_syntax(is_syntax_call, c),
normalized_undefined);
}
}
}
if (b != NULL)
{
free_basic(b);
}
return NULL;
}
/*****************************************************************************
* Specify a cast for converting from a basic ('from') to another basic (cast)
*/
static entity
get_cast_function_for_basic(basic cast, basic from)
{
switch (basic_tag(cast))
{
case is_basic_int:
if (from!=NULL && from!=basic_undefined && basic_string_p(from))
{
return CreateIntrinsic(CHAR_TO_INT_CONVERSION_NAME);
}
else
{
switch(basic_int(cast))
{
case 2:
case 4:
case 8:
return CreateIntrinsic(INT_GENERIC_CONVERSION_NAME) ;
default:
pips_internal_error("Unexpected integer size %d", basic_int(cast));
}
}
break;
case is_basic_float:
switch(basic_float(cast))
{
case 4:
return CreateIntrinsic(REAL_GENERIC_CONVERSION_NAME) ;
case 8:
return CreateIntrinsic(DBLE_GENERIC_CONVERSION_NAME) ;
default:
pips_internal_error("Unexpected float size %d", basic_float(cast));
}
break;
case is_basic_logical:
switch(basic_logical(cast))
{
case 1:
case 2:
case 4:
case 8:
return entity_undefined;
default:
pips_internal_error("Unexpected logical size %d", basic_logical(cast));
}
break;
case is_basic_complex:
switch(basic_complex(cast))
{
case 8:
return CreateIntrinsic(CMPLX_GENERIC_CONVERSION_NAME) ;
case 16:
return CreateIntrinsic(DCMPLX_GENERIC_CONVERSION_NAME) ;
default:
pips_internal_error("Unexpected complex size %d", basic_complex(cast));
}
break;
case is_basic_string:
return CreateIntrinsic(INT_TO_CHAR_CONVERSION_NAME);
case is_basic_overloaded:
pips_internal_error("Should never convert to overloaded...");
default:
pips_internal_error("Unexpected basic tag (%d)", basic_tag(cast));
}
return NULL;
}
/*****************************************************************************
* Cast an expression
* e.g: x --> INT(x)
*/
expression
insert_cast(basic cast, basic from, expression exp, type_context_p context)
{
call c;
syntax s;
entity cast_function;
expression exp_constant;
s = expression_syntax(exp);
/* If exp is a constant -> Convert it
* e.g: 5.9 -> 5 (REAL -> INT)
*/
if ((exp_constant = cast_constant(exp, cast, context)) != NULL)
{
return exp_constant;
}
/* If not */
cast_function = get_cast_function_for_basic(cast, from);
if (cast_function == NULL)
{
pips_internal_error("Cast function is not verified!");
}
if (cast_function == entity_undefined)
{
pips_internal_error("Can not convert to LOGICAL!");
}
c = make_call(cast_function, CONS(EXPRESSION, exp, NIL));
s = make_syntax(is_syntax_call, c);
/* Count the number of conversions */
context->number_of_conversion++;
return make_expression(s, normalized_undefined);
}
/* Type check double complex? */
#define TC_DCOMPLEX \
get_bool_property("TYPE_CHECKER_DOUBLE_COMPLEX_EXTENSION")
/* MB : Type check long double complex */
#define TC_LONGDCOMPLEX \
get_bool_property("TYPE_CHECKER_LONG_DOUBLE_COMPLEX_EXTENSION")
/* Determine the longest basic among the arguments of c
*/
static basic
basic_union_arguments(call c, hash_table types)
{
basic b2, b1 = basic_undefined;
MAP(EXPRESSION, e,
{
if (b1==basic_undefined)
{
/* first time */
b1 = GET_TYPE(types, e);
}
else
{
/* after first argument */
b2 = GET_TYPE(types, e);
if (is_inferior_basic(b1, b2))
b1 = b2;
}
},
call_arguments(c));
return b1==basic_undefined? b1: copy_basic(b1);
}
/************* CHECK THE VALIDE OF ARGUMENTS BASIC OF FUNCTION ************/
/* Verify if all the arguments basic of function C are INTEGER
* If there is no argument, I return TRUE
*/
static bool
check_if_basics_ok(list le, hash_table types, bool(*basic_ok)(basic))
{
MAP(EXPRESSION, e,
{
if (!basic_ok(GET_TYPE(types, e)))
{
return false;
}
}
, le);
return true;
}
static bool
is_basic_int_p(basic b)
{
return basic_int_p(b) && basic_int(b)==4;
}
static bool
is_basic_longint_p(basic b) /* MB */
{
return basic_int_p(b) && basic_int(b)==6;
}
static bool
is_basic_longlongint_p(basic b) /* MB */
{
return basic_int_p(b) && basic_int(b)==8;
}
static bool
is_basic_real_p(basic b)
{
return basic_float_p(b) && basic_float(b)==4;
}
static bool
is_basic_double_p(basic b)
{
return basic_float_p(b) && basic_float(b)==8;
}
static bool
is_basic_longdouble_p(basic b) /* MB */
{
return basic_float_p(b) && basic_float(b)==16;
}
static bool
is_basic_complex_p(basic b)
{
return basic_complex_p(b) && basic_complex(b)==8;
}
static bool
is_basic_dcomplex_p(basic b)
{
return basic_complex_p(b) && basic_complex(b)==16;
}
static bool
is_basic_longdcomplex_p(basic b) /* MB */
{
return basic_complex_p(b) && basic_complex(b)==32;
}
static bool
arguments_are_integer(call c, hash_table types)
{
return check_if_basics_ok(call_arguments(c), types, is_basic_int_p);
}
static bool
arguments_are_longinteger(call c, hash_table types) /* MB */
{
return check_if_basics_ok(call_arguments(c), types, is_basic_longint_p);
}
static bool
arguments_are_longlonginteger(call c, hash_table types) /* MB */
{
return check_if_basics_ok(call_arguments(c), types, is_basic_longlongint_p);
}
static bool
arguments_are_real(call c, hash_table types)
{
return check_if_basics_ok(call_arguments(c), types, is_basic_real_p);
}
static bool
arguments_are_double(call c, hash_table types)
{
return check_if_basics_ok(call_arguments(c), types, is_basic_double_p);
}
static bool
arguments_are_longdouble(call c, hash_table types) /* MB */
{
return check_if_basics_ok(call_arguments(c), types, is_basic_longdouble_p);
}
static bool
arguments_are_complex(call c, hash_table types)
{
return check_if_basics_ok(call_arguments(c), types, is_basic_complex_p);
}
static bool
arguments_are_dcomplex(call c, hash_table types)
{
return check_if_basics_ok(call_arguments(c), types, is_basic_dcomplex_p);
}
static bool
arguments_are_longdcomplex(call c, hash_table types) /* MB */
{
return check_if_basics_ok(call_arguments(c), types, is_basic_longdcomplex_p);
}
/**************************************************************************
* Verify if all the arguments basic of function C
* If there is no argument, I return TRUE
*
* Note: I - Integer; R - Real; D - Double; C - Complex;
*/
/* Molka Becher: add of long int, long long int, long double and long
double complex types */
static bool
arguments_are_something(
call c,
type_context_p context,
bool integer_ok,
bool longinteger_ok,
bool longlonginteger_ok,
bool real_ok,
bool double_ok,
bool longdouble_ok,
bool complex_ok,
bool dcomplex_ok,
bool longdcomplex_ok,
bool logical_ok,
bool character_ok)
{
basic b;
int argnumber = 0;
bool
okay = true,
arg_double = false,
arg_cmplx = false;
list args = call_arguments(c);
FOREACH(EXPRESSION, e, args)
{
argnumber++;
pips_assert("type is defined", hash_defined_p(context->types, e));
b = GET_TYPE(context->types, e);
/* Subroutine maybe be used as a function */
if (basic_overloaded_p(b))
{
syntax s = expression_syntax(e);
const char* what ;
switch (syntax_tag(s)) {
case is_syntax_call:
what = entity_local_name(call_function(syntax_call(s)));
break;
case is_syntax_reference:
what = entity_local_name(reference_variable(syntax_reference(s)));
break;
case is_syntax_range:
what = "**RANGE**";
break;
default: pips_internal_error("unexpected syntax tag");
}
add_one_line_of_comment((statement) stack_head(context->stats),
"not typed '%s' used as a function.",
what, entity_local_name(call_function(c)));
context->number_of_error++;
okay = false;
}
else if (!((integer_ok && basic_int_p(b) && basic_int(b)==4) ||
(longinteger_ok && basic_int_p(b) && basic_int(b)==6) ||
(longlonginteger_ok && basic_int_p(b) && basic_int(b)==8) ||
(real_ok && basic_float_p(b) && basic_float(b)==4) ||
(double_ok && basic_float_p(b) && basic_float(b)==8) ||
(longdouble_ok && basic_float_p(b) && basic_float(b)==16) ||
(complex_ok && basic_complex_p(b) && basic_complex(b)==8) ||
(dcomplex_ok && basic_complex_p(b) && basic_complex(b)==16) ||
(longdcomplex_ok && basic_complex_p(b) && basic_complex(b)==32) ||
(logical_ok && basic_logical_p(b)) ||
(character_ok && basic_string_p(b))))
{
/* The message should be language dependent, C or Fortran */
if(fortran_language_module_p(get_current_module_entity())) {
add_one_line_of_comment((statement) stack_head(context->stats),
"#%d argument of '%s' must be "
"%s%s%s%s%s%s%s%s%s%s%s but not %s",
argnumber,
entity_local_name(call_function(c)),
integer_ok? "INT, ": "",
// The next two types are not used
// for Fortran
longinteger_ok? "": "",
longlonginteger_ok? "": "",
real_ok? "REAL, ": "",
double_ok? "DOUBLE, ": "",
// FI: Used to be QUAD. Exists or not?
//longdouble_ok? "DOUBLE*16, ": "",
longdouble_ok? "": "",
complex_ok? "COMPLEX, ": "",
dcomplex_ok? "DCOMPLEX, ": "",
// FI: what should it be in Fortran?
longdcomplex_ok? "": "",
logical_ok? "LOGICAL, ": "",
character_ok? "CHARACTER, ": "",
basic_to_string(b));
} else { /* Assume C */
/* FI: assumes no pointers ever; still pretty much
Fortran stuff */
add_one_line_of_comment((statement) stack_head(context->stats),
"#%d argument of '%s' must be "
"%s%s%s%s%s%s%s%s%s%s%s but not %s",
argnumber,
entity_local_name(call_function(c)),
integer_ok? "int, ": "",
longinteger_ok? "long int, ": "",
longlonginteger_ok? "long long int, ": "",
real_ok? "float, ": "",
double_ok? "double, ": "",
longdouble_ok? "long double, ": "",
complex_ok? "complex, ": "",
dcomplex_ok? "double complex, ": "",
longdcomplex_ok? "long double complex, ": "",
logical_ok? "bool, ": "",
/* FI: nothing about strings? */
character_ok? "char, ": "",
basic_to_string(b));
}
context->number_of_error++;
okay = false;
}
/* if TC_DCOMPLEX, maybe they should not be incompatible? */
arg_cmplx = arg_cmplx ||
(complex_ok && basic_complex_p(b) && basic_complex(b)==8);
arg_double = arg_double ||
(double_ok && basic_float_p(b) && basic_float(b)==8);
}
if (arg_cmplx && arg_double)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"mixed complex and double arguments of '%s' forbidden",
entity_local_name(call_function(c)));
context->number_of_error++;
okay = false;
}
return okay;
}
static bool
arguments_are_IRDCS(call c, type_context_p context)
{
return arguments_are_something
(c, context, true, true, true, true, true, true, true, TC_DCOMPLEX, TC_LONGDCOMPLEX, false, true);
}
static bool
arguments_are_IRDC(call c, type_context_p context)
{
return arguments_are_something
(c, context, true, true, true, true, true, true, true, TC_DCOMPLEX, TC_LONGDCOMPLEX, false, false);
}
static bool
arguments_are_character(call c, type_context_p context)
{
return arguments_are_something
(c, context, false, false, false, false, false, false, false, false, false, false, true);
}
static bool
arguments_are_logical(call c, type_context_p context)
{
return arguments_are_something
(c, context, false, false, false, false, false, false, false, false, false, true, false);
}
static bool
arguments_are_RD(call c, type_context_p context)
{
return arguments_are_something
(c, context, false, false, false, true, true, true, false, false, false, false, false);
}
static bool
arguments_are_IR(call c, type_context_p context)
{
return arguments_are_something
(c, context, true, true, true, true, false, false, false, false, false, false, false);
}
static bool
arguments_are_IRD(call c, type_context_p context)
{
return arguments_are_something
(c, context, true, true, true, true, true, true, false, false, false, false, false);
}
/**************************************************************************
* Verify if all the arguments basic of function C are REAL, DOUBLE
* and COMPLEX
* According to (ANSI X3.9-1978 FORTRAN 77, Table 2 & 3, Page 6-5 & 6-6),
* it is prohibited an arithetic operator operaters on
* a pair of DOUBLE and COMPLEX, so that I return false in that case.
*
* PDSon: If there is no argument, I return TRUE
*/
static bool
arguments_are_RDC(call c, type_context_p context)
{
return arguments_are_something
(c, context, false, false, false, true, true, true, true, TC_DCOMPLEX, TC_LONGDCOMPLEX, false, false);
}
/**************************************************************************
* Verification if all the arguments are compatible
* PDSon: If #arguments <=1, I return true
*/
bool
arguments_are_compatible(call c, hash_table types)
{
basic b1, b2;
b1 = basic_undefined;
MAP(EXPRESSION, e,
{
/* First item */
if(basic_undefined_p(b1))
{
b1 = GET_TYPE(types, e);
}
/* Next item */
else
{
b2 = GET_TYPE(types, e);
if(!basic_compatible_p(b1, b2))
{
return false;
}
}
}
, call_arguments(c));
return true;
}
/**************************************************************************
* Typing all the arguments of c to basic b if their basic <> b
*/
static void
typing_arguments(call c, type_context_p context, basic b)
{
basic b1;
list args = call_arguments(c);
while (args != NIL)
{
b1 = GET_TYPE(context->types, EXPRESSION(CAR(args)));
if (!basic_equal_p(b, b1))
{
EXPRESSION_(CAR(args)) =
insert_cast(b, b1, EXPRESSION(CAR(args)), context);
/* Update hash table */
PUT_TYPE(context->types, EXPRESSION(CAR(args)), copy_basic(b));
}
args = CDR(args);
}
}
/**************************************************************************
* TYPING THE INTRINSIC FUNCTIONS
* Typing arithmetic operator (+, -, --, *, /), except **
*/
static basic
typing_arithmetic_operator(call c, type_context_p context)
{
basic b;
if(!arguments_are_IRDC(c, context))
{
/* Just for return a result */
return make_basic_float(4);
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
return b;
}
/**************************************************************************
* Typing power operator (**)
*/
static basic
typing_power_operator(call c, type_context_p context)
{
basic b, b1, b2;
list /* of expression */ args = call_arguments(c);
b = basic_undefined;
if(!arguments_are_IRDC(c, context))
{
/* Just for return a result */
return make_basic_float(4);
}
b1 = GET_TYPE(context->types, EXPRESSION(CAR(args)));
b2 = GET_TYPE(context->types, EXPRESSION(CAR(CDR(args))));
if (is_inferior_basic(b1, b2))
{
b = b2;
}
else
{
b = b1;
}
if (!basic_equal_p(b, b1))
{
EXPRESSION_(CAR(args)) =
insert_cast(b, b1, EXPRESSION(CAR(args)), context);
}
/* Fortran prefers: (ANSI X3.9-1978, FORTRAN 77, PAGE 6-6, TABLE 3)
* "var_double = var_double ** var_int" instead of
* "var_double = var_double ** DBLE(var_int)"
*/
if (!basic_equal_p(b, b2) && !basic_int_p(b2))
{
EXPRESSION_(CAR(CDR(args))) =
insert_cast(b, b2, EXPRESSION(CAR(CDR(args))), context);
}
return copy_basic(b);
}
/**************************************************************************
* Typing relational operator (LT, LE, EQ, GT, GE)
*/
static basic
typing_relational_operator(call c, type_context_p context)
{
basic b;
if(!arguments_are_IRDCS(c, context))
{
/* Just for return a result */
return make_basic_logical(4);
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
free_basic(b);
return make_basic_logical(4);
}
/**************************************************************************
* Typing logical operator (NOT, AND, OR, EQV, NEQV)
*/
static basic
typing_logical_operator(call c, type_context_p context)
{
if(!arguments_are_logical(c, context))
{
/* Just for return a result */
return make_basic_logical(4);
}
return make_basic_logical(4);
}
/**************************************************************************
* Typing concatenate operator (//)
*/
static basic
typing_concat_operator(call c, type_context_p context)
{
if(!arguments_are_character(c, context))
{
/* Just for return a result */
return make_basic_string(value_undefined);
}
return make_basic_string(value_undefined);
}
/**************************************************************************
* Typing function C whose argument type is from_type and
* whose return type is to_type
*/
static basic
typing_function_argument_type_to_return_type(call c, type_context_p context,
basic from_type, basic to_type)
{
bool check_arg = false;
/* INT */
if(basic_int_p(from_type) && basic_int(from_type) == 4)
{
check_arg = arguments_are_integer(c, context->types);
}
/* LONG INT : added by MB */
else if(basic_int_p(from_type) && basic_int(from_type) == 6)
{
check_arg = arguments_are_longinteger(c, context->types);
}
/* LONG LONG INT */
else if(basic_int_p(from_type) && basic_int(from_type) == 8)
{
check_arg = arguments_are_longlonginteger(c, context->types);
}
/* REAL */
else if(basic_float_p(from_type) && basic_float(from_type) == 4)
{
check_arg = arguments_are_real(c, context->types);
}
/* DOUBLE */
else if(basic_float_p(from_type) && basic_float(from_type) == 8)
{
check_arg = arguments_are_double(c, context->types);
}
/* LONG DOUBLE : added by MB */
else if(basic_float_p(from_type) && basic_float(from_type) == 16)
{
check_arg = arguments_are_longdouble(c, context->types);
}
/* COMPLEX */
else if(basic_complex_p(from_type) && basic_complex(from_type) == 8)
{
check_arg = arguments_are_complex(c, context->types);
}
/* DOUBLE COMPLEX */
else if(basic_complex_p(from_type) && basic_complex(from_type) == 16)
{
if (TC_DCOMPLEX)
check_arg = arguments_are_dcomplex(c, context->types);
}
/* LONG DOUBLE COMPLEX : added by MB*/
else if(basic_complex_p(from_type) && basic_complex(from_type) == 32)
{
if (TC_LONGDCOMPLEX)
check_arg = arguments_are_longdcomplex(c, context->types);
}
/* CHAR */
else if(basic_string_p(from_type))
{
check_arg = arguments_are_character(c, context);
}
/* LOGICAL */
else if(basic_logical_p(from_type))
{
check_arg = arguments_are_logical(c, context);
}
/* UNEXPECTED */
else
{
pips_internal_error("Unexpected basic: %s ",
basic_to_string(from_type));
}
/* ERROR: Invalide of argument type */
if(check_arg == false)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Invalid argument(s) to '%s'!",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
return copy_basic(to_type);
}
static basic
typing_function_int_to_int(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
result = typing_function_argument_type_to_return_type(c, context,
type_INT, type_INT);
free_basic(type_INT);
return result;
}
static basic
typing_function_longint_to_longint(call c, type_context_p context) /* MB */
{
basic result, type_LINT = make_basic_int(6);
result = typing_function_argument_type_to_return_type(c, context,
type_LINT, type_LINT);
free_basic(type_LINT);
return result;
}
static basic
typing_function_longlongint_to_longlongint(call c, type_context_p context) /* MB */
{
basic result, type_LLINT = make_basic_int(8);
result = typing_function_argument_type_to_return_type(c, context,
type_LLINT, type_LLINT);
free_basic(type_LLINT);
return result;
}
static basic
typing_function_real_to_real(call c, type_context_p context)
{
basic result, type_REAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_REAL, type_REAL);
free_basic(type_REAL);
return result;
}
static basic
typing_function_double_to_double(call c, type_context_p context)
{
basic result, type_DBLE = make_basic_float(8);
result = typing_function_argument_type_to_return_type(c, context,
type_DBLE, type_DBLE);
free_basic(type_DBLE);
return result;
}
static basic
typing_function_longdouble_to_longdouble(call c, type_context_p context) /* MB */
{
basic result, type_LDBLE = make_basic_float(16);
result = typing_function_argument_type_to_return_type(c, context,
type_LDBLE, type_LDBLE);
free_basic(type_LDBLE);
return result;
}
static basic
typing_function_complex_to_complex(call c, type_context_p context)
{
basic result, type_CMPLX = make_basic_complex(8);
result = typing_function_argument_type_to_return_type(c, context,
type_CMPLX, type_CMPLX);
free_basic(type_CMPLX);
return result;
}
static basic
typing_function_dcomplex_to_dcomplex(call c, type_context_p context)
{
basic result, type_DCMPLX = make_basic_complex(16);
result = typing_function_argument_type_to_return_type(c, context,
type_DCMPLX, type_DCMPLX);
free_basic(type_DCMPLX);
return result;
}
static basic
typing_function_longdcomplex_to_longdcomplex(call c, type_context_p context) /*MB: added for long double complex type*/
{
basic result, type_LDCMPLX = make_basic_complex(32);
result = typing_function_argument_type_to_return_type(c, context,
type_LDCMPLX, type_LDCMPLX);
free_basic(type_LDCMPLX);
return result;
}
static basic
typing_function_longdcomplex_to_longdouble(call c, type_context_p context) /* MB */
{
basic result, type_LDBLE = make_basic_float(16);
basic type_LDCMPLX = make_basic_complex(32);
result = typing_function_argument_type_to_return_type(c, context,
type_LDCMPLX, type_LDBLE);
free_basic(type_LDBLE);
free_basic(type_LDCMPLX);
return result;
}
static basic
typing_function_char_to_int(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_CHAR = make_basic_string(value_undefined);
result = typing_function_argument_type_to_return_type(c, context, type_CHAR,
type_INT);
free_basic(type_INT);
free_basic(type_CHAR);
return result;
}
static basic
typing_function_int_to_char(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_CHAR = make_basic_string(value_undefined);
result = typing_function_argument_type_to_return_type(c, context,
type_INT,
type_CHAR);
free_basic(type_INT);
free_basic(type_CHAR);
return result;
}
static basic
typing_function_real_to_int(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_REAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_REAL,
type_INT);
free_basic(type_INT);
free_basic(type_REAL);
return result;
}
static basic
typing_function_real_to_longint(call c, type_context_p context) /* MB */
{
basic result, type_LINT = make_basic_int(6);
basic type_REAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_REAL,
type_LINT);
free_basic(type_LINT);
free_basic(type_REAL);
return result;
}
static basic
typing_function_real_to_longlongint(call c, type_context_p context) /* MB */
{
basic result, type_LLINT = make_basic_int(8);
basic type_REAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_REAL,
type_LLINT);
free_basic(type_LLINT);
free_basic(type_REAL);
return result;
}
static basic
typing_function_int_to_real(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_REAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_INT,
type_REAL);
free_basic(type_INT);
free_basic(type_REAL);
return result;
}
/* function added to handle one of the bit manipulation functions :
BTEST. Amira Mensi */
static basic
typing_function_int_to_logical(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_LOGICAL = make_basic_float(4);
result = typing_function_argument_type_to_return_type(c, context,
type_INT,
type_LOGICAL);
free_basic(type_INT);
free_basic(type_LOGICAL);
return result;
}
static basic
typing_function_double_to_int(call c, type_context_p context)
{
basic result, type_INT = make_basic_int(4);
basic type_DBLE = make_basic_float(8);
result = typing_function_argument_type_to_return_type(c, context,
type_DBLE,
type_INT);
free_basic(type_INT);
free_basic(type_DBLE);
return result;
}
static basic
typing_function_double_to_longint(call c, type_context_p context) /* MB */
{
basic result, type_LINT = make_basic_int(6);
basic type_DBLE = make_basic_float(8);
result = typing_function_argument_type_to_return_type(c, context,
type_DBLE, type_LINT);
free_basic(type_LINT);
free_basic(type_DBLE);
return result;
}
static basic
typing_function_double_to_longlongint(call c, type_context_p context) /* MB */
{
basic result, type_LLINT = make_basic_int(8);
basic type_DBLE = make_basic_float(8);
result = typing_function_argument_type_to_return_type(c, context,
type_DBLE, type_LLINT);
free_basic(type_LLINT);
free_basic(type_DBLE);
return result;
}
static basic
typing_function_longdouble_to_int(call c, type_context_p context) /* MB */
{
basic result, type_INT = make_basic_int(4);
basic type_LDBLE = make_basic_float(16);
result = typing_function_argument_type_to_return_type(c, context,
type_LDBLE,
type_INT);
free_basic(type_INT);
free_basic(type_LDBLE);
return result;
}
static basic
typing_function_longdouble_to_longint(call c, type_context_p context) /* MB */
{
basic result, type_LINT = make_basic_int(6);
basic type_LDBLE = make_basic_float(16);
result = typing_function_argument_type_to_return_type(c, context,
type_LDBLE,
type_LINT);
free_basic(type_LINT);
free_basic(type_LDBLE);
return result;
}
static basic
typing_function_longdouble_to_longlongint(call c, type_context_p context) /* MB */
{
basic result, type_LLINT = make_basic_int(8);
basic type_LDBLE = make_basic_float(16);
result = typing_function_argument_type_to_return_type(c, context,
type_LDBLE,
type_LLINT);
free_basic(type_LLINT);
free_basic(type_LDBLE);
return result;
}
static basic
typing_function_real_to_double(call c, type_context_p context)
{
basic result, type_REAL = make_basic_float(4);
basic type_DBLE = make_basic_float(8);
result = typing_function_argument_type_to_return_type(c, context,
type_REAL,
type_DBLE);
free_basic(type_REAL);
free_basic(type_DBLE);
return result;
}
static basic
typing_function_complex_to_real(call c, type_context_p context)
{
basic result, type_REAL = make_basic_float(4);
basic type_CMPLX = make_basic_complex(8);
result = typing_function_argument_type_to_return_type(c, context,
type_CMPLX,
type_REAL);
free_basic(type_REAL);
free_basic(type_CMPLX);
return result;
}
static basic
typing_function_dcomplex_to_double(call c, type_context_p context)
{
basic result, type_DBLE = make_basic_float(8);
basic type_DCMPLX = make_basic_complex(16);
result = typing_function_argument_type_to_return_type(c, context,
type_DCMPLX,
type_DBLE);
free_basic(type_DBLE);
free_basic(type_DCMPLX);
return result;
}
static basic
typing_function_char_to_logical(call c, type_context_p context)
{
basic result, type_LOGICAL = make_basic_logical(4);
basic type_CHAR = make_basic_string(value_undefined);
result = typing_function_argument_type_to_return_type(c, context,
type_CHAR,
type_LOGICAL);
free_basic(type_LOGICAL);
free_basic(type_CHAR);
return result;
}
/**************************************************************************
* Arguments are REAL (or DOUBLE); and the return is the same with argument
*/
static basic
typing_function_RealDouble_to_RealDouble(call c, type_context_p context)
{
basic b;
if(!arguments_are_RD(c, context))
{
return make_basic_float(4); /* Just for return a result */
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
return b;
}
static basic
typing_function_RealDouble_to_Integer(call c, type_context_p context)
{
basic b;
if(!arguments_are_RD(c, context))
{
return make_basic_float(4); /* Just for return a result */
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
free_basic(b);
return make_basic_int(4);
}
static basic
typing_function_RealDoubleComplex_to_RealDoubleComplex(call c,
type_context_p context)
{
basic b;
if(!arguments_are_RDC(c, context))
{
return make_basic_float(4); /* Just for return a result */
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
return b;
}
static basic
typing_function_IntegerRealDouble_to_IntegerRealDouble(call c,
type_context_p context)
{
basic b;
if(!arguments_are_IRD(c, context))
{
return make_basic_float(4); /* Just for return a result */
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
// Typing all arguments to b if necessary
typing_arguments(c, context, b);
return b;
}
/**************************************************************************
* The arguments are INT, REAL, DOUBLE or COMPLEX. The return is the same
* with the argument except case argument are COMPLEX, return is REAL
*
* Note: Only for Intrinsic ABS(): ABS(CMPLX(x)) --> REAL
*/
static basic
typing_function_IntegerRealDoubleComplex_to_IntegerRealDoubleReal(call c,
type_context_p context)
{
basic b;
if(!arguments_are_IRDC(c, context))
{
return make_basic_float(4); /* Just for return result */
}
/* Find the longest type amongs all arguments */
b = basic_union_arguments(c, context->types);
/* Typing all arguments to b if necessary */
typing_arguments(c, context, b);
if (basic_complex_p(b) )
{
if (basic_complex(b)==8)
{
free_basic(b);
b = make_basic_float(4); /* CMPLX --> REAL */
} else if (basic_complex(b)==16 && TC_DCOMPLEX) {
free_basic(b);
b = make_basic_float(8); /* DCMPLX -> DOUBLE */
} /* else? */
}
return b;
}
/**************************************************************************
* Intrinsic conversion to a numeric
*
* Note: argument must be numeric
*/
static basic
typing_function_conversion_to_numeric(call c, type_context_p context,
basic to_type)
{
if(!arguments_are_IRDC(c, context))
{
return copy_basic(to_type);
}
return copy_basic(to_type);
}
static basic
typing_function_conversion_to_integer(call c, type_context_p context)
{
basic result, b = make_basic_int(4);
result = typing_function_conversion_to_numeric(c, context, b);
free_basic(b);
return result;
}
static basic
typing_function_conversion_to_real(call c, type_context_p context)
{
basic result, b = make_basic_float(4);
result = typing_function_conversion_to_numeric(c, context, b);
free_basic(b);
return result;
}
static basic
typing_function_conversion_to_double(call c, type_context_p context)
{
basic result, b = make_basic_float(8);
result = typing_function_conversion_to_numeric(c, context, b);
free_basic(b);
return result;
}
static basic
typing_function_conversion_to_complex(call c, type_context_p context)
{
basic b;
expression arg;
if(!arguments_are_IRDC(c, context))
{
return make_basic_float(4); /* Just for return result */
}
arg = EXPRESSION(CAR(call_arguments(c)));
if (CDR(call_arguments(c)) == NIL &&
basic_complex_p(GET_TYPE(context->types, arg)))
{
syntax ss = expression_syntax(arg);
if (syntax_call_p(ss))
{
call_arguments(c) = call_arguments(syntax_call(ss));
context->number_of_conversion++;
}
else /* Argument is a varibale */
{
return make_basic_complex(8);
}
/* Free memory occupied by old argument list*/
}
/* Typing all arguments to REAL if necessary */
b = make_basic_float(4);
typing_arguments(c, context, b);
free_basic(b);
return make_basic_complex(8);
}
static basic
typing_function_conversion_to_dcomplex(call c, type_context_p context)
{
basic b;
expression arg;
if(!arguments_are_IRDC(c, context))
{
return make_basic_float(4); /* Just for return result */
}
arg = EXPRESSION(CAR(call_arguments(c)));
if (CDR(call_arguments(c)) == NIL &&
basic_complex_p(GET_TYPE(context->types, arg)))
{
syntax ss = expression_syntax(arg);
if (syntax_call_p(ss))
{
call_arguments(c) = call_arguments(syntax_call(ss));
context->number_of_conversion++;
}
else /* Argument is a varibale */
{
return make_basic_complex(16);
}
/* Free memory occupied by old argument list */
}
/* Typing all arguments to DBLE if necessary */
b = make_basic_float(8);
typing_arguments(c, context, b);
free_basic(b);
return make_basic_complex(16);
}
/* CMPLX_ */
static basic
typing_function_constant_complex(call c, type_context_p context)
{
basic b;
if(!arguments_are_IR(c, context))
{
return make_basic_float(4); /* Just for return result */
}
/* Typing all arguments to REAL if necessary */
b = make_basic_float(4);
typing_arguments(c, context, b);
free_basic(b);
return make_basic_complex(8);
}
/* DCMPLX_ */
static basic
typing_function_constant_dcomplex(call c, type_context_p context)
{
basic b;
if(!arguments_are_IRD(c, context))
{
return make_basic_float(4); /* Just for return result */
}
/* Typing all arguments to DOUBLE if necessary */
b = make_basic_float(8);
typing_arguments(c, context, b);
free_basic(b);
return make_basic_complex(16);
}
static basic
typing_function_overloaded(call __attribute__ ((unused)) c,
type_context_p __attribute__ ((unused)) context)
{
return make_basic_overloaded();
}
static basic
typing_function_format_name(call __attribute__ ((unused)) c,
type_context_p __attribute__ ((unused)) context)
{
return make_basic_int(4);
}
static basic
typing_of_assign(call c, type_context_p context)
{
list args = call_arguments(c);
basic b1, b2;
if(!arguments_are_compatible(c, context->types))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Arguments of assignment '%s' are not compatible",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
else
{
b1 = GET_TYPE(context->types, EXPRESSION(CAR(args)));
b2 = GET_TYPE(context->types, EXPRESSION(CAR(CDR(args))));
if (!basic_equal_p(b1, b2))
{
EXPRESSION_(CAR(CDR(args))) =
insert_cast(b1, b2, EXPRESSION(CAR(CDR(args))), context);
}
}
/* Here, we aren't interested in the type of return */
return basic_undefined;
}
static basic
typing_substring(call c, type_context_p context)
{
int count = 0;
MAP(EXPRESSION, e,
{
count++;
switch (count)
{
case 1:
if( !basic_string_p(GET_TYPE(context->types, e)) ||
!syntax_reference_p(expression_syntax(e)) )
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 must be a reference to string");
/* Count the number of errors */
context->number_of_error++;
}
break;
case 2:
case 3:
if( !basic_int_p(GET_TYPE(context->types, e)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #%d must be an integer expression",
count);
/* Count the number of errors */
context->number_of_error++;
}
break;
default: /* count > 3 */
add_one_line_of_comment((statement) stack_head(context->stats),
"Too many of arguments for sub-string function");
/* Count the number of errors */
context->number_of_error++;
return make_basic_string(value_undefined);
}
},
call_arguments(c));
if (count < 3)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Lack of %d argument(s) for sub-string function",
3-count);
/* Count the number of errors */
context->number_of_error++;
}
return make_basic_string(value_undefined);
}
static basic
typing_assign_substring(call c, type_context_p context)
{
int count = 0;
MAP(EXPRESSION, e,
{
count++;
switch (count)
{
case 1:
if( !basic_string_p(GET_TYPE(context->types, e)) ||
!syntax_reference_p(expression_syntax(e)) )
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 must be a reference to string");
/* Count the number of errors */
context->number_of_error++;
}
break;
case 2:
case 3:
if( !basic_int_p(GET_TYPE(context->types, e)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #%d must be an integer expression",
count);
/* Count the number of errors */
context->number_of_error++;
}
break;
case 4:
if( !basic_string_p(GET_TYPE(context->types, e)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #4 must be a string expression");
/* Count the number of errors */
context->number_of_error++;
}
break;
default: /* count > 4 */
add_one_line_of_comment((statement) stack_head(context->stats),
"Too many of arguments for assign sub-string function");
/* Count the number of errors */
context->number_of_error++;
return basic_undefined;
}
},
call_arguments(c));
if (count < 4)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Lack of %d argument(s) for assign sub-string function",
4-count);
/* Count the number of errors */
context->number_of_error++;
}
return basic_undefined;
}
static basic
typing_buffer_inout(call c, type_context_p context)
{
int count = 0;
MAP(EXPRESSION, e,
{
count++;
switch (count)
{
case 1:
if( !basic_int_p(GET_TYPE(context->types, e)) )
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 must be an integer expression");
/* Count the number of errors */
context->number_of_error++;
}
break;
case 2:
case 3:
case 4:
/* PDSon: Nobody knows the type of 3 last arguments, I do nothing here */
break;
default: /* count > 4 */
add_one_line_of_comment((statement) stack_head(context->stats),
"Too many of arguments for function '%s'",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
return basic_undefined;
}
},
call_arguments(c));
if (count < 4)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Lack of %d argument(s) for function '%s'",
4-count, entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
return basic_undefined;
}
static basic no_typing(call __attribute__ ((unused)) c,
type_context_p __attribute__ ((unused)) context)
{
basic bt = basic_undefined;
pips_internal_error("This should not be type-checked because it is not Fortran function");
return bt; /* To please the compiler */
}
static basic
typing_implied_do(call c, type_context_p context)
{
basic b_int = NULL;
int count = 0;
MAP(EXPRESSION, e,
{
count++;
switch (count)
{
case 1:
b_int = GET_TYPE(context->types, e);
if( !basic_int_p(GET_TYPE(context->types, e)) ||
!syntax_reference_p(expression_syntax(e)) )
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 must be a reference to integer");
/* Count the number of errors */
context->number_of_error++;
}
break;
case 2: /* range */
if(!syntax_range_p(expression_syntax(e)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #2 must be a range of integer");
/* Count the number of errors */
context->number_of_error++;
return basic_undefined;
}
else
{
range r = syntax_range(expression_syntax(e));
if (!check_loop_range(r, context->types))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Range must be Integer, Real or Double!");
context->number_of_error++;
}
else
{
type_loop_range(b_int, r, context);
}
}
return basic_undefined;
}
},
call_arguments(c));
if (count < 2)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Lack of %d argument(s) for function '%s'",
2-count, entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
return basic_undefined;
}
/******************* VERIFICATION SYNTAX FOR STATEMENTS ********************/
/* Verify if an expression is a constant:
* YES : return true; otherwise, return FALSE
*/
static bool
is_constant(expression exp)
{
syntax s = expression_syntax(exp);
if (!syntax_call_p(s))
{
return false;
}
return (entity_constant_p(call_function(syntax_call(s))));
}
/* Verify if an expression is a constant of basic b:
* YES : return true; otherwise, return FALSE
*/
static bool
is_constant_of_basic(expression exp, basic b)
{
type call_type, return_type;
basic bb;
if (!is_constant(exp))
{
return false;
}
call_type = entity_type(call_function(syntax_call(expression_syntax(exp))));
return_type = functional_result(type_functional(call_type));
bb = variable_basic(type_variable(return_type));
if (basic_undefined_p(bb) || !basic_equal_p(b, bb))
{
return false;
}
return true;
}
static basic
statement_without_argument(call c, type_context_p context)
{
if (call_arguments(c) != NIL)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Statement '%s' doesn't need any argument",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
/* Here, we are not interested in the basic returned */
return basic_undefined;
}
/***************************************************************************
* Statement with at most one argument: integer or character constant,
* like PAUSE, STOP.
* Attention: Integer value must be <= 99999 (at most 5 digits)
* (According to ANSI X3.9-1978 FORTRAN 77; PAGE 11-9)
*/
static basic
statement_with_at_most_one_integer_or_character(call c,
type_context_p context)
{
basic b_int, b_char;
expression arg1;
entity en;
int l;
list args = call_arguments(c);
if (args != NIL)
{
b_int = make_basic_int(4);
b_char = make_basic_string(0);
arg1 = EXPRESSION(CAR(args));
if ( !is_constant_of_basic(arg1, b_int) &&
!is_constant_of_basic(arg1, b_char))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 of '%s' must be an integer or character constant",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
else if ( is_constant_of_basic(arg1, b_int) )
{
en = call_function(syntax_call(expression_syntax(arg1)));
l = strlen(entity_local_name(en));
if (l > 5)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument must be an integer of at most 5 digits (instead of '%d')",
l);
/* Count the number of errors */
context->number_of_error++;
}
}
if (CDR(args) != NIL)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Statement '%s' needs at most an argument, " \
"neight integer constant nor character constant",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
free_basic(b_int);
free_basic(b_char);
}
/* Here, we are not interested in the basic returned */
return basic_undefined;
}
static basic
statement_with_at_most_one_expression_integer(call c,
type_context_p context)
{
basic b;
list args = call_arguments(c);
if (args != NIL)
{
expression arg1 = EXPRESSION(CAR(args));
b = GET_TYPE(context->types, arg1);
if ( !basic_int_p(b) )
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Argument #1 of '%s' must be an integer expression",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
if (CDR(args) != NIL)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Statement '%s' needs at most an integer expression",
entity_local_name(call_function(c)));
/* Count the number of errors */
context->number_of_error++;
}
}
/* Here, we are not interested in the basic returned */
return basic_undefined;
}
/************************************************ VERIFICATION OF SPECIFIERS */
static bool
is_label_statement(expression exp)
{
call c;
entity fc;
syntax s = expression_syntax(exp);
if (!syntax_call_p(s))
{
return false;
}
c = syntax_call(s);
fc = call_function(c);
return entity_label_p(fc);
}
static bool
is_label_specifier(string s, expression e, type_context_p context)
{
if (!is_label_statement(e))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"%s specifier must be a label statement", s);
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
static bool
is_integer_specifier(string s, expression e, type_context_p context)
{
basic b = GET_TYPE(context->types, e);
if (!basic_int_p(b))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"%s specifier must be an integer expression", s);
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
static bool
is_string_specifier(string s,expression e, type_context_p context)
{
basic b = GET_TYPE(context->types, e);
if (!basic_string_p(b))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"%s specifier must be a character expression", s);
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
static bool
is_label_integer_string_specifier(string s, expression e,
type_context_p context)
{
basic b = GET_TYPE(context->types, e);
if (!is_label_statement(e) && !basic_int_p(b) && !basic_string_p(b))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"%s specifier must be a label, an integer or character expression", s);
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
static bool
is_varibale_array_element_specifier(string s, expression e, basic b,
type_context_p context)
{
if (!basic_equal_p(GET_TYPE(context->types, e), b) ||
!syntax_reference_p(expression_syntax(e)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"%s specifier must be a variable or an array element of %s", s,
basic_string_p(b)? "STRING":basic_to_string(b));
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
/* This function verifies the unit specifier; that is integer positive
* expression or character expression
* (According to ANSI X3.9-1978 FORTRAN 77; PAGE 12-7)
*/
static bool
is_unit_specifier(expression exp, type_context_p context)
{
basic b;
b = GET_TYPE(context->types, exp);
if (!basic_int_p(b) && !basic_string_p(b))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"UNIT specifier must be an integer or character expression");
/* Count the number of errors */
context->number_of_error++;
return false;
}
return true;
}
static bool
is_format_specifier(expression exp, type_context_p context)
{
return is_label_integer_string_specifier("FORMAT", exp, context);
}
static bool
is_record_specifier(expression exp, type_context_p context)
{
return is_label_integer_string_specifier("RECORD", exp, context);
}
/* Integer variable or integer array element which is maybe modified
*/
static bool
is_iostat_specifier(expression exp, type_context_p context)
{
basic b = make_basic_int(4);
bool r = is_varibale_array_element_specifier("IOSTAT", exp, b, context);
free_basic(b);
return r;
}
/* Error specifier is a label statement
*/
static bool
is_err_specifier(expression exp, type_context_p context)
{
return is_label_specifier("ERR", exp, context);
}
static bool
is_end_specifier(expression exp, type_context_p context)
{
return is_label_specifier("END", exp, context);
}
static bool
is_file_specifier(expression exp, type_context_p context)
{
return is_string_specifier("FILE", exp, context);
}
static bool
is_status_specifier(expression exp, type_context_p context)
{
return is_string_specifier("STATUS", exp, context);
}
static bool
is_access_specifier(expression exp, type_context_p context)
{
return is_string_specifier("ACCESS", exp, context);
}
static bool
is_form_specifier(expression exp, type_context_p context)
{
return is_string_specifier("FORM", exp, context);
}
static bool
is_recl_specifier(expression exp, type_context_p context)
{
return is_integer_specifier("RECL", exp, context);
}
static bool
is_blank_specifier(expression exp, type_context_p context)
{
return is_string_specifier("BLANK", exp, context);
}
static bool
is_exist_specifier(expression exp, type_context_p context)
{
basic b = make_basic_logical(4);
bool r = is_varibale_array_element_specifier("IOSTAT", exp, b, context);
free_basic(b);
return r;
}
static bool
is_opened_specifier(expression exp, type_context_p context)
{
basic b = make_basic_logical(4);
bool r = is_varibale_array_element_specifier("OPENED", exp, b, context);
free_basic(b);
return r;
}
static bool
is_number_specifier(expression exp, type_context_p context)
{
basic b = make_basic_int(4);
bool r = is_varibale_array_element_specifier("NUMBER", exp, b, context);
free_basic(b);
return r;
}
static bool
is_named_specifier(expression exp, type_context_p context)
{
basic b = make_basic_logical(4);
bool r = is_varibale_array_element_specifier("NAMED", exp, b, context);
free_basic(b);
return r;
}
static bool
is_name_specifier(expression exp, type_context_p context)
{
basic b = make_basic_string(0);
bool r = is_varibale_array_element_specifier("NAME", exp, b, context);
free_basic(b);
return r;
}
static bool
is_sequential_specifier(expression exp, type_context_p context)
{
basic b = make_basic_string(0);
bool r = is_varibale_array_element_specifier("SEQUENTIAL", exp, b, context);
free_basic(b);
return r;
}
static bool
is_direct_specifier(expression exp, type_context_p context)
{
basic b = make_basic_string(0);
bool r = is_varibale_array_element_specifier("DIRECT", exp, b, context);
free_basic(b);
return r;
}
static bool
is_formated_specifier(expression exp, type_context_p context)
{
basic b = make_basic_string(0);
bool r = is_varibale_array_element_specifier("FORMATTED", exp, b, context);
free_basic(b);
return r;
}
static bool
is_unformated_specifier(expression exp, type_context_p context)
{
basic b = make_basic_string(0);
bool r = is_varibale_array_element_specifier("UNFORMATTED", exp, b, context);
free_basic(b);
return r;
}
static bool
is_nextrec_specifier(expression exp, type_context_p context)
{
basic b = make_basic_int(4);
bool r = is_varibale_array_element_specifier("NEXTREC", exp, b, context);
free_basic(b);
return r;
}
static bool
check_spec (string name,
bool allowed,
const char* specifier,
expression contents,
type_context_p context,
bool (*check_contents)(expression, type_context_p))
{
if (same_string_p(name, specifier))
{
if (allowed)
{
if (check_contents(contents, context))
{
return true;
}
/* else ok */
}
else /* not allowed */
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Specifier '%s' is not allowed", name);
context->number_of_error++;
}
return true; /* checked! */
}
return false;
}
static bool
check_io_list(list /* of expression */ args,
type_context_p ctxt,
bool a_unit,
bool a_fmt,
bool a_rec,
bool a_iostat,
bool a_err,
bool a_end,
bool a_iolist,
bool a_file,
bool a_status,
bool a_access,
bool a_form,
bool a_blank,
bool a_recl,
bool a_exist,
bool a_opened,
bool a_number,
bool a_named,
bool a_name,
bool a_sequential,
bool a_direct,
bool a_formatted,
bool a_unformatted,
bool a_nextrec)
{
const char* spec;
pips_assert("Even number of arguments", gen_length(args)%2==0);
for (; args; args = CDR(CDR(args)))
{
expression specifier = EXPRESSION(CAR(args));
expression cont = EXPRESSION(CAR(CDR(args)));
syntax s = expression_syntax(specifier);
pips_assert("Specifier must be a call with arguments",
!syntax_call_p(s) || !call_arguments(syntax_call(s)));
spec = entity_local_name(call_function(syntax_call(s)));
/* specifier must be UNIT= FMT=... */
if (!check_spec("UNIT=", a_unit, spec, cont, ctxt,
is_unit_specifier) &&
!check_spec("FMT=", a_fmt, spec, cont, ctxt,
is_format_specifier) &&
!check_spec("IOSTAT=", a_iostat, spec, cont, ctxt,
is_iostat_specifier) &&
!check_spec("REC=", a_rec, spec, cont, ctxt,
is_record_specifier) &&
!check_spec("ERR=", a_err, spec, cont, ctxt,
is_err_specifier) &&
!check_spec("END=", a_end, spec, cont, ctxt,
is_end_specifier) &&
!check_spec("IOLIST=", a_iolist, spec, cont, ctxt,
(bool (*)(expression, type_context_p)) gen_true2) &&
!check_spec("FILE=", a_file, spec, cont, ctxt,
is_file_specifier) &&
!check_spec("STATUS=", a_status, spec, cont, ctxt,
is_status_specifier) &&
!check_spec("ACCESS=", a_access, spec, cont, ctxt,
is_access_specifier) &&
!check_spec("FORM=", a_form, spec, cont, ctxt,
is_form_specifier) &&
!check_spec("BLANK=", a_blank, spec, cont, ctxt,
is_blank_specifier) &&
!check_spec("RECL=", a_recl, spec, cont, ctxt,
is_recl_specifier) &&
!check_spec("EXIST=", a_exist, spec, cont, ctxt,
is_exist_specifier) &&
!check_spec("OPENED=", a_opened, spec, cont, ctxt,
is_opened_specifier) &&
!check_spec("NUMBER=", a_number, spec, cont, ctxt,
is_number_specifier) &&
!check_spec("NAMED=", a_named, spec, cont, ctxt,
is_named_specifier) &&
!check_spec("NAME=", a_name, spec, cont, ctxt,
is_name_specifier) &&
!check_spec("SEQUENTIAL=", a_sequential, spec, cont, ctxt,
is_sequential_specifier) &&
!check_spec("DIRECT=", a_direct, spec, cont, ctxt,
is_direct_specifier) &&
!check_spec("FORMATED=", a_formatted, spec, cont, ctxt,
is_formated_specifier) &&
!check_spec("UNFORMATED=", a_unformatted, spec, cont, ctxt,
is_unformated_specifier) &&
!check_spec("NEXTREC=", a_nextrec, spec, cont, ctxt,
is_nextrec_specifier))
{
add_one_line_of_comment((statement) stack_head(ctxt->stats),
"Unexpected specifier '%s'", spec);
ctxt->number_of_error++;
return false;
}
}
return true;
}
static basic
check_read_write(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, true, true, true, true, true, true,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
false, false, false, false, false, false, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_open(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
true, true, true, true, true, true, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_close(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
false, true, false, false, false, false, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_inquire(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
true, false, true, true, true, true, true, true,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
true, true, true, true, true, true,
/* UNFORMATTED NEXTREC */
true, true);
return basic_undefined;
}
static basic
check_backspace(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
false, false, false, false, false, false, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_endfile(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
false, false, false, false, false, false, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_rewind(call c, type_context_p context)
{
list args = call_arguments(c);
check_io_list(args, context,
/* UNIT FMT REC IOSTAT ERR END IOLIST */
true, false, false, true, true, false, false,
/* FILE STATUS ACCESS FORM BLANK RECL EXIST OPENED */
false, false, false, false, false, false, false, false,
/* NUMBER NAMED NAME SEQUENTIAL DIRECT FORMATTED */
false, false, false, false, false, false,
/* UNFORMATTED NEXTREC */
false, false);
return basic_undefined;
}
static basic
check_format(call c, type_context_p context)
{
list args = call_arguments(c);
if (args == NIL)
{
add_one_line_of_comment((statement) stack_head(context->stats),
"FORMAT statement needs a format specification");
context->number_of_error++;
}
else
{
expression exp = EXPRESSION(CAR(args));
if (!basic_string_p(GET_TYPE(context->types, exp)))
{
add_one_line_of_comment((statement) stack_head(context->stats),
"Format specification must be a string");
context->number_of_error++;
}
}
return basic_undefined;
}
/*********************** SIMPLIFICATION DES EXPRESSIONS **********************/
/* Find the specific name from the specific argument
* ---
* Each intrinsic of name generic have a function for switching to the
* specific name correspondent with the argument
*/
static void
switch_generic_to_specific(expression exp, type_context_p context,
string arg_int_name,
string arg_real_name,
string arg_double_name,
string arg_complex_name,
string arg_dcomplex_name)
{
call c;
list args;
basic arg_basic;
string specific_name = NULL;
/* Here, expression_syntax(exp) is always a call */
syntax s = expression_syntax(exp);
c = syntax_call(s);
args = call_arguments(c);
arg_basic = GET_TYPE(context->types, EXPRESSION(CAR(args)));
if (basic_int_p(arg_basic))
{
specific_name = arg_int_name;
}
else if (basic_float_p(arg_basic) && basic_float(arg_basic) == 4)
{
specific_name = arg_real_name;
}
else if (basic_float_p(arg_basic) && basic_float(arg_basic) == 8)
{
specific_name = arg_double_name;
}
else if (basic_complex_p(arg_basic) && basic_complex(arg_basic) == 8)
{
specific_name = arg_complex_name;
}
else if (basic_complex_p(arg_basic) && basic_complex(arg_basic) == 16)
{
if (TC_DCOMPLEX)
specific_name = arg_dcomplex_name;
/* else generic name is kept... */
}
/* Modify the (function:entity) of the call c if necessary
* NOTE: If specific_name == NULL: Invalid argument or
* argument basic unknown
*/
if(specific_name != NULL &&
strcmp(specific_name, entity_local_name(call_function(c))) != 0)
{
call_function(c) = CreateIntrinsic(specific_name);
/* Count number of simplifications */
context->number_of_simplication++;
}
}
/* AINT */
static void
switch_specific_aint(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "AINT", "DINT", NULL, NULL);
}
/* ANINT */
static void
switch_specific_anint(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ANINT", "DNINT", NULL, NULL);
}
/* NINT */
static void
switch_specific_nint(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "NINT", "IDNINT", NULL, NULL);
}
/* ABS */
static void
switch_specific_abs(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"IABS", "ABS", "DABS", "CABS", "CDABS");
}
/* MOD */
static void
switch_specific_mod(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"MOD", "AMOD", "DMOD", NULL, NULL);
}
/* SIGN */
static void
switch_specific_sign(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"ISIGN", "SIGN", "DSIGN", NULL, NULL);
}
/* DIM */
static void
switch_specific_dim(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"IDIM", "DIM", "DDIM", NULL, NULL);
}
/* MAX */
static void
switch_specific_max(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"MAX0", "AMAX1", "DMAX1", NULL, NULL);
}
/* MIN */
static void
switch_specific_min(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
"MIN0", "AMIN1", "DMIN1", NULL, NULL);
}
/* SQRT */
static void
switch_specific_sqrt(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "SQRT", "DSQRT", "CSQRT", "CDSQRT");
}
/* EXP */
static void
switch_specific_exp(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "EXP", "DEXP", "CEXP", "CDEXP");
}
/* LOG */
static void
switch_specific_log(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ALOG", "DLOG", "CLOG", "CDLOG");
}
/* LOG10 */
static void
switch_specific_log10(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ALOG10", "DLOG10", NULL, NULL);
}
/* SIN */
static void
switch_specific_sin(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL,"SIN","DSIN", "CSIN", "CDSIN");
}
/* COS */
static void
switch_specific_cos(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "COS", "DCOS", "CCOS", "CDCOS");
}
/* TAN */
static void
switch_specific_tan(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "TAN", "DTAN", NULL, NULL);
}
/* ASIN */
static void
switch_specific_asin(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ASIN", "DASIN", NULL, NULL);
}
/* ACOS */
static void
switch_specific_acos(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ACOS", "DACOS", NULL, NULL);
}
/* ATAN */
static void
switch_specific_atan(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ATAN", "DATAN", NULL, NULL);
}
/* ATAN2 */
static void
switch_specific_atan2(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "ATAN2", "DATAN2", NULL, NULL);
}
/* SINH */
static void
switch_specific_sinh(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "SINH", "DSINH", NULL, NULL);
}
/* COSH */
static void
switch_specific_cosh(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "COSH", "DCOSH", NULL, NULL);
}
/* TANH */
static void
switch_specific_tanh(expression exp, type_context_p context)
{
switch_generic_to_specific(exp, context,
NULL, "TANH", "DTANH", NULL, NULL);
}
/* forward declarations */
static void simplification_complex(expression, type_context_p);
static void simplification_dcomplex(expression, type_context_p);
static void
switch_specific_cmplx(expression exp, type_context_p context)
{
if (get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS"))
{
pips_assert("expression is a call", expression_call_p(exp));
call_function(syntax_call(expression_syntax(exp))) =
CreateIntrinsic("CMPLX");
}
simplification_complex(exp, context);
}
static void
switch_specific_dcmplx(expression exp, type_context_p context)
{
if (get_bool_property("TYPE_CHECKER_EXPLICIT_COMPLEX_CONSTANTS") &&
TC_DCOMPLEX)
{
pips_assert("expression is a call", expression_call_p(exp));
call_function(syntax_call(expression_syntax(exp))) =
CreateIntrinsic("DCMPLX");
}
simplification_dcomplex(exp, context);
}
/************************* SIMPLIFICATION THE CONVERSION CALL *************
* e.g: INT(INT(R)) -> INT(R)
* INT(2.9) -> 2
* INT(I) -> I
*/
static void
simplification_conversion(expression exp, basic to_basic,
type_context_p context)
{
syntax s_arg;
expression arg, exp_tmp = NULL;
basic b;
call c = syntax_call(expression_syntax(exp));
arg = EXPRESSION(CAR(call_arguments(c)));
s_arg = expression_syntax(arg);
/* Argument is a variable */
if (syntax_reference_p(s_arg))
{
/* e.g: INT(I) -> I */
if (basic_equal_p(to_basic,
entity_basic(reference_variable(
syntax_reference(s_arg)))) &&
CDR(call_arguments(c)) == NIL)
{
exp_tmp = copy_expression(arg);
context->number_of_simplication++;
}
/* e.g: CMPLX(R) -> CMPLX(R, 0.0E0) */
else if (ENTITY_CONVERSION_CMPLX_P(call_function(c)) &&
! basic_complex_p(entity_basic
(reference_variable(syntax_reference(s_arg)))) &&
CDR(call_arguments(c)) == NIL)
{
call c_imag;
expression exp_imag;
c_imag = make_call(make_constant_entity("0.0E0",
is_basic_float, 8),
NIL);
exp_imag = make_expression(make_syntax(is_syntax_call, c_imag),
normalized_undefined);
call_arguments(c)
= CONS(EXPRESSION, arg, CONS(EXPRESSION, exp_imag, NIL));
context->number_of_simplication++;
}
/* e.g: DCMPLX(D) -> DCMPLX(D, 0.0D0) */
else if (ENTITY_CONVERSION_DCMPLX_P(call_function(c)) &&
! basic_complex_p(entity_basic
(reference_variable(syntax_reference(s_arg)))) &&
CDR(call_arguments(c)) == NIL)
{
call c_imag;
expression exp_imag;
c_imag = make_call(make_constant_entity("0.0D0",
is_basic_float, 16),
NIL);
exp_imag = make_expression(make_syntax(is_syntax_call, c_imag),
normalized_undefined);
call_arguments(c)
= CONS(EXPRESSION, arg, CONS(EXPRESSION, exp_imag, NIL));
context->number_of_simplication++;
}
}
/* Argument is a call */
else if(syntax_call_p(s_arg))
{
b = GET_TYPE(context->types, arg);
/* e.g: INT(INT(R)) -> INT(R) */
if (basic_equal_p(b, to_basic))
{
exp_tmp = copy_expression(arg);
context->number_of_simplication++;
}
/* Cast constant if necessary */
/* Conversion: CMPLX, CMPLX_, DCMPLX, DCMPLX_ */
else if (ENTITY_IMPLIED_CMPLX_P(call_function(c)) ||
ENTITY_CONVERSION_CMPLX_P(call_function(c)) ||
ENTITY_IMPLIED_DCMPLX_P(call_function(c)) ||
ENTITY_CONVERSION_DCMPLX_P(call_function(c)))
{
list args = call_arguments(c);
basic b_arg = GET_TYPE(context->types, arg);
/* Imagine party is empty */
if (CDR(args) == NIL)
{
/* Argument is NOT complex or double complex */
if (!basic_complex_p(b_arg))
{
call c_imag;
expression exp_imag;
/* CMPLX */
if ((ENTITY_IMPLIED_CMPLX_P(call_function(c)) ||
ENTITY_CONVERSION_CMPLX_P(call_function(c))))
{
c_imag = make_call(make_constant_entity("0.0E0",
is_basic_float, 8),
NIL);
}
/* DCMPLX */
else
{
c_imag = make_call(make_constant_entity("0.0D0",
is_basic_float, 16),
NIL);
}
exp_imag = make_expression(make_syntax(is_syntax_call, c_imag),
normalized_undefined);
call_arguments(c)
= CONS(EXPRESSION, arg, CONS(EXPRESSION, exp_imag, NIL));
context->number_of_simplication++;
}
/* CMPLX(C) -> C; DCMPLX(DC) -> DC */
else if( (basic_complex(b_arg) == 8 &&
ENTITY_CONVERSION_CMPLX_P(call_function(c))) ||
(basic_complex(b_arg) == 16 &&
ENTITY_CONVERSION_DCMPLX_P(call_function(c))))
{
syntax s_tmp;
normalized n_tmp;
/* Argument being a call is examined in typing function */
pips_assert("Argument is a call ",
syntax_call_p(expression_syntax(arg)));
s_tmp = expression_syntax(exp);
n_tmp = expression_normalized(exp);
expression_syntax(exp)
= copy_syntax(expression_syntax(arg));
expression_normalized(exp)
= copy_normalized(expression_normalized(arg));
free_syntax(s_tmp);
free_normalized(n_tmp);
context->number_of_simplication++;
return;
}
}
/* Cast constants if necessary */
exp_tmp = cast_constant(exp, to_basic, context);
/* Number of simplifications is already counted in cast_constant() */
}
/* Conversion: INT (IFIX, ...), REAL (FLOAT, ...), DBLE
* e.g: INT(2.9) -> 2
*/
else
{
exp_tmp = cast_constant(arg, to_basic, context);
/* Number of simplifications is already counted in cast_constant() */
}
}
/* Update exp */
if (exp_tmp != NULL)
{
free_syntax(expression_syntax(exp));
free_normalized(expression_normalized(exp));
expression_syntax(exp) = copy_syntax(expression_syntax(exp_tmp));
expression_normalized(exp) = copy_normalized(
expression_normalized(exp_tmp));
free_expression(exp_tmp);
}
}
static void
simplification_int(expression exp, type_context_p context)
{
basic b = make_basic_int(4);
simplification_conversion(exp, b, context);
free_basic(b);
}
static void
simplification_real(expression exp, type_context_p context)
{
basic b = make_basic_float(4);
simplification_conversion(exp, b, context);
free_basic(b);
}
static void
simplification_double(expression exp, type_context_p context)
{
basic b = make_basic_float(8);
simplification_conversion(exp, b, context);
free_basic(b);
}
static void
simplification_complex(expression exp, type_context_p context)
{
basic b = make_basic_complex(8);
simplification_conversion(exp, b, context);
free_basic(b);
}
static void
simplification_dcomplex(expression exp, type_context_p context)
{
basic b = make_basic_complex(16);
simplification_conversion(exp, b, context);
free_basic(b);
}
/* Move the following functions to ri-util/type.c */
type
MakeVoidResult()
{
return make_type(is_type_void, UU);
}
parameter
MakeVoidParameter()
{
return make_parameter(make_type(is_type_void, UU),
make_mode(is_mode_reference, UU),
make_dummy_unknown());
}
//unuse
type
pointer_to_overloaded_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakePointerParameter);
return t;
}
type
integer_to_overloaded_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeIntegerParameter);
return t;
}
type
longinteger_to_overloaded_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeLongIntegerParameter);
return t;
}
type
longlonginteger_to_overloaded_type(int n) /* MB */
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeLongLongIntegerParameter);
return t;
}
type
integer_to_void_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, make_type_void(NIL));
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeIntegerParameter);
return t;
}
type __attribute__ ((unused))
void_to_overloaded_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeOverloadedResult());
t = make_type(is_type_functional, ft);
functional_parameters(ft) =
make_parameter_list(n, MakeVoidParameter);
return t;
}
type
overloaded_to_void_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeVoidResult());
functional_parameters(ft) =
make_parameter_list(n, MakeOverloadedParameter);
t = make_type(is_type_functional, ft);
return t;
}
type
void_to_integer_type(int n)
{
type t = type_undefined;
functional ft = functional_undefined;
ft = make_functional(NIL, MakeIntegerResult());
functional_parameters(ft) =
make_parameter_list(n, MakeVoidParameter);
t = make_type(is_type_functional, ft);
return t;
}
/******************************************************** INTRINSICS LIST */
static hash_table intrinsic_type_descriptor_mapping = hash_table_undefined;
/**************************************************************************
* Get the function for typing the specified intrinsic
*
*/
typing_function_t get_typing_function_for_intrinsic(const char* name)
{
return ((IntrinsicDescriptor *) hash_get(intrinsic_type_descriptor_mapping, name))->type_function;
}
/**************************************************************************
* Get the function for switching to specific name from generic name
*
*/
switch_name_function get_switch_name_function_for_intrinsic(const char* name)
{
return ((IntrinsicDescriptor *) hash_get(intrinsic_type_descriptor_mapping, name))->name_function;
}
/* This function creates an entity that represents an intrinsic
function. Fortran operators and basic statements are intrinsic
functions.
An intrinsic function has a rom storage, an unknown initial value and a
functional type whose result and arguments have an overloaded basic
type. The number of arguments is given by the IntrinsicTypeDescriptorTable
data structure. */
static entity MakeIntrinsic(string name, int arity, type (*intrinsic_type)(int)) {
entity e;
e = make_entity(AddPackageToName(TOP_LEVEL_MODULE_NAME, name),
intrinsic_type(arity),
make_storage(is_storage_rom, UU),
make_value(is_value_intrinsic, NIL),
DEFAULT_ENTITY_KIND);
return e;
}
/* This function creates an entity that represents an intrinsic
function, if the entity does not already exist. Fortran operators
and basic statements are intrinsic functions.
An intrinsic function has a rom storage, an unknown initial value and a
functional type whose result and arguments have an overloaded basic
type. The number of arguments is given by the IntrinsicTypeDescriptorTable
data structure. */
entity FindOrMakeIntrinsic(string name, int arity, type (*intrinsic_type)(int))
{
entity e = FindEntity(TOP_LEVEL_MODULE_NAME, name);
if (entity_undefined_p(e)) {
e = MakeIntrinsic(name, arity, intrinsic_type);
}
return e;
}
/** Create a default intrinsic
Useful to create on-the-fly intrinsics.
It creates an intrinsic with a default type, that is with overload
parameter and return types.
@param name is the name of the intrinsic
@param n is the number of argument
@return the entity of the intrinsic
*/
entity
FindOrMakeDefaultIntrinsic(string name, int arity)
{
entity e = FindEntity(TOP_LEVEL_MODULE_NAME, name);
if (!entity_undefined_p(e))
/* It seems it has been previously created: */
return e;
return MakeIntrinsic(name, arity, default_intrinsic_type);
}
/* This function is called one time (at the very beginning) to create
all intrinsic functions. */
void register_intrinsic_type_descriptor(IntrinsicDescriptor *p) {
FindOrMakeIntrinsic(p->name, p->nbargs, p->intrinsic_type);
hash_put(intrinsic_type_descriptor_mapping,p->name,p);
}
void
CreateIntrinsics( set module_list )
{
/* The table of intrinsic functions. this table is used at the begining
of linking to create Fortran operators, commands and intrinsic functions.
Functions with a variable number of arguments are declared with INT_MAX
arguments.
*/
/* Nga Nguyen 27/06/2003 Fuse the tables of intrinsics for C and Fortran.
Since there are differences between some kind of operators, such as in
Fortran, "+" is only applied to arithmetic numbers, in C, "+" is also applied
to pointer, the typing functions are different. So in some cases, we have to
rename the operators */
/* Pragma can be represented in the pips IR as a list of expression so new
* functions/intrinsics are needed. For exmaple to represent OMP pragmas,
* following intrinscs are needed:
* 1 - omp, parallel and for which are constant so with 0 argument,
* 2 - the colom poperator (for reduction) that takes two arguments
* 3 - private and reduction that takes a variable number of arguments.
*/
/*
* IntrinsicDescriptor need:
* {Name, Nbr_arg, Type, Type_Function, switch_name_function}
* \Name Name of the intrinsic operator/function
* \Nbr_arg Number of argument than the intrinsic operator/function need
* \Type is a pointer of function, that expect to have 1 arg (\Nbr_arg) and return a type of kind functional
* \Type_Function
* \switch_name_function
*/
static IntrinsicDescriptor IntrinsicTypeDescriptorTable[] =
{
{PLUS_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},
{MINUS_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},
{DIVIDE_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},
{MULTIPLY_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},
{UNARY_MINUS_OPERATOR_NAME, 1, default_intrinsic_type, typing_arithmetic_operator, 0}, // unary minus
{POWER_OPERATOR_NAME, 2, default_intrinsic_type, typing_power_operator, 0},
/* internal inverse operator... */
{ INVERSE_OPERATOR_NAME, 1, real_to_real_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex, 0},
{ASSIGN_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{EQUIV_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_logical_operator, 0},
{NON_EQUIV_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_logical_operator, 0},
{OR_OPERATOR_NAME, 2, logical_to_logical_type, typing_logical_operator, 0},
{AND_OPERATOR_NAME, 2, logical_to_logical_type, typing_logical_operator, 0},
{NOT_OPERATOR_NAME, 1, logical_to_logical_type, typing_logical_operator, 0},
{LESS_THAN_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{GREATER_THAN_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{LESS_OR_EQUAL_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{GREATER_OR_EQUAL_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{EQUAL_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{NON_EQUAL_OPERATOR_NAME, 2, overloaded_to_logical_type, typing_relational_operator, 0},
{CONCATENATION_FUNCTION_NAME, 2, character_to_character_type, typing_concat_operator, 0},
/* FORTRAN IO statement */
{WRITE_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_read_write, 0},
{REWIND_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_rewind, 0},
{BACKSPACE_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_backspace, 0},
{OPEN_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_open, 0},
{CLOSE_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_close, 0},
{READ_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_read_write, 0},
{BUFFERIN_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, typing_buffer_inout, 0},
{BUFFEROUT_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, typing_buffer_inout, 0},
{ENDFILE_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_endfile, 0},
{IMPLIED_DO_NAME, (INT_MAX), default_intrinsic_type, typing_implied_do, 0},
{REPEAT_VALUE_NAME, 2, default_intrinsic_type, no_typing, 0},
{STATIC_INITIALIZATION_FUNCTION_NAME, (INT_MAX) , default_intrinsic_type, no_typing, 0},
{DATA_LIST_FUNCTION_NAME, (INT_MAX) , default_intrinsic_type, no_typing, 0},
{FORMAT_FUNCTION_NAME, 1, default_intrinsic_type, check_format, 0},
{INQUIRE_FUNCTION_NAME, (INT_MAX), default_intrinsic_type, check_inquire, 0},
{SUBSTRING_FUNCTION_NAME, 3, substring_type, typing_substring, 0},
{ASSIGN_SUBSTRING_FUNCTION_NAME, 4, assign_substring_type, typing_assign_substring, 0},
/* Control statement */
{CONTINUE_FUNCTION_NAME, 0, default_intrinsic_type, statement_without_argument, 0},
{"ENDDO", 0, default_intrinsic_type, 0, 0}, // Why do we need this one?
{PAUSE_FUNCTION_NAME, 1, default_intrinsic_type,
statement_with_at_most_one_integer_or_character, 0},
{RETURN_FUNCTION_NAME, 0, default_intrinsic_type,
statement_with_at_most_one_expression_integer, 0},
{STOP_FUNCTION_NAME, 0, default_intrinsic_type,
statement_with_at_most_one_integer_or_character, 0},
{END_FUNCTION_NAME, 0, default_intrinsic_type, statement_without_argument, 0}, // Is it useful?
{INT_GENERIC_CONVERSION_NAME, 1, overloaded_to_integer_type,
typing_function_conversion_to_integer, simplification_int},
{IFIX_GENERIC_CONVERSION_NAME, 1, real_to_integer_type, typing_function_real_to_int,
simplification_int},
{IDINT_GENERIC_CONVERSION_NAME, 1, double_to_integer_type, typing_function_double_to_int,
simplification_int},
{REAL_GENERIC_CONVERSION_NAME, 1, overloaded_to_real_type, typing_function_conversion_to_real,
simplification_real},
{FLOAT_GENERIC_CONVERSION_NAME, 1, overloaded_to_real_type, typing_function_conversion_to_real,
simplification_real},
{DFLOAT_GENERIC_CONVERSION_NAME, 1, overloaded_to_double_type,
typing_function_conversion_to_double, simplification_double},
{SNGL_GENERIC_CONVERSION_NAME, 1, overloaded_to_real_type, typing_function_conversion_to_real,
simplification_real},
{DBLE_GENERIC_CONVERSION_NAME, 1, overloaded_to_double_type,
typing_function_conversion_to_double, simplification_double},
{DREAL_GENERIC_CONVERSION_NAME, 1, overloaded_to_double_type, /* Arnauld Leservot, code CEA */
typing_function_conversion_to_double, simplification_double},
{CMPLX_GENERIC_CONVERSION_NAME, (INT_MAX), overloaded_to_complex_type,
typing_function_conversion_to_complex, simplification_complex},
{DCMPLX_GENERIC_CONVERSION_NAME, (INT_MAX), overloaded_to_doublecomplex_type,
typing_function_conversion_to_dcomplex, simplification_dcomplex},
/* (0.,1.) -> switched to a function call... */
{ IMPLIED_COMPLEX_NAME, 2, overloaded_to_complex_type,
typing_function_constant_complex, switch_specific_cmplx },
{ IMPLIED_DCOMPLEX_NAME, 2, overloaded_to_doublecomplex_type,
typing_function_constant_dcomplex, switch_specific_dcmplx },
{CHAR_TO_INT_CONVERSION_NAME, 1, default_intrinsic_type, typing_function_char_to_int, 0},
{INT_TO_CHAR_CONVERSION_NAME, 1, default_intrinsic_type, typing_function_int_to_char, 0},
{AINT_CONVERSION_NAME, 1, real_to_real_type,
typing_function_RealDouble_to_RealDouble, switch_specific_aint},
{DINT_CONVERSION_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ANINT_CONVERSION_NAME, 1, real_to_real_type,
typing_function_RealDouble_to_RealDouble, switch_specific_anint},
{DNINT_CONVERSION_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{NINT_CONVERSION_NAME, 1, real_to_integer_type,
typing_function_RealDouble_to_Integer, switch_specific_nint},
{IDNINT_CONVERSION_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
//Fortran
{IABS_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ABS_OPERATOR_NAME, 1, real_to_real_type,
typing_function_IntegerRealDoubleComplex_to_IntegerRealDoubleReal,
switch_specific_abs},
{DABS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CABS_OPERATOR_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{CDABS_OPERATOR_NAME, 1, doublecomplex_to_double_type,
typing_function_dcomplex_to_double, 0},
{MODULO_OPERATOR_NAME, 2, default_intrinsic_type,
typing_function_IntegerRealDouble_to_IntegerRealDouble,
switch_specific_mod},
{REAL_MODULO_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{DOUBLE_MODULO_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{ISIGN_OPERATOR_NAME, 2, integer_to_integer_type, typing_function_int_to_int, 0},
{SIGN_OPERATOR_NAME, 2, default_intrinsic_type,
typing_function_IntegerRealDouble_to_IntegerRealDouble,
switch_specific_sign},
{DSIGN_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{IDIM_OPERATOR_NAME, 2, integer_to_integer_type, typing_function_int_to_int, 0},
{DIM_OPERATOR_NAME, 2, default_intrinsic_type,
typing_function_IntegerRealDouble_to_IntegerRealDouble,
switch_specific_dim},
{DDIM_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{DPROD_OPERATOR_NAME, 2, real_to_double_type, typing_function_real_to_double, 0},
{MAX_OPERATOR_NAME, (INT_MAX), default_intrinsic_type,
typing_function_IntegerRealDouble_to_IntegerRealDouble,
switch_specific_max},
{MAX0_OPERATOR_NAME, (INT_MAX), integer_to_integer_type,
typing_function_int_to_int, 0},
{AMAX1_OPERATOR_NAME, (INT_MAX), real_to_real_type, typing_function_real_to_real, 0},
{DMAX1_OPERATOR_NAME, (INT_MAX), double_to_double_type,
typing_function_double_to_double, 0},
{AMAX0_OPERATOR_NAME, (INT_MAX), integer_to_real_type,
typing_function_int_to_real, 0},
{MAX1_OPERATOR_NAME, (INT_MAX), real_to_integer_type, typing_function_real_to_int, 0},
{MIN_OPERATOR_NAME, (INT_MAX), default_intrinsic_type,
typing_function_IntegerRealDouble_to_IntegerRealDouble,
switch_specific_min},
{MIN0_OPERATOR_NAME, (INT_MAX), integer_to_integer_type,
typing_function_int_to_int, 0},
{AMIN1_OPERATOR_NAME, (INT_MAX), real_to_real_type, typing_function_real_to_real, 0},
{DMIN1_OPERATOR_NAME, (INT_MAX), double_to_double_type,
typing_function_double_to_double, 0},
{AMIN0_OPERATOR_NAME, (INT_MAX), integer_to_real_type,
typing_function_int_to_real, 0},
{MIN1_OPERATOR_NAME, (INT_MAX), real_to_integer_type, typing_function_real_to_int, 0},
{LENGTH_OPERATOR_NAME, 1, character_to_integer_type, typing_function_char_to_int, 0},
{INDEX_OPERATOR_NAME, 2, character_to_integer_type, typing_function_char_to_int, 0},
{AIMAG_CONVERSION_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{DIMAG_CONVERSION_NAME, 1, doublecomplex_to_double_type,
typing_function_dcomplex_to_double, 0},
{CONJG_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{DCONJG_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{SQRT_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex,
switch_specific_sqrt},
{DSQRT_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CSQRT_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{CDSQRT_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{EXP_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex,
switch_specific_exp},
{DEXP_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CEXP_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{CDEXP_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{LOG_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex,
switch_specific_log},
{ALOG_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{DLOG_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CLOG_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{CDLOG_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{LOG10_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_log10},
{ALOG10_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{DLOG10_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SIN_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex,
switch_specific_sin},
{DSIN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CSIN_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{CDSIN_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{COS_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDoubleComplex_to_RealDoubleComplex,
switch_specific_cos},
{DCOS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CCOS_OPERATOR_NAME, 1, complex_to_complex_type,
typing_function_complex_to_complex, 0},
{CDCOS_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type,
typing_function_dcomplex_to_dcomplex, 0},
{TAN_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_tan},
{DTAN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ASIN_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_asin},
{DASIN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ACOS_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_acos},
{DACOS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ATAN_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_atan},
{DATAN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ATAN2_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_atan2},
{DATAN2_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SINH_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_sinh},
{DSINH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{COSH_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_cosh},
{DCOSH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{TANH_OPERATOR_NAME, 1, default_intrinsic_type,
typing_function_RealDouble_to_RealDouble, switch_specific_tanh},
{DTANH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LGE_OPERATOR_NAME, 2, character_to_logical_type, typing_function_char_to_logical, 0},
{LGT_OPERATOR_NAME, 2, character_to_logical_type, typing_function_char_to_logical, 0},
{LLE_OPERATOR_NAME, 2, character_to_logical_type, typing_function_char_to_logical, 0},
{LLT_OPERATOR_NAME, 2, character_to_logical_type, typing_function_char_to_logical, 0},
{LIST_DIRECTED_FORMAT_NAME, 0, default_intrinsic_type,
typing_function_format_name, 0},
{UNBOUNDED_DIMENSION_NAME, 0, default_intrinsic_type,
typing_function_overloaded, 0},
/* Bit manipulation functions : ISO/IEC 1539 */
{ISHFT_OPERATOR_NAME, 2, integer_to_integer_type, typing_function_int_to_int, 0},
{ISHFTC_OPERATOR_NAME, 3,integer_to_integer_type, typing_function_int_to_int, 0},
{IBITS_OPERATOR_NAME, 3, integer_to_integer_type, typing_function_int_to_int, 0},
{MVBITS_OPERATOR_NAME, 5,integer_to_integer_type, typing_function_int_to_int, 0},
{BTEST_OPERATOR_NAME, 2,integer_to_logical_type, typing_function_int_to_logical, 0},
{IBSET_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
{IBCLR_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
{BIT_SIZE_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
{IAND_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
{IEOR_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
{IOR_OPERATOR_NAME, 2,integer_to_integer_type, typing_function_int_to_int, 0},
/* These operators are used within the OPTIMIZE transformation in
order to manipulate operators such as n-ary add and multiply or
multiply-add operators ( JZ - sept 98) */
{EOLE_SUM_OPERATOR_NAME, (INT_MAX), default_intrinsic_type ,
typing_arithmetic_operator, 0},
{EOLE_PROD_OPERATOR_NAME, (INT_MAX), default_intrinsic_type ,
typing_arithmetic_operator, 0},
{EOLE_FMA_OPERATOR_NAME, 3, default_intrinsic_type ,
typing_arithmetic_operator, 0},
{EOLE_FMS_OPERATOR_NAME, 3, default_intrinsic_type ,
typing_arithmetic_operator, 0},
/* integer combined multiply add or sub - FC oct 2005 */
{ IMA_OPERATOR_NAME, 3, integer_to_integer_type,
typing_function_int_to_int, 0 },
{ IMS_OPERATOR_NAME, 3, integer_to_integer_type,
typing_function_int_to_int, 0 },
/* Here are C intrinsics arranged in the order of the standard ISO/IEC 9899:TC2. MB */
/* ISO 6.5.2.3 structure and union members */
{FIELD_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
{POINT_TO_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
/* ISO 6.5.2.4 postfix increment and decrement operators, real or pointer type operand */
{POST_INCREMENT_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{POST_DECREMENT_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
/* ISO 6.5.3.1 prefix increment and decrement operators, real or pointer type operand */
{PRE_INCREMENT_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{PRE_DECREMENT_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
/* ISO 6.5.3.2 address and indirection operators, add pointer type */
// this definition must be more precise but cause a type issue
// {ADDRESS_OF_OPERATOR_NAME, 1, pointer_to_overloaded_type, 0, 0},
{ADDRESS_OF_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{DEREFERENCING_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
/* ISO 6.5.3.3 unary arithmetic operators */
{UNARY_PLUS_OPERATOR_NAME, 1, default_intrinsic_type, typing_arithmetic_operator, 0},
/* Unuary minus : ALREADY EXIST (FORTRAN)
{UNARY_MINUS_OPERATOR_NAME, 1, default_intrinsic_type, typing_arithmetic_operator, 0},*/
{BITWISE_NOT_OPERATOR_NAME, 1, integer_to_overloaded_type, typing_arithmetic_operator, 0},
{C_NOT_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
/* ISO 6.5.5 multiplicative operators : ALREADY EXIST (FORTRAN)
{MULTIPLY_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},
{DIVIDE_OPERATOR_NAME, 2, default_intrinsic_type, typing_arithmetic_operator, 0},*/
{C_MODULO_OPERATOR_NAME, 2, integer_to_overloaded_type, typing_arithmetic_operator, 0},
/* ISO 6.5.6 additive operators, arithmetic types or pointer + integer type*/
{PLUS_C_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
{MINUS_C_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
/* ISO 6.5.7 bitwise shift operators*/
{LEFT_SHIFT_OPERATOR_NAME, 2, integer_to_overloaded_type, 0, 0},
{RIGHT_SHIFT_OPERATOR_NAME, 2, integer_to_overloaded_type, 0, 0},
/* ISO 6.5.8 relational operators,arithmetic or pointer types */
{C_LESS_THAN_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
{C_GREATER_THAN_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
{C_LESS_OR_EQUAL_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
{C_GREATER_OR_EQUAL_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
/* ISO 6.5.9 equality operators, return 0 or 1*/
{C_EQUAL_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
{C_NON_EQUAL_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
/* ISO 6.5.10 bitwise AND operator */
{BITWISE_AND_OPERATOR_NAME, 2, integer_to_integer_type, typing_arithmetic_operator, 0},
/* ISO 6.5.11 bitwise exclusive OR operator */
{BITWISE_XOR_OPERATOR_NAME, 2, integer_to_integer_type, typing_arithmetic_operator, 0},
/* ISO 6.5.12 bitwise inclusive OR operator */
{BITWISE_OR_OPERATOR_NAME, 2, integer_to_integer_type, typing_arithmetic_operator, 0},
/* ISO 6.5.13 logical AND operator */
{C_AND_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
/* ISO 6.5.14 logical OR operator */
{C_OR_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
/* ISO 6.5.15 conditional operator */
{CONDITIONAL_OPERATOR_NAME, 3, default_intrinsic_type, 0, 0},
/* ISO 6.5.16.1 simple assignment : ALREADY EXIST (FORTRAN)
{ASSIGN_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0}, */
/* ISO 6.5.16.2 compound assignments*/
{MULTIPLY_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{DIVIDE_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{MODULO_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{PLUS_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{MINUS_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{LEFT_SHIFT_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{RIGHT_SHIFT_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{BITWISE_AND_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{BITWISE_XOR_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
{BITWISE_OR_UPDATE_OPERATOR_NAME, 2, default_intrinsic_type, typing_of_assign, 0},
/* ISO 6.5.17 comma operator */
{COMMA_OPERATOR_NAME, (INT_MAX), default_intrinsic_type, 0, 0},
{BREAK_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{CASE_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{DEFAULT_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{C_RETURN_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
/* intrinsic to handle C initialization */
{BRACE_INTRINSIC, (INT_MAX) , default_intrinsic_type, no_typing, 0},
/* #include */
{ASSERT_FUNCTION_NAME, 3, overloaded_to_void_type,0,0},
{ASSERT_FAIL_FUNCTION_NAME, 4, overloaded_to_void_type,0,0}, /* does not return */
/* #include */
{CACOS_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CACOSF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CACOSL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CASIN_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CASINF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CASINL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CATAN_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CATANF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CATANL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CCOS_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CCOSF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CCOSL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CSIN_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CSINF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CSINL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CTAN_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CTANF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CTANL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CACOSH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CACOSHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CACOSHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CASINH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CASINHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CASINHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CATANH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CATANHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CATANHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CCOSH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CCOSHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CCOSHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CSINH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CSINHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CSINHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CTANH_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CTANHF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CTANHL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CEXP_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CEXPF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CEXPL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CLOG_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CLOGF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CLOGL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CABS_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{CABSF_OPERATOR_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{CABSL_OPERATOR_NAME, 1, longdoublecomplex_to_longdouble_type, typing_function_longdcomplex_to_longdouble, 0},
{CPOW_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CPOWF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CPOWL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{C_CSQRT_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CSQRTF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CSQRTL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CARG_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{CARGF_OPERATOR_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{CARGL_OPERATOR_NAME, 1, longdoublecomplex_to_longdouble_type, typing_function_longdcomplex_to_longdouble, 0},
{CIMAG_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{GCC_CIMAG_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{CIMAGF_OPERATOR_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{CIMAGL_OPERATOR_NAME, 1, longdoublecomplex_to_longdouble_type, typing_function_longdcomplex_to_longdouble, 0},
{CONJ_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CONJF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CONJL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CPROJ_OPERATOR_NAME, 1, doublecomplex_to_doublecomplex_type, typing_function_dcomplex_to_dcomplex, 0},
{CPROJF_OPERATOR_NAME, 1, complex_to_complex_type, typing_function_complex_to_complex, 0},
{CPROJL_OPERATOR_NAME, 1, longdoublecomplex_to_longdoublecomplex_type, typing_function_longdcomplex_to_longdcomplex, 0},
{CREAL_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{GCC_CREAL_OPERATOR_NAME, 1, doublecomplex_to_double_type, typing_function_dcomplex_to_double, 0},
{CREALF_OPERATOR_NAME, 1, complex_to_real_type, typing_function_complex_to_real, 0},
{CREALL_OPERATOR_NAME, 1, longdoublecomplex_to_longdouble_type, typing_function_longdcomplex_to_longdouble, 0},
/* #include */
{ISALNUM_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISALPHA_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISBLANK_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISCNTRL_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISDIGIT_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISGRAPH_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISLOWER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISPRINT_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISPUNCT_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISSPACE_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISUPPER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{ISXDIGIT_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{TOLOWER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{TOUPPER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
/* End ctype.h */
//not found in standard C99 (in GNU C Library)
{ISASCII_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{TOASCII_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{_TOLOWER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{_TOUPPER_OPERATOR_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
/* Real type is void -> unsigned short int ** */
{CTYPE_B_LOC_OPERATOR_NAME, 0, integer_to_integer_type, 0, 0},
/* #include */
/* {"errno", 0, overloaded_to_integer_type, 0, 0}, */
/* bits/errno.h */
{__ERRNO_LOCATION_OPERATOR_NAME, 0, default_intrinsic_type, 0, 0},
/* #include */
{FECLEAREXCEPT_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{FERAISEEXCEPT_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{FESETEXCEPTFLAG_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FETESTEXCEPT_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{FEGETROUND_FUNCTION_NAME, 1, void_to_integer_type, 0, 0},
{FESETROUND_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
// fenv_t *
//{FESETENV_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
//{FEUPDATEENV_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
/* #include */
/* {"__flt_rounds", 1, void_to_integer_type, 0, 0}, */
/* #include */
{IMAXABS_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{IMAXDIV_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
/* #include */
/* {"_sysconf", 1, integer_to_integer_type, 0, 0},
{"localeconv", 1, default_intrinsic_type, 0, 0},
{"dcgettext", 3, default_intrinsic_type, 0, 0},
{"dgettext", 2, default_intrinsic_type, 0, 0},
{"gettext", 1, default_intrinsic_type, 0, 0},
{"textdomain", 1, default_intrinsic_type, 0, 0},
{"bindtextdomain", 2, default_intrinsic_type, 0, 0},
{"wdinit", 1, void_to_integer_type, 0 ,0},
{"wdchkind", 1, overloaded_to_integer_type, 0 ,0},
{"wdbindf", 3, overloaded_to_integer_type, 0 ,0},
{"wddelim", 3, default_intrinsic_type, 0, 0},
{"mcfiller", 1, void_to_overloaded_type, 0, 0},
{"mcwrap", 1, void_to_integer_type, 0 ,0},*/
/* #include */
/* #include */
{SETLOCALE_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
/* #include */
{FPCLASSIFY_OPERATOR_NAME, 1, double_to_integer_type,typing_function_double_to_int, 0},
{ISFINITE_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{ISINF_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{ISNAN_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{ISNANL_OPERATOR_NAME, 1, double_to_integer_type, typing_function_real_to_int, 0},
{ISNANF_OPERATOR_NAME, 1, real_to_integer_type, typing_function_real_to_int, 0},
{ISNORMAL_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{SIGNBIT_OPERATOR_NAME, 1, double_to_integer_type,typing_function_double_to_int, 0},
{C_ACOS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double , 0},
{ACOSF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ACOSL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ASIN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ASINF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ASINL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ATAN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ATANF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ATANL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ATAN2_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{ATAN2F_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{ATAN2L_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_COS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{COSF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{COSL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_SIN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SINF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{SINL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_TAN_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{TANF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{TANL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ACOSH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ACOSHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ACOSHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ASINH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ASINHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ASINHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_ATANH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ATANHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ATANHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_COSH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{COSHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{COSHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_SINH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SINHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{SINHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_TANH_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{TANHF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{TANHL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_EXP_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{EXPF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{EXPL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{EXP2_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{EXP2F_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{EXP2L_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{EXPM1_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{EXPM1F_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{EXPM1L_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FREXP_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},/*?*/
{ILOGB_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{ILOGBF_OPERATOR_NAME, 1, double_to_integer_type, typing_function_double_to_int, 0},
{ILOGBL_OPERATOR_NAME, 1, longdouble_to_integer_type, typing_function_longdouble_to_int, 0},
{LDEXP_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{LDEXPF_OPERATOR_NAME, 2, overloaded_to_real_type, 0, 0},
{LDEXPL_OPERATOR_NAME, 2, overloaded_to_longdouble_type, 0, 0},
{C_LOG_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LOGF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LOGL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_LOG10_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LOG10F_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LOG10L_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{LOG1P_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LOG1PF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LOG1PL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{LOG2_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LOG2F_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LOG2L_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{LOGB_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LOGBF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LOGBL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{MODF_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{MODFF_OPERATOR_NAME, 2, overloaded_to_real_type, 0, 0},
{SCALBN_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{SCALBNF_OPERATOR_NAME, 2, overloaded_to_real_type, 0, 0},
{SCALBNL_OPERATOR_NAME, 2, overloaded_to_longdouble_type, 0, 0},
{SCALB_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0}, //POSIX.1-2001
{SCALBLN_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{SCALBLNF_OPERATOR_NAME, 2, overloaded_to_real_type, 0, 0},
{SCALBLNL_OPERATOR_NAME, 2, overloaded_to_longdouble_type, 0, 0},
{CBRT_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CBRTF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{CBRTL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FABS_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{FABSF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{FABSL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{HYPOT_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{HYPOTF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{HYPOTL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{POW_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{POWF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{POWL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{C_SQRT_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SQRTF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{SQRTL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{ERF_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ERFF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ERFL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{ERFC_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ERFCF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ERFCL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{GAMMA_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0}, /* GNU C Library */
{LGAMMA_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{LGAMMAF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{LGAMMAL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{TGAMMA_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{TGAMMAF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{CEIL_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{CEILF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{CEILL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FLOOR_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{FLOORF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{FLOORL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{NEARBYINT_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{NEARBYINTF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{NEARBYINTL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{RINT_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{RINTF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{RINTL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{LRINT_OPERATOR_NAME, 1, double_to_longinteger_type, typing_function_double_to_longint, 0},
{LRINTF_OPERATOR_NAME, 1, real_to_longinteger_type, typing_function_real_to_longint, 0},
{LRINTL_OPERATOR_NAME, 1, longdouble_to_longinteger_type, typing_function_longdouble_to_longint, 0},
{LLRINT_OPERATOR_NAME, 1, double_to_longlonginteger_type, typing_function_double_to_longlongint, 0},
{LLRINTF_OPERATOR_NAME, 1, real_to_longlonginteger_type, typing_function_real_to_longlongint, 0},
{LLRINTL_OPERATOR_NAME, 1, longdouble_to_longlonginteger_type, typing_function_longdouble_to_longlongint, 0},
{ROUND_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{ROUNDF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{ROUNDL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{LROUND_OPERATOR_NAME, 1, double_to_longinteger_type, typing_function_double_to_longint, 0},
{LROUNDF_OPERATOR_NAME, 1, real_to_longinteger_type, typing_function_real_to_longint, 0},
{LROUNDL_OPERATOR_NAME, 1, longdouble_to_longinteger_type, typing_function_longdouble_to_longint, 0},
{LLROUND_OPERATOR_NAME, 1, double_to_longlonginteger_type, typing_function_double_to_longlongint, 0},
{LLROUNDF_OPERATOR_NAME, 1, real_to_longlonginteger_type, typing_function_real_to_longlongint, 0},
{LLROUNDL_OPERATOR_NAME, 1, longdouble_to_longlonginteger_type, typing_function_longdouble_to_longlongint, 0},
{TRUNC_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{TRUNCF_OPERATOR_NAME, 1, real_to_real_type, typing_function_real_to_real, 0},
{TRUNCL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FMOD_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{FMODF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{FMODL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{REMAINDER_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{REMAINDERF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{REMAINDERL_OPERATOR_NAME, 1, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{COPYSIGN_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{COPYSIGNF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{COPYSIGNL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{NAN_OPERATOR_NAME, 1, char_pointer_to_double_type, 0, 0},
{NANF_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{NANL_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{NEXTAFTER_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{NEXTAFTERF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{NEXTAFTERL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{NEXTTOWARD_OPERATOR_NAME, 2, overloaded_to_double_type,0, 0},
{NEXTTOWARDF_OPERATOR_NAME, 2, overloaded_to_real_type, 0, 0},
{NEXTTOWARDL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FDIM_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{FDIMF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{FDIML_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FMAX_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{FMAXF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{FMAXL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FMIN_OPERATOR_NAME, 2, double_to_double_type, typing_function_double_to_double, 0},
{FMINF_OPERATOR_NAME, 2, real_to_real_type, typing_function_real_to_real, 0},
{FMINL_OPERATOR_NAME, 2, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{FMA_OPERATOR_NAME, 3, double_to_double_type, typing_function_double_to_double, 0},
{FMAF_OPERATOR_NAME, 3, real_to_real_type, typing_function_real_to_real, 0},
{FMAL_OPERATOR_NAME, 3, longdouble_to_longdouble_type, typing_function_longdouble_to_longdouble, 0},
{ISGREATER_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
{ISGREATEREQUAL_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
{ISLESS_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
{ISLESSEQUAL_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
{ISLESSGREATER_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
{ISUNORDERED_OPERATOR_NAME, 2, double_to_integer_type, typing_function_double_to_int, 0},
/* End math.h */
{J0_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{J1_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{JN_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{Y0_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{Y1_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{YN_OPERATOR_NAME, 2, overloaded_to_double_type, 0, 0},
{MATHERR_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{SIGNIFICAND_OPERATOR_NAME, 1, double_to_double_type, typing_function_double_to_double, 0},
{SIGFPE_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
{SINGLE_TO_DECIMAL_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{DOUBLE_TO_DECIMAL_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{EXTENDED_TO_DECIMAL_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{QUADRUPLE_TO_DECIMAL_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{DECIMAL_TO_SINGLE_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{DECIMAL_TO_DOUBLE_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{DECIMAL_TO_EXTENDED_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{DECIMAL_TO_QUADRUPLE_OPERATOR_NAME, 4, overloaded_to_void_type, 0, 0},
{STRING_TO_DECIMAL_OPERATOR_NAME, 6, overloaded_to_void_type, 0, 0},
{FUNC_TO_DECIMAL_OPERATOR_NAME, 9, overloaded_to_void_type, 0, 0},
{FILE_TO_DECIMAL_OPERATOR_NAME, 8, overloaded_to_void_type, 0, 0},
{SECONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{SFCONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{SGCONVERT_OPERATOR_NAME, 4, default_intrinsic_type, 0, 0},
{ECONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{FCONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{GCONVERT_OPERATOR_NAME, 4, default_intrinsic_type, 0, 0},
{QECONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{QFCONVERT_OPERATOR_NAME, 5, default_intrinsic_type, 0, 0},
{QGCONVERT_OPERATOR_NAME, 4, default_intrinsic_type, 0, 0},
/* same name in stdlib
{"ecvt", 4, default_intrinsic_type, 0, 0},
{"fcvt", 4, default_intrinsic_type, 0, 0},
{"gcvt", 3, default_intrinsic_type, 0, 0},
{"strtod", 2, overloaded_to_double_type, 0, 0}, */
/*#include */
{"setjmp", 1, overloaded_to_integer_type, 0, 0},
{"__setjmp", 1, overloaded_to_integer_type, 0, 0},
{"longjmp", 2, overloaded_to_void_type, 0, 0},
{"__longjmp", 2, overloaded_to_void_type, 0, 0},
{"sigsetjmp", 2, overloaded_to_integer_type, 0, 0},
{"siglongjmp", 2, overloaded_to_void_type, 0, 0},
/*#include */
{SIGNAL_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
{RAISE_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
/*#include */
/*#include */
/*#include */
/*#include */
/*#include */
{REMOVE_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{RENAME_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{TMPFILE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{TMPNAM_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{FCLOSE_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{FFLUSH_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{FOPEN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{FREOPEN_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{SETBUF_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{SETVBUF_FUNCTION_NAME, 4, overloaded_to_integer_type, 0, 0},
{FPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{FSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_FSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{PRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{SCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_SCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{SPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{SSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_SSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{VSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_VSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{VSSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_VSSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{VFSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ISOC99_VFSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{VFPRINTF_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{VPRINTF_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{VSPRINTF_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{FGETC_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{FGETS_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{FPUTC_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FPUTS_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{GETC_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{_IO_GETC_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{PUTC_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{_IO_PUTC_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{GETCHAR_FUNCTION_NAME, 1, void_to_integer_type, 0, 0},
{PUTCHAR_FUNCTION_NAME, 1, integer_to_integer_type, 0, 0},
{GETS_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{PUTS_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{UNGETC_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FREAD_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{FWRITE_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{FGETPOS_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FSEEK_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{FSETPOS_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FTELL_FUNCTION_NAME,1, default_intrinsic_type, 0, 0},
{C_REWIND_FUNCTION_NAME,1, default_intrinsic_type, 0, 0},
{CLEARERR_FUNCTION_NAME,1, default_intrinsic_type, 0, 0},
{FEOF_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{FERROR_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{PERROR_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{__FILBUF_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{__FILSBUF_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{SETBUFFER_FUNCTION_NAME, 3, overloaded_to_void_type, 0, 0},
{SETLINEBUF_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SNPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{VSNPRINTF_FUNCTION_NAME, 4, overloaded_to_integer_type, 0, 0},
{FDOPEN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{CTERMID_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{FILENO_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{POPEN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{CUSERID_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{TEMPNAM_FUNCTION_NAME, 2,default_intrinsic_type, 0, 0},
/* same name in stdlib
{"getopt", 3, overloaded_to_integer_type, 0, 0},
{"getsubopt", 3, default_intrinsic_type, 0, 0},*/
{GETW_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{PUTW_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{PCLOSE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{FSEEKO_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{FTELLO_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{FOPEN64_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{FREOPEN64_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{TMPFILE64_FUNCTION_NAME, 1,default_intrinsic_type, 0, 0},
{FGETPOS64_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{FSETPOS64_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{FSEEKO64_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{FTELLO64_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
/* C IO system functions in man -S 2. The typing could be refined. See unistd.h */
{C_OPEN_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0}, /* 2 or 3 arguments */
{CREAT_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{C_CLOSE_FUNCTION_NAME, 1, integer_to_integer_type, 0, 0},
{C_WRITE_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0}, /* returns ssize_t */
{C_READ_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{USLEEP_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{LINK_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{SYMLINK_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{UNLINK_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
/* {FCNTL_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},*/ /* 2 or 3 arguments of various types*/ /* located with fcntl.h */
{FSYNC_FUNCTION_NAME, 2, integer_to_integer_type, 0, 0},
{FDATASYNC_FUNCTION_NAME, 2, integer_to_integer_type, 0, 0},
{IOCTL_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{SELECT_FUNCTION_NAME, 5, overloaded_to_integer_type, 0, 0},
{PSELECT_FUNCTION_NAME, 6, overloaded_to_integer_type, 0, 0},
{STAT_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{FSTAT_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{LSTAT_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
/*#include */
{ATOF_FUNCTION_NAME, 1, char_pointer_to_double_type, 0, 0},
{ATOI_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ATOL_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ATOLL_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{STRTOD_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{STRTOF_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{STRTOLD_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{STRTOL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{STRTOLL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{STRTOUL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{STRTOULL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{RAND_FUNCTION_NAME, 1, void_to_integer_type, 0, 0},
{SRAND_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{CALLOC_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{FREE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{MALLOC_FUNCTION_NAME, 1, unsigned_integer_to_void_pointer_type, 0, 0},
{REALLOC_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ALLOCA_FUNCTION_NAME, 1, unsigned_integer_to_void_pointer_type, 0, 0},
{ABORT_FUNCTION_NAME, 1, void_to_void_type, 0, 0},
{ATEXIT_FUNCTION_NAME, 1, void_to_void_to_int_pointer_type, 0, 0},
{EXIT_FUNCTION_NAME, 1, integer_to_void_type, 0, 0},
{_EXIT_FUNCTION_NAME, 1, integer_to_void_type, 0, 0},
{GETENV_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SYSTEM_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{BSEARCH_FUNCTION_NAME, 5, default_intrinsic_type, 0, 0},
{QSORT_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{C_ABS_FUNCTION_NAME, 1, integer_to_integer_type, typing_function_int_to_int, 0},
{LABS_FUNCTION_NAME, 1, longinteger_to_longinteger_type, typing_function_longint_to_longint, 0},
{LLABS_FUNCTION_NAME, 1, longlonginteger_to_longlonginteger_type, typing_function_longlongint_to_longlongint, 0},
{DIV_FUNCTION_NAME, 2, integer_to_overloaded_type, 0, 0},
{LDIV_FUNCTION_NAME, 2, longinteger_to_overloaded_type, 0, 0},
{LLDIV_FUNCTION_NAME, 2, longlonginteger_to_overloaded_type, 0, 0},
{MBLEN_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{MBTOWC_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{WCTOMB_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{MBSTOWCS_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{WCSTOMBS_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
//to check
{POSIX_MEMALIGN_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ATOQ_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{EXITHANDLE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{DRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ERAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{JRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{LCONG48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{LRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{MRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{NRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SEED48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SRAND48_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{PUTENV_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SETKEY_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SWAB_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{MKSTEMP_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{MKSTEMP64_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{A614_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ECVT_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{FCVT_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{GCVT_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{GETSUBOPT_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{GRANTPT_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{INITSTATE_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{C_164A_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{MKTEMP_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{PTSNAME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{RANDOM_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0}, /* void -> long int */
{REALPATH_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{SETSTATE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{SRANDOM_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{TTYSLOT_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{UNLOCKPT_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{VALLOC_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{DUP2_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{QECVT_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{QFCVT_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{QGCVT_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{GETCWD_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{GETEXECNAME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{GETLOGIN_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{GETOPT_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{GETOPT_LONG_FUNCTION_NAME, 5, default_intrinsic_type, 0, 0},
{GETOPT_LONG_ONLY_FUNCTION_NAME, 5, default_intrinsic_type, 0, 0},
{GETPASS_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{GETPASSPHRASE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{GETPW_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ISATTY_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{MEMALIGN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{TTYNAME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{LLTOSTR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ULLTOSTR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
/*#include */
{MEMCPY_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{MEMMOVE_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{STRCPY_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRDUP_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{STRNCPY_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{STRCAT_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRNCAT_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{MEMCMP_FUNCTION_NAME,3,overloaded_to_integer_type, 0, 0},
{STRCMP_FUNCTION_NAME,2,overloaded_to_integer_type, 0, 0},
{STRCOLL_FUNCTION_NAME,2,overloaded_to_integer_type, 0, 0},
{STRNCMP_FUNCTION_NAME,3,overloaded_to_integer_type, 0, 0},
{STRXFRM_FUNCTION_NAME,3,overloaded_to_integer_type, 0, 0},
{MEMCHR_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{STRCHR_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRCSPN_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRPBRK_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRRCHR_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRSPN_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRSTR_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{STRTOK_FUNCTION_NAME,2,default_intrinsic_type, 0, 0},
{MEMSET_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{STRERROR_FUNCTION_NAME,1,integer_to_overloaded_type, 0, 0},
{STRERROR_R_FUNCTION_NAME,3,default_intrinsic_type, 0, 0},
{STRLEN_FUNCTION_NAME,1,default_intrinsic_type, 0, 0},
/*#include */
/*#include */
{TIME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{LOCALTIME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{DIFFTIME_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{NANOSLEEP_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{GETTIMEOFDAY_FUNCTION_NAME, 2, overloaded_to_void_type, 0, 0}, // BSD-GNU
{CLOCK_GETTIME_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0}, // BSD-GNU
{CLOCK_FUNCTION_NAME, 0, void_to_overloaded_type, 0, 0},
{SECOND_FUNCTION_NAME, 0, void_to_overloaded_type, 0, 0}, //GFORTRAN
/*#include */
{ FWPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ FWSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ SWPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ SWSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ VFWPRINTF_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{ VFWSCANF_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{ VSWPRINTF_FUNCTION_NAME, 4, overloaded_to_integer_type, 0, 0},
{ VSWSCANF_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{ VWPRINTF_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{ VWSCANF_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{ WPRINTF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ WSCANF_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{ FGETWC_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ FGETWS_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ FPUTWC_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ FPUTWS_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ FWIDE_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{ GETWC_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ GETWCHAR_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{ PUTWC_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ PUTWCHAR_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ UNGETWC_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSTOD_FUNCTION_NAME, 2, overloaded_to_double_type, 0, 0},
{ WCSTOF_FUNCTION_NAME, 2, overloaded_to_real_type, 0, 0},
{ WCSTOLD_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSTOL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSTOLL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSTOUL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSTOULL_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSCPY_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSNCPY_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WMEMCPY_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WMEMMOVE_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSCAT_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSNCAT_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSCMP_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{ WCSCOLL_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
{ WCSNCMP_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{ WCSXFRM_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WMEMCMP_FUNCTION_NAME, 3, overloaded_to_integer_type, 0, 0},
{ WCSCHR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSCSPN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSPBRK_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSRCHR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSSPN_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSSTR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSTOK_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WMEMCHR_FUNCTION_NAME, 2, default_intrinsic_type, 0, 0},
{ WCSLEN_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ WMEMSET_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCSFTIME_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{ BTOWC_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ WCTOB_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{ MBSINIT_FUNCTION_NAME, 1, overloaded_to_integer_type, 0, 0},
{ MBRLEN_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ MBRTOWC_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ WCRTOMB_FUNCTION_NAME, 3, default_intrinsic_type, 0, 0},
{ MBSRTOWCS_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
{ WCSRTOMBS_FUNCTION_NAME, 4, default_intrinsic_type, 0, 0},
/*#include */
{ISWALNUM_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWALPHA_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWBLANK_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWCNTRL_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWDIGIT_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWGRAPH_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWLOWER_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWPRINT_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWPUNCT_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWSPACE_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWUPPER_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWXDIGIT_OPERATOR_NAME, 1, overloaded_to_integer_type, 0, 0},
{ISWCTYPE_OPERATOR_NAME, 2, overloaded_to_integer_type, 0, 0},
{WCTYPE_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{TOWLOWER_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{TOWUPPER_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
{TOWCTRANS_OPERATOR_NAME, 2, default_intrinsic_type, 0, 0},
{WCTRANS_OPERATOR_NAME, 1, default_intrinsic_type, 0, 0},
/* netdb.h */
{__H_ERRNO_LOCATION_OPERATOR_NAME, 0, default_intrinsic_type, 0, 0},
/* #include */
{FCNTL_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{DIRECTIO_FUNCTION_NAME, 2, integer_to_integer_type, 0, 0},
{OPEN64_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{CREAT64_FUNCTION_NAME, 2, overloaded_to_integer_type, 0, 0},
/* OMP */
{OMP_IF_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{OMP_OMP_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{OMP_FOR_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{OMP_PRIVATE_FUNCTION_NAME,(INT_MAX), default_intrinsic_type, 0, 0},
{OMP_PARALLEL_FUNCTION_NAME, 0, default_intrinsic_type, 0, 0},
{OMP_REDUCTION_FUNCTION_NAME,(INT_MAX), default_intrinsic_type, 0, 0},
/* BSD */
{ERR_FUNCTION_NAME, (INT_MAX), overloaded_to_void_type, 0, 0},
{ERRX_FUNCTION_NAME, (INT_MAX), overloaded_to_void_type, 0, 0},
{WARN_FUNCTION_NAME, (INT_MAX), overloaded_to_void_type, 0, 0},
{WARNX_FUNCTION_NAME, (INT_MAX), overloaded_to_void_type, 0, 0},
{VERR_FUNCTION_NAME, 3, overloaded_to_void_type, 0, 0},
{VERRX_FUNCTION_NAME, 3, overloaded_to_void_type, 0, 0},
{VWARN_FUNCTION_NAME, 2, overloaded_to_void_type, 0, 0},
{VWARNX_FUNCTION_NAME, 2, overloaded_to_void_type, 0, 0},
/* F95 */
{ALLOCATE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{DEALLOCATE_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{ETIME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{DTIME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
{CPU_TIME_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
/* F2003 */
{C_LOC_FUNCTION_NAME, 1, default_intrinsic_type, 0, 0},
/* PIPS run-time support for C code generation
*
* Source code located in validation/Hyperplane/run_time.src for the
* time being.
*/
{PIPS_C_MIN_OPERATOR_NAME, (INT_MAX), integer_to_integer_type,
typing_function_int_to_int, 0},
{PIPS_C_MAX_OPERATOR_NAME, (INT_MAX), integer_to_integer_type,
typing_function_int_to_int, 0},
{PIPS_C_DIV_OPERATOR_NAME, 2, integer_to_integer_type,
typing_function_int_to_int, 0},
/* assembly function */
{ ASM_FUNCTION_NAME, 1, overloaded_to_void_type , 0 , 0},
// The 2 last arg don't know for what
/* PIPS intrinsics to simulate various effects */
{PIPS_MEMORY_BARRIER_OPERATOR_NAME, 0, void_to_void_type, 0, 0},
{PIPS_IO_BARRIER_OPERATOR_NAME, 0, void_to_void_type, 0, 0},
/*SPIRE*/
{SEND_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
{RECV_FUNCTION_NAME, (INT_MAX), overloaded_to_integer_type, 0, 0},
/*MPI necessary calls*/
//since C and Fortran MPI functions are not differentiate,
// The Fortran version is consider for number of argument
// (it has 1 more argument for the error handler when the C version return it)
{MPI_INIT_FUNCTION_NAME, (3), overloaded_to_integer_type, 0, 0},
{MPI_FINALIZE_FUNCTION_NAME, (1), overloaded_to_integer_type, 0, 0},
{MPI_BARRIER_FUNCTION_NAME, (2), overloaded_to_integer_type, 0, 0},
{MPI_COMM_SIZE_FUNCTION_NAME, (3), overloaded_to_integer_type, 0, 0},
{MPI_COMM_RANK_FUNCTION_NAME, (3), overloaded_to_integer_type, 0, 0},
{MPI_SEND_FUNCTION_NAME, (7), overloaded_to_integer_type, 0, 0},
{MPI_SSEND_FUNCTION_NAME, (7), overloaded_to_integer_type, 0, 0},
{MPI_RSEND_FUNCTION_NAME, (7), overloaded_to_integer_type, 0, 0},
{MPI_BSEND_FUNCTION_NAME, (7), overloaded_to_integer_type, 0, 0},
{MPI_ISEND_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_ISSEND_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_IRSEND_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_IBSEND_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_RECV_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_IRECV_FUNCTION_NAME, (8), overloaded_to_integer_type, 0, 0},
{MPI_SENDRECV_FUNCTION_NAME, (13), overloaded_to_integer_type, 0, 0},
{NULL, 0, 0, 0, 0}
};
intrinsic_type_descriptor_mapping=hash_table_make(hash_string,sizeof(IntrinsicTypeDescriptorTable));
for(IntrinsicDescriptor *p = &IntrinsicTypeDescriptorTable[0];p->name;++p) {
if(!set_belong_p(module_list,p->name))
register_intrinsic_type_descriptor(p);
}
}
bool bootstrap(string workspace)
{
pips_debug(1, "bootstraping in workspace %s\n", workspace);
if (db_resource_p(DBR_ENTITIES, ""))
pips_internal_error("entities already initialized");
/* Create all intrinsics, skipping user-defined one */
set module_list = set_make(set_string);
gen_array_t ml = db_get_module_list();
for(int i=0; i < (int) gen_array_nitems(ml); i++)
set_add_element(module_list, module_list, (char*)gen_array_item(ml,i));
CreateIntrinsics(module_list);
set_free(module_list);
gen_array_free(ml);
/* Creates the dynamic and static areas for the super global
* arrays such as the logical unit array (see below).
*/
CreateAreas();
/* The current entity is unknown, but for a TOP-LEVEL:TOP-LEVEL
* which is used to create the logical unit array for IO effects
*/
CreateLogicalUnits();
/* create hidden variables to modelize the abstract states defined by the libc:
seed for random function package
heap abstract state
*/
CreateRandomSeed();
CreateTimeSeed();
CreateHeapAbstractState();
/* Create hidden variable to modelize the abstract state of :
temporary arry for memmove function. Molka Becher
*/
CreateMemmoveAbstractState();
/* Create the empty label */
(void) make_entity(strdup(concatenate(TOP_LEVEL_MODULE_NAME,
MODULE_SEP_STRING,
LABEL_PREFIX,
NULL)),
MakeTypeStatement(),
make_storage_rom(),
make_value(is_value_constant,
make_constant_litteral()),
DEFAULT_ENTITY_KIND);
/* FI: I suppress the owner filed to make the database moveable */
/* FC: the content must be consistent with pipsdbm/methods.h */
DB_PUT_MEMORY_RESOURCE(DBR_ENTITIES, "", (char*) entity_domain);
pips_debug(1, "bootstraping done\n");
return true;
}
value
MakeValueLitteral()
{
return(make_value(is_value_constant,
make_constant(is_constant_litteral, UU)));
}
string
MakeFileName(prefix, base, suffix)
char *prefix, *base, *suffix;
{
char *s;
s = (char*) malloc(strlen(prefix)+strlen(base)+strlen(suffix)+1);
strcpy(s, prefix);
strcat(s, base);
strcat(s, suffix);
return(s);
}
/* This array is pointed by FILE * pointers returned or used by fopen,
fclose,... . The argument f must be the intrinsic fopen returning a
FILE * or another function also returning a FILE *. So we do not
have to synthesize the type FILE. */
entity MakeIoFileArray(entity f)
{
entity io_files = FindOrCreateEntity(IO_EFFECTS_PACKAGE_NAME, IO_EFFECTS_IO_FILE_NAME);
if(type_undefined_p(entity_type(io_files))) {
/* FI: this initialization is usually performed in
bootstrap.c, but it is easier to do it here because the
IO_FILE type does not have to be built from scratch. */
type rt = functional_result(type_functional(entity_type(f)));
type ct = copy_type(type_to_pointed_type(rt)); // FI: no risk with typedef
pips_assert("ct is a scalar type",
ENDP(variable_dimensions(type_variable(ct))));
variable_dimensions(type_variable(ct)) =
CONS(DIMENSION,
make_dimension(int_to_expression(0),
/*
MakeNullaryCall
(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME))
*/
int_to_expression(2000),
NIL),
NIL);
entity_type(io_files) = ct;
entity ent = FindOrCreateEntity(TOP_LEVEL_MODULE_NAME,
IO_EFFECTS_PACKAGE_NAME);
entity_storage(io_files) =
make_storage(is_storage_ram,
make_ram(ent,
FindEntity(IO_EFFECTS_PACKAGE_NAME,
STATIC_AREA_LOCAL_NAME),
0, NIL));
entity_initial(io_files) = make_value(is_value_unknown, UU);
}
return io_files;
}