[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: GOOPS slot access protected via slot accessors, n
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: GOOPS slot access protected via slot accessors, not struct perms |
Date: |
Sat, 23 Sep 2017 08:27:41 -0400 (EDT) |
wingo pushed a commit to branch stable-2.2
in repository guile.
commit f23415589a0e263e34a687b5dad1b1624e949639
Author: Andy Wingo <address@hidden>
Date: Sat Sep 23 14:19:38 2017 +0200
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.
---
module/oop/goops.scm | 33 +++++++++++++++++++++++++++------
1 file changed, 27 insertions(+), 6 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a469180..4569336 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>))