From 8e998f4e5be326a2bc91220e86d555ce79d2890e Mon Sep 17 00:00:00 2001 From: bnewbold Date: Wed, 11 Feb 2009 14:31:28 -0500 Subject: ps02 files --- ps02_generics/generic-sequences.scm | 114 +++++++ ps02_generics/generic-specs.scm | 121 ++++++++ ps02_generics/ghelper.scm | 84 +++++ ps02_generics/ps.txt | 593 ++++++++++++++++++++++++++++++++++++ 4 files changed, 912 insertions(+) create mode 100644 ps02_generics/generic-sequences.scm create mode 100644 ps02_generics/generic-specs.scm create mode 100644 ps02_generics/ghelper.scm create mode 100644 ps02_generics/ps.txt (limited to 'ps02_generics') diff --git a/ps02_generics/generic-sequences.scm b/ps02_generics/generic-sequences.scm new file mode 100644 index 0000000..5e426cf --- /dev/null +++ b/ps02_generics/generic-sequences.scm @@ -0,0 +1,114 @@ +;;;; Generic sequence operator definitions + +;;; First we declare the operators we want to be generic. +;;; Each declaration specifies the arity (number of arguments) +;;; and the default operation, if necessary. + +(define sequence:null + (make-generic-operator 1 #f)) + + +(define sequence:ref + (make-generic-operator 2 #f)) + +(define sequence:size + (make-generic-operator 1 #f)) + +(define sequence:type + (make-generic-operator 1 #f)) + +(define sequence:null? + (make-generic-operator 1 #f)) + +(define sequence:equal? + (make-generic-operator 2 #f)) + +(define sequence:set! + (make-generic-operator 3 #f)) + +(define sequence:subsequence + (make-generic-operator 3 #f)) + + +;;; sequence:append takes multiple arguments. It is defined in terms +;;; of a binary generic append that takes a sequence and a list of sequences. + +(define (sequence:append . sequences) + (if (null? sequences) + (error "Need at least one sequence for append")) + (let ((type? (sequence:type (car sequences)))) + (if (not (for-all? (cdr sequences) type?)) + (error "All sequences for append must be of the same type" + sequences)) + (fold-right generic:binary-append + (sequence:null (sequence:type (car sequences))) + sequences))) + +(define generic:binary-append (make-generic-operator 2 #f)) + +;;; Implementations of the generic operators. + +(define (any? x) #t) +(define (constant val) (lambda (x) val)) +(define (is-exactly val) (lambda (x) (eq? x val))) + +(assign-operation sequence:null (constant "") (is-exactly string?)) +(assign-operation sequence:null (constant '()) (is-exactly list?)) +(assign-operation sequence:null (constant #()) (is-exactly vector?)) + +(assign-operation sequence:ref string-ref string? exact-integer?) +(assign-operation sequence:ref list-ref list? exact-integer?) +(assign-operation sequence:ref vector-ref vector? exact-integer?) + +(assign-operation sequence:size string-length string?) +(assign-operation sequence:size length list?) +(assign-operation sequence:size vector-length vector?) + +(assign-operation sequence:type (constant string?) string?) +(assign-operation sequence:type (constant list?) list?) +(assign-operation sequence:type (constant vector?) vector?) + + +(define (vector-null? v) (= (vector-length v) 0)) + +(assign-operation sequence:null? string-null? string?) +(assign-operation sequence:null? null? list?) +(assign-operation sequence:null? vector-null? vector?) + + +;;; To assign to the ith element of a list: + +(define (list-set! list i val) + (cond ((null? list) + (error "List does not have enough elements" i)) + ((= i 0) (set-car! list val)) + (else (list-set! (cdr list) (- i 1) val)))) + +(assign-operation sequence:set! string-set! string? exact-integer? any?) +(assign-operation sequence:set! list-set! list? exact-integer? any?) +(assign-operation sequence:set! vector-set! vector? exact-integer? any?) + + +(assign-operation sequence:subsequence + substring + string? exact-integer? exact-integer?) +(assign-operation sequence:subsequence + sublist + list? exact-integer? exact-integer?) +(assign-operation sequence:subsequence + subvector + vector? exact-integer? exact-integer?) + + +(define (vector-append v1 v2) + (let ((n1 (vector-length v1)) + (n2 (vector-length v2))) + (make-initialized-vector (+ n1 n2) + (lambda (i) + (if (< i n1) + (vector-ref v1 i) + (vector-ref v2 (- i n1))))))) + +(assign-operation generic:binary-append string-append string? string?) +(assign-operation generic:binary-append append list? list?) +(assign-operation generic:binary-append vector-append vector? vector?) diff --git a/ps02_generics/generic-specs.scm b/ps02_generics/generic-specs.scm new file mode 100644 index 0000000..ad07d96 --- /dev/null +++ b/ps02_generics/generic-specs.scm @@ -0,0 +1,121 @@ +;;;; Generic sequence operations + +;;; There are many kinds of data that can be used to represent sequences: +;;; examples include strings, lists, and vectors. + +;;; There are operations that can be defined for all sequence types. + +;;; Constructing +;;; +;;; (sequence:construct ... ) +;;; Constructs a new sequence of the given type and of size n with +;;; the given elements: item-1 ... item-n + +;;; (sequence:null ) +;;; Produces the null sequence of the given type + + +;;; Selecting +;;; +;;; (sequence:ref ) +;;; Returns the ith element of the sequence. We use zero-based +;;; indexing, so for a sequence of length n the ith item is +;;; referenced by (sequence:ref ). + +;;; (sequence:size ) +;;; Returns the number of elements in the sequence. + +;;; (sequence:type ) +;;; Returns the predicate defining the type of the sequence given. + + +;;; Testing +;;; +;;; (sequence:null? ) +;;; Returns #t if the sequence is null, otherwise returns #f. + +;;; (sequence:equal? ) +;;; Returns #t if the sequences are of the same type and have equal +;;; elements in the same order, otherwise returns #f. + + +;;; Mutation +;;; +;;; Some sequences are immutable, while others can be changed. +;;; +;;; For those that can be modified we can change an element: +;;; +;;; (sequence:set! ) +;;; Sets the ith element of the sequence to v. + +;;; Cutting and Pasting +;;; +;;; (sequence:subsequence ) +;;; The arguments start and end must be exact integers such that +;;; 0 <= start <= end <= (sequence:size ). +;;; Returns a new sequence of the same type as the given sequence, +;;; of size end-start with elements selected from the given sequence. +;;; The new sequence starts with the element of the given sequence +;;; referenced by start. It ends with the element of the given +;;; sequence referenced by end-1. + +;;; (sequence:append ... ) +;;; Requires that the sequences are all of the same type. Returns +;;; a new sequence of the type, formed by concatenating the +;;; elements of the given sequences. The size of the new sequence +;;; is the sum of the sizes of the given sequences. + +;;; Iterators +;;; +;;; (sequence:generate ) +;;; Makes a new sequence of the given sequence type, of size n. +;;; The ith element of the new sequence is the value of the +;;; function at the index i. + +;;; (sequence:map ... ) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the function is n. The ith element +;;; of the new sequence is the value of the function applied to the +;;; n ith elements of the given sequences. + +;;; (sequence:for-each ... ) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the procedure is n. Applies the +;;; procedure to the n ith elements of the given sequences; +;;; discards the value. This is done for effect. + +;;; Filtration and Search +;;; +;;; (sequence:filter ) +;;; Returns a new sequence with exactly those elements of the given +;;; sequence for which the predicate is true (does not return #f). +;;; +;;; (sequence:get-index ) +;;; Returns the index of the first element of the sequence that +;;; satisfies the predicate. Returns #f if no element of the +;;; sequence satisfies the predicate. +;;; +;;; (sequence:get-element ) +;;; Returns the first element of the sequence that satisfies the +;;; predicate. Returns #f if no element of the sequence satisfies +;;; the predicate. + +;;; Accumulation +;;; +;;; (sequence:fold-right ) +;;; Returns the result of applying the given binary function, +;;; from the right, starting with the initial value. +;;; For example, +;;; (sequence:fold-right list 'end '(a b c)) +;;; => (a (b (c end))) + +;;; +;;; (sequence:fold-left ) +;;; Returns the result of applying the given binary function, +;;; starting with the initial value, from the left. +;;; For example, +;;; (sequence:fold-left list 'start '(a b c)) +;;; => (((start a) b) c) + + + 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)))))) diff --git a/ps02_generics/ps.txt b/ps02_generics/ps.txt new file mode 100644 index 0000000..82dfa2a --- /dev/null +++ b/ps02_generics/ps.txt @@ -0,0 +1,593 @@ + + MASSACHVSETTS INSTITVTE OF TECHNOLOGY + Department of Electrical Engineering and Computer Science + + 6.945 Spring 2009 + Problem Set 2 + + Issued: Wed. 11 Feb. 2009 Due: Wed. 18 Feb. 2009 + +Reading: + SICP sections 2.4 and 2.5 + (Tagged data, Data-directed programming, Generic Operations) + + If you are really interested in generic dispatch see the paper + by Ernst, et al. Do not obsess over the formal semantics, what + is really interesting here is the way predicate dispatch can be + used to subsume other kinds of dispatch. +http://pag.csail.mit.edu/~mernst/pubs/dispatching-ecoop98-abstract.html + +Code: ghelper.scm, generic-specs.scm, generic-sequences.scm, attached. + +Documentation: + The MIT/GNU Scheme documentation + online at http://www.gnu.org/software/mit-scheme/ + + + Generic Operations + +In this problem set we will explore a variety of methods we can use for +implementing and exploiting generic operations. + +The procedures in the file ghelper.scm are an elegant mechanism for +implementing generic-operator dispatch, where the handlers for the +generic operators are specified by the predicates that the arguments +satisfy. + +The file generic-specs.scm is an informal programmer's specification +of generic operations that can be defined over a variety of ordered +linear data structures, such as lists, vectors, and strings. + +The file, generic-sequences.scm is a beginning implementation of the +generic operators specified in generic-specs.scm. + +------------- +Problem 2.1: + +Complete the implementation started in generic-sequences.scm to match +the specifications in generic-specs.scm. Demonstrate that each of +your generic operators works as specified, by showing examples. You +should insert your tests as comments in the code you hand in. + +Notice that the types in the underlying Scheme are not uniformly +specified, so this is not entirely trivial: in our seed file, for +example, we had to define vector-null?, list-set!, and vector-append +just to fill out things a bit. +------------- + +Operations like sequence:append can be extended to allow the +combination of unlike sequences. For example, we might expect to be +able to write + + (sequence:append (list 'a 'b 'c) (vector 'd 'e 'f)) + +and get back the list (a b c d e f), assuming that we want a sequence +of the first argument type to be the sequence type of the result. + +One way to implement this sort of thing is to write specific handlers +for all the combinations of types we might want. This may be a large +problem. However, the problem can be mitigated by using coercions, +such as vector->list, list->vector, etc. The cost of doing the +coercions is the construction of a new intermediate data structure +that is not needed in the result. This may or may not be important, +depending on the application. With coercions, we make up and use new +combinators to help construct the generic operator entries: + + (define (compose-1st-arg f g) + (lambda (x y) (f (g x) y))) + + (define (compose-2nd-arg f g) + (lambda (x y) (f x (g y)))) + +Using these we can write such things as: + + (assign-operation generic:binary-append + (compose-2nd-arg vector-append list->vector) + vector? list?) + + (assign-operation generic:binary-append + (compose-2nd-arg append vector->list) + list? vector?) + + +------------- +Problem 2.2: + +Examine the generic specifications. What generalizations that mix +combinations of sequence types may be useful? Amend the specification +document so as to include the generalization. (Turn in the amended +specification sheet with your changes clearly indicated.) Amend your +implementation to make these generalizations. + +Some of the coercions that you may need are provided by Scheme, but +others may need to be written, such as vector->string. (Consult the +online MIT/GNU Scheme reference manual to see what is and is not +provided.) +------------- + +The code for sequence:append illustrates an interesting problem. Our +generic dispatch program does not allow us to make generic operations +with unspecified arity -- that take many arguments -- such as +addition. We programmed around that restriction by defining a binary +generic operation and then using a folding reduction (fold-right) to +extend the binary operation to take an arbitrary number of arguments. +However, the folding reduction needs to know the null sequence of the +type being constructed. Alternatively, we could have extended the +generic dispatch to allow creation of procedures with unspecified +arity. This would allow us to move the folding to the type-specific +procedures rather than make it a wrapper around the binary generic +procedure. + + +------------- +Problem 2.3 + +Is this a good idea? (Please state and argue your opinion.) + +Assuming that we want to do this, what changes would you have to make +in the ghelper.scm file? For example, how would make-generic-operator +have to change? assign-operation? + +We do not want you to actually implement these changes, just think +about what would have to be done and informally describe your +conclusions. +------------- + + +Ben Bitdiddle is pleased with our generic sequences but notes that, +beyond generic N-tuples, it is useful also to have generic sets. He +proposes that we further extend our language with: + + (generic:sequence->set ) + Returns a list corresponding to with no duplicates. + Duplication is determined using EQUAL? (not EQ? nor EQV?). + + The remaining traditional set operations are straightforward: + + (set:equal? ) + (set:union ) + (set:intersection ) + (set:difference ) - E.g. {A,B,C}\{9,B,D}={A,C} + (set:strict-subset? ) + +Alyssa P. Hacker is quick to point out that an efficient way to +implement sets is as sorted, irredundant lists. She adds, ``Of +course, this would require a generic:less? predicate to induce a total +order on the potential set elements.'' + +To that end, Alyssa proposes the following ordering on types of objects: + + null < Boolean < char < number < symbol < string < vector < list + +She notes that MIT Scheme already provides handy implementations of +each of: char len-1 len-2) #f) + ;; Invariant: equal lengths + ((null? list-1) #f) ; same + (else + (or (generic:less? (car list-1) (car list-2)) + (generic:less? (cdr list-1) (cdr list-2))))))) + +Alyssa counters that the following is more appropriate: + +(define (list len-1 len-2) #f) + ;; Invariant: equal lengths + (else + (let prefix ... ) +;;; Constructs a new sequence of the given type and of size n with +;;; the given elements: item-1 ... item-n + +;;; (sequence:null ) +;;; Produces the null sequence of the given type + + +;;; Selecting +;;; +;;; (sequence:ref ) +;;; Returns the ith element of the sequence. We use zero-based +;;; indexing, so for a sequence of length n the ith item is +;;; referenced by (sequence:ref ). + +;;; (sequence:size ) +;;; Returns the number of elements in the sequence. + +;;; (sequence:type ) +;;; Returns the predicate defining the type of the sequence given. + + +;;; Testing +;;; +;;; (sequence:null? ) +;;; Returns #t if the sequence is null, otherwise returns #f. + +;;; (sequence:equal? ) +;;; Returns #t if the sequences are of the same type and have equal +;;; elements in the same order, otherwise returns #f. + + +;;; Mutation +;;; +;;; Some sequences are immutable, while others can be changed. +;;; +;;; For those that can be modified we can change an element: +;;; +;;; (sequence:set! ) +;;; Sets the ith element of the sequence to v. + +;;; Cutting and Pasting +;;; +;;; (sequence:subsequence ) +;;; The arguments start and end must be exact integers such that +;;; 0 <= start <= end <= (sequence:size ). +;;; Returns a new sequence of the same type as the given sequence, +;;; of size end-start with elements selected from the given sequence. +;;; The new sequence starts with the element of the given sequence +;;; referenced by start. It ends with the element of the given +;;; sequence referenced by end-1. + +;;; (sequence:append ... ) +;;; Requires that the sequences are all of the same type. Returns +;;; a new sequence of the type, formed by concatenating the +;;; elements of the given sequences. The size of the new sequence +;;; is the sum of the sizes of the given sequences. + +;;; Iterators +;;; +;;; (sequence:generate ) +;;; Makes a new sequence of the given sequence type, of size n. +;;; The ith element of the new sequence is the value of the +;;; function at the index i. + +;;; (sequence:map ... ) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the function is n. The ith element +;;; of the new sequence is the value of the function applied to the +;;; n ith elements of the given sequences. + +;;; (sequence:for-each ... ) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the procedure is n. Applies the +;;; procedure to the n ith elements of the given sequences; +;;; discards the value. This is done for effect. + +;;; Filtration and Search +;;; +;;; (sequence:filter ) +;;; Returns a new sequence with exactly those elements of the given +;;; sequence for which the predicate is true (does not return #f). +;;; +;;; (sequence:get-index ) +;;; Returns the index of the first element of the sequence that +;;; satisfies the predicate. Returns #f if no element of the +;;; sequence satisfies the predicate. +;;; +;;; (sequence:get-element ) +;;; Returns the first element of the sequence that satisfies the +;;; predicate. Returns #f if no element of the sequence satisfies +;;; the predicate. + +;;; Accumulation +;;; +;;; (sequence:fold-right ) +;;; Returns the result of applying the given binary function, +;;; from the right, starting with the initial value. +;;; For example, +;;; (sequence:fold-right list 'end '(a b c)) +;;; => (a (b (c end))) + +;;; +;;; (sequence:fold-left ) +;;; Returns the result of applying the given binary function, +;;; starting with the initial value, from the left. +;;; For example, +;;; (sequence:fold-left list 'start '(a b c)) +;;; => (((start a) b) c) + +;;;; Generic sequence operator definitions +;;; generic-sequences.scm + +;;; First we declare the operators we want to be generic. +;;; Each declaration specifies the arity (number of arguments) +;;; and the default operation, if necessary. + +(define sequence:null + (make-generic-operator 1 #f)) + + +(define sequence:ref + (make-generic-operator 2 #f)) + +(define sequence:size + (make-generic-operator 1 #f)) + +(define sequence:type + (make-generic-operator 1 #f)) + +(define sequence:null? + (make-generic-operator 1 #f)) + +(define sequence:equal? + (make-generic-operator 2 #f)) + +(define sequence:set! + (make-generic-operator 3 #f)) + +(define sequence:subsequence + (make-generic-operator 3 #f)) + + +;;; sequence:append takes multiple arguments. It is defined in terms +;;; of a binary generic append that takes a sequence and a list of +;;; sequences. + +(define (sequence:append . sequences) + (if (null? sequences) + (error "Need at least one sequence for append")) + (let ((type? (sequence:type (car sequences)))) + (if (not (for-all? (cdr sequences) type?)) + (error "All sequences for append must be of the same type" + sequences)) + (fold-right generic:binary-append (sequence:null type?) sequences))) + +(define generic:binary-append (make-generic-operator 2 #f)) + +;;; Implementations of the generic operators. + +(define (any? x) #t) +(define (constant val) (lambda (x) val)) +(define (is-exactly val) (lambda (x) (eq? x val))) + +(assign-operation sequence:null (constant "") (is-exactly string?)) +(assign-operation sequence:null (constant '()) (is-exactly list?)) +(assign-operation sequence:null (constant #()) (is-exactly vector?)) + +(assign-operation sequence:ref string-ref string? exact-nonnegative-integer?) +(assign-operation sequence:ref list-ref list? exact-nonnegative-integer?) +(assign-operation sequence:ref vector-ref vector? exact-nonnegative-integer?) + +(assign-operation sequence:size string-length string?) +(assign-operation sequence:size length list?) +(assign-operation sequence:size vector-length vector?) + +(assign-operation sequence:type (constant string?) string?) +(assign-operation sequence:type (constant list?) list?) +(assign-operation sequence:type (constant vector?) vector?) + + +(define (vector-null? v) (= (vector-length v) 0)) + +(assign-operation sequence:null? string-null? string?) +(assign-operation sequence:null? null? list?) +(assign-operation sequence:null? vector-null? vector?) + + +;;; To assign to the ith element of a list: + +(define (list-set! list i val) + (cond ((null? list) + (error "List does not have enough elements" i)) + ((= i 0) (set-car! list val)) + (else (list-set! (cdr list) (- i 1) val)))) + +(assign-operation sequence:set! string-set! + string? exact-nonnegative-integer? any?) +(assign-operation sequence:set! list-set! + list? exact-nonnegative-integer? any?) +(assign-operation sequence:set! vector-set! + vector? exact-nonnegative-integer? any?) + +(assign-operation sequence:subsequence substring + string? exact-nonnegative-integer? exact-nonnegative-integer?) + +(assign-operation sequence:subsequence sublist + list? exact-nonnegative-integer? exact-nonnegative-integer?) + +(assign-operation sequence:subsequence subvector + vector? exact-nonnegative-integer? exact-nonnegative-integer?) + + +(define (vector-append v1 v2) + (let ((n1 (vector-length v1)) + (n2 (vector-length v2))) + (make-initialized-vector (+ n1 n2) + (lambda (i) + (if (< i n1) + (vector-ref v1 i) + (vector-ref v2 (- i n1))))))) + +(assign-operation generic:binary-append string-append string? string?) +(assign-operation generic:binary-append append list? list?) +(assign-operation generic:binary-append vector-append vector? vector?) + +;;;; Most General Generic-Operator Dispatch +;;; ghelper.scm + +(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)))))) -- cgit v1.2.3