tree gfc_conv_string_init (tree length, gfc_expr * expr) { gfc_char_t *s; HOST_WIDE_INT len; int slen; tree str; bool free_s = false; gcc_assert (expr->expr_type == EXPR_CONSTANT); gcc_assert (expr->ts.type == BT_CHARACTER); gcc_assert (INTEGER_CST_P (length)); gcc_assert (TREE_INT_CST_HIGH (length) == 0); len = TREE_INT_CST_LOW (length); slen = expr->value.character.length; if (len > slen) { s = gfc_get_wide_string (len); memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); gfc_wide_memset (&s[slen], ' ', len - slen); free_s = true; } else s = expr->value.character.string; str = gfc_build_wide_string_const (expr->ts.kind, len, s); if (free_s) free (s); return str; }
int gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { int i; if (result->ts.cl && result->ts.cl->length) result->value.character.length = (int) mpz_get_ui (result->ts.cl->length->value.integer); gcc_assert (buffer_size >= size_character (result->value.character.length, result->ts.kind)); result->value.character.string = gfc_get_wide_string (result->value.character.length + 1); if (result->ts.kind == gfc_default_character_kind) for (i = 0; i < result->value.character.length; i++) result->value.character.string[i] = (gfc_char_t) buffer[i]; else { mpz_t integer; unsigned bytes = size_character (1, result->ts.kind); mpz_init (integer); gcc_assert (bytes <= sizeof (unsigned long)); for (i = 0; i < result->value.character.length; i++) { gfc_conv_tree_to_mpz (integer, native_interpret_expr (gfc_get_char_type (result->ts.kind), &buffer[bytes*i], buffer_size-bytes*i)); result->value.character.string[i] = (gfc_char_t) mpz_get_ui (integer); } mpz_clear (integer); } result->value.character.string[result->value.character.length] = '\0'; return result->value.character.length; }
static gfc_expr * create_character_intializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { int len, start, end; gfc_char_t *dest; gfc_extract_int (ts->cl->length, &len); if (init == NULL) { /* Create a new initializer. */ init = gfc_get_expr (); init->expr_type = EXPR_CONSTANT; init->ts = *ts; dest = gfc_get_wide_string (len + 1); dest[len] = '\0'; init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ if (ref != NULL) gfc_wide_memset (dest, ' ', len); } else dest = init->value.character.string; if (ref) { gfc_expr *start_expr, *end_expr; gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds are one-based [start, end], we want zero based [start, end). */ start_expr = gfc_copy_expr (ref->u.ss.start); end_expr = gfc_copy_expr (ref->u.ss.end); if ((gfc_simplify_expr (start_expr, 1) == FAILURE) || (gfc_simplify_expr (end_expr, 1)) == FAILURE) { gfc_error ("failure to simplify substring reference in DATA " "statement at %L", &ref->u.ss.start->where); return NULL; } gfc_extract_int (start_expr, &start); start--; gfc_extract_int (end_expr, &end); } else { /* Set the whole string. */ start = 0; end = len; } /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) len = rvalue->representation.length; else len = rvalue->value.character.length; if (len > end - start) { len = end - start; gfc_warning_now ("initialization string truncated to match variable " "at %L", &rvalue->where); } if (rvalue->ts.type == BT_HOLLERITH) { int i; for (i = 0; i < len; i++) dest[start+i] = rvalue->representation.string[i]; } else memcpy (&dest[start], rvalue->value.character.string, len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) { init->representation.length = init->value.character.length; init->representation.string = gfc_widechar_to_char (init->value.character.string, init->value.character.length); } return init; }