Merge commit '5b7632331e'

Conflicts:
	module/oop/goops.scm

module/oop/goops.scm

@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 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
@@ -1269,12 +1269,20 @@
 	   ;;   '(index size) for instance allocated slots
 	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
-	   (cons name
+           (case (slot-definition-allocation s)
-		 (cons (compute-slot-init-function name s)
+             ((#:each-subclass #:class)
-		       (if (or (integer? g-n-s)
+              (unless (and (zero? size) (pair? g-n-s))
-			       (zero? size))
+                (error "Class-allocated slots should not reserve fields"))
-			   g-n-s
+              ;; Don't initialize the slot; that's handled when the slot
-			   (append g-n-s (list index size)))))))
+              ;; 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
@@ -1426,6 +1434,12 @@
 ;;; compute-get-n-set
 ;;;
 (define-method (compute-get-n-set (class <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
@@ -1440,7 +1454,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))))
@@ -1450,7 +1464,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
@@ -1462,10 +1476,9 @@
        (list get set)))
     (else    (next-method))))
 
-(define (make-closure-variable class)
+(define (make-closure-variable class value)
-  (let ((shared-variable (make-unbound)))
+  (list (lambda (o) value)
-    (list (lambda (o) shared-variable)
+        (lambda (o v) (set! value v))))
-	  (lambda (o v) (set! shared-variable v)))))
 
 (define-method (compute-get-n-set (o <object>) s)
   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))

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 <foreign-test> #:a (ash 1 64))))
+
+(with-test-prefix "#:each-subclass"
+  (let* ((<subclass-allocation-test>
+          (class ()
+            (test #:init-value '() #:allocation #:each-subclass)
+            #:name '<subclass-allocation-test>))
+         (a (make <subclass-allocation-test>)))
+    (pass-if-equal '() (slot-ref a 'test))
+    (let ((b (make <subclass-allocation-test>)))
+      (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 <subclass-allocation-test>)
+
+      (pass-if-equal 100 (slot-ref a 'test))
+      (pass-if-equal 100 (slot-ref b 'test))
+
+      (let ((<test-subclass>
+             (class (<subclass-allocation-test>))))
+        (pass-if-equal 100 (slot-ref a 'test))
+        (pass-if-equal 100 (slot-ref b 'test))
+        (let ((c (make <test-subclass>)))
+          (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 <test-subclass>)
+
+          (pass-if-equal 100 (slot-ref a 'test))
+          (pass-if-equal 100 (slot-ref b 'test))
+          (pass-if-equal 200 (slot-ref c 'test)))))))