/[guile]/guile/guile-core/oop/goops/dispatch.scm
ViewVC logotype

Diff of /guile/guile-core/oop/goops/dispatch.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by ttn, Tue Feb 26 10:32:34 2002 UTC revision 1.8 by ttn, Tue Feb 26 10:38:53 2002 UTC
# Line 1  Line 1 
 ;;;; oop/goop/dispatch.scm --- provide `memoize-method!'  
   
1  ;;;;    Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.  ;;;;    Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
2  ;;;;  ;;;;
3  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
# Line 237  Line 235 
235      (define (lookup-create-cmethod gf args)      (define (lookup-create-cmethod gf args)
236        (no-applicable-method (car args) (cadr args))))        (no-applicable-method (car args) (cadr args))))
237    
238  (define method-cache-install!  (define (memoize-method! gf args exp)
   (letrec ((first-n  
             (lambda (ls n)  
               (if (or (zero? n) (null? ls))  
                   '()  
                   (cons (car ls) (first-n (cdr ls) (- n 1)))))))  
     (lambda (insert! exp args applicable)  
       (let* ((specializers (method-specializers (car applicable)))  
              (n-specializers  
               (if (list? specializers)  
                   (length specializers)  
                   (+ 1 (slot-ref (method-cache-generic-function exp)  
                                  'n-specialized)))))  
         (let* ((types (map class-of (first-n args n-specializers)))  
                (entry+cmethod (compute-entry-with-cmethod applicable types)))  
           (insert! exp (car entry+cmethod)) ; entry = types + cmethod  
           (cdr entry+cmethod) ; cmethod  
           )))))  
   
 (define (memoize-method!-uninstrumented gf args exp)  
239    (if (not (slot-ref gf 'used-by))    (if (not (slot-ref gf 'used-by))
240        (slot-set! gf 'used-by '()))        (slot-set! gf 'used-by '()))
241    (let ((applicable ((if (eq? gf compute-applicable-methods)    (let ((applicable ((if (eq? gf compute-applicable-methods)
# Line 292  Line 271 
271             (set-car! args gf)             (set-car! args gf)
272             (lookup-create-cmethod no-applicable-method args)))))             (lookup-create-cmethod no-applicable-method args)))))
273    
 (define -memoize-method!-stats #f)  
   
 (define (memoize-method! gf args exp)  
   (memoize-method!-uninstrumented gf args exp))  
   
274  (set-procedure-property! memoize-method! 'system-procedure #t)  (set-procedure-property! memoize-method! 'system-procedure #t)
275    
276  ;;;  (define method-cache-install!
277  ;;; Memoization Reflection    (letrec ((first-n
278  ;;;              (lambda (ls n)
279                  (if (or (zero? n) (null? ls))
280                      '()
281                      (cons (car ls) (first-n (cdr ls) (- n 1)))))))
282  ;;; oop/goop/dispatch.scm ends here      (lambda (insert! exp args applicable)
283          (let* ((specializers (method-specializers (car applicable)))
284                 (n-specializers
285                  (if (list? specializers)
286                      (length specializers)
287                      (+ 1 (slot-ref (method-cache-generic-function exp)
288                                     'n-specialized)))))
289            (let* ((types (map class-of (first-n args n-specializers)))
290                   (entry+cmethod (compute-entry-with-cmethod applicable types)))
291              (insert! exp (car entry+cmethod)) ; entry = types + cmethod
292              (cdr entry+cmethod) ; cmethod
293              )))))

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26