From 5b7632331e7551ac202bbaba37c572b96a791c6e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Jan 2015 12:40:43 +0100 Subject: [PATCH] Fix #:init-value on class-allocated slots Allocating an instance of a class with a #:class or #:each-subclass slot allocation should not re-initialize the class-allocated slot. In Guile 1.8, this worked by effectively doing a slot-bound? within %initialize-object. In Guile 2.0 we instead initialize the slot when it is allocated -- in compute-get-n-set. * module/oop/goops.scm (compute-getters-n-setters): Don't set an init-thunk for class-allocated slots. (compute-get-n-set): Initialize class-allocated slots here, if an init-thunk or init-value are present. * test-suite/tests/goops.test ("#:each-subclass"): Add test. --- module/oop/goops.scm | 39 ++++++++++++++++++++++++------------- test-suite/tests/goops.test | 39 ++++++++++++++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 14 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index b92c82013..9ab1eb22a 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, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014, 2015 Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -1200,12 +1200,20 @@ ;; '(index size) for instance allocated slots ;; '() for other slots (verify-accessors name g-n-s) - (cons name - (cons (compute-slot-init-function name s) - (if (or (integer? g-n-s) - (zero? size)) - g-n-s - (append g-n-s (list index size))))))) + (case (slot-definition-allocation s) + ((#:each-subclass #:class) + (unless (and (zero? size) (pair? g-n-s)) + (error "Class-allocated slots should not reserve fields")) + ;; Don't initialize the slot; that's handled when the slot + ;; is allocated, in compute-get-n-set. + (cons name (cons #f g-n-s))) + (else + (cons name + (cons (compute-slot-init-function name s) + (if (or (integer? g-n-s) + (zero? size)) + g-n-s + (append g-n-s (list index size))))))))) slots)) ;;; compute-cpl @@ -1357,6 +1365,12 @@ ;;; compute-get-n-set ;;; (define-method (compute-get-n-set (class ) s) + (define (class-slot-init-value) + (let ((thunk (slot-definition-init-thunk s))) + (if thunk + (thunk) + (slot-definition-init-value s)))) + (case (slot-definition-allocation s) ((#:instance) ;; Instance slot ;; get-n-set is just its offset @@ -1371,7 +1385,7 @@ (let ((name (slot-definition-name s))) (if (memq name (map slot-definition-name (class-direct-slots class))) ;; This slot is direct; create a new shared variable - (make-closure-variable class) + (make-closure-variable class (class-slot-init-value)) ;; Slot is inherited. Find its definition in superclass (let loop ((l (cdr (class-precedence-list class)))) (let ((r (assoc name (slot-ref (car l) 'getters-n-setters)))) @@ -1381,7 +1395,7 @@ ((#:each-subclass) ;; slot shared by instances of direct subclass. ;; (Thomas Buerger, April 1998) - (make-closure-variable class)) + (make-closure-variable class (class-slot-init-value))) ((#:virtual) ;; No allocation ;; slot-ref and slot-set! function must be given by the user @@ -1393,10 +1407,9 @@ (list get set))) (else (next-method)))) -(define (make-closure-variable class) - (let ((shared-variable (make-unbound))) - (list (lambda (o) shared-variable) - (lambda (o v) (set! shared-variable v))))) +(define (make-closure-variable class value) + (list (lambda (o) value) + (lambda (o v) (set! value v)))) (define-method (compute-get-n-set (o ) s) (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s))) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index d8a5ecfad..724c0eec0 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, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 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 @@ -562,3 +562,40 @@ (pass-if-exception "out of range" exception:out-of-range (make #:a (ash 1 64)))) + +(with-test-prefix "#:each-subclass" + (let* (( + (class () + (test #:init-value '() #:allocation #:each-subclass) + #:name ')) + (a (make ))) + (pass-if-equal '() (slot-ref a 'test)) + (let ((b (make ))) + (pass-if-equal '() (slot-ref b 'test)) + (slot-set! a 'test 100) + (pass-if-equal 100 (slot-ref a 'test)) + (pass-if-equal 100 (slot-ref b 'test)) + + ;; #:init-value of the class shouldn't reinitialize slot when + ;; instances are allocated. + (make ) + + (pass-if-equal 100 (slot-ref a 'test)) + (pass-if-equal 100 (slot-ref b 'test)) + + (let (( + (class ()))) + (pass-if-equal 100 (slot-ref a 'test)) + (pass-if-equal 100 (slot-ref b 'test)) + (let ((c (make ))) + (pass-if-equal 100 (slot-ref a 'test)) + (pass-if-equal 100 (slot-ref b 'test)) + (pass-if-equal '() (slot-ref c 'test)) + (slot-set! c 'test 200) + (pass-if-equal 200 (slot-ref c 'test)) + + (make ) + + (pass-if-equal 100 (slot-ref a 'test)) + (pass-if-equal 100 (slot-ref b 'test)) + (pass-if-equal 200 (slot-ref c 'test)))))))