mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 04:30:19 +02:00
Code Activity

* goops.scm (compute-getters-n-setters): Check for bad init-thunk.

Browse source
This commit is contained in:
Mikael Djurfeldt 2003-04-17 17:37:11 +00:00
parent 57b1d51841
commit 266f3a23d7
2 changed files with 13 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

4
oop/ChangeLog
View file

@ -1,3 +1,7 @@
2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (compute-getters-n-setters): Check for bad init-thunk.
2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se> 2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (compute-getter-method): For custom getter: Check * goops.scm (compute-getter-method): For custom getter: Check

12
oop/goops.scm
View file

@ -1192,8 +1192,14 @@
;;; ;;;
(define (compute-getters-n-setters class slots env) (define (compute-getters-n-setters class slots env)
(define (compute-slot-init-function s) (define (compute-slot-init-function name s)
(or (slot-definition-init-thunk s) (or (let ((thunk (slot-definition-init-thunk s)))
(and thunk
(if (not (and (closure? thunk)
(thunk? thunk)))
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
name class thunk))
thunk))
(let ((init (slot-definition-init-value s))) (let ((init (slot-definition-init-value s)))
(and (not (unbound? init)) (and (not (unbound? init))
(lambda () init))))) (lambda () init)))))
@ -1233,7 +1239,7 @@
;; '() for other slots ;; '() for other slots
(verify-accessors name g-n-s) (verify-accessors name g-n-s)
(cons name (cons name
(cons (compute-slot-init-function s) (cons (compute-slot-init-function name s)
(if (or (integer? g-n-s) (if (or (integer? g-n-s)
(zero? size)) (zero? size))
g-n-s g-n-s