[Guile-commits] 01/01: Fix #:init-value on class-allocated slots

[Andy Wingo]

wingo pushed a commit to branch stable-2.0
in repository guile.

commit 5b7632331e7551ac202bbaba37c572b96a791c6e
Author: Andy Wingo <address@hidden>
Date:   Thu Jan 22 12:40:43 2015 +0100

    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 b92c820..9ab1eb2 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 <address@hidden>
 ;;;;
 ;;;; 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 <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 <object>) 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 d8a5ecf..724c0ee 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 <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)))))))