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 (environment = empty list). It now stands every environment
imaginable (think about it!). 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 ** Garbage collection frequency improved for large malloc heaps
The decision when to run the GC is now done in a way that avoids GCs 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> 2003-04-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops/dispatch.scm (cache-hashval): Corrected termination * goops/dispatch.scm (cache-hashval): Corrected termination

17
oop/goops.scm
View file

@ -508,7 +508,7 @@
(define method (define method
(letrec ((specializers (letrec ((specializers
(lambda (ls) (lambda (ls)
(cond ((null? ls) '('())) (cond ((null? ls) (list (list 'quote '())))
((pair? ls) (cons (if (pair? (car ls)) ((pair? ls) (cons (if (pair? (car ls))
(cadar ls) (cadar ls)
'<top>) '<top>)
@ -1042,17 +1042,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)))))