mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 20:40:29 +02:00
Code Activity

Revert to 1.6 (1.7 was an accidental checkin).

Browse source
This commit is contained in:
Thien-Thi Nguyen 2002-02-26 10:38:53 +00:00
parent 327d4dd38f
commit b39eac3a5a
1 changed files with 19 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

53
oop/goops/dispatch.scm
View file

@ -1,5 +1,3 @@
;;;; 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
@ -237,26 +235,7 @@
(define (lookup-create-cmethod gf args)
(no-applicable-method (car args) (cadr args))))
(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)
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))
(slot-set! gf 'used-by '()))
(let ((applicable ((if (eq? gf compute-applicable-methods)
@ -292,17 +271,23 @@
(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)
;;;
;;; Memoization Reflection
;;;
;;; oop/goop/dispatch.scm ends here
(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
)))))