GOOPS slot access protected via slot accessors, not struct perms

* module/oop/goops.scm (opaque-slot?, read-only-slot?): New helpers.
  (allocate-slots): Protect opaque and read-only slots by wrapping the
  slot accessors instead of relying on struct permissions.
  (%compute-layout): Remove opaque-slot case.

1 files changed, 27 insertions, 6 deletions

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a46918062..4569336a9 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -719,6 +719,10 @@ followed by its associated value.  If @var{l} does not hold a value for
 (define-standard-accessor-method ((standard-set n) o v)
   (struct-set! o n v))
 
+;; Boot definitions.
+(define (opaque-slot? slot) #f)
+(define (read-only-slot? slot) #f)
+
 (define (allocate-slots class slots)
   "Transform the computed list of direct slot definitions @var{slots}
 into a corresponding list of effective slot definitions, allocating
@@ -752,11 +756,27 @@ slots as we go."
                                value)))
                        set))))
         (lambda (get/raw get set)
-          (struct-set! slot slot-index-slot-ref/raw get/raw)
-          (struct-set! slot slot-index-slot-ref get)
-          (struct-set! slot slot-index-slot-set! set)
-          (struct-set! slot slot-index-index index)
-          (struct-set! slot slot-index-size size)))
+          (let ((get (if (opaque-slot? slot)
+                         (lambda (o)
+                           (error "Slot is opaque" name))
+                         get))
+                (set (cond
+                      ((opaque-slot? slot)
+                       (lambda (o v)
+                         (error "Slot is opaque" name)))
+                      ((read-only-slot? slot)
+                       (lambda (o v)
+                         (let ((v* (get/raw o)))
+                           (if (unbound? v*)
+                               ;; Allow initialization.
+                               (set o v)
+                               (error "Slot is read-only" name)))))
+                      (else set))))
+            (struct-set! slot slot-index-slot-ref/raw get/raw)
+            (struct-set! slot slot-index-slot-ref get)
+            (struct-set! slot slot-index-slot-set! set)
+            (struct-set! slot slot-index-index index)
+            (struct-set! slot slot-index-size size))))
       slot))
   (struct-set! class class-index-nfields 0)
   (map-in-order make-effective-slot-definition slots))
@@ -772,7 +792,6 @@ slots as we go."
                    ((subclass? type <protected-slot>) #\p)
                    (else #\u))
                   (cond
-                   ((subclass? type <opaque-slot>) #\o)
                    ((subclass? type <read-only-slot>) #\r)
                    ((subclass? type <hidden-slot>) #\h)
                    (else #\w)))
@@ -893,6 +912,8 @@ slots as we go."
 (define-standard-class <float-slot> (<foreign-slot>))
 (define-standard-class <double-slot> (<foreign-slot>))
 
+(define (opaque-slot? slot) (is-a? slot <opaque-slot>))
+(define (read-only-slot? slot) (is-a? slot <read-only-slot>))