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))))))