sync to trunk
svn: r14681
This commit is contained in:
Sam Tobin-Hochstadt
commit
83abdf9eae
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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 (... <tmpl>) 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)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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?)))
|
||||
|
|
|
|||
|
|
@ -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?)))
|
||||
|
|
|
|||
|
|
@ -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?)))
|
||||
|
|
|
|||
|
|
@ -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))))])))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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].}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <at line ...> 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 <value>, contract <at ...>
|
||||
(test-engine-got "got")
|
||||
|
||||
(profjWizward-insert-java-class "Insert Java Class")
|
||||
(profjWizard-insert-java-union "Insert Java Union")
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <at line ...> to blame: procedure <at line ...>
|
||||
(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 <value>, contract <at ...>
|
||||
(test-engine-got "bekam")
|
||||
|
||||
(profjWizward-insert-java-class "Java-Klasse einfügen")
|
||||
(profjWizard-insert-java-union "Java-Vereinigung einfügen")
|
||||
|
||||
|
|
|
|||
|
|
@ -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))])
|
||||
|
|
|
|||
83
collects/syntax/private/template-runtime.ss
Normal file
83
collects/syntax/private/template-runtime.ss
Normal file
|
|
@ -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")])))
|
||||
99
collects/syntax/scribblings/template.scrbl
Normal file
99
collects/syntax/scribblings/template.scrbl
Normal file
|
|
@ -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)]))
|
||||
]}
|
||||
|
|
@ -9,3 +9,4 @@
|
|||
@include-section["flatten-begin.scrbl"]
|
||||
@include-section["struct.scrbl"]
|
||||
@include-section["path-spec.scrbl"]
|
||||
@include-section["template.scrbl"]
|
||||
|
|
|
|||
189
collects/syntax/template.ss
Normal file
189
collects/syntax/template.ss
Normal file
|
|
@ -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)))))
|
||||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
31
collects/test-engine/print.ss
Normal file
31
collects/test-engine/print.ss
Normal file
|
|
@ -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. ~<w> 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))))))
|
||||
|
||||
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 <file-name> -p <port> -a <ip-address> --ssl]}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 <list-of-rib>)
|
||||
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 <rename-table> 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];
|
||||
|
||||
|
|
|
|||
|
|
@ -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_
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user