diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 0ad160f982..ee93bb8ee8 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1302,6 +1302,7 @@ (read-curly-brace-as-paren #f) (read-accept-infix-dot #f) (print-vector-length #f)))) + (define/override (get-transformer-module) #f) (define/override (default-settings) (drscheme:language:make-simple-settings #f 'write 'mixed-fraction-e #f #t 'debug)) (define/override (order-manuals x) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 1ba75f6ed6..1cb2cbbe2d 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -878,7 +878,9 @@ (λ (port) (write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!) (,(if use-copy? 'namespace-require/copy 'namespace-require) ',module-language-spec) - (namespace-transformer-require ',transformer-module-language-spec) + ,@(if transformer-module-language-spec + (list `(namespace-transformer-require ',transformer-module-language-spec)) + (list)) ((dynamic-require ',init-code-mod-name 'init-code))) port)) 'truncate @@ -895,7 +897,8 @@ 'truncate 'text))) (let* ([pre-to-be-embedded-module-specs0 - (if (equal? module-language-spec transformer-module-language-spec) + (if (or (not transformer-module-language-spec) + (equal? module-language-spec transformer-module-language-spec)) (list module-language-spec) (list module-language-spec transformer-module-language-spec))] @@ -1110,7 +1113,8 @@ (if use-copy? (namespace-require/copy module-spec) (namespace-require module-spec)) - (namespace-transformer-require transformer-module-spec))))) + (when transformer-module-spec + (namespace-transformer-require transformer-module-spec)))))) ;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof))) ;; type reader = type-spec-of-read-syntax (see mz manual for details) diff --git a/collects/drscheme/private/launcher-bootstrap.ss b/collects/drscheme/private/launcher-bootstrap.ss index eb2b3c3149..46420a57eb 100644 --- a/collects/drscheme/private/launcher-bootstrap.ss +++ b/collects/drscheme/private/launcher-bootstrap.ss @@ -41,7 +41,8 @@ (current-command-line-arguments program-argv) ((if use-require/copy? namespace-require/copy namespace-require) language-module-spec) - (namespace-transformer-require transformer-module-spec) + (when transformer-module-spec + (namespace-transformer-require transformer-module-spec)) (init-code-proc) diff --git a/collects/r5rs/lang.ss b/collects/r5rs/lang.ss index 1b0f83d302..13c54990de 100644 --- a/collects/r5rs/lang.ss +++ b/collects/r5rs/lang.ss @@ -92,6 +92,8 @@ (rename require #%require) (rename provide #%provide)) + (provide-for-syntax syntax-rules) + (define-syntax synrule-in-stx-module-begin (lambda (stx) (datum->syntax-object diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index be2cb56e7a..644c725e79 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -122,7 +122,9 @@ the settings above should match r5rs (test-expression "(list 1)" "(1)") (test-expression "(car (list))" "{bug09.png} car: expects argument of type ; given ()") - (test-expression "argv" "#0()"))) + (test-expression "argv" "#0()") + + (test-expression "(define-syntax app syntax-case)" "syntax-case: bad syntax in: syntax-case"))) @@ -219,7 +221,8 @@ the settings above should match r5rs (test-expression "(list 1)" "(1)") (test-expression "(car (list))" "{bug09.png} car: expects argument of type ; given ()") - (test-expression "argv" "#0()"))) + (test-expression "argv" "#0()") + (test-expression "(define-syntax app syntax-case)" "syntax-case: bad syntax in: syntax-case"))) @@ -323,7 +326,9 @@ the settings above should match r5rs (test-expression "(car (list))" "{bug09.png} car: expects argument of type ; given ()") - (test-expression "argv" "{bug09.png} reference to undefined identifier: argv"))) + (test-expression "argv" "{bug09.png} reference to undefined identifier: argv") + (test-expression "(define-syntax app syntax-case)" + "compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: syntax-case"))) ;; ; ; @@ -444,7 +449,8 @@ the settings above should match r5rs (test-expression "argv" "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv"))) + "reference to an identifier before its definition: argv") + (test-expression "(define-syntax app syntax-case)" ""))) @@ -567,7 +573,10 @@ the settings above should match r5rs (test-expression "argv" "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv"))) + "reference to an identifier before its definition: argv") + + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name"))) @@ -680,7 +689,9 @@ the settings above should match r5rs (test-expression "(car (list))" "car: expects argument of type ; given empty") (test-expression "argv" "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv"))) + "reference to an identifier before its definition: argv") + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name"))) @@ -793,7 +804,9 @@ the settings above should match r5rs (test-expression "(car (list))" "car: expects argument of type ; given empty") (test-expression "argv" "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv"))) + "reference to an identifier before its definition: argv") + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name"))) @@ -904,7 +917,9 @@ the settings above should match r5rs (test-expression "(car (list))" "car: expects argument of type ; given empty") (test-expression "argv" "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv"))) + "reference to an identifier before its definition: argv") + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name")))