mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-13 15:10:34 +02:00
Code Activity

* goops.scm (compute-getters-n-setters): Allow for primitive

Browse source 
procedure thunks.  (Thanks to Neil W. Van Dyke.)
This commit is contained in:
Mikael Djurfeldt 2003-04-20 17:35:41 +00:00
parent 624b0da1ca
commit 05a6b2d3cc
2 changed files with 14 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

5
oop/ChangeLog
View file

@ -1,3 +1,8 @@
2003-04-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (compute-getters-n-setters): Allow for primitive
procedure thunks. (Thanks to Neil W. Van Dyke.)
2003-04-19 Mikael Djurfeldt <djurfeldt@nada.kth.se> 2003-04-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops/dispatch.scm (cache-hashval): Corrected termination * goops/dispatch.scm (cache-hashval): Corrected termination

15
oop/goops.scm
View file

@ -1190,17 +1190,20 @@
(define standard-set (standard-accessor-method make-set standard-set-methods)) (define standard-set (standard-accessor-method make-set standard-set-methods))
;;; compute-getters-n-setters ;;; compute-getters-n-setters
;;; ;;;
(define (make-thunk thunk)
(lambda () (thunk)))
(define (compute-getters-n-setters class slots env) (define (compute-getters-n-setters class slots env)
(define (compute-slot-init-function name s) (define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s))) (or (let ((thunk (slot-definition-init-thunk s)))
(and thunk (and thunk
(if (not (and (closure? thunk) (cond ((not (thunk? thunk))
(thunk? thunk))) (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S" name class thunk))
name class thunk)) ((closure? thunk) thunk)
thunk)) (else (make-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)))))