+(define-syntax arity-case
+ (lambda (x)
+ (syntax-case x ()
+ ;; (arity-case n 2 foo bar)
+ ;; => (case n
+ ;; ((0) (foo))
+ ;; ((1) (foo a))
+ ;; ((2) (foo a b))
+ ;; (else bar))
+ ((arity-case n max form alternate)
+ (let ((max (syntax->datum #'max)))
+ #`(case n
+ #,@(let lp ((n 0))
+ (let ((ids (map (lambda (n)
+ (let* ((n (+ (char->integer #\a) n))
+ (c (integer->char n)))
+ (datum->syntax #'here (symbol c))))
+ (iota n))))
+ #`(((#,n) (form #,@ids))
+ . #,(if (< n max)
+ (lp (1+ n))
+ #'()))))
+ (else alternate)))))))
+
+;;;
+;;; These dispatchers are set as the "procedure" field of <generic>
+;;; instances. Unlike CLOS, in GOOPS a generic function can have
+;;; multiple arities.
+;;;
+;;; We pre-generate fast dispatchers for applications of up to 20
+;;; arguments. More arguments than that will go through slower generic
+;;; routines that cons arguments into a rest list.
+;;;
+(define (multiple-arity-dispatcher fv miss)
+ (define-syntax dispatch
+ (lambda (x)
+ (define (build-clauses args)
+ (let ((len (length (syntax->datum args))))
+ #`((#,args ((vector-ref fv #,len) . #,args))
+ . #,(syntax-case args ()
+ (() #'())
+ ((arg ... _) (build-clauses #'(arg ...)))))))
+ (syntax-case x ()
+ ((dispatch arg ...)
+ #`(case-lambda
+ #,@(build-clauses #'(arg ...))
+ (args (apply miss args)))))))
+ (arity-case (vector-length fv) 20 dispatch
+ (lambda args
+ (let ((nargs (length args)))
+ (if (< nargs (vector-length fv))
+ (apply (vector-ref fv nargs) args)
+ (apply miss args))))))
+
+;;;
+;;; The above multiple-arity-dispatcher is entirely sufficient, and
+;;; should be fast enough. Still, for no good reason we also have an
+;;; arity dispatcher for generics that are only called with one arity.
+;;;
+(define (single-arity-dispatcher f nargs miss)
+ (define-syntax-rule (dispatch arg ...)
+ (case-lambda
+ ((arg ...) (f arg ...))
+ (args (apply miss args))))
+ (arity-case nargs 20 dispatch
+ (lambda args
+ (if (eqv? (length args) nargs)
+ (apply f args)
+ (apply miss args)))))
+
+;;;
+;;; The guts of generic function dispatch are here. Once we've selected
+;;; an arity, we need to map from arguments to effective method. Until
+;;; we have `eqv?' specializers, this map is entirely a function of the
+;;; types (classes) of the arguments. So, we look in the cache to see
+;;; if we have seen this set of concrete types, and if so we apply the
+;;; previously computed effective method. Otherwise we miss the cache,
+;;; so we'll have to compute the right answer for this set of types, add
+;;; the mapping to the cache, and apply the newly computed method.
+;;;
+;;; The cached mapping is invalidated whenever a new method is defined
+;;; on this generic, or whenever the class hierarchy of any method
+;;; specializer changes.
+;;;
+(define (single-arity-cache-dispatch cache nargs cache-miss)
+ (match cache
+ (() cache-miss)
+ ((#(len types rest? cmethod nargs*) . cache)
+ (define (type-ref n)
+ (and (< n len) (list-ref types n)))
+ (cond
+ ((eqv? nargs nargs*)
+ (let ((cache-miss (single-arity-cache-dispatch cache nargs cache-miss)))
+ (define-syntax args-match?
+ (syntax-rules ()
+ ((args-match?) #t)
+ ((args-match? (arg type) (arg* type*) ...)
+ ;; Check that the arg has the exact type that we saw. It
+ ;; could be that `type' is #f, which indicates the end of
+ ;; the specializers list. Once all specializers have been
+ ;; examined, we don't need to look at any more arguments
+ ;; to know that this is a cache hit.
+ (or (not type)
+ (and (eq? (class-of arg) type)
+ (args-match? (arg* type*) ...))))))
+ (define-syntax dispatch
+ (lambda (x)
+ (define (bind-types types k)
+ (let lp ((types types) (n 0))
+ (syntax-case types ()
+ (() (k))
+ ((type . types)
+ #`(let ((type (type-ref #,n)))
+ #,(lp #'types (1+ n)))))))
+ (syntax-case x ()
+ ((dispatch arg ...)
+ (with-syntax (((type ...) (generate-temporaries #'(arg ...))))
+ (bind-types
+ #'(type ...)
+ (lambda ()
+ #'(lambda (arg ...)
+ (if (args-match? (arg type) ...)
+ (cmethod arg ...)
+ (cache-miss arg ...))))))))))
+ (arity-case nargs 20 dispatch
+ (lambda args
+ (define (args-match? args)
+ (let lp ((args args) (types types))
+ (match types
+ ((type . types)
+ (let ((arg (car args))
+ (args (cdr args)))
+ (and (eq? type (class-of arg))
+ (lp args types))))
+ (_ #t))))
+ (if (args-match? args)
+ (apply cmethod args)
+ (apply cache-miss args))))))
+ (else
+ (single-arity-cache-dispatch cache nargs cache-miss))))))
+
+(define (compute-generic-function-dispatch-procedure gf)
+ (define (seen-arities cache)
+ (let lp ((arities 0) (cache cache))
+ (match cache
+ (() arities)
+ ((#(_ _ _ _ nargs) . cache)
+ (lp (logior arities (ash 1 nargs)) cache)))))
+ (define (cache-miss . args)
+ (memoize-generic-function-application! gf args)
+ (apply gf args))
+ (let* ((cache (slot-ref gf 'effective-methods))
+ (arities (seen-arities cache))
+ (max-arity (let lp ((max -1))
+ (if (< arities (ash 1 (1+ max)))
+ max
+ (lp (1+ max))))))
+ (cond
+ ((= max-arity -1)
+ ;; Nothing in the cache.
+ cache-miss)
+ ((= arities (ash 1 max-arity))
+ ;; Only one arity in the cache.
+ (let ((nargs (match cache ((#(_ _ _ _ nargs) . _) nargs))))
+ (let ((f (single-arity-cache-dispatch cache nargs cache-miss)))
+ (single-arity-dispatcher f nargs cache-miss))))
+ (else
+ ;; Multiple arities.
+ (let ((fv (make-vector (1+ max-arity) #f)))
+ (let lp ((n 0))
+ (when (<= n max-arity)
+ (let ((f (single-arity-cache-dispatch cache n cache-miss)))
+ (vector-set! fv n f)
+ (lp (1+ n)))))
+ (multiple-arity-dispatcher fv cache-miss))))))
+
+(define (recompute-generic-function-dispatch-procedure! gf)
+ (slot-set! gf 'procedure
+ (compute-generic-function-dispatch-procedure gf)))