[Guile-commits] 06/08: Fix bootstrap slot permissions for <class>

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0f14a9e59826c1c304d1f50c741e91d99760ff43
Author: Andy Wingo <address@hidden>
Date:   Sat Sep 23 15:15:18 2017 +0200

    Fix bootstrap slot permissions for <class>
    
    * module/oop/goops.scm: Fix bootstrap slot computation to preserve slot
      permissions.
---
 module/oop/goops.scm | 16 +++++++++++++---
 1 file changed, 13 insertions(+), 3 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 78bbc4b..39bff06 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -932,13 +932,23 @@ slots as we go."
   ;; Boot definition that avoids munging nfields.
   (define (allocate-slots class slots)
     (define (make-effective-slot-definition slot index)
-      (let* ((slot (compute-effective-slot-definition class slot)))
+      (let* ((slot (compute-effective-slot-definition class slot))
+             (get/raw (standard-get index))
+             (set/raw (standard-set index)))
         (struct-set! slot slot-index-slot-ref/raw (standard-get index))
         (struct-set! slot slot-index-slot-ref
                      (if (slot-definition-init-thunk slot)
-                         (struct-ref slot slot-index-slot-ref/raw)
+                         get/raw
                          (bound-check-get index)))
-        (struct-set! slot slot-index-slot-set! (standard-set index))
+        (struct-set! slot slot-index-slot-set!
+                     (if (read-only-slot? slot)
+                         (lambda (o v)
+                           (let ((v* (get/raw o)))
+                             (if (unbound? v*)
+                                 ;; Allow initialization.
+                                 (set/raw o v)
+                                 (error "Slot is read-only" slot))))
+                         set/raw))
         (struct-set! slot slot-index-index index)
         (struct-set! slot slot-index-size 1)
         slot))