diff --git a/collects/deinprogramm/contract/contract-test-display.ss b/collects/deinprogramm/contract/contract-test-display.ss index ab2907edf2..72b2abe941 100644 --- a/collects/deinprogramm/contract/contract-test-display.ss +++ b/collects/deinprogramm/contract/contract-test-display.ss @@ -12,6 +12,7 @@ string-constants (lib "test-engine/test-info.scm") (lib "test-engine/test-engine.scm") + (lib "test-engine/print.ss") deinprogramm/contract/contract deinprogramm/contract/contract-test-engine) @@ -54,6 +55,25 @@ (send drscheme-frame display-test-panel content) (send curr-win show #f))))))) + (define/public (display-success-summary port count) + (unless (test-silence) + (display (case count + [(0) (string-constant test-engine-0-tests-passed)] + [(1) (string-constant test-engine-1-test-passed)] + [(2) (string-constant test-engine-both-tests-passed)] + [else (format (string-constant test-engine-all-n-tests-passed) + count)]) + port))) + + (define/public (display-untested-summary port) + (unless (test-silence) + (fprintf port (string-constant test-engine-should-be-tested)) + (display "\n" port))) + + (define/public (display-disabled-summary port) + (display (string-constant test-engine-tests-disabled) port) + (display "\n" port)) + (define/public (display-results) (let* ([curr-win (and current-tab (send current-tab get-test-window))] [window (or curr-win (make-object test-window%))] @@ -90,28 +110,34 @@ (send editor insert (cond [(zero? total-checks) zero-message] - [(= 1 total-checks) "Ran 1 check.\n"] - [else (format "Ran ~a checks.\n" total-checks)])) + [(= 1 total-checks) + (string-append (string-constant test-engine-ran-1-check) "\n")] + [else (format (string-append (string-constant test-engine-ran-n-checks) "\n") + total-checks)])) (when (> total-checks 0) (send editor insert (cond [(and (zero? failed-checks) (= 1 total-checks)) - "Check passed!\n\n"] - [(zero? failed-checks) "All checks passed!\n\n"] - [(= failed-checks total-checks) "0 checks passed.\n"] - [else (format "~a of the ~a checks failed.\n\n" + (string-append (string-constant test-engine-1-check-passed) "\n\n")] + [(zero? failed-checks) + (string-append (string-constant test-engine-all-checks-passed) "\n\n")] + [(= failed-checks total-checks) + (string-append (string-constant test-engine-0-checks-passed) "\n")] + [else (format (string-append (string-constant test-engine-m-of-n-checks-failed) "\n\n") failed-checks total-checks)]))) (send editor insert (cond ((null? violated-contracts) - "No contract violations!\n\n") + (string-append (string-constant test-engine-no-contract-violations) "\n\n")) + ((null? (cdr violated-contracts)) + (string-append (string-constant test-engine-1-contract-violation) "\n\n")) (else - (format "~a contract violations.\n\n" + (format (string-append (string-constant test-engine-n-contract-violations) "\n\n") (length violated-contracts))))) )]) (case style [(check-require) - (check-outcomes "This program is unchecked!\n")] + (check-outcomes (string-append (string-constant test-engine-is-unchecked) "\n"))] [else (check-outcomes "")]) (unless (and (zero? total-checks) @@ -126,24 +152,24 @@ (define/public (display-check-failures checks editor test-info src-editor) (when (pair? checks) - (send editor insert "Check failures:\n")) + (send editor insert (string-append (string-constant test-engine-check-failures) "\n"))) (for ([failed-check (reverse checks)]) (send editor insert "\t") (if (failed-check-exn? failed-check) (make-error-link editor - (failed-check-msg failed-check) + (failed-check-reason failed-check) (failed-check-exn? failed-check) - (failed-check-src failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor) (make-link editor - (failed-check-msg failed-check) - (failed-check-src failed-check) + (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor)) (send editor insert "\n"))) (define/public (display-contract-violations violations editor test-info src-editor) (when (pair? violations) - (send editor insert "Contract violations:\n")) + (send editor insert (string-append (string-constant test-engine-contract-violations) "\n"))) (for-each (lambda (violation) (send editor insert "\t") (make-contract-link editor violation src-editor) @@ -154,9 +180,9 @@ ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) - ;; make-link: text% (listof (U string snip%)) src editor -> void - (define (make-link text msg dest src-editor) - (insert-messages text msg) + ;; make-link: text% check-fail src editor -> void + (define (make-link text reason dest src-editor) + (display-reason text reason) (let ((start (send text get-end-position))) (send text insert (format-src dest)) (when (and src-editor current-rep) @@ -165,12 +191,53 @@ (lambda (t s e) (highlight-check-error dest src-editor)) #f #f) (set-clickback-style text start "royalblue")))) - - ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void - (define (make-error-link text msg exn dest src-editor) - (make-link text msg dest src-editor) + + (define (display-reason text fail) + (let* ((print-string + (lambda (m) + (send text insert m))) + (print-formatted + (lambda (m) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + (print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print (string-constant test-engine-check-encountered-error) + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print (string-constant test-engine-actual-value-differs-error) + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print (string-constant test-engine-actual-value-not-within-error) + (formatter (outofrange-test fail)) + (outofrange-range fail) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print (string-constant test-engine-encountered-error-error) + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print (string-constant test-engine-expected-error-error) + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) + + ;; make-error-link: text% check-fail exn src editor -> void + (define (make-error-link text reason exn dest src-editor) + (make-link text reason dest src-editor) (let ((start (send text get-end-position))) - (send text insert "Trace error ") + (send text insert (string-constant test-engine-trace-error)) + (send text insert " ") (when (and src-editor current-rep) (send text set-clickback start (send text get-end-position) @@ -188,8 +255,16 @@ (define (make-contract-link text violation src-editor) (let* ((contract (contract-violation-contract violation)) (stx (contract-syntax contract)) - (srcloc (contract-violation-srcloc violation))) - (insert-messages text (contract-violation-messages violation)) + (srcloc (contract-violation-srcloc violation)) + (message (contract-violation-message violation))) + (cond + ((string? message) + (send text insert message)) + ((contract-got? message) + (insert-messages text (list (string-constant test-engine-got) + " " + ((contract-got-format message) + (contract-got-value message)))))) (when srcloc (send text insert " ") (let ((source (srcloc-source srcloc)) @@ -205,13 +280,16 @@ (highlight-error line column pos span src-editor)) #f #f) (set-clickback-style text start "blue"))) - (send text insert ", contract ") + (send text insert ", ") + (send text insert (string-constant test-engine-contract)) + (send text insert " ") (format-clickable-syntax-src text stx src-editor) (cond ((contract-violation-blame violation) => (lambda (blame) (next-line text) - (send text insert "to blame: procedure ") + (send text insert (string-constant test-engine-to-blame)) + (send text insert " ") (format-clickable-syntax-src text blame src-editor)))))) (define (format-clickable-syntax-src text stx src-editor) @@ -243,18 +321,23 @@ (format-position (car src) (cadr src) (caddr src))) (define (format-position file line column) - (string-append - (if (path? file) - (let-values (((base name must-be-dir?) - (split-path file))) - (if (path? name) - (string-append " in " (path->string name) " at ") - "")) - "") - "at line " (cond [line => number->string] - [else "(unknown)"]) - " column " (cond [column => number->string] - [else "(unknown)"]))) + (let ([line (cond [line => number->string] + [else + (string-constant test-engine-unknown)])] + [col + (cond [column => number->string] + [else (string-constant test-engine-unknown)])]) + + (if (path? file) + (let-values (((base name must-be-dir?) + (split-path file))) + (if (path? name) + (format (string-constant test-engine-in-at-line-column) + (path->string name) line col) + (format (string-constant test-engine-at-line-column) + line col))) + (format (string-constant test-engine-at-line-column) + line col)))) (define (highlight-error line column position span src-editor) (when (and current-rep src-editor) diff --git a/collects/deinprogramm/contract/contract-test-engine.ss b/collects/deinprogramm/contract/contract-test-engine.ss index e62a6fdb15..8c86518af6 100644 --- a/collects/deinprogramm/contract/contract-test-engine.ss +++ b/collects/deinprogramm/contract/contract-test-engine.ss @@ -2,8 +2,9 @@ (provide build-contract-test-engine contract-violation? - contract-violation-obj contract-violation-contract contract-violation-messages - contract-violation-blame contract-violation-srcloc) + contract-violation-obj contract-violation-contract contract-violation-message + contract-violation-blame contract-violation-srcloc + contract-got? contract-got-value contract-got-format) (require scheme/class (lib "test-engine/test-engine.scm") @@ -18,7 +19,7 @@ (class* test-engine% () (super-instantiate ()) (inherit-field test-info test-display) - (inherit setup-info display-untested) + (inherit setup-info display-untested display-disabled) (define display-rep #f) (define display-event-space #f) @@ -72,18 +73,11 @@ [(mixed-results) (display-results display-rep display-event-space)])))) (else - (fprintf port "Tests disabled.\n")))) + (display-disabled port)))) (define/private (display-success port event-space count) (clear-results event-space) - (unless (test-silence) - (fprintf port "~a test~a passed!\n" - (case count - [(0) "Zero"] - [(1) "The only"] - [(2) "Both"] - [else (format "All ~a" count)]) - (if (= count 1) "" "s")))) + (send test-display display-success-summary port count)) (define/override (display-results rep event-space) (cond @@ -98,7 +92,9 @@ )) -(define-struct contract-violation (obj contract messages srcloc blame)) +(define-struct contract-got (value format)) + +(define-struct contract-violation (obj contract message srcloc blame)) (define contract-test-info% (class* test-info-base% () @@ -123,13 +119,12 @@ (make-srcloc source line col pos span)) mark))) (else #f))) - (messages - (if message - (list message) - (list "got " ((test-format) obj))))) + (message + (or message + (make-contract-got obj (test-format))))) (set! contract-violations - (cons (make-contract-violation obj contract messages srcloc blame) + (cons (make-contract-violation obj contract message srcloc blame) contract-violations))) (inner (void) contract-failed obj contract message)) diff --git a/collects/drscheme/private/bindings-browser.ss b/collects/drscheme/private/bindings-browser.ss index 5dffcb066b..9a2b5181ef 100644 --- a/collects/drscheme/private/bindings-browser.ss +++ b/collects/drscheme/private/bindings-browser.ss @@ -15,7 +15,6 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto mred mzlib/match mzlib/string - stepper/private/marks mzlib/contract) (provide render-bindings/snip) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index c2a10f4065..03de70254b 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -467,7 +467,8 @@ the state transitions / contracts are: (string-constant automatically-to-ps) (λ (b) (if b 'postscript 'standard)) - (λ (n) (eq? 'postscript n)))))))]) + (λ (n) (eq? 'postscript n)))) + (general-panel-procs editor-panel))))]) (add-general-checkbox-panel))) (define (add-warnings-checkbox-panel) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index a27b834dfb..2bed6520da 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -766,41 +766,43 @@ system looks for certain names in that file: @itemize[ -@item{The @scheme['blurb] field: If present, the blurb field should contain a list of XHTML fragments -encoded as x-expressions (see the xml collection for details) that -PLaneT will use as a short description of your project.} +@item{The @indexed-scheme['blurb] field: If present, the blurb field +should contain a list of XHTML fragments encoded as x-expressions (see +the xml collection for details) that PLaneT will use as a short +description of your project.} -@item{The @scheme['release-notes] field: If present, the release-notes field should contain a list of XHTML -fragments encoded as x-expressions (see the xml collection for -details) that PLaneT will use as a short description of what's new -in this release of your package.} +@item{The @indexed-scheme['release-notes] field: If present, the +release-notes field should contain a list of XHTML fragments encoded +as x-expressions (see the xml collection for details) that PLaneT will +use as a short description of what's new in this release of your +package.} -@item{The @scheme['categories] field: -If present, the categories field should be a list of symbols -corresponding to the categories under which this package should be listed. +@item{The @indexed-scheme['categories] field: If present, the categories +field should be a list of symbols corresponding to the categories +under which this package should be listed. The valid categories are: @itemize[ - @item{@scheme['devtools]: Development Tools} - @item{@scheme['net]: Networking and Protocols} - @item{@scheme['media]: Graphics and Audio} - @item{@scheme['xml]: XML-Related} - @item{@scheme['datastructures]: Data Structures and Algorithms} - @item{@scheme['io]: Input/Output and Filesystem} - @item{@scheme['scientific]: Mathematical and Scientific} - @item{@scheme['system]: Hardware/Operating System-Specific Tools} - @item{@scheme['ui]: Textual and Graphical User Interface} - @item{@scheme['metaprogramming]: Metaprogramming Tools} - @item{@scheme['planet]: PLaneT-Related} - @item{@scheme['misc]: Miscellaneous}] + @item{@indexed-scheme['devtools]: Development Tools} + @item{@indexed-scheme['net]: Networking and Protocols} + @item{@indexed-scheme['media]: Graphics and Audio} + @item{@indexed-scheme['xml]: XML-Related} + @item{@indexed-scheme['datastructures]: Data Structures and Algorithms} + @item{@indexed-scheme['io]: Input/Output and Filesystem} + @item{@indexed-scheme['scientific]: Mathematical and Scientific} + @item{@indexed-scheme['system]: Hardware/Operating System-Specific Tools} + @item{@indexed-scheme['ui]: Textual and Graphical User Interface} + @item{@indexed-scheme['metaprogramming]: Metaprogramming Tools} + @item{@indexed-scheme['planet]: PLaneT-Related} + @item{@indexed-scheme['misc]: Miscellaneous}] If you put symbols other than these the categories field, they will be ignored. If you put no legal symbols in the categories field or do not include this field in your info.ss file, your package will be categorized as "Miscellaneous."} -@item{The @scheme['can-be-loaded-with] field: +@item{The @indexed-scheme['can-be-loaded-with] field: If present, the can-be-loaded-with field should be a quoted datum of one of the following forms: @@ -819,13 +821,13 @@ particular file and assumes that nothing else writes to that same file, then multiple versions of the same package being loaded simultaneously may be a problem. This field allows you to specify whether your package can be loaded simultaneously with older versions -of itself. If its value is @scheme['all], then the package may be loaded with -any older version. If it is @scheme['none], then it may not be loaded with -older versions at all. If it is @scheme[(list 'all-except VER-SPEC ...)] then -any package except those that match one of the given VER-SPEC forms -may be loaded with this package; if it is @scheme[(list 'only VER-SPEC ...)] -then only packages that match one of the given VER-SPEC forms may be -loaded with this package. +of itself. If its value is @indexed-scheme['all], then the package may be +loaded with any older version. If it is @indexed-scheme['none], then it +may not be loaded with older versions at all. If it is @scheme[(list +'all-except VER-SPEC ...)] then any package except those that match +one of the given VER-SPEC forms may be loaded with this package; if it +is @scheme[(list 'only VER-SPEC ...)] then only packages that match +one of the given VER-SPEC forms may be loaded with this package. When checking to see if a package may be loaded, PLaneT compares it to all other currently-loaded instances of the same package with any @@ -834,16 +836,16 @@ can-be-loaded-with field allows the older package to be loaded. If all such comparisons succeed then the new package may be loaded; otherwise PLaneT signals an error. -The default for this field is @scheme['none] as a conservative protection -measure. For many packages it is safe to set this field to -@scheme['any].} +The default for this field is @indexed-scheme['none] as a conservative +protection measure. For many packages it is safe to set this field to +@indexed-scheme['any].} -@item{The @scheme['homepage] field: +@item{The @indexed-scheme['homepage] field: If present, the URL field should be a string corresponding to a URL for the package. PLaneT provides this link with the description of your package on the main PLaneT web page.} -@item{The @scheme['primary-file] field: +@item{The @indexed-scheme['primary-file] field: If present, the primary-file field should be a either a string corresponding to the name (without path) of the main Scheme source file of your package, or a list of such strings. The PLaneT web page @@ -856,7 +858,7 @@ If you include only a single string, it will be used as the require line printed on your package's page. If you include a list of strings, then the first legal file string in the list will be used.} -@item{The @scheme['required-core-version] field: If present, the +@item{The @indexed-scheme['required-core-version] field: If present, the required-core-version field should be a string with the same syntax as the output of the @scheme[version] function. Defining this field indicates that PLaneT should only allow users of a version of mzscheme @@ -866,14 +868,14 @@ requirements than its inclusion in a particular repository; for instance, setting this field to @scheme["300.2"] would cause the PLaneT server not to serve it to MzScheme v300.1 or older clients.} -@item{The @scheme['version] field: +@item{The @indexed-scheme['version] field: If present, the version field should be a string that describes the version number of this code that should be presented to users (e.g., @scheme["0.15 alpha"]). This field does not override or in any way interact with your package's package version number, which is assigned by PLaneT, but may be useful to users.} -@item{The @scheme['repositories] field: If present, the repositories +@item{The @indexed-scheme['repositories] field: If present, the repositories field should be a list consisting of some subset of the strings @scheme["4.x"] and @scheme["3xx"]. The string @scheme["4.x"] indicates that this package should be included in the v4.x repository (which @@ -886,9 +888,9 @@ multiple repositories with the same PLaneT version number.}] In addition, PLaneT uses the setup-plt installer to install packages on client machines, so most fields it looks for can be included with -their usual effects. In particular, adding a @scheme['name] field indicates that -the Scheme files in the package should be compiled during -installation; it is a good idea to add it. +their usual effects. In particular, adding a @indexed-scheme['name] +field indicates that the Scheme files in the package should be +compiled during installation; it is a good idea to add it. An example info.ss file looks like this: diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index cd96ba7833..699aa89569 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -96,23 +96,17 @@ ;; extend-preferences-panel : vertical-panel -> void ;; adds in the configuration for the Java colors to the prefs panel - (define (extend-preferences-panel parent) - (let ((standard-color-prefs - (make-object group-box-panel% (string-constant profj-java-mode-color-heading) parent)) - (coverage-color-panel - (make-object group-box-panel% (string-constant profj-coverage-color-heading) parent)) - (put - (lambda (p) - (lambda (line) - (let ([sym (car line)] - [str (caddr line)]) - (color-prefs:build-color-selection-panel - p - (short-sym->pref-name sym) - (short-sym->style-name sym) - str)))))) - (for-each (put standard-color-prefs) color-prefs-table) - (for-each (put coverage-color-panel) coverage-color-prefs))) + (define ((extend-preferences-panel color-table) parent) + (let ((put + (lambda (line) + (let ([sym (car line)] + [str (caddr line)]) + (color-prefs:build-color-selection-panel + parent + (short-sym->pref-name sym) + (short-sym->style-name sym) + str))))) + (for-each put color-table))) (define mode-surrogate% (class color:text-mode% @@ -1230,7 +1224,10 @@ ;; (drscheme:modes:add-mode (string-constant profj-java-mode) mode-surrogate repl-submit matches-language) - (color-prefs:add-to-preferences-panel (string-constant profj-java) extend-preferences-panel) + (color-prefs:add-to-preferences-panel (string-constant profj-java) + (extend-preferences-panel color-prefs-table)) + (color-prefs:add-to-preferences-panel (string-constant profj-java-coverage) + (extend-preferences-panel coverage-color-prefs)) (define (register line) (let ([sym (car line)] diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index f445aaabf6..6404d5bb5b 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/collects/rnrs/syntax-case-6.ss @@ -2,10 +2,10 @@ (require (for-syntax scheme/base) r6rs/private/qq-gen - scheme/stxparam scheme/mpair r6rs/private/exns - (for-syntax r6rs/private/check-pattern)) + (for-syntax syntax/template + r6rs/private/check-pattern)) (provide make-variable-transformer (rename-out [r6rs:syntax-case syntax-case] @@ -138,35 +138,6 @@ ;; Also, R6RS doesn't have (... ) quoting in patterns --- only ;; in templates. <<<< FIXME -(define-syntax-parameter pattern-vars null) - -(provide pattern-vars) - -(define-for-syntax (add-pattern-vars ids) - (append (syntax->list ids) - (syntax-parameter-value (quote-syntax pattern-vars)))) - -;; ---------------------------------------- - -(define-for-syntax (extract-pattern-ids stx lits) - (syntax-case stx () - [(a . b) (append (extract-pattern-ids #'a lits) - (extract-pattern-ids #'b lits))] - [#(a ...) (apply append - (map (lambda (a) - (extract-pattern-ids a lits)) - (syntax->list #'(a ...))))] - [a - (identifier? #'a) - (if (or (ormap (lambda (lit) - (free-identifier=? lit #'a)) - lits) - (free-identifier=? #'a #'(... ...)) - (free-identifier=? #'a #'_)) - null - (list #'a))] - [_ null])) - (define-syntax (r6rs:syntax-case stx) (syntax-case stx () [(_ expr (lit ...) clause ...) @@ -194,186 +165,58 @@ . #,(map (lambda (clause) (syntax-case clause () [(pat val) - (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + (begin ((check-pat-ellipses stx) #'pat) - #`(pat (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - val)))] + #`(pat val))] [(pat fender val) - (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + (begin ((check-pat-ellipses stx) #'pat) - #`(pat (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - fender) - (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - val)))] + #`(pat fender val))] [else clause])) (syntax->list #'(clause ...))))))] [(_ . rest) (syntax/loc stx (syntax-case . rest))])) ;; ---------------------------------------- -(define-for-syntax (make-unwrap-map tmpl pattern-vars) - (let loop ([tmpl tmpl] - [in-ellipses? #f] - [counting? #f]) - (syntax-case tmpl () - [(ellipses expr) - (and (not in-ellipses?) - (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (loop #'expr #t #f)] - [(expr ellipses . rest) - (and (not in-ellipses?) - (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (box (cons (loop #'expr #f #f) - (let rloop ([rest #'rest]) - (syntax-case rest () - [(ellipses . rest) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - ;; keep going: - (rloop #'rest)] - [else (loop rest #f #t)]))))] - [(a . b) (let ([a (loop #'a in-ellipses? #f)] - [b (loop #'b in-ellipses? counting?)]) - (if (or a b counting?) - (cons a b) - #f))] - [#(a ...) (let ([as (loop (syntax->list #'(a ...)) - in-ellipses? - #f)]) - (and as (vector as)))] - [a - (identifier? #'a) - (ormap (lambda (pat-var) - (free-identifier=? #'a pat-var)) - pattern-vars)] - [_ #f]))) +(define (unwrap-reconstructed data stx datum) + datum) -(define-for-syntax (group-ellipses tmpl umap) - (define (stx-cdr s) (if (syntax? s) (cdr (syntax-e s)) (cdr s))) - (let loop ([tmpl tmpl][umap umap]) - (if (not umap) - tmpl - (syntax-case tmpl () - [(ellipses expr) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - tmpl] - [(expr ellipses . rest) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (let rloop ([rest (stx-cdr (stx-cdr tmpl))] - [accum (list #'ellipses (loop #'expr - (car (unbox umap))))]) - (syntax-case rest () - [(ellipses . _) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - ;; keep going: - (rloop (stx-cdr rest) (cons #'ellipses accum))] - [_ (cons (datum->syntax #f (reverse accum)) - (loop rest (cdr (unbox umap))))]))] - [(a . b) (let ([n (cons (loop #'a (car umap)) - (loop (cdr (if (syntax? tmpl) - (syntax-e tmpl) - tmpl)) - (cdr umap)))]) - (if (syntax? tmpl) - (datum->syntax tmpl n tmpl tmpl tmpl) - n))] - [#(a ...) (datum->syntax - tmpl - (list->vector (loop (syntax->list #'(a ...)) - (vector-ref umap 0))) - tmpl - tmpl - tmpl)] - [_ tmpl])))) +(define (unwrap-pvar data stx) + ;; unwrap based on srcloc: + (let loop ([v stx]) + (cond + [(syntax? v) + (if (eq? (syntax-source v) unwrapped-tag) + (loop (syntax-e v)) + v)] + [(pair? v) (mcons (loop (car v)) + (loop (cdr v)))] + [(vector? v) (list->vector + (map loop (vector->list v)))] + [else v]))) -(define (unwrap stx mapping) - (cond - [(not mapping) - ;; In case stx is a pair, explicitly convert - (datum->syntax #f (convert-mpairs stx))] - [(eq? mapping #t) - ;; was a pattern var; unwrap based on srcloc: - (let loop ([v stx]) - (cond - [(syntax? v) - (if (eq? (syntax-source v) unwrapped-tag) - (loop (syntax-e v)) - v)] - [(pair? v) (mcons (loop (car v)) - (loop (cdr v)))] - [(vector? v) (list->vector - (map loop (vector->list v)))] - [else v]))] - [(pair? mapping) - (let ([p (if (syntax? stx) - (syntax-e stx) - stx)]) - (mcons (unwrap (car p) (car mapping)) - (unwrap (cdr p) (cdr mapping))))] - [(vector? mapping) - (list->vector (let loop ([v (unwrap (vector->list (syntax-e stx)) - (vector-ref mapping 0))]) - (cond - [(null? v) null] - [(mpair? v) (cons (mcar v) (loop (mcdr v)))] - [(syntax? v) (syntax->list v)])))] - [(null? mapping) null] - [(box? mapping) - ;; ellipses - (let* ([mapping (unbox mapping)] - [rest-mapping (cdr mapping)] - [p (if (syntax? stx) (syntax-e stx) stx)] - [repeat-stx (car p)] - [rest-stx (cdr p)]) - (let ([repeats (list->mlist - (map (lambda (rep) - (unwrap rep (car mapping))) - (syntax->list repeat-stx)))] - [rest-mapping - ;; collapse #fs to single #f: - (if (let loop ([rest-mapping rest-mapping]) - (if (pair? rest-mapping) - (if (not (car rest-mapping)) - (loop (cdr rest-mapping)) - #f) - (not rest-mapping))) - #f - rest-mapping)]) - - (if (and (not rest-mapping) - (or (null? rest-stx) - (and (syntax? rest-stx) - (null? (syntax-e rest-stx))))) - repeats - (mappend repeats - (unwrap rest-stx rest-mapping)))))] - [else (error 'unwrap "strange unwrap mapping: ~e" mapping)])) +(define (leaf-to-syntax datum) + (datum->syntax #f datum)) + +(define (ellipses-end stx) + ;; R6RS says that (x ...) must be a list, so we need a special rule + (if (and (syntax? stx) (null? (syntax-e stx))) + null + stx)) + +(define-for-syntax (no-data x) #f) (define-syntax (r6rs:syntax stx) (syntax-case stx () - [(_ tmpl) - (let ([umap (make-unwrap-map #'tmpl - (syntax-parameter-value #'pattern-vars))]) - (quasisyntax/loc stx - (unwrap (if #f - ;; Process tmpl first, so that syntax errors are reported - ;; usinf the original source. - #,(syntax/loc stx (syntax tmpl)) - ;; Convert tmpl to group ...-created repetitions together, - ;; so that `unwrap' can tell which result came from which - ;; template: - #,(with-syntax ([tmpl (group-ellipses #'tmpl umap)]) - (syntax/loc stx (syntax tmpl)))) - '#,umap)))] - [(_ . rest) (syntax/loc stx (syntax . rest))])) + [(_ template) + (transform-template #'template + #:constant-as-leaf? #t + #:save (lambda (x) #f) + #:restore-stx #'unwrap-reconstructed + #:leaf-datum-stx #'leaf-to-syntax + #:pvar-restore-stx #'unwrap-pvar + #:cons-stx #'mcons + #:ellipses-end-stx #'ellipses-end)])) ;; ---------------------------------------- diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 469ce825f5..cf8b4d4c83 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -219,14 +219,12 @@ ids))] [add-package-context (lambda (def-ctxes) (lambda (stx) - (for/fold ([stx stx]) - ([def-ctx (in-list (reverse def-ctxes))]) - (let ([q (local-expand #`(quote #,stx) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ stx) #'stx])))))]) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctxes)]) + (syntax-case q () + [(_ stx) #'stx]))))]) (let loop ([exprs init-exprs] [rev-forms null] [def-ctxes (list def-ctx)]) @@ -293,11 +291,10 @@ (lambda () (list (quote-syntax hidden) ...)))))))))))] [else - (let ([expr ((add-package-context (cdr def-ctxes)) - (local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) - ctx - kernel-forms - (car def-ctxes)))]) + (let ([expr (local-expand (car exprs) + ctx + kernel-forms + def-ctxes)]) (syntax-case expr (begin) [(begin . rest) (loop (append (flatten-begin expr) (cdr exprs)) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 6de5d4e53f..74408bc4a8 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -837,10 +837,9 @@ v4 todo: (define (->d-proj ->d-stct) (let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))] - [mandatory-count (length (->d-mandatory-dom-ctcs ->d-stct))] - [non-kwd-ctc-count (+ mandatory-count - opt-count - (if (->d-mtd? ->d-stct) 1 0))] + [mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) + (if (->d-mtd? ->d-stct) 1 0))] + [non-kwd-ctc-count (+ mandatory-count opt-count)] [arity (cond [(->d-rest-ctc ->d-stct) @@ -988,7 +987,7 @@ v4 todo: arity (->d-mandatory-keywords ->d-stct) - (->d-optional-keywords ->d-stct)))))))) + (->d-keywords ->d-stct)))))))) ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst (define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str) diff --git a/collects/scheme/private/sc.ss b/collects/scheme/private/sc.ss index 10f2a8b788..04ba3b1dff 100644 --- a/collects/scheme/private/sc.ss +++ b/collects/scheme/private/sc.ss @@ -507,7 +507,7 @@ (set! cnt (add1 cnt)) (string->symbol (format "~a~a" prefix cnt))))) ;; The pattern expander: - (-define (expander p proto-r local-top use-ellipses? use-tail-pos hash!) + (-define (expander p proto-r local-top use-ellipses? use-tail-pos hash! need-list?) (cond [(and use-ellipses? (ellipsis? p)) (let*-values ([(p-head) (stx-car p)] @@ -559,8 +559,9 @@ (pick-specificity top last-el))))] - [rest (expander rest-p proto-r local-top #t use-tail-pos hash!)] - [ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash!)]) + [rest (expander rest-p proto-r local-top #t use-tail-pos hash! need-list?)] + [ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash! + (or need-list? (positive? el-count)))]) (if proto-r `(lambda (r) ,(let ([pre (let ([deeps @@ -597,10 +598,11 @@ (sub1 el-count))))]) (wrap `(map - (lambda vals (,ehead - ,(if (null? proto-rr-shallow) - 'vals - '(append shallows vals)))) + (lambda vals + (,ehead + ,(if (null? proto-rr-shallow) + 'vals + '(append shallows vals)))) ,@valses) el-count))]))]) (if (null? proto-rr-shallow) @@ -611,9 +613,17 @@ proto-rr-shallow))]) ,deeps)))] [post (apply-to-r rest)]) - (if (eq? post 'null) - pre - `(append ,pre ,post)))) + (let ([v (if (eq? post 'null) + pre + `(append ,pre ,post))]) + (if (and (not need-list?) (syntax? p)) + ;; Keep srcloc, properties, etc.: + (let ([small-dest (datum->syntax p + 'dest + p + p)]) + `(datum->syntax/shape (quote-syntax ,small-dest) ,v)) + v)))) ;; variables were hashed (void))))] [(stx-pair? p) @@ -623,21 +633,21 @@ (if (and (stx-pair? (stx-cdr p)) (stx-null? (stx-cdr (stx-cdr p)))) (let ([dp (stx-car (stx-cdr p))]) - (expander dp proto-r dp #f use-tail-pos hash!)) + (expander dp proto-r dp #f use-tail-pos hash! need-list?)) (raise-syntax-error 'syntax "misplaced ellipses in template" top hd)) - (let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash!)] - [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash!)]) + (let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash! #f)] + [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash! need-list?)]) (if proto-r `(lambda (r) ,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym)) ;; variables were hashed (void)))))] [(stx-vector? p #f) - (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash!)]) + (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) (list->vector (stx->list ,(apply-to-r e)))) @@ -646,7 +656,7 @@ [(and (syntax? p) (struct? (syntax-e p)) (prefab-struct-key (syntax-e p))) - (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash!)]) + (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) (stx->list ,(apply-to-r e)))) @@ -697,7 +707,8 @@ l))]) (if pr (set-mcdr! pr (cons r (mcdr pr))) - (hash-set! ht (syntax-e r) (cons (mcons r (list r)) l))))))))]) + (hash-set! ht (syntax-e r) (cons (mcons r (list r)) l))))))) + #f)]) (if proto-r `(lambda (r) ,(let ([main (let ([build (apply-to-r l)]) @@ -808,9 +819,10 @@ `(pattern-substitute (quote-syntax ())) p sub-gensym)] + [(and (pair? t) (eq? (car t) 'quote-syntax) - (stx-smaller-than? (car t) 10)) + (stx-smaller-than? (cdr t) 10)) ;; Shift into `pattern-substitute' mode with an intitial constant. ;; (Only do this for small constants, so we don't traverse ;; big constants when looking for substitutions.) @@ -1028,7 +1040,7 @@ (stx-car stx))))))) (-define (make-syntax-mapping depth valvar) (make-set!-transformer (-make-syntax-mapping depth valvar))) - (-define (syntax-mapping? v) + (-define (syntax-pattern-variable? v) (and (set!-transformer? v) (-syntax-mapping? (set!-transformer-procedure v)))) (-define (syntax-mapping-depth v) @@ -1038,6 +1050,6 @@ (#%provide (protect make-match&env get-match-vars make-interp-match make-pexpand - make-syntax-mapping syntax-mapping? + make-syntax-mapping syntax-pattern-variable? syntax-mapping-depth syntax-mapping-valvar stx-memq-pos no-ellipses?))) diff --git a/collects/scheme/private/stxcase-scheme.ss b/collects/scheme/private/stxcase-scheme.ss index a091315538..53eb04f0f1 100644 --- a/collects/scheme/private/stxcase-scheme.ss +++ b/collects/scheme/private/stxcase-scheme.ss @@ -60,4 +60,5 @@ (#%provide syntax (all-from "with-stx.ss") (all-from "stxloc.ss") check-duplicate-identifier - syntax-rules syntax-id-rules)) + syntax-rules syntax-id-rules + (for-syntax syntax-pattern-variable?))) diff --git a/collects/scheme/private/stxcase.ss b/collects/scheme/private/stxcase.ss index f6261c0e16..39008d7bd7 100644 --- a/collects/scheme/private/stxcase.ss +++ b/collects/scheme/private/stxcase.ss @@ -491,7 +491,7 @@ (map (lambda (var) (and (let ([v (syntax-local-value var (lambda () #f))]) - (and (syntax-mapping? v) + (and (syntax-pattern-variable? v) v)))) unique-vars)]) (if (and (or (null? var-bindings) @@ -556,4 +556,5 @@ (cons (quote-syntax list*) r)])))))))))) x))) - (#%provide (all-from "ellipses.ss") syntax-case** syntax)) + (#%provide (all-from "ellipses.ss") syntax-case** syntax + (for-syntax syntax-pattern-variable?))) diff --git a/collects/scheme/private/stxloc.ss b/collects/scheme/private/stxloc.ss index 35ccaae5a7..a4b51be4ce 100644 --- a/collects/scheme/private/stxloc.ss +++ b/collects/scheme/private/stxloc.ss @@ -38,7 +38,7 @@ (syntax-case** #f #t stx () free-identifier=? [(_ loc pattern) (if (if (symbol? (syntax-e #'pattern)) - (syntax-mapping? (syntax-local-value #'pattern (lambda () #f))) + (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) #f) (syntax (syntax pattern)) (syntax (relocate loc (syntax pattern))))]))) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index 1186ed6305..86321b198a 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -56,7 +56,7 @@ (cadddr (cdr stx/binding)))))])]) (and (pair? b) - (let ([seen (make-hasheq)] + (let ([seen (make-hash)] [search-key #f]) (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))] [rqueue null] @@ -99,7 +99,7 @@ (loop queue rqueue need-result?) ;; Check parents, if we can get the source: (if (and (path? (resolved-module-path-name rmp)) - (not (hash-ref seen rmp #f))) + (not (hash-ref seen (cons export-phase rmp) #f))) (let ([exports (hash-ref module-info-cache @@ -130,7 +130,7 @@ (cdr stxess))]))]) (hash-set! module-info-cache rmp t) t))))]) - (hash-set! seen rmp #t) + (hash-set! seen (cons export-phase rmp) #t) (let ([a (assq id (let ([a (assoc export-phase exports)]) (if a (cdr a) @@ -149,7 +149,7 @@ 0 0 0))) - (cadr a)) + (reverse (cadr a))) rqueue) need-result?) (begin @@ -158,9 +158,9 @@ ;; for now. #; (error 'find-scheme-tag - "dead end when looking for binding source: ~e" - id) - #f)))) + "dead end when looking for binding source: ~e" + id) + (loop queue rqueue need-result?))))) ;; Can't get the module source, so continue with queue: (loop queue rqueue need-result?)))]) (or here-result diff --git a/collects/scribblings/reference/chars.scrbl b/collects/scribblings/reference/chars.scrbl index 2f35d15017..0c163335dd 100644 --- a/collects/scribblings/reference/chars.scrbl +++ b/collects/scribblings/reference/chars.scrbl @@ -7,10 +7,12 @@ @guideintro["characters"]{characters} -@deftech{Characters} range over Unicode scalar values, which includes +@deftech{Characters} range over Unicode +@index['("scalar value")]{scalar values}, which includes characters whose values range from @schemevalfont{#x0} to @schemevalfont{#x10FFFF}, but not including @schemevalfont{#xD800} to -@schemevalfont{#xDFFF}. +@schemevalfont{#xDFFF}. The scalar values are a subset of the Unicode +@index['("code point")]{code points}. Two characters are @scheme[eqv?] if they correspond to the same scalar value. For each scalar value less than 256, character values that are diff --git a/collects/scribblings/reference/hashes.scrbl b/collects/scribblings/reference/hashes.scrbl index 72d88b6df3..75b3f9e023 100644 --- a/collects/scribblings/reference/hashes.scrbl +++ b/collects/scribblings/reference/hashes.scrbl @@ -21,8 +21,11 @@ A @deftech{hash table} (or simply @deftech{hash}) maps each of its keys to a single value. For a given hash table, keys are equivalent via @scheme[equal?], @scheme[eqv?], or @scheme[eq?], and keys are retained either strongly or weakly (see @secref["weakbox"]). A hash -table is also either mutable or immutable; immutable tables support -constant-time functional update. +table is also either mutable or immutable. Immutable tables support +constant-time access and update, just like mutable hash tables; the +the constant on immutable operations is usually larger, but the +functional nature of immutable hash tables can pay off in certain +algorithms. A hash table can be used as a two-valued @tech{sequence} (see @secref["sequences"]). The keys and values of the hash table serve as diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index 92d2458771..0adbac5306 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/collects/scribblings/reference/stx-patterns.scrbl @@ -411,3 +411,16 @@ The @scheme[_] transformer binding prohibits @scheme[_] from being used as an expression. This binding useful only in syntax patterns, where it indicates a pattern that matches any syntax object. See @scheme[syntax-case].} + + +@defproc[(syntax-pattern-variable? [v any/c]) boolean?]{ + +Return @scheme[#t] if @scheme[v] is a value that, as a +transformer-binding value, makes the bound variable as pattern +variable in @scheme[syntax] and other forms. To check whether an +identifier is a pattern variable, use @scheme[syntax-local-value] to +get the identifier's transformer value, and then test the value with +@scheme[syntax-pattern-variable?]. + +The @scheme[syntax-pattern-variable?] procedure is provided +@scheme[for-syntax] by @schememodname[scheme/base].} diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index f2ee0a869a..f15261e460 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -156,7 +156,11 @@ with an empty context is used, instead.} @defproc[(local-expand [stx syntax?] [context-v (or/c 'expression 'top-level 'module 'module-begin list?)] [stop-ids (or/c (listof identifier?) #f)] - [intdef-ctx (or/c internal-definition-context? #f) #f]) + [intdef-ctx (or/c internal-definition-context? + (and/c pair? + (listof internal-definition-context?)) + #f) + #f]) syntax?]{ Expands @scheme[stx] in the lexical context of the expression @@ -176,12 +180,13 @@ instead of a list, then @scheme[stx] is expanded only as long as the outermost form of @scheme[stx] is a macro (i.e., expansion does not proceed to sub-expressions). -The optional @scheme[intdef-ctx] argument must be either @scheme[#f] -or the result of @scheme[syntax-local-make-definition-context]. In the -latter case, lexical information for internal definitions is added to -@scheme[stx] before it is expanded. The lexical information is also -added to the expansion result (because the expansion might introduce -bindings or references to internal-definition bindings). +The optional @scheme[intdef-ctx] argument must be either @scheme[#f], +the result of @scheme[syntax-local-make-definition-context], or a list +of such results. In the latter two cases, lexical information for +internal definitions is added to @scheme[stx] before it is expanded +(in reverse order relative to the list). The lexical information is +also added to the expansion result (because the expansion might +introduce bindings or references to internal-definition bindings). Expansion of @scheme[stx] can use certificates for the expression already being expanded (see @secref["stxcerts"]) , and @tech{inactive diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index b3504fc66d..c0060edf13 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -1292,7 +1292,8 @@ please adhere to these guidelines: ;; Profj (profj-java "Java") (profj-java-mode "Java mode") - + (profj-java-coverage "Java Coverage") ;; shows up in the preferences dialog under 'Color' + (profj-beginner-lang "Beginner") (profj-beginner-lang-one-line-summary "Java-like Beginner teaching language") (profj-full-lang "Full") @@ -1363,7 +1364,63 @@ please adhere to these guidelines: ;;Following two appear in Scheme (Java, etc) menu, cause Tests to be Run automatically or not (test-engine-enable-tests "Enable Tests") (test-engine-disable-tests "Disable Tests") - + + (test-engine-ran-1-test "Ran 1 test.") + (test-engine-ran-1-check "Ran 1 check.") + ;; ditto, only plural + (test-engine-ran-n-tests "Ran ~a tests.") + (test-engine-ran-n-checks "Ran ~a checks.") + (test-engine-1-test-passed "The test passed!") + (test-engine-1-check-passed "The check passed!") + (test-engine-both-tests-passed "Both tests passed!") + (test-engine-both-checks-passed "Both checks passed!") + (test-engine-all-tests-passed "All tests passed!") + (test-engine-all-checks-passed "All checks passed!") + (test-engine-all-n-tests-passed "All ~a tests passed!") + (test-engine-all-n-checks-passed "All ~a checks passed!") + (test-engine-0-tests-passed "0 tests passed.") + (test-engine-0-checks-passed "0 checks passed.") + (test-engine-m-of-n-tests-failed "~a of the ~a tests failed.") + (test-engine-m-of-n-checks-failed "~a of the ~a checks failed.") + (test-engine-must-be-tested "This program must be tested!") + (test-engine-is-unchecked "This program is unchecked!") + (test-engine-tests-disabled "Tests disabled.") + (test-engine-should-be-tested "This program should be tested.") + (test-engine-at-line-column "at line ~a, column ~a") + (test-engine-in-at-line-column "in ~a, line ~a, column ~a") + ; as in "column (unknown)" + (test-engine-unknown "(unknown)") + (test-engine-trace-error "Trace error") + + ; The ~F is special marker for the offending values, which may be + ; printed specially in DrScheme. + (test-engine-check-encountered-error + "check-expect encountered the following error instead of the expected value, ~F. ~n :: ~a") + (test-engine-actual-value-differs-error + "Actual value ~F differs from ~F, the expected value.") + (test-engine-actual-value-not-within-error + "Actual value ~F is not within ~v of expected value ~F.") + (test-engine-encountered-error-error + "check-error encountered the following error instead of the expected ~a~n :: ~a") + (test-engine-expected-error-error + "check-error expected the following error, but instead received the value ~F.~n ~a") + + ; section header + (test-engine-check-failures "Check failures:") + ; section header + (test-engine-contract-violations "Contract violations:") + + ; part of one phrase "contract to blame: procedure <...> + (test-engine-contract "contract") + (test-engine-to-blame "to blame: procedure") + + (test-engine-no-contract-violations "No contract violations.") + (test-engine-1-contract-violation "1 contract violation.") + (test-engine-n-contract-violations "~a contract violations.") + + ; as in got , contract + (test-engine-got "got") + (profjWizward-insert-java-class "Insert Java Class") (profjWizard-insert-java-union "Insert Java Union") diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index 2280eb68d0..c93aa957ed 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -1267,6 +1267,65 @@ (test-engine-enable-tests "Test aktivieren") (test-engine-disable-tests "Tests deaktivieren Tests") + (test-engine-ran-1-test "1 Test gelaufen.") + (test-engine-ran-1-check "1 Check gelaufen.") + ;; ditto, only plural + (test-engine-ran-n-tests "~a Tests gelaufen.") + (test-engine-ran-n-checks "~a Checks gelaufen.") + (test-engine-1-test-passed "Der eine Test ist bestanden!") + (test-engine-1-check-passed "Der eine Check ist bestanden!") + (test-engine-both-tests-passed "Beide Tests bestanden!") + (test-engine-both-checks-passed "Beide Checks bestanden!") + (test-engine-all-tests-passed "Alle Tests bestanden!") + (test-engine-all-checks-passed "Alle Checks bestanden!") + (test-engine-all-n-tests-passed "Alle ~a Tests bestanden!") + (test-engine-all-n-checks-passed "Alle ~a Checks bestanden!") + (test-engine-0-tests-passed "0 Tests bestanden.") + (test-engine-0-checks-passed "0 Checks bestanden.") + (test-engine-m-of-n-tests-failed "~a der ~a Tests fehlgeschlagen.") + (test-engine-m-of-n-checks-failed "~a der ~a Checks fehlgeschlagen.") + (test-engine-must-be-tested "Dieses Programm muss noch getestet werden!") + (test-engine-is-unchecked "Dieses Programm hat keine Checks!") + (test-engine-tests-disabled "Tests deaktiviert.") + (test-engine-zero-tests-passed "Keine Tests waren erfolgreich!") + (test-engine-the-only-test-passed "Der einzige Test war erfolgreich.") + (test-engine-both-tests-passed "Beide Tests waren erfolgreich.") + ; ~a is replaced by count + (test-engine-all-tests-passed "Alle ~a Tests waren erfolgreich!") + (test-engine-should-be-tested "Dieses Programm sollte getestet werden.") + (test-engine-at-line-column "in Zeile ~a, Spalte ~a") + (test-engine-in-at-line-column "in ~a, Zeile ~a, Spalte ~a") + ; as in "column (unknown)" + (test-engine-unknown "(unbekannt)") + (test-engine-trace-error "Trace-Fehler") + + (test-engine-check-encountered-error + "check-expect bekam den folgenden Fehler statt des erwarteten Werts, ~F. ~n :: ~a") + (test-engine-actual-value-differs-error + "Der tatsächliche Wert ~F ist nicht der erwartete Wert ~F.") + (test-engine-actual-value-not-within-error + "Der tatsächliche Wert ~F ist nicht innerhalb von ~v des erwarteten Werts ~F.") + (test-engine-encountered-error-error + "check-error bekam den folgenden Fehler anstatt des erwarteten ~a~n :: ~a") + (test-engine-expected-error-error + "check-error erwartete den folgenden Fehler, bekam aber den Wert ~F.~n ~a") + + ; section header + (test-engine-check-failures "Check-Fehler:") + ; section header + (test-engine-contract-violations "Vertragsverletzungen:") + + ; part of one phrase "contract to blame: procedure + (test-engine-contract "Vertrag") + (test-engine-to-blame "verantwortlich: Prozedur") + + (test-engine-no-contract-violations "Keine Vertragsverletzungen.") + (test-engine-1-contract-violation "1 Vertragsverletzung.") + (test-engine-n-contract-violations "~a Vertragsverletzungen.") + + ; as in got , contract + (test-engine-got "bekam") + (profjWizward-insert-java-class "Java-Klasse einfügen") (profjWizard-insert-java-union "Java-Vereinigung einfügen") diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index ba9ecebdee..be748fd4f2 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -299,7 +299,7 @@ [(attribute name) (identifier? #'name) (let ([mapping (syntax-local-value #'name (lambda () #f))]) - (unless (syntax-mapping? mapping) + (unless (syntax-pattern-variable? mapping) (wrong-syntax #'name "not bound as a pattern variable")) (let ([var (syntax-mapping-valvar mapping)]) (let ([attr (syntax-local-value var (lambda () #f))]) diff --git a/collects/syntax/private/template-runtime.ss b/collects/syntax/private/template-runtime.ss new file mode 100644 index 0000000000..809aa5e125 --- /dev/null +++ b/collects/syntax/private/template-runtime.ss @@ -0,0 +1,83 @@ +#lang scheme/base +(require "../stx.ss") + +(provide template-map-apply) + +(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes) +(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes) + +(define (stx-list->vector l) + (list->vector + (if (list? l) + l + (let loop ([l l]) + (cond + [(null? l) null] + [(pair? l) (cons (car l) (loop (cdr l)))] + [(syntax? l) (loop (syntax-e l))]))))) + +(define (template-map-apply tmap d->s leaf->s leaf-datum pvar->s pcons ellipses-end data stx) + (let loop ([tmap tmap][data data][stx stx][local-pcons pcons]) + (cond + [(not tmap) (if (box? data) + (leaf->s (unbox data) stx) + (leaf-datum stx))] + [(eq? tmap #t) (pvar->s data stx)] + [(pair? tmap) + (let ([a (loop (car tmap) + (if (pair? data) (car data) (vector-ref data 1)) + (stx-car stx) + pcons)] + [b (loop (cdr tmap) + (if (pair? data) (cdr data) (vector-ref data 2)) + (stx-cdr stx) + local-pcons)]) + (if (vector? data) + (d->s + (vector-ref data 0) + stx + (pcons a b)) + (local-pcons a b)))] + [(vector? tmap) + (d->s (car data) + stx + (stx-list->vector + (loop (vector-ref tmap 0) + (cdr data) + (vector->list (syntax-e stx)) + cons)))] + [(box? tmap) + (d->s (car data) + stx + (box + (loop (unbox tmap) + (cdr data) + (unbox (syntax-e stx)) + pcons)))] + [(ellipses? tmap) + (let ([prefix (map (lambda (e) + (loop (ellipses-elem tmap) + (if (pair? data) (car data) (vector-ref data 1)) + e + local-pcons)) + (syntax->list (stx-car stx)))] + [rest (loop (ellipses-rest tmap) + (if (pair? data) (cdr data) (vector-ref data 2)) + (stx-cdr stx) + local-pcons)]) + (let ([appended (let loop ([prefix prefix]) + (if (null? prefix) + (ellipses-end rest) + (local-pcons (car prefix) (loop (cdr prefix)))))]) + (if (vector? data) + (d->s (vector-ref data 0) + stx + appended) + appended)))] + [(prefab? tmap) + (d->s (car data) + stx + (loop (prefab-fields tmap) + (cdr data) + (cdr (vector->list (struct->vector (syntax-e stx))))))] + [else (error "template-map-apply fallthrough")]))) diff --git a/collects/syntax/scribblings/template.scrbl b/collects/syntax/scribblings/template.scrbl new file mode 100644 index 0000000000..832354b8b0 --- /dev/null +++ b/collects/syntax/scribblings/template.scrbl @@ -0,0 +1,99 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/template)) + +@title[#:tag "template"]{Controlling Syntax Templates} + +@defmodule[syntax/template] + +@defproc[(transform-template [template-stx syntax?] + [#:save save-proc (syntax? . -> . any/c)] + [#:restore-stx restore-proc-stx syntax?] + [#:leaf-save leaf-save-proc (syntax? . -> . any/c) save-proc] + [#:leaf-restore-stx leaf-restore-proc-stx syntax? #'(lambda (data stx) stx)] + [#:leaf-datum-stx leaf-datum-proc-stx syntax? #'(lambda (v) v)] + [#:pvar-save pvar-save-proc (identifier? . -> . any/c) (lambda (x) #f)] + [#:pvar-restore-stx pvar-restore-stx syntax? #'(lambda (d stx) stx)] + [#:cons-stx cons-proc-stx syntax? cons] + [#:ellipses-end-stx ellipses-end-stx syntax? #'values] + [#:constant-as-leaf? constant-as-leaf? boolean? #f]) + syntax?]{ + +Produces an representation of an expression similar to +@SCHEME[#`((UNSYNTAX @scheme[syntax]) #,template-stx)], but functions like +@scheme[save-proc] can collect information that might otherwise be +lost by @scheme[syntax] (such as properties when the syntax object is +marshaled within bytecode), and run-time functions like the one +specified by @scheme[restore-proc-stx] can use the saved information or +otherwise process the syntax object that is generated by the template. + +The @scheme[save-proc] is applied to each syntax object in the +representation of the original template (i.e., in +@scheme[template-stx]). If @scheme[constant-as-leaf?] is @scheme[#t], +then @scheme[save-proc] is applied only to syntax objects that contain +at least one pattern variable in a sub-form. The result of +@scheme[save-proc] is provided back as the first argument to +@scheme[restore-proc-stx], which indicates a function with a contract +@scheme[(any/c syntax any/c . -> . any/c)]; the second argument to +@scheme[restore-proc-stx] is the syntax object that @scheme[syntax] +generates, and the last argument is a datum that have been processed +recursively (by functions such as @scheme[restore-proc-stx]) and that +normally would be converted back to a syntax object using the second +argument's context, source, and properties. Note that +@scheme[save-proc] works at expansion time (with respect to the +template form), while @scheme[restore-proc-stx] indicates a function +that is called at run time (for the template form), and the data that +flows from @scheme[save-proc] to @scheme[restore-proc-stx] crosses +phases via @scheme[quote]. + +The @scheme[leaf-save-proc] and @scheme[leaf-restore-proc-stx] procedures +are analogous to @scheme[save-proc] and +@scheme[restore-proc-stx], but they are applied to leaves, so +there is no third argument for recursively processed sub-forms. The +function indicated by @scheme[leaf-restore-proc-stx] should have the +contract @scheme[(any/c syntax? . -> . any/c)]. + +The @scheme[leaf-datum-proc-stx] procedure is applied to leaves that +are not syntax objects, which can happen because pairs and the empty +list are not always individually wrapped as syntax objects. The +function should have the contract @scheme[(any/c . -> . any/c)]. When +@scheme[constant-as-leaf?] is @scheme[#f], the only possible argument +to the procedure is @scheme[null]. + +The @scheme[pvar-save] and @scheme[pvar-restore-stx] procedures are +analogous to @scheme[save-proc] and @scheme[restore-proc-stx], +but they are applied to pattern variables. The +@scheme[pvar-restore-stx] procedure should have the contract +@scheme[(any/c syntax? . -> . any/c)], where the second argument +corresponds to the substitution of the pattern variable. + +The @scheme[cons-proc-stx] procedure is used to build intermediate +pairs, including pairs passed to @scheme[restore-proc-stx] and pairs +that do not correspond to syntax objects. + +The @scheme[ellipses-end-stx] procedure is an extra filter on the +syntax object that follows a sequence of @scheme[...] ellipses in the +template. The procedure should have the contract @scheme[(any/c . -> +. any/c)]. + +The following example illustrates a use of @scheme[transform-template] +to implement a @scheme[syntax/shape] form that preserves the +@scheme['paren-shape] property from the original template, even if the +template code is marshaled within bytecode. + +@schemeblock[ +(define-for-syntax (get-shape-prop stx) + (syntax-property stx 'paren-shape)) + +(define (add-shape-prop v stx datum) + (syntax-property (datum->syntax stx datum stx stx stx) + 'paren-shape + v)) + +(define-syntax (syntax/shape stx) + (syntax-case stx () + [(_ tmpl) + (transform-template #'tmpl + #:save get-shape-prop + #:restore-stx #'add-shape-prop)])) +]} diff --git a/collects/syntax/scribblings/transformer-helpers.scrbl b/collects/syntax/scribblings/transformer-helpers.scrbl index 951c202743..0b8957186c 100644 --- a/collects/syntax/scribblings/transformer-helpers.scrbl +++ b/collects/syntax/scribblings/transformer-helpers.scrbl @@ -9,3 +9,4 @@ @include-section["flatten-begin.scrbl"] @include-section["struct.scrbl"] @include-section["path-spec.scrbl"] +@include-section["template.scrbl"] diff --git a/collects/syntax/template.ss b/collects/syntax/template.ss new file mode 100644 index 0000000000..bb35a5ccfd --- /dev/null +++ b/collects/syntax/template.ss @@ -0,0 +1,189 @@ +#lang scheme/base +(require "stx.ss" + (for-template scheme/base + "private/template-runtime.ss")) + +(provide transform-template) + +;; A template map descibres the structure of a template +;; in terms of where pattern variables are replaced. +;; +;; Walk a map and a template in parallel, and you see +;; these map cases: +;; +;; - #f => corresponding template portion is constant +;; - #t => corresponding template portion is a pattern variable +;; - (cons map1 map2) => template part is a pair +;; which substitutions in one side +;; or the other +;; - (vector map) => template portion is a vector, +;; contents like the list in map +;; - (box map) => template portion is a box with substition +;; - #s(ellipses count map) => template portion is an ellipses-generated list +;; - #s(prefab v map) => templat portion is a prefab + +(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes) +(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes) + +(define (datum->syntax* stx d) + (datum->syntax stx d stx stx stx)) + +(define (make-template-map tmpl const-leaf?) + (let loop ([tmpl tmpl] + [in-ellipses? #f]) + (syntax-case tmpl () + [(ellipses expr) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (loop #'expr #t)] + [(expr ellipses . rest) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (let-values ([(elem) (loop #'expr #f)] + [(rest count) + (let rloop ([rest #'rest][count 1]) + (syntax-case rest () + [(ellipses . rest) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + ;; keep going: + (rloop #'rest (add1 count))] + [else (values (loop rest #f) count)]))]) + (make-ellipses elem count rest))] + [(a . b) (let ([a (loop #'a in-ellipses?)] + [b (loop #'b in-ellipses?)]) + (and (or a b (not const-leaf?)) + (cons a b)))] + [#(a ...) (let ([as (loop (syntax->list #'(a ...)) + in-ellipses?)]) + (and (or as (not const-leaf?)) + (vector as)))] + [#&(a) (let ([as (loop #'a in-ellipses?)]) + (and (or as (not const-leaf?)) + (box as)))] + [a + (identifier? #'a) + (syntax-pattern-variable? (syntax-local-value #'a (lambda () #f)))] + [_ + (let ([k (prefab-struct-key (syntax-e tmpl))]) + (and k + (let ([as (loop (cdr (vector->list (struct->vector (syntax-e tmpl))) in-ellipses?))]) + (and (or as (not const-leaf?)) + (make-prefab k as)) + #f)))]))) + +(define (template-map-collect tmap template s->d leaf->d pvar->d) + (let loop ([tmap tmap][template template]) + (cond + [(not tmap) (if (syntax? template) + (box (leaf->d template)) + #f)] + [(eq? tmap #t) (pvar->d template)] + [(pair? tmap) + (if (syntax? template) + (vector (s->d template) + (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template))) + (cons (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template))))] + [(vector? tmap) + (cons (s->d template) + (loop (vector-ref tmap 0) + (vector->list (syntax-e template))))] + [(box? tmap) + (cons (s->d template) + (loop (unbox tmap) + (syntax-e template)))] + [(ellipses? tmap) + (let ([rest (let loop ([rest (stx-cdr template)] + [count (ellipses-count tmap)]) + (if (zero? count) + rest + (loop (stx-cdr rest) (sub1 count))))]) + (if (syntax? template) + (vector (s->d template) + (loop (ellipses-elem tmap) (stx-car template)) + (loop (ellipses-rest tmap) rest)) + (cons (loop (ellipses-elem tmap) (stx-car template)) + (loop (ellipses-rest tmap) rest))))] + [(prefab? tmap) + (cons (s->d template) + (loop (prefab-fields tmap) + (cdr (vector->list (struct->vector (syntax-e template))))))] + [else (error "template-map-collect fall-through")]))) + +(define (group-ellipses tmap template) + (let loop ([tmap tmap][template template]) + (cond + [(boolean? tmap) template] + [(pair? tmap) + (let ([p (cons (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template)))]) + (if (syntax? template) + (datum->syntax* template p) + p))] + [(vector? tmap) + (datum->syntax* template + (list->vector + (loop (vector-ref tmap 0) + (vector->list (syntax-e template)))))] + [(box? tmap) + (datum->syntax* template + (box + (loop (unbox tmap) + (syntax-e template))))] + [(ellipses? tmap) + (let ([rest + (loop (ellipses-rest tmap) + (let loop ([rest (stx-cdr template)] + [count (ellipses-count tmap)]) + (if (zero? count) + rest + (loop (stx-cdr rest) (sub1 count)))))] + [elem (loop (ellipses-elem tmap) (stx-car template))]) + (let ([new `((,elem ,@(for/list ([i (in-range (ellipses-count tmap))]) + #'(... ...))) + . ,rest)]) + (if (syntax? template) + (datum->syntax* template new) + new)))] + [(prefab? tmap) + (datum->syntax* + template + (apply + make-prefab-struct + (prefab-key tmap) + (loop (prefab-fields tmap) + (cdr (vector->list (struct->vector (syntax-e template)))))))] + [else (error "group-ellipses fall-through")]))) + +(define (transform-template template-stx + #:save s->d + #:restore-stx d->s + #:leaf-save [leaf->d s->d] + #:leaf-restore-stx [leaf->s #'(lambda (data stx) stx)] + #:leaf-datum-stx [leaf-datum #'values] + #:pvar-save [pvar->d (lambda (x) #f)] + #:pvar-restore-stx [pvar->s #'(lambda (d s) s)] + #:cons-stx [pcons cons] + #:ellipses-end-stx [ellipses-end #'values] + #:constant-as-leaf? [const-leaf? #f]) + (let* ([tmap (make-template-map template-stx const-leaf?)] + [grouped-template + ;; Convert tmpl to group ...-created repetitions together, + ;; so that `unwrap' can tell which result came from which + ;; template: + (group-ellipses tmap template-stx)] + [data (template-map-collect tmap template-stx + s->d leaf->d pvar->d)]) + #`(if #f + ;; Process tmpl first, so that syntax errors are reported + ;; usinf the original source. + (syntax #,template-stx) + ;; Apply give d->s to result: + (template-map-apply '#,tmap + #,d->s #,leaf->s #,leaf-datum #,pvar->s #,pcons #,ellipses-end + '#,data + (syntax #,grouped-template))))) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 6da1ad7bbb..61315b1624 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -40,13 +40,14 @@ This @tt{universe.ss} teachpack implements and provides the functionality The purpose of this documentation is to give experienced Schemers and HtDP teachers a concise overview for using the library. The first part of the - documentation focuses on @tech{world} programs. Section @secref["world-example"] - presents an illustration of how to design such programs for a simple - domain; it is suited for a novice who knows how to design conditional - functions for symbols. The second half of the documentation focuses on - "universe" programs: how it is managed via a server, how @tech{world} - programs register with the server, etc. The last two sections show how to - design a simple universe of two communicating worlds. + documentation focuses on @tech{world} programs. Section + @secref["world-example"] presents an illustration of how to design such + programs for a simple domain; it is suited for a novice who knows how to + design conditional functions for enumerations, intervals, and unions. The + second half of the documentation focuses on "universe" programs: how it is + managed via a server, how @tech{world} programs register with the server, + etc. The last two sections show how to design a simple universe of two + communicating worlds. @emph{Note}: For a quick and educational introduction to just worlds, see @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How @@ -215,20 +216,26 @@ current world. The clock ticks at the rate of @scheme[rate-expr].}} @item{A @tech{KeyEvent} represents key board events, e.g., keys pressed or released. -@deftech{KeyEvent} : @scheme[(or/c char? symbol?)] +@deftech{KeyEvent} : @scheme[string?] -A single-character string is used to signal that the user has hit an alphanumeric - key. Some of these one-character strings may look unusual: +For simplicity, we represent key events with strings, but not all strings + are key events. The representation of key events comes in distinct + classes. First, a single-character string is used to signal that the user + has hit a "regular" key. Some of these one-character strings may look + unusual: @itemize[ + @item{@scheme[" "] stands for the space bar (@scheme[#\space]);} @item{@scheme["\r"] stands for the return key (@scheme[#\return]);} @item{@scheme["\t"] stands for the tab key (@scheme[#\tab]); and} @item{@scheme["\b"] stands for the backspace key (@scheme[#\backspace]).} + ] -On rare occasions you may also encounter @scheme["\u007F"], which is the + On rare occasions you may also encounter @scheme["\u007F"], which is the string representing the delete key (aka rubout). -A string with more than one character denotes arrow keys or other special events, +Second, some keys have multiple-character string representations. Strings + with more than one character denotes arrow keys or other special events, starting with the most important: @itemize[ @item{@scheme["left"] is the left arrow;} @@ -272,7 +279,7 @@ A string with more than one character denotes arrow keys or other special events @scheme["subtract"], @scheme["decimal"], @scheme["divide"]} -@item{@scheme["'f1"], +@item{@scheme["f1"], @scheme["f2"], @scheme["f3"], @scheme["f4"], @@ -316,18 +323,16 @@ A string with more than one character denotes arrow keys or other special events of the call becomes the current world. Here is a typical key-event handler: -@(begin -#reader scribble/comment-reader -(schemeblock +@schemeblock[ (define (change w a-key) (cond - [(key=? a-key 'left) (world-go w -DELTA)] - [(key=? a-key 'right) (world-go w +DELTA)] - [(char? a-key) w] ;; to demonstrate order-free checking - [(key=? a-key 'up) (world-go w -DELTA)] - [(key=? a-key 'down) (world-go w +DELTA)] + [(key=? a-key "left") (world-go w -DELTA)] + [(key=? a-key "right") (world-go w +DELTA)] + [(= (string-length a-key) 1) w] (code:comment "to demonstrate order-free checking") + [(key=? a-key "up") (world-go w -DELTA)] + [(key=? a-key "down") (world-go w +DELTA)] [else w])) -)) +] } The omitted, auxiliary function @emph{world-go} is supposed to consume a world and a number and produces a world. @@ -338,20 +343,20 @@ A string with more than one character denotes arrow keys or other special events @deftech{MouseEvent} : @scheme[(one-of/c 'button-down 'button-up 'drag 'move 'enter 'leave)] -All @tech{MouseEvent}s are represented via symbols: +All @tech{MouseEvent}s are represented via strings: @itemize[ -@item{@scheme['button-down] +@item{@scheme["button-down"] signals that the computer user has pushed a mouse button down;} -@item{@scheme['button-up] +@item{@scheme["button-up"] signals that the computer user has let go of a mouse button;} -@item{@scheme['drag] +@item{@scheme["drag"] signals that the computer user is dragging the mouse;} -@item{@scheme['move] +@item{@scheme["move"] signals that the computer user has moved the mouse;} -@item{@scheme['enter] +@item{@scheme["enter"] signals that the computer user has moved the mouse into the canvas area; and} -@item{@scheme['leave] +@item{@scheme["leave"] signals that the computer user has moved the mouse out of the canvas area.} ] @@ -543,7 +548,7 @@ Second, we must translate the actions in our domain---the arrows in the (define (click w x y me) ...) ;; control : WorldState @tech{KeyEvent} -> WorldState -;; deal with a key event (symbol, char) @emph{ke} +;; deal with a key event @emph{ke} ;; in the current world @emph{w} (define (control w ke) ...) )) @@ -1531,7 +1536,7 @@ The final step is to design the ball @tech{world}. Recall that each world enumeration of two cases: @(begin #reader scribble/comment-reader -(schemeblock +(schemeblock ;; teachpack: universe.ss ;; WorldState is one of: diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm index 81ef2bfc69..2425a3f803 100644 --- a/collects/test-engine/java-tests.scm +++ b/collects/test-engine/java-tests.scm @@ -174,7 +174,7 @@ (when current-testcase (set-tc-stat-checks! current-testcase - (cons (make-failed-check src msg exn) + (cons (make-failed-check msg exn) (tc-stat-checks current-testcase)))) (inner (void) check-failed msg src exn)) diff --git a/collects/test-engine/print.ss b/collects/test-engine/print.ss new file mode 100644 index 0000000000..7f66297c30 --- /dev/null +++ b/collects/test-engine/print.ss @@ -0,0 +1,31 @@ +#lang scheme/base + +(provide print-with-values) + +; This is like the printf procedures---it uses `print-string' to print +; the string portions, and print-formatted to print the values +; referenced via ~F. ~ is not supported. + +(define (print-with-values fstring print-string print-formatted + . vals) + (let ((size (string-length fstring))) + (let loop ((start 0) + (i 0) + (vals vals) + (seen-vals '())) ; reversed + (cond + ((>= i size) + (print-string (apply format (substring fstring start i) (reverse seen-vals)))) + ((char=? (string-ref fstring i) #\~) + (case (string-ref fstring (+ 1 i)) + ((#\n #\~) (loop start (+ 1 i) vals seen-vals)) + ((#\F #\f) + (print-string (apply format (substring fstring start i) (reverse seen-vals))) + (print-formatted (car vals)) + (loop (+ 2 i) (+ 2 i) (cdr vals) '())) + (else + (loop start (+ 2 i) (cdr vals) (cons (car vals) seen-vals))))) + (else + (loop start (+ 1 i) vals seen-vals)))))) + + diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 89e72076dd..6eacf70146 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -5,6 +5,7 @@ scheme/match (only scheme/base for) "test-engine.scm" + "test-info.scm" ) (require-for-syntax stepper/private/shared) @@ -40,19 +41,6 @@ (define-for-syntax CHECK-ERROR-DEFN-STR CHECK-EXPECT-DEFN-STR) -(define-struct check-fail (src)) - -;; (make-unexpected-error src string exn) -(define-struct (unexpected-error check-fail) (expected message exn)) -;; (make-unequal src scheme-val scheme-val) -(define-struct (unequal check-fail) (test actual)) -;; (make-outofrange src scheme-val scheme-val inexact) -(define-struct (outofrange check-fail) (test actual range)) -;; (make-incorrect-error src string exn) -(define-struct (incorrect-error check-fail) (expected message exn)) -;; (make-expected-error src string scheme-val) -(define-struct (expected-error check-fail) (message value)) - ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; the common part of all three test forms. (define-for-syntax (check-expect-maker @@ -121,7 +109,7 @@ (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) - (lambda (src v1 v2 _) (make-unequal src v1 v2)) + (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) test actual #f src test-info 'check-expect)) @@ -158,14 +146,14 @@ (let ([result (with-handlers ([exn? (lambda (e) (or (equal? (exn-message e) error) - (make-incorrect-error src error + (make-incorrect-error src (test-format) error (exn-message e) e)))]) (let ([test-val (test)]) - (make-expected-error src error test-val)))]) + (make-expected-error src (test-format) error test-val)))]) (if (check-fail? result) (begin (send (send test-info get-info) check-failed - (check->message result) (check-fail-src result) + result (check-fail-src result) (and (incorrect-error? result) (incorrect-error-exn result))) #f) #t))) @@ -180,14 +168,14 @@ ;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) -;; (scheme-val scheme-val scheme-val -> check-fail) +;; (src format scheme-val scheme-val scheme-val -> check-fail) ;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void (define (run-and-check check maker test expect range src test-info kind) (match-let ([(list result result-val exn?) (with-handlers ([exn? (lambda (e) (raise e) (let ([display (error-display-handler)]) #;((error-display-handler) (exn-message e) e) - (list (make-unexpected-error src expect + (list (make-unexpected-error src (test-format) expect (exn-message e) e) 'error (lambda () (printf "~a~n" e) @@ -195,42 +183,13 @@ (let ([test-val (test)]) (cond [(check expect test-val range) (list #t test-val #f)] [else - (list (maker src test-val expect range) test-val #f)])))]) + (list (maker src (test-format) test-val expect range) test-val #f)])))]) (cond [(check-fail? result) - (send (send test-info get-info) check-failed (check->message result) (check-fail-src result) exn?) + (send (send test-info get-info) check-failed result (check-fail-src result) exn?) #f] [else #t]))) - -(define (check->message fail) - (cond - [(unexpected-error? fail) - (list "check encountered the following error instead of the expected value, " - ((test-format) (unexpected-error-expected fail)) - (format ". ~n :: ~a~n" (unexpected-error-message fail)))] - [(unequal? fail) - (list "Actual value " - ((test-format) (unequal-test fail)) - " differs from " - ((test-format) (unequal-actual fail)) - ", the expected value.\n")] - [(outofrange? fail) - (list "Actual value " - ((test-format) (outofrange-test fail)) - (format " is not within ~v of expected value " (outofrange-range fail)) - ((test-format) (outofrange-actual fail)) - ".\n")] - [(incorrect-error? fail) - (list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n" - (incorrect-error-expected fail) - (incorrect-error-message fail)))] - [(expected-error? fail) - (list "check-error expected the following error, but instead received the value " - ((test-format) (expected-error-value fail)) - (format ".~n ~a~n" (expected-error-message fail)))])) - - (define (builder) (let ([te (build-test-engine)]) (namespace-set-variable-value! 'test~object te (current-namespace)) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 28c6632601..3e73771cd1 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -6,7 +6,8 @@ framework string-constants "test-info.scm" - "test-engine.scm") + "test-engine.scm" + "print.ss") (define test-display% (class* object% () @@ -45,8 +46,26 @@ (when current-tab (send current-tab current-test-editor content)) (when (and curr-win (docked?)) (send drscheme-frame display-test-panel content) - #;(send curr-win show #f)) - ))) + #;(send curr-win show #f))))) + + (define/public (display-success-summary port count) + (unless (test-silence) + (display (case count + [(0) (string-constant test-engine-0-tests-passed)] + [(1) (string-constant test-engine-1-test-passed)] + [(2) (string-constant test-engine-both-tests-passed)] + [else (format (string-constant test-engine-all-n-tests-passed) + count)]) + port))) + + (define/public (display-untested-summary port) + (unless (test-silence) + (display (string-constant test-engine-should-be-tested) port) + (display "\n" port))) + + (define/public (display-disabled-summary port) + (display (string-constant test-engine-tests-disabled) port) + (display "\n" port)) (define/public (display-results) (let* ([curr-win (and current-tab (send current-tab get-test-window))] @@ -80,49 +99,78 @@ [failed-tests (send test-info tests-failed)] [total-checks (send test-info checks-run)] [failed-checks (send test-info checks-failed)] - [test-outcomes - (lambda (zero-message) + [outcomes + (lambda (total failed zero-message ck?) (send editor insert (cond - [(zero? total-tests) zero-message] - [(= 1 total-tests) "Ran 1 test.\n"] - [else (format "Ran ~a tests.\n" total-tests)])) - (when (> total-tests 0) + [(zero? total) zero-message] + [(= 1 total) + (string-append + (if ck? + (string-constant test-engine-ran-1-check) + (string-constant test-engine-ran-1-test)) + "\n")] + [else + (format (string-append + (if ck? + (string-constant test-engine-ran-n-checks) + (string-constant test-engine-ran-n-tests)) + "\n") + total)])) + (when (> total 0) (send editor insert (cond - [(and (zero? failed-tests) (= 1 total-tests)) - "Test passed!\n\n"] - [(zero? failed-tests) "All tests passed!\n\n"] - [(= failed-tests total-tests) "0 tests passed.\n"] - [else (format "~a of the ~a tests failed.\n\n" failed-tests total-tests)]))))] - [check-outcomes - (lambda (zero-message ck) - (send editor insert - (cond - [(zero? total-checks) zero-message] - [(= 1 total-checks) (format "Ran 1 ~a.\n" ck)] - [else (format "Ran ~a ~as.\n" total-checks ck)])) - (when (> total-checks 0) - (send editor insert - (cond - [(and (zero? failed-checks) (= 1 total-checks)) - (format "The ~a passed!\n\n" ck)] - [(zero? failed-checks) (format "All ~as passed!\n\n" ck)] - [(= failed-checks total-checks) (format "0 ~as passed.\n" ck)] - [else (format "~a of the ~a ~as failed.\n\n" - failed-checks total-checks ck)]))))]) + [(and (zero? failed) (= 1 total)) + (string-append (if ck? + (string-constant test-engine-1-check-passed) + (string-constant test-engine-1-test-passed)) + "\n\n")] + [(zero? failed) + (string-append (if ck? + (string-constant test-engine-all-checks-passed) + (string-constant test-engine-all-tests-passed)) + "\n\n")] + [(= failed total) + (string-append (if ck? + (string-constant test-engine-0-checks-passed) + (string-constant test-engine-0-tests-passed)) + "\n")] + [else + (format + (string-append (if ck? + (string-constant test-engine-m-of-n-checks-failed) + (string-constant test-engine-m-of-n-tests-failed)) + "\n\n") + failed total)]))))] + [check-outcomes/check + (lambda (zero-message) + (outcomes total-checks failed-checks + zero-message #t))] + [check-outcomes/test + (lambda (zero-message) + (outcomes total-checks failed-checks + zero-message #f))] + [test-outcomes + (lambda (zero-message) + (outcomes total-tests failed-tests + zero-message #f))]) (case style [(test-require) - (test-outcomes "This program must be tested!\n") - (check-outcomes "This program is unchecked!\n" "check")] + (test-outcomes + (string-append (string-constant test-engine-must-be-tested) "\n")) + (check-outcomes/check + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(check-require) - (check-outcomes "This program is unchecked!\n" "check")] + (check-outcomes/check + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(test-basic) (test-outcomes "") - (check-outcomes "" "check")] + (check-outcomes/check "")] [(test-check) - (check-outcomes "This program must be tested.\n" "test")] - [else (check-outcomes "" "check")]) + (check-outcomes/test + (string-append (string-constant test-engine-must-be-tested) + "\n"))] + [else (check-outcomes/check "")]) (unless (and (zero? total-checks) (zero? total-tests)) (inner (display-check-failures (send test-info failed-checks) @@ -134,13 +182,13 @@ (send editor insert "\t") (if (failed-check-exn? failed-check) (make-error-link editor - (failed-check-msg failed-check) + (failed-check-reason failed-check) (failed-check-exn? failed-check) - (failed-check-src failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor) (make-link editor - (failed-check-msg failed-check) - (failed-check-src failed-check) + (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor)) (send editor insert "\n"))) @@ -148,13 +196,9 @@ ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) - ;; make-link: text% (listof (U string snip%)) src editor -> void - (define (make-link text msg dest src-editor) - (for ([m msg]) - (when (is-a? m snip%) - (send m set-style (send (send text get-style-list) - find-named-style "Standard"))) - (send text insert m)) + ;; make-link: text% check-fail src editor -> void + (define (make-link text reason dest src-editor) + (display-reason text reason) (let ((start (send text get-end-position))) (send text insert (format-src dest)) (when (and src-editor current-rep) @@ -170,12 +214,57 @@ start end #f) (send c set-delta-foreground "royalblue") (send text change-style c start end #f))))) + + (define (display-reason text fail) + (write (list 'display-reason fail (check-fail? fail) (message-error? fail)) + (current-error-port)) + (newline (current-error-port)) + + (let* ((print-string + (lambda (m) + (send text insert m))) + (print-formatted + (lambda (m) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + (print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print (string-constant test-engine-check-encountered-error) + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print (string-constant test-engine-actual-value-differs-error) + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print (string-constant test-engine-actual-value-not-within-error) + (formatter (outofrange-test fail)) + (outofrange-range fail) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print (string-constant test-engine-encountered-error-error) + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print (string-constant test-engine-expected-error-error) + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) - ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void - (define (make-error-link text msg exn dest src-editor) - (make-link text msg dest src-editor) + ;; make-error-link: text% check-fail exn src editor -> void + (define (make-error-link text reason exn dest src-editor) + (make-link text reason dest src-editor) (let ((start (send text get-end-position))) - (send text insert "Trace error ") + (send text insert (string-constant test-engine-trace-error)) + (send text insert " ") (when (and src-editor current-rep) (send text set-clickback start (send text get-end-position) @@ -195,15 +284,22 @@ (let ([src-file car] [src-line cadr] [src-col caddr]) - (string-append - (cond - [(symbol? (src-file src)) (string-append " At ")] - [(path? (src-file src)) (string-append " In " (path->string (src-file src)) " at ")] - [(is-a? (src-file src) editor<%>) " At "]) - "line " (cond [(src-line src) => number->string] - [else "(unknown)"]) - " column " (cond [(src-col src) => number->string] - [else "(unknown)"])))) + (let ([line (cond [(src-line src) => number->string] + [else + (string-constant test-engine-unknown)])] + [col + (cond [(src-col src) => number->string] + [else (string-constant test-engine-unknown)])]) + (string-append + " " + (cond + [(or (symbol? (src-file src)) + (is-a? (src-file src) editor<%>)) + (format (string-constant test-engine-at-line-column) line col)] + [(path? (src-file src)) + (format (string-constant test-engine-in-at-line-column) + (path->string (src-file src)) + line col)]))))) (define (highlight-check-error srcloc src-editor) (let* ([src-pos cadddr] diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index 9a321a80e4..361837844c 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -71,17 +71,34 @@ (define/public (display-check-failures checks test-info) (for ([failed-check (reverse checks)]) (printf "~a" "\t") - (make-link (failed-check-msg failed-check) - (failed-check-src failed-check)) + (make-link (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check))) (printf "~a" "\n"))) (define/public (report-success) (void)) + + (define/public (display-success-summary port count) + (unless (test-silence) + (fprintf port "~a test~a passed!\n" + (case count + [(0) "Zero"] + [(1) "The only"] + [(2) "Both"] + [else (format "All ~a" count)]) + (if (= count 1) "" "s")))) + (define (display-untested-summary port) + (unless (test-silence) + (fprintf port "This program should be tested.~n"))) + + (define (display-disabled-summary port) + (fprintf port "Tests disabled.\n")) + (define/public (next-line) (printf "~a" "\n\t")) - ;; make-link: (listof (U string snip%)) src -> void - (define (make-link msg dest) - (for-each printf msg) + ;; make-link: (listof (U check-fail (U string snip%))) src -> void + (define (make-link reason dest) + (print-reason display display reason) (printf (format-src dest))) (define (format-src src) @@ -142,24 +159,21 @@ [(mixed-results) (display-results display-rep display-event-space)]))] [else - (fprintf port "Tests disabled.\n")])) + (display-disabled port)])) (define/private (display-success port event count) (when event (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event]) ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display report-success))))) - (unless (test-silence) - (fprintf port "~a test~a passed!\n" - (case count - [(0) "Zero"] - [(1) "The only"] - [(2) "Both"] - [else (format "All ~a" count)]) - (if (= count 1) "" "s")))) + (send test-display display-success-summary port count)) + (define/public (display-untested port) - (unless (test-silence) - (fprintf port "This program should be tested.~n"))) + (send test-display display-untested-summary port)) + + (define/public (display-disabled port) + (send test-display display-disabled-summary port)) + (define/public (display-results rep event-space) (cond [(and rep event-space) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index b7db3e200a..f2c2a694d6 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -1,11 +1,28 @@ #lang scheme/base -(require scheme/class) +(require scheme/class + "print.ss") (provide (all-defined-out)) -;; (make-failed-check src (listof (U string snip%)) (U #f exn)) -(define-struct failed-check (src msg exn?)) +;; (make-failed-check check-fail (U #f exn) +(define-struct failed-check (reason exn?)) + +(define-struct check-fail (src format)) + +;; (make-unexpected-error src format string exn) +(define-struct (unexpected-error check-fail) (expected message exn)) +;; (make-unequal src format scheme-val scheme-val) +(define-struct (unequal check-fail) (test actual)) +;; (make-outofrange src format scheme-val scheme-val inexact) +(define-struct (outofrange check-fail) (test actual range)) +;; (make-incorrect-error src format string exn) +(define-struct (incorrect-error check-fail) (expected message exn)) +;; (make-expected-error src format string scheme-val) +(define-struct (expected-error check-fail) (message value)) + +;; (make-message-error src format (listof string)) +(define-struct (message-error check-fail) (strings)) (define test-info-base% (class* object% () @@ -41,11 +58,18 @@ (set! total-tsts (add1 total-tsts)) (inner (void) add-test)) - ;; check-failed: (list (U string snip%)) src (U exn false) -> void + ;; check-failed: (U check-fail (list (U string snip%))) src (U exn false) -> void (define/pubment (check-failed msg src exn?) (set! failed-cks (add1 failed-cks)) - (set! failures (cons (make-failed-check src msg exn?) failures)) - (inner (void) check-failed msg src exn?)) + (let ((fail + ;; We'd like every caller to make a check-fail object, + ;; but some (such as ProfessorJ's run time) cannot because + ;; of phase problems. Therefore, do the coercion here. + (if (check-fail? msg) + msg + (make-message-error src #f msg)))) + (set! failures (cons (make-failed-check fail exn?) failures)) + (inner (void) check-failed fail src exn?))) (define/pubment (test-failed failed-info) (set! failed-tsts (add1 failed-tsts)) @@ -57,3 +81,36 @@ (for ([a analyses]) (send a analyze src vals))) (define/public (extract-info pred?) (filter pred? (map (lambda (a) (send a provide-info)) analyses))))) + +; helper for printing error messages +(define (print-reason print-string print-formatted fail) + (let ((print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print "check-expect encountered the following error instead of the expected value, ~F. ~n :: ~a" + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print "Actual value ~F differs from ~F, the expected value." + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print "Actual value ~F is not within ~v of expected value ~F." + (formatter (outofrange-test fail)) + (format (outofrange-range fail)) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print "check-error encountered the following error instead of the expected ~a~n :: ~a" + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print "check-error expected the following error, but instead received the value ~F.~n ~a" + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) + diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 3b299b5f8d..e161246738 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1345,7 +1345,8 @@ '((contract (->d ([x number?]) () #:rest rst number? any) (λ (x . rst) (values 4 5)) 'pos - 'neg))) + 'neg) + #f)) (test/pos-blame '->d-arity1 diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index 65c6e320c9..246784e200 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -196,4 +196,19 @@ ;; ---------------------------------------- +(test-pack-seq + 10 + (define-package p5 (q) + (define* x 10) + (define-syntax (y stx) + (syntax-case stx () + [(_ z) #'(begin (define z x))])) + (define* x 12) + (define* z 13) + (y q)) + (open-package p5) + q) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index f44b983465..e496697faf 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -53,6 +53,8 @@ The following API is provided to customize the server instance: web-server/web-config-unit web-server/web-server-unit)) +@section-index{plt-web-server} + One command-line utility is provided with the @|web-server|: @commandline{plt-web-server [-f -p -a --ssl]} diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index d9dd2994b8..e48ae4f104 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -4508,15 +4508,8 @@ local_module_introduce(int argc, Scheme_Object *argv[]) v = scheme_stx_source_module(s, 0); if (SCHEME_FALSEP(v)) { - if (env->genv->module) { - if (env->genv->module->rn_stx && !SAME_OBJ(scheme_true, env->genv->module->rn_stx)) { - v = scheme_stx_to_rename(env->genv->module->rn_stx); - s = scheme_add_rename(s, v); - } - } else { - if (env->genv->rename_set) - s = scheme_add_rename(s, env->genv->rename_set); - } + if (env->genv->rename_set) + s = scheme_add_rename(s, env->genv->rename_set); } return s; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 3552cff5e0..1115e4c34b 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -9274,13 +9274,31 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0); } +static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming) +{ + Scheme_Object *rl = renaming; + + if (SCHEME_PAIRP(renaming)) { + l = scheme_add_rib_delimiter(l, scheme_null); + while (!SCHEME_NULLP(rl)) { + l = scheme_add_rename(l, SCHEME_CAR(rl)); + rl = SCHEME_CDR(rl); + } + l = scheme_add_rib_delimiter(l, renaming); + } else { + l = scheme_add_rename(l, renaming); + } + + return l; +} + static Scheme_Object * do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) { Scheme_Comp_Env *env, *orig_env, **ip; Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL; int cnt, pos, kind; - int bad_sub_env = 0; + int bad_sub_env = 0, bad_intdef = 0; Scheme_Object *observer, *catch_lifts_key = NULL; env = scheme_current_thread->current_local_env; @@ -9324,7 +9342,36 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (!scheme_is_sub_env(stx_env, env)) bad_sub_env = 1; env = stx_env; - } + } else if (SCHEME_PAIRP(argv[3])) { + Scheme_Object *rl = argv[3]; + while (SCHEME_PAIRP(rl)) { + if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) { + Scheme_Comp_Env *stx_env; + stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl)); + if (!scheme_is_sub_env(stx_env, env)) + bad_sub_env = 1; + } else + break; + rl = SCHEME_CDR(rl); + } + if (!SCHEME_NULLP(rl)) + bad_intdef = 1; + else { + rl = argv[3]; + env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl)); + if (SCHEME_NULLP(SCHEME_CDR(rl))) + renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl)); + else { + /* reverse and extract: */ + renaming = scheme_null; + while (!SCHEME_NULLP(rl)) { + renaming = cons(SCHEME_PTR2_VAL(SCHEME_CAR(rl)), renaming); + rl = SCHEME_CDR(rl); + } + } + } + } else + bad_intdef = 1; } if (argc > 4) { @@ -9385,18 +9432,13 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in /* Report errors related to 3rd argument, finally */ if (argc > 3) { - if (SCHEME_TRUEP(argv[3])) { - if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) { - if (bad_sub_env) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does " - "not match internal-definition context at the front of the context list", - name); - return NULL; - } - } else { - scheme_wrong_type(name, "internal-definition context or #f", 3, argc, argv); - return NULL; - } + if (bad_intdef) { + scheme_wrong_type(name, "internal-definition context, non-empty list of internal-definition contexts, or #f", 3, argc, argv); + return NULL; + } else if (bad_sub_env) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does not match internal-definition context", + name); + return NULL; } } @@ -9424,7 +9466,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in l = scheme_stx_activate_certs(l); if (renaming) - l = scheme_add_rename(l, renaming); + l = add_intdef_renamings(l, renaming); SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l); @@ -9479,7 +9521,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l); if (renaming) - l = scheme_add_rename(l, renaming); + l = add_intdef_renamings(l, renaming); if (for_expr) { /* Package up expanded expr with the environment. */ diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index c5d0d05dab..195996cb99 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -3823,31 +3823,45 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); if (!menv || restart) { - if (!menv) { - Scheme_Object *insp; + Scheme_Object *insp; + if (!menv) { /* printf("new %ld %s\n", env->phase, SCHEME_SYM_VAL(m->modname)); */ menv = scheme_new_module_env(env, m, 0); scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - /* These three should be set by various "finish"es, but - we initialize them in case there's an error runing a "finish". */ - menv->require_names = scheme_null; - menv->et_require_names = scheme_null; - menv->tt_require_names = scheme_null; - menv->dt_require_names = scheme_null; - menv->phase = env->phase; menv->link_midx = syntax_idx; - insp = scheme_make_inspector(m->insp); - menv->insp = insp; } else { + Scheme_Env *env2; + menv->module = m; menv->running = 0; menv->et_running = 0; menv->ran = 0; + menv->did_starts = NULL; + + for (env2 = menv->exp_env; env2; env2 = env2->exp_env) { + env2->module = m; + } + for (env2 = menv->template_env; env2; env2 = env2->template_env) { + env2->module = m; + } + env2 = menv->label_env; + if (env2) + env2->module = m; } + insp = scheme_make_inspector(m->insp); + menv->insp = insp; + + /* These three should be set by various "finish"es, but + we initialize them in case there's an error runing a "finish". */ + menv->require_names = scheme_null; + menv->et_require_names = scheme_null; + menv->tt_require_names = scheme_null; + menv->dt_require_names = scheme_null; + if (env->label_env != env) { setup_accessible_table(m); @@ -3965,9 +3979,6 @@ static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, return; } - if (restart) - menv->running = 0; - if (menv->running > 0) { return; } @@ -4001,6 +4012,7 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, { Scheme_Env *menv; Scheme_Object *l, *new_cycle_list; + int prep_namespace = 0; if (SAME_OBJ(m, kernel)) return; @@ -4019,15 +4031,6 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, check_phase(menv, env, 0); - if (restart) { - menv->did_starts = NULL; - menv->require_names = NULL; - menv->et_require_names = NULL; - menv->tt_require_names = NULL; - menv->dt_require_names = NULL; - menv->other_require_names = NULL; - } - show("chck", menv, eval_exp, eval_run, base_phase); if (did_start(menv->did_starts, base_phase, eval_exp, eval_run)) @@ -4044,6 +4047,13 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, chain_start_module(menv, env, eval_exp, eval_run, base_phase, cycle_list, syntax_idx); + if (restart) { + if (menv->rename_set_ready) { + menv->rename_set_ready = 0; + prep_namespace = 1; + } + } + if (env->phase == base_phase) { if (eval_exp) { if (eval_exp > 0) { @@ -4079,6 +4089,9 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, show_indent(-1); show_done("done", menv, eval_exp, eval_run, base_phase); + + if (prep_namespace) + scheme_prep_namespace_rename(menv); } static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) @@ -4677,7 +4690,7 @@ module_execute(Scheme_Object *data) if (!SCHEME_SYMBOLP(m->self_modidx)) { Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx; Scheme_Object *nmidx; - + nmidx = scheme_make_modidx(midx->path, midx->base, m->modname); m->self_modidx = nmidx; @@ -4749,7 +4762,7 @@ module_execute(Scheme_Object *data) /* Replacing an already-running or already-syntaxing module? */ if (old_menv) { - start_module(m, env, 1, NULL, 0, (old_menv->running > 0) ? 1 : 0, env->phase, scheme_null); + start_module(m, env, 1, NULL, old_menv->et_running, old_menv->running, env->phase, scheme_null); } return scheme_void; @@ -8436,10 +8449,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ ? scheme_modidx_shift(exss[j], me->src_modidx, idx) : idx); - if (!iname) - iname = exs[j]; - - if (SCHEME_SYM_WEIRDP(iname)) { + if (SCHEME_SYM_WEIRDP(exs[j])) { /* This shouldn't happen. In case it does, don't import a gensym or parallel symbol. The former is useless. The latter is supposed to be module-specific, and it could @@ -8448,6 +8458,9 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ continue; } + if (!iname) + iname = exs[j]; + if (prefix) iname = scheme_symbol_append(prefix, iname); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 385e3f4e9d..5c5337730d 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -744,6 +744,7 @@ int *scheme_stx_get_rib_sealed(Scheme_Object *rib); Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename); Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); +Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs); Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to, Scheme_Object *uid); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index a012173ea4..7f555aff10 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -220,6 +220,7 @@ static Module_Renames *krn; #define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) #define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) +#define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type)) static int is_rename_inspector_info(Scheme_Object *v) { @@ -267,6 +268,15 @@ static int is_rename_inspector_info(Scheme_Object *v) new vectors can be added imperatively; simplification turns this into a vector + - A wrap-elem (make-rib-delimiter ) + appears in pairs around rib elements; the deeper is just a + bracket, while the shallow one contains a non-empty list of + ribs; for each environment name defined within the set of + ribs, no rib within the set can build on a binding to that + environment past the end delimiter; this is used by `local-expand' + when given a list of ribs, and simplifcation eliminates + rib delimiters + - A wrap-elem is a module rename set the hash table maps renamed syms to modname-srcname pairs @@ -1942,6 +1952,34 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) return scheme_add_rename(o, rib); } +Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs) +{ + Scheme_Object *s; + + s = scheme_alloc_small_object(); + s->type = scheme_rib_delimiter_type; + SCHEME_BOX_VAL(s) = ribs; + + return scheme_add_rename(o, s); +} + +static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim) +{ + Scheme_Object *l = SCHEME_BOX_VAL(rib_delim); + Scheme_Lexical_Rib *rib; + + while (!SCHEME_NULLP(l)) { + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l); + while (rib) { + if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0])) + return 1; + rib = rib->next; + } + l = SCHEME_CDR(l); + } + return 0; +} + static Scheme_Hash_Table *make_recur_table() { if (quick_hash_table) { @@ -3940,8 +3978,8 @@ static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *othe return orig; } -/* This needs to be a multiple of 3: */ -#define QUICK_STACK_SIZE 12 +/* This needs to be a multiple of 4: */ +#define QUICK_STACK_SIZE 16 /* Although resolve_env may call itself recursively, the recursion depth is bounded (by the fact that modules can't be nested, @@ -3970,7 +4008,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; Scheme_Object *mresult = scheme_false, *mresult_insp; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; - Scheme_Object *rename_stack[QUICK_STACK_SIZE]; + Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false; int stack_pos = 0, no_lexical = 0; int is_in_module = 0, skip_other_mods = 0, floating_checked = 0; Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; @@ -3992,21 +4030,27 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, while (1) { if (WRAP_POS_END_P(wraps)) { /* See rename case for info on rename_stack: */ - Scheme_Object *result, *result_free_rename, *key; + Scheme_Object *result, *result_free_rename, *key, *rd; int did_lexical = 0; EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); result = scheme_false; result_free_rename = scheme_false; + rib_delim = scheme_null; while (!SCHEME_NULLP(o_rename_stack)) { - key = SCHEME_CAAR(o_rename_stack); + key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0]; if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); did_lexical = 1; - result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); - result_free_rename = SCHEME_CDR(result); - result = SCHEME_CAR(result); + rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3]; + if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { + /* not a match, due to rib delimiter */ + } else { + result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1]; + result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2]; + rib_delim = rd; + } } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { @@ -4020,9 +4064,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, key = rename_stack[stack_pos - 1]; if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); - result = rename_stack[stack_pos - 2]; - result_free_rename = rename_stack[stack_pos - 3]; - did_lexical = 1; + rd = rename_stack[stack_pos - 4]; + if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { + /* not a match, due to rib delimiter */ + } else { + result = rename_stack[stack_pos - 2]; + result_free_rename = rename_stack[stack_pos - 3]; + rib_delim = rd; + did_lexical = 1; + } } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { @@ -4030,7 +4080,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, did_lexical = 0; } } - stack_pos -= 3; + stack_pos -= 4; } if (!did_lexical) { result = mresult; @@ -4485,12 +4535,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, free_id_rename = vec; } if (stack_pos < QUICK_STACK_SIZE) { + rename_stack[stack_pos++] = rib_delim; rename_stack[stack_pos++] = free_id_rename; rename_stack[stack_pos++] = envname; rename_stack[stack_pos++] = other_env; } else { - o_rename_stack = CONS(CONS(other_env, CONS(envname, free_id_rename)), - o_rename_stack); + Scheme_Object *vec; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = other_env; + SCHEME_VEC_ELS(vec)[1] = envname; + SCHEME_VEC_ELS(vec)[2] = free_id_rename; + SCHEME_VEC_ELS(vec)[3] = rib_delim; + o_rename_stack = CONS(vec, o_rename_stack); } if (is_rib) { /* skip future instances of the same rib; @@ -4531,6 +4587,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else rib = NULL; } + } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) { + rib_delim = WRAP_POS_FIRST(wraps); + if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) + rib_delim = scheme_false; } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); did_rib = NULL; @@ -5465,8 +5525,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab { WRAP_POS w, prev, w2; Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs; - Scheme_Object *ribs_stack = scheme_null; - Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; + Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false; + Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl; Scheme_Lexical_Rib *did_rib = NULL; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; int copy_on_write, no_rib_mutation = 1; @@ -5509,6 +5569,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab old_key = NULL; v2l = scheme_null; + v2rdl = NULL; EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); @@ -5625,7 +5686,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab ribs_stack = scheme_make_pair(scheme_false, ribs_stack); } else { ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, - (Scheme_Object *)prev_skip_ribs_ht), + scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht, + rib_delim)), ribs_stack); } @@ -5643,6 +5705,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab break; } } + } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) { + rib_delim = WRAP_POS_FIRST(w); + if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) + rib_delim = scheme_false; } WRAP_POS_INC(w); @@ -5667,6 +5733,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab Scheme_Object *local_ribs; int ii, vvsize, done_rib_pos = 0; + rib_delim = scheme_false; + if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); @@ -5674,8 +5742,11 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab vsize = 0; local_ribs = NULL; } else { - prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack)); - skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack)); + rib_delim = SCHEME_CAR(ribs_stack); + prec_ribs = SCHEME_CAR(rib_delim); + rib_delim = SCHEME_CDR(rib_delim); + skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim); + rib_delim = SCHEME_CDR(rib_delim); ribs_stack = SCHEME_CDR(ribs_stack); if (SCHEME_RIBP(v)) { @@ -5707,6 +5778,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab size = vsize; v2 = scheme_make_vector(2 + (2 * size), NULL); + v2_rib_delims = MALLOC_N(Scheme_Object *, size); pos = 0; /* counter for used slots */ @@ -5737,8 +5809,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab /* Either this name is in prev, in which case the answer must match this rename's target, or this rename's answer applies. */ - Scheme_Object *ok = NULL, *ok_replace = NULL; - int ok_replace_index = 0; + Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL; + int ok_replace_index = 0, ok_replace_rd_index = 0; Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; if (rib) { @@ -5774,7 +5846,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if (!WRAP_POS_END_P(prev) || SCHEME_PAIRP(v2l)) { WRAP_POS w3; - Scheme_Object *vp; + Scheme_Object *vp, **vrdp; /* Check marks (now that we have the correct barriers). */ WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); @@ -5799,11 +5871,16 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab orig_prev_env = prev_env; if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); if (SAME_OBJ(prev_env, other_env)) { - ok = SCHEME_VEC_ELS(v)[0]; - ok_replace = v2; - ok_replace_index = 2 + size + j; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_env); + if (SCHEME_FALSEP(rib_delim) + || SAME_OBJ(v2_rib_delims[j], rib_delim) + || !is_in_rib_delim(prev_env, rib_delim)) { + ok = SCHEME_VEC_ELS(v)[0]; + ok_replace = v2; + ok_replace_index = 2 + size + j; + ok_replace_rd = v2_rib_delims; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); + } } else { EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); ok = NULL; @@ -5816,12 +5893,19 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab int passed_mutable = 0; WRAP_POS_COPY(w3, prev); svl = v2l; + svrdl = v2rdl; for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; - if (SCHEME_PAIRP(svl)) + if (SCHEME_PAIRP(svl)) { vp = SCHEME_CAR(svl); - else + if (svrdl) + vrdp = (Scheme_Object **)SCHEME_CAR(svrdl); + else + vrdp = NULL; + } else { vp = WRAP_POS_FIRST(w3); + vrdp = NULL; + } if (SCHEME_VECTORP(vp)) { psize = SCHEME_RENAME_LEN(vp); for (j = 0; j < psize; j++) { @@ -5829,7 +5913,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; orig_prev_env = prev_env; if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); - if (SAME_OBJ(prev_env, other_env)) { + if (SAME_OBJ(prev_env, other_env) + && (SCHEME_FALSEP(rib_delim) + || (vrdp && (SAME_OBJ(vrdp[j], rib_delim))) + || !is_in_rib_delim(prev_env, rib_delim))) { ok = SCHEME_VEC_ELS(v)[0]; if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) free_id_rename = SCHEME_CDR(orig_prev_env); @@ -5839,14 +5926,17 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(other_env, NULL))); ok = NULL; /* Alternate time/space tradeoff: could be - SCHEME_VEC_ELS(vp)[2+psize+j], - which is the value from prev */ + SCHEME_VEC_ELS(vp)[2+psize+j], + which is the value from prev */ } - if (ok && SCHEME_PAIRP(svl) && !passed_mutable) { + if (ok && SCHEME_PAIRP(svl) && !passed_mutable + && (SCHEME_FALSEP(rib_delim) || vrdp)) { /* Can overwrite old map, instead of adding a new one. */ ok_replace = vp; ok_replace_index = 2 + psize + j; + ok_replace_rd = vrdp; + ok_replace_rd_index = j; } break; } @@ -5854,9 +5944,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if (j < psize) break; } - if (SCHEME_PAIRP(svl)) + if (SCHEME_PAIRP(svl)) { svl = SCHEME_CDR(svl); - else { + if (svrdl) svrdl = SCHEME_CDR(svrdl); + } else { WRAP_POS_INC(w3); } } @@ -5887,10 +5978,12 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; + ok_replace_rd[ok_replace_rd_index] = rib_delim; } else { EXPLAIN_S(fprintf(stderr, " add mapping %s\n", scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(v2)[2+size+pos] = ok; + v2_rib_delims[pos] = rib_delim; pos++; } } else { @@ -5945,6 +6038,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } v2l = CONS(v2, v2l); + v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl); } WRAP_POS_DEC(w); @@ -6062,6 +6156,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, } } /* else empty simplified vector, which we drop */ + } else if (SCHEME_RIB_DELIMP(a)) { + /* simpliciation eliminates the need for rib delimiters */ } else if (SCHEME_RENAMESP(a) || SCHEME_RENAMES_SETP(a)) { int which = 0; @@ -8252,7 +8348,7 @@ static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) Scheme_Stx *stx; if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-property", "syntax", 0, argc, argv); + scheme_wrong_type("syntax-property-symbol-keys", "syntax", 0, argc, argv); stx = (Scheme_Stx *)argv[0]; diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 1cb9de0bcc..bc774cc6e9 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -168,84 +168,85 @@ enum { scheme_logger_type, /* 150 */ scheme_log_reader_type, /* 151 */ scheme_free_id_info_type, /* 152 */ + scheme_rib_delimiter_type, /* 153 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 153 */ + _scheme_last_normal_type_, /* 154 */ - scheme_rt_weak_array, /* 154 */ + scheme_rt_weak_array, /* 155 */ - scheme_rt_comp_env, /* 155 */ - scheme_rt_constant_binding, /* 156 */ - scheme_rt_resolve_info, /* 157 */ - scheme_rt_optimize_info, /* 158 */ - scheme_rt_compile_info, /* 159 */ - scheme_rt_cont_mark, /* 160 */ - scheme_rt_saved_stack, /* 161 */ - scheme_rt_reply_item, /* 162 */ - scheme_rt_closure_info, /* 163 */ - scheme_rt_overflow, /* 164 */ - scheme_rt_overflow_jmp, /* 165 */ - scheme_rt_meta_cont, /* 166 */ - scheme_rt_dyn_wind_cell, /* 167 */ - scheme_rt_dyn_wind_info, /* 168 */ - scheme_rt_dyn_wind, /* 169 */ - scheme_rt_dup_check, /* 170 */ - scheme_rt_thread_memory, /* 171 */ - scheme_rt_input_file, /* 172 */ - scheme_rt_input_fd, /* 173 */ - scheme_rt_oskit_console_input, /* 174 */ - scheme_rt_tested_input_file, /* 175 */ - scheme_rt_tested_output_file, /* 176 */ - scheme_rt_indexed_string, /* 177 */ - scheme_rt_output_file, /* 178 */ - scheme_rt_load_handler_data, /* 179 */ - scheme_rt_pipe, /* 180 */ - scheme_rt_beos_process, /* 181 */ - scheme_rt_system_child, /* 182 */ - scheme_rt_tcp, /* 183 */ - scheme_rt_write_data, /* 184 */ - scheme_rt_tcp_select_info, /* 185 */ - scheme_rt_namespace_option, /* 186 */ - scheme_rt_param_data, /* 187 */ - scheme_rt_will, /* 188 */ - scheme_rt_struct_proc_info, /* 189 */ - scheme_rt_linker_name, /* 190 */ - scheme_rt_param_map, /* 191 */ - scheme_rt_finalization, /* 192 */ - scheme_rt_finalizations, /* 193 */ - scheme_rt_cpp_object, /* 194 */ - scheme_rt_cpp_array_object, /* 195 */ - scheme_rt_stack_object, /* 196 */ - scheme_rt_preallocated_object, /* 197 */ - scheme_thread_hop_type, /* 198 */ - scheme_rt_srcloc, /* 199 */ - scheme_rt_evt, /* 200 */ - scheme_rt_syncing, /* 201 */ - scheme_rt_comp_prefix, /* 202 */ - scheme_rt_user_input, /* 203 */ - scheme_rt_user_output, /* 204 */ - scheme_rt_compact_port, /* 205 */ - scheme_rt_read_special_dw, /* 206 */ - scheme_rt_regwork, /* 207 */ - scheme_rt_buf_holder, /* 208 */ - scheme_rt_parameterization, /* 209 */ - scheme_rt_print_params, /* 210 */ - scheme_rt_read_params, /* 211 */ - scheme_rt_native_code, /* 212 */ - scheme_rt_native_code_plus_case, /* 213 */ - scheme_rt_jitter_data, /* 214 */ - scheme_rt_module_exports, /* 215 */ - scheme_rt_delay_load_info, /* 216 */ - scheme_rt_marshal_info, /* 217 */ - scheme_rt_unmarshal_info, /* 218 */ - scheme_rt_runstack, /* 219 */ - scheme_rt_sfs_info, /* 220 */ - scheme_rt_validate_clearing, /* 221 */ - scheme_rt_rb_node, /* 222 */ + scheme_rt_comp_env, /* 156 */ + scheme_rt_constant_binding, /* 157 */ + scheme_rt_resolve_info, /* 158 */ + scheme_rt_optimize_info, /* 159 */ + scheme_rt_compile_info, /* 160 */ + scheme_rt_cont_mark, /* 161 */ + scheme_rt_saved_stack, /* 162 */ + scheme_rt_reply_item, /* 163 */ + scheme_rt_closure_info, /* 164 */ + scheme_rt_overflow, /* 165 */ + scheme_rt_overflow_jmp, /* 166 */ + scheme_rt_meta_cont, /* 167 */ + scheme_rt_dyn_wind_cell, /* 168 */ + scheme_rt_dyn_wind_info, /* 169 */ + scheme_rt_dyn_wind, /* 170 */ + scheme_rt_dup_check, /* 171 */ + scheme_rt_thread_memory, /* 172 */ + scheme_rt_input_file, /* 173 */ + scheme_rt_input_fd, /* 174 */ + scheme_rt_oskit_console_input, /* 175 */ + scheme_rt_tested_input_file, /* 176 */ + scheme_rt_tested_output_file, /* 177 */ + scheme_rt_indexed_string, /* 178 */ + scheme_rt_output_file, /* 179 */ + scheme_rt_load_handler_data, /* 180 */ + scheme_rt_pipe, /* 181 */ + scheme_rt_beos_process, /* 182 */ + scheme_rt_system_child, /* 183 */ + scheme_rt_tcp, /* 184 */ + scheme_rt_write_data, /* 185 */ + scheme_rt_tcp_select_info, /* 186 */ + scheme_rt_namespace_option, /* 187 */ + scheme_rt_param_data, /* 188 */ + scheme_rt_will, /* 189 */ + scheme_rt_struct_proc_info, /* 190 */ + scheme_rt_linker_name, /* 191 */ + scheme_rt_param_map, /* 192 */ + scheme_rt_finalization, /* 193 */ + scheme_rt_finalizations, /* 194 */ + scheme_rt_cpp_object, /* 195 */ + scheme_rt_cpp_array_object, /* 196 */ + scheme_rt_stack_object, /* 197 */ + scheme_rt_preallocated_object, /* 198 */ + scheme_thread_hop_type, /* 199 */ + scheme_rt_srcloc, /* 200 */ + scheme_rt_evt, /* 201 */ + scheme_rt_syncing, /* 202 */ + scheme_rt_comp_prefix, /* 203 */ + scheme_rt_user_input, /* 204 */ + scheme_rt_user_output, /* 205 */ + scheme_rt_compact_port, /* 206 */ + scheme_rt_read_special_dw, /* 207 */ + scheme_rt_regwork, /* 208 */ + scheme_rt_buf_holder, /* 209 */ + scheme_rt_parameterization, /* 210 */ + scheme_rt_print_params, /* 211 */ + scheme_rt_read_params, /* 212 */ + scheme_rt_native_code, /* 213 */ + scheme_rt_native_code_plus_case, /* 214 */ + scheme_rt_jitter_data, /* 215 */ + scheme_rt_module_exports, /* 216 */ + scheme_rt_delay_load_info, /* 217 */ + scheme_rt_marshal_info, /* 218 */ + scheme_rt_unmarshal_info, /* 219 */ + scheme_rt_runstack, /* 220 */ + scheme_rt_sfs_info, /* 221 */ + scheme_rt_validate_clearing, /* 222 */ + scheme_rt_rb_node, /* 223 */ #endif - scheme_place_type, /* 223 */ - scheme_engine_type, /* 224 */ + scheme_place_type, /* 224 */ + scheme_engine_type, /* 225 */ _scheme_last_type_ }; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 5f800c28fa..fdcad81833 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -619,6 +619,8 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_log_reader_type, mark_log_reader); GC_REG_TRAV(scheme_rt_runstack, runstack_val); + + GC_REG_TRAV(scheme_rib_delimiter_type, small_object); } END_XFORM_SKIP;