/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "tm.h"
+#include "tm.h" /* For UNITS_PER_WORD. */
#include "tree.h"
#include "ggc.h"
#include "toplev.h"
-#include "real.h"
-#include "gimple.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
tree type;
tree bound;
tree tmp;
- tree cond, cond1, cond2, cond3, cond4, size;
+ tree cond, cond1, cond3, cond4, size;
tree ubound;
tree lbound;
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
- gfc_ref *ref;
arg = expr->value.function.actual;
arg2 = arg->next;
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- /* Follow any component references. */
- if (arg->expr->expr_type == EXPR_VARIABLE
- || arg->expr->expr_type == EXPR_CONSTANT)
- {
- as = arg->expr->symtree->n.sym->as;
- for (ref = arg->expr->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_COMPONENT:
- as = ref->u.c.component->as;
- continue;
-
- case REF_SUBSTRING:
- continue;
-
- case REF_ARRAY:
- {
- switch (ref->u.ar.type)
- {
- case AR_ELEMENT:
- case AR_SECTION:
- case AR_UNKNOWN:
- as = NULL;
- continue;
-
- case AR_FULL:
- break;
- }
- break;
- }
- }
- }
- }
- else
- as = NULL;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
/* 13.14.53: Result value for LBOUND
tree stride = gfc_conv_descriptor_stride_get (desc, bound);
cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
- cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
gfc_index_zero_node);
gfc_expr *arg;
gfc_ss *ss;
gfc_se argse;
- tree source;
tree source_bytes;
tree type;
tree tmp;
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg);
- source = argse.expr;
type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
argse.expr));
source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg, ss);
- source = gfc_conv_descriptor_data_get (argse.expr);
type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Obtain the argument's word length. */
tree size_bytes;
tree upper;
tree lower;
- tree stride;
tree stmt;
gfc_actual_arglist *arg;
gfc_se argse;
tree idx;
idx = gfc_rank_cst[n];
gfc_add_modify (&argse.pre, source_bytes, tmp);
- stride = gfc_conv_descriptor_stride_get (argse.expr, idx);
lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
scalar_transfer:
extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
dest_word_len, source_bytes);
+ extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
if (expr->ts.type == BT_CHARACTER)
{
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
ss1 = gfc_walk_expr (arg1->expr);
- arg1se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ if (ss1 == gfc_ss_terminator)
+ {
+ /* Allocatable scalar. */
+ arg1se.want_pointer = 1;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg1->expr, "$data");
+ gfc_conv_expr (&arg1se, arg1->expr);
+ tmp = arg1se.expr;
+ }
+ else
+ {
+ /* Allocatable array. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ }
+
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg1->expr, "$data");
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
}
+/* Generate code for the SAME_TYPE_AS intrinsic.
+ Generate inline code that directly checks the vindices. */
+
+static void
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
+{
+ gfc_expr *a, *b;
+ gfc_se se1, se2;
+ tree tmp;
+
+ gfc_init_se (&se1, NULL);
+ gfc_init_se (&se2, NULL);
+
+ a = expr->value.function.actual->expr;
+ b = expr->value.function.actual->next->expr;
+
+ if (a->ts.type == BT_CLASS)
+ {
+ gfc_add_component_ref (a, "$vptr");
+ gfc_add_component_ref (a, "$hash");
+ }
+ else if (a->ts.type == BT_DERIVED)
+ a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ a->ts.u.derived->hash_value);
+
+ if (b->ts.type == BT_CLASS)
+ {
+ gfc_add_component_ref (b, "$vptr");
+ gfc_add_component_ref (b, "$hash");
+ }
+ else if (b->ts.type == BT_DERIVED)
+ b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ b->ts.u.derived->hash_value);
+
+ gfc_conv_expr (&se1, a);
+ gfc_conv_expr (&se2, b);
+
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+ se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+ se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
+}
+
+
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr);
else
- gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
+ gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this,
void
gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{
- gfc_intrinsic_sym *isym;
const char *name;
int lib, kind;
tree fndecl;
- isym = expr->value.function.isym;
-
name = &expr->value.function.name[2];
if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
gfc_conv_associated(se, expr);
break;
+ case GFC_ISYM_SAME_TYPE_AS:
+ gfc_conv_same_type_as (se, expr);
+ break;
+
case GFC_ISYM_ABS:
gfc_conv_intrinsic_abs (se, expr);
break;
case GFC_ISYM_CHMOD:
case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
+ case GFC_ISYM_EXTENDS_TYPE_OF:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_FNUM:
OSDN Git Service
