From 176a888bb42c4815d4fcb4f5adbf16c724052867 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 9 Oct 2007 12:57:18 +0000 Subject: [PATCH] changed the case-> combinator back so that it does not use a symbolic comparison to find -> and friends svn: r7460 --- .../mzlib/private/contract-arr-obj-helpers.ss | 43 ++++++++----------- collects/mzlib/private/contract-arrow.ss | 23 ++++++---- collects/mzlib/private/contract-object.ss | 21 +++++++-- 3 files changed, 51 insertions(+), 36 deletions(-) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 8abcc91b87..52d4d6a099 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -45,7 +45,7 @@ proj-code) first-order-check)))))))))) - (define (make-case->/proc method-proc? stx inferred-name-stx) + (define (make-case->/proc method-proc? stx inferred-name-stx select/h) (syntax-case stx () ;; if there are no cases, this contract should only accept the "empty" case-lambda. @@ -56,7 +56,7 @@ [(_ cases ...) (let-values ([(arguments-check build-projs check-val first-order-check wrapper) - (case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) + (case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)]) (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) (with-syntax ([(inner-check ...) (check-val outer-args)] [(val pos-blame neg-blame src-info orig-str name-id) outer-args] @@ -81,14 +81,14 @@ proj-code) first-order-check)))))))))])) - (define (make-opt->/proc method-proc? stx) + (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) (syntax-case stx (any) [(_ (reqs ...) (opts ...) any) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx)] + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)] [(_ (reqs ...) (opts ...) res) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx)])) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)])) - (define (make-opt->*/proc method-proc? stx inferred-name-stx) + (define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-stx) (syntax-case stx (any) [(_ (reqs ...) (opts ...) any) (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] @@ -106,8 +106,11 @@ (with-syntax ([expanded-case-> (make-case->/proc method-proc? - (syntax (case-> (-> case-doms ... any) ...)) - inferred-name-stx)]) + (with-syntax ([case-> case-arr-stx] + [-> arr-stx]) + (syntax (case-> (-> case-doms ... any) ...))) + inferred-name-stx + select/h)]) (syntax/loc stx (let ([req-vs reqs] ... [opt-vs opts] ...) @@ -140,8 +143,11 @@ (with-syntax ([expanded-case-> (make-case->/proc method-proc? - (syntax (case-> (-> case-doms ... single-case-result) ...)) - inferred-name-stx)]) + (with-syntax ([case-> case-arr-stx] + [-> arr-stx]) + (syntax (case-> (-> case-doms ... single-case-result) ...))) + inferred-name-stx + select/h)]) (set-inferred-name-from stx (syntax/loc stx @@ -210,6 +216,7 @@ ;; case->/h : boolean ;; syntax ;; (listof syntax) + ;; select/h ;; -> (values (syntax -> syntax) ;; (syntax -> syntax) ;; (syntax -> syntax) @@ -218,7 +225,7 @@ ;; (syntax -> syntax)) ;; like the other /h functions, but composes the wrapper functions ;; together and combines the cases of the case-lambda into a single list. - (define (case->/h method-proc? orig-stx cases) + (define (case->/h method-proc? orig-stx cases select/h) (let loop ([cases cases] [name-ids '()]) (cond @@ -1080,20 +1087,6 @@ [(_ x dom rest-x rest-dom rng . result-stuff) (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) - ;; select/h : syntax -> /h-function - (define (select/h stx err-name ctxt-stx) - (syntax-case* stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) (λ (x y) (eq? (syntax-e x) (syntax-e y))) - [(-> . args) ->/h] - [(->* . args) ->*/h] - [(->d . args) ->d/h] - [(->d* . args) ->d*/h] - [(->r . args) ->r/h] - [(->pp . args) ->pp/h] - [(->pp-rest . args) ->pp-rest/h] - [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] - [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) - - ;; set-inferred-name-from : syntax syntax -> syntax (define (set-inferred-name-from with-name to-be-named) (let ([name (syntax-local-infer-name with-name)]) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index d932468430..f805ff1b4a 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -303,20 +303,27 @@ inner-args/body (syntax (dom-x ... rst-x)))))))]))) - #; - (define-syntax-set (->/real ->*/real) - (define (->/real/proc stx) (make-/proc #f ->/h stx)) - (define (->*/real/proc stx) (make-/proc #f ->*/h stx))) + (define-for-syntax (select/h stx err-name ctxt-stx) + (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) + [(-> . args) ->/h] + [(->* . args) ->*/h] + [(->d . args) ->d/h] + [(->d* . args) ->d*/h] + [(->r . args) ->r/h] + [(->pp . args) ->pp/h] + [(->pp-rest . args) ->pp-rest/h] + [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] + [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) (define-syntax (->d stx) (make-/proc #f ->d/h stx)) (define-syntax (->d* stx) (make-/proc #f ->d*/h stx)) (define-syntax (->r stx) (make-/proc #f ->r/h stx)) (define-syntax (->pp stx) (make-/proc #f ->pp/h stx)) (define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx)) - (define-syntax (case-> stx) (make-case->/proc #f stx stx)) - (define-syntax (opt-> stx) (make-opt->/proc #f stx)) - (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx)) - + (define-syntax (case-> stx) (make-case->/proc #f stx stx select/h)) + (define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->)) + (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->)) + ;; ;; arrow opter ;; diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index e62ea6a4ec..62c84bbc7d 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -31,10 +31,25 @@ (define (obj->r/proc stx) (make-/proc #t ->r/h stx)) (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx)) (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx)) - (define (obj-case->/proc stx) (make-case->/proc #t stx stx)) + (define (obj-case->/proc stx) (make-case->/proc #t stx stx select/h)) + + ;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how + ;; I can avoid this duplication -robby + (define (select/h stx err-name ctxt-stx) + (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) + [(-> . args) ->/h] + [(->* . args) ->*/h] + [(->d . args) ->d/h] + [(->d* . args) ->d*/h] + [(->r . args) ->r/h] + [(->pp . args) ->pp/h] + [(->pp-rest . args) ->pp-rest/h] + [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] + [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) + - (define (obj-opt->/proc stx) (make-opt->/proc #t stx)) - (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx)) + (define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->)) + (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->)) (define (object-contract/proc stx)