suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

svn: r2393

Browse Source
This commit is contained in:
Robby Findler 2006-03-08 17:23:45 +00:00
parent 2cdcb9aeb1
commit 7249080888
2 changed files with 25 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mzlib/private/contract-arrow.ss
View File

@ -44,9 +44,12 @@
(if any-range?
(syntax (lambda (args ...) (val (dom-ctc args) ...)))
(syntax (lambda (args ...) (rng-ctc (val (dom-ctc args) ...)))))])
(with-syntax ([inner-lambda (if name
(syntax-property lambda-stx 'inferred-name name)
lambda-stx)])
(with-syntax ([inner-lambda (cond
[(identifier? name)
(syntax-property lambda-stx 'inferred-name (syntax-e name))]
[(symbol? name)
(syntax-property lambda-stx 'inferred-name name)]
[else lambda-stx])])
(with-syntax ([outer-lambda
(syntax
(lambda (chk rng-ctc dom-ctc ...)
@ -100,13 +103,13 @@
(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 (case->/proc stx) (make-case->/proc #f stx))
(define (obj-case->/proc stx) (make-case->/proc #t stx))
(define (case->/proc stx) (make-case->/proc #f stx stx))
(define (obj-case->/proc stx) (make-case->/proc #t stx stx))
(define (obj-opt->/proc stx) (make-opt->/proc #t stx))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx))
(define (opt->/proc stx) (make-opt->/proc #f stx))
(define (opt->*/proc stx) (make-opt->*/proc #f stx))
(define (opt->*/proc stx) (make-opt->*/proc #f stx stx))
;; make-/proc : boolean
;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
@ -136,7 +139,7 @@
(lambda (pos-blame neg-blame src-info orig-str)
proj-code)))))))))))
(define (make-case->/proc method-proc? stx)
(define (make-case->/proc method-proc? stx inferred-name-stx)
(syntax-case stx ()
[(_ cases ...)
(let-values ([(arguments-check build-projs check-val wrapper)
@ -147,7 +150,7 @@
[(body ...) (wrapper outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
stx
inferred-name-stx
(syntax/loc stx (case-lambda body ...)))])
(let ([inner-lambda-w/err-check
(syntax
@ -166,11 +169,11 @@
(define (make-opt->/proc method-proc? stx)
(syntax-case stx (any)
[(_ (reqs ...) (opts ...) any)
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)))]
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx)]
[(_ (reqs ...) (opts ...) res)
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))))]))
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx)]))
(define (make-opt->*/proc method-proc? stx)
(define (make-opt->*/proc method-proc? stx inferred-name-stx)
(syntax-case stx (any)
[(_ (reqs ...) (opts ...) any)
(let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
@ -188,7 +191,8 @@
(with-syntax ([expanded-case->
(make-case->/proc
method-proc?
(syntax (case-> (-> case-doms ... any) ...)))])
(syntax (case-> (-> case-doms ... any) ...))
inferred-name-stx)])
(syntax/loc stx
(let ([req-vs reqs] ...
[opt-vs opts] ...)
@ -221,7 +225,8 @@
(with-syntax ([expanded-case->
(make-case->/proc
method-proc?
(syntax (case-> (-> case-doms ... single-case-result) ...)))])
(syntax (case-> (-> case-doms ... single-case-result) ...))
inferred-name-stx)])
(set-inferred-name-from
stx
(syntax/loc stx

7
collects/tests/mzscheme/contract-test.ss
View File

@ -3307,7 +3307,11 @@
(define contract-inferred-name-test6 (case-lambda [(x) x]
[(x y) y]))
(provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))))
(provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))
(define contract-inferred-name-test7 (case-lambda [(x) (values x x)]
[(x y) (values y y)]))
(provide/contract (contract-inferred-name-test7 (opt->* (number?) (number?) (number? number?))))))
(eval '(require contract-test-suite-inferred-name1))
;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly.
(eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2))
@ -3315,6 +3319,7 @@
(eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4))
(eval '(test 'contract-inferred-name-test5 object-name contract-inferred-name-test5))
(eval '(test 'contract-inferred-name-test6 object-name contract-inferred-name-test6))
(eval '(test 'contract-inferred-name-test7 object-name contract-inferred-name-test7))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;