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