From patchwork Mon Aug 12 19:40:07 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1971658 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.a=rsa-sha256 header.s=nc1116a header.b=nIpmSG91; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4WjPyN5qZTz1yYl for ; Tue, 13 Aug 2024 05:40:59 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id BC6C23858C50 for ; Mon, 12 Aug 2024 19:40:57 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout3.netcologne.de (cc-smtpout3.netcologne.de [IPv6:2001:4dd0:100:1062:25:2:0:3]) by sourceware.org (Postfix) with ESMTPS id 4C00C3858D20; Mon, 12 Aug 2024 19:40:12 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 4C00C3858D20 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=netcologne.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=netcologne.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 4C00C3858D20 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2001:4dd0:100:1062:25:2:0:3 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723491622; cv=none; b=tZfjCM37P6PsG/CNWlOSa2ch8z/ooiPWv6oXrvB5TMUgowfV9cyEHZZibtGv/4redCetXAHgy+qPflx/YXSVL78wo3tFbyzJFoQv/WF9D5I30IF5H9yoh7n37Rp3aqCgA0OTQdQe2z1u1dmVb+GYoj45AMAqU1utI5/OXLrwx4c= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723491622; c=relaxed/simple; bh=g/sxDKLxH8FroVYUaB+YM4uT1fHAF63h38bEt/juJyQ=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=p4y9BJB6ovEIYXY7+XM2AFv9wzCzufrDObOO/PKTHoqivlvAKncnahzBKSLqOjI4hK3kQLZkBVho5F+I0NG7L0YvNa36psJkZ4cUxmLGuLlIDQwrBBqRhS5b50Az6Zt2sMw296itNfnW6SMEgas5Hal2goc0uQ93cCJ9b4n0jJo= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cc-smtpin2.netcologne.de (cc-smtpin2.netcologne.de [89.1.8.202]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id EB4C9125D9; Mon, 12 Aug 2024 21:40:09 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1723491610; bh=g/sxDKLxH8FroVYUaB+YM4uT1fHAF63h38bEt/juJyQ=; h=Message-ID:Date:To:From:Subject:From; b=nIpmSG91QUnRzsAFPt/kbH3mj8h8xChwlgM7izv/rUdqv5dnd1466e09Dpyc3lHIg dgZR9YZmSiC117rHBbK7+HfZWWTc2dKknQztqT5GKn4JYms9qOpPLExp+H/EexZ1CU T9l6zFPFJjTAiZ5IgYOc8geUn9RB85rlXyWduSn+EW4xq776Xvanapzmu/2StCw/87 gaMdcbBAy1Puq6/7mzXRb80klC0jlTSuoSrxL6YdcopOlw3VswwFq5OLloUbT77Hia HAXMOoZsgv2FKYZy7mZBMNg/c2RvMCV4QSjLouePiispaxHgZ5kr1H1htYZsrIzy7P Ib9tY2lSJQvRg== Received: from [IPV6:2001:4dd7:49a:0:4942:4a44:df8d:c191] (2001-4dd7-49a-0-4942-4a44-df8d-c191.ipv6dyn.netcologne.de [IPv6:2001:4dd7:49a:0:4942:4a44:df8d:c191]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by cc-smtpin2.netcologne.de (Postfix) with ESMTPSA id 8F7DA11DCC; Mon, 12 Aug 2024 21:40:07 +0200 (CEST) Message-ID: <7e2c06f4-a402-4be4-98a7-aab44f14e033@netcologne.de> Date: Mon, 12 Aug 2024 21:40:07 +0200 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US, de-DE To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] First part of Fortran's unsigned implementation X-NetCologne-Spam: L X-Spamd-Bar: / X-Rspamd-Action: no action X-Rspamd-Queue-Id: 8F7DA11DCC X-Spam-Status: No, score=-9.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org Hello world, the attached patch and ChangeLog show the current state of the UNSIGNED implementation for gfortran. This pretty much follows J3/24-116.txt and implements the basic functionality, plus the non-array intrinsics. Some basic functionality is tested (see the attached test cases), but there are, with a very high probability, still quite a few bugs. However, given my problems with git and the branch, maybe the best strategy is to push this to master as soon as possible; I would then start working on the array intrinsics. Regarding where to put this: Paul, you had the idea of making this dependent on a future standard plan. I think we can do this, setting -funsigned when this is flag is set. Where to put the test cases: I currently have them in the main gfortran.dg directory. A subdirectory might also be a good idea, but then somebody would have to help me withe DejaGnu code to put there. So... Comments? Suggestions? OK for master? Best regards Thomas gcc/fortran/ChangeLog: * arith.cc (gfc_reduce_unsigned): New function. (gfc_arith_error): Add ARITH_UNSIGNED_TRUNCATED and ARITH_UNSIGNED_NEGATIVE. (gfc_arith_init_1): Initialize unsigned types. (gfc_check_unsigned_range): New function. (gfc_range_check): Handle unsigned types. (gfc_arith_uminus): Likewise. (gfc_arith_plus): Likewise. (gfc_arith_minus): Likewise. (gfc_arith_times): Likewise. (gfc_arith_divide): Likewise. (gfc_compare_expr): Likewise. (eval_intrinsic): Likewise. (gfc_int2int): Also convert unsigned. (gfc_uint2uint): New function. (gfc_int2uint): New function. (gfc_uint2int): New function. (gfc_uint2real): New function. (gfc_uint2complex): New function. (gfc_real2uint): New function. (gfc_complex2uint): New function. (gfc_log2uint): New function. (gfc_uint2log): New function. * arith.h (gfc_int2uint, gfc_uint2uint, gfc_uint2int, gfc_uint2real, gfc_uint2complex, gfc_real2uint, gfc_complex2uint, gfc_log2uint, gfc_uint2log: Add prototypes. * check.cc (gfc_boz2uint): New function (type_check2): New function. (int_or_real_or_unsigned_check): New function. (less_than_bitsizekind): Adjust for unsingeds. (less_than_bitsize2): Likewise. (gfc_check_allocated): Likewise. (gfc_check_mod): Likewise. (gfc_check_bge_bgt_ble_blt): Likewise. (gfc_check_bitfcn): Likewise. (gfc_check_digits): Likewise. (gfc_check_dshift): Likewise. (gfc_check_huge): Likewise. (gfc_check_iu): New function. (gfc_check_iand_ieor_ior): Adjust for unsigneds. (gfc_check_ibits): Likewise. (gfc_check_uint): New function. (gfc_check_ishft): Adjust for unsigneds. (gfc_check_ishftc): Likewise. (gfc_check_min_max): Likewise. (gfc_check_merge_bits): Likewise. (gfc_check_selected_int_kind): Likewise. (gfc_check_shift): Likewise. (gfc_check_mvbits): Likewise. (gfc_invalid_unsigned_ops): Likewise. * decl.cc (gfc_match_decl_type_spec): Likewise. * dump-parse-tree.cc (show_expr): Likewise. * expr.cc (gfc_get_constant_expr): Likewise. (gfc_copy_expr): Likewise. (gfc_extract_int): Likewise. (numeric_type): Likewise. * gfortran.h (enum arith): Extend with ARITH_UNSIGNED_TRUNCATED and ARITH_UNSIGNED_NEGATIVE. (enum gfc_isym_id): Extend with GFC_ISYM_SU_KIND and GFC_ISYM_UINT. (gfc_check_unsigned_range): New prototype- (gfc_arith_error): Likewise. (gfc_reduce_unsigned): Likewise. (gfc_boz2uint): Likewise. (gfc_invalid_unsigned_ops): Likewise. (gfc_convert_mpz_to_unsigned): Likewise. * gfortran.texi: Add some rudimentary documentation. * intrinsic.cc (gfc_type_letter): Adjust for unsigneds. (add_functions): Add uint and adjust functions to be called. (add_conversions): Add unsigned conversions. (gfc_convert_type_warn): Adjust for unsigned. * intrinsic.h (gfc_check_iu, gfc_check_uint, gfc_check_mod, gfc_simplify_uint, gfc_simplify_selected_unsigned_kind, gfc_resolve_uint): New prototypes. * invoke.texi: Add -funsigned. * iresolve.cc (gfc_resolve_dshift): Handle unsigneds. (gfc_resolve_iand): Handle unsigneds. (gfc_resolve_ibclr): Handle unsigneds. (gfc_resolve_ibits): Handle unsigneds. (gfc_resolve_ibset): Handle unsigneds. (gfc_resolve_ieor): Handle unsigneds. (gfc_resolve_ior): Handle unsigneds. (gfc_resolve_uint): Handle unsigneds. (gfc_resolve_merge_bits): Handle unsigneds. (gfc_resolve_not): Handle unsigneds. * lang.opt: Add -funsigned. * libgfortran.h: Add BT_UNSIGNED. * match.cc (gfc_match_type_spec): Match UNSIGNED. * misc.cc (gfc_basic_typename): Add UNSIGNED. (gfc_typename): Likewise. * primary.cc (convert_unsigned): New function. (match_unsigned_constant): New function. (gfc_match_literal_constant): Handle unsigned. * resolve.cc (resolve_operator): Handle unsigned. (resolve_ordinary_assign): Likewise. * simplify.cc (convert_mpz_to_unsigned): Renamed to... (gfc_convert_mpz_to_unsigned): and adjusted. (gfc_simplify_bit_size): Adjusted for unsigned. (compare_bitwise): Likewise. (gfc_simplify_bge): Likewise. (gfc_simplify_bgt): Likewise. (gfc_simplify_ble): Likewise. (gfc_simplify_blt): Likewise. (simplify_cmplx): Likewise. (gfc_simplify_digits): Likewise. (simplify_dshift): Likewise. (gfc_simplify_huge): Likewise. (gfc_simplify_iand): Likewise. (gfc_simplify_ibclr): Likewise. (gfc_simplify_ibits): Likewise. (gfc_simplify_ibset): Likewise. (gfc_simplify_ieor): Likewise. (gfc_simplify_uint): Likewise. (gfc_simplify_ior): Likewise. (simplify_shift): Likewise. (gfc_simplify_ishftc): Likewise. (gfc_simplify_merge_bits): Likewise. (min_max_choose): Likewise. (gfc_simplify_mod): Likewise. (gfc_simplify_modulo): Likewise. (gfc_simplify_popcnt): Likewise. (gfc_simplify_range): Likewise. (gfc_simplify_selected_unsigned_kind): Likewise. (gfc_convert_constant): Likewise. * target-memory.cc (size_unsigned): New function. (gfc_element_size): Adjust for unsigned. * trans-const.cc (gfc_conv_mpz_unsigned_to_tree): Handle unsigneds. (gfc_conv_constant_to_tree): Likewise. * trans-decl.cc (gfc_conv_cfi_to_gfc): Put in "not yet implemented". * trans-expr.cc (gfc_conv_gfc_desc_to_cfi_desc): Likewise. * trans-intrinsic.cc (gfc_conv_intrinsic_mod): Handle unsigned. (gfc_conv_intrinsic_shift): Likewise. (gfc_conv_intrinsic_function): Add GFC_ISYM_UINT. * trans-io.cc (enum iocall): Add IOCALL_X_UNSIGNED and IOCALL_X_UNSIGNED_WRITE. (gfc_build_io_library_fndecls): Add transfer_unsigned and transfer_unsigned_write. (transfer_expr): Handle unsigneds. * trans-types.cc (gfc_unsinged_kinds): New array. (gfc_unsigned_types): Likewise. (gfc_init_kinds): Handle them. (validate_unsigned): New function. (gfc_validate_kind): Use it. (gfc_build_unsigned_type): New function. (gfc_init_types): Use it. (gfc_get_unsigned_type): New function. (gfc_typenode_for_spec): Handle unsigned. * trans-types.h (gfc_get_unsigned_type): New prototype. libgfortran/ChangeLog: * gfortran.map: Add _gfortran_transfer_unsgned and _gfortran_transfer-signed. * io/io.h (set_unsigned): New prototype. (us_max): New prototype. (read_decimal_unsigned): New prototype. (write_iu): New prototype. * io/list_read.c (convert_unsigned): New function. (read_integer): Also handle unsigneds. (list_formatted_read_scalar): Handle unsigneds. (nml_read_obj): Likewise. * io/read.c (set_unsigned): New function. (us_max): New function. (read_utf8): Whitespace fixes. (read_default_char1): Whitespace fixes. (read_a_char4): Whitespace fixes. (next_char): Whiltespace fixes. (read_decimal_unsigned): New function. (read_f): Whitespace fixes. (read_x): Whitespace fixes. * io/transfer.c (transfer_unsigned): New function. (transfer_unsigned_write): (require_one_of_two_types): New function. (formatted_transfer_scalar_read): Use it. (formatted_transfer_scalar_write): Also use it. * io/write.c (write_decimal_unsigned): New function. (write_iu): New function. (write_unsigned): New function. (list_formatted_write_scalar): Adjust for unsigneds. * libgfortran.h (GFC_UINTEGER_1_HUGE): Define. (GFC_UINTEGER_2_HUGE): Define. (GFC_UINTEGER_4_HUGE): Define. (GFC_UINTEGER_8_HUGE): Define. (GFC_UINTEGER_16_HUGE): Define. (HAVE_GFC_UINTEGER_1): Undefine (done by mk-kind-h.sh) (HAVE_GFC_UINTEGER_4): Likewise. * mk-kinds-h.sh: Add GFC_UINTEGER_*_HUGE. gcc/testsuite/ChangeLog: * gfortran.dg/unsigned_1.f90: New test. * gfortran.dg/unsigned_10.f90: New test. * gfortran.dg/unsigned_11.f90: New test. * gfortran.dg/unsigned_12.f90: New test. * gfortran.dg/unsigned_13.f90: New test. * gfortran.dg/unsigned_14.f90: New test. * gfortran.dg/unsigned_15.f90: New test. * gfortran.dg/unsigned_16.f90: New test. * gfortran.dg/unsigned_17.f90: New test. * gfortran.dg/unsigned_18.f90: New test. * gfortran.dg/unsigned_19.f90: New test. * gfortran.dg/unsigned_2.f90: New test. * gfortran.dg/unsigned_20.f90: New test. * gfortran.dg/unsigned_21.f90: New test. * gfortran.dg/unsigned_22.f90: New test. * gfortran.dg/unsigned_3.f90: New test. * gfortran.dg/unsigned_4.f90: New test. * gfortran.dg/unsigned_5.f90: New test. * gfortran.dg/unsigned_6.f90: New test. * gfortran.dg/unsigned_7.f90: New test. * gfortran.dg/unsigned_8.f90: New test. * gfortran.dg/unsigned_9.f90: New test. diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index b373c25e5e1..e198506d58a 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -58,7 +58,16 @@ gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where) mpz_tdiv_q_2exp (z, z, -e); } +/* Reduce an unsigned number to within its range. */ +void +gfc_reduce_unsigned (gfc_expr *e) +{ + int k; + gcc_checking_assert (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_UNSIGNED); + k = gfc_validate_kind (BT_UNSIGNED, e->ts.kind, false); + mpz_and (e->value.integer, e->value.integer, gfc_unsigned_kinds[k].huge); +} /* Set the model number precision by the requested KIND. */ void @@ -86,7 +95,7 @@ gfc_set_model (mpfr_t x) /* Given an arithmetic error code, return a pointer to a string that explains the error. */ -static const char * +const char * gfc_arith_error (arith code) { const char *p; @@ -121,7 +130,12 @@ gfc_arith_error (arith code) case ARITH_INVALID_TYPE: p = G_("Invalid type in arithmetic operation at %L"); break; - + case ARITH_UNSIGNED_TRUNCATED: + p = G_("Unsigned constant truncated at %L"); + break; + case ARITH_UNSIGNED_NEGATIVE: + p = G_("Negation of unsigned constant at %L not permitted"); + break; default: gfc_internal_error ("gfc_arith_error(): Bad error code"); } @@ -160,6 +174,7 @@ void gfc_arith_init_1 (void) { gfc_integer_info *int_info; + gfc_unsigned_info *uint_info; gfc_real_info *real_info; mpfr_t a, b; int i; @@ -202,6 +217,36 @@ gfc_arith_init_1 (void) int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); } + /* Similar, for UNSIGNED. */ + if (flag_unsigned) + { + for (uint_info = gfc_unsigned_kinds; uint_info->kind != 0; uint_info++) + { + /* UNSIGNED is radix 2. */ + gcc_assert (uint_info->radix == 2); + /* Huge. */ + mpz_init (uint_info->huge); + mpz_set_ui (uint_info->huge, 2); + mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits); + mpz_sub_ui (uint_info->huge, uint_info->huge, 1); + + /* int_min - the smallest number we can reasonably convert from. */ + + mpz_init (uint_info->int_min); + mpz_set_ui (uint_info->int_min, 2); + mpz_pow_ui (uint_info->int_min, uint_info->int_min, + uint_info->digits - 1); + mpz_neg (uint_info->int_min, uint_info->int_min); + + /* Range. */ + mpfr_set_z (a, uint_info->huge, GFC_RND_MODE); + mpfr_log10 (a, a, GFC_RND_MODE); + mpfr_trunc (a,a); + uint_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); + } + + } + mpfr_clear (a); for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) @@ -344,6 +389,25 @@ gfc_check_integer_range (mpz_t p, int kind) return result; } +/* Same as above. */ +arith +gfc_check_unsigned_range (mpz_t p, int kind) +{ + int i; + + i = gfc_validate_kind (BT_UNSIGNED, kind, false); + + if (pedantic && mpz_cmp_si (p, 0) < 0) + return ARITH_UNSIGNED_NEGATIVE; + + if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0) + return ARITH_UNSIGNED_TRUNCATED; + + if (mpz_cmp (p, gfc_unsigned_kinds[i].huge) > 0) + return ARITH_UNSIGNED_TRUNCATED; + + return ARITH_OK; +} /* Given a real and a kind, make sure that the real lies within the range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or @@ -541,6 +605,10 @@ gfc_range_check (gfc_expr *e) rc = gfc_check_integer_range (e->value.integer, e->ts.kind); break; + case BT_UNSIGNED: + rc = gfc_check_unsigned_range (e->value.integer, e->ts.kind); + break; + case BT_REAL: rc = gfc_check_real_range (e->value.real, e->ts.kind); if (rc == ARITH_UNDERFLOW) @@ -639,6 +707,23 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) mpz_neg (result->value.integer, op1->value.integer); break; + case BT_UNSIGNED: + { + if (pedantic) + return ARITH_UNSIGNED_NEGATIVE; + + arith neg_rc; + mpz_neg (result->value.integer, op1->value.integer); + neg_rc = gfc_range_check (result); + if (neg_rc != ARITH_OK) + gfc_warning (0, gfc_arith_error (neg_rc), &result->where); + + gfc_reduce_unsigned (result); + if (pedantic) + rc = neg_rc; + } + break; + case BT_REAL: mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE); break; @@ -674,6 +759,11 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) mpz_add (result->value.integer, op1->value.integer, op2->value.integer); break; + case BT_UNSIGNED: + mpz_add (result->value.integer, op1->value.integer, op2->value.integer); + gfc_reduce_unsigned (result); + break; + case BT_REAL: mpfr_add (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); @@ -708,6 +798,7 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) switch (op1->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); break; @@ -748,6 +839,11 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); break; + case BT_UNSIGNED: + mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); + gfc_reduce_unsigned (result); + break; + case BT_REAL: mpfr_mul (result->value.real, op1->value.real, op2->value.real, GFC_RND_MODE); @@ -785,6 +881,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) switch (op1->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: if (mpz_sgn (op2->value.integer) == 0) { rc = ARITH_DIV0; @@ -1131,6 +1228,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) switch (op1->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: rc = mpz_cmp (op1->value.integer, op2->value.integer); break; @@ -1719,14 +1817,25 @@ eval_intrinsic (gfc_intrinsic_op op, gcc_fallthrough (); /* Numeric binary */ + case INTRINSIC_POWER: + if (flag_unsigned && op == INTRINSIC_POWER) + { + if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED) + goto runtime; + } + + gcc_fallthrough(); + case INTRINSIC_PLUS: case INTRINSIC_MINUS: case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) goto runtime; + if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2)) + goto runtime; + /* Do not perform conversions if operands are not conformable as required for the binary intrinsic operators (F2018:10.1.5). Defer to a possibly overloading user-defined operator. */ @@ -2172,7 +2281,8 @@ wprecision_int_real (mpz_t n, mpfr_t r) return ret; } -/* Convert integers to integers. */ +/* Convert integers to integers; we can reuse this for also converting + unsigneds. */ gfc_expr * gfc_int2int (gfc_expr *src, int kind) @@ -2180,7 +2290,7 @@ gfc_int2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - if (src->ts.type != BT_INTEGER) + if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED) return NULL; result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); @@ -2289,6 +2399,109 @@ gfc_int2complex (gfc_expr *src, int kind) return result; } +/* Convert unsigned to unsigned, or integer to unsigned. */ + +gfc_expr * +gfc_uint2uint (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER) + return NULL; + + result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where); + mpz_set (result->value.integer, src->value.integer); + + rc = gfc_range_check (result); + if (rc != ARITH_OK) + gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where); + + gfc_reduce_unsigned (result); + return result; +} + +gfc_expr * +gfc_int2uint (gfc_expr *src, int kind) +{ + return gfc_uint2uint (src, kind); +} + +gfc_expr * +gfc_uint2int (gfc_expr *src, int kind) +{ + return gfc_int2int (src, kind); +} + +/* Convert UNSIGNED to reals. */ + +gfc_expr * +gfc_uint2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + if (src->ts.type != BT_UNSIGNED) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); + + if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) + { + /* This should be rare, just in case. */ + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion + && wprecision_int_real (src->value.integer, result->value.real)) + gfc_warning (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + + return result; +} + +/* Convert default integer to default complex. */ + +gfc_expr * +gfc_uint2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + if (src->ts.type != BT_UNSIGNED) + return NULL; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); + + if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind)) + != ARITH_OK) + { + /* This should be rare, just in case. */ + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion + && wprecision_int_real (src->value.integer, + mpc_realref (result->value.complex))) + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + + return result; +} /* Convert default real to default integer. */ @@ -2339,6 +2552,51 @@ gfc_real2int (gfc_expr *src, int kind) return result; } +/* Convert real to unsigned. */ + +gfc_expr * +gfc_real2uint (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + if (src->ts.type != BT_REAL) + return NULL; + + result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where); + + gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); + if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK) + gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where); + + gfc_reduce_unsigned (result); + + /* If there was a fractional part, warn about this. */ + + if (warn_conversion) + { + mpfr_t f; + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + mpfr_clear (f); + } + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + + return result; +} /* Convert real to real. */ @@ -2521,6 +2779,68 @@ gfc_complex2int (gfc_expr *src, int kind) return result; } +/* Convert complex to integer. */ + +gfc_expr * +gfc_complex2uint (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + if (src->ts.type != BT_COMPLEX) + return NULL; + + result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where); + + gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), + &src->where); + + if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK) + gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where); + + gfc_reduce_unsigned (result); + + if (warn_conversion || warn_conversion_extra) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* See if we discarded an imaginary part. */ + if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) + { + gfc_warning_now (w, "Non-zero imaginary part discarded " + "in conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + else { + mpfr_t f; + + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + mpfr_clear (f); + } + + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + } + + return result; +} + /* Convert complex to real. */ @@ -2695,6 +3015,22 @@ gfc_log2int (gfc_expr *src, int kind) return result; } +/* Convert logical to unsigned. */ + +gfc_expr * +gfc_log2uint (gfc_expr *src, int kind) +{ + gfc_expr *result; + + if (src->ts.type != BT_LOGICAL) + return NULL; + + result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where); + mpz_set_si (result->value.integer, src->value.logical); + + return result; +} + /* Convert integer to logical. */ @@ -2712,6 +3048,22 @@ gfc_int2log (gfc_expr *src, int kind) return result; } +/* Convert unsigned to logical. */ + +gfc_expr * +gfc_uint2log (gfc_expr *src, int kind) +{ + gfc_expr *result; + + if (src->ts.type != BT_UNSIGNED) + return NULL; + + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); + result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); + + return result; +} + /* Convert character to character. We only use wide strings internally, so we only set the kind. */ diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h index f2e63bca215..95db799167a 100644 --- a/gcc/fortran/arith.h +++ b/gcc/fortran/arith.h @@ -63,15 +63,24 @@ gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op); gfc_expr *gfc_int2int (gfc_expr *, int); gfc_expr *gfc_int2real (gfc_expr *, int); gfc_expr *gfc_int2complex (gfc_expr *, int); +gfc_expr *gfc_int2uint (gfc_expr *, int); +gfc_expr *gfc_uint2uint (gfc_expr *, int); +gfc_expr *gfc_uint2int (gfc_expr *, int); +gfc_expr *gfc_uint2real (gfc_expr *, int); +gfc_expr *gfc_uint2complex (gfc_expr *, int); gfc_expr *gfc_real2int (gfc_expr *, int); +gfc_expr *gfc_real2uint (gfc_expr *, int); gfc_expr *gfc_real2real (gfc_expr *, int); gfc_expr *gfc_real2complex (gfc_expr *, int); gfc_expr *gfc_complex2int (gfc_expr *, int); +gfc_expr *gfc_complex2uint (gfc_expr *, int); gfc_expr *gfc_complex2real (gfc_expr *, int); gfc_expr *gfc_complex2complex (gfc_expr *, int); gfc_expr *gfc_log2log (gfc_expr *, int); gfc_expr *gfc_log2int (gfc_expr *, int); +gfc_expr *gfc_log2uint (gfc_expr *, int); gfc_expr *gfc_int2log (gfc_expr *, int); +gfc_expr *gfc_uint2log (gfc_expr *, int); gfc_expr *gfc_hollerith2int (gfc_expr *, int); gfc_expr *gfc_hollerith2real (gfc_expr *, int); gfc_expr *gfc_hollerith2complex (gfc_expr *, int); diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 2f50d84b876..1020ba5342f 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -465,7 +465,34 @@ gfc_boz2int (gfc_expr *x, int kind) return true; } +/* Same as above for UNSIGNED, but much simpler because + of wraparound. */ +bool +gfc_boz2uint (gfc_expr *x, int kind) +{ + int k; + if (!is_boz_constant(x)) + return false; + + mpz_init (x->value.integer); + mpz_set_str (x->value.integer, x->boz.str, x->boz.rdx); + k = gfc_validate_kind (BT_UNSIGNED, kind, false); + if (mpz_cmp (x->value.integer, gfc_unsigned_kinds[k].huge) > 0) + { + gfc_warning (0, _("BOZ contstant truncated at %L"), &x->where); + mpz_and (x->value.integer, x->value.integer, gfc_unsigned_kinds[k].huge); + } + + x->ts.type = BT_UNSIGNED; + x->ts.kind = kind; + /* Clear boz info. */ + x->boz.rdx = 0; + x->boz.len = 0; + free (x->boz.str); + + return true; +} /* Make sure an expression is a scalar. */ static bool @@ -497,6 +524,20 @@ type_check (gfc_expr *e, int n, bt type) return false; } +/* Check the type of an expression which can be one of two. */ + +static bool +type_check2 (gfc_expr *e, int n, bt type1, bt type2) +{ + if (e->ts.type == type1 || e->ts.type == type2) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be %s or %s", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, gfc_basic_typename (type1), gfc_basic_typename (type2)); + + return false; +} /* Check that the expression is a numeric type. */ @@ -548,6 +589,23 @@ int_or_real_check (gfc_expr *e, int n) return true; } +/* Check that an expression is integer or real... or unsigned. */ + +static bool +int_or_real_or_unsigned_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL + && e->ts.type != BT_UNSIGNED) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " + "REAL or UNSIGNED", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + return true; +} + /* Check that an expression is integer or real; allow character for F2003 or later. */ @@ -855,14 +913,20 @@ static bool less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) { int i, val; + int bit_size; if (expr->expr_type != EXPR_CONSTANT) return true; - i = gfc_validate_kind (BT_INTEGER, k, false); + i = gfc_validate_kind (expr->ts.type, k, false); gfc_extract_int (expr, &val); - if (val > gfc_integer_kinds[i].bit_size) + if (expr->ts.type == BT_INTEGER) + bit_size = gfc_integer_kinds[i].bit_size; + else + bit_size = gfc_unsigned_kinds[i].bit_size; + + if (val > bit_size) { gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " "INTEGER(KIND=%d)", arg, &expr->where, k); @@ -881,14 +945,21 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_expr *expr2, const char *arg3, gfc_expr *expr3) { int i2, i3; + int k, bit_size; if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) { gfc_extract_int (expr2, &i2); gfc_extract_int (expr3, &i3); i2 += i3; - i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); - if (i2 > gfc_integer_kinds[i3].bit_size) + k = gfc_validate_kind (expr1->ts.type, expr1->ts.kind, false); + + if (expr1->ts.type == BT_INTEGER) + bit_size = gfc_integer_kinds[k].bit_size; + else + bit_size = gfc_unsigned_kinds[k].bit_size; + + if (i2 > bit_size) { gfc_error ("%<%s + %s%> at %L must be less than or equal " "to BIT_SIZE(%qs)", @@ -1408,7 +1479,6 @@ gfc_check_allocated (gfc_expr *array) return true; } - /* Common check function where the first argument must be real or integer and the second argument must be the same as the first. */ @@ -1437,6 +1507,39 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) return true; } +/* Check function where the first argument must be real or integer (or + unsigned) and the second argument must be the same as the first. */ + +bool +gfc_check_mod (gfc_expr *a, gfc_expr *p) +{ + if (flag_unsigned) + { + if (!int_or_real_or_unsigned_check (a,0)) + return false; + } + else if (!int_or_real_check (a, 0)) + return false; + + if (a->ts.type != p->ts.type) + { + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &p->where); + return false; + } + + if (a->ts.kind != p->ts.kind) + { + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &p->where)) + return false; + } + + return true; +} + bool gfc_check_x_yd (gfc_expr *x, gfc_expr *y) @@ -1957,11 +2060,36 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) && !gfc_boz2int (j, i->ts.kind)) return false; - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + /* If i is BOZ and j is UNSIGNED, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED + && !gfc_boz2uint (i, j->ts.kind)) + return false; - if (!type_check (j, 1, BT_INTEGER)) - return false; + /* If j is BOZ and i is UNSIGNED, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED + && !gfc_boz2uint (j, i->ts.kind)) + return false; + + if (gfc_invalid_unsigned_ops (i,j)) + return false; + + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + + if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED)) + return false; + + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + } return true; } @@ -1970,8 +2098,16 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) bool gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + } if (!type_check (pos, 1, BT_INTEGER)) return false; @@ -2642,7 +2778,13 @@ gfc_check_dble (gfc_expr *x) bool gfc_check_digits (gfc_expr *x) { - if (!int_or_real_check (x, 0)) + + if (flag_unsigned) + { + if (!int_or_real_or_unsigned_check (x, 0)) + return false; + } + else if (!int_or_real_check (x, 0)) return false; return true; @@ -2725,33 +2867,54 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) if (!boz_args_check (i, j)) return false; - /* If i is BOZ and j is integer, convert i to type of j. If j is not - an integer, clear the BOZ; otherwise, check that i is an integer. */ if (i->ts.type == BT_BOZ) { - if (j->ts.type != BT_INTEGER) - reset_boz (i); - else if (!gfc_boz2int (i, j->ts.kind)) - return false; + if (j->ts.type == BT_INTEGER) + { + if (!gfc_boz2int (i, j->ts.kind)) + return false; + } + else if (flag_unsigned && j->ts.type == BT_UNSIGNED) + { + if (!gfc_boz2uint (i, j->ts.kind)) + return false; + } + else + reset_boz (i); } - else if (!type_check (i, 0, BT_INTEGER)) + + if (j->ts.type == BT_BOZ) { - if (j->ts.type == BT_BOZ) + if (i->ts.type == BT_INTEGER) + { + if (!gfc_boz2int (j, i->ts.kind)) + return false; + } + else if (flag_unsigned && i->ts.type == BT_UNSIGNED) + { + if (!gfc_boz2uint (j, i->ts.kind)) + return false; + } + else reset_boz (j); - return false; } - /* If j is BOZ and i is integer, convert j to type of i. If i is not - an integer, clear the BOZ; otherwise, check that i is an integer. */ - if (j->ts.type == BT_BOZ) + if (flag_unsigned) { - if (i->ts.type != BT_INTEGER) - reset_boz (j); - else if (!gfc_boz2int (j, i->ts.kind)) + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + + if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) return false; } - else if (!type_check (j, 1, BT_INTEGER)) - return false; if (!same_type_check (i, 0, j, 1)) return false; @@ -3022,7 +3185,12 @@ gfc_check_fnum (gfc_expr *unit) bool gfc_check_huge (gfc_expr *x) { - if (!int_or_real_check (x, 0)) + if (flag_unsigned) + { + if (!int_or_real_or_unsigned_check (x, 0)) + return false; + } + else if (!int_or_real_check (x, 0)) return false; return true; @@ -3052,6 +3220,21 @@ gfc_check_i (gfc_expr *i) return true; } +/* Check that the single argument is an integer or an UNSIGNED. */ + +bool +gfc_check_iu (gfc_expr *i) +{ + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else if (!type_check (i, 0, BT_INTEGER)) + return false; + + return true; +} bool gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) @@ -3070,11 +3253,35 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) && !gfc_boz2int (j, i->ts.kind)) return false; - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + /* If i is BOZ and j is UNSIGNED, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED + && !gfc_boz2uint (i, j->ts.kind)) + return false; - if (!type_check (j, 1, BT_INTEGER)) - return false; + /* If j is BOZ and i is UNSIGNED, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED + && !gfc_boz2uint (j, i->ts.kind)) + return false; + + if (gfc_invalid_unsigned_ops (i,j)) + return false; + + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + + if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + } if (i->ts.kind != j->ts.kind) { @@ -3090,8 +3297,16 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) bool gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + } if (!type_check (pos, 1, BT_INTEGER)) return false; @@ -3240,6 +3455,29 @@ gfc_check_int (gfc_expr *x, gfc_expr *kind) return true; } +bool +gfc_check_uint (gfc_expr *x, gfc_expr *kind) +{ + + if (!flag_unsigned) + { + gfc_error ("UINT intrinsic only valid with %<-funsigned%> at %L", + &x->where); + return false; + } + + /* BOZ is dealt within simplify_uint*. */ + if (x->ts.type == BT_BOZ) + return true; + + if (!numeric_check (x, 0)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + + return true; +} bool gfc_check_intconv (gfc_expr *x) @@ -3266,8 +3504,18 @@ gfc_check_intconv (gfc_expr *x) bool gfc_check_ishft (gfc_expr *i, gfc_expr *shift) { - if (!type_check (i, 0, BT_INTEGER) - || !type_check (shift, 1, BT_INTEGER)) + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + } + + if (!type_check (shift, 1, BT_INTEGER)) return false; if (!less_than_bitsize1 ("I", i, NULL, shift, true)) @@ -3280,9 +3528,16 @@ gfc_check_ishft (gfc_expr *i, gfc_expr *shift) bool gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) { - if (!type_check (i, 0, BT_INTEGER) - || !type_check (shift, 1, BT_INTEGER)) - return false; + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + } if (size != NULL) { @@ -3756,11 +4011,29 @@ gfc_check_min_max (gfc_actual_arglist *arg) gfc_current_intrinsic, &x->where)) return false; } - else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + else { - gfc_error ("% argument of %qs intrinsic at %L must be INTEGER, " - "REAL or CHARACTER", gfc_current_intrinsic, &x->where); - return false; + if (flag_unsigned) + { + if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL + && x->ts.type != BT_UNSIGNED) + { + gfc_error ("% argument of %qs intrinsic at %L must be " + "INTEGER, REAL, CHARACTER or UNSIGNED", + gfc_current_intrinsic, &x->where); + return false; + } + } + else + { + if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + { + gfc_error ("% argument of %qs intrinsic at %L must be " + "INTEGER, REAL or CHARACTER", + gfc_current_intrinsic, &x->where); + return false; + } + } } return check_rest (x->ts.type, x->ts.kind, arg); @@ -4202,20 +4475,54 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) && !gfc_boz2int (j, i->ts.kind)) return false; - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + /* If i is BOZ and j is unsigned, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED + && !gfc_boz2uint (i, j->ts.kind)) + return false; - if (!type_check (j, 1, BT_INTEGER)) - return false; + /* If j is BOZ and i is unsigned, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED + && !gfc_boz2int (j, i->ts.kind)) + return false; + + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + + if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + } if (!same_type_check (i, 0, j, 1)) return false; - if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind)) - return false; + if (mask->ts.type == BT_BOZ) + { + if (i->ts.type == BT_INTEGER && !gfc_boz2int (mask, i->ts.kind)) + return false; + if (i->ts.type == BT_UNSIGNED && !gfc_boz2uint (mask, i->ts.kind)) + return false; + } - if (!type_check (mask, 2, BT_INTEGER)) - return false; + if (flag_unsigned) + { + if (!type_check2 (mask, 2, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (mask, 2, BT_INTEGER)) + return false; + } if (!same_type_check (i, 0, mask, 2)) return false; @@ -5012,7 +5319,6 @@ gfc_check_selected_int_kind (gfc_expr *r) return true; } - bool gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { @@ -5108,8 +5414,16 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind) bool gfc_check_shift (gfc_expr *i, gfc_expr *shift) { - if (!type_check (i, 0, BT_INTEGER)) - return false; + if (flag_unsigned) + { + if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (i, 0, BT_INTEGER)) + return false; + } if (!type_check (shift, 0, BT_INTEGER)) return false; @@ -6604,8 +6918,17 @@ bool gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, gfc_expr *to, gfc_expr *topos) { - if (!type_check (from, 0, BT_INTEGER)) - return false; + + if (flag_unsigned) + { + if (!type_check2 (from, 0, BT_INTEGER, BT_UNSIGNED)) + return false; + } + else + { + if (!type_check (from, 0, BT_INTEGER)) + return false; + } if (!type_check (frompos, 1, BT_INTEGER)) return false; @@ -7637,3 +7960,12 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) return true; } + +/* Check two operands that either both or none of them can + be UNSIGNED. */ + +bool +gfc_invalid_unsigned_ops (gfc_expr * op1, gfc_expr * op2) +{ + return (op1->ts.type == BT_UNSIGNED) + (op2->ts.type == BT_UNSIGNED) == 1; +} diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index b8308aeee55..cc358f09b83 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4342,6 +4342,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) goto get_kind; } + if (flag_unsigned) + { + if ((matched_type && strcmp ("unsigned", name) == 0) + || (!matched_type && gfc_match (" unsigned") == MATCH_YES)) + { + ts->type = BT_UNSIGNED; + ts->kind = gfc_default_integer_kind; + goto get_kind; + } + } + if ((matched_type && strcmp ("character", name) == 0) || (!matched_type && gfc_match (" character") == MATCH_YES)) { diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 80aa8ef84e7..e94dc495708 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -563,6 +563,14 @@ show_expr (gfc_expr *p) fprintf (dumpfile, "_%d", p->ts.kind); break; + case BT_UNSIGNED: + mpz_out_str (dumpfile, 10, p->value.integer); + fputc('u', dumpfile); + + if (p->ts.kind != gfc_default_integer_kind) + fprintf (dumpfile, "_%d", p->ts.kind); + break; + case BT_LOGICAL: if (p->value.logical) fputs (".true.", dumpfile); diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index be138d196a2..226e9da9a44 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -159,6 +159,7 @@ gfc_get_constant_expr (bt type, int kind, locus *where) switch (type) { case BT_INTEGER: + case BT_UNSIGNED: mpz_init (e->value.integer); break; @@ -296,6 +297,7 @@ gfc_copy_expr (gfc_expr *p) switch (q->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: mpz_init_set (q->value.integer, p->value.integer); break; @@ -696,7 +698,6 @@ gfc_extract_int (gfc_expr *expr, int *result, int report_error) return false; } - /* Same as gfc_extract_int, but use a HWI. */ bool @@ -899,7 +900,8 @@ gfc_kind_max (gfc_expr *e1, gfc_expr *e2) static bool numeric_type (bt type) { - return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; + return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER + || type == BT_UNSIGNED; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 8d89797412e..ff298af015b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -227,7 +227,8 @@ enum gfc_intrinsic_op enum arith { ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN, ARITH_DIV0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC, ARITH_PROHIBIT, - ARITH_WRONGCONCAT, ARITH_INVALID_TYPE, ARITH_NOT_REDUCED + ARITH_WRONGCONCAT, ARITH_INVALID_TYPE, ARITH_NOT_REDUCED, + ARITH_UNSIGNED_TRUNCATED, ARITH_UNSIGNED_NEGATIVE }; /* Statements. */ @@ -705,7 +706,12 @@ enum gfc_isym_id GFC_ISYM_Y0, GFC_ISYM_Y1, GFC_ISYM_YN, - GFC_ISYM_YN2 + GFC_ISYM_YN2, + + /* Add this at the end, so maybe the module format + remains compatible. */ + GFC_ISYM_SU_KIND, + GFC_ISYM_UINT, }; enum init_local_logical @@ -2735,6 +2741,25 @@ gfc_integer_info; extern gfc_integer_info gfc_integer_kinds[]; +/* Unsigned numbers, experimental. */ + +typedef struct +{ + mpz_t huge, int_min; + + int kind, radix, digits, bit_size, range; + + /* True if the C type of the given name maps to this precision. Note that + more than one bit can be set. We will use this later on. */ + unsigned int c_unsigned_char : 1; + unsigned int c_unsigned_short : 1; + unsigned int c_unsigned_int : 1; + unsigned int c_unsigned_long : 1; + unsigned int c_unsigned_long_long : 1; +} +gfc_unsigned_info; + +extern gfc_unsigned_info gfc_unsigned_kinds[]; typedef struct { @@ -3447,7 +3472,10 @@ void gfc_errors_to_warnings (bool); void gfc_arith_init_1 (void); void gfc_arith_done_1 (void); arith gfc_check_integer_range (mpz_t p, int kind); +arith gfc_check_unsigned_range (mpz_t p, int kind); bool gfc_check_character_range (gfc_char_t, int); +const char *gfc_arith_error (arith); +void gfc_reduce_unsigned (gfc_expr *e); extern bool gfc_seen_div0; @@ -3459,6 +3487,7 @@ tree gfc_get_union_type (gfc_symbol *); tree gfc_get_derived_type (gfc_symbol * derived, int codimen = 0); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; +extern int gfc_default_unsigned_kind; extern int gfc_max_integer_kind; extern int gfc_default_real_kind; extern int gfc_default_double_kind; @@ -4001,10 +4030,12 @@ bool gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*, size_t*, size_t*, size_t*); bool gfc_boz2int (gfc_expr *, int); +bool gfc_boz2uint (gfc_expr *, int); bool gfc_boz2real (gfc_expr *, int); bool gfc_invalid_boz (const char *, locus *); bool gfc_invalid_null_arg (gfc_expr *); +bool gfc_invalid_unsigned_ops (gfc_expr *, gfc_expr *); /* class.cc */ void gfc_fix_class_refs (gfc_expr *e); @@ -4087,6 +4118,7 @@ void gfc_convert_mpz_to_signed (mpz_t, int); gfc_expr *gfc_simplify_ieee_functions (gfc_expr *); bool gfc_is_constant_array_expr (gfc_expr *); bool gfc_is_size_zero_array (gfc_expr *); +void gfc_convert_mpz_to_unsigned (mpz_t, int, bool sign = true); /* trans-array.cc */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 7e8783a3690..9043fa321dc 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1192,6 +1192,7 @@ extensions. @menu * Extensions implemented in GNU Fortran:: * Extensions not implemented in GNU Fortran:: +* Experimental features for Fortran 202Y:: @end menu @@ -2701,7 +2702,90 @@ descriptor occurred, use @code{INQUIRE} to get the file position, count the characters up to the next @code{NEW_LINE} and then start reading from the position marked previously. +@node Experimental features for Fortran 202Y +@section Experimental features for Fortran 202Y +@cindex Fortran 202Y +GNU Fortran supports some experimental features which have been +proposed and accepted by the J3 standards committee. These +exist to give users a chance to try them out, and to provide +a reference implementation. + +As these features have not been finalized, there is a chance that the +version in the upcoming standard will differ from what GNU Fortran +currently implements. Stability of these implementations is therefore +not guaranteed. + +@menu +* Unsigned integers:: +@end menu + +@node Unsigned integers +@subsection Unsigned integers +@cindex Unsigned integers +GNU Fortran supports unsigned integers according to +@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The +data type is called @code{UNSIGNED}. For an unsigned type with $n$ bits, +it implements integer arithmetic modulo @code{2**n}, comparable to the +@code{unsigned} data type in C. + +The data type has @code{KIND} numbers comparable to other Fortran data +types, which can be selected via the @code{SELECTED_UNSIGNED_KIND} +function. + +Mixed arithmetic, comparisoins and assignment between @code{UNSIGNED} +and other types are only possible via explicit conversion. Conversion +from @code{UNSIGNED} to other types is done via type conversion +functions like @code{INT} or @code{REAL}. Conversion from other types +to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be +used as index variables in @code{DO} loops or as array indices. + +Unsigned numbers have a trailing @code{u} as suffix, optionally followed +by a @code{KIND} number separated by an underscore. + +Input and output can be done using the @code{I}, @code{B}, @code{O} +and @code{Z} descriptors, plus unformatted I/O. + +Here is a small, somewhat contrived example of their use: +@smallexample +program main + unsigned(kind=8) :: v + v = huge(v) - 32u_8 + print *,v +end program main +@end smallexample +which will output the number 18446744073709551583. + +Arithmetic operations work on unsigned integers, except for exponentiation, +which is prohibited. Unary minus is not permitted when @code{-predantic} +is in force; this prohibition is part of J3/24-116.txt. + +Generally, unsigned integers are only permitted as data in intrinsics. + +Unsigned numbers can be read and written using list-directed, +formatted and unformatted I/O. For formatted I/O, the @code{B}, +@code{I}, @code{O} and @code{Z} descriptors are valid. Negative +values and values which would overflow are rejected with +@code{-pedantic}. + +As of now, the following intrinsics take unsigned arguments: +@itemize @bullet +@item @code{BLT}, @code{BLE}, @code{BGE} and @code{BGT}. These intrinsics + are actually redundant because comparison operators could be used + directly. +@item @code{IAND}, @code{IOR}, @code{IEOR} and @code{NOT} +@item @code{BIT_SIZE}, @code{DIGITS} and @code{HUGE} +@item @code{DSHIFTL} and @code{DSHIFTR} +@item @code{IBCLR}, @code{IBITS} and @code{IBITS} +@item @code{MIN} and @code{MAX} +@item @code{ISHFT}, @code{ISHFTC}, @code{SHIFTL}, @code{SHIFTR} and @code{SHIFTA}. +@item @code{MERGE_BITS} +@item @code{MOD} and @code{MODULO} +@item @code{MVBITS} +@item @code{RANGE} +@item @code{TRANSFER} +@end itemize +This list will grow in the near future. @c --------------------------------------------------------------------- @c --------------------------------------------------------------------- @c Mixed-Language Programming diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 40f4c4f4b0b..926ac44dfd4 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -95,6 +95,12 @@ gfc_type_letter (bt type, bool logical_equals_int) c = 'h'; break; + /* 'u' would be the logical choice, but it is used for + "unknown", let's use m for "modulo". */ + case BT_UNSIGNED: + c = 'm'; + break; + default: c = 'u'; break; @@ -1655,7 +1661,7 @@ add_functions (void) make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008); add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_i, gfc_simplify_bit_size, NULL, + gfc_check_iu, gfc_simplify_bit_size, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); @@ -2256,6 +2262,12 @@ add_functions (void) make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU); + add_sym_2 ("uint", GFC_ISYM_UINT, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNSIGNED, di, GFC_STD_GNU, + gfc_check_uint, gfc_simplify_uint, gfc_resolve_uint, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("uint", GFC_ISYM_UINT, GFC_STD_GNU); + add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior, @@ -2685,7 +2697,7 @@ add_functions (void) make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95); add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod, + gfc_check_mod, gfc_simplify_mod, gfc_resolve_mod, a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED); if (flag_dec_intrinsic_ints) @@ -2707,7 +2719,7 @@ add_functions (void) make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95, - gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, + gfc_check_mod, gfc_simplify_modulo, gfc_resolve_modulo, a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95); @@ -2735,7 +2747,7 @@ add_functions (void) make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77); add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_i, gfc_simplify_not, gfc_resolve_not, + gfc_check_iu, gfc_simplify_not, gfc_resolve_not, i, BT_INTEGER, di, REQUIRED); if (flag_dec_intrinsic_ints) @@ -2784,14 +2796,14 @@ add_functions (void) add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_popcnt, NULL, + gfc_check_iu, gfc_simplify_popcnt, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008); add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_poppar, NULL, + gfc_check_iu, gfc_simplify_poppar, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008); @@ -2952,6 +2964,16 @@ add_functions (void) make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); + if (flag_unsigned) + { + + add_sym_1 ("selected_unsigned_kind", GFC_ISYM_SU_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, gfc_check_selected_int_kind, + gfc_simplify_selected_unsigned_kind, NULL, r, BT_INTEGER, di, REQUIRED); + + make_generic ("selected_unsigned_kind", GFC_ISYM_SU_KIND, GFC_STD_GNU); + } + add_sym_1 ("selected_logical_kind", GFC_ISYM_SL_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2023, /* it has the same requirements */ gfc_check_selected_int_kind, gfc_simplify_selected_logical_kind, NULL, r, BT_INTEGER, di, REQUIRED); @@ -4043,6 +4065,15 @@ add_conversions (void) BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); } + if (flag_unsigned) + { + for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++) + for (j = 0; gfc_unsigned_kinds[j].kind != 0; j++) + if (i != j) + add_conv (BT_UNSIGNED, gfc_unsigned_kinds[i].kind, + BT_UNSIGNED, gfc_unsigned_kinds[j].kind, GFC_STD_GNU); + } + if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) { /* Hollerith-Integer conversions. */ @@ -5316,7 +5347,8 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, else if (from_ts.type == ts->type || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) - || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) + || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX) + || (from_ts.type == BT_UNSIGNED && ts->type == BT_UNSIGNED)) { /* Larger kinds can hold values of smaller kinds without problems. Hence, only warn if target kind is smaller than the source diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 2c287caa6ad..ea29219819d 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -89,6 +89,7 @@ bool gfc_check_hostnm (gfc_expr *); bool gfc_check_huge (gfc_expr *); bool gfc_check_hypot (gfc_expr *, gfc_expr *); bool gfc_check_i (gfc_expr *); +bool gfc_check_iu (gfc_expr *); bool gfc_check_iand_ieor_ior (gfc_expr *, gfc_expr *); bool gfc_check_and (gfc_expr *, gfc_expr *); bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); @@ -98,6 +99,7 @@ bool gfc_check_image_status (gfc_expr *, gfc_expr *); bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_int (gfc_expr *, gfc_expr *); bool gfc_check_intconv (gfc_expr *); +bool gfc_check_uint (gfc_expr *, gfc_expr *); bool gfc_check_irand (gfc_expr *); bool gfc_check_is_contiguous (gfc_expr *); bool gfc_check_isatty (gfc_expr *); @@ -124,6 +126,7 @@ bool gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_minloc_maxloc (gfc_actual_arglist *); bool gfc_check_minval_maxval (gfc_actual_arglist *); +bool gfc_check_mod (gfc_expr *, gfc_expr *); bool gfc_check_nearest (gfc_expr *, gfc_expr *); bool gfc_check_new_line (gfc_expr *); bool gfc_check_norm2 (gfc_expr *, gfc_expr *); @@ -324,6 +327,7 @@ gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_uint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int2 (gfc_expr *); gfc_expr *gfc_simplify_int8 (gfc_expr *); gfc_expr *gfc_simplify_long (gfc_expr *); @@ -399,6 +403,7 @@ gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *); +gfc_expr *gfc_simplify_selected_unsigned_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_logical_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *); @@ -530,6 +535,7 @@ void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_idnint (gfc_expr *, gfc_expr *); void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_uint (gfc_expr *, gfc_expr*, gfc_expr *); void gfc_resolve_int2 (gfc_expr *, gfc_expr *); void gfc_resolve_int8 (gfc_expr *, gfc_expr *); void gfc_resolve_long (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 6bc42afe2c4..dcb5782ef4b 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -129,7 +129,7 @@ by type. Explanations are in the following sections. -fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp -fopenmp-allocators -fopenmp-simd -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 --std=@var{std} -ftest-forall-temp +-std=@var{std} -ftest-forall-temp -funsigned } @item Preprocessing Options @@ -611,6 +611,9 @@ earlier gfortran versions and should not be used any more. @item -ftest-forall-temp Enhance test coverage by forcing most forall assignments to use temporary. +@opindex @code{funsigned} +@item -funsigned +Allow the experimental unsigned extension. @end table @node Preprocessing Options diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index c63a4a8d38c..f466a473f15 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -895,11 +895,13 @@ void gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED, gfc_expr *shift ATTRIBUTE_UNUSED) { + char c = i->ts.type == BT_INTEGER ? 'i' : 'u'; + f->ts = i->ts; if (f->value.function.isym->id == GFC_ISYM_DSHIFTL) - f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind); + f->value.function.name = gfc_get_string ("dshiftl_%c%d", c, f->ts.kind); else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR) - f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind); + f->value.function.name = gfc_get_string ("dshiftr_%c%d", c, f->ts.kind); else gcc_unreachable (); } @@ -1182,6 +1184,7 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) /* If the kind of i and j are different, then g77 cross-promoted the kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ + if (i->ts.kind != j->ts.kind) { if (i->ts.kind == gfc_kind_max (i, j)) @@ -1191,7 +1194,8 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) } f->ts = i->ts; - f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); + const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_m_%d" : "__iand_%d"; + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1206,7 +1210,8 @@ void gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) { f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); + const char *name = i->ts.kind == BT_UNSIGNED ? "__ibclr_m_%d" : "__ibclr_%d"; + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1215,7 +1220,8 @@ gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED, gfc_expr *len ATTRIBUTE_UNUSED) { f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); + const char *name = i->ts.kind == BT_UNSIGNED ? "__ibits_m_%d" : "__ibits_%d"; + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1223,7 +1229,8 @@ void gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) { f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); + const char *name = i->ts.kind == BT_UNSIGNED ? "__ibset_m_%d" : "__ibset_%d"; + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1273,6 +1280,7 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) /* If the kind of i and j are different, then g77 cross-promoted the kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ + if (i->ts.kind != j->ts.kind) { if (i->ts.kind == gfc_kind_max (i, j)) @@ -1281,8 +1289,9 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) gfc_convert_type (i, &j->ts, 2); } + const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_m_%d" : "__ieor_%d"; f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1292,6 +1301,7 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) /* If the kind of i and j are different, then g77 cross-promoted the kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ + if (i->ts.kind != j->ts.kind) { if (i->ts.kind == gfc_kind_max (i, j)) @@ -1300,8 +1310,9 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) gfc_convert_type (i, &j->ts, 2); } + const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_m_%d" : "__ior_%d"; f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); + f->value.function.name = gfc_get_string (name, i->ts.kind); } @@ -1345,6 +1356,18 @@ gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind) gfc_type_abi_kind (&a->ts)); } +void +gfc_resolve_uint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_UNSIGNED; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__uint_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + void gfc_resolve_int2 (gfc_expr *f, gfc_expr *a) @@ -1977,7 +2000,10 @@ gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i, gfc_expr *mask ATTRIBUTE_UNUSED) { f->ts = i->ts; - f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind); + + f->value.function.name = + gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i->ts.type), + i->ts.kind); } @@ -2213,7 +2239,8 @@ void gfc_resolve_not (gfc_expr *f, gfc_expr *i) { f->ts = i->ts; - f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); + const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d"; + f->value.function.name = gfc_get_string (name, i->ts.kind); } diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 5cf7b492254..f5fbe47121c 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -788,6 +788,10 @@ frepack-arrays Fortran Var(flag_repack_arrays) Copy array sections into a contiguous block on procedure entry. +funsigned +Fortran Var(flag_unsigned) +Experimental unsigned numbers. + fcoarray= Fortran RejectNegative Joined Enum(gfc_fcoarray) Var(flag_coarray) Init(GFC_FCOARRAY_NONE) -fcoarray= Specify which coarray parallelization should be used. diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 2cb4a5a08ff..895629d6f80 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -190,7 +190,7 @@ typedef enum typedef enum { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX, BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID, - BT_ASSUMED, BT_UNION, BT_BOZ + BT_ASSUMED, BT_UNION, BT_BOZ, BT_UNSIGNED } bt; diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 1851a8f94a5..e206da95bde 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -2131,6 +2131,13 @@ gfc_match_type_spec (gfc_typespec *ts) goto kind_selector; } + if (flag_unsigned && gfc_match ("unsigned") == MATCH_YES) + { + ts->type = BT_UNSIGNED; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } + if (gfc_match ("double precision") == MATCH_YES) { ts->type = BT_REAL; diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc index a365cec9b49..991829516ef 100644 --- a/gcc/fortran/misc.cc +++ b/gcc/fortran/misc.cc @@ -70,6 +70,9 @@ gfc_basic_typename (bt type) case BT_INTEGER: p = "INTEGER"; break; + case BT_UNSIGNED: + p = "UNSIGNED"; + break; case BT_REAL: p = "REAL"; break; @@ -145,6 +148,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash) else sprintf (buffer, "INTEGER(%d)", ts->kind); break; + case BT_UNSIGNED: + sprintf (buffer, "UNSIGNED(%d)", ts->kind); + break; case BT_REAL: sprintf (buffer, "REAL(%d)", ts->kind); break; diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 76f6bcb8a78..80cbf39a752 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -209,6 +209,44 @@ convert_integer (const char *buffer, int kind, int radix, locus *where) } +/* Convert an unsigned string to an expression node. XXX: + This needs a calculation modulo 2^n. TODO: Implement restriction + that no unary minus is permitted. */ +static gfc_expr * +convert_unsigned (const char *buffer, int kind, int radix, locus *where) +{ + gfc_expr *e; + const char *t; + int k; + arith rc; + + e = gfc_get_constant_expr (BT_UNSIGNED, kind, where); + /* A leading plus is allowed, but not by mpz_set_str. */ + if (buffer[0] == '+') + t = buffer + 1; + else + t = buffer; + + mpz_set_str (e->value.integer, t, radix); + + k = gfc_validate_kind (BT_UNSIGNED, kind, false); + + /* XXX Maybe move this somewhere else. */ + rc = gfc_range_check (e); + if (rc != ARITH_OK) + { + if (pedantic) + gfc_error_now (gfc_arith_error (rc), &e->where); + else + gfc_warning (0, gfc_arith_error (rc), &e->where); + } + + gfc_convert_mpz_to_unsigned (e->value.integer, gfc_unsigned_kinds[k].bit_size, + false); + + return e; +} + /* Convert a real string to an expression node. */ static gfc_expr * @@ -296,6 +334,71 @@ match_integer_constant (gfc_expr **result, int signflag) return MATCH_YES; } +/* Match an unsigned constant (an integer with suffixed u). No sign + is currently accepted, in accordance with 24-116.txt, but that + could be changed later. This is very much like the integer + constant matching above, but with enough differences to put it into + its own function. */ + +static match +match_unsigned_constant (gfc_expr **result) +{ + int length, kind, is_iso_c; + locus old_loc; + char *buffer; + gfc_expr *e; + match m; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + length = match_digits (/* signflag = */ false, 10, NULL); + + if (length == -1) + goto fail; + + m = gfc_match_char ('u'); + if (m == MATCH_NO) + goto fail; + + gfc_current_locus = old_loc; + + buffer = (char *) alloca (length + 1); + memset (buffer, '\0', length + 1); + + gfc_gobble_whitespace (); + + match_digits (false, 10, buffer); + + m = gfc_match_char ('u'); + if (m == MATCH_NO) + goto fail; + + kind = get_kind (&is_iso_c); + if (kind == -2) + kind = gfc_default_unsigned_kind; + if (kind == -1) + return MATCH_ERROR; + + if (kind == 4 && flag_integer4_kind == 8) + kind = 8; + + if (gfc_validate_kind (BT_UNSIGNED, kind, true) < 0) + { + gfc_error ("Unsigned kind %d at %C not available", kind); + return MATCH_ERROR; + } + + e = convert_unsigned (buffer, kind, 10, &gfc_current_locus); + e->ts.is_c_interop = is_iso_c; + + *result = e; + return MATCH_YES; + + fail: + gfc_current_locus = old_loc; + return MATCH_NO; +} /* Match a Hollerith constant. */ @@ -1549,6 +1652,13 @@ gfc_match_literal_constant (gfc_expr **result, int signflag) if (m != MATCH_NO) return m; + if (flag_unsigned) + { + m = match_unsigned_constant (result); + if (m != MATCH_NO) + return m; + } + m = match_integer_constant (result, signflag); if (m != MATCH_NO) return m; @@ -4339,4 +4449,3 @@ gfc_match_equiv_variable (gfc_expr **result) { return match_variable (result, 1, 0); } - diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index eb3085a05ca..f73cb86026c 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -4190,6 +4190,13 @@ resolve_operator (gfc_expr *e) gfc_op2string (e->value.op.op)); return false; } + if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED + && e->value.op.op == INTRINSIC_UMINUS) + { + gfc_error ("Negation of unsigned expression at %L not permitted ", + &e->value.op.op1->where); + return false; + } break; } @@ -4238,11 +4245,36 @@ resolve_operator (gfc_expr *e) gfc_op2string (e->value.op.op), &e->where, gfc_typename (e)); return false; + case INTRINSIC_POWER: + + if (flag_unsigned) + { + if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED) + { + CHECK_INTERFACES + gfc_error ("Exponentiation not valid at %L for %s and %s", + &e->where, gfc_typename (op1), gfc_typename (op2)); + return false; + } + } + gcc_fallthrough(); + case INTRINSIC_PLUS: case INTRINSIC_MINUS: case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: + + /* UNSIGNED cannot appear in a mixed expression without explicit + conversion. */ + if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2)) + { + CHECK_INTERFACES + gfc_error ("Operands of binary numeric operator %<%s%> at %L are %s/%s", + gfc_op2string (e->value.op.op), &e->where, + gfc_typename (op1), gfc_typename (op2)); + return false; + } + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { /* Do not perform conversions if operands are not conformable as @@ -4445,6 +4477,15 @@ resolve_operator (gfc_expr *e) return false; } + if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2)) + { + CHECK_INTERFACES + gfc_error ("Inconsistent types for operator at %L and %L: " + "%s and %s", &op1->where, &op2->where, + gfc_typename (op1), gfc_typename (op2)); + return false; + } + gfc_type_convert_binary (e, 1); e->ts.type = BT_LOGICAL; @@ -11524,6 +11565,13 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) return false; } + if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs)) + { + gfc_error (_("Cannot assign %s to %s at %L"), gfc_typename (rhs), + gfc_typename (lhs), &rhs->where); + return false; + } + /* Handle the case of a BOZ literal on the RHS. */ if (rhs->ts.type == BT_BOZ) { diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 8ddd491de11..e339f7ebc06 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -147,8 +147,8 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind) The conversion is a no-op unless x is negative; otherwise, it can be accomplished by masking out the high bits. */ -static void -convert_mpz_to_unsigned (mpz_t x, int bitsize) +void +gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool sign) { mpz_t mask; @@ -156,7 +156,7 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize) { /* Confirm that no bits above the signed range are unset if we are doing range checking. */ - if (flag_range_check != 0) + if (sign && flag_range_check != 0) gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); mpz_init_set_ui (mask, 1); @@ -171,7 +171,7 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize) { /* Confirm that no bits above the signed range are set if we are doing range checking. */ - if (flag_range_check != 0) + if (sign && flag_range_check != 0) gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); } } @@ -1658,8 +1658,14 @@ gfc_expr * gfc_simplify_bit_size (gfc_expr *e) { int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - return gfc_get_int_expr (e->ts.kind, &e->where, - gfc_integer_kinds[i].bit_size); + int bit_size; + + if (flag_unsigned && e->ts.type == BT_UNSIGNED) + bit_size = gfc_unsigned_kinds[i].bit_size; + else + bit_size = gfc_integer_kinds[i].bit_size; + + return gfc_get_int_expr (e->ts.kind, &e->where, bit_size); } @@ -1693,11 +1699,11 @@ compare_bitwise (gfc_expr *i, gfc_expr *j) mpz_init_set (x, i->value.integer); k = gfc_validate_kind (i->ts.type, i->ts.kind, false); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); mpz_init_set (y, j->value.integer); k = gfc_validate_kind (j->ts.type, j->ts.kind, false); - convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); + gfc_convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); res = mpz_cmp (x, y); mpz_clear (x); @@ -1709,47 +1715,74 @@ compare_bitwise (gfc_expr *i, gfc_expr *j) gfc_expr * gfc_simplify_bge (gfc_expr *i, gfc_expr *j) { + bool result; + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) return NULL; + if (flag_unsigned && i->ts.type == BT_UNSIGNED) + result = mpz_cmp (i->value.integer, j->value.integer) >= 0; + else + result = compare_bitwise (i, j) >= 0; + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) >= 0); + result); } gfc_expr * gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) { + bool result; + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) return NULL; + if (flag_unsigned && i->ts.type == BT_UNSIGNED) + result = mpz_cmp (i->value.integer, j->value.integer) > 0; + else + result = compare_bitwise (i, j) > 0; + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) > 0); + result); } gfc_expr * gfc_simplify_ble (gfc_expr *i, gfc_expr *j) { + bool result; + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) return NULL; + if (flag_unsigned && i->ts.type == BT_UNSIGNED) + result = mpz_cmp (i->value.integer, j->value.integer) <= 0; + else + result = compare_bitwise (i, j) <= 0; + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) <= 0); + result); } gfc_expr * gfc_simplify_blt (gfc_expr *i, gfc_expr *j) { + bool result; + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) return NULL; + if (flag_unsigned && i->ts.type == BT_UNSIGNED) + result = mpz_cmp (i->value.integer, j->value.integer) < 0; + else + result = compare_bitwise (i, j) < 0; + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) < 0); + result); } - gfc_expr * gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) { @@ -1798,6 +1831,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) switch (x->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); break; @@ -1819,6 +1853,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) switch (y->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: mpfr_set_z (mpc_imagref (result->value.complex), y->value.integer, GFC_RND_MODE); break; @@ -2354,6 +2389,10 @@ gfc_simplify_digits (gfc_expr *x) digits = gfc_integer_kinds[i].digits; break; + case BT_UNSIGNED: + digits = gfc_unsigned_kinds[i].digits; + break; + case BT_REAL: case BT_COMPLEX: digits = gfc_real_kinds[i].digits; @@ -2454,13 +2493,23 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, { gfc_expr *result; int i, k, size, shift; + bt type = BT_INTEGER; if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT || shiftarg->expr_type != EXPR_CONSTANT) return NULL; - k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); - size = gfc_integer_kinds[k].bit_size; + if (flag_unsigned && arg1->ts.type == BT_UNSIGNED) + { + k = gfc_validate_kind (BT_UNSIGNED, arg1->ts.kind, false); + size = gfc_unsigned_kinds[k].bit_size; + type = BT_UNSIGNED; + } + else + { + k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); + size = gfc_integer_kinds[k].bit_size; + } gfc_extract_int (shiftarg, &shift); @@ -2468,7 +2517,7 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, if (right) shift = size - shift; - result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); + result = gfc_get_constant_expr (type, arg1->ts.kind, &arg1->where); mpz_set_ui (result->value.integer, 0); for (i = 0; i < shift; i++) @@ -2479,8 +2528,11 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, if (mpz_tstbit (arg1->value.integer, i)) mpz_setbit (result->value.integer, shift + i); - /* Convert to a signed value. */ - gfc_convert_mpz_to_signed (result->value.integer, size); + /* Convert to a signed value if needed. */ + if (type == BT_INTEGER) + gfc_convert_mpz_to_signed (result->value.integer, size); + else + gfc_reduce_unsigned (result); return result; } @@ -3263,7 +3315,11 @@ gfc_simplify_huge (gfc_expr *e) mpz_set (result->value.integer, gfc_integer_kinds[i].huge); break; - case BT_REAL: + case BT_UNSIGNED: + mpz_set (result->value.integer, gfc_unsigned_kinds[i].huge); + break; + + case BT_REAL: mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); break; @@ -3367,11 +3423,13 @@ gfc_expr * gfc_simplify_iand (gfc_expr *x, gfc_expr *y) { gfc_expr *result; + bt type; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER; + result = gfc_get_constant_expr (type, x->ts.kind, &x->where); mpz_and (result->value.integer, x->value.integer, y->value.integer); return range_check (result, "IAND"); @@ -3403,13 +3461,18 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) result->representation.string = NULL; } - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); + if (x->ts.type == BT_INTEGER) + { + gfc_convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); - mpz_clrbit (result->value.integer, pos); + mpz_clrbit (result->value.integer, pos); - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + } + else + mpz_clrbit (result->value.integer, pos); return result; } @@ -3434,9 +3497,13 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) gfc_extract_int (y, &pos); gfc_extract_int (z, &len); - k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); + k = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + if (x->ts.type == BT_INTEGER) + bitsize = gfc_integer_kinds[k].bit_size; + else + bitsize = gfc_unsigned_kinds[k].bit_size; - bitsize = gfc_integer_kinds[k].bit_size; if (pos + len > bitsize) { @@ -3446,8 +3513,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); + + if (x->ts.type == BT_INTEGER) + gfc_convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); bits = XCNEWVEC (int, bitsize); @@ -3469,8 +3538,9 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) free (bits); - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); + if (x->ts.type == BT_INTEGER) + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); return result; } @@ -3501,13 +3571,18 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) result->representation.string = NULL; } - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); + if (x->ts.type == BT_INTEGER) + { + gfc_convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); - mpz_setbit (result->value.integer, pos); + mpz_setbit (result->value.integer, pos); - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + } + else + mpz_setbit (result->value.integer, pos); return result; } @@ -3545,11 +3620,13 @@ gfc_expr * gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) { gfc_expr *result; + bt type; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER; + result = gfc_get_constant_expr (type, x->ts.kind, &x->where); mpz_xor (result->value.integer, x->value.integer, y->value.integer); return range_check (result, "IEOR"); @@ -3627,7 +3704,6 @@ done: return range_check (result, "INDEX"); } - static gfc_expr * simplify_intconv (gfc_expr *e, int kind, const char *name) { @@ -3738,16 +3814,48 @@ gfc_simplify_idint (gfc_expr *e) return range_check (result, "IDINT"); } +gfc_expr * +gfc_simplify_uint (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result = NULL; + int kind; + + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + /* Convert BOZ to integer, and return without range checking. */ + if (e->ts.type == BT_BOZ) + { + if (!gfc_boz2uint (e, kind)) + return NULL; + result = gfc_copy_expr (e); + return result; + } + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_convert_constant (e, BT_UNSIGNED, kind); + + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, "UINT"); +} + gfc_expr * gfc_simplify_ior (gfc_expr *x, gfc_expr *y) { gfc_expr *result; + bt type; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER; + result = gfc_get_constant_expr (type, x->ts.kind, &x->where); mpz_ior (result->value.integer, x->value.integer, y->value.integer); return range_check (result, "IOR"); @@ -3823,8 +3931,11 @@ simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, gfc_extract_int (s, &shift); - k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); - bitsize = gfc_integer_kinds[k].bit_size; + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + if (e->ts.type == BT_INTEGER) + bitsize = gfc_integer_kinds[k].bit_size; + else + bitsize = gfc_unsigned_kinds[k].bit_size; result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); @@ -3900,7 +4011,11 @@ simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, } } - gfc_convert_mpz_to_signed (result->value.integer, bitsize); + if (result->ts.type == BT_INTEGER) + gfc_convert_mpz_to_signed (result->value.integer, bitsize); + else + gfc_reduce_unsigned(result); + free (bits); return result; @@ -4000,7 +4115,8 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) if (shift == 0) return result; - convert_mpz_to_unsigned (result->value.integer, isize); + if (result->ts.type == BT_INTEGER) + gfc_convert_mpz_to_unsigned (result->value.integer, isize); bits = XCNEWVEC (int, ssize); @@ -4046,7 +4162,8 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) } } - gfc_convert_mpz_to_signed (result->value.integer, isize); + if (result->ts.type == BT_INTEGER) + gfc_convert_mpz_to_signed (result->value.integer, isize); free (bits); return result; @@ -5104,7 +5221,7 @@ gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) || mask_expr->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); + result = gfc_get_constant_expr (i->ts.type, i->ts.kind, &i->where); /* Convert all argument to unsigned. */ mpz_init_set (arg1, i->value.integer); @@ -5135,6 +5252,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) switch (arg->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: if (extremum->ts.kind < arg->ts.kind) extremum->ts.kind = arg->ts.kind; ret = mpz_cmp (arg->value.integer, @@ -6113,6 +6231,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) switch (p->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: if (mpz_cmp_ui (p->value.integer, 0) == 0) { gfc_error ("Argument %qs of MOD at %L shall not be zero", @@ -6138,7 +6257,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - if (a->ts.type == BT_INTEGER) + if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED) mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); else { @@ -6165,6 +6284,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) switch (p->ts.type) { case BT_INTEGER: + case BT_UNSIGNED: if (mpz_cmp_ui (p->value.integer, 0) == 0) { gfc_error ("Argument %qs of MODULO at %L shall not be zero", @@ -6190,8 +6310,8 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - if (a->ts.type == BT_INTEGER) - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED) + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); else { gfc_set_model_kind (kind); @@ -6646,11 +6766,16 @@ gfc_simplify_popcnt (gfc_expr *e) k = gfc_validate_kind (e->ts.type, e->ts.kind, false); - /* Convert argument to unsigned, then count the '1' bits. */ - mpz_init_set (x, e->value.integer); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); - res = mpz_popcount (x); - mpz_clear (x); + if (flag_unsigned && e->ts.type == BT_UNSIGNED) + res = mpz_popcount (e->value.integer); + else + { + /* Convert argument to unsigned, then count the '1' bits. */ + mpz_init_set (x, e->value.integer); + gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + res = mpz_popcount (x); + mpz_clear (x); + } return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); } @@ -6727,6 +6852,10 @@ gfc_simplify_range (gfc_expr *e) i = gfc_integer_kinds[i].range; break; + case BT_UNSIGNED: + i = gfc_unsigned_kinds[i].range; + break; + case BT_REAL: case BT_COMPLEX: i = gfc_real_kinds[i].range; @@ -7404,6 +7533,29 @@ gfc_simplify_selected_int_kind (gfc_expr *e) return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); } +/* Same as above, but with unsigneds. */ + +gfc_expr * +gfc_simplify_selected_unsigned_kind (gfc_expr *e) +{ + int i, kind, range; + + if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range)) + return NULL; + + kind = INT_MAX; + + for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++) + if (gfc_unsigned_kinds[i].range >= range + && gfc_unsigned_kinds[i].kind < kind) + kind = gfc_unsigned_kinds[i].kind; + + if (kind == INT_MAX) + kind = -1; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); +} + gfc_expr * gfc_simplify_selected_logical_kind (gfc_expr *e) @@ -8793,6 +8945,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) case BT_INTEGER: f = gfc_int2int; break; + case BT_UNSIGNED: + f = gfc_int2uint; + break; case BT_REAL: f = gfc_int2real; break; @@ -8807,12 +8962,38 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) } break; + case BT_UNSIGNED: + switch (type) + { + case BT_INTEGER: + f = gfc_uint2int; + break; + case BT_UNSIGNED: + f = gfc_uint2uint; + break; + case BT_REAL: + f = gfc_uint2real; + break; + case BT_COMPLEX: + f = gfc_uint2complex; + break; + case BT_LOGICAL: + f = gfc_uint2log; + break; + default: + goto oops; + } + break; + case BT_REAL: switch (type) { case BT_INTEGER: f = gfc_real2int; break; + case BT_UNSIGNED: + f = gfc_real2uint; + break; case BT_REAL: f = gfc_real2real; break; @@ -8830,6 +9011,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) case BT_INTEGER: f = gfc_complex2int; break; + case BT_UNSIGNED: + f = gfc_complex2uint; + break; case BT_REAL: f = gfc_complex2real; break; @@ -8848,6 +9032,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) case BT_INTEGER: f = gfc_log2int; break; + case BT_UNSIGNED: + f = gfc_log2uint; + break; case BT_LOGICAL: f = gfc_log2log; break; @@ -8863,6 +9050,11 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) f = gfc_hollerith2int; break; + /* Hollerith is for legacy code, we do not currently support + converting this to UNSIGNED. */ + case BT_UNSIGNED: + goto oops; + case BT_REAL: f = gfc_hollerith2real; break; @@ -8891,6 +9083,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) f = gfc_character2int; break; + case BT_UNSIGNED: + goto oops; + case BT_REAL: f = gfc_character2real; break; diff --git a/gcc/fortran/target-memory.cc b/gcc/fortran/target-memory.cc index a02db7a06e4..53d360cd266 100644 --- a/gcc/fortran/target-memory.cc +++ b/gcc/fortran/target-memory.cc @@ -42,6 +42,11 @@ size_integer (int kind) return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind))); } +static size_t +size_unsigned (int kind) +{ + return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_unsigned_type (kind))); +} static size_t size_float (int kind) @@ -85,6 +90,9 @@ gfc_element_size (gfc_expr *e, size_t *siz) case BT_INTEGER: *siz = size_integer (e->ts.kind); return true; + case BT_UNSIGNED: + *siz = size_unsigned (e->ts.kind); + return true; case BT_REAL: *siz = size_float (e->ts.kind); return true; diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc index fc5b6d03057..204f4df301c 100644 --- a/gcc/fortran/trans-const.cc +++ b/gcc/fortran/trans-const.cc @@ -206,6 +206,14 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind) return wide_int_to_tree (gfc_get_int_type (kind), val); } +/* Same, but for unsigned. */ + +tree +gfc_conv_mpz_unsigned_to_tree (mpz_t i, int kind) +{ + wide_int val = wi:: from_mpz (gfc_get_unsigned_type (kind), i, true); + return wide_int_to_tree (gfc_get_unsigned_type (kind), val); +} /* Convert a GMP integer into a tree node of type given by the type argument. */ @@ -315,6 +323,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr) else return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); + case BT_UNSIGNED: + return gfc_conv_mpz_unsigned_to_tree (expr->value.integer, expr->ts.kind); + case BT_REAL: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index ca6a515a180..dce56036540 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -7098,6 +7098,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR ? CFI_type_cfunptr : CFI_type_cptr); break; + + case BT_UNSIGNED: + gfc_internal_error ("Unsigned not yet implemented"); + case BT_ASSUMED: case BT_CLASS: case BT_PROCEDURE: diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3677e49a356..6a89bda9837 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -5837,6 +5837,10 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) } else gcc_unreachable (); + + case BT_UNSIGNED: + gfc_internal_error ("Unsigned not yet implemented"); + case BT_PROCEDURE: case BT_HOLLERITH: case BT_UNION: diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 150cb9ff963..fef74c8364f 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -3423,6 +3423,13 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) args[0], args[1]); break; + case BT_UNSIGNED: + /* Even easier, we only need one. */ + type = TREE_TYPE (args[0]); + se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type, + args[0], args[1]); + break; + case BT_REAL: fmod = NULL_TREE; /* Check if we have a builtin fmod. */ @@ -6772,6 +6779,7 @@ gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, { tree args[2], type, num_bits, cond; tree bigshift; + bool do_convert = false; gfc_conv_intrinsic_function_args (se, expr, args, 2); @@ -6780,15 +6788,24 @@ gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, type = TREE_TYPE (args[0]); if (!arithmetic) - args[0] = fold_convert (unsigned_type_for (type), args[0]); + { + args[0] = fold_convert (unsigned_type_for (type), args[0]); + do_convert = true; + } else gcc_assert (right_shift); + if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED) + { + do_convert = true; + args[0] = fold_convert (signed_type_for (type), args[0]); + } + se->expr = fold_build2_loc (input_location, right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, TREE_TYPE (args[0]), args[0], args[1]); - if (!arithmetic) + if (do_convert) se->expr = fold_convert (type, se->expr); if (!arithmetic) @@ -10908,6 +10925,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_INT2: case GFC_ISYM_INT8: case GFC_ISYM_LONG: + case GFC_ISYM_UINT: gfc_conv_intrinsic_int (se, expr, RND_TRUNC); break; diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 7ab82fa2f5b..e9e67a0d6b8 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -117,6 +117,8 @@ enum iocall IOCALL_WRITE_DONE, IOCALL_X_INTEGER, IOCALL_X_INTEGER_WRITE, + IOCALL_X_UNSIGNED, + IOCALL_X_UNSIGNED_WRITE, IOCALL_X_LOGICAL, IOCALL_X_LOGICAL_WRITE, IOCALL_X_CHARACTER, @@ -335,6 +337,14 @@ gfc_build_io_library_fndecls (void) get_identifier (PREFIX("transfer_integer_write")), ". w R . ", void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + iocall[IOCALL_X_UNSIGNED] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_unsigned")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_UNSIGNED_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_unsigned_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("transfer_logical")), ". w W . ", void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); @@ -2341,6 +2351,15 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, break; + case BT_UNSIGNED: + arg2 = build_int_cst (unsigned_type_node, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_UNSIGNED]; + else + function = iocall[IOCALL_X_UNSIGNED_WRITE]; + + break; + case BT_REAL: arg2 = build_int_cst (integer_type_node, kind); if (last_dt == READ) diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index e6da8e1a58b..ad4939eb175 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -86,8 +86,10 @@ static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)]; #define MAX_INT_KINDS 5 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1]; gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1]; +gfc_unsigned_info gfc_unsigned_kinds[MAX_INT_KINDS + 1]; static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1]; static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1]; +static GTY(()) tree gfc_unsigned_types[MAX_INT_KINDS + 1]; #define MAX_REAL_KINDS 5 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; @@ -109,6 +111,7 @@ int gfc_index_integer_kind; /* The default kinds of the various types. */ int gfc_default_integer_kind; +int gfc_default_unsigned_kind; int gfc_max_integer_kind; int gfc_default_real_kind; int gfc_default_double_kind; @@ -413,6 +416,14 @@ gfc_init_kinds (void) gfc_integer_kinds[i_index].digits = bitsize - 1; gfc_integer_kinds[i_index].bit_size = bitsize; + if (flag_unsigned) + { + gfc_unsigned_kinds[i_index].kind = kind; + gfc_unsigned_kinds[i_index].radix = 2; + gfc_unsigned_kinds[i_index].digits = bitsize; + gfc_unsigned_kinds[i_index].bit_size = bitsize; + } + gfc_logical_kinds[i_index].kind = kind; gfc_logical_kinds[i_index].bit_size = bitsize; @@ -585,6 +596,8 @@ gfc_init_kinds (void) gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size; } + gfc_default_unsigned_kind = gfc_default_integer_kind; + /* Choose the default real kind. Again, we choose 4 when possible. */ if (flag_default_real_8) { @@ -756,6 +769,18 @@ validate_integer (int kind) return -1; } +static int +validate_unsigned (int kind) +{ + int i; + + for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++) + if (gfc_unsigned_kinds[i].kind == kind) + return i; + + return -1; +} + static int validate_real (int kind) { @@ -810,6 +835,9 @@ gfc_validate_kind (bt type, int kind, bool may_fail) case BT_INTEGER: rc = validate_integer (kind); break; + case BT_UNSIGNED: + rc = validate_unsigned (kind); + break; case BT_LOGICAL: rc = validate_logical (kind); break; @@ -880,6 +908,24 @@ gfc_build_uint_type (int size) return make_unsigned_type (size); } +static tree +gfc_build_unsigned_type (gfc_unsigned_info *info) +{ + int mode_precision = info->bit_size; + + if (mode_precision == CHAR_TYPE_SIZE) + info->c_unsigned_char = 1; + if (mode_precision == SHORT_TYPE_SIZE) + info->c_unsigned_short = 1; + if (mode_precision == INT_TYPE_SIZE) + info->c_unsigned_int = 1; + if (mode_precision == LONG_TYPE_SIZE) + info->c_unsigned_long = 1; + if (mode_precision == LONG_LONG_TYPE_SIZE) + info->c_unsigned_long_long = 1; + + return gfc_build_uint_type (mode_precision); +} static tree gfc_build_real_type (gfc_real_info *info) @@ -1034,6 +1080,40 @@ gfc_init_types (void) } gfc_character1_type_node = gfc_character_types[0]; + /* The middle end only recognizes a single unsigned type. For + compatibility of existing test cases, let's just use the + character type. The reader of tree dumps is expected to be able + to deal with this. */ + + if (flag_unsigned) + { + for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index) + { + int index_char = -1; + for (int i=0; gfc_character_kinds[i].kind != 0; i++) + { + if (gfc_character_kinds[i].bit_size == + gfc_unsigned_kinds[index].bit_size) + { + index_char = i; + break; + } + } + if (index_char > 0) + { + gfc_unsigned_types[index] = gfc_character_types[index_char]; + } + else + { + type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); + gfc_unsigned_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", + gfc_integer_kinds[index].kind); + PUSH_TYPE (name_buf, type); + } + } + } + PUSH_TYPE ("byte", unsigned_char_type_node); PUSH_TYPE ("void", void_type_node); @@ -1092,6 +1172,13 @@ gfc_get_int_type (int kind) return index < 0 ? 0 : gfc_integer_types[index]; } +tree +gfc_get_unsigned_type (int kind) +{ + int index = gfc_validate_kind (BT_UNSIGNED, kind, true); + return index < 0 ? 0 : gfc_unsigned_types[index]; +} + tree gfc_get_real_type (int kind) { @@ -1192,6 +1279,10 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim) basetype = gfc_get_int_type (spec->kind); break; + case BT_UNSIGNED: + basetype = gfc_get_unsigned_type (spec->kind); + break; + case BT_REAL: basetype = gfc_get_real_type (spec->kind); break; diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 60096facde8..afc4da99526 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -76,6 +76,7 @@ void gfc_init_c_interop_kinds (void); tree get_dtype_type_node (void); tree gfc_get_int_type (int); +tree gfc_get_unsigned_type (int); tree gfc_get_real_type (int); tree gfc_get_complex_type (int); tree gfc_get_logical_type (int); diff --git a/gcc/testsuite/gfortran.dg/unsigned_1.f90 b/gcc/testsuite/gfortran.dg/unsigned_1.f90 new file mode 100644 index 00000000000..eefecab3715 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test some arithmetic and selected_unsigned_kind. +program memain + unsigned :: u, v + integer, parameter :: u1 = selected_unsigned_kind(2), & + u2 = selected_unsigned_kind(4), & + u4 = selected_unsigned_kind(6), & + u8 = selected_unsigned_kind(10) + u = 1u + v = 42u + if (u + v /= 43u) then + error stop 1 + end if + if (u1 /= 1 .or. u2 /= 2 .or. u4 /= 4 .or. u8 /= 8) error stop 2 +end program memain diff --git a/gcc/testsuite/gfortran.dg/unsigned_10.f90 b/gcc/testsuite/gfortran.dg/unsigned_10.f90 new file mode 100644 index 00000000000..df9167649fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_10.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test I/O with Z, O and B descriptors. + +program main + implicit none + unsigned(kind=8) :: u,v + integer :: i + open(10,status="scratch") + u = 3u + do i=0,63 + write (10,'(Z16)') u + u = u + u + end do + rewind 10 + u = 3u + do i=0,63 + read (10,'(Z16)') v + if (u /= v) then + print *,u,v + end if + u = u + u + end do + rewind 10 + u = 3u + do i=0,63 + write (10,'(O22)') u + u = u + u + end do + rewind 10 + u = 3u + do i=0,63 + read (10,'(O22)') v + if (u /= v) then + print *,u,v + end if + u = u + u + end do + + rewind 10 + u = 3u + do i=0,63 + write (10,'(B64)') u + u = u + u + end do + rewind 10 + u = 3u + do i=0,63 + read (10,'(B64)') v + if (u /= v) then + print *,u,v + end if + u = u + u + end do + +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_11.f90 b/gcc/testsuite/gfortran.dg/unsigned_11.f90 new file mode 100644 index 00000000000..ad817a843a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_11.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test min/max +program main + unsigned :: u_a, u_b + if (max(1u,2u) /= 2u) error stop 1 + if (max(2u,1u) /= 2u) error stop 2 + if (min(1u,2u) /= 1u) error stop 3 + if (min(2u,1u) /= 1u) error stop 4 + u_a = 1u + u_b = 2u + if (max(u_a,u_b) /= u_b) error stop 5 + if (max(u_b,u_a) /= u_b) error stop 6 + if (min(u_a,u_b) /= u_a) error stop 7 + if (min(u_b,u_a) /= u_a) error stop 8 + if (max(4294967295u, 1u) /= 4294967295u) error stop 9 + u_a = 4294967295u + u_b = 1u + if (max(u_a,u_b) /= 4294967295u) error stop 10 + if (max(u_b,u_a) /= 4294967295u) error stop 11 + if (min(u_a,u_b) /= 1u) error stop 12 + if (min(u_b,u_a) /= 1u) error stop 13 +end program diff --git a/gcc/testsuite/gfortran.dg/unsigned_12.f90 b/gcc/testsuite/gfortran.dg/unsigned_12.f90 new file mode 100644 index 00000000000..9a96b3cfb13 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_12.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test some +program main + unsigned :: u_a + u_a = 1u + if (ishft(1u,31) /= 2147483648u) error stop 1 + if (ishft(u_a,31) /= 2147483648u) error stop 2 + + u_a = 3u + if (ishft(3u,2) /= 12u) error stop 3 + if (ishft(u_a,2) /= 12u) error stop 4 + + u_a = huge(u_a) + if (ishftc(huge(u_a),1) /= huge(u_a)) error stop 5 + if (ishftc(u_a,1) /= u_a) error stop 6 + +end program diff --git a/gcc/testsuite/gfortran.dg/unsigned_13.f90 b/gcc/testsuite/gfortran.dg/unsigned_13.f90 new file mode 100644 index 00000000000..7bc2396a5c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_13.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test basic functionality of ishft and ishftc. +program main + unsigned :: u_a + u_a = 1u + if (ishft(1u,31) /= 2147483648u) error stop 1 + if (ishft(u_a,31) /= 2147483648u) error stop 2 + + u_a = 3u + if (ishft(3u,2) /= 12u) error stop 3 + if (ishft(u_a,2) /= 12u) error stop 4 + + u_a = huge(u_a) + if (ishftc(huge(u_a),1) /= huge(u_a)) error stop 5 + if (ishftc(u_a,1) /= u_a) error stop 6 + +end program diff --git a/gcc/testsuite/gfortran.dg/unsigned_14.f90 b/gcc/testsuite/gfortran.dg/unsigned_14.f90 new file mode 100644 index 00000000000..81c200fd883 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_14.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test basic functionality of merge_bits. +program main + unsigned(kind=4) :: a, b, c + if (merge_bits(15u,51u,85u) /= 39u) error stop 1 + a = 15u + b = 51u + c = 85u + if (merge_bits(a,b,c) /= 39u) error stop 2 + + if (merge_bits(4026531840u,3422552064u,2852126720u) /= 3825205248u) error stop 3 + + a = 4026531840u_4 + b = 3422552064u_4 + c = 2852126720u_4 + if (merge_bits(a,b,c) /= 3825205248u) error stop 4 +end program diff --git a/gcc/testsuite/gfortran.dg/unsigned_15.f90 b/gcc/testsuite/gfortran.dg/unsigned_15.f90 new file mode 100644 index 00000000000..da4ccd2dc17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_15.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-funsigned" } +! Test different prohibited conversions. +program main + integer :: i + unsigned :: u + print *,1 + 2u ! { dg-error "Operands of binary numeric operator" } + print *,2u + 1 ! { dg-error "Operands of binary numeric operator" } + print *,2u ** 1 ! { dg-error "Exponentiation not valid" } + print *,2u ** 1u ! { dg-error "Exponentiation not valid" } + print *,1u < 2 ! { dg-error "Inconsistent types" } + print *,int(1u) < 2 +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_16.f90 b/gcc/testsuite/gfortran.dg/unsigned_16.f90 new file mode 100644 index 00000000000..34eb9d3f6c3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_16.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-funsigned -pedantic" } +! Some checks with -pedantic. +program main + unsigned :: u + print *,-129u_1 ! { dg-error "Negation of unsigned constant" } + print *,256u_1 ! { dg-error "Unsigned constant truncated" } + u = 1u + u = -u ! { dg-error "Negation of unsigned expression" } +end program diff --git a/gcc/testsuite/gfortran.dg/unsigned_17.f90 b/gcc/testsuite/gfortran.dg/unsigned_17.f90 new file mode 100644 index 00000000000..4557f1d30cb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_17.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test modulo and mod intrinsics. +program main + unsigned :: u1, u2 + if (mod(5u,2u) /= 1u) error stop 1 + if (modulo(5u,2u) /= 1u) error stop 2 + u1 = 5u + u2 = 2u + if (mod(u1,u2) /= 1u) error stop 3 + if (modulo(u1,u2) /= 1u) error stop 4 + + if (mod(4294967295u,4294967281u) /= 14u) error stop 5 + if (mod(4294967281u,4294967295u) /= 4294967281u) error stop 6 + if (modulo(4294967295u,4294967281u) /= 14u) error stop 7 + if (modulo(4294967281u,4294967295u) /= 4294967281u) error stop 8 + u1 = 4294967295u + u2 = 4294967281u + if (mod(u1,u2) /= 14u) error stop 9 + if (mod(u2,u1) /= u2) error stop 10 +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_18.f90 b/gcc/testsuite/gfortran.dg/unsigned_18.f90 new file mode 100644 index 00000000000..f6207abd562 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_18.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program memain + implicit none + unsigned(1) i1,j1 + unsigned(2) i2,j2 + unsigned(4) i4,j4 + unsigned(8) i8,j8 + integer ibits,n + + ibits=bit_size(1u_1) + do n=1,ibits + i1=huge(i1) + call mvbits(1u_1, 0,n,i1,0) + j1=uint(-1-2_1**n+2) + if(i1.ne.j1) error stop 1 + enddo + ibits=bit_size(1u_2) + do n=1,ibits + i2=huge(i2) + call mvbits(1u_2, 0,n,i2,0) + j2=uint(-1-2_2**n+2) + if(i2.ne.j2) error stop 2 + enddo + ibits=bit_size(1u_4) + do n=1,ibits + i4=huge(i4) + call mvbits(1u_4, 0,n,i4,0) + j4=uint(-1-2_4**n+2) + if(i4.ne.j4) error stop 3 + enddo + ibits=bit_size(1_8) + do n=1,ibits + i8=huge(i8) + call mvbits(1u_8, 0,n,i8,0) + j8=uint(-1-2_8**n+2,8) + if(i8.ne.j8) error stop 4 + enddo + +end program memain diff --git a/gcc/testsuite/gfortran.dg/unsigned_19.f90 b/gcc/testsuite/gfortran.dg/unsigned_19.f90 new file mode 100644 index 00000000000..2795ddf335e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_19.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program memain + if (range(1u_1) /= 2) error stop 1 + if (range(1u_2) /= 4) error stop 2 + if (range(1u_4) /= 9) error stop 3 + if (range(1u_8) /= 19) error stop 4 +end program memain diff --git a/gcc/testsuite/gfortran.dg/unsigned_2.f90 b/gcc/testsuite/gfortran.dg/unsigned_2.f90 new file mode 100644 index 00000000000..499fd164786 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test some list-directed I/O +program main + implicit none + unsigned :: uw, ur, vr + unsigned(kind=8) :: u8 + uw = 10u + open (10, status="scratch") + write (10,*) uw,-1 + rewind 10 + read (10,*) ur,vr + if (ur /= 10u .or. vr /= 4294967295u) error stop 1 + rewind 10 + write (10,*) 17179869184u_8 + rewind 10 + read (10,*) u8 + if (u8 /= 17179869184u_8) error stop 2 +end program main + diff --git a/gcc/testsuite/gfortran.dg/unsigned_20.f90 b/gcc/testsuite/gfortran.dg/unsigned_20.f90 new file mode 100644 index 00000000000..f66016c874c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_20.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program memain + + unsigned(1) :: u1 + unsigned(2) :: u2 + unsigned(4) :: u4 + unsigned(8) :: u8 + + u1 = 1u_1 + if (shifta ( 1u , 1) /= 0u_1) error stop 1 + if (shifta ( u1 , 1) /= 0u_1) error stop 2 + + u1 = 128u_1 + if (shifta ( 128u_1, 1) /= 192u_1) error stop 3 + if (shiftl ( 128u_1, 1) /= 0u_1) error stop 4 + if (shiftr ( 128u_1, 1) /= 64u_1) error stop 5 + + if (shifta ( u1, 1) /= 192u_1) error stop 6 + if (shiftl ( u1, 1) /= 0u_1) error stop 7 + if (shiftr ( u1, 1) /= 64u_1) error stop 8 + + u2 = 32768u_2 + if (shifta ( 32768u_2, 1) /= 49152u_2) error stop 9 + if (shiftl ( 32768u_2, 1) /= 0u_2) error stop 10 + if (shiftr ( 32768u_2, 1) /= 16384u_2) error stop 11 + if (shifta ( u2, 1) /= 49152u_2) error stop 12 + if (shiftl ( u2, 1) /= 0u_2) error stop 13 + if (shiftr ( u2, 1) /= 16384u_2) error stop 14 + + u4 = 2147483648u_4 + if (shifta ( 2147483648u_4, 1) /= 3221225472u_4) error stop 15 + if (shiftl ( 2147483648u_4, 1) /= 0u_4) error stop 16 + if (shiftr ( 2147483648u_4, 1) /= 1073741824u_4) error stop 17 + if (shifta ( u4, 1) /= 3221225472u_4) error stop 18 + if (shiftl ( u4, 1) /= 0u_4) error stop 19 + if (shiftr ( u4, 1) /= 1073741824u_4) error stop 20 + + u8 = 9223372036854775808u_8 + if (shifta(9223372036854775808u_8, 1) /= 13835058055282163712u_8) error stop 21 + if (shiftl(9223372036854775808u_8, 1) /= 0u_8) error stop 22 + if (shiftr(9223372036854775808u_8, 1) /= 4611686018427387904u_8) error stop 23 + if (shifta( u8, 1) /= 13835058055282163712u_8) error stop 24 + if (shiftl( u8, 1) /= 0u_8) error stop 25 + if (shiftr( u8, 1) /= 4611686018427387904u_8) error stop 26 +end program memain diff --git a/gcc/testsuite/gfortran.dg/unsigned_21.f90 b/gcc/testsuite/gfortran.dg/unsigned_21.f90 new file mode 100644 index 00000000000..23302c7eabe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_21.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program main + integer :: i + integer(2) :: j + unsigned :: u + i = -1 + u = transfer(i,u) + if (u /= huge(u)) error stop 1 + u = 40000u + j = transfer(u,j) + if (j /= -25536) error stop 2 +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_22.f90 b/gcc/testsuite/gfortran.dg/unsigned_22.f90 new file mode 100644 index 00000000000..bc2f810238d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_22.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-funsigned -pedantic" } +program memain + implicit none + integer :: iostat + character(len=100) :: iomsg + unsigned :: u + open (10) + write (10,'(I10)') -1 + write (10,'(I10)') 2_8**32 + rewind 10 + read (10,'(I10)',iostat=iostat,iomsg=iomsg) u + if (iostat == 0) error stop 1 + if (iomsg /= "Negative sign for unsigned integer read") error stop 2 + read (10,'(I10)',iostat=iostat,iomsg=iomsg) u + if (iostat == 0) error stop 3 + if (iomsg /= "Value overflowed during unsigned integer read") error stop 4 + rewind 10 + read (10,*,iostat=iostat,iomsg=iomsg) u + if (iostat == 0) error stop 5 + if (iomsg /= "Negative sign for unsigned integer in item 1 of list input ") error stop 6 + read (10,*,iostat=iostat,iomsg=iomsg) u + if (iostat == 0) error stop 7 + if (iomsg /= "Unsigned integer overflow while reading item 1 of list input") error stop 8 + end program memain diff --git a/gcc/testsuite/gfortran.dg/unsigned_3.f90 b/gcc/testsuite/gfortran.dg/unsigned_3.f90 new file mode 100644 index 00000000000..7d5b4d67cfd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-funsigned" } +! Test that overflow warned about. +program main + unsigned(1) :: u + u = 256u_1 ! { dg-warning "Unsigned constant truncated" } + u = -127u_1 + u = 255u_1 + u = -129u_1 ! { dg-warning "Unsigned constant truncated" } +end diff --git a/gcc/testsuite/gfortran.dg/unsigned_4.f90 b/gcc/testsuite/gfortran.dg/unsigned_4.f90 new file mode 100644 index 00000000000..46b08a3e81f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_4.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test some basic formatted I/O. + +program main + unsigned :: u + open (10,status="scratch") + write (10,'(I4)') 1u + write (10,'(I4)') -1 + rewind 10 + read (10,'(I4)') u + if (u /= 1u) error stop 1 + read (10,'(I4)') u + if (u /= 4294967295u) error stop 2 +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_5.f90 b/gcc/testsuite/gfortran.dg/unsigned_5.f90 new file mode 100644 index 00000000000..b8b956ecdf6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_5.f90 @@ -0,0 +1,123 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test conversions from unsigned to different data types by +! doing some I/O. +program main + implicit none + integer :: vi,i + integer, parameter :: n_int = 16, n_real = 8 + unsigned(kind=1) :: u1 + unsigned(kind=2) :: u2 + unsigned(kind=4) :: u4 + unsigned(kind=8) :: u8 + unsigned :: u + integer, dimension(n_int) :: ires + real(kind=8), dimension(n_real) :: rres + real(kind=8) :: vr + complex (kind=8) :: vc + data ires /11,12,14,18,21,22,24,28,41,42,44,48,81,82,84,88/ + data rres /14., 18., 24., 28., 44., 48., 84., 88./ + open (10,status="scratch") + + write (10,*) int(11u_1,1) + write (10,*) int(12u_1,2) + write (10,*) int(14u_1,4) + write (10,*) int(18u_1,8) + + write (10,*) int(21u_2,1) + write (10,*) int(22u_2,2) + write (10,*) int(24u_2,4) + write (10,*) int(28u_2,8) + + write (10,*) int(41u_4,1) + write (10,*) int(42u_4,2) + write (10,*) int(44u_4,4) + write (10,*) int(48u_4,8) + + write (10,*) int(81u_8,1) + write (10,*) int(82u_8,2) + write (10,*) int(84u_8,4) + write (10,*) int(88u_8,8) + + rewind 10 + do i=1,n_int + read (10,*) vi + if (vi /= ires(i)) error stop 1 + end do + + rewind 10 + u1 = 11u; write (10,*) int(u1,1) + u1 = 12u; write (10,*) int(u1,2) + u1 = 14u; write (10,*) int(u1,4) + u1 = 18u; write (10,*) int(u1,8) + + u2 = 21u; write (10,*) int(u2,1) + u2 = 22u; write (10,*) int(u2,2) + u2 = 24u; write (10,*) int(u2,4) + u2 = 28u; write (10,*) int(u2,8) + + u4 = 41u; write (10,*) int(u4,1) + u4 = 42u; write (10,*) int(u4,2) + u4 = 44u; write (10,*) int(u4,4) + u4 = 48u; write (10,*) int(u4,8) + + u8 = 81u; write (10,*) int(u8,1) + u8 = 82u; write (10,*) int(u8,2) + u8 = 84u; write (10,*) int(u8,4) + u8 = 88u; write (10,*) int(u8,8) + + rewind 10 + do i=1,n_int + read (10,*) vi + if (vi /= ires(i)) error stop 2 + end do + + rewind 10 + write (10,*) real(14u_1,4) + write (10,*) real(18u_1,8) + write (10,*) real(24u_2,4) + write (10,*) real(28u_2,8) + write (10,*) real(44u_4,4) + write (10,*) real(48u_4,8) + write (10,*) real(84u_8,4) + write (10,*) real(88u_8,8) + + rewind 10 + do i=1, n_real + read (10, *) vr + if (vr /= rres(i)) error stop 3 + end do + + rewind 10 + u1 = 14u_1; write (10,*) real(u1,4) + u1 = 18u_1; write (10,*) real(u1,8) + u2 = 24u_2; write (10,*) real(u2,4) + u2 = 28u_2; write (10,*) real(u2,8) + u4 = 44u_4; write (10,*) real(u4,4) + u4 = 48u_4; write (10,*) real(u4,8) + u8 = 84u_4; write (10,*) real(u8,4) + u8 = 88u_4; write (10,*) real(u8,8) + + rewind 10 + do i=1, n_real + read (10, *) vr + if (vr /= rres(i)) error stop 4 + end do + + rewind 10 + u1 = 14u_1; write (10,*) cmplx(14u_1,u1,kind=4) + u1 = 18u_1; write (10,*) cmplx(18u_1,u1,kind=8) + u2 = 24u_2; write (10,*) cmplx(24u_2,u2,kind=4) + u2 = 28u_2; write (10,*) cmplx(28u_2,u2,kind=8) + u4 = 44u_4; write (10,*) cmplx(44u_4,u4,kind=4) + u4 = 48u_8; write (10,*) cmplx(48u_4,u4,kind=8) + u8 = 84u_8; write (10,*) cmplx(84u_8,u8,kind=4) + u8 = 88u_8; write (10,*) cmplx(88u_8,u8,kind=8) + + rewind 10 + do i=1,n_real + read (10, *) vc + if (real(vc) /= rres(i)) error stop 5 + if (aimag(vc) /= rres(i)) error stop 6 + end do +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_6.f90 b/gcc/testsuite/gfortran.dg/unsigned_6.f90 new file mode 100644 index 00000000000..677fdddec21 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_6.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test the uint intrinsic. +program main + implicit none + integer :: i + real :: r + complex :: c + if (1u /= uint(1)) error stop 1 + if (2u /= uint(2.0)) error stop 2 + if (3u /= uint((3.2,0.))) error stop 3 + + i = 4 + if (uint(i) /= 4u) error stop 4 + r = 5.2 + if (uint(r) /= 5u) error stop 5 + c = (6.2,-1.2) + if (uint(c) /= 6u) error stop 6 + + if (uint(z'ff') /= 255u) error stop 7 +end program main diff --git a/gcc/testsuite/gfortran.dg/unsigned_7.f90 b/gcc/testsuite/gfortran.dg/unsigned_7.f90 new file mode 100644 index 00000000000..703c8abcbf7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_7.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test bit functions, huge and digits. + unsigned :: u1, u2, u3 + u1 = 32u + u2 = 64u + if (ior (u1,u2) /= u1 + u2) error stop 1 + if (ior (32u,64u) /= 32u + 64u) error stop 2 + u1 = 234u + u2 = 221u + if (iand (u1,u2) /= 200u) error stop 3 + if (iand (234u,221u) /= 200u) error stop 4 + if (ieor (u1,u2) /= 55u) error stop 5 + if (ieor (234u,221u) /= 55u) error stop 6 + u1 = huge(u1) + if (u1 /= 4294967295u) error stop 7 + u2 = not(0u) + u3 = u2 - u1 + if (u3 /= 0u) error stop 8 + u2 = not(255u); + if (u2 /= huge(u2) - 255u) error stop 9 + u1 = 255u + u2 = not(u1) + if (u2 /= huge(u2) - 255u) error stop 9 + if (digits(u1) /= 32) error stop 10 +end diff --git a/gcc/testsuite/gfortran.dg/unsigned_8.f90 b/gcc/testsuite/gfortran.dg/unsigned_8.f90 new file mode 100644 index 00000000000..f23056ab3bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_8.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test bit_size, btest and bgt plus friends. +program main + implicit none + unsigned :: u + integer :: i, j + unsigned :: ui, uj + logical:: test_i, test_u + if (bit_size(u) /= 32) error stop 1 + if (.not. btest(32,5)) error stop 2 + if (btest(32,4)) error stop 3 + u = 32u + if (btest(u,4)) error stop 4 + do i=1,3 + ui = uint(i) + do j=1,3 + uj = uint(j) + test_i = blt(i,j) + test_u = blt(ui,uj) + if (test_i .neqv. test_u) error stop 5 + test_i = ble(i,j) + test_u = ble(ui,uj) + if (test_i .neqv. test_u) error stop 6 + test_i = bge(i,j) + test_u = bge(ui,uj) + if (test_i .neqv. test_u) error stop 7 + test_i = bgt(i,j) + test_u = bgt(ui,uj) + if (test_i .neqv. test_u) error stop 8 + end do + end do + if (blt (1, 1) .neqv. blt (1u, 1u)) error stop 8 + if (ble (1, 1) .neqv. ble (1u, 1u)) error stop 9 + if (bge (1, 1) .neqv. bge (1u, 1u)) error stop 10 + if (bgt (1, 1) .neqv. bgt (1u, 1u)) error stop 11 + if (blt (1, 2) .neqv. blt (1u, 2u)) error stop 12 + if (ble (1, 2) .neqv. ble (1u, 2u)) error stop 13 + if (bge (1, 2) .neqv. bge (1u, 2u)) error stop 14 + if (bgt (1, 2) .neqv. bgt (1u, 2u)) error stop 15 + if (blt (1, 3) .neqv. blt (1u, 3u)) error stop 16 + if (ble (1, 3) .neqv. ble (1u, 3u)) error stop 17 + if (bge (1, 3) .neqv. bge (1u, 3u)) error stop 18 + if (bgt (1, 3) .neqv. bgt (1u, 3u)) error stop 19 + if (blt (2, 1) .neqv. blt (2u, 1u)) error stop 20 + if (ble (2, 1) .neqv. ble (2u, 1u)) error stop 21 + if (bge (2, 1) .neqv. bge (2u, 1u)) error stop 22 + if (bgt (2, 1) .neqv. bgt (2u, 1u)) error stop 23 + if (blt (2, 2) .neqv. blt (2u, 2u)) error stop 24 + if (ble (2, 2) .neqv. ble (2u, 2u)) error stop 25 + if (bge (2, 2) .neqv. bge (2u, 2u)) error stop 26 + if (bgt (2, 2) .neqv. bgt (2u, 2u)) error stop 27 + if (blt (2, 3) .neqv. blt (2u, 3u)) error stop 28 + if (ble (2, 3) .neqv. ble (2u, 3u)) error stop 29 + if (bge (2, 3) .neqv. bge (2u, 3u)) error stop 30 + if (bgt (2, 3) .neqv. bgt (2u, 3u)) error stop 31 + if (blt (3, 1) .neqv. blt (3u, 1u)) error stop 32 + if (ble (3, 1) .neqv. ble (3u, 1u)) error stop 33 + if (bge (3, 1) .neqv. bge (3u, 1u)) error stop 34 + if (bgt (3, 1) .neqv. bgt (3u, 1u)) error stop 35 + if (blt (3, 2) .neqv. blt (3u, 2u)) error stop 36 + if (ble (3, 2) .neqv. ble (3u, 2u)) error stop 37 + if (bge (3, 2) .neqv. bge (3u, 2u)) error stop 38 + if (bgt (3, 2) .neqv. bgt (3u, 2u)) error stop 39 + if (blt (3, 3) .neqv. blt (3u, 3u)) error stop 40 + if (ble (3, 3) .neqv. ble (3u, 3u)) error stop 41 + if (bge (3, 3) .neqv. bge (3u, 3u)) error stop 42 + if (bgt (3, 3) .neqv. bgt (3u, 3u)) error stop 43 + +end diff --git a/gcc/testsuite/gfortran.dg/unsigned_9.f90 b/gcc/testsuite/gfortran.dg/unsigned_9.f90 new file mode 100644 index 00000000000..1b0f095b32c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_9.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Test dshiftl, dshiftr, ibclr, ibset and ibits intrinsics. +program main + unsigned :: u, v, w + integer :: i, j, k + + u = 1u; v = 4u + i = 1; j = 4 + if (int(dshiftl(u,v,12)) /= dshiftl(i,j,12)) error stop 1 + if (int(dshiftl(1u,4u,12)) /= dshiftl(1,4,12)) error stop 2 + if (int(dshiftr(u,v,12)) /= dshiftr(i,j,12)) error stop 3 + if (int(dshiftr(1u,4u,12)) /= dshiftr(1,4,12)) error stop 4 + + k = 14 + + if (int(dshiftl(u,v,k)) /= dshiftl(i,j,k)) error stop 5 + if (int(dshiftl(1u,4u,k)) /= dshiftl(1,4,k)) error stop 6 + if (int(dshiftr(u,v,k)) /= dshiftr(i,j,k)) error stop 7 + if (int(dshiftr(1u,4u,k)) /= dshiftr(1,4,k)) error stop 8 + + u = 255u + i = 255 + do k=0,8 + if (ibclr(i,k) /= int(ibclr(u,k))) error stop 9 + if (ibset(i,k+4) /= int(ibset(u,k+4))) error stop 10 + end do + if (ibclr(255,5) /= int(ibclr(255u,5))) error stop 11 + if (ibset(255,10) /= int(ibset(255u,10))) error stop 12 + + if (uint(ibits(6,6,2)) /= ibits(6u,6,2)) error stop 13 +end program main diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 82f8f3c5e9c..e71cbcf2376 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1775,4 +1775,6 @@ GFORTRAN_15 { global: _gfortran_internal_pack_class; _gfortran_internal_unpack_class; + _gfortran_transfer_unsigned; + _gfortran_transfer_unsigned_write; } GFORTRAN_14; diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 1c23676cc4c..2677551b277 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -861,9 +861,15 @@ internal_proto (transfer_array_inner); extern void set_integer (void *, GFC_INTEGER_LARGEST, int); internal_proto(set_integer); +extern void set_unsigned (void *, GFC_UINTEGER_LARGEST, int); +internal_proto(set_unsigned); + extern GFC_UINTEGER_LARGEST si_max (int); internal_proto(si_max); +extern GFC_UINTEGER_LARGEST us_max (int); +internal_proto(us_max); + extern int convert_real (st_parameter_dt *, void *, const char *, int); internal_proto(convert_real); @@ -891,6 +897,10 @@ internal_proto(read_radix); extern void read_decimal (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_decimal); +extern void read_decimal_unsigned (st_parameter_dt *, const fnode *, char *, + int); +internal_proto(read_decimal_unsigned); + extern void read_user_defined (st_parameter_dt *, void *); internal_proto(read_user_defined); @@ -941,6 +951,9 @@ internal_proto(write_f); extern void write_i (st_parameter_dt *, const fnode *, const char *, int); internal_proto(write_i); +extern void write_iu (st_parameter_dt *, const fnode *, const char *, int); +internal_proto(write_iu); + extern void write_l (st_parameter_dt *, const fnode *, char *, int); internal_proto(write_l); diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 96b2efe854f..ba6d0f1289f 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -722,6 +722,86 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) return 1; } +/* Same as above, but for unsigneds, where overflow checks are only + preformed with -pedantic, except on the repeat count. */ + +static int +convert_unsigned (st_parameter_dt *dtp, int length, int negative) +{ + char c, *buffer, message[IOMSG_LEN]; + GFC_UINTEGER_LARGEST v, value, max, v_old; + int m; + + if (compile_options.pedantic && negative) + goto overflow; + + buffer = dtp->u.p.saved_string; + max = length == -1 ? MAX_REPEAT : us_max(length); + + v = 0; + for (;;) + { + c = *buffer++; + if (c == '\0') + break; + c -= '0'; + v_old = v; + v = v * 10 + c; + + if (length == -1 && v > max) + goto overflow; + else if (compile_options.pedantic && v < v_old) + goto overflow; + } + + m = 0; + + if (length != -1) + { + if (negative) + value = -v; + else + value = v; + + if (compile_options.pedantic && value > max) + goto overflow; + else + value = value & max; + + set_unsigned (dtp->u.p.value, value, length); + } + else + { + dtp->u.p.repeat_count = v; + + if (dtp->u.p.repeat_count == 0) + { + snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input", + dtp->u.p.item_count); + + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + m = 1; + } + } + free_saved (dtp); + return m; + + overflow: + if (length== -1) + snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); + else if (negative) + snprintf (message, IOMSG_LEN, "Negative sign for unsigned integer " + "in item %d of list input", dtp->u.p.item_count); + else + snprintf (message, IOMSG_LEN, "Unsigned integer overflow while reading " + "item %d of list input", dtp->u.p.item_count); + + free_saved (dtp); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + + return 1; +} /* Parse a repeat count for logical and complex values which cannot begin with a digit. Returns nonzero if we are done, zero if we @@ -990,11 +1070,10 @@ read_logical (st_parameter_dt *dtp, int length) used for repeat counts. */ static void -read_integer (st_parameter_dt *dtp, int length) +read_integer (st_parameter_dt *dtp, int length, bt type) { char message[IOMSG_LEN]; int c, negative; - negative = 0; c = next_char (dtp); @@ -1055,8 +1134,11 @@ read_integer (st_parameter_dt *dtp, int length) } repeat: - if (convert_integer (dtp, -1, 0)) - return; + if (type == BT_INTEGER) + { + if (convert_integer (dtp, -1, 0)) + return; + } /* Get the real integer. */ @@ -1077,6 +1159,9 @@ read_integer (st_parameter_dt *dtp, int length) return; case '-': + if (compile_options.pedantic && type == BT_UNSIGNED) + goto bad_integer; + negative = 1; /* Fall through... */ @@ -1127,8 +1212,13 @@ read_integer (st_parameter_dt *dtp, int length) else if (c != '\n') eat_line (dtp); - snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input", + if (type == BT_INTEGER) + snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input", dtp->u.p.item_count); + else + snprintf (message, IOMSG_LEN, "Bad unsigned for item %d in list input", + dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -1139,17 +1229,27 @@ read_integer (st_parameter_dt *dtp, int length) eat_separator (dtp); push_char (dtp, '\0'); - if (convert_integer (dtp, length, negative)) + if (type == BT_INTEGER) + { + if (convert_integer (dtp, length, negative)) /* XXX */ + { + free_saved (dtp); + return; + } + } + else { - free_saved (dtp); - return; + if (convert_unsigned (dtp, length, negative)) /* XXX */ + { + free_saved (dtp); + return; + } } free_saved (dtp); - dtp->u.p.saved_type = BT_INTEGER; + dtp->u.p.saved_type = type; } - /* Read a character variable. */ static void @@ -2224,7 +2324,8 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, switch (type) { case BT_INTEGER: - read_integer (dtp, kind); + case BT_UNSIGNED: + read_integer (dtp, kind, type); break; case BT_LOGICAL: read_logical (dtp, kind); @@ -2318,6 +2419,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, break; case BT_INTEGER: + case BT_UNSIGNED: case BT_LOGICAL: memcpy (p, dtp->u.p.value, size); break; @@ -3029,7 +3131,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, switch (nl->type) { case BT_INTEGER: - read_integer (dtp, len); + case BT_UNSIGNED: + read_integer (dtp, len, nl->type); break; case BT_LOGICAL: diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index 7a9e341d7d8..78014e2ffe5 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -92,6 +92,62 @@ set_integer (void *dest, GFC_INTEGER_LARGEST value, int length) } } +/* set_integer()-- All of the integer assignments come here to + actually place the value into memory. */ + +void +set_unsigned (void *dest, GFC_UINTEGER_LARGEST value, int length) +{ + NOTE ("set_integer: %lld %p", (long long int) value, dest); + switch (length) + { +#ifdef HAVE_GFC_UINTEGER_16 +#ifdef HAVE_GFC_REAL_17 + case 17: + { + GFC_UINTEGER_16 tmp = value; + memcpy (dest, (void *) &tmp, 16); + } + break; +#endif +/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */ + case 10: + case 16: + { + GFC_UINTEGER_16 tmp = value; + memcpy (dest, (void *) &tmp, length); + } + break; +#endif + case 8: + { + GFC_UINTEGER_8 tmp = value; + memcpy (dest, (void *) &tmp, length); + } + break; + case 4: + { + GFC_UINTEGER_4 tmp = value; + memcpy (dest, (void *) &tmp, length); + } + break; + case 2: + { + GFC_UINTEGER_2 tmp = value; + memcpy (dest, (void *) &tmp, length); + } + break; + case 1: + { + GFC_UINTEGER_1 tmp = value; + memcpy (dest, (void *) &tmp, length); + } + break; + default: + internal_error (NULL, "Bad integer kind"); + } +} + /* Max signed value of size give by length argument. */ @@ -132,6 +188,28 @@ si_max (int length) } } +GFC_UINTEGER_LARGEST +us_max (int length) +{ + switch (length) + { +#ifdef HAVE_GFC_UINTEGER_16 + case 17: + case 16: + return GFC_UINTEGER_16_HUGE; +#endif + case 8: + return GFC_UINTEGER_8_HUGE; + case 4: + return GFC_UINTEGER_4_HUGE; + case 2: + return GFC_UINTEGER_2_HUGE; + case 1: + return GFC_UINTEGER_1_HUGE; + default: + internal_error (NULL, "Bad unsigned kind"); + } +} /* convert_real()-- Convert a character representation of a floating point number to the machine number. Returns nonzero if there is an @@ -392,7 +470,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes) if ((c & ~masks[nb-1]) == patns[nb-1]) goto found; goto invalid; - + found: c = (c & masks[nb-1]); nread = nb - 1; @@ -423,7 +501,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes) goto invalid; return c; - + invalid: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding"); return (gfc_char4_t) '?'; @@ -466,7 +544,7 @@ read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width) size_t m; s = read_block_form (dtp, &width); - + if (s == NULL) return; if (width > len) @@ -610,7 +688,7 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length) read_utf8_char4 (dtp, p, length, w); else read_default_char4 (dtp, p, length, w); - + dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; } @@ -651,7 +729,7 @@ next_char (st_parameter_dt *dtp, char **p, size_t *w) if (c != ' ') return c; if (dtp->u.p.blank_status != BLANK_UNSPECIFIED) - return ' '; /* return a blank to signal a null */ + return ' '; /* return a blank to signal a null */ /* At this point, the rest of the field has to be trailing blanks */ @@ -730,19 +808,19 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) c = next_char (dtp, &p, &w); if (c == '\0') break; - + if (c == ' ') { if (dtp->u.p.blank_status == BLANK_NULL) { /* Skip spaces. */ for ( ; w > 0; p++, w--) - if (*p != ' ') break; + if (*p != ' ') break; continue; } if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } - + if (c < '0' || c > '9') goto bad; @@ -778,6 +856,119 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) } +/* read_decimal_unsigned() - almost the same as above. Checks for sign + and overflow are performed with -pedantic. */ + +void +read_decimal_unsigned (st_parameter_dt *dtp, const fnode *f, char *dest, + int length) +{ + GFC_UINTEGER_LARGEST value, old_value; + size_t w; + int negative; + char c, *p; + + w = f->u.w; + + /* This is a legacy extension, and the frontend will only allow such cases + * through when -fdec-format-defaults is passed. + */ + if (w == (size_t) DEFAULT_WIDTH) + w = default_width_for_integer (length); + + p = read_block_form (dtp, &w); + + if (p == NULL) + return; + + p = eat_leading_spaces (&w, p); + if (w == 0) + { + set_unsigned (dest, (GFC_UINTEGER_LARGEST) 0, length); + return; + } + + negative = 0; + + switch (*p) + { + case '-': + if (compile_options.pedantic) + goto no_sign; + + negative = 1; + + /* Fall through */ + + case '+': + p++; + if (--w == 0) + goto bad; + /* Fall through */ + + default: + break; + } + + /* At this point we have a digit-string */ + value = 0; + + for (;;) + { + c = next_char (dtp, &p, &w); + if (c == '\0') + break; + + if (c == ' ') + { + if (dtp->u.p.blank_status == BLANK_NULL) + { + /* Skip spaces. */ + for ( ; w > 0; p++, w--) + if (*p != ' ') break; + continue; + } + if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; + } + + if (c < '0' || c > '9') + goto bad; + + c -= '0'; + old_value = value; + value = 10 * value + c; + if (compile_options.pedantic && value < old_value) + goto overflow; + } + + if (negative) + value = -value; + + if (compile_options.pedantic && value > us_max (length)) + goto overflow; + + set_unsigned (dest, value, length); + return; + + bad: + generate_error (&dtp->common, LIBERROR_READ_VALUE, + "Bad value during unsigned integer read"); + next_record (dtp, 1); + return; + + no_sign: + generate_error (&dtp->common, LIBERROR_READ_VALUE, + "Negative sign for unsigned integer read"); + next_record (dtp, 1); + return; + + overflow: + generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, + "Value overflowed during unsigned integer read"); + next_record (dtp, 1); + +} + /* read_radix()-- This function reads values for non-decimal radixes. The difference here is that we treat the values here as unsigned @@ -992,7 +1183,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) if (w == 0) goto zero; - /* Check for Infinity or NaN. */ + /* Check for Infinity or NaN. */ if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N')))) { int seen_paren = 0; @@ -1034,9 +1225,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) ++p; ++out; } - + *out = '\0'; - + if (seen_paren != 0 && seen_paren != 2) goto bad_float; @@ -1133,7 +1324,7 @@ found_digit: ++p; --w; } - + /* No exponent has been seen, so we use the current scale factor. */ exponent = - dtp->u.p.scale_factor; goto done; @@ -1171,7 +1362,7 @@ exponent: ++p; --w; } - + /* Only allow trailing blanks. */ while (w > 0) { @@ -1180,7 +1371,7 @@ exponent: ++p; --w; } - } + } else /* BZ or BN status is enabled. */ { while (w > 0) @@ -1220,7 +1411,7 @@ done: significand. */ else if (!seen_int_digit && !seen_dec_digit) { - notify_std (&dtp->common, GFC_STD_LEGACY, + notify_std (&dtp->common, GFC_STD_LEGACY, "REAL input of style 'E+NN'"); *(out++) = '0'; } @@ -1313,20 +1504,20 @@ read_x (st_parameter_dt *dtp, size_t n) if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp)) && dtp->u.p.current_unit->bytes_left < (gfc_offset) n) n = dtp->u.p.current_unit->bytes_left; - + if (n == 0) return; - + if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) { gfc_char4_t c; size_t nbytes, j; - + /* Proceed with decoding one character at a time. */ for (j = 0; j < n; j++) { c = read_utf8 (dtp, &nbytes); - + /* Check for a short read and if so, break out. */ if (nbytes == 0 || c == (gfc_char4_t)0) break; @@ -1363,7 +1554,7 @@ read_x (st_parameter_dt *dtp, size_t n) the rest of the I/O statement. Set the corresponding flag. */ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; - + /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { @@ -1377,7 +1568,7 @@ read_x (st_parameter_dt *dtp, size_t n) goto done; } n++; - } + } done: if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || @@ -1386,4 +1577,3 @@ read_x (st_parameter_dt *dtp, size_t n) dtp->u.p.current_unit->bytes_left -= n; dtp->u.p.current_unit->strm_pos += (gfc_offset) n; } - diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index a86099d46f5..64f394dddc7 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -56,6 +56,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see transfer_complex transfer_real128 transfer_complex128 + transfer_unsigned and for WRITE @@ -67,6 +68,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see transfer_complex_write transfer_real128_write transfer_complex128_write + transfer_unsigned_write These subroutines do not return status. The *128 functions are in the file transfer128.c. @@ -82,6 +84,12 @@ export_proto(transfer_integer); extern void transfer_integer_write (st_parameter_dt *, void *, int); export_proto(transfer_integer_write); +extern void transfer_unsigned (st_parameter_dt *, void *, int); +export_proto(transfer_unsigned); + +extern void transfer_unsigned_write (st_parameter_dt *, void *, int); +export_proto(transfer_unsigned_write); + extern void transfer_real (st_parameter_dt *, void *, int); export_proto(transfer_real); @@ -1410,6 +1418,9 @@ type_name (bt type) case BT_INTEGER: p = "INTEGER"; break; + case BT_UNSIGNED: + p = "UNSIGNED"; + break; case BT_LOGICAL: p = "LOGICAL"; break; @@ -1485,6 +1496,31 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) return 1; } +/* Check that the actual matches one of two expected types; issue an error + if that is not the case. */ + + +static int +require_one_of_two_types (st_parameter_dt *dtp, bt expected1, bt expected2, + bt actual, const fnode *f) +{ + char buffer[BUFLEN]; + + if (actual == expected1) + return 0; + + if (actual == expected2) + return 0; + + snprintf (buffer, BUFLEN, + "Expected %s or %s for item %d in formatted transfer, got %s", + type_name (expected1), type_name (expected2), + dtp->u.p.item_count - 1, type_name (actual)); + + format_error (dtp, f, buffer); + return 1; + +} /* Check that the dtio procedure required for formatted IO is present. */ @@ -1627,9 +1663,12 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind case FMT_I: if (n == 0) goto need_read_data; - if (require_type (dtp, BT_INTEGER, type, f)) + if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f)) return; - read_decimal (dtp, f, p, kind); + if (type == BT_INTEGER) + read_decimal (dtp, f, p, kind); + else + read_decimal_unsigned (dtp, f, p, kind); break; case FMT_B: @@ -2123,9 +2162,12 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin case FMT_I: if (n == 0) goto need_data; - if (require_type (dtp, BT_INTEGER, type, f)) + if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f)) return; - write_i (dtp, f, p, kind); + if (type == BT_INTEGER) + write_i (dtp, f, p, kind); + else + write_iu (dtp, f, p, kind); break; case FMT_B: @@ -2608,6 +2650,18 @@ transfer_integer_write (st_parameter_dt *dtp, void *p, int kind) transfer_integer (dtp, p, kind); } +void +transfer_unsigned (st_parameter_dt *dtp, void *p, int kind) +{ + wrap_scalar_transfer (dtp, BT_UNSIGNED, p, kind, kind, 1); +} + +void +transfer_unsigned_write (st_parameter_dt *dtp, void *p, int kind) +{ + transfer_unsigned (dtp, p, kind); +} + void transfer_real (st_parameter_dt *dtp, void *p, int kind) { diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 91d1da2007a..2f414c6b57d 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -949,7 +949,134 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, return; } +/* Same as above, but somewhat simpler because we only treat unsigned + numbers. */ +static void +write_decimal_unsigned (st_parameter_dt *dtp, const fnode *f, + const char *source, int len) +{ + GFC_UINTEGER_LARGEST n = 0; + int w, m, digits, nsign, nzero, nblank; + char *p; + const char *q; + sign_t sign; + char itoa_buf[GFC_BTOA_BUF_SIZE]; + + w = f->u.integer.w; + m = f->format == FMT_G ? -1 : f->u.integer.m; + + n = extract_uint (source, len); + + /* Special case: */ + if (m == 0 && n == 0) + { + if (w == 0) + w = 1; + + p = write_block (dtp, w); + if (p == NULL) + return; + + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (p4, ' ', w); + } + else + memset (p, ' ', w); + goto done; + } + + /* Just in case somebody wants a + sign. */ + sign = calculate_sign (dtp, false); + nsign = sign == S_NONE ? 0 : 1; + + q = gfc_itoa (n, itoa_buf, sizeof (itoa_buf)); + digits = strlen (q); + + /* Select a width if none was specified. The idea here is to always + print something. */ + if (w == DEFAULT_WIDTH) + w = default_width_for_integer (len); + + if (w == 0) + w = ((digits < m) ? m : digits) + nsign; + + p = write_block (dtp, w); + if (p == NULL) + return; + + nzero = 0; + if (digits < m) + nzero = m - digits; + + /* See if things will work. */ + + nblank = w - (nsign + nzero + digits); + + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *)p; + if (nblank < 0) + { + memset4 (p4, '*', w); + goto done; + } + + if (!dtp->u.p.namelist_mode) + { + memset4 (p4, ' ', nblank); + p4 += nblank; + } + + if (sign == S_PLUS) + *p4++ = '+'; + + memset4 (p4, '0', nzero); + p4 += nzero; + + memcpy4 (p4, q, digits); + + if (dtp->u.p.namelist_mode) + { + p4 += digits; + memset4 (p4, ' ', nblank); + } + + return; + } + + if (nblank < 0) + { + star_fill (p, w); + goto done; + } + + if (!dtp->u.p.namelist_mode) + { + memset (p, ' ', nblank); + p += nblank; + } + + if (sign == S_PLUS) + *p++ = '+'; + + memset (p, '0', nzero); + p += nzero; + + memcpy (p, q, digits); + + if (dtp->u.p.namelist_mode) + { + p += digits; + memset (p, ' ', nblank); + } + + done: + return; + +} /* Convert hexadecimal to ASCII. */ static const char * @@ -1240,6 +1367,11 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len) write_decimal (dtp, f, p, len); } +void +write_iu (st_parameter_dt *dtp, const fnode *f, const char *p, int len) +{ + write_decimal_unsigned (dtp, f, p, len); +} void write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len) @@ -1404,6 +1536,47 @@ write_integer (st_parameter_dt *dtp, const char *source, int kind) write_decimal (dtp, &f, source, kind); } +/* Write a list-directed unsigned value. We use the same formatting + as for integer. */ + +static void +write_unsigned (st_parameter_dt *dtp, const char *source, int kind) +{ + int width; + fnode f; + + switch (kind) + { + case 1: + width = 4; + break; + + case 2: + width = 6; + break; + + case 4: + width = 11; + break; + + case 8: + width = 20; + break; + + case 16: + width = 40; + break; + + default: + width = 0; + break; + } + f.u.integer.w = width; + f.u.integer.m = -1; + f.format = FMT_NONE; + write_decimal_unsigned (dtp, &f, source, kind); +} + /* Write a list-directed string. We have to worry about delimiting the strings if the file has been opened in that mode. */ @@ -1942,6 +2115,9 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, case BT_INTEGER: write_integer (dtp, p, kind); break; + case BT_UNSIGNED: + write_unsigned (dtp, p, kind); + break; case BT_LOGICAL: write_logical (dtp, p, kind); break; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index effa3732c18..faf57a33358 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -307,6 +307,15 @@ typedef GFC_UINTEGER_4 gfc_char4_t; (GFC_INTEGER_16)((((GFC_UINTEGER_16)1) << 127) - 1) #endif +#define GFC_UINTEGER_1_HUGE ((GFC_UINTEGER_1) -1) +#define GFC_UINTEGER_2_HUGE ((GFC_UINTEGER_2) -1) +#define GFC_UINTEGER_4_HUGE ((GFC_UINTEGER_4) -1) +#define GFC_UINTEGER_8_HUGE ((GFC_UINTEGER_8) -1) +#ifdef HAVE_GFC_UINTEGER_16 +#define GFC_UINTEGER_16_HUGE ((GFC_UINTEGER_16) -1) +#endif + + /* M{IN,AX}{LOC,VAL} need also infinities and NaNs if supported. */ #if __FLT_HAS_INFINITY__ @@ -2042,9 +2051,4 @@ extern int __snprintfieee128 (char *, size_t, const char *, ...) #endif -/* We always have these. */ - -#define HAVE_GFC_UINTEGER_1 1 -#define HAVE_GFC_UINTEGER_4 1 - #endif /* LIBGFOR_H */ diff --git a/libgfortran/mk-kinds-h.sh b/libgfortran/mk-kinds-h.sh index 0e0ec195875..647b3b6eadb 100755 --- a/libgfortran/mk-kinds-h.sh +++ b/libgfortran/mk-kinds-h.sh @@ -38,6 +38,7 @@ for k in $possible_integer_kinds; do echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};" echo "#define HAVE_GFC_LOGICAL_${k}" echo "#define HAVE_GFC_INTEGER_${k}" + echo "#define HAVE_GFC_UINTEGER_${k}" echo "" fi rm -f tmp$$.*