mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +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:33:08 +00:00
parent a980f465e9
commit 3bf465263c
3 changed files with 22 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

7
NEWS
View file

@ -56,6 +56,13 @@ got confused if handed method code created in a null environment
(environment = empty list). It now stands every environment
imaginable (think about it!).
** GOOPS init-thunks can now be primitive procedures
Previously, attempts to provide something else than a closure as value
for the #:init-thunk slot option would yield a segmentation fault.
Now, it's possible to supply a primitive procedure as init-thunk.
Non-allowed values result in an error.
** Garbage collection frequency improved for large malloc heaps
The decision when to run the GC is now done in a way that avoids GCs

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>
* goops/dispatch.scm (cache-hashval): Corrected termination

15
oop/goops.scm
View file

@ -508,7 +508,7 @@
(define method
(letrec ((specializers
(lambda (ls)
(cond ((null? ls) '('()))
(cond ((null? ls) (list (list 'quote '())))
((pair? ls) (cons (if (pair? (car ls))
(cadar ls)
'<top>)
@ -1043,16 +1043,19 @@
;;; compute-getters-n-setters
;;;
(define (make-thunk thunk)
(lambda () (thunk)))
(define (compute-getters-n-setters class slots env)
(define (compute-slot-init-function name 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))
(cond ((not (thunk? thunk))
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
name class thunk))
((closure? thunk) thunk)
(else (make-thunk thunk)))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))