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, |
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) |
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) |
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 |
|
|
))))) |
|