[PATCH] Avoid GOOPS in (system foreign-object)?

[Ludovic Courtès]

Hello!

I would like to have foreign object types based on structs rather than
GOOPS classes.

The rationale is that GOOPS is normally not loaded unless the user
explicitly asks for it; having (system foreign-objects) load it would
add overhead even for users who just want SMOB-like functionality.

WDYT?

The preliminary patch attached is an attempt to do that.  Somehow, the
creation of GOOPS classes for vtables doesn’t work as I thought, which
means that ‘test-foreign-object-scm’ cannot define methods and so on
(which I agree is useful functionality.)  What am I missing?

Thanks!

Ludo’.

PS: The reason I’m looking at it is that I would really want us to
    release 2.0.12 ASAP, so any changes to this API must be settled.

6fb47e8e1977e6aed9a3f636c463365a8e7cf7b9 HEAD wip-foreign-objects
Author: Ludovic Courtès <address@hidden>
Date:   Thu May 21 17:03:40 2015 +0200

    foreign-object: Rebase on top of structs instead of GOOPS.

3 files changed, 75 insertions(+), 92 deletions(-)
 libguile/foreign-object.c                     |  6 +-
 module/system/foreign-object.scm              | 99 +++++++++++++++------------
 test-suite/standalone/test-foreign-object-scm | 62 +++++------------

        Modified   libguile/foreign-object.c
diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c
index 830f73f..e631f17 100644
--- a/libguile/foreign-object.c
+++ b/libguile/foreign-object.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2014, 2015 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
@@ -23,7 +23,6 @@
 #endif
 
 #include "libguile/_scm.h"
-#include "libguile/goops.h"
 #include "libguile/foreign-object.h"
 
 
@@ -58,7 +57,8 @@ scm_make_foreign_object_type (SCM name, SCM slot_names,
 void
 scm_assert_foreign_object_type (SCM type, SCM val)
 {
-  if (!SCM_IS_A_P (val, type))
+  if (!SCM_STRUCTP (val)
+      || !scm_is_eq (SCM_STRUCT_VTABLE (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));
 }
        Modified   module/system/foreign-object.scm
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
index f7bfc94..cde9664 100644
--- a/module/system/foreign-object.scm
+++ b/module/system/foreign-object.scm
@@ -23,7 +23,7 @@
 ;;; Code:
 
 (define-module (system foreign-object)
-  #:use-module (oop goops)
+  #:use-module (system foreign)
   #:export     (make-foreign-object-type
                 define-foreign-object-type))
 
@@ -31,59 +31,70 @@
   (load-extension (string-append "libguile-" (effective-version))
                   "scm_init_foreign_object"))
 
-(define-class <foreign-class> (<class>))
+;; Constant from struct.h.
+(define vtable-index-finalizer 3)
 
-(define-class <foreign-class-with-finalizer> (<foreign-class>)
-  (finalizer #:init-keyword #:finalizer #:init-value #f
-             #:getter finalizer))
+(define <foreign-vtable>
+  ;; The meta-vtable for foreign structs.
+  (make-struct/no-tail <standard-vtable>
+                       (make-struct-layout standard-vtable-fields)
+                       (lambda (obj port)
+                         (format port "#<foreign-vtable ~a ~a>"
+                                 (struct-vtable-name obj)
+                                 (number->string (object-address obj) 16)))))
+
+(define* (make-foreign-vtable name layout
+                              #:key finalizer printer)
+  "Return a vtable called NAME for foreign objects with the given
+LAYOUT, PRINTER, and FINALIZER."
+  (let ((vtable (make-struct/no-tail <foreign-vtable>
+                                     (make-struct-layout layout)
+                                     printer)))
+    ;; Note: as a side-effect, this defines a GOOPS class for VTABLE.
+    (set-struct-vtable-name! vtable name)
 
-(define-method (allocate-instance (class <foreign-class-with-finalizer>)
-                                  initargs)
-  (let ((instance (next-method))
-        (finalizer (finalizer class)))
     (when finalizer
-      (%add-finalizer! instance finalizer))
-    instance))
+      (let ((c-finalizer (procedure->pointer void
+                                             (compose finalizer pointer->scm)
+                                             '(*))))
+        (struct-set! vtable vtable-index-finalizer
+                     (pointer-address c-finalizer))))
+    vtable))
 
-(define* (make-foreign-object-type name slots #:key finalizer
-                                   (getters (map (const #f) slots)))
+(define* (make-foreign-object-type name slots #:key finalizer printer)
   (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 getter)
-                       (unless (symbol? slot)
-                         (error "slot name should be a symbol" slot))
-                       (cons* slot #:class <foreign-slot>
-                              #:init-keyword (symbol->keyword slot)
-                              #:init-value 0
-                              (if getter (list #:getter getter) '())))
-                     slots
-                     getters)))
-    (if finalizer
-        (make-class '() dslots #:name name
-                    #:finalizer finalizer
-                    #:metaclass <foreign-class-with-finalizer>)
-        (make-class '() dslots #:name name
-                    #:metaclass <foreign-class>))))
+  (unless (or (not printer) (procedure? printer))
+    (error "printer should be a procedure" printer))
+  (make-foreign-vtable name
+                       (string-concatenate (map (const "uw") slots))
+                       #:finalizer finalizer
+                       #:printer printer))
+
+(define (wrong-type-error s who)
+  (throw 'wrong-type-arg who
+         "Wrong type argument: ~S" (list s)
+         (list s)))
+
+(define-syntax-rule (assert-valid-struct type obj proc)
+  (unless (eq? type (struct-vtable obj))
+    (wrong-type-error obj proc)))
 
 (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 slot (ensure-generic 'slot (and (defined? 'slot) slot)))
-           ...
-           (define name
-             (make-foreign-object-type 'name '(slot ...) kwarg ...
-                                       #:getters (list slot ...)))
-           (define constructor
-             (lambda (slot ...)
-               (make name #,@(kw-apply #'(slot ...))))))))))
+       (with-syntax (((index ...) (iota (length #'(slot ...)))))
+         #`(begin
+             (define-inlinable (slot obj)
+               (assert-valid-struct name obj 'slot)
+               (struct-ref obj index))
+             ...
+             (define name
+               (make-foreign-object-type 'name '(slot ...) kwarg ...))
+             (define constructor
+               (lambda (slot ...)
+                 (make-struct/no-tail name slot ...)))))))))
+
        Modified   test-suite/standalone/test-foreign-object-scm
diff --git a/test-suite/standalone/test-foreign-object-scm 
b/test-suite/standalone/test-foreign-object-scm
index 7e4bd85..8e6de39 100755
--- a/test-suite/standalone/test-foreign-object-scm
+++ b/test-suite/standalone/test-foreign-object-scm
@@ -3,7 +3,7 @@ exec guile -q -s "$0" "$@"
 !#
 ;;; test-foreign-object-scm --- Foreign object interface.     -*- Scheme -*-
 ;;;
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 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
@@ -21,8 +21,7 @@ exec guile -q -s "$0" "$@"
 
 (use-modules (system foreign)
              (system foreign-object)
-             (rnrs bytevectors)
-             (oop goops))
+             (rnrs bytevectors))
 
 (define (libc-ptr name)
   (catch #t
@@ -36,14 +35,18 @@ exec guile -q -s "$0" "$@"
 (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-foreign-object-type <cstr>
+  make-cstr
+  (cstr-addr cstr-len)
+  #:finalizer (lambda (cstr)
+                (free (make-pointer (cstr-addr cstr))))
+  #:printer (lambda (cstr port)
+              (format port "<<cstr> ~s>" (cstr->string cstr))))
 
 (define (cstr->string cstr)
-  (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8"))
+  (pointer->string (make-pointer (cstr-addr cstr))
+                   (cstr-len cstr)
+                   "UTF-8"))
 
 (define* (string->cstr str #:optional (k make-cstr))
   (let* ((bv (string->utf8 str))
@@ -54,18 +57,9 @@ exec guile -q -s "$0" "$@"
     (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>))
+(define (cstr-append a b)
   (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 ()
@@ -76,34 +70,12 @@ exec guile -q -s "$0" "$@"
            (begin
              (set! failed? #t)
              (format (current-error-port)
-                     "bad return from expression `~a': expected ~A; got ~A~%"
+                     "bad return from expression `~a': expected ~s; got ~s~%"
                      '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)))
+(test "Hello, world!"
+      (cstr->string
+       (cstr-append (string->cstr "Hello, ") (string->cstr "world!"))))
 
 (gc) (gc) (gc)