-;;;
-;;; Method entries
-;;;
-
-(define code-table-lookup
- (letrec ((check-entry (lambda (entry types)
- (cond
- ((not (pair? entry)) (and (null? types) entry))
- ((null? types) #f)
- (else
- (and (eq? (car entry) (car types))
- (check-entry (cdr entry) (cdr types))))))))
- (lambda (code-table types)
- (cond ((null? code-table) #f)
- ((check-entry (car code-table) types))
- (else (code-table-lookup (cdr code-table) types))))))
-
-(define (compute-cmethod methods types)
- (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
- (let* ((method (car methods))
- (cmethod (compile-method methods types))
- (entry (append types cmethod)))
- (slot-set! method 'code-table
- (cons entry (slot-ref method 'code-table)))
- cmethod)))
-