From patchwork Tue Nov 28 18:40:33 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 842255 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-468113-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="DqeJIunr"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3ymXYp71CHz9sBd for ; Wed, 29 Nov 2017 05:41:16 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=TPzksoJ7YYKsETeSY8iTVZk0/iJm8vhJouhPbkgJF3q31yCr85 wif8/8nMo6xyMQOgX9Ob4tCg3HqFCtUGXhsgLTyyIj/S6VlZMgxNx2OI3YVxVlTV FfNy8XQYne/g2Gn7Z7iU0jhZj6hsIHftOvVt9A5Wt9A+Xl3BQ0uekpgfI= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=ThNGyY9JkVBMxGrVS6bfb6LsuWo=; b=DqeJIunrOq5XA41ApEVv 2oC9fxha12wP4oOWgd1X7Yi4QEhyEwuZwxNKULU9UbR5/q0TPPORpL/ujsZo/PzD lCMq+T8WEBfh5eE5DMQzWThLSZxgcZKKNtuZTLewStHkJiB+eAmLv/+FefcFo3c2 SdYVv/g0RajPvPGDNGnfAss= Received: (qmail 96146 invoked by alias); 28 Nov 2017 18:40:58 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 96116 invoked by uid 89); 28 Nov 2017 18:40:57 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-10.6 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, KAM_SHORT, KB_WAM_FROM_NAME_SINGLEWORD, RCVD_IN_DNSWL_LOW, SPF_PASS, T_RP_MATCHES_RCVD autolearn=ham version=3.3.2 spammy=1560, 0.2, ii, dim X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 28 Nov 2017 18:40:41 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 19CFB125C3; Tue, 28 Nov 2017 19:40:37 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id 0B94D11DC1; Tue, 28 Nov 2017 19:40:37 +0100 (CET) Received: from [78.35.131.21] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.1.9) (envelope-from ) id 5a1dada5-02b7-7f0000012729-7f00000184f6-1 for ; Tue, 28 Nov 2017 19:40:37 +0100 Received: from [192.168.178.20] (xdsl-78-35-131-21.netcologne.de [78.35.131.21]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Tue, 28 Nov 2017 19:40:33 +0100 (CET) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Implement maxval for characters Message-ID: Date: Tue, 28 Nov 2017 19:40:33 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.4.0 MIME-Version: 1.0 Hello world, the attached patch implements maxval for characters, an F2003 feature that we were missing up to now. Regression-tested on x86_64-pc-linux-gnu. OK for trunk? Regards Thomas 2017-11-28 Thomas Koenig PR fortran/36313 * check.c (gfc_check_minval_maxval): Use int_orLreal_or_char_check_f2003 for array argument. * iresolve.c (gfc_resolve_maxval): Insert number in function name for character arguments. (gfc_resolve_minval): Likewise. * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Fix comment. (gfc_conv_intrinsic_minmaxval): Resort arguments and call library function if dealing with a character function. 2017-11-28 Thomas Koenig PR fortran/36313 * Makefile.am: Add new files for character-valued maxval and minval. * Makefile.in: Regenerated. * gfortran.map: Add new functions. * m4/iforeach-s2.m4: New file. * m4/ifunction-s2.m4: New file. * m4/iparm.m4: Add intitval for minval and maxval. * m4/maxval0s.m4: New file. * m4/maxval1s.m4: New file. * m4/minval0s.m4: New file. * m4/minval1s.m4: New file. * generated/maxval0_s1.c: New file. * generated/maxval0_s4.c: New file. * generated/maxval1_s1.c: New file. * generated/maxval1_s4.c: New file. * generated/minval0_s1.c: New file. * generated/minval0_s4.c: New file. * generated/minval1_s1.c: New file. * generated/minval1_s4.c: New file. 2017-11-28 Thomas Koenig PR fortran/36313 * gfortran.dg/maxval_char_1.f90: New test. * gfortran.dg/maxval_char_2.f90: New test. * gfortran.dg/maxval_char_3.f90: New test. * gfortran.dg/maxval_char_4.f90: New test. * gfortran.dg/minval_char_1.f90: New test. * gfortran.dg/minval_char_2.f90: New test. * gfortran.dg/minval_char_3.f90: New test. * gfortran.dg/minval_char_4.f90: New test. Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (Revision 255070) +++ gcc/fortran/check.c (Arbeitskopie) @@ -3317,7 +3317,7 @@ check_reduction (gfc_actual_arglist *ap) bool gfc_check_minval_maxval (gfc_actual_arglist *ap) { - if (!int_or_real_check (ap->expr, 0) + if (!int_or_real_or_char_check_f2003 (ap->expr, 0) || !array_check (ap->expr, 0)) return false; Index: gcc/fortran/iresolve.c =================================================================== --- gcc/fortran/iresolve.c (Revision 255070) +++ gcc/fortran/iresolve.c (Arbeitskopie) @@ -1823,9 +1823,14 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, else name = "maxval"; - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), array->ts.kind); + if (array->ts.type != BT_CHARACTER) + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), array->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, + gfc_type_letter (array->ts.type), array->ts.kind); } @@ -2023,9 +2028,14 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, else name = "minval"; - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), array->ts.kind); + if (array->ts.type != BT_CHARACTER) + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), array->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, + gfc_type_letter (array->ts.type), array->ts.kind); } Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 255070) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -4571,7 +4571,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_exp actual = expr->value.function.actual; arrayexpr = actual->expr; - /* Special case for character maxval. Remove unneeded actual + /* Special case for character maxloc. Remove unneeded actual arguments, then call a library function. */ if (arrayexpr->ts.type == BT_CHARACTER) @@ -5039,6 +5039,34 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_exp return; } + actual = expr->value.function.actual; + arrayexpr = actual->expr; + + if (arrayexpr->ts.type == BT_CHARACTER) + { + gfc_actual_arglist *a2, *a3; + a2 = actual->next; /* dim */ + a3 = a2->next; /* mask */ + if (a2->expr == NULL || expr->rank == 0) + { + if (a3->expr == NULL) + actual->next = NULL; + else + { + actual->next = a3; + a2->next = NULL; + } + gfc_free_actual_arglist (a2); + } + else + if (a3->expr == NULL) + { + a2->next = NULL; + gfc_free_actual_arglist (a3); + } + gfc_conv_intrinsic_funcall (se, expr); + return; + } type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ limit = gfc_create_var (type, "limit"); @@ -5087,8 +5115,6 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_exp gfc_add_modify (&se->pre, limit, tmp); /* Walk the arguments. */ - actual = expr->value.function.actual; - arrayexpr = actual->expr; arrayss = gfc_walk_expr (arrayexpr); gcc_assert (arrayss != gfc_ss_terminator); Index: libgfortran/Makefile.am =================================================================== --- libgfortran/Makefile.am (Revision 255143) +++ libgfortran/Makefile.am (Arbeitskopie) @@ -357,6 +357,14 @@ $(srcdir)/generated/maxval_r8.c \ $(srcdir)/generated/maxval_r10.c \ $(srcdir)/generated/maxval_r16.c +i_maxval0s_c=\ +$(srcdir)/generated/maxval0_s1.c \ +$(srcdir)/generated/maxval0_s4.c + +i_maxval1s_c=\ +$(srcdir)/generated/maxval1_s1.c \ +$(srcdir)/generated/maxval1_s4.c + i_minloc0_c= \ $(srcdir)/generated/minloc0_4_i1.c \ $(srcdir)/generated/minloc0_8_i1.c \ @@ -450,6 +458,14 @@ $(srcdir)/generated/minval_r8.c \ $(srcdir)/generated/minval_r10.c \ $(srcdir)/generated/minval_r16.c +i_minval0s_c=\ +$(srcdir)/generated/minval0_s1.c \ +$(srcdir)/generated/minval0_s4.c + +i_minval1s_c=\ +$(srcdir)/generated/minval1_s1.c \ +$(srcdir)/generated/minval1_s4.c + i_norm2_c= \ $(srcdir)/generated/norm2_r4.c \ $(srcdir)/generated/norm2_r8.c \ @@ -748,7 +764,8 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \ $(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \ - $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) + $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \ + $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) # Machine generated specifics gfor_built_specific_src= \ @@ -973,6 +990,8 @@ I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4 I_M4_DEPS2=$(I_M4_DEPS) m4/ifunction_logical.m4 I_M4_DEPS3=$(I_M4_DEPS) m4/iforeach-s.m4 I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4 +I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4 +I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4 kinds.h: $(srcdir)/mk-kinds-h.sh $(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@ @@ -1039,6 +1058,12 @@ $(i_maxloc2s_c): m4/maxloc2s.m4 $(I_M4_DEPS) $(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@ +$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5) + $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@ + +$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6) + $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@ + $(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0) $(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@ @@ -1057,6 +1082,12 @@ $(i_minloc2s_c): m4/minloc2s.m4 $(I_M4_DEPS) $(i_minval_c): m4/minval.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@ +$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5) + $(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@ + +$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6) + $(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@ + $(i_product_c): m4/product.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@ Index: libgfortran/Makefile.in =================================================================== --- libgfortran/Makefile.in (Revision 255143) +++ libgfortran/Makefile.in (Arbeitskopie) @@ -329,7 +329,11 @@ am__objects_41 = maxloc2_4_s1.lo maxloc2_4_s4.lo m maxloc2_8_s4.lo maxloc2_16_s1.lo maxloc2_16_s4.lo am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo minloc2_8_s1.lo \ minloc2_8_s4.lo minloc2_16_s1.lo minloc2_16_s4.lo -am__objects_43 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \ +am__objects_43 = maxval0_s1.lo maxval0_s4.lo +am__objects_44 = minval0_s1.lo minval0_s4.lo +am__objects_45 = maxval1_s1.lo maxval1_s4.lo +am__objects_46 = minval1_s1.lo minval1_s4.lo +am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \ $(am__objects_7) $(am__objects_8) $(am__objects_9) \ $(am__objects_10) $(am__objects_11) $(am__objects_12) \ $(am__objects_13) $(am__objects_14) $(am__objects_15) \ @@ -341,14 +345,16 @@ am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo m $(am__objects_31) $(am__objects_32) $(am__objects_33) \ $(am__objects_34) $(am__objects_35) $(am__objects_36) \ $(am__objects_37) $(am__objects_38) $(am__objects_39) \ - $(am__objects_40) $(am__objects_41) $(am__objects_42) -@LIBGFOR_MINIMAL_FALSE@am__objects_44 = close.lo file_pos.lo format.lo \ + $(am__objects_40) $(am__objects_41) $(am__objects_42) \ + $(am__objects_43) $(am__objects_44) $(am__objects_45) \ + $(am__objects_46) +@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \ @LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \ @LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \ @LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \ @LIBGFOR_MINIMAL_FALSE@ fbuf.lo -am__objects_45 = size_from_kind.lo $(am__objects_44) -@LIBGFOR_MINIMAL_FALSE@am__objects_46 = access.lo c99_functions.lo \ +am__objects_49 = size_from_kind.lo $(am__objects_48) +@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \ @LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \ @LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \ @LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \ @@ -358,8 +364,8 @@ am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo m @LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \ @LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \ @LIBGFOR_MINIMAL_FALSE@ unlink.lo -@IEEE_SUPPORT_TRUE@am__objects_47 = ieee_helper.lo -am__objects_48 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \ +@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo +am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \ eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \ ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \ selected_char_kind.lo size.lo spread_generic.lo \ @@ -366,11 +372,11 @@ am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo m string_intrinsics.lo rand.lo random.lo reshape_generic.lo \ reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \ - $(am__objects_46) $(am__objects_47) -@IEEE_SUPPORT_TRUE@am__objects_49 = ieee_arithmetic.lo \ + $(am__objects_50) $(am__objects_51) +@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \ @IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo -am__objects_50 = -am__objects_51 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ +am__objects_54 = +am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ _abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \ _abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \ _aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \ @@ -394,19 +400,19 @@ am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo m _conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \ _aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \ _anint_r8.lo _anint_r10.lo _anint_r16.lo -am__objects_52 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ +am__objects_56 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ _sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \ _dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \ _atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \ _mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \ _mod_r10.lo _mod_r16.lo -am__objects_53 = misc_specifics.lo -am__objects_54 = $(am__objects_51) $(am__objects_52) $(am__objects_53) \ +am__objects_57 = misc_specifics.lo +am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \ dprod_r8.lo f2c_specifics.lo -am__objects_55 = $(am__objects_3) $(am__objects_43) $(am__objects_45) \ - $(am__objects_48) $(am__objects_49) $(am__objects_50) \ - $(am__objects_54) -@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_55) +am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \ + $(am__objects_52) $(am__objects_53) $(am__objects_54) \ + $(am__objects_58) +@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59) @onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) DEFAULT_INCLUDES = -I.@am__isrc@ @@ -810,6 +816,14 @@ $(srcdir)/generated/maxval_r8.c \ $(srcdir)/generated/maxval_r10.c \ $(srcdir)/generated/maxval_r16.c +i_maxval0s_c = \ +$(srcdir)/generated/maxval0_s1.c \ +$(srcdir)/generated/maxval0_s4.c + +i_maxval1s_c = \ +$(srcdir)/generated/maxval1_s1.c \ +$(srcdir)/generated/maxval1_s4.c + i_minloc0_c = \ $(srcdir)/generated/minloc0_4_i1.c \ $(srcdir)/generated/minloc0_8_i1.c \ @@ -903,6 +917,14 @@ $(srcdir)/generated/minval_r8.c \ $(srcdir)/generated/minval_r10.c \ $(srcdir)/generated/minval_r16.c +i_minval0s_c = \ +$(srcdir)/generated/minval0_s1.c \ +$(srcdir)/generated/minval0_s4.c + +i_minval1s_c = \ +$(srcdir)/generated/minval1_s1.c \ +$(srcdir)/generated/minval1_s4.c + i_norm2_c = \ $(srcdir)/generated/norm2_r4.c \ $(srcdir)/generated/norm2_r8.c \ @@ -1201,7 +1223,8 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c $(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \ $(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \ - $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) + $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \ + $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) # Machine generated specifics @@ -1379,6 +1402,8 @@ I_M4_DEPS1 = $(I_M4_DEPS) m4/ifunction.m4 I_M4_DEPS2 = $(I_M4_DEPS) m4/ifunction_logical.m4 I_M4_DEPS3 = $(I_M4_DEPS) m4/iforeach-s.m4 I_M4_DEPS4 = $(I_M4_DEPS) m4/ifunction-s.m4 +I_M4_DEPS5 = $(I_M4_DEPS) m4/iforeach-s2.m4 +I_M4_DEPS6 = $(I_M4_DEPS) m4/ifunction-s2.m4 EXTRA_DIST = $(m4_files) all: $(BUILT_SOURCES) config.h $(MAKE) $(AM_MAKEFLAGS) all-am @@ -1784,6 +1809,10 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_4_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i2.Plo@am__quote@ @@ -1867,6 +1896,10 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_4_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i2.Plo@am__quote@ @@ -5612,6 +5645,62 @@ minloc2_16_s4.lo: $(srcdir)/generated/minloc2_16_s @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minloc2_16_s4.lo `test -f '$(srcdir)/generated/minloc2_16_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minloc2_16_s4.c +maxval0_s1.lo: $(srcdir)/generated/maxval0_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s1.lo -MD -MP -MF $(DEPDIR)/maxval0_s1.Tpo -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s1.Tpo $(DEPDIR)/maxval0_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s1.c' object='maxval0_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c + +maxval0_s4.lo: $(srcdir)/generated/maxval0_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s4.lo -MD -MP -MF $(DEPDIR)/maxval0_s4.Tpo -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s4.Tpo $(DEPDIR)/maxval0_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s4.c' object='maxval0_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c + +minval0_s1.lo: $(srcdir)/generated/minval0_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s1.lo -MD -MP -MF $(DEPDIR)/minval0_s1.Tpo -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s1.Tpo $(DEPDIR)/minval0_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s1.c' object='minval0_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c + +minval0_s4.lo: $(srcdir)/generated/minval0_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s4.lo -MD -MP -MF $(DEPDIR)/minval0_s4.Tpo -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s4.Tpo $(DEPDIR)/minval0_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s4.c' object='minval0_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c + +maxval1_s1.lo: $(srcdir)/generated/maxval1_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s1.lo -MD -MP -MF $(DEPDIR)/maxval1_s1.Tpo -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s1.Tpo $(DEPDIR)/maxval1_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s1.c' object='maxval1_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c + +maxval1_s4.lo: $(srcdir)/generated/maxval1_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s4.lo -MD -MP -MF $(DEPDIR)/maxval1_s4.Tpo -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s4.Tpo $(DEPDIR)/maxval1_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s4.c' object='maxval1_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c + +minval1_s1.lo: $(srcdir)/generated/minval1_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s1.lo -MD -MP -MF $(DEPDIR)/minval1_s1.Tpo -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s1.Tpo $(DEPDIR)/minval1_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s1.c' object='minval1_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c + +minval1_s4.lo: $(srcdir)/generated/minval1_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s4.lo -MD -MP -MF $(DEPDIR)/minval1_s4.Tpo -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s4.Tpo $(DEPDIR)/minval1_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s4.c' object='minval1_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c + size_from_kind.lo: io/size_from_kind.c @am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT size_from_kind.lo -MD -MP -MF $(DEPDIR)/size_from_kind.Tpo -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo @@ -6507,6 +6596,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran @MAINTAINER_MODE_TRUE@$(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@ +@MAINTAINER_MODE_TRUE@$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@ + +@MAINTAINER_MODE_TRUE@$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@ + @MAINTAINER_MODE_TRUE@$(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@ @@ -6525,6 +6620,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran @MAINTAINER_MODE_TRUE@$(i_minval_c): m4/minval.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@ +@MAINTAINER_MODE_TRUE@$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@ + +@MAINTAINER_MODE_TRUE@$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@ + @MAINTAINER_MODE_TRUE@$(i_product_c): m4/product.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@ Index: libgfortran/generated/maxval0_s1.c =================================================================== --- libgfortran/generated/maxval0_s1.c (nicht existent) +++ libgfortran/generated/maxval0_s1.c (Arbeitskopie) @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 0 + +extern void maxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, gfc_charlen_type); +export_proto(maxval0_s1); + +void +maxval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s1 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_1 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mmaxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mmaxval0_s1); + +void +mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_1 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void smaxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(smaxval0_s1); + +void +smaxval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + maxval0_s1 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif Index: libgfortran/generated/maxval0_s4.c =================================================================== --- libgfortran/generated/maxval0_s4.c (nicht existent) +++ libgfortran/generated/maxval0_s4.c (Arbeitskopie) @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 0 + +extern void maxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, gfc_charlen_type); +export_proto(maxval0_s4); + +void +maxval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s4 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_4 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mmaxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mmaxval0_s4); + +void +mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_4 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void smaxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(smaxval0_s4); + +void +smaxval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + maxval0_s4 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif Index: libgfortran/generated/maxval1_s1.c =================================================================== --- libgfortran/generated/maxval1_s1.c (nicht existent) +++ libgfortran/generated/maxval1_s1.c (Arbeitskopie) @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +#include +#include + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void maxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(maxval1_s1); + +void +maxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + src = base; + { + + const GFC_INTEGER_1 *retval; + retval = base; + if (len <= 0) + memset (dest, 0, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mmaxval1_s1); + +void +mmaxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_1 *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void smaxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(smaxval1_s1); + +void +smaxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval1_s1 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 0, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif Index: libgfortran/generated/maxval1_s4.c =================================================================== --- libgfortran/generated/maxval1_s4.c (nicht existent) +++ libgfortran/generated/maxval1_s4.c (Arbeitskopie) @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#include +#include + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void maxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(maxval1_s4); + +void +maxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + src = base; + { + + const GFC_INTEGER_4 *retval; + retval = base; + if (len <= 0) + memset (dest, 0, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mmaxval1_s4); + +void +mmaxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_4 *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void smaxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(smaxval1_s4); + +void +smaxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval1_s4 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 0, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif Index: libgfortran/generated/minval0_s1.c =================================================================== --- libgfortran/generated/minval0_s1.c (nicht existent) +++ libgfortran/generated/minval0_s1.c (Arbeitskopie) @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 255 + +extern void minval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, gfc_charlen_type); +export_proto(minval0_s1); + +void +minval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s1 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_1 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mminval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mminval0_s1); + +void +mminval0_s1 (GFC_INTEGER_1 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_1 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void sminval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(sminval0_s1); + +void +sminval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + minval0_s1 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif Index: libgfortran/generated/minval0_s4.c =================================================================== --- libgfortran/generated/minval0_s4.c (nicht existent) +++ libgfortran/generated/minval0_s4.c (Arbeitskopie) @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 255 + +extern void minval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, gfc_charlen_type); +export_proto(minval0_s4); + +void +minval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s4 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_4 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mminval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mminval0_s4); + +void +mminval0_s4 (GFC_INTEGER_4 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_4 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void sminval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(sminval0_s4); + +void +sminval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + minval0_s4 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif Index: libgfortran/generated/minval1_s1.c =================================================================== --- libgfortran/generated/minval1_s1.c (nicht existent) +++ libgfortran/generated/minval1_s1.c (Arbeitskopie) @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +#include +#include + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void minval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(minval1_s1); + +void +minval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + src = base; + { + + const GFC_INTEGER_1 *retval; + retval = base; + if (len <= 0) + memset (dest, 255, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mminval1_s1); + +void +mminval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_1 *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void sminval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(sminval1_s1); + +void +sminval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval1_s1 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 255, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif Index: libgfortran/generated/minval1_s4.c =================================================================== --- libgfortran/generated/minval1_s4.c (nicht existent) +++ libgfortran/generated/minval1_s4.c (Arbeitskopie) @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#include +#include + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void minval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(minval1_s4); + +void +minval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + src = base; + { + + const GFC_INTEGER_4 *retval; + retval = base; + if (len <= 0) + memset (dest, 255, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mminval1_s4); + +void +mminval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_4 *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void sminval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(sminval1_s4); + +void +sminval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval1_s4 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 255, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif Index: libgfortran/gfortran.map =================================================================== --- libgfortran/gfortran.map (Revision 255143) +++ libgfortran/gfortran.map (Arbeitskopie) @@ -420,6 +420,10 @@ GFORTRAN_8 { _gfortran_maxloc2_4_s4; _gfortran_maxloc2_8_s1; _gfortran_maxloc2_8_s4; + _gfortran_maxval0_s1; + _gfortran_maxval0_s4; + _gfortran_maxval1_s1; + _gfortran_maxval1_s4; _gfortran_maxval_i16; _gfortran_maxval_i1; _gfortran_maxval_i2; @@ -513,6 +517,10 @@ GFORTRAN_8 { _gfortran_minloc2_4_s4; _gfortran_minloc2_8_s1; _gfortran_minloc2_8_s4; + _gfortran_minval0_s1; + _gfortran_minval0_s4; + _gfortran_minval1_s1; + _gfortran_minval1_s4; _gfortran_minval_i16; _gfortran_minval_i1; _gfortran_minval_i2; @@ -599,6 +607,10 @@ GFORTRAN_8 { _gfortran_mmaxloc2_4_s4; _gfortran_mmaxloc2_8_s1; _gfortran_mmaxloc2_8_s4; + _gfortran_mmaxval0_s1; + _gfortran_mmaxval0_s4; + _gfortran_mmaxval1_s1; + _gfortran_mmaxval1_s4; _gfortran_mmaxval_i16; _gfortran_mmaxval_i1; _gfortran_mmaxval_i2; @@ -680,6 +692,10 @@ GFORTRAN_8 { _gfortran_mminloc2_4_s4; _gfortran_mminloc2_8_s1; _gfortran_mminloc2_8_s4; + _gfortran_mminval0_s1; + _gfortran_mminval0_s4; + _gfortran_mminval1_s1; + _gfortran_mminval1_s4; _gfortran_mminval_i16; _gfortran_mminval_i1; _gfortran_mminval_i2; @@ -927,6 +943,10 @@ GFORTRAN_8 { _gfortran_smaxloc2_4_s4; _gfortran_smaxloc2_8_s1; _gfortran_smaxloc2_8_s4; + _gfortran_smaxval0_s1; + _gfortran_smaxval0_s4; + _gfortran_smaxval1_s1; + _gfortran_smaxval1_s4; _gfortran_smaxval_i16; _gfortran_smaxval_i1; _gfortran_smaxval_i2; @@ -1008,6 +1028,10 @@ GFORTRAN_8 { _gfortran_sminloc2_4_s4; _gfortran_sminloc2_8_s1; _gfortran_sminloc2_8_s4; + _gfortran_sminval0_s1; + _gfortran_sminval0_s4; + _gfortran_sminval1_s1; + _gfortran_sminval1_s4; _gfortran_sminval_i16; _gfortran_sminval_i1; _gfortran_sminval_i2; Index: libgfortran/m4/iforeach-s2.m4 =================================================================== --- libgfortran/m4/iforeach-s2.m4 (nicht existent) +++ libgfortran/m4/iforeach-s2.m4 (Arbeitskopie) @@ -0,0 +1,222 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +define(START_FOREACH_FUNCTION, +`static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 'initval` + +extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret, + gfc_charlen_type xlen, + 'atype` * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const 'atype_name` *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { +')dnl +define(START_FOREACH_BLOCK, +` while (base) + { + do + { + /* Implementation start. */ +')dnl +define(FINISH_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(START_MASKED_FOREACH_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const atype_name *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { +')dnl +define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl +define(FINISH_MASKED_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(FOREACH_FUNCTION, +`START_FOREACH_FUNCTION +$1 +START_FOREACH_BLOCK +$2 +FINISH_FOREACH_FUNCTION')dnl +define(MASKED_FOREACH_FUNCTION, +`START_MASKED_FOREACH_FUNCTION +$1 +START_MASKED_FOREACH_BLOCK +$2 +FINISH_MASKED_FOREACH_FUNCTION')dnl +define(SCALAR_FOREACH_FUNCTION, +` +extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + name`'rtype_qual`_'atype_code (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +}')dnl Index: libgfortran/m4/ifunction-s2.m4 =================================================================== --- libgfortran/m4/ifunction-s2.m4 (nicht existent) +++ libgfortran/m4/ifunction-s2.m4 (Arbeitskopie) @@ -0,0 +1,542 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +dnl +dnl Pass the implementation for a single section as the parameter to +dnl {MASK_}ARRAY_FUNCTION. +dnl The variables base, delta, and len describe the input section. +dnl For masked section the mask is described by mbase and mdelta. +dnl These should not be modified. The result should be stored in *dest. +dnl The names count, extent, sstride, dstride, base, dest, rank, dim +dnl retarray, array, pdim and mstride should not be used. +dnl The variable n is declared as index_type and may be used. +dnl Other variable declarations may be placed at the start of the code, +dnl The types of the array parameter and the return value are +dnl atype_name and rtype_name respectively. +dnl Execution should be allowed to continue to the end of the block. +dnl You should not return or break from the inner loop of the implementation. +dnl Care should also be taken to avoid using the names defined in iparm.m4 +define(START_ARRAY_FUNCTION, +`#include +#include + +static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const atype_name * restrict base; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const atype_name * restrict src; + src = base; + { +')dnl +define(START_ARRAY_BLOCK, +` if (len <= 0) + memset (dest, '$1`, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { +')dnl +define(FINISH_ARRAY_FUNCTION, +` } + '$1` + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(START_MASKED_ARRAY_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + const atype_name * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in u_name intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "u_name"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const atype_name * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { +')dnl +define(START_MASKED_ARRAY_BLOCK, +` for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { +')dnl +define(FINISH_MASKED_ARRAY_FUNCTION, +` } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(SCALAR_ARRAY_FUNCTION, +` +void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, '$1`, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +}')dnl +define(ARRAY_FUNCTION, +`START_ARRAY_FUNCTION($1) +$2 +START_ARRAY_BLOCK($1) +$3 +FINISH_ARRAY_FUNCTION($4)')dnl +define(MASKED_ARRAY_FUNCTION, +`START_MASKED_ARRAY_FUNCTION +$2 +START_MASKED_ARRAY_BLOCK +$3 +FINISH_MASKED_ARRAY_FUNCTION')dnl Index: libgfortran/m4/iparm.m4 =================================================================== --- libgfortran/m4/iparm.m4 (Revision 255143) +++ libgfortran/m4/iparm.m4 (Arbeitskopie) @@ -35,3 +35,4 @@ define(name, regexp(regexp(file, `[^/]*$', `\&'), define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl +define(initval,ifelse(index(name,`maxval'),0,0,index(name,`minval'),0,255))dnl Index: libgfortran/m4/maxval0s.m4 =================================================================== --- libgfortran/m4/maxval0s.m4 (nicht existent) +++ libgfortran/m4/maxval0s.m4 (Arbeitskopie) @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include ' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif Index: libgfortran/m4/maxval1s.m4 =================================================================== --- libgfortran/m4/maxval1s.m4 (nicht existent) +++ libgfortran/m4/maxval1s.m4 (Arbeitskopie) @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(0, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(0, +` const atype_name *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(0) + +#endif Index: libgfortran/m4/minval0s.m4 =================================================================== --- libgfortran/m4/minval0s.m4 (nicht existent) +++ libgfortran/m4/minval0s.m4 (Arbeitskopie) @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include +#include ' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif Index: libgfortran/m4/minval1s.m4 =================================================================== --- libgfortran/m4/minval1s.m4 (nicht existent) +++ libgfortran/m4/minval1s.m4 (Arbeitskopie) @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(255, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(255, +` const atype_name *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(255) + +#endif