diff options
author | Thien-Thi Nguyen <ttn@gnuvola.org> | 2002-02-26 10:32:34 +0000 |
---|---|---|
committer | Thien-Thi Nguyen <ttn@gnuvola.org> | 2002-02-26 10:32:34 +0000 |
commit | 327d4dd38f22fb1ef48906068f9b95b15fba6052 (patch) | |
tree | 2a80f0bd6cb1c7b1d12db75cc13f7358d5a39ab0 /oop | |
parent | 58ed8bc61ceaa2dbb40b08650ac9ae9eedc8495b (diff) | |
download | guile-327d4dd38f22fb1ef48906068f9b95b15fba6052.tar.gz |
doc/ref/ChangeLog
Diffstat (limited to 'oop')
-rw-r--r-- | oop/goops/dispatch.scm | 61 |
1 files changed, 38 insertions, 23 deletions
diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index 749cf9273..137def45b 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -1,15 +1,17 @@ +;;;; oop/goop/dispatch.scm --- provide `memoize-method!' + ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. -;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2, or (at your option) ;;;; any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -38,7 +40,7 @@ ;;;; If you write modifications of your own for GUILE, it is your choice ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;;; +;;;; (define-module (oop goops dispatch) @@ -235,7 +237,26 @@ (define (lookup-create-cmethod gf args) (no-applicable-method (car args) (cadr args)))) -(define (memoize-method! gf args exp) +(define method-cache-install! + (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) (if (not (slot-ref gf 'used-by)) (slot-set! gf 'used-by '())) (let ((applicable ((if (eq? gf compute-applicable-methods) @@ -271,23 +292,17 @@ (set-car! args gf) (lookup-create-cmethod no-applicable-method args))))) +(define -memoize-method!-stats #f) + +(define (memoize-method! gf args exp) + (memoize-method!-uninstrumented gf args exp)) + (set-procedure-property! memoize-method! 'system-procedure #t) -(define method-cache-install! - (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 - ))))) +;;; +;;; Memoization Reflection +;;; + + + +;;; oop/goop/dispatch.scm ends here |