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

.

Browse Source 
original commit: e8cba904a3dcf993d861601390b7ffa04b0920ee
This commit is contained in:
Matthew Flatt 2001-07-25 22:44:35 +00:00
parent 4ff0476c11
commit adbc34d59d
3 changed files with 37 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mzlib/unit.ss
View File

@ -694,7 +694,7 @@
(let* ([badsyntax (lambda (s why) (let* ([badsyntax (lambda (s why)
(raise-syntax-error (raise-syntax-error
(if (syntax-e (syntax global?)) (if (syntax-e (syntax global?))
'global-define-values/invoke-unit 'namespace-variable-bind/invoke-unit
'define-values/invoke-unit) 'define-values/invoke-unit)
(format "bad syntax (~a)" why) (format "bad syntax (~a)" why)
(syntax orig) (syntax orig)
@ -740,7 +740,7 @@
. imports))]) . imports))])
(if (syntax-e (syntax global?)) (if (syntax-e (syntax global?))
(syntax (let-values ([(tagged-export ...) invoke-unit]) (syntax (let-values ([(tagged-export ...) invoke-unit])
(global-defined-value 'tagged-export tagged-export) (namespace-variable-binding 'tagged-export tagged-export)
... ...
(void))) (void)))
(syntax (define-values (tagged-export ...) invoke-unit))))))]))) (syntax (define-values (tagged-export ...) invoke-unit))))))])))
@ -754,7 +754,7 @@
[(_ exports unit) [(_ exports unit)
(syntax (do-define-values/invoke-unit #f exports unit #f () orig))])))) (syntax (do-define-values/invoke-unit #f exports unit #f () orig))]))))
(define-syntax global-define-values/invoke-unit (define-syntax namespace-variable-bind/invoke-unit
(lambda (stx) (lambda (stx)
(with-syntax ([orig stx]) (with-syntax ([orig stx])
(syntax-case stx () (syntax-case stx ()
@ -767,4 +767,4 @@
exn:unit? struct:exn:unit make-exn:unit exn:unit? struct:exn:unit make-exn:unit
define-values/invoke-unit define-values/invoke-unit
global-define-values/invoke-unit)) namespace-variable-bind/invoke-unit))

8
collects/mzlib/unitsig.ss
View File

@ -233,7 +233,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ global? signame unite prefix imports orig) [(_ global? signame unite prefix imports orig)
(let* ([formname (if (syntax-e (syntax global?)) (let* ([formname (if (syntax-e (syntax global?))
'global-define-values/invoke-unit/sig 'namespace-variable-bind/invoke-unit/sig
'define-values/invoke-unit/sig)] 'define-values/invoke-unit/sig)]
[badsyntax (lambda (s why) [badsyntax (lambda (s why)
(raise-syntax-error (raise-syntax-error
@ -253,7 +253,7 @@
[im-flattened (flatten-signatures im-sigs)] [im-flattened (flatten-signatures im-sigs)]
[d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))]) [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
(with-syntax ([dv/iu (if (syntax-e (syntax global?)) (with-syntax ([dv/iu (if (syntax-e (syntax global?))
(quote-syntax global-define-values/invoke-unit) (quote-syntax namespace-variable-bind/invoke-unit)
(quote-syntax define-values/invoke-unit))] (quote-syntax define-values/invoke-unit))]
[ex-flattened (d->s ex-flattened)] [ex-flattened (d->s ex-flattened)]
[ex-exploded (d->s ex-exploded)] [ex-exploded (d->s ex-exploded)]
@ -283,7 +283,7 @@
[(_ signame unit) [(_ signame unit)
(syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))])))) (syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))]))))
(define-syntax global-define-values/invoke-unit/sig (define-syntax namespace-variable-bind/invoke-unit/sig
(lambda (stx) (lambda (stx)
(with-syntax ([orig stx]) (with-syntax ([orig stx])
(syntax-case stx () (syntax-case stx ()
@ -316,6 +316,6 @@
(struct unit/sig (unit imports exports)) (struct unit/sig (unit imports exports))
define-values/invoke-unit/sig define-values/invoke-unit/sig
global-define-values/invoke-unit/sig namespace-variable-bind/invoke-unit/sig
provide-signature-elements)) provide-signature-elements))

29
collects/tests/mzscheme/macrolib.ss
View File

@ -107,6 +107,35 @@
(let ([=> 12]) (evcase 3 [3 => 17])) (let ([=> 12]) (evcase 3 [3 => 17]))
(let ([=> 17]) (evcase 3 [3 =>])))) (let ([=> 17]) (evcase 3 [3 =>]))))
(define (opt-lam-test exp expected)
(let ([got (eval exp)])
(unless (equal? got expected)
(printf "FAILED test: ~a~n expected: ~s~n got: ~s~n"
exp expected got))))
(define (opt-lam-test/bad exp expected)
(let ([got (with-handlers ([exn:syntax?
(lambda (exn) (exn-message exn))])
(cons 'got-result (eval exp)))])
(unless (regexp-match expected got)
(printf "FAILED test: ~a~n expected: ~s~n got: ~s~n"
exp expected got))))
(test 1 (opt-lambda (start) start) 1)
(test 1 (opt-lambda ([start 1]) start))
(test 1 (opt-lambda ([start 2]) start) 1)
(test '(1) (opt-lambda args args) 1)
(test '(1) (opt-lambda (x . args) args) 2 1)
(test '(2 1) (opt-lambda ([x 1] . args) (cons x args)) 2 1)
(test '(1) (opt-lambda ([x 1] . args) (cons x args)))
(test '(1 2 3) (opt-lambda ([x 1] . args) (cons x args)) 1 2 3)
(syntax-test #'(opt-lambda))
(syntax-test #'(opt-lambda 1 x))
(syntax-test #'(opt-lambda (x [x 1]) x))
(syntax-test #'(opt-lambda ([x 1] y) x))
(syntax-test #'(opt-lambda (1) x))
(syntax-test #'(opt-lambda ([2 1]) x))
(report-errs) (report-errs)