You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* Since target arithmetic must be done on the host, there has to
be some way of evaluating arithmetic expressions as the host
switch (code)
{
case ARITH_OK:
- p = "Arithmetic OK";
+ p = _("Arithmetic OK at %L");
break;
case ARITH_OVERFLOW:
- p = "Arithmetic overflow";
+ p = _("Arithmetic overflow at %L");
break;
case ARITH_UNDERFLOW:
- p = "Arithmetic underflow";
+ p = _("Arithmetic underflow at %L");
break;
case ARITH_NAN:
- p = "Arithmetic NaN";
+ p = _("Arithmetic NaN at %L");
break;
case ARITH_DIV0:
- p = "Division by zero";
+ p = _("Division by zero at %L");
break;
case ARITH_INCOMMENSURATE:
- p = "Array operands are incommensurate";
+ p = _("Array operands are incommensurate at %L");
break;
case ARITH_ASYMMETRIC:
- p = "Integer outside symmetric range implied by Standard Fortran";
+ p =
+ _("Integer outside symmetric range implied by Standard Fortran at %L");
break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
if (val == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+ gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (val == ARITH_ASYMMETRIC)
{
- gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+ gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
goto runtime;
- if (op1->expr_type != EXPR_CONSTANT
- && (op1->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (op1)
- || !gfc_expanded_ac (op1)))
+ if (op1->from_H
+ || (op1->expr_type != EXPR_CONSTANT
+ && (op1->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op1)
+ || !gfc_expanded_ac (op1))))
goto runtime;
if (op2 != NULL
- && op2->expr_type != EXPR_CONSTANT
- && (op2->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (op2)
- || !gfc_expanded_ac (op2)))
+ && (op2->from_H
+ || (op2->expr_type != EXPR_CONSTANT
+ && (op2->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op2)
+ || !gfc_expanded_ac (op2)))))
goto runtime;
if (unary)
if (rc != ARITH_OK)
{ /* Something went wrong */
- gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+ gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
static void
arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
{
- gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
- gfc_typename (from), gfc_typename (to), where);
+ switch (rc)
+ {
+ case ARITH_OK:
+ gfc_error ("Arithmetic OK converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_OVERFLOW:
+ gfc_error ("Arithmetic overflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_UNDERFLOW:
+ gfc_error ("Arithmetic underflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_NAN:
+ gfc_error ("Arithmetic NaN converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_DIV0:
+ gfc_error ("Division by zero converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_INCOMMENSURATE:
+ gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_ASYMMETRIC:
+ gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+ " converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ default:
+ gfc_internal_error ("gfc_arith_error(): Bad error code");
+ }
/* TODO: Do something about the error, ie, throw exception, return
NaN, etc. */
{
if (rc == ARITH_ASYMMETRIC)
{
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
}
else
{
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
return result;
}
+
+/* Convert logical to integer. */
+
+gfc_expr *
+gfc_log2int (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ mpz_set_si (result->value.integer, src->value.logical);
+ return result;
+}
+
+/* Convert integer to logical. */
+
+gfc_expr *
+gfc_int2log (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
+ return result;
+}
+
+/* Convert Hollerith to integer. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2int (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+ int len;
+
+ len = src->value.character.length;
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_CONSTANT;
+ result->ts.type = BT_INTEGER;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to real. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2real (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+ int len;
+
+ len = src->value.character.length;
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_CONSTANT;
+ result->ts.type = BT_REAL;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to complex. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2complex (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+ int len;
+
+ len = src->value.character.length;
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_CONSTANT;
+ result->ts.type = BT_COMPLEX;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ kind = kind * 2;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to character. */
+
+gfc_expr *
+gfc_hollerith2character (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+
+ result = gfc_copy_expr (src);
+ result->ts.type = BT_CHARACTER;
+ result->ts.kind = kind;
+ result->from_H = 1;
+
+ return result;
+}
+
+/* Convert Hollerith to logical. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2logical (gfc_expr * src, int kind)
+{
+ gfc_expr *result;
+ int len;
+
+ len = src->value.character.length;
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_CONSTANT;
+ result->ts.type = BT_LOGICAL;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
OSDN Git Service
