Re: [gfortran] Fix PR17631: intrinsic MVBITS missing

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

I updated the patch, implementing your suggestions. Appended below, the new
file is attached. I did some preprocessor magic to implement variants for the
different integer kinds.

- Tobi

2004-09-24  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/17631
fortran/
	* intrinsic.c (add_sym_5): Remove.
	(add_subroutines): Add resolution function for MVBITS.
	* intrinsic.h (gfc_resolve_mvbits): Declare resolution function for
	MVBITS
	* iresolve.c (gfc_resolve_mvbits): New function.
	(gfc_resolve_random_number): Remove empty line at end of function.
libgfortran/
	* Makefile.am (gfor_helper_src): Add intrinsics/mvbits.h.
	* intrinsics/mvbits.h: New file.


Index: intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.23
diff -u -p -r1.23 intrinsic.c
--- intrinsic.c 16 Sep 2004 16:00:42 -0000      1.23
+++ intrinsic.c 24 Sep 2004 11:29:30 -0000
@@ -600,35 +600,6 @@ static void add_sym_4s (const char *name
 }


-static void add_sym_5 (const char *name, int elemental, int actual_ok, bt type,
-                      int kind,
-                      try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr
*,gfc_expr *),
-                      gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr
*,gfc_expr *,gfc_expr *),
-                      void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr
*,gfc_expr *,gfc_expr *,gfc_expr *),
-                      const char* a1, bt type1, int kind1, int optional1,
-                      const char* a2, bt type2, int kind2, int optional2,
-                      const char* a3, bt type3, int kind3, int optional3,
-                      const char* a4, bt type4, int kind4, int optional4,
-                      const char* a5, bt type5, int kind5, int optional5
-                      ) {
-  gfc_check_f cf;
-  gfc_simplify_f sf;
-  gfc_resolve_f rf;
-
-  cf.f5 = check;
-  sf.f5 = simplify;
-  rf.f5 = resolve;
-
-  add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
-          a1, type1, kind1, optional1,
-          a2, type2, kind2, optional2,
-          a3, type3, kind3, optional3,
-          a4, type4, kind4, optional4,
-          a5, type5, kind5, optional5,
-          (void*)0);
-}
-
-
 static void add_sym_5s
 (
  const char *name, int elemental, int actual_ok, bt type, int kind,
@@ -1960,12 +1931,11 @@ add_subroutines (void)
             trim_name, BT_LOGICAL, dl, 1);


-  /* This needs changing to add_sym_5s if it gets a resolution function.  */
-  add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0,
-            gfc_check_mvbits, gfc_simplify_mvbits, NULL,
-            f, BT_INTEGER, di, 0, fp, BT_INTEGER, di, 0,
-            ln, BT_INTEGER, di, 0, t, BT_INTEGER, di, 0,
-            tp, BT_INTEGER, di, 0);
+  add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0,
+             gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
+             f, BT_INTEGER, di, 0, fp, BT_INTEGER, di, 0,
+             ln, BT_INTEGER, di, 0, t, BT_INTEGER, di, 0,
+             tp, BT_INTEGER, di, 0);

   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0,
              gfc_check_random_number, NULL, gfc_resolve_random_number,
Index: intrinsic.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.15
diff -u -p -r1.15 intrinsic.h
--- intrinsic.h 15 Sep 2004 14:09:07 -0000      1.15
+++ intrinsic.h 24 Sep 2004 11:29:30 -0000
@@ -323,6 +323,7 @@ void gfc_resolve_verify (gfc_expr *, gfc

 /* Intrinsic subroutine resolution.  */
 void gfc_resolve_cpu_time (gfc_code *);
+void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_system_clock(gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
 void gfc_resolve_getarg (gfc_code *);
Index: iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.16
diff -u -p -r1.16 iresolve.c
--- iresolve.c  15 Sep 2004 14:09:07 -0000      1.16
+++ iresolve.c  24 Sep 2004 11:29:30 -0000
@@ -1444,6 +1444,19 @@ gfc_resolve_cpu_time (gfc_code * c ATTRI


 void
+gfc_resolve_mvbits (gfc_code * c)
+{
+  const char *name;
+  int kind;
+
+  kind = c->ext.actual->expr->ts.kind;
+  name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
 {
   const char *name;
@@ -1456,7 +1469,6 @@ gfc_resolve_random_number (gfc_code * c
     name = gfc_get_string (PREFIX("arandom_r%d"), kind);

   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
-
 }


Index: Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.18
diff -u -r1.18 Makefile.am
--- Makefile.am 15 Sep 2004 14:09:12 -0000      1.18
+++ Makefile.am 24 Sep 2004 11:30:42 -0000
@@ -52,6 +52,7 @@
 intrinsics/getcwd.c \
 intrinsics/getXid.c \
 intrinsics/ishftc.c \
+intrinsics/mvbits.c \
 intrinsics/pack_generic.c \
 intrinsics/size.c \
 intrinsics/spread_generic.c \

/* Implementation of the MVBITS intrinsic
   Copyright (C) 2004 Free Software Foundation, Inc.
   Contributed by Tobias Schlüter

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 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 Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with libgfortran; see the file COPYING.LIB.  If not,
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* TODO: This should be replaced by a compiler builtin.  */

#ifndef SUB_NAME
#include <libgfortran.h>
#endif

#ifdef SUB_NAME
/* MVBITS copies LEN bits starting at bit position FROMPOS from FROM
   into TO, starting at bit position TOPOS.  */

void 
SUB_NAME (const TYPE *from, const GFC_INTEGER_4 *frompos,
	  const GFC_INTEGER_4 *len, TYPE *to, const GFC_INTEGER_4 *topos)
{
  TYPE oldbits, newbits, lenmask;

  lenmask = (*len == sizeof (TYPE)*8) ? ~(TYPE)0 : (1 << *len) - 1;
  newbits = (((UTYPE)(*from) >> *frompos) & lenmask) << *topos;
  oldbits = *to & (~(lenmask << *topos));

  *to = newbits | oldbits;
}
#endif

#ifndef SUB_NAME
#  define TYPE GFC_INTEGER_4
#  define UTYPE GFC_UINTEGER_4
#  define SUB_NAME prefix (mvbits_i4)
#  include "mvbits.c"
#  undef SUB_NAME
#  undef TYPE
#  undef UTYPE

#  define TYPE GFC_INTEGER_8
#  define UTYPE GFC_UINTEGER_8
#  define SUB_NAME prefix (mvbits_i8)
#  include "mvbits.c"
#  undef SUB_NAME
#  undef TYPE
#  undef UTYPE
#endif