diff options
Diffstat (limited to 'ps02_generics/ghelper.scm')
-rw-r--r-- | ps02_generics/ghelper.scm | 84 |
1 files changed, 84 insertions, 0 deletions
diff --git a/ps02_generics/ghelper.scm b/ps02_generics/ghelper.scm new file mode 100644 index 0000000..c6a7f85 --- /dev/null +++ b/ps02_generics/ghelper.scm @@ -0,0 +1,84 @@ +;;;; Most General Generic-Operator Dispatch + +(declare (usual-integrations)) + +;;; Generic-operator dispatch is implemented here by a discrimination +;;; list, where the arguments passed to the operator are examined by +;;; predicates that are supplied at the point of attachment of a +;;; handler (by ASSIGN-OPERATION). + +;;; To be the correct branch all arguments must be accepted by +;;; the branch predicates, so this makes it necessary to +;;; backtrack to find another branch where the first argument +;;; is accepted if the second argument is rejected. Here +;;; backtracking is implemented by OR. + +(define (make-generic-operator arity default-operation) + (let ((record (make-operator-record arity))) + + (define (operator . arguments) + (if (not (= (length arguments) arity)) + (error:wrong-number-of-arguments operator arity arguments)) + (apply (or (let per-arg + ((tree (operator-record-tree record)) + (args arguments)) + (let per-pred ((tree tree)) + (and (pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (or (per-arg (cdar tree) (cdr args)) + (per-pred (cdr tree))) + (cdar tree)) + (per-pred (cdr tree)))))) + default-operation + (error:no-applicable-methods operator arguments)) + arguments)) + + (hash-table/put! *generic-operator-table* operator record) + operator)) + +(define *generic-operator-table* + (make-eq-hash-table)) + +(define (make-operator-record arity) (cons arity '())) +(define (operator-record-arity record) (car record)) +(define (operator-record-tree record) (cdr record)) +(define (set-operator-record-tree! record tree) (set-cdr! record tree)) + +(define (assign-operation operator handler . argument-predicates) + (let ((record + (let ((record (hash-table/get *generic-operator-table* operator #f)) + (arity (length argument-predicates))) + (if record + (begin + (if (not (= arity (operator-record-arity record))) + (error "Incorrect operator arity:" operator)) + record) + (let ((record (make-operator-record arity))) + (hash-table/put! *generic-operator-table* operator record) + record))))) + (set-operator-record-tree! record + (bind-in-tree argument-predicates + handler + (operator-record-tree record)))) + operator) + +(define (bind-in-tree keys handler tree) + (let loop ((keys keys) (tree tree)) + (let ((p.v (assq (car keys) tree))) + (if (pair? (cdr keys)) + (if p.v + (begin + (set-cdr! p.v + (loop (cdr keys) (cdr p.v))) + tree) + (cons (cons (car keys) + (loop (cdr keys) '())) + tree)) + (if p.v + (begin + (warn "Replacing a handler:" (cdr p.v) handler) + (set-cdr! p.v handler) + tree) + (cons (cons (car keys) handler) + tree)))))) |