[gfortran] Add malloc and free intrinsics

[François-Xavier Coudert <fxcoudert at gmail dot com>]

Now that gfortran will support Cray pointers, a useful addition is the
non-standard MALLOC and FREE intrinsics. They're used on many
scientific codes to perform dynamic memory allocation.

Attached patch (independent of the Cray pointers patch, although in
real life both are used together; I will provide specific testcases
for their interrelation once the CP patch is in) adds these two
intrinsics: front-end, library, doc and a testcase.

I would really welcome comments on the doc part, since I am not a
native english speaker, and I was not too confident with what should
be said. Thanks in advance.

This was built and tested on i686-linux. OK for mainline?

Index: gcc/fortran/check.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.34
diff -u -3 -p -p -u -r1.34 check.c
--- gcc/fortran/check.c	17 Sep 2005 18:57:59 -0000	1.34
+++ gcc/fortran/check.c	26 Sep 2005 13:03:57 -0000
@@ -1339,6 +1339,18 @@ gfc_check_min_max_double (gfc_actual_arg
 
 /* End of min/max family.  */
 
+try
+gfc_check_malloc (gfc_expr * size)
+{
+  if (type_check (size, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (size, 0) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
 
 try
 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
@@ -2541,6 +2553,19 @@ gfc_check_flush (gfc_expr * unit)
     return FAILURE;
 
   if (scalar_check (unit, 0) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
+gfc_check_free (gfc_expr * i)
+{
+  if (type_check (i, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (i, 0) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.87
diff -u -3 -p -p -u -r1.87 gfortran.h
--- gcc/fortran/gfortran.h	17 Sep 2005 18:57:59 -0000	1.87
+++ gcc/fortran/gfortran.h	26 Sep 2005 13:03:57 -0000
@@ -353,6 +353,7 @@ enum gfc_generic_isym_id
   GFC_ISYM_LOG,
   GFC_ISYM_LOG10,
   GFC_ISYM_LOGICAL,
+  GFC_ISYM_MALLOC,
   GFC_ISYM_MATMUL,
   GFC_ISYM_MAX,
   GFC_ISYM_MAXLOC,
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.55
diff -u -3 -p -p -u -r1.55 intrinsic.c
--- gcc/fortran/intrinsic.c	22 Sep 2005 19:00:22 -0000	1.55
+++ gcc/fortran/intrinsic.c	26 Sep 2005 13:03:57 -0000
@@ -1605,6 +1605,11 @@ add_functions (void)
 
   make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
 
+  add_sym_1 ("malloc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_malloc,
+	     NULL, gfc_resolve_malloc, a, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
+
   add_sym_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_matmul, NULL, gfc_resolve_matmul,
 	     ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
@@ -2116,12 +2121,13 @@ add_subroutines (void)
     *val = "value", *num = "number", *name = "name",
     *trim_name = "trim_name", *ut = "unit";
 
-  int di, dr, dc, dl;
+  int di, dr, dc, dl, ii;
 
   di = gfc_default_integer_kind;
   dr = gfc_default_real_kind;
   dc = gfc_default_character_kind;
   dl = gfc_default_logical_kind;
+  ii = gfc_index_integer_kind;
 
   add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
 
@@ -2223,6 +2229,9 @@ add_subroutines (void)
   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_flush, NULL, gfc_resolve_flush,
 	      c, BT_INTEGER, di, OPTIONAL);
+
+  add_sym_1s ("free", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
+	      NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
 
   add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
           gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.33
diff -u -3 -p -p -u -r1.33 intrinsic.h
--- gcc/fortran/intrinsic.h	22 Sep 2005 19:00:23 -0000	1.33
+++ gcc/fortran/intrinsic.h	26 Sep 2005 13:03:57 -0000
@@ -82,6 +82,7 @@ try gfc_check_min_max (gfc_actual_arglis
 try gfc_check_min_max_integer (gfc_actual_arglist *);
 try gfc_check_min_max_real (gfc_actual_arglist *);
 try gfc_check_min_max_double (gfc_actual_arglist *);
+try gfc_check_malloc (gfc_expr *);
 try gfc_check_matmul (gfc_expr *, gfc_expr *);
 try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_minloc_maxloc (gfc_actual_arglist *);
@@ -131,6 +132,7 @@ try gfc_check_system_clock (gfc_expr *, 
 try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_exit (gfc_expr *);
 try gfc_check_flush (gfc_expr *);
+try gfc_check_free (gfc_expr *);
 try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_gerror (gfc_expr *);
 try gfc_check_getlog (gfc_expr *);
@@ -330,6 +332,7 @@ void gfc_resolve_link (gfc_expr *, gfc_e
 void gfc_resolve_log (gfc_expr *, gfc_expr *);
 void gfc_resolve_log10 (gfc_expr *, gfc_expr *);
 void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_malloc (gfc_expr *, gfc_expr *);
 void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *);
 void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
@@ -387,6 +390,7 @@ void gfc_resolve_chdir_sub (gfc_code *);
 void gfc_resolve_cpu_time (gfc_code *);
 void gfc_resolve_exit (gfc_code *);
 void gfc_resolve_flush (gfc_code *);
+void gfc_resolve_free (gfc_code *);
 void gfc_resolve_fstat_sub (gfc_code *);
 void gfc_resolve_gerror (gfc_code *);
 void gfc_resolve_getarg (gfc_code *);
Index: gcc/fortran/intrinsic.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.texi,v
retrieving revision 1.17
diff -u -3 -p -p -u -r1.17 intrinsic.texi
--- gcc/fortran/intrinsic.texi	22 Sep 2005 19:00:23 -0000	1.17
+++ gcc/fortran/intrinsic.texi	26 Sep 2005 13:03:57 -0000
@@ -85,10 +85,12 @@ and editing.  All contributions and corr
 * @code{EXIT}:          EXIT,      Exit the program with status.
 * @code{EXP}:           EXP,       Exponential function
 * @code{EXPONENT}:      EXPONENT,  Exponent function
+* @code{FREE}:          FREE,      Memory freeing subroutine
 * @code{FLOOR}:         FLOOR,     Integer floor function
 * @code{FNUM}:          FNUM,      File number function
 * @code{LOG}:           LOG,       Logarithm function
 * @code{LOG10}:         LOG10,     Base 10 logarithm function 
+* @code{MALLOC}:        MALLOC,    Dynamic memory allocation function
 * @code{REAL}:          REAL,      Convert to real type 
 * @code{SQRT}:          SQRT,      Square-root function
 * @code{SIN}:           SIN,       Sine function
@@ -2644,6 +2646,36 @@ end program test_exponent
 @end table
 
 
+@node FREE
+@section @code{FREE} --- Frees memory
+@findex @code{FREE} intrinsic
+@cindex FREE
+
+@table @asis
+@item @emph{Description}:
+Frees memory previously allocated by @code{MALLOC()}.
+
+@item @emph{Option}:
+gnu
+
+@item @emph{Class}:
+subroutine
+
+@item @emph{Syntax}:
+@code{FREE(PTR)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{PTR} @tab The type shall be @code{INTEGER} with intent in.
+@end multitable
+
+@item @emph{Return value}:
+None
+
+@item @emph{Example}:
+See @code{MALLOC} for an example.
+@end table
+
 
 @node FLOOR
 @section @code{FLOOR} --- Integer floor function
@@ -2826,6 +2858,52 @@ end program test_log10
 @item @code{ALOG10(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab f95, gnu
 @item @code{DLOG10(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab f95, gnu
 @end multitable
+@end table
+
+
+@node MALLOC
+@section @code{MALLOC} --- Allocate dynamic memory
+@findex @code{MALLOC} intrinsic
+@cindex MALLOC
+
+@table @asis
+@item @emph{Description}:
+@code{MALLOC(SIZE)} allocates @var{SIZE} bytes of dynamic memory and
+returns the address of the allocated memory.
+
+@item @emph{Option}:
+gnu
+
+@item @emph{Class}:
+non-elemental function
+
+@item @emph{Syntax}:
+@code{PTR = MALLOC(SIZE)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{SIZE} @tab The type shall be @code{INTEGER(*)}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER(K)}, with @var{K} such that
+@code{INTEGER(K)} has the same size as C pointers (@code{sizeof(void *)}).
+
+@item @emph{Example}:
+@smallexample
+program test_malloc
+  integer i
+  integer ptr_x
+  real*8 x(*)
+  pointer(ptr_x,x)
+
+  ptr_x = malloc(20*8)
+  do i = 1, n
+    x(i) = sqrt(1.0d0 / i)
+  end do
+  call free(ptr_x)
+end program test_malloc
+@end smallexample
 @end table
 
 
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.40
diff -u -3 -p -p -u -r1.40 iresolve.c
--- gcc/fortran/iresolve.c	22 Sep 2005 19:00:23 -0000	1.40
+++ gcc/fortran/iresolve.c	26 Sep 2005 13:03:58 -0000
@@ -871,6 +871,24 @@ gfc_resolve_logical (gfc_expr * f, gfc_e
 
 
 void
+gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
+{
+  if (size->ts.kind < gfc_default_integer_kind)
+    {
+      gfc_typespec ts;
+
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_default_integer_kind;
+      gfc_convert_type_warn (size, &ts, 2, 0);
+    }
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+  f->value.function.name = gfc_get_string (PREFIX("malloc_i%d"), size->ts.kind);
+}
+
+
+void
 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 {
   gfc_expr temp;
@@ -1938,6 +1956,22 @@ gfc_resolve_flush (gfc_code * c)
 
   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_free (gfc_code * c)
+{
+  gfc_typespec ts;
+  gfc_expr *n;
+
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_index_integer_kind;
+  n = c->ext.actual->expr;
+  if (n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
 }
 
 
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.54
diff -u -3 -p -p -u -r1.54 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c	13 Sep 2005 08:07:15 -0000	1.54
+++ gcc/fortran/trans-intrinsic.c	26 Sep 2005 13:03:58 -0000
@@ -2997,6 +2997,7 @@ gfc_conv_intrinsic_function (gfc_se * se
     case GFC_ISYM_IRAND:
     case GFC_ISYM_ISATTY:
     case GFC_ISYM_LINK:
+    case GFC_ISYM_MALLOC:
     case GFC_ISYM_MATMUL:
     case GFC_ISYM_RAND:
     case GFC_ISYM_RENAME:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.42
diff -u -3 -p -p -u -r1.42 Makefile.am
--- libgfortran/Makefile.am	25 Sep 2005 21:39:55 -0000	1.42
+++ libgfortran/Makefile.am	26 Sep 2005 13:03:58 -0000
@@ -65,6 +65,7 @@ intrinsics/kill.c \
 intrinsics/ierrno.c \
 intrinsics/ishftc.c \
 intrinsics/link.c \
+intrinsics/malloc.c \
 intrinsics/mvbits.c \
 intrinsics/pack_generic.c \
 intrinsics/perror.c \
Index: libgfortran/intrinsics/malloc.c
===================================================================
RCS file: libgfortran/intrinsics/malloc.c
diff -N libgfortran/intrinsics/malloc.c
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ libgfortran/intrinsics/malloc.c	2005-09-26 14:23:13.000000000 +0200
@@ -0,0 +1,65 @@
+/* Implementation of the MALLOC and FREE intrinsics
+   Copyright (C) 2005 Free Software Foundation, Inc.
+   Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
+
+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 General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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.
+
+You should have received a copy of the GNU General Public
+License along with libgfortran; see the file COPYING.  If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+extern void PREFIX(free) (void **);
+export_proto_np(PREFIX(free));
+
+void
+PREFIX(free) (void ** ptr)
+{
+  free (*ptr);
+}
+
+
+extern void * malloc_i4 (GFC_INTEGER_4 *);
+export_proto(malloc_i4);
+
+void *
+malloc_i4 (GFC_INTEGER_4 * size)
+{
+  return malloc (*size);
+}
+
+
+extern void * malloc_i8 (GFC_INTEGER_8 *);
+export_proto(malloc_i8);
+
+void *
+malloc_i8 (GFC_INTEGER_8 * size)
+{
+  return malloc (*size);
+}

Attachment: malloc.ChangeLog
Description: Binary data

Attachment: malloc_free_1.f90
Description: Binary data