; ************************************************************************* ; Copyright (c) 1992 Xerox Corporation. ; All Rights Reserved. ; ; Use, reproduction, and preparation of derivative works are permitted. ; Any copy of this software or of any derivative work must include the ; above copyright notice of Xerox Corporation, this paragraph and the ; one after it. Any distribution of this software or derivative works ; must comply with all applicable United States export control laws. ; ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED ; OF THE POSSIBILITY OF SUCH DAMAGES. ; ************************************************************************* ; ; port to R6RS -- 2007 Christian Sloma ; (library (clos std-protocols generic-invocation) (export register-generic-invocation-generics! generic-invocation-generic? generic-compute-apply-generic generic-compute-apply-methods generic-compute-methods generic-compute-method-more-specific?) (import (only (rnrs) define set! or eq? let case-lambda if and quote list car apply lambda list-sort filter cond null? not error else cdr let-values values reverse case cons map let* append begin memq) (clos private method-cache) (clos introspection) (clos private compat)) (define compute-apply-generic #f) (define compute-apply-methods #f) (define compute-methods #f) (define compute-method-more-specific? #f) (define (register-generic-invocation-generics! gf-compute-apply-generic gf-compute-apply-methods gf-compute-methods gf-compute-method-more-specific?) (set! compute-apply-generic gf-compute-apply-generic) (set! compute-apply-methods gf-compute-apply-methods) (set! compute-methods gf-compute-methods) (set! compute-method-more-specific? gf-compute-method-more-specific?)) (define (generic-invocation-generic? obj) (or (eq? obj compute-apply-generic) (eq? obj compute-apply-methods) (eq? obj compute-methods) (eq? obj compute-method-more-specific?))) (define (generic-compute-apply-generic generic) (let ((fallback (and (generic-invocation-generic? generic) (method-procedure (last (generic-methods generic))))) (dispatch (make-cached-dispatch generic (lambda (args) (let ((methods (compute-methods generic args))) (compute-apply-methods generic methods)))))) (case-lambda ((a) (if (and fallback (generic-invocation-generic? a)) (fallback generic '() a) (let ((args (list a))) ((dispatch args) args)))) ((a b) (if (and fallback (generic-invocation-generic? a)) (fallback generic '() a b) (let ((args (list a b))) ((dispatch args) args)))) ((a b c) (if (and fallback (generic-invocation-generic? a)) (fallback generic '() a b c) (let ((args (list a b c))) ((dispatch args) args)))) ((a b c d) (if (and fallback (generic-invocation-generic? a)) (fallback generic '() a b c d) (let ((args (list a b c d))) ((dispatch args) args)))) (args (if (and fallback (generic-invocation-generic? (car args))) (apply fallback generic '() args) ((dispatch args) args)))))) (define (generic-compute-methods generic args) (let ((applicable (filter (lambda (method) (every-2 applicable? (method-specializers method) args)) (generic-methods generic))) (method-more-specific? (compute-method-more-specific? generic args))) (list-sort method-more-specific? applicable))) (define (generic-compute-method-more-specific? generic args) (lambda (m1 m2) (let loop ((specls1 (method-specializers m1)) (specls2 (method-specializers m2)) (args args)) (cond ((and (null? specls1) (null? specls2)) (if (not (eq? (method-qualifier m1) (method-qualifier m2))) #f (error 'compute-method-more-specific? "Two methods are equally specific."))) ((or (null? specls1) (null? specls2)) (error 'compute-method-more-specific? "Two methods have a different number of specializers.")) ((null? args) (error 'compute-method-more-specific? "Fewer arguments than specializers.")) (else (let ((c1 (car specls1)) (c2 (car specls2)) (arg (car args))) (if (eq? c1 c2) (loop (cdr specls1) (cdr specls2) (cdr args)) (more-specific? c1 c2 arg)))))))) (define (generic-compute-apply-methods generic methods) (let-values (((arround-methods before-methods primary-methods after-methods) (sort-methods-by-qualifier methods))) (cond ((null? primary-methods) (compute-apply-no-primary-methods generic)) ((and (null? arround-methods) (null? before-methods) (null? after-methods)) (compute-apply-primary-methods generic primary-methods)) (else (compute-apply-arround-methods generic arround-methods before-methods primary-methods after-methods))))) (define (sort-methods-by-qualifier methods) (let loop ((methods methods) (arround-methods '()) (before-methods '()) (primary-methods '()) (after-methods '())) (if (null? methods) (values (reverse arround-methods) (reverse before-methods) (reverse primary-methods) ;; after-methods are applied ;; in reverse order after-methods) (case (method-qualifier (car methods)) ((arround) (loop (cdr methods) (cons (car methods) arround-methods) before-methods primary-methods after-methods)) ((before) (loop (cdr methods) arround-methods (cons (car methods) before-methods) primary-methods after-methods)) ((primary) (loop (cdr methods) arround-methods before-methods (cons (car methods) primary-methods) after-methods)) ((after) (loop (cdr methods) arround-methods before-methods primary-methods (cons (car methods) after-methods))) (else (error 'apply "wrong method-qualifier" (car methods))))))) (define (compute-apply-no-primary-methods generic) (lambda (args) (error 'apply "No applicable methods." generic args))) (define (compute-apply-primary-methods generic primary-methods) (let ((procs (map method-procedure primary-methods))) (lambda (args) (apply-nested-procs generic procs args)))) (define (compute-apply-arround-methods generic arround-methods before-methods primary-methods after-methods) (let* ((arround-procs (map method-procedure arround-methods)) (before-procs (map method-procedure before-methods)) (primary-procs (map method-procedure primary-methods)) (after-procs (map method-procedure after-methods)) (inner-proc (lambda (generic empty-list . args) (apply-before/after-procs generic before-procs args) (let ((result (apply-nested-procs generic primary-procs args))) (apply-before/after-procs generic after-procs args) result))) (procs (append arround-procs (list inner-proc)))) (lambda (args) (apply-nested-procs generic procs args)))) (define (apply-nested-procs generic procs args) (apply (car procs) generic (cdr procs) args)) (define (apply-before/after-procs generic procs args) (if (not (null? procs)) (begin (apply (car procs) generic '() args) (apply-before/after-procs generic (cdr procs) args)))) (define (applicable? c arg) (memq c (class-precedence-list (class-of arg)))) (define (more-specific? c1 c2 arg) (memq c2 (memq c1 (class-precedence-list (class-of arg))))) ) ;; library (clos std-protocols generic-invocation)