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 <l...@gnu.org>
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)
