From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Avoid GOOPS in (system foreign-object)? Date: Thu, 21 May 2015 17:28:16 +0200 Message-ID: <87wq022bn3.fsf@gnu.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1432235243 3637 80.91.229.3 (21 May 2015 19:07:23 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 21 May 2015 19:07:23 +0000 (UTC) Cc: guile-devel@gnu.org To: Andy Wingo Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Thu May 21 21:07:22 2015 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1YvVoC-00070t-7T for guile-devel@m.gmane.org; Thu, 21 May 2015 21:07:08 +0200 Original-Received: from localhost ([::1]:59170 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YvVoB-0000rX-Iu for guile-devel@m.gmane.org; Thu, 21 May 2015 15:07:07 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55628) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YvVnX-0008K0-CQ for guile-devel@gnu.org; Thu, 21 May 2015 15:06:29 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YvVnS-000542-Vb for guile-devel@gnu.org; Thu, 21 May 2015 15:06:27 -0400 Original-Received: from fencepost.gnu.org ([2001:4830:134:3::e]:39897) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YvVnS-00053w-T1 for guile-devel@gnu.org; Thu, 21 May 2015 15:06:22 -0400 Original-Received: from reverse-83.fdn.fr ([80.67.176.83]:52782 helo=pluto) by fencepost.gnu.org with esmtpsa (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1YvVnR-0000Wk-Ow; Thu, 21 May 2015 15:06:22 -0400 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 2 Prairial an 223 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x3D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-unknown-linux-gnu X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2001:4830:134:3::e X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17721 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable 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=E2=80=99t work as I thought, wh= ich means that =E2=80=98test-foreign-object-scm=E2=80=99 cannot define methods = and so on (which I agree is useful functionality.) What am I missing? Thanks! Ludo=E2=80=99. PS: The reason I=E2=80=99m 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. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable 6fb47e8e1977e6aed9a3f636c463365a8e7cf7b9 HEAD wip-foreign-objects Author: Ludovic Court=C3=A8s 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 =20 #include "libguile/_scm.h" -#include "libguile/goops.h" #include "libguile/foreign-object.h" =20 =20 @@ -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-objec= t.scm index f7bfc94..cde9664 100644 --- a/module/system/foreign-object.scm +++ b/module/system/foreign-object.scm @@ -23,7 +23,7 @@ ;;; Code: =20 (define-module (system foreign-object) - #:use-module (oop goops) + #:use-module (system foreign) #:export (make-foreign-object-type define-foreign-object-type)) =20 @@ -31,59 +31,70 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_foreign_object")) =20 -(define-class ()) +;; Constant from struct.h. +(define vtable-index-finalizer 3) =20 -(define-class () - (finalizer #:init-keyword #:finalizer #:init-value #f - #:getter finalizer)) +(define + ;; The meta-vtable for foreign structs. + (make-struct/no-tail + (make-struct-layout standard-vtable-fields) + (lambda (obj port) + (format port "#" + (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 + (make-struct-layout layout) + printer))) + ;; Note: as a side-effect, this defines a GOOPS class for VTABLE. + (set-struct-vtable-name! vtable name) =20 -(define-method (allocate-instance (class ) - initargs) - (let ((instance (next-method)) - (finalizer (finalizer class))) (when finalizer - (%add-finalizer! instance finalizer)) - instance)) + (let ((c-finalizer (procedure->pointer void + (compose finalizer pointer->s= cm) + '(*)))) + (struct-set! vtable vtable-index-finalizer + (pointer-address c-finalizer)))) + vtable)) =20 -(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 - #: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 ) - (make-class '() dslots #:name name - #:metaclass )))) + (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))) =20 (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/sta= ndalone/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" "$@" =20 (use-modules (system foreign) (system foreign-object) - (rnrs bytevectors) - (oop goops)) + (rnrs bytevectors)) =20 (define (libc-ptr name) (catch #t @@ -36,14 +35,18 @@ exec guile -q -s "$0" "$@" (define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '* si= ze_t))) (define free (pointer->procedure void (libc-ptr "free") '(*))) =20 -(define (finalize-cstr cstr) - (free (make-pointer (addr cstr)))) - -(define-foreign-object-type make-cstr (addr len) - #:finalizer finalize-cstr) +(define-foreign-object-type + make-cstr + (cstr-addr cstr-len) + #:finalizer (lambda (cstr) + (free (make-pointer (cstr-addr cstr)))) + #:printer (lambda (cstr port) + (format port "< ~s>" (cstr->string cstr)))) =20 (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")) =20 (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))) =20 -(define-method (write (cstr ) port) - (format port "< ~s>" (cstr->string cstr))) - -(define-method (display (cstr ) port) - (display (cstr->string cstr) port)) - -(define-method (+ (a ) (b )) +(define (cstr-append a b) (string->cstr (string-append (cstr->string a) (cstr->string b)))) =20 -(define-method (equal? (a ) (b )) - (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))))))) =20 -(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 #:addr addr #:len len)))) - -;; Subclassing. -(define-class () - (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 #:addr addr #:len len - #:wrapped-string string)))) - -(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!"))) - ;; Tests that methods work on . - (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!")))) =20 (gc) (gc) (gc) --=-=-=--