summaryrefslogtreecommitdiff
path: root/oop
diff options
context:
space:
mode:
authorThien-Thi Nguyen <ttn@gnuvola.org>2002-02-26 10:32:34 +0000
committerThien-Thi Nguyen <ttn@gnuvola.org>2002-02-26 10:32:34 +0000
commit327d4dd38f22fb1ef48906068f9b95b15fba6052 (patch)
tree2a80f0bd6cb1c7b1d12db75cc13f7358d5a39ab0 /oop
parent58ed8bc61ceaa2dbb40b08650ac9ae9eedc8495b (diff)
downloadguile-327d4dd38f22fb1ef48906068f9b95b15fba6052.tar.gz
doc/ref/ChangeLog
Diffstat (limited to 'oop')
-rw-r--r--oop/goops/dispatch.scm61
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