diff options
-rw-r--r-- | libguile/goops.c | 20 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 4 | ||||
-rw-r--r-- | module/oop/goops.scm | 22 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 43 |
4 files changed, 56 insertions, 33 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 4a2e24d24..884b4b673 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -659,7 +659,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) { SCM slot_name = SCM_CAR (slots); - SCM slot_value = SCM_PACK (0); + SCM slot_value = SCM_GOOPS_UNBOUND; if (!scm_is_null (SCM_CDR (slot_name))) { @@ -683,12 +683,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, - SCM_PACK (0), + SCM_GOOPS_UNBOUND, FUNC_NAME); } } - if (SCM_UNPACK (slot_value)) + if (!SCM_GOOPS_UNBOUNDP (slot_value)) /* set slot to provided value */ set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value); else @@ -696,14 +696,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, /* set slot to its :init-form if it exists */ tmp = SCM_CADAR (get_n_set); if (scm_is_true (tmp)) - { - slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); - if (SCM_GOOPS_UNBOUNDP (slot_value)) - set_slot_value (class, - obj, - SCM_CAR (get_n_set), - scm_call_0 (tmp)); - } + set_slot_value (class, + obj, + SCM_CAR (get_n_set), + scm_call_0 (tmp)); } } diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e4df6e1bd..7c926f2a9 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc. +;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013,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 @@ -113,8 +113,6 @@ (list . list) (vector . vector) ((class-of . 1) . class-of) - ((@slot-ref . 2) . slot-ref) - ((@slot-set! . 3) . slot-set) ((vector-ref . 2) . vector-ref) ((vector-set! . 3) . vector-set) ((variable-ref . 1) . variable-ref) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index f2f61c58b..b92c82013 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -82,13 +82,7 @@ (eval-when (expand load eval) (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) - (add-interesting-primitive! 'class-of) - (define (@slot-ref o n) - (struct-ref o n)) - (define (@slot-set! o n v) - (struct-set! o n v)) - (add-interesting-primitive! '@slot-ref) - (add-interesting-primitive! '@slot-set!)) + (add-interesting-primitive! 'class-of)) ;; Then load the rest of GOOPS (use-modules (oop goops util) @@ -1121,7 +1115,7 @@ (lambda (o) (assert-bound (proc o) o))) ;; the idea is to compile the index into the procedure, for fastest -;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. +;; lookup. (eval-when (expand load eval) (define num-standard-pre-cache 20)) @@ -1133,9 +1127,9 @@ (define (make-one x) (define (body-trans form) (cond ((not (pair? form)) form) - ((eq? (car form) '@slot-ref) + ((eq? (car form) 'struct-ref) `(,(car form) ,(cadr form) ,x)) - ((eq? (car form) '@slot-set!) + ((eq? (car form) 'struct-set!) `(,(car form) ,(cadr form) ,x ,(cadddr form))) (else (map body-trans form)))) @@ -1148,16 +1142,16 @@ ((lambda (,n-var) (lambda ,args ,@body)) n))))))) (define-standard-accessor-method ((bound-check-get n) o) - (let ((x (@slot-ref o n))) + (let ((x (struct-ref o n))) (if (unbound? x) (slot-unbound o) x))) (define-standard-accessor-method ((standard-get n) o) - (@slot-ref o n)) + (struct-ref o n)) (define-standard-accessor-method ((standard-set n) o v) - (@slot-set! o n v)) + (struct-set! o n v)) ;;; compute-getters-n-setters ;;; diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 1705ee811..d8a5ecfad 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -1,6 +1,6 @@ ;;;; goops.test --- test suite for GOOPS -*- scheme -*- ;;;; -;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 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 @@ -474,9 +474,9 @@ (x bar) (set! (x bar) 2) (equal? (reverse z) - '(before-ref before-set! 1 before-ref after-ref - after-set! 1 1 before-ref after-ref - before-set! 2 before-ref after-ref after-set! 2 2))) + '(before-set! 1 before-ref after-ref + after-set! 1 1 before-ref after-ref + before-set! 2 before-ref after-ref after-set! 2 2))) (current-module)))) (use-modules (oop goops composite-slot)) @@ -527,3 +527,38 @@ exception:no-applicable-method (eval '(quxy 1) (current-module)))) + +(with-test-prefix "foreign slots" + (define-class <foreign-test> () + (a #:init-keyword #:a #:class <foreign-slot> + #:accessor test-a) + (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot> + #:accessor test-b)) + + (pass-if-equal "constructing, no initargs" + '(0 3) + (let ((x (make <foreign-test>))) + (list (slot-ref x 'a) + (slot-ref x 'b)))) + + (pass-if-equal "constructing, initargs" + '(1 2) + (let ((x (make <foreign-test> #:a 1 #:b 2))) + (list (slot-ref x 'a) + (slot-ref x 'b)))) + + (pass-if-equal "getters" + '(0 3) + (let ((x (make <foreign-test>))) + (list (test-a x) (test-b x)))) + + (pass-if-equal "setters" + '(10 20) + (let ((x (make <foreign-test>))) + (set! (test-a x) 10) + (set! (test-b x) 20) + (list (test-a x) (test-b x)))) + + (pass-if-exception "out of range" + exception:out-of-range + (make <foreign-test> #:a (ash 1 64)))) |