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

25
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) (define-standard-accessor-method ((standard-set n) o v)
(struct-set! o n v)) (struct-set! o n v))
;; Boot definitions.
(define (opaque-slot? slot) #f)
(define (read-only-slot? slot) #f)
(define (allocate-slots class slots) (define (allocate-slots class slots)
"Transform the computed list of direct slot definitions @var{slots} "Transform the computed list of direct slot definitions @var{slots}
into a corresponding list of effective slot definitions, allocating into a corresponding list of effective slot definitions, allocating
@ -752,11 +756,27 @@ slots as we go."
value))) value)))
set)))) set))))
(lambda (get/raw get set) (lambda (get/raw get set)
(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/raw get/raw)
(struct-set! slot slot-index-slot-ref get) (struct-set! slot slot-index-slot-ref get)
(struct-set! slot slot-index-slot-set! set) (struct-set! slot slot-index-slot-set! set)
(struct-set! slot slot-index-index index) (struct-set! slot slot-index-index index)
(struct-set! slot slot-index-size size))) (struct-set! slot slot-index-size size))))
slot)) slot))
(struct-set! class class-index-nfields 0) (struct-set! class class-index-nfields 0)
(map-in-order make-effective-slot-definition slots)) (map-in-order make-effective-slot-definition slots))
@ -772,7 +792,6 @@ slots as we go."
((subclass? type <protected-slot>) #\p) ((subclass? type <protected-slot>) #\p)
(else #\u)) (else #\u))
(cond (cond
((subclass? type <opaque-slot>) #\o)
((subclass? type <read-only-slot>) #\r) ((subclass? type <read-only-slot>) #\r)
((subclass? type <hidden-slot>) #\h) ((subclass? type <hidden-slot>) #\h)
(else #\w))) (else #\w)))
@ -893,6 +912,8 @@ slots as we go."
(define-standard-class <float-slot> (<foreign-slot>)) (define-standard-class <float-slot> (<foreign-slot>))
(define-standard-class <double-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>))