mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

GOOPS slot access protected via slot accessors, not struct perms

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-09-23 14:19:38 +02:00
parent b0ecf83ef0
commit f23415589a
1 changed files with 27 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

33
module/oop/goops.scm
View file

@ -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>))