/[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.6 by mdj, Sun Oct 21 09:48:23 2001 UTC revision 1.7 by ttn, Tue Feb 26 10:32:34 2002 UTC
# Line 1  Line 1 
1    ;;;; oop/goop/dispatch.scm --- provide `memoize-method!'
2    
3  ;;;;    Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.  ;;;;    Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
4  ;;;;  ;;;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
6  ;;;; it under the terms of the GNU General Public License as published by  ;;;; it under the terms of the GNU General Public License as published by
7  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;;;; the Free Software Foundation; either version 2, or (at your option)
8  ;;;; any later version.  ;;;; any later version.
9  ;;;;  ;;;;
10  ;;;; This program is distributed in the hope that it will be useful,  ;;;; This program is distributed in the hope that it will be useful,
11  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  ;;;; GNU General Public License for more details.  ;;;; GNU General Public License for more details.
14  ;;;;  ;;;;
15  ;;;; You should have received a copy of the GNU General Public License  ;;;; You should have received a copy of the GNU General Public License
16  ;;;; along with this software; see the file COPYING.  If not, write to  ;;;; along with this software; see the file COPYING.  If not, write to
17  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
# Line 38  Line 40 
40  ;;;; If you write modifications of your own for GUILE, it is your choice  ;;;; If you write modifications of your own for GUILE, it is your choice
41  ;;;; whether to permit this exception to apply to your modifications.  ;;;; whether to permit this exception to apply to your modifications.
42  ;;;; If you do not wish that, delete this exception notice.  ;;;; If you do not wish that, delete this exception notice.
43  ;;;;  ;;;;
44    
45    
46  (define-module (oop goops dispatch)  (define-module (oop goops dispatch)
# Line 235  Line 237 
237      (define (lookup-create-cmethod gf args)      (define (lookup-create-cmethod gf args)
238        (no-applicable-method (car args) (cadr args))))        (no-applicable-method (car args) (cadr args))))
239    
240  (define (memoize-method! gf args exp)  (define method-cache-install!
241      (letrec ((first-n
242                (lambda (ls n)
243                  (if (or (zero? n) (null? ls))
244                      '()
245                      (cons (car ls) (first-n (cdr ls) (- n 1)))))))
246        (lambda (insert! exp args applicable)
247          (let* ((specializers (method-specializers (car applicable)))
248                 (n-specializers
249                  (if (list? specializers)
250                      (length specializers)
251                      (+ 1 (slot-ref (method-cache-generic-function exp)
252                                     'n-specialized)))))
253            (let* ((types (map class-of (first-n args n-specializers)))
254                   (entry+cmethod (compute-entry-with-cmethod applicable types)))
255              (insert! exp (car entry+cmethod)) ; entry = types + cmethod
256              (cdr entry+cmethod) ; cmethod
257              )))))
258    
259    (define (memoize-method!-uninstrumented gf args exp)
260    (if (not (slot-ref gf 'used-by))    (if (not (slot-ref gf 'used-by))
261        (slot-set! gf 'used-by '()))        (slot-set! gf 'used-by '()))
262    (let ((applicable ((if (eq? gf compute-applicable-methods)    (let ((applicable ((if (eq? gf compute-applicable-methods)
# Line 271  Line 292 
292             (set-car! args gf)             (set-car! args gf)
293             (lookup-create-cmethod no-applicable-method args)))))             (lookup-create-cmethod no-applicable-method args)))))
294    
295    (define -memoize-method!-stats #f)
296    
297    (define (memoize-method! gf args exp)
298      (memoize-method!-uninstrumented gf args exp))
299    
300  (set-procedure-property! memoize-method! 'system-procedure #t)  (set-procedure-property! memoize-method! 'system-procedure #t)
301    
302  (define method-cache-install!  ;;;
303    (letrec ((first-n  ;;; Memoization Reflection
304              (lambda (ls n)  ;;;
305                (if (or (zero? n) (null? ls))  
306                    '()  
307                    (cons (car ls) (first-n (cdr ls) (- n 1)))))))  
308      (lambda (insert! exp args applicable)  ;;; oop/goop/dispatch.scm ends here
       (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  
           )))))  

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

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