New foreign object facility, to replace SMOBs

* libguile/foreign-object.c:
* libguile/foreign-object.h:
* module/system/foreign-object.scm:
* test-suite/standalone/test-foreign-object-c.c:
* test-suite/standalone/test-foreign-object-scm: New files.

* test-suite/standalone/Makefile.am:
* module/Makefile.am:
* libguile/Makefile.am: Add new files.

* libguile.h: Add foreign-object.h.
* libguile/init.c (scm_i_init_guile): Call scm_register_foreign_object.

libguile.h

@@ -1,7 +1,7 @@
 #ifndef SCM_LIBGUILE_H
 #define SCM_LIBGUILE_H
 
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -52,6 +52,7 @@ extern "C" {
 #include "libguile/finalizers.h"
 #include "libguile/fluids.h"
 #include "libguile/foreign.h"
+#include "libguile/foreign-object.h"
 #include "libguile/fports.h"
 #include "libguile/gc.h"
 #include "libguile/gdbint.h"

libguile/Makefile.am

@@ -147,6 +147,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =				\
 	finalizers.c				\
 	fluids.c				\
 	foreign.c				\
+	foreign-object.c			\
 	fports.c				\
 	frames.c				\
 	gc-malloc.c				\
@@ -573,6 +574,7 @@ modinclude_HEADERS =				\
 	filesys.h				\
 	fluids.h				\
 	foreign.h				\
+	foreign-object.h			\
 	fports.h				\
 	frames.h				\
 	gc.h					\

libguile/foreign-object.c

@@ -0,0 +1,187 @@
+/* Copyright (C) 2014 Free Software Foundation, Inc.
+ *
+ * This library 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 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/goops.h"
+#include "libguile/foreign-object.h"
+
+
+
+
+static SCM make_fobj_type_var;
+
+static void
+init_make_fobj_type_var (void)
+{
+  make_fobj_type_var = scm_c_private_lookup ("system foreign-object",
+                                             "make-foreign-object-type");
+}
+
+SCM
+scm_make_foreign_object_type (SCM name, SCM slot_names,
+                              scm_t_struct_finalize finalizer)
+{
+  SCM type;
+
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_make_fobj_type_var);
+
+  type = scm_call_2 (scm_variable_ref (make_fobj_type_var), name, slot_names);
+
+  if (finalizer)
+    SCM_SET_VTABLE_INSTANCE_FINALIZER (type, finalizer);
+
+  return type;
+}
+
+void
+scm_assert_foreign_object_type (SCM type, SCM val)
+{
+  if (!SCM_IS_A_P (val, type))
+    scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
+               scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
+}
+
+SCM
+scm_make_foreign_object_1 (SCM type, scm_t_bits val0)
+{
+  return scm_make_foreign_object_n (type, 1, &val0);
+}
+
+SCM
+scm_make_foreign_object_2 (SCM type, scm_t_bits val0, scm_t_bits val1)
+{
+  scm_t_bits vals[2] = { val0, val1 };
+
+  return scm_make_foreign_object_n (type, 2, vals);
+}
+
+SCM
+scm_make_foreign_object_3 (SCM type, scm_t_bits val0, scm_t_bits val1,
+                           scm_t_bits val2)
+{
+  scm_t_bits vals[3] = { val0, val1, val2 };
+
+  return scm_make_foreign_object_n (type, 3, vals);
+}
+
+SCM
+scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[])
+#define FUNC_NAME "make-foreign-object"
+{
+  SCM obj;
+  SCM layout;
+  size_t i;
+
+  SCM_VALIDATE_VTABLE (SCM_ARG1, type);
+
+  layout = SCM_VTABLE_LAYOUT (type);
+
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  for (i = 0; i < n; i++)
+    if (scm_i_symbol_ref (layout, i * 2) != 'u')
+      scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  obj = scm_c_make_structv (type, 0, 0, NULL);
+
+  for (i = 0; i < n; i++)
+    SCM_STRUCT_DATA_SET (obj, i, vals[i]);
+
+  return obj;
+}
+#undef FUNC_NAME
+
+scm_t_bits
+scm_foreign_object_ref (SCM obj, size_t n)
+#define FUNC_NAME "foreign-object-ref"
+{
+  SCM layout;
+
+  SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+  
+  layout = SCM_STRUCT_LAYOUT (obj);
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  if (scm_i_symbol_ref (layout, n * 2) != 'u')
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  return SCM_STRUCT_DATA_REF (obj, n);
+}
+#undef FUNC_NAME
+
+void
+scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val)
+#define FUNC_NAME "foreign-object-set!"
+{
+  SCM layout;
+
+  SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+  
+  layout = SCM_STRUCT_LAYOUT (obj);
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  if (scm_i_symbol_ref (layout, n * 2) != 'u')
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  SCM_STRUCT_DATA_SET (obj, n, val);
+}
+#undef FUNC_NAME
+  
+static void
+invoke_finalizer (void *obj, void *data)
+{
+  scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
+}
+
+static SCM
+sys_add_finalizer_x (SCM obj, SCM finalizer)
+#define FUNC_NAME "%add-finalizer!"
+{
+  SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
+
+  scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+scm_init_foreign_object (void)
+{
+  scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
+                      (scm_t_subr) sys_add_finalizer_x);
+}
+
+void
+scm_register_foreign_object (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_foreign_object",
+                            (scm_t_extension_init_func)scm_init_foreign_object,
+                            NULL);
+}

libguile/foreign-object.h

@@ -0,0 +1,48 @@
+#ifndef SCM_FOREIGN_OBJECT_H
+#define SCM_FOREIGN_OBJECT_H
+
+/* Copyright (C) 2014 Free Software Foundation, Inc.
+ *
+ * This library 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 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+
+
+
+SCM_API SCM scm_make_foreign_object_type (SCM name, SCM slot_names,
+                                          scm_t_struct_finalize finalizer);
+
+SCM_API void scm_assert_foreign_object_type (SCM type, SCM val);
+
+SCM_API SCM scm_make_foreign_object_1 (SCM type, scm_t_bits val0);
+SCM_API SCM scm_make_foreign_object_2 (SCM type, scm_t_bits val0,
+                                        scm_t_bits val1);
+SCM_API SCM scm_make_foreign_object_3 (SCM type, scm_t_bits val0,
+                                        scm_t_bits val1, scm_t_bits val2);
+SCM_API SCM scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[]);
+
+SCM_API scm_t_bits scm_foreign_object_ref (SCM obj, size_t n);
+SCM_API void scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val);
+
+SCM_INTERNAL void scm_register_foreign_object (void);
+
+
+#endif  /* SCM_FOREIGN_OBJECT_H */

libguile/init.c

@@ -397,6 +397,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_vm ();
   scm_register_r6rs_ports ();
   scm_register_foreign ();
+  scm_register_foreign_object ();
   scm_register_srfi_1 ();
   scm_register_srfi_60 ();
   scm_register_poll ();

module/Makefile.am

@@ -361,6 +361,7 @@ SYSTEM_SOURCES =				\
   system/vm/trap-state.scm			\
   system/vm/vm.scm				\
   system/foreign.scm				\
+  system/foreign-object.scm			\
   system/xref.scm				\
   system/repl/debug.scm				\
   system/repl/error-handling.scm		\

module/system/foreign-object.scm

@@ -0,0 +1,88 @@
+;;; Wrapping foreign objects in Scheme
+
+;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; 
+;;; This library 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 3 of the License, or (at your option) any later version.
+;;; 
+;;; This library 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 this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;; 
+
+;;; Commentary:
+;;
+;;
+;;; Code:
+
+(define-module (system foreign-object)
+  #:use-module (oop goops)
+  #:export     (make-foreign-object-type
+                define-foreign-object-type))
+
+(eval-when (eval load expand)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_foreign_object"))
+
+(define-class <finalizer-class> (<class>)
+  (finalizer #:init-keyword #:finalizer #:init-value #f
+             #:getter finalizer))
+
+(define-method (allocate-instance (class <finalizer-class>) initargs)
+  (let ((instance (next-method))
+        (finalizer (finalizer class)))
+    (when finalizer
+      (%add-finalizer! instance finalizer))
+    instance))
+
+(define (getter-method class slot-name existing)
+  (let ((getter (ensure-generic existing slot-name))
+        (slot-def (or (assq slot-name (slot-ref class 'getters-n-setters))
+                      (slot-missing class slot-name))))
+    (add-method! getter (compute-getter-method class slot-def))
+    getter))
+
+(define* (make-foreign-object-type name slots #:key finalizer)
+  (unless (symbol? name)
+    (error "type name should be a symbol" name))
+  (unless (or (not finalizer) (procedure? finalizer))
+    (error "finalizer should be a procedure" finalizer))
+  (let ((dslots (map (lambda (slot)
+                       (unless (symbol? slot)
+                         (error "slot name should be a symbol" slot))
+                       (list slot #:class <foreign-slot>
+                             #:init-keyword (symbol->keyword slot)
+                             #:init-value 0))
+                   slots)))
+    (if finalizer
+        (make-class '() dslots #:name name
+                    #:finalizer finalizer #:metaclass <finalizer-class>)
+        (make-class '() dslots #:name name))))
+
+(define-syntax define-foreign-object-type
+  (lambda (x)
+    (define (kw-apply slots)
+      (syntax-case slots ()
+        (() #'())
+        ((slot . slots)
+         (let ((kw (symbol->keyword (syntax->datum #'slot))))
+           #`(#,kw slot . #,(kw-apply #'slots))))))
+
+    (syntax-case x ()
+      ((_ name constructor (slot ...) kwarg ...)
+       #`(begin
+           (define name
+             (make-foreign-object-type 'name '(slot ...) kwarg ...))
+           (define slot
+             (getter-method name 'slot (and (defined? 'slot) slot)))
+           ...
+           (define constructor
+             (lambda (slot ...)
+               (make name #,@(kw-apply #'(slot ...))))))))))

test-suite/standalone/Makefile.am

@@ -129,6 +129,17 @@ TESTS += test-ffi
 
 endif HAVE_SHARED_LIBRARIES
 
+# test-foreign-object-scm
+check_SCRIPTS += test-foreign-object-scm
+TESTS += test-foreign-object-scm
+
+# test-foreign-object-c
+test_foreign_object_c_SOURCES = test-foreign-object-c.c
+test_foreign_object_c_CFLAGS = ${test_cflags}
+test_foreign_object_c_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-foreign-object-c
+TESTS += test-foreign-object-c
+
 # test-list
 test_list_SOURCES = test-list.c
 test_list_CFLAGS = ${test_cflags}

test-suite/standalone/test-foreign-object-c.c

@@ -0,0 +1,116 @@
+/* test-foreign-object-c.c - exercise C foreign object interface */
+
+/* Copyright (C) 2014 Free Software Foundation, Inc.
+ *
+ * This library 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 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+enum
+  {
+    CSTR_SLOT_ADDR,
+    CSTR_SLOT_LEN,
+    CSTR_SLOT_COUNT
+  };
+
+static void
+finalizer (SCM obj)
+{
+  scm_t_bits addr = scm_foreign_object_ref (obj, CSTR_SLOT_ADDR);
+  free ((void *) addr);
+}
+
+static SCM
+make_cstr_from_static (SCM type, const char *str)
+{
+  char *ours = strdup (str);
+
+  if (!ours)
+    abort ();
+
+  return scm_make_foreign_object_2 (type, (scm_t_bits) ours, strlen (ours));
+}
+
+static int
+cstr_equals_static_p (SCM cstr, const char *str)
+{
+  const char *addr;
+  size_t len;
+
+  addr = (const char *) scm_foreign_object_ref (cstr, CSTR_SLOT_ADDR);
+  len = scm_foreign_object_ref (cstr, CSTR_SLOT_LEN);
+
+  if (strlen (str) != len)
+    return 0;
+
+  return strncmp (addr, str, len) == 0;
+}
+
+static void
+test_scm_foreign_object (void)
+{
+  SCM type_name, slot_names, type, cstr;
+
+  type_name = scm_from_utf8_symbol ("<cstr>");
+  slot_names = scm_list_2 (scm_from_utf8_symbol ("addr"),
+                           scm_from_utf8_symbol ("len"));
+  type = scm_make_foreign_object_type (type_name, slot_names, finalizer);
+
+  cstr = make_cstr_from_static (type, "Hello, world!");
+  scm_assert_foreign_object_type (type, cstr);
+
+  if (!cstr_equals_static_p (cstr, "Hello, world!"))
+    {
+      fprintf (stderr, "fail: test-foreign-object 1\n");
+      exit (EXIT_FAILURE);
+    }
+
+  {
+    int i;
+    for (i = 0; i < 5000; i++)
+      cstr = make_cstr_from_static (type, "Hello, world!");
+    cstr = SCM_BOOL_F;
+  }
+
+  scm_gc ();
+  scm_gc ();
+  scm_gc ();
+
+  /* Allow time for the finalizer thread to run.  */
+  scm_usleep (scm_from_uint (50 * 1000));
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+  test_scm_foreign_object ();
+}
+
+int
+main (int argc, char *argv[])
+{
+  scm_boot_guile (argc, argv, tests, NULL);
+  return 0;
+}

test-suite/standalone/test-foreign-object-scm

@@ -0,0 +1,119 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+;;; test-foreign-object-scm --- Foreign object interface.     -*- Scheme -*-
+;;;
+;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;
+;;; This library 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 3 of the License, or (at your option) any later version.
+;;;
+;;; This library 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 this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(use-modules (system foreign)
+             (system foreign-object)
+             (rnrs bytevectors)
+             (oop goops))
+
+(define (libc-ptr name)
+  (catch #t
+    (lambda () (dynamic-pointer name (dynamic-link)))
+    (lambda (k . args)
+      (print-exception (current-error-port) #f k args)
+      (write "Skipping test.\n" (current-error-port))
+      (exit 0))))
+
+(define malloc (pointer->procedure '* (libc-ptr "malloc") (list size_t)))
+(define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '* size_t)))
+(define free (pointer->procedure void (libc-ptr "free") '(*)))
+
+(define (finalize-cstr cstr)
+  (free (make-pointer (addr cstr))))
+
+(define-foreign-object-type <cstr> make-cstr (addr len)
+  #:finalizer finalize-cstr)
+
+(define (cstr->string cstr)
+  (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8"))
+
+(define* (string->cstr str #:optional (k make-cstr))
+  (let* ((bv (string->utf8 str))
+         (len (bytevector-length bv))
+         (mem (malloc len)))
+    (when (null-pointer? mem)
+      (error "Out of memory."))
+    (memcpy mem (bytevector->pointer bv) len)
+    (k (pointer-address mem) len)))
+
+(define-method (write (cstr <cstr>) port)
+  (format port "<<cstr> ~s>" (cstr->string cstr)))
+
+(define-method (display (cstr <cstr>) port)
+  (display (cstr->string cstr) port))
+
+(define-method (+ (a <cstr>) (b <cstr>))
+  (string->cstr (string-append (cstr->string a) (cstr->string b))))
+
+(define-method (equal? (a <cstr>) (b <cstr>))
+  (equal? (cstr->string a) (cstr->string b)))
+
+(define failed? #f)
+(define-syntax test
+  (syntax-rules ()
+    ((_ exp res)
+     (let ((expected res)
+           (actual exp))
+       (if (not (equal? actual expected))
+           (begin
+             (set! failed? #t)
+             (format (current-error-port)
+                     "bad return from expression `~a': expected ~A; got ~A~%"
+                     'exp expected actual)))))))
+
+(test (string->cstr "Hello, world!")
+      (+ (string->cstr "Hello, ") (string->cstr "world!")))
+
+;; GOOPS construction syntax instead of make-cstr.
+(test (string->cstr "Hello, world!")
+      (string->cstr "Hello, world!"
+                    (lambda (addr len)
+                      (make <cstr> #:addr addr #:len len))))
+
+;; Subclassing.
+(define-class <wrapped-cstr> (<cstr>)
+  (wrapped-string #:init-keyword #:wrapped-string
+                  #:getter wrapped-string
+                  #:init-form (error "missing #:wrapped-string")))
+
+(define (string->wrapped-cstr string)
+  (string->cstr string (lambda (addr len)
+                         (make <wrapped-cstr> #:addr addr #:len len
+                               #:wrapped-string string))))
+
+(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!")))
+  ;; Tests that <cst> methods work on <wrapped-cstr>.
+  (test "Hello, world!" (cstr->string wrapped-cstr))
+  ;; Test the additional #:wrapped-string slot.
+  (test "Hello, world!" (wrapped-string wrapped-cstr)))
+
+(gc) (gc) (gc)
+
+;; Sleep 50 milliseconds to allow the finalization thread to run.
+(usleep #e50e3)
+
+;; But we don't really know if it ran.  Oh well.
+
+(exit (if failed? 1 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End: