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

added automatic compilation to the module language, plus various other tweaks (contract library enhancement, bug fixes here and there)

Browse Source 
svn: r15635
This commit is contained in:
Robby Findler 2009-07-30 05:17:40 +00:00
parent 6fe071364f
commit b5b32d1d8e
31 changed files with 1777 additions and 1262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/algol60/tool.ss
View File

@ -8,7 +8,8 @@
"compile.ss" "compile.ss"
compiler/embed compiler/embed
string-constants string-constants
(prefix bd: "bd-tool.ss")) errortrace/errortrace-lib
(prefix bd: "bd-tool.ss"))
(provide tool@) (provide tool@)
@ -92,8 +93,7 @@
(lambda () (lambda ()
(error-display-handler (error-display-handler
(drscheme:debug:make-debug-error-display-handler (error-display-handler))) (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(current-eval (current-compile (make-errortrace-compile-handler))
(drscheme:debug:make-debug-eval-handler (current-eval)))
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(printf "~a~n" (printf "~a~n"
(exn-message x)))]) (exn-message x)))])

29
collects/drscheme/private/debug.ss
View File

@ -8,7 +8,8 @@ profile todo:
|# |#
(require scheme/unit (require errortrace/errortrace-key
scheme/unit
scheme/contract scheme/contract
errortrace/stacktrace errortrace/stacktrace
scheme/class scheme/class
@ -64,21 +65,15 @@ profile todo:
;; for debugging -- be sure to print to here, not the current output port ;; for debugging -- be sure to print to here, not the current output port
(define original-output-port (current-output-port)) (define original-output-port (current-output-port))
;; cm-key : symbol
;; the key used to put information on the continuation
(define cm-key (gensym 'drscheme-debug-continuation-mark-key))
(define (get-cm-key) cm-key)
;; cms->srclocs : continuation-marks -> (listof srcloc) ;; cms->srclocs : continuation-marks -> (listof srcloc)
(define (cms->srclocs cms) (define (cms->srclocs cms)
(map (map
(λ (x) (make-srcloc (list-ref x 0) (λ (x) (make-srcloc (list-ref x 1)
(list-ref x 1)
(list-ref x 2) (list-ref x 2)
(list-ref x 3) (list-ref x 3)
(list-ref x 4))) (list-ref x 4)
(continuation-mark-set->list cms cm-key))) (list-ref x 5)))
(continuation-mark-set->list cms errortrace-key)))
;; error-delta : (instanceof style-delta%) ;; error-delta : (instanceof style-delta%)
(define error-delta (make-object style-delta% 'change-style 'italic)) (define error-delta (make-object style-delta% 'change-style 'italic))
@ -493,7 +488,7 @@ profile todo:
;; with-mark : mark-stx syntax (any? -> syntax) -> syntax ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax
;; a member of stacktrace-imports^ ;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with cm-key are ;; guarantees that the continuation marks associated with errortrace-key are
;; members of the debug-source type, after unwrapped with st-mark-source ;; members of the debug-source type, after unwrapped with st-mark-source
(define (with-mark src-stx expr) (define (with-mark src-stx expr)
(let ([source (cond (let ([source (cond
@ -518,10 +513,10 @@ profile todo:
[column (or (syntax-column src-stx) 0)]) [column (or (syntax-column src-stx) 0)])
(if source (if source
(with-syntax ([expr expr] (with-syntax ([expr expr]
[mark (list source line column position span)] [mark (list 'dummy-thing source line column position span)]
[cm-key cm-key]) [errortrace-key errortrace-key])
(syntax (syntax
(with-continuation-mark 'cm-key (with-continuation-mark 'errortrace-key
'mark 'mark
expr))) expr)))
expr))) expr)))
@ -1265,8 +1260,8 @@ profile todo:
(let ([profile-info (thread-cell-ref current-profile-info)]) (let ([profile-info (thread-cell-ref current-profile-info)])
(when profile-info (when profile-info
(hash-set! profile-info (hash-set! profile-info
key key
(make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr))))
(void)) (void))
;; register-profile-start : sym -> (union #f number) ;; register-profile-start : sym -> (union #f number)

1
collects/drscheme/private/drsig.ss
View File

@ -65,7 +65,6 @@
hide-backtrace-window hide-backtrace-window
show-backtrace-window show-backtrace-window
open-and-highlight-in-file open-and-highlight-in-file
get-cm-key
small-planet-bitmap small-planet-bitmap

14
collects/drscheme/private/language-configuration.ss
View File

@ -1285,6 +1285,16 @@
(super-new))) (super-new)))
(define (add-errortrace-key-mixin %)
(class %
(define/override (on-execute setting run-in-user-thread)
(super on-execute setting run-in-user-thread)
(run-in-user-thread
(λ ()
(namespace-require 'errortrace/errortrace-key)
(namespace-transformer-require 'errortrace/errortrace-key))))
(super-new)))
(define (r5rs-mixin %) (define (r5rs-mixin %)
(class % (class %
(define/override (on-execute setting run-in-user-thread) (define/override (on-execute setting run-in-user-thread)
@ -1374,7 +1384,7 @@
(list -200 3) (list -200 3)
#t #t
(string-constant pretty-big-scheme-one-line-summary) (string-constant pretty-big-scheme-one-line-summary)
assume-mixin)) (λ (%) (assume-mixin (add-errortrace-key-mixin %)))))
(add-language (add-language
(make-simple '(lib "r5rs/lang.ss") (make-simple '(lib "r5rs/lang.ss")
"plt:r5rs" "plt:r5rs"
@ -1383,7 +1393,7 @@
(list -200 -1000) (list -200 -1000)
#f #f
(string-constant r5rs-one-line-summary) (string-constant r5rs-one-line-summary)
(lambda (%) (r5rs-mixin (assume-mixin %))))) (lambda (%) (r5rs-mixin (assume-mixin (add-errortrace-key-mixin %))))))
(add-language (add-language
(make-simple 'mzscheme (make-simple 'mzscheme

82
collects/drscheme/private/language.ss
View File

@ -5,25 +5,33 @@
;; (esp. useful when debugging the users's io) ;; (esp. useful when debugging the users's io)
(require "drsig.ss" (require "drsig.ss"
string-constants string-constants
mzlib/pconvert
mzlib/pretty ;; NOTE: this module instantiates stacktrace itself, so we have
mzlib/etc ;; to be careful to not mix that instantiation with the one
mzlib/struct ;; drscheme/private/debug.ss does. errortrace-lib's is for the
mzlib/class ;; compilation handling, DrScheme's is for profiling and test coverage
scheme/file ;; (which do not do compilation)
mzlib/list (prefix-in el: errortrace/errortrace-lib)
compiler/embed
launcher mzlib/pconvert
mred scheme/pretty
framework mzlib/struct
mrlib/syntax-browser scheme/class
compiler/distribute scheme/file
compiler/bundle-dist scheme/list
"rep.ss") compiler/embed
launcher
mred
framework
mrlib/syntax-browser
compiler/distribute
compiler/bundle-dist
"rep.ss")
(import [prefix drscheme:debug: drscheme:debug^] (import [prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:help-desk: drscheme:help-desk^]) [prefix drscheme:help-desk: drscheme:help-desk^])
(export drscheme:language^) (export drscheme:language^)
@ -203,8 +211,9 @@
(define (simple-module-based-language-config-panel (define (simple-module-based-language-config-panel
_parent _parent
#:case-sensitive [*case-sensitive '?] #:case-sensitive [*case-sensitive '?]
#:annotations-callback [annotations-callback void] #:dynamic-panel-extras [dynamic-panel-extras void]
#:dynamic-panel-extras [dynamic-panel-extras void]) #:get-debugging-radio-box [get-debugging-radio-box void]
#:debugging-radio-box-callback [debugging-radio-box-callback void])
(letrec ([parent (instantiate vertical-panel% () (letrec ([parent (instantiate vertical-panel% ()
(parent _parent) (parent _parent)
(alignment '(center center)))] (alignment '(center center)))]
@ -238,7 +247,7 @@
(string-constant debugging-and-profiling) (string-constant debugging-and-profiling)
(string-constant test-coverage))) (string-constant test-coverage)))
(parent dynamic-panel) (parent dynamic-panel)
(callback (λ (x y) (annotations-callback x y))))] (callback debugging-radio-box-callback))]
[output-style (make-object radio-box% [output-style (make-object radio-box%
(string-constant output-style-label) (string-constant output-style-label)
(list (string-constant constructor-printing-style) (list (string-constant constructor-printing-style)
@ -263,7 +272,7 @@
(string-constant use-pretty-printer-label) (string-constant use-pretty-printer-label)
output-panel output-panel
void)]) void)])
(get-debugging-radio-box debugging)
(dynamic-panel-extras dynamic-panel) (dynamic-panel-extras dynamic-panel)
(case-lambda (case-lambda
@ -412,16 +421,29 @@
(define (initialize-simple-module-based-language setting run-in-user-thread) (define (initialize-simple-module-based-language setting run-in-user-thread)
(run-in-user-thread (run-in-user-thread
(λ () (λ ()
(let ([annotations (simple-settings-annotations setting)]) (let ([annotations (simple-settings-annotations setting)])
(when (memq annotations '(debug debug/profile test-coverage)) (case annotations
(current-eval [(debug)
(drscheme:debug:make-debug-eval-handler (current-compile (el:make-errortrace-compile-handler))
(current-eval))) (error-display-handler
(error-display-handler (drscheme:debug:make-debug-error-display-handler
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(error-display-handler)))) (use-compiled-file-paths
(drscheme:debug:profiling-enabled (eq? annotations 'debug/profile)) (cons (build-path "compiled" "errortrace")
(drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage))) (use-compiled-file-paths)))]
[(debug/profile)
(drscheme:debug:profiling-enabled #t)
(error-display-handler
(drscheme:debug:make-debug-error-display-handler
(error-display-handler)))
(current-eval (drscheme:debug:make-debug-eval-handler (current-eval)))]
[(debug/profile test-coverage)
(drscheme:debug:test-coverage-enabled #t)
(current-eval (drscheme:debug:make-debug-eval-handler (current-eval)))]))
(global-port-print-handler (global-port-print-handler
(λ (value port) (λ (value port)
(let ([converted-value (simple-module-based-language-convert-value value setting)]) (let ([converted-value (simple-module-based-language-convert-value value setting)])
@ -1122,7 +1144,7 @@
(define to-snips null) (define to-snips null)
(define-struct to-snip (predicate? >value setup-thunk)) (define-struct to-snip (predicate? >value setup-thunk))
(define add-snip-value (define add-snip-value
(opt-lambda (predicate constructor [setup-thunk void]) (lambda (predicate constructor [setup-thunk void])
(set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips)))) (set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips))))
(define (value->snip v) (define (value->snip v)

1
collects/drscheme/private/link.ss
View File

@ -57,4 +57,3 @@
(prefix drscheme:modes: drscheme:modes^) (prefix drscheme:modes: drscheme:modes^)
(prefix drscheme:tracing: drscheme:tracing^)) (prefix drscheme:tracing: drscheme:tracing^))
drscheme-unit@)) drscheme-unit@))

153
collects/drscheme/private/module-language.ss
View File

@ -4,6 +4,7 @@
(require scheme/unit (require scheme/unit
scheme/class scheme/class
scheme/list scheme/list
scheme/path
mred mred
compiler/embed compiler/embed
compiler/cm compiler/cm
@ -45,9 +46,10 @@
;; command-line-args : (vectorof string) ;; command-line-args : (vectorof string)
;; auto-text : string ;; auto-text : string
(define-struct (module-language-settings drscheme:language:simple-settings) (define-struct (module-language-settings drscheme:language:simple-settings)
(collection-paths command-line-args auto-text compilation-on?)) (collection-paths command-line-args auto-text compilation-on? full-trace?))
(define default-compilation-on? #t) (define default-compilation-on? #t)
(define default-full-trace? #t)
(define default-auto-text "#lang scheme\n") (define default-auto-text "#lang scheme\n")
;; module-mixin : (implements drscheme:language:language<%>) ;; module-mixin : (implements drscheme:language:language<%>)
@ -68,19 +70,27 @@
(define/override (config-panel parent) (define/override (config-panel parent)
(module-language-config-panel parent)) (module-language-config-panel parent))
;; NOTE: this method is also used in the super class's implementation
;; of default-settings?, which is why the super call is appropriate
;; there, even tho these settings are not the same as the defaults
;; in other languages (here 'none is the default annotations,
;; there you get errortrace annotations).
(define/override (default-settings) (define/override (default-settings)
(let ([super-defaults (super default-settings)]) (let ([super-defaults (super default-settings)])
(apply make-module-language-settings (make-module-language-settings
(append #t 'write 'mixed-fraction-e #f #t 'none ;; simple settings defaults
(vector->list (drscheme:language:simple-settings->vector super-defaults))
(list '(default) '(default)
#() #()
default-auto-text default-auto-text
default-compilation-on?))))) default-compilation-on?
default-full-trace?)))
;; default-settings? : -> boolean ;; default-settings? : -> boolean
(define/override (default-settings? settings) (define/override (default-settings? settings)
(and (super default-settings? settings) (and (super default-settings? settings)
(equal? (module-language-settings-collection-paths settings) (equal? (module-language-settings-collection-paths settings)
'(default)) '(default))
(equal? (module-language-settings-command-line-args settings) (equal? (module-language-settings-command-line-args settings)
@ -90,7 +100,9 @@
;; (equal? (module-language-settings-auto-text settings) ;; (equal? (module-language-settings-auto-text settings)
;; default-auto-text) ;; default-auto-text)
(equal? (module-language-settings-compilation-on? settings) (equal? (module-language-settings-compilation-on? settings)
default-compilation-on?))) default-compilation-on?)
(equal? (module-language-settings-full-trace? settings)
default-full-trace?)))
(define/override (marshall-settings settings) (define/override (marshall-settings settings)
(let ([super-marshalled (super marshall-settings settings)]) (let ([super-marshalled (super marshall-settings settings)])
@ -112,7 +124,10 @@
(list-ref marshalled 3))] (list-ref marshalled 3))]
[compilation-on? (if (<= marshalled-len 4) [compilation-on? (if (<= marshalled-len 4)
default-compilation-on? default-compilation-on?
(list-ref marshalled 4))]) (list-ref marshalled 4))]
[full-trace? (if (<= marshalled-len 5)
default-full-trace?
(list-ref marshalled 5))])
(and (list? collection-paths) (and (list? collection-paths)
(andmap (λ (x) (or (string? x) (symbol? x))) (andmap (λ (x) (or (string? x) (symbol? x)))
collection-paths) collection-paths)
@ -128,7 +143,8 @@
(list collection-paths (list collection-paths
command-line-args command-line-args
auto-text auto-text
compilation-on?))))))))))) compilation-on?
full-trace?)))))))))))
(define/override (on-execute settings run-in-user-thread) (define/override (on-execute settings run-in-user-thread)
(super on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread)
@ -142,14 +158,62 @@
settings))]) settings))])
(when (null? cpaths) (when (null? cpaths)
(fprintf (current-error-port) (fprintf (current-error-port)
"Warning: your collection paths are empty!\n")) "WARNING: your collection paths are empty!\n"))
(current-library-collection-paths cpaths)) (current-library-collection-paths cpaths))
(when (and (module-language-settings-compilation-on? settings) (compile-context-preservation-enabled (module-language-settings-full-trace? settings))
(eq? (drscheme:language:simple-settings-annotations settings) 'none))
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))) (when (module-language-settings-compilation-on? settings)
;[manager-trace-handler (λ (x) (display x) (newline))] (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
))) (manager-skip-file-handler
(λ (p)
;; iterate over all of the collection paths; if we find that this path is
;; inside the collection hierarchy, we skip it.
(let ([p-eles (explode-path (simplify-path p))])
(let c-loop ([collects-paths (current-library-collection-paths)])
(cond
[(null? collects-paths) #f]
[else
(let i-loop ([collects-eles (explode-path (car collects-paths))]
[p-eles p-eles])
(cond
[(null? collects-eles)
;; we're inside the collection hierarchy, so we just
;; use the date of the original file (or the zo, whichever
;; is newer).
(let-values ([(base name dir) (split-path p)])
(let* ([ext (filename-extension p)]
[pbytes (path->bytes name)]
[zo-file-name
(and ext
(bytes->path
(bytes-append
(subbytes
pbytes
0
(- (bytes-length pbytes)
(bytes-length ext)))
#"zo")))]
[zo-path (and zo-file-name
(build-path
base
(car (use-compiled-file-paths))
zo-file-name))])
(cond
[(and zo-file-name (file-exists? zo-path))
(max (file-or-directory-modify-seconds p)
(file-or-directory-modify-seconds zo-file-name))]
[else
(file-or-directory-modify-seconds p)])))]
[(null? p-eles)
;; this case shouldn't happen... I think.
(c-loop (cdr collects-paths))]
[else
(cond
[(equal? (car p-eles) (car collects-eles))
(i-loop (cdr collects-eles) (cdr p-eles))]
[else
(c-loop (cdr collects-paths))])]))])))))))))
(define/override (get-one-line-summary) (define/override (get-one-line-summary)
(string-constant module-language-one-line-summary)) (string-constant module-language-one-line-summary))
@ -320,6 +384,7 @@
(semaphore-post s)))) (semaphore-post s))))
(semaphore-wait s)) (semaphore-wait s))
(custodian-shutdown-all (send rep get-user-custodian))) (custodian-shutdown-all (send rep get-user-custodian)))
(define (raise-hopeless-syntax-error . error-args) (define (raise-hopeless-syntax-error . error-args)
(with-handlers ([exn? raise-hopeless-exception]) (with-handlers ([exn? raise-hopeless-exception])
(apply raise-syntax-error '|Module Language| (apply raise-syntax-error '|Module Language|
@ -341,20 +406,41 @@
[alignment '(center center)] [alignment '(center center)]
[stretchable-height #f] [stretchable-height #f]
[stretchable-width #f])) [stretchable-width #f]))
(define compilation-on-radio-box #f) (define compilation-on-check-box #f)
(define annotations-radio-box #f) (define compilation-on? #t)
(define save-stacktrace-on-check-box #f)
(define debugging-radio-box #f)
(define simple-case-lambda (define simple-case-lambda
(drscheme:language:simple-module-based-language-config-panel (drscheme:language:simple-module-based-language-config-panel
new-parent new-parent
#:case-sensitive #t #:case-sensitive #t
#:annotations-callback
(λ (cb evt) (update-compilation-on-radio-box-visibility)) #:get-debugging-radio-box (λ (rb) (set! debugging-radio-box rb))
#:debugging-radio-box-callback
(λ (debugging-radio-box evt)
(update-compilation-checkbox debugging-radio-box))
#:dynamic-panel-extras #:dynamic-panel-extras
(λ (dynamic-panel) (λ (dynamic-panel)
(set! annotations-radio-box (car (send dynamic-panel get-children))) (set! compilation-on-check-box
(set! compilation-on-radio-box (new check-box% (new check-box%
[label (string-constant automatically-compile?)] [label (string-constant automatically-compile)]
[parent dynamic-panel]))))) [parent dynamic-panel]
[callback
(λ (_1 _2) (set! compilation-on? (send compilation-on-check-box get-value)))]))
(set! save-stacktrace-on-check-box (new check-box%
[label (string-constant preserve-stacktrace-information)]
[parent dynamic-panel])))))
(define (update-compilation-checkbox debugging-radio-box)
(case (send debugging-radio-box get-selection)
[(2 3)
(send compilation-on-check-box enable #f)
(send compilation-on-check-box set-value #f)]
[(0 1)
(send compilation-on-check-box enable #t)
(send compilation-on-check-box set-value compilation-on?)]))
(define cp-panel (new group-box-panel% (define cp-panel (new group-box-panel%
[parent new-parent] [parent new-parent]
[label (string-constant ml-cp-collection-paths)])) [label (string-constant ml-cp-collection-paths)]))
@ -409,8 +495,7 @@
(send remove-button enable lb-selection) (send remove-button enable lb-selection)
(send raise-button enable (and lb-selection (not (= lb-selection 0)))) (send raise-button enable (and lb-selection (not (= lb-selection 0))))
(send lower-button enable (send lower-button enable
(and lb-selection (not (= lb-selection (- lb-tot 1))))) (and lb-selection (not (= lb-selection (- lb-tot 1)))))))
(update-compilation-on-radio-box-visibility)))
(define (add-callback) (define (add-callback)
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path) (let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
@ -499,12 +584,10 @@
(define (install-auto-text str) (define (install-auto-text str)
(send auto-text-text-box set-value (regexp-replace #rx"\n$" str ""))) (send auto-text-text-box set-value (regexp-replace #rx"\n$" str "")))
(define (update-compilation-on-radio-box-visibility)
(send compilation-on-radio-box enable (equal? 0 (send annotations-radio-box get-selection))))
(install-collection-paths '(default)) (install-collection-paths '(default))
(update-buttons) (update-buttons)
(install-auto-text default-auto-text) (install-auto-text default-auto-text)
(update-compilation-checkbox debugging-radio-box)
(case-lambda (case-lambda
[() [()
@ -515,13 +598,19 @@
(list (get-collection-paths) (list (get-collection-paths)
(get-command-line-args) (get-command-line-args)
(get-auto-text) (get-auto-text)
(send compilation-on-radio-box get-value)))))] (case (send debugging-radio-box get-selection)
[(2 3) #f]
[(0 1) compilation-on?])
(send save-stacktrace-on-check-box get-value)))))]
[(settings) [(settings)
(simple-case-lambda settings) (simple-case-lambda settings)
(install-collection-paths (module-language-settings-collection-paths settings)) (install-collection-paths (module-language-settings-collection-paths settings))
(install-command-line-args (module-language-settings-command-line-args settings)) (install-command-line-args (module-language-settings-command-line-args settings))
(install-auto-text (module-language-settings-auto-text settings)) (install-auto-text (module-language-settings-auto-text settings))
(send compilation-on-radio-box set-value (module-language-settings-compilation-on? settings)) (set! compilation-on? (module-language-settings-compilation-on? settings))
(send compilation-on-check-box set-value (module-language-settings-compilation-on? settings))
(update-compilation-checkbox debugging-radio-box)
(send save-stacktrace-on-check-box set-value (module-language-settings-full-trace? settings))
(update-buttons)])) (update-buttons)]))
;; transform-module : (union #f path) syntax ;; transform-module : (union #f path) syntax

28
collects/drscheme/private/rep.ss
View File

@ -117,6 +117,7 @@ TODO
run-in-evaluation-thread run-in-evaluation-thread
after-many-evals after-many-evals
on-execute
shutdown shutdown
@ -134,6 +135,8 @@ TODO
reset-pretty-print-width reset-pretty-print-width
get-prompt get-prompt
insert-prompt insert-prompt
get-context)) get-context))
@ -662,7 +665,7 @@ TODO
;; highlight-errors : (listof srcloc) ;; highlight-errors : (listof srcloc)
;; (union #f (listof srcloc)) ;; (union #f (listof srcloc))
;; -> (void) ;; -> (void)
(define/public (highlight-errors raw-locs raw-error-arrows) (define/public (highlight-errors raw-locs [raw-error-arrows #f])
(let* ([cleanup-locs (let* ([cleanup-locs
(λ (locs) (λ (locs)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
@ -859,7 +862,7 @@ TODO
(field (user-language-settings #f) (field (user-language-settings #f)
(user-custodian-parent #f) (user-custodian-parent #f)
(memory-killed-thread #f) (memory-killed-cust-box #f)
(user-custodian #f) (user-custodian #f)
(custodian-limit (and (custodian-memory-accounting-available?) (custodian-limit (and (custodian-memory-accounting-available?)
(preferences:get 'drscheme:child-only-memory-limit))) (preferences:get 'drscheme:child-only-memory-limit)))
@ -912,7 +915,7 @@ TODO
(no-user-evaluation-message (no-user-evaluation-message
(get-frame) (get-frame)
user-exit-code user-exit-code
(not (thread-running? memory-killed-thread)))) (not (custodian-box-value memory-killed-cust-box))))
(set! show-no-user-evaluation-message? #t))) (set! show-no-user-evaluation-message? #t)))
(field (need-interaction-cleanup? #f)) (field (need-interaction-cleanup? #f))
@ -1140,6 +1143,10 @@ TODO
(cleanup-interaction) (cleanup-interaction)
(insert-prompt))))))) (insert-prompt)))))))
;; =User=, =Handler=
(define/pubment (on-execute rout) (inner (void) on-execute rout))
;; =Kernel=, =Handler=
(define/pubment (after-many-evals) (inner (void) after-many-evals)) (define/pubment (after-many-evals) (inner (void) after-many-evals))
(define/private shutdown-user-custodian ; =Kernel=, =Handler= (define/private shutdown-user-custodian ; =Kernel=, =Handler=
@ -1199,9 +1206,7 @@ TODO
(set! user-custodian-parent (make-custodian)) (set! user-custodian-parent (make-custodian))
(set! user-custodian (parameterize ([current-custodian user-custodian-parent]) (set! user-custodian (parameterize ([current-custodian user-custodian-parent])
(make-custodian))) (make-custodian)))
(set! memory-killed-thread (set! memory-killed-cust-box (make-custodian-box user-custodian-parent #t))
(parameterize ([current-custodian user-custodian-parent])
(thread (λ () (semaphore-wait (make-semaphore 0))))))
(when custodian-limit (when custodian-limit
(custodian-limit-memory user-custodian-parent (custodian-limit-memory user-custodian-parent
custodian-limit custodian-limit
@ -1294,7 +1299,11 @@ TODO
(send (drscheme:language-configuration:language-settings-language user-language-settings) (send (drscheme:language-configuration:language-settings-language user-language-settings)
on-execute on-execute
(drscheme:language-configuration:language-settings-settings user-language-settings) (drscheme:language-configuration:language-settings-settings user-language-settings)
(let ([run-on-user-thread (lambda (t) (queue-user/wait t))]) (let ([run-on-user-thread (lambda (t)
(queue-user/wait
(λ ()
(with-handlers ((exn? (λ (x) (printf "~s\n" (exn-message x)))))
(t)))))])
run-on-user-thread)) run-on-user-thread))
;; setup the special repl values ;; setup the special repl values
@ -1312,6 +1321,11 @@ TODO
"copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n") "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n")
(raise exn))) (raise exn)))
;; allow extensions to this class to do some setup work
(on-execute
(let ([run-on-user-thread (lambda (t) (queue-user/wait t))])
run-on-user-thread))
(parameterize ([current-eventspace user-eventspace]) (parameterize ([current-eventspace user-eventspace])
(queue-callback (queue-callback
(λ () (λ ()

79
collects/drscheme/tool-lib.ss
View File

@ -27,6 +27,8 @@ all of the names in the tools library, for use defining keybindings
(require/doc drscheme/private/ts scheme/base scribble/manual) (require/doc drscheme/private/ts scheme/base scribble/manual)
(require/doc (for-label errortrace/errortrace-key))
(shutdown-splash) (shutdown-splash)
(define-values/invoke-unit/infer drscheme@) (define-values/invoke-unit/infer drscheme@)
(close-splash) (close-splash)
@ -298,7 +300,7 @@ all of the names in the tools library, for use defining keybindings
drscheme:debug:error-display-handler/stacktrace drscheme:debug:error-display-handler/stacktrace
(->* (string? any/c) (->* (string? any/c)
((or/c false/c (listof srcloc?))) ((or/c false/c (listof srcloc?)))
any) (or/c #f (listof srcloc?)))
((msg exn) ((stack #f))) ((msg exn) ((stack #f)))
@{Displays the error message represented by the string, adding @{Displays the error message represented by the string, adding
embellishments like those that appears in the DrScheme REPL, embellishments like those that appears in the DrScheme REPL,
@ -306,8 +308,12 @@ all of the names in the tools library, for use defining keybindings
and a clickable icon for the source of the error (read & syntax errors show their source and a clickable icon for the source of the error (read & syntax errors show their source
locations and otherwise the first place in the stack trace is shown). locations and otherwise the first place in the stack trace is shown).
If @scheme[stack] is false, then the stack trace embedded in the @scheme[exn] argument (if any) is used. If @scheme[stack] is false, then the stack traces embedded in the @scheme[exn] argument (if any) are used.
Specifically, this function looks for a stacktrace via
@scheme[errortrace-key] in the continuation marks of @scheme[exn] and @scheme[continuation-mark-set->context].
If @scheme[stack] is not false, that stack is added to the stacks already in the exception.
This should be called in the same eventspace and on the same thread as the error.}) This should be called in the same eventspace and on the same thread as the error.})
(proc-doc/names (proc-doc/names
@ -320,9 +326,6 @@ all of the names in the tools library, for use defining keybindings
@{This function implements an error-display-handler in terms @{This function implements an error-display-handler in terms
of another error-display-handler. of another error-display-handler.
This function is designed to work in conjunction with
@scheme[drscheme:debug:make-debug-eval-handler].
See also MzScheme's See also MzScheme's
@scheme[error-display-handler] @scheme[error-display-handler]
parameter. parameter.
@ -330,29 +333,15 @@ all of the names in the tools library, for use defining keybindings
If the current-error-port is the definitions window in If the current-error-port is the definitions window in
drscheme, this error handler inserts some debugging drscheme, this error handler inserts some debugging
annotations, calls @scheme[oedh], and then highlights the annotations, calls @scheme[oedh], and then highlights the
source location of the runtime error.}) source location of the runtime error.
(proc-doc/names
drscheme:debug:make-debug-eval-handler
((any/c . -> . any/c)
. -> .
(any/c . -> . any/c))
(odeh)
@{This function implements an eval-handler in terms of another
eval-handler.
This function is designed to work in conjunction with It looks for both stack trace information in the continuation
@scheme[drscheme:debug:make-debug-error-display-handler]. marks both via the
@schememodname[errortrace/errortrace-key]
module and via
@scheme[continuation-mark-set->context].
See also MzScheme's @scheme[eval-handler] })
parameter.
The resulting eval-handler expands and annotates the input
expression and then passes it to the input eval-handler,
unless the input expression is already compiled, in which
case it just hands it directly to the input eval-handler.})
(proc-doc/names (proc-doc/names
drscheme:debug:hide-backtrace-window drscheme:debug:hide-backtrace-window
@ -360,20 +349,6 @@ all of the names in the tools library, for use defining keybindings
() ()
@{Hides the backtrace window.}) @{Hides the backtrace window.})
(proc-doc/names
drscheme:debug:profiling-enabled
(case-> (boolean? . -> . void?)
(-> boolean?))
((enabled?) ())
@{A parameter that controls if profiling information is recorded.
Defaults to @scheme[#f].
Only applies if
@scheme[drscheme:debug:make-debug-eval-handler]
has been added to the eval handler.})
(proc-doc/names (proc-doc/names
drscheme:debug:add-prefs-panel drscheme:debug:add-prefs-panel
(-> void?) (-> void?)
@ -386,15 +361,14 @@ all of the names in the tools library, for use defining keybindings
(debug-info) (debug-info)
@{This function opens a DrScheme to display @{This function opens a DrScheme to display
@scheme[debug-info]. Only the src the position @scheme[debug-info]. Only the src the position
and the span fields of the srcloc are considered. and the span fields of the srcloc are considered.})
See also
@scheme[drscheme:debug:get-cm-key].})
(proc-doc/names (proc-doc/names
drscheme:debug:show-backtrace-window drscheme:debug:show-backtrace-window
(string? (string?
(or/c exn? (listof srcloc?)) (or/c exn?
(listof srcloc?)
(non-empty-listof (cons/c string? (listof srcloc?))))
. -> . . -> .
void?) void?)
(error-message dis) (error-message dis)
@ -404,17 +378,8 @@ all of the names in the tools library, for use defining keybindings
The @scheme[error-message] argument is the text of the error, The @scheme[error-message] argument is the text of the error,
@scheme[dis] is the debug information, extracted from the @scheme[dis] is the debug information, extracted from the
continuation mark in the exception record, using continuation mark in the exception record, using
@scheme[drscheme:debug:get-cm-key].}) @scheme[errortrace-key].})
(proc-doc/names
drscheme:debug:get-cm-key
(-> any)
()
@{Returns a key used with @scheme[contination-mark-set->list].
The contination mark set attached to an exception record
for the user's program may use this mark. If it does,
each mark on the continuation is a list of the fields
of a srcloc object.})
; ;
; ;

27
collects/errortrace/errortrace-key.ss
View File

@ -1,5 +1,30 @@
(module errortrace-key '#%kernel (module errortrace-key '#%kernel
;; this file is badly named; it contains
;; all of the code used at runtime by the
;; various annotations inserted by this
;; library.
(define-values (errortrace-key) (gensym 'key)) (define-values (errortrace-key) (gensym 'key))
(#%provide errortrace-key)) (define-values (test-coverage-info)
(make-parameter
(make-hash)
(λ (x)
(if (hash? x)
(void)
(error 'test-coverage-info "expected a hash, got ~e" x))
x)))
(define-values (test-covered)
(lambda (key)
(hash-set! (test-coverage-info) key #t)))
(define-values (init-test-coverage)
(lambda (l)
(hash-set! (test-coverage-info) 'base l)))
(#%provide errortrace-key
init-test-coverage
test-covered
test-coverage-info))

743
collects/errortrace/errortrace-lib.ss
View File

@ -1,62 +1,143 @@
#lang scheme/base
;; Poor man's stack-trace-on-exceptions/profiler. ;; Poor man's stack-trace-on-exceptions/profiler.
;; See manual for information. ;; See manual for information.
(module errortrace-lib scheme/base (require "stacktrace.ss"
(require "stacktrace.ss" "errortrace-key.ss"
"errortrace-key.ss" scheme/contract
mzlib/list scheme/unit
mzlib/unit scheme/runtime-path
mzlib/runtime-path (for-syntax scheme/base))
(for-syntax scheme/base))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define oprintf
;; Test coverage run-time support (let ([op (current-output-port)])
(define test-coverage-enabled (make-parameter #f)) (λ args
(apply fprintf op args))))
(define test-coverage-info (make-hasheq)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test coverage run-time support
(define test-coverage-enabled (make-parameter #f))
(define (initialize-test-coverage-point key expr) (define test-coverage-state '())
(hash-set! test-coverage-info key (mcons expr 0))) (define (initialize-test-coverage) (set! test-coverage-state '()))
(define (test-covered key) (define (initialize-test-coverage-point expr)
(let ([v (hash-ref test-coverage-info key)]) (when (and (syntax-position expr)
(set-mcdr! v (add1 (mcdr v))))) (syntax-span expr))
(set! test-coverage-state (cons (list (syntax-source expr)
(syntax-position expr)
(syntax-span expr))
test-coverage-state))))
(define (get-coverage-counts) ;; get-coverage : -> (values (listof (list src number number)) (listof (list src number number)))
(hash-map test-coverage-info (lambda (k v) (cons (mcar v) (mcdr v))))) ;; the first result is a (minimized) set of ranges for all of the code that could be executed
;; the second result is the set of ranges that were actually executed.
(define (get-coverage)
(let* ([hash (test-coverage-info)]
[all (hash-ref hash 'base '())]
[covered '()])
(hash-for-each hash (lambda (x y) (unless (eq? x 'base) (set! covered (cons x covered)))))
(values all covered)))
(define (add-test-coverage-init-code stx)
(syntax-case stx (#%plain-module-begin)
[(mod name init-import (#%plain-module-begin b1 b2 body ...))
#`(#,(namespace-module-identifier) name init-import
#,(syntax-recertify
#`(#%plain-module-begin
b1 b2 ;; the two requires that were introduced earlier
(#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
body ...)
(list-ref (syntax->list stx) 3)
orig-inspector
#f))]))
(define (annotate-covered-file name . more) (define (annotate-covered-file filename-path [display-string #f])
(apply annotate-file name (get-coverage-counts) (annotate-file filename-path
(if (null? more) '(#f) more))) (map (λ (c) (cons (car c) (if (cdr c) 1 0))) (get-coverage))
display-string))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profiling run-time support
(define profile-thread #f) ;; The next procedure is called by `annotate' and `annotate-top' to wrap
(define profile-key (gensym)) ;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
(define profiling-enabled (make-parameter #f)) ;; test-coverage-point : syntax syntax -> (values syntax info)
(define profiling-record-enabled (make-parameter #t)) ;; sets a test coverage point for a single expression
(define profile-paths-enabled (make-parameter #f)) (define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled) (zero? phase))
(syntax-case expr ()
[(mod name . reste)
(and (identifier? #'mod)
(free-identifier=? #'mod
(namespace-module-identifier)
(namespace-base-phase)))
;; don't annotate module expressions
body]
[_
(cond
[(and (syntax-source expr)
(number? (syntax-position expr))
(number? (syntax-position expr)))
(initialize-test-coverage-point expr)
(with-syntax ([src (datum->syntax #f (syntax-source expr) (quote-syntax here))]
[start-pos (syntax-position expr)]
[end-pos (+ (syntax-position expr) (syntax-span expr))]
[body body])
#'(begin (#%plain-app test-covered '(src start-pos end-pos)) body))]
[else
body])])
body))
(define profile-info (make-hasheq)) ;; remove-duplicates : (listof X) -> (listof X)
(define (remove-duplicates l)
(let ([ht (make-hash)])
(for-each (lambda (x) (hash-set! ht x #t)) l)
(sort (hash-map ht (lambda (x y) x))
(lambda (x y)
(cond
[(= (list-ref x 1) (list-ref y 1))
(< (list-ref x 2) (list-ref y 2))]
[else
(< (list-ref x 1) (list-ref y 1))])))))
(define (clear-profile-results) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(hash-for-each profile-info ;; Profiling run-time support
(lambda (k v)
(set-box! (vector-ref v 0) #f)
(vector-set! v 1 0)
(vector-set! v 2 0)
(vector-set! v 4 null))))
(define (initialize-profile-point key name expr) (define profile-thread-cell (make-thread-cell #f))
(hash-set! profile-info key (define profile-key (gensym))
(vector (box #f) 0 0 (and name (syntax-e name)) expr null)))
(define (register-profile-start key) (define thread->profile-table (make-weak-hasheq))
(and (profiling-record-enabled)
(let ([v (hash-ref profile-info key)]) (define profiling-enabled (make-parameter #f))
(define profiling-record-enabled (make-parameter #t))
(define profile-paths-enabled (make-parameter #f))
(define (clear-profile-results)
(when (thread-cell-ref profile-thread-cell)
(hash-for-each
(thread-cell-ref profile-thread-cell)
(lambda (k v)
(set-box! (vector-ref v 0) #f)
(vector-set! v 1 0)
(vector-set! v 2 0)
(vector-set! v 4 null)))))
(define (initialize-profile-point key name expr)
(unless (thread-cell-ref profile-thread-cell)
(let ([new-table (make-hasheq)])
(hash-set! thread->profile-table (current-thread) new-table)
(thread-cell-set! profile-thread-cell new-table)))
(hash-set! (thread-cell-ref profile-thread-cell)
key
(vector (box #f) 0 0 (and name (syntax-e name)) expr null)))
(define (register-profile-start key)
(and (profiling-record-enabled)
(thread-cell-ref profile-thread-cell)
(let ([v (hash-ref (thread-cell-ref profile-thread-cell) key #f)])
(when v
(let ([b (vector-ref v 0)]) (let ([b (vector-ref v 0)])
(vector-set! v 1 (add1 (vector-ref v 1))) (vector-set! v 1 (add1 (vector-ref v 1)))
(when (profile-paths-enabled) (when (profile-paths-enabled)
@ -72,111 +153,119 @@
#f #f
(begin (begin
(set-box! b #t) (set-box! b #t)
(current-process-milliseconds))))))) (current-process-milliseconds))))))))
(define (register-profile-done key start) (define (register-profile-done key start)
(when start (when start
(let ([v (hash-ref profile-info key)]) (when (thread-cell-ref profile-thread-cell)
(let ([b (vector-ref v 0)]) (let ([v (hash-ref (thread-cell-ref profile-thread-cell) key #f)])
(set-box! b #f) (when v
(vector-set! v 2 (let ([b (vector-ref v 0)])
(+ (- (current-process-milliseconds) start) (set-box! b #f)
(vector-ref v 2))))))) (vector-set! v 2
(+ (- (current-process-milliseconds) start)
(vector-ref v 2)))))))))
(define (get-profile-results) (define (get-profile-results [t (current-thread)])
(hash-map profile-info (cond
(lambda (key val) [(hash-ref thread->profile-table t #f)
(let ([count (vector-ref val 1)] =>
[time (vector-ref val 2)] (λ (profile-info)
[name (vector-ref val 3)] (hash-map profile-info
[expr (vector-ref val 4)] (lambda (key val)
[cmss (vector-ref val 5)]) (let ([count (vector-ref val 1)]
(list count time name expr [time (vector-ref val 2)]
(if (hash? cmss) [name (vector-ref val 3)]
(hash-map cmss (lambda (ks v) [expr (vector-ref val 4)]
(cons v [cmss (vector-ref val 5)])
(map (lambda (k) (list count time name expr
(let ([v (cdr (hash-ref profile-info k))]) (if (hash? cmss)
(list (vector-ref v 2) (hash-map cmss (lambda (ks v)
(vector-ref v 3)))) (cons v
ks)))) (map (lambda (k)
null)))))) (let ([v (cdr (hash-ref profile-info k))])
(list (vector-ref v 2)
(vector-ref v 3))))
ks))))
null))))))]
[else '()]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stacktrace instrumenter ;; Stacktrace instrumenter
(define-runtime-path key-syntax (define-runtime-path key-syntax
'(lib "errortrace-key-syntax.ss" "errortrace")) '(lib "errortrace-key-syntax.ss" "errortrace"))
(define dynamic-errortrace-key (define dynamic-errortrace-key
(dynamic-require key-syntax 'errortrace-key-syntax)) (dynamic-require key-syntax 'errortrace-key-syntax))
;; with-mark : stx stx -> stx ;; with-mark : stx stx -> stx
(define (with-mark mark expr) (define (with-mark mark expr)
(with-syntax ([expr expr] (let ([loc (make-st-mark mark)])
[loc (make-st-mark mark)] (if loc
[et-key dynamic-errortrace-key]) (with-syntax ([expr expr]
(execute-point [loc loc]
mark [et-key dynamic-errortrace-key])
(syntax (execute-point
(with-continuation-mark mark
et-key (syntax
loc (with-continuation-mark et-key
expr))))) loc
expr))))
expr)))
(define-values/invoke-unit/infer stacktrace@) (define-values/invoke-unit/infer stacktrace@)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execute counts ;; Execute counts
(define execute-info (make-hasheq)) (define execute-info (make-hasheq))
(define execute-counts-enabled (make-parameter #f)) (define execute-counts-enabled (make-parameter #f))
(define (register-executed-once key) (define (register-executed-once key)
(let ([i (hash-ref execute-info key)]) (let ([i (hash-ref execute-info key)])
(set-mcdr! i (add1 (mcdr i))))) (set-mcdr! i (add1 (mcdr i)))))
(define (execute-point mark expr) (define (execute-point mark expr)
(if (execute-counts-enabled) (if (execute-counts-enabled)
(let ([key (gensym)]) (let ([key (gensym)])
(hash-set! execute-info key (mcons mark 0)) (hash-set! execute-info key (mcons mark 0))
(with-syntax ([key (datum->syntax #f key (quote-syntax here))] (with-syntax ([key (datum->syntax #f key (quote-syntax here))]
[expr expr] [expr expr]
[register-executed-once register-executed-once]);<- 3D! [register-executed-once register-executed-once]);<- 3D!
(syntax (syntax
(begin (begin
(register-executed-once 'key) (register-executed-once 'key)
expr)))) expr))))
expr)) expr))
(define (get-execute-counts) (define (get-execute-counts)
(hash-map execute-info (lambda (k v) (cons (mcar v) (hash-map execute-info (lambda (k v) (cons (mcar v)
(mcdr v))))) (mcdr v)))))
(define (annotate-executed-file name . more) (define (annotate-executed-file name [display-string "^.,"])
(apply annotate-file name (get-execute-counts) (annotate-file name (get-execute-counts) display-string))
(if (null? more) '("^.,") more)))
;; shared functionality for annotate-executed-file and annotate-covered-file ;; shared functionality for annotate-executed-file and annotate-covered-file
(define (annotate-file name counts display-string) (define (annotate-file name counts display-string)
(let ([name (path->complete-path name (current-directory))]) (let ([name (path->complete-path name (current-directory))])
(let* (;; Filter relevant syntaxes (let* (;; Filter relevant syntaxes
[here (filter (lambda (s) [here (filter (lambda (s)
(and (equal? name (syntax-source (car s))) (and (equal? name (syntax-source (car s)))
(syntax-position (car s)))) (syntax-position (car s))))
counts)] counts)]
;; Sort them: earlier first, wider if in same position ;; Sort them: earlier first, wider if in same position
[sorted (sort here [sorted (sort here
(lambda (a b) (lambda (a b)
(let ([ap (syntax-position (car a))] (let ([ap (syntax-position (car a))]
[bp (syntax-position (car b))]) [bp (syntax-position (car b))])
(or (< ap bp) (or (< ap bp)
(and (= ap bp) (and (= ap bp)
(> (syntax-span (car a)) (> (syntax-span (car a))
(syntax-span (car b))))))))] (syntax-span (car b))))))))]
;; Merge entries with the same position+span ;; Merge entries with the same position+span
[sorted (if (null? sorted) [sorted (if (null? sorted)
sorted ; guarantee one element for the next case sorted ; guarantee one element for the next case
(let loop ([xs (reverse sorted)] [r '()]) (let loop ([xs (reverse sorted)] [r '()])
(cond [(null? (cdr xs)) (append xs r)] (cond [(null? (cdr xs)) (append xs r)]
@ -191,206 +280,220 @@
(cddr xs)) (cddr xs))
r)] r)]
[else (loop (cdr xs) (cons (car xs) r))])))] [else (loop (cdr xs) (cons (car xs) r))])))]
[pic (make-string (file-size name) #\space)] [pic (make-string (file-size name) #\space)]
[display-string [display-string
(case display-string (case display-string
[(#t) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"] [(#t) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"]
[(#f) "#-"] [(#f) "#."]
[else display-string])] [else display-string])]
[many-char (string-ref display-string [many-char (string-ref display-string
(sub1 (string-length display-string)))]) (sub1 (string-length display-string)))])
;; Fill out picture ;; Fill out picture
(for-each (lambda (s) (for-each (lambda (s)
(let ([pos (sub1 (syntax-position (car s)))] (let ([pos (sub1 (syntax-position (car s)))]
[span (syntax-span (car s))] [span (syntax-span (car s))]
[key (let ([k (cdr s)]) [key (let ([k (cdr s)])
(if (< k (string-length display-string)) (if (< k (string-length display-string))
(string-ref display-string k) (string-ref display-string k)
many-char))]) many-char))])
(let loop ([p pos]) (let loop ([p pos])
(unless (= p (+ pos span)) (unless (= p (+ pos span))
(string-set! pic p key) (string-set! pic p key)
(loop (add1 p)))))) (loop (add1 p))))))
sorted) sorted)
;; Write annotated file ;; Write annotated file
(with-input-from-file name (with-input-from-file name
(lambda () (lambda ()
(let loop () (let loop ()
(let ([pos (file-position (current-input-port))] (let ([pos (file-position (current-input-port))]
[line (read-line (current-input-port) 'any)]) [line (read-line (current-input-port) 'any)])
(unless (eof-object? line) (unless (eof-object? line)
(printf "~a\n" line) (printf "~a\n" line)
(let ([w (string-length line)]) (let ([w (string-length line)])
;; Blank leading spaces in pic (copy them: works for tabs) ;; Blank leading spaces in pic (copy them: works for tabs)
(let loop ([i 0]) (let loop ([i 0])
(when (and (< i w) (when (and (< i w)
(char-whitespace? (string-ref line i))) (char-whitespace? (string-ref line i)))
(string-set! pic (+ pos i) (string-ref line i)) (string-set! pic (+ pos i) (string-ref line i))
(loop (add1 i)))) (loop (add1 i))))
(printf "~a\n" (substring pic pos (+ pos w)))) (printf "~a\n" (substring pic pos (+ pos w))))
(loop))))))))) (loop)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Eval handler, exception handler ;; Eval handler, exception handler
(define instrumenting-enabled (define instrumenting-enabled
(make-parameter #t)) (make-parameter #t))
(define error-context-display-depth (define error-context-display-depth
(make-parameter 10000 (lambda (x) (and (integer? x) x)))) (make-parameter 10000 (lambda (x) (and (integer? x) x))))
;; port exn -> void ;; port exn -> void
;; effect: prints out the context surrounding the exception ;; effect: prints out the context surrounding the exception
(define (print-error-trace p x) (define (print-error-trace p x)
(let loop ([n (error-context-display-depth)] (let loop ([n (error-context-display-depth)]
[l (map st-mark-source [l (map st-mark-source
(continuation-mark-set->list (exn-continuation-marks x) (continuation-mark-set->list (exn-continuation-marks x)
errortrace-key))]) errortrace-key))])
(cond (cond
[(or (zero? n) (null? l)) (void)] [(or (zero? n) (null? l)) (void)]
[(pair? l) [(pair? l)
(let* ([stx (car l)] (let* ([stx (car l)]
[source (syntax-source stx)] [source (syntax-source stx)]
[file (cond [file (cond
[(string? source) source] [(string? source) source]
[(path? source) [(path? source)
(path->string source)] (path->string source)]
[(not source) [(not source)
#f] #f]
[else [else
(format "~a" source)])] (format "~a" source)])]
[line (syntax-line stx)] [line (syntax-line stx)]
[col (syntax-column stx)] [col (syntax-column stx)]
[pos (syntax-position stx)]) [pos (syntax-position stx)])
(fprintf p "~a~a: ~e~n" (fprintf p "~a~a: ~e~n"
(or file "[unknown source]") (or file "[unknown source]")
(cond (cond
[line (format ":~a:~a" line col)] [line (format ":~a:~a" line col)]
[pos (format "::~a" pos)] [pos (format "::~a" pos)]
[else ""]) [else ""])
(syntax->datum stx)) (syntax->datum stx))
(loop (- n 1) (cdr l)))]))) (loop (- n 1) (cdr l)))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profile printer ;; Profile printer
(define (output-profile-results paths? sort-time?) (define (output-profile-results paths? sort-time?)
(profiling-enabled #f) (profiling-enabled #f)
(error-print-width 50) (error-print-width 50)
(printf "Sorting profile data...~n") (printf "Sorting profile data...~n")
(let* ([sel (if sort-time? cadr car)] (let* ([sel (if sort-time? cadr car)]
[counts (sort (filter (lambda (c) (positive? (car c))) [counts (sort (filter (lambda (c) (positive? (car c)))
(get-profile-results)) (get-profile-results))
(lambda (a b) (< (sel a) (sel b))))] (lambda (a b) (< (sel a) (sel b))))]
[total 0]) [total 0])
(for-each (for-each
(lambda (c) (lambda (c)
(set! total (+ total (sel c))) (set! total (+ total (sel c)))
(printf "=========================================================~n") (printf "=========================================================~n")
(printf "time = ~a : no. = ~a : ~e in ~s~n" (printf "time = ~a : no. = ~a : ~e in ~s~n"
(cadr c) (car c) (caddr c) (cadddr c)) (cadr c) (car c) (caddr c) (cadddr c))
;; print call paths ;; print call paths
(when paths? (when paths?
(for-each (for-each
(lambda (cms) (lambda (cms)
(unless (null? (cdr cms)) (unless (null? (cdr cms))
(printf " ~e VIA ~e" (car cms) (caadr cms)) (printf " ~e VIA ~e" (car cms) (caadr cms))
(for-each (for-each
(lambda (cm) (lambda (cm)
(printf " <- ~e" (car cm))) (printf " <- ~e" (car cm)))
(cddr cms)) (cddr cms))
(printf "~n"))) (printf "~n")))
(sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b))))))) (sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b)))))))
counts) counts)
(printf "Total samples: ~a~n" total))) (printf "Total samples: ~a~n" total)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define orig-inspector (current-code-inspector)) (define orig-inspector (current-code-inspector))
(define errortrace-annotate (define errortrace-annotate
(lambda (top-e) (lambda (top-e)
(define (normal e) (define (normal e)
(let ([ex (expand-syntax e)]) (annotate-top (expand-syntax e)
(annotate-top ex (namespace-base-phase)))) (namespace-base-phase)))
(syntax-case top-e () (syntax-case top-e ()
[(mod name . reste) [(mod name . reste)
(and (identifier? #'mod) (and (identifier? #'mod)
(free-identifier=? #'mod (namespace-module-identifier) (free-identifier=? #'mod
(namespace-base-phase))) (namespace-module-identifier)
(if (eq? (syntax-e #'name) 'errortrace-key) (namespace-base-phase)))
top-e (if (eq? (syntax-e #'name) 'errortrace-key)
(let ([top-e (expand-syntax top-e)]) top-e
(syntax-case top-e (#%plain-module-begin) (let ([top-e (expand-syntax top-e)])
[(mod name init-import (#%plain-module-begin body ...)) (initialize-test-coverage)
(normal (syntax-case top-e (#%plain-module-begin)
#`(#,(namespace-module-identifier) name init-import [(mod name init-import (#%plain-module-begin body ...))
#,(syntax-recertify (add-test-coverage-init-code
#`(#%plain-module-begin (normal
#,((make-syntax-introducer) #`(#,(namespace-module-identifier) name init-import
#'(#%require errortrace/errortrace-key)) #,(syntax-recertify
#,((make-syntax-introducer) #`(#%plain-module-begin
#'(#%require (for-syntax errortrace/errortrace-key))) #,((make-syntax-introducer)
body ...) (syntax/loc (datum->syntax #f 'x #f)
(list-ref (syntax->list top-e) 3) (#%require errortrace/errortrace-key)))
orig-inspector #,((make-syntax-introducer)
#f)))])))] (syntax/loc (datum->syntax #f 'x #f)
[_else (#%require (for-syntax errortrace/errortrace-key))))
(normal top-e)]))) body ...)
(list-ref (syntax->list top-e) 3)
orig-inspector
#f))))])))]
[_else
(normal top-e)])))
(define errortrace-compile-handler (define-namespace-anchor orig-namespace)
(let ([orig (current-compile)]
[reg (namespace-module-registry (current-namespace))])
(lambda (e immediate-eval?)
(orig
(if (and (instrumenting-enabled)
(eq? reg
(namespace-module-registry (current-namespace)))
(not (compiled-expression? (if (syntax? e)
(syntax-e e)
e))))
(let ([e2 (errortrace-annotate
(if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax #f e))))])
e2)
e)
immediate-eval?))))
(define errortrace-error-display-handler (define (make-errortrace-compile-handler)
(let ([orig (error-display-handler)]) (let ([orig (current-compile)]
(lambda (msg exn) [reg (namespace-module-registry (current-namespace))])
(if (exn? exn) (namespace-attach-module (namespace-anchor->namespace orig-namespace) 'scheme/base)
(let ([p (open-output-string)]) (namespace-attach-module (namespace-anchor->namespace orig-namespace) 'errortrace/errortrace-key)
(display (exn-message exn) p) (lambda (e immediate-eval?)
(newline p) (orig
(print-error-trace p exn) (if (and (instrumenting-enabled)
(orig (get-output-string p) exn)) (eq? reg
(orig msg exn))))) (namespace-module-registry (current-namespace)))
(not (compiled-expression? (if (syntax? e)
(syntax-e e)
e))))
(let ([e2 (errortrace-annotate
(if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax #f e))))])
e2)
e)
immediate-eval?))))
(provide errortrace-compile-handler (define errortrace-compile-handler (make-errortrace-compile-handler))
errortrace-error-display-handler
errortrace-annotate
print-error-trace (define errortrace-error-display-handler
error-context-display-depth (let ([orig (error-display-handler)])
(lambda (msg exn)
(if (exn? exn)
(let ([p (open-output-string)])
(display (exn-message exn) p)
(newline p)
(print-error-trace p exn)
(orig (get-output-string p) exn))
(orig msg exn)))))
instrumenting-enabled (provide/contract
[annotate-covered-file (->* (path-string?) ((or/c string? #t #f)) void?)]
profiling-enabled [annotate-executed-file (->* (path-string?) ((or/c string? #t #f)) void?)])
profiling-record-enabled (provide make-errortrace-compile-handler
profile-paths-enabled errortrace-compile-handler
get-profile-results errortrace-error-display-handler
output-profile-results errortrace-annotate
clear-profile-results
print-error-trace
execute-counts-enabled error-context-display-depth
get-execute-counts
annotate-executed-file instrumenting-enabled
;; use names that are consistent with the above profiling-enabled
(rename-out [test-coverage-enabled coverage-counts-enabled]) profiling-record-enabled
get-coverage-counts profile-paths-enabled
annotate-covered-file get-profile-results
output-profile-results
annotate-top)) clear-profile-results
execute-counts-enabled
get-execute-counts
;; need to rename here to avoid having to rename when the unit is invoked.
(rename-out [test-coverage-enabled coverage-counts-enabled])
get-coverage
test-coverage-info
annotate-top)

3
collects/errortrace/errortrace.ss
View File

@ -22,7 +22,8 @@
annotate-executed-file annotate-executed-file
coverage-counts-enabled coverage-counts-enabled
get-coverage-counts get-coverage
test-coverage-info
annotate-covered-file) annotate-covered-file)
(current-compile errortrace-compile-handler) (current-compile errortrace-compile-handler)

91
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -118,7 +118,12 @@ by a factor of 2 or 3.}
@defboolparam[profiling-enabled on?]{ @defboolparam[profiling-enabled on?]{
Errortrace's profiling instrumentation is @scheme[#f] by default. To use it, Errortrace's profiling instrumentation is @scheme[#f] by default. To use it,
you also need to ensure that @scheme[instrumenting-enabled] is on.} you also need to ensure that @scheme[instrumenting-enabled] is on.
Also, profiling only records information about the time taken on the thread
that compiled the code (more precisely, the thread that instruments the code via
the @scheme[errortrace-compile-handler]).
}
@defboolparam[profiling-record-enabled on?]{ @defboolparam[profiling-record-enabled on?]{
@ -131,7 +136,8 @@ version of the procedure, but the old information is also preserved.
Depending of the source program, profiling usually induces a factor of Depending of the source program, profiling usually induces a factor of
2 to 4 slowdown, in addition to any slowdown from the 2 to 4 slowdown, in addition to any slowdown from the
exception-information instrumentation.} exception-information instrumentation.
}
@defproc[(output-profile-results [paths? any/c] [sort-time? any/c]) void?]{ @defproc[(output-profile-results [paths? any/c] [sort-time? any/c]) void?]{
@ -139,10 +145,10 @@ Gets the current profile results using @scheme[get-profile-results] and
displays them. It optionally shows paths information (if it is recorded), displays them. It optionally shows paths information (if it is recorded),
and sorts by either time or call counts.} and sorts by either time or call counts.}
@defproc[(get-profile-results) list?]{ @defproc[(get-profile-results [thd thread? (current-thread)]) list?]{
Returns a list of lists that contain all profiling information accumulated Returns a list of lists that contain all profiling information accumulated
so far: so far (for the thread @scheme[thd]):
@itemize[ @itemize[
@item{the number of times a procedure was called.} @item{the number of times a procedure was called.}
@ -182,7 +188,8 @@ all procedures instrumented for profiling information.}
@defproc[(clear-profile-results) void?]{ @defproc[(clear-profile-results) void?]{
Clears accumulated profile results.} Clears accumulated profile results for the current thread.}
@; ------------------------------------------------ @; ------------------------------------------------
@ -214,25 +221,30 @@ Parameters that determine if the first (exact coverage) or second
(profiler-based coverage) are enabled. Remember that setting (profiler-based coverage) are enabled. Remember that setting
@scheme[instrumenting-enabled] to @scheme[#f] also disables both.} @scheme[instrumenting-enabled] to @scheme[#f] also disables both.}
@deftogether[( @defproc[(get-coverage) (listof (cons/c syntax? boolean?))]{
@defproc[(get-coverage-counts) list?]
@defproc[(get-execute-counts) list?])]{ Returns a list of pairs, one for each instrumented expression. The
first element of the pair is a @scheme[syntax?] object (usually containing
source location information) for the original expression, and the
second element of the pair indicates if the code has been executed.
This list is snapshot of the current state of the computation.}
@defproc[(get-execute-counts) (list (cons/c syntax? number?))])]{
Returns a list of pairs, one for each instrumented expression. The Returns a list of pairs, one for each instrumented expression. The
first element of the pair is a @scheme[syntax?] object (usually containing first element of the pair is a @scheme[syntax?] object (usually containing
source location information) for the original expression, and the source location information) for the original expression, and the
second element of the pair is the number of times that the second element of the pair is the number of times that the
expression has been evaluated. These elements are destructively expression has been evaluated.
modified, so to take a snapshot you will need to copy them.} This list is snapshot of the current state of the computation.}
@deftogether[( @deftogether[(
@defproc[(annotate-covered-file @defproc[(annotate-covered-file
[filename-path path-string?] [filename-path path-string?]
[display-string (or/c string? false/c) #f]) [display-string (or/c string? #f) #f])
void?] void?]
@defproc[(annotate-executed-file @defproc[(annotate-executed-file
[filename-path path-string?] [filename-path path-string?]
[display-string (or/c string? false/c) "^.,"]) [display-string (or/c string? #t #f) "^.,"])
void?])]{ void?])]{
Writes the named file to the @scheme[current-output-port], inserting an Writes the named file to the @scheme[current-output-port], inserting an
@ -241,9 +253,15 @@ additional line between each source line to reflect execution counts
The optional @scheme[display-string] is used for the annotation: the first The optional @scheme[display-string] is used for the annotation: the first
character is used for expressions that were visited 0 times, the character is used for expressions that were visited 0 times, the
second character for 1 time, ..., and the last character for second character for 1 time, ..., and the last character for
expressions that were visited more times. It can also be @scheme[#t] expressions that were visited more times. It can also be
for a maximal display (@scheme["012...9ABC...Z"]), or @scheme[#f] for @scheme[#f] for a minimal display, @scheme["#."], or, in
a minimal display (@scheme["#-"]).} the case of @scheme[annotate-executed-file],
@scheme[#t] for a maximal display, @scheme["0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"].
}
@defparam[test-coverage-info ht hasheq?]{
The hash-table in this parameter is used to store the profile results.
}
@; ------------------------------------------------------ @; ------------------------------------------------------
@ -281,12 +299,28 @@ The additional exports are as follows:
Compiles @scheme[stx] using the compilation handler that was active Compiles @scheme[stx] using the compilation handler that was active
when the @schememodname[errortrace/errortrace-lib] module was when the @schememodname[errortrace/errortrace-lib] module was
executed, but first instruments the code for Errortrace information. executed, but first instruments the code for Errortrace information.
The code is instrumented only if @scheme[(namespace-module-registry The code is instrumented only if
(current-namespace))] is the same as when the @schemeblock[(namespace-module-registry (current-namespace))]
is the same as when the
@schememodname[errortrace/errortrace-lib] module was executed. This @schememodname[errortrace/errortrace-lib] module was executed. This
procedure is suitable for use as a compilation handler via procedure is suitable for use as a compilation handler via
@scheme[current-compile].} @scheme[current-compile].}
@defproc[(make-errortrace-compile-handler)
(-> any/c any/c compiled-expression)]{
Produces a compile handler that is like
@scheme[errortrace-compile-handler], except that the code that the
it produces is instrumented if the value of
@schemeblock[(namespace-module-registry (current-namespace))]
is the same as when the original thunk is invoked.
In addition, when the thunk is invoked, it uses
@scheme[namespace-attach-module] to attach the
@schememodname[errortrace/errortrace-key] module and the
@schememodname['#%kernel] module to the @scheme[current-namespace].
}
@defproc[(errortrace-error-display-handler (string string?) (exn exn?)) void?]{ @defproc[(errortrace-error-display-handler (string string?) (exn exn?)) void?]{
Displays information about the exception; this procedure is suitable Displays information about the exception; this procedure is suitable
@ -344,14 +378,17 @@ expression, typically @scheme[(namespace-base-phase)] for a top-level
expression.} expression.}
@deftogether[( @deftogether[(
@defproc[(make-st-mark (syntax syntax?)) st-mark?] @defproc[(make-st-mark (syntax syntax?)) (or/c #f st-mark?)]
@defproc[(st-mark-source (st-mark st-mark?)) syntax?] @defproc[(st-mark-source (st-mark st-mark?)) syntax?]
@defproc[(st-mark-bindings (st-mark st-mark?)) list?])]{ @defproc[(st-mark-bindings (st-mark st-mark?)) list?])]{
The @schemeout[st-mark-source] and @schemeout[st-mark-bindings] The @schemeout[st-mark-source] and @schemeout[st-mark-bindings]
functions extract information from a particular kind of value. The functions extract information from a particular kind of value.
value must be created by @schemeout[make-st-mark]. The The value must be created by @schemeout[make-st-mark]
@schemeout[st-mark-source] extracts the value originally provided to (the shape of the value is guaranteed to be writable and not to be @scheme[#f], but otherwise unspecified).
The @scheme[make-st-mark] function returns @scheme[#f] when there is
no source location information in the syntax object.
The @schemeout[st-mark-source] extracts the value originally provided to
the expression-maker, and @schemeout[st-mark-bindings] returns local the expression-maker, and @schemeout[st-mark-bindings] returns local
binding information (if available) as a list of two element (syntax? binding information (if available) as a list of two element (syntax?
any/c) lists. The @schemeout[st-mark-bindings] function is currently any/c) lists. The @schemeout[st-mark-bindings] function is currently
@ -437,3 +474,13 @@ this case, the result of @schemein[register-profile-start] should be
@scheme[#f].} @scheme[#f].}
} }
@section{Errortrace Key}
@defmodule[errortrace/errortrace-key]
This module depends only on @schememodname['#%kernel].
@defthing[errortrace-key symbol?]{
A key used by errortrace via @scheme[with-continuation-mark] to
record stack information.
}

1066
collects/errortrace/stacktrace.ss
View File

File diff suppressed because it is too large Load Diff

31
collects/framework/main.ss
View File

@ -54,6 +54,37 @@
(link standard-mred@ framework@)) (link standard-mred@ framework@))
(provide/doc (provide/doc
(proc-doc/names
text:range? (-> any/c boolean?) (arg)
@{Determines if @scheme[arg] is an instance of the @tt{range} struct.})
(proc-doc/names
text:range-start
(-> text:range? exact-nonnegative-integer?)
(range)
@{Returns the start position of the range.})
(proc-doc/names
text:range-end
(-> text:range? exact-nonnegative-integer?)
(range)
@{Returns the end position of the range.})
(proc-doc/names
text:range-caret-space?
(-> text:range? boolean?)
(range)
@{Returns a boolean indicating where the caret-space in the range goes. See also @method[text:basic<%> highlight-range].})
(proc-doc/names
text:range-style
(-> text:range? exact-nonnegative-integer?)
(range)
@{Returns the style of the range. See also @method[text:basic<%> highlight-range].})
(proc-doc/names
text:range-color
(-> text:range? (or/c string? (is-a?/c color%)))
(range)
@{Returns the color of the highlighted range.})
(parameter-doc (parameter-doc
text:autocomplete-append-after text:autocomplete-append-after
(parameter/c string?) (parameter/c string?)

9
collects/framework/private/sig.ss
View File

@ -217,7 +217,14 @@
(autocomplete-append-after (autocomplete-append-after
autocomplete-limit autocomplete-limit
get-completions/manuals get-completions/manuals
lookup-port-name)) lookup-port-name
range?
range-start
range-end
range-caret-space?
range-style
range-color))
(define-signature canvas-class^ (define-signature canvas-class^
(basic<%> (basic<%>

28
collects/framework/private/text.ss
View File

@ -7,17 +7,16 @@ WARNING: printf is rebound in the body of the unit to always
|# |#
(require string-constants (require string-constants
mzlib/class scheme/unit
mzlib/match scheme/class
scheme/match
scheme/path scheme/path
"sig.ss" "sig.ss"
"../gui-utils.ss" "../gui-utils.ss"
"../preferences.ss" "../preferences.ss"
mred/mred-sig mred/mred-sig
mrlib/interactive-value-port mrlib/interactive-value-port
mzlib/list
setup/dirs setup/dirs
mzlib/string
(prefix-in srfi1: srfi/1)) (prefix-in srfi1: srfi/1))
(require setup/xref (require setup/xref
scribble/xref scribble/xref
@ -41,6 +40,7 @@ WARNING: printf is rebound in the body of the unit to always
(apply fprintf original-output-port args) (apply fprintf original-output-port args)
(void)) (void))
(define-struct range (start end caret-space? style color) #:inspector #f) (define-struct range (start end caret-space? style color) #:inspector #f)
(define-struct rectangle (left top right bottom style color) #:inspector #f) (define-struct rectangle (left top right bottom style color) #:inspector #f)
@ -2674,12 +2674,12 @@ WARNING: printf is rebound in the body of the unit to always
(map (map
(λ (a-committer) (λ (a-committer)
(match a-committer (match a-committer
[($ committer [(struct committer
kr (kr
commit-peeker-evt commit-peeker-evt
done-evt done-evt
resp-chan resp-chan
resp-nack) resp-nack))
(choice-evt (choice-evt
(handle-evt (handle-evt
commit-peeker-evt commit-peeker-evt
@ -2737,9 +2737,9 @@ WARNING: printf is rebound in the body of the unit to always
;; does the dumping. otherwise, return #f ;; does the dumping. otherwise, return #f
(define ((service-committer data peeker-evt) a-committer) (define ((service-committer data peeker-evt) a-committer)
(match a-committer (match a-committer
[($ committer [(struct committer
kr commit-peeker-evt (kr commit-peeker-evt
done-evt resp-chan resp-nack) done-evt resp-chan resp-nack))
(let ([size (queue-size data)]) (let ([size (queue-size data)])
(cond (cond
[(not (eq? peeker-evt commit-peeker-evt)) [(not (eq? peeker-evt commit-peeker-evt))
@ -2758,7 +2758,7 @@ WARNING: printf is rebound in the body of the unit to always
;; otherwise return #f ;; otherwise return #f
(define (service-waiter a-peeker) (define (service-waiter a-peeker)
(match a-peeker (match a-peeker
[($ peeker bytes skip-count pe resp-chan nack-evt polling?) [(struct peeker (bytes skip-count pe resp-chan nack-evt polling?))
(cond (cond
[(and pe (not (eq? pe peeker-evt))) [(and pe (not (eq? pe peeker-evt)))
(choice-evt (channel-put-evt resp-chan #f) (choice-evt (channel-put-evt resp-chan #f)

2
collects/framework/splash.ss
View File

@ -299,7 +299,7 @@
(class canvas% (class canvas%
(inherit get-client-size get-dc) (inherit get-client-size get-dc)
(define/override (on-char evt) (char-observer evt)) (define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)) (define/override (on-paint) (when splash-cache-bitmap (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)))
(define/override (on-event evt) (splash-event-callback evt)) (define/override (on-event evt) (splash-event-callback evt))
(super-new))) (super-new)))

6
collects/scheme/private/contract.ss
View File

@ -1356,7 +1356,7 @@ improve method arity mismatch contract violation error messages?
false/c false/c
printable/c printable/c
symbols one-of/c symbols one-of/c
listof cons/c list/c listof non-empty-listof cons/c list/c
vectorof vector-immutableof vector/c vector-immutable/c vectorof vector-immutableof vector/c vector-immutable/c
box-immutable/c box/c box-immutable/c box/c
promise/c promise/c
@ -2087,6 +2087,10 @@ improve method arity mismatch contract violation error messages?
(define listof (define listof
(*-immutableof list? map andmap list listof)) (*-immutableof list? map andmap list listof))
(define (non-empty-list? x) (and (pair? x) (list? (cdr x))))
(define non-empty-listof
(*-immutableof non-empty-list? map andmap non-empty-list non-empty-listof))
(define (immutable-vector? val) (and (immutable? val) (vector? val))) (define (immutable-vector? val) (and (immutable? val) (vector? val)))
(define vector-immutableof (define vector-immutableof

14
collects/scribblings/drscheme/interface-essentials.scrbl
View File

@ -168,21 +168,21 @@ non-Scheme languages. You specify a language in one of two ways:
@itemize[ @itemize[
@item{Select the @menuitem["Language" "Choose Language..."] menu @item{Select the @drlang{Module} language (via the
@menuitem["Language" "Choose Language..."] menu item), and then
specify a specific language as part of the program usually by
starting the definitions-window content with @hash-lang[].}
@item{Select the @menuitem["Language" "Choose Language..."] menu
item, and choose a language other than @drlang{Module}. After item, and choose a language other than @drlang{Module}. After
changing the language, click @onscreen{Run} to reset the changing the language, click @onscreen{Run} to reset the
language in the interactions window. The bottom-left corner of language in the interactions window. The bottom-left corner of
DrScheme's main window also has a shortcut menu item for DrScheme's main window also has a shortcut menu item for
selecting previously selected languages.} selecting previously selected languages.}
@item{Select the @drlang{Module} language (via the
@menuitem["Language" "Choose Language..."] menu item), and then
specify a specific language as part of the program usually by
starting the definitions-window content with @hash-lang[].}
] ]
The latter method, @drlang{Module} with @hash-lang[], is the recommend The former method, @drlang{Module} with @hash-lang[], is the recommend
mode, and it is described further in @secref["module"]. mode, and it is described further in @secref["module"].
The @menuitem["Language" "Choose Language..."] dialog contains a The @menuitem["Language" "Choose Language..."] dialog contains a

6
collects/scribblings/reference/contracts.scrbl
View File

@ -266,6 +266,12 @@ the contract @scheme[c]. Beware that when this contract is applied to
a value, the result is not necessarily @scheme[eq?] to the input.} a value, the result is not necessarily @scheme[eq?] to the input.}
@defproc[(non-empty-listof [c (or/c contract? (any/c . -> . any/c))]) contract?]{
Returns a contract that recognizes non-empty lists whose elements match
the contract @scheme[c]. Beware that when this contract is applied to
a value, the result is not necessarily @scheme[eq?] to the input.}
@defproc[(cons/c [car-c contract?][cdr-c contract?]) contract?]{ @defproc[(cons/c [car-c contract?][cdr-c contract?]) contract?]{
Produces a contract the recognizes pairs first and second elements Produces a contract the recognizes pairs first and second elements

23
collects/scribblings/tools/rep.scrbl
View File

@ -2,6 +2,7 @@
@(require "common.ss") @(require "common.ss")
@(tools-title "rep") @(tools-title "rep")
@definterface[drscheme:rep:text<%> ()]{ @definterface[drscheme:rep:text<%> ()]{
} }
@ -90,6 +91,24 @@ The @scheme[complete-program?] argument determines if the
}} }}
@defmethod[#:mode augment (after-many-evals) any]{
Called from the drscheme main thread after
@method[drscheme:rep:text% evaluate-from-port] finishes (no matter
how it finishes).
}
@defmethod[#:mode augment (on-execute [run-on-user-thread (-> any)]) any]{
Called from the drscheme thread after the language's
@method[drscheme:language:language<%> on-execute]
method has been invoked, and after the
special values have been setup (the ones registered
via @scheme[drscheme:language:add-snip-value]).
Use @scheme[run-on-user-thread] to initialize the user's parameters, etc.
}
@defmethod[(get-error-range) @defmethod[(get-error-range)
(or/c false/c (list/c (is-a?/c text:basic%) number? number?))]{ (or/c false/c (list/c (is-a?/c text:basic%) number? number?))]{
@methspec{ @methspec{
@ -155,7 +174,9 @@ for more information about parameters.
} }
@defmethod[(highlight-errors [locs (listof (list (instance (implements text:basic<%>)) small-integer small-integer))]) @defmethod[(highlight-errors
[locs (listof srcloc?)]
[error-arrows (or/c #f (listof srcloc?)) #f])
void?]{ void?]{
Call this method to highlight errors associated with this repl. Call this method to highlight errors associated with this repl.
See also See also

6
collects/string-constants/english-string-constants.ss
View File

@ -1009,7 +1009,11 @@ please adhere to these guidelines:
(decimal-notation-for-rationals "Use decimal notation for rationals") (decimal-notation-for-rationals "Use decimal notation for rationals")
(enforce-primitives-group-box-label "Initial Bindings") (enforce-primitives-group-box-label "Initial Bindings")
(enforce-primitives-check-box-label "Disallow redefinition of initial bindings") (enforce-primitives-check-box-label "Disallow redefinition of initial bindings")
(automatically-compile? "Automatically compile source files?") (automatically-compile "Populate compiled/ directories (for faster loading)")
(preserve-stacktrace-information "Preserve stacktrace (disable some JIT optimizations)")
(expression-level-stacktrace "Expression-level stacktrace")
(function-level-stacktrace "Function-level stacktrace")
; used in the bottom left of the drscheme frame ; used in the bottom left of the drscheme frame
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only

181
collects/string-constants/japanese-string-constants.ss
View File

@ -191,6 +191,7 @@ please adhere to these guidelines:
(cs-status-loading-docs-index "構文の検証: ドキュメントの索引をロードしています") (cs-status-loading-docs-index "構文の検証: ドキュメントの索引をロードしています")
(cs-mouse-over-import "束縛 ~s が ~s からインポートされました") (cs-mouse-over-import "束縛 ~s が ~s からインポートされました")
(cs-view-docs "~a のドキュメントを表示する") (cs-view-docs "~a のドキュメントを表示する")
(cs-view-docs-from "~a 参照元は ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use
(cs-lexical-variable "レキシカル変数") (cs-lexical-variable "レキシカル変数")
(cs-imported-variable "インポート変数") (cs-imported-variable "インポート変数")
@ -241,6 +242,11 @@ please adhere to these guidelines:
(erase-log-directory-contents "記録先のディレクトリ ~a の内容を消去しますか？") (erase-log-directory-contents "記録先のディレクトリ ~a の内容を消去しますか？")
(error-erasing-log-directory "記録先のディレクトリの内容を消去できませんでした。\n\n~a\n") (error-erasing-log-directory "記録先のディレクトリの内容を消去できませんでした。\n\n~a\n")
;; menu items connected to the logger -- also in a button in the planet status line in the drs frame
(show-log "ログを表示(&L)")
(hide-log "ログを非表示(&L)")
(logging-all "すべて") ;; in the logging window in drscheme, shows all logs simultaneously
;; modes ;; modes
(mode-submenu-label "モード") (mode-submenu-label "モード")
(scheme-mode "Scheme モード") (scheme-mode "Scheme モード")
@ -320,6 +326,18 @@ please adhere to these guidelines:
;; in the Help Desk language dialog, title on the right. ;; in the Help Desk language dialog, title on the right.
(plt:hd:manual-search-ordering "マニュアルの検索順序") (plt:hd:manual-search-ordering "マニュアルの検索順序")
;; in the help-desk standalone font preference dialog, on a check box
(use-drscheme-font-size "DrScheme のフォンサイズを使用する")
;; in the preferences dialog in drscheme there is example text for help desk font size.
;; clicking the links in that text produces a dialog with this message
(help-desk-this-is-just-example-text
"これはフォントサイズを設定するためのサンプルです。[ヘルプ] メニューから [ヘルプデスクを開く] を開いてリンクを辿ってください。")
;; this appears in the bottom part of the frame the first time the user hits `f1'
;; (assuming nothing else has loaded the documentation index first)
;; see also: cs-status-loading-docs-index
(help-desk-loading-documentation-index "ヘルプデスク: ドキュメントの索引を読み込んでいます")
;; Help desk htty proxy ;; Help desk htty proxy
(http-proxy "HTTP プロキシ") (http-proxy "HTTP プロキシ")
@ -372,13 +390,15 @@ please adhere to these guidelines:
;;; about box ;;; about box
(about-drscheme-frame-title "DrScheme について") (about-drscheme-frame-title "DrScheme について")
;;; save file in particular format prompting. ;;; save file in particular format prompting.
(save-as-plain-text "このファイルをプレーンテキストで保存しますか？") (save-as-plain-text "このファイルをプレーンテキストで保存しますか？")
(save-in-drs-format "このファイルを DrScheme 専用のバイナリ形式で保存しますか？") (save-in-drs-format "このファイルを DrScheme 専用のバイナリ形式で保存しますか？")
(yes "はい") (yes "はい")
(no "いいえ") (no "いいえ")
;; saving image (right click on an image to see the text)
(save-image "画像を保存する...")
;;; preferences ;;; preferences
(preferences "環境設定") (preferences "環境設定")
(error-saving-preferences "環境設定を保存時にエラーが発生しました: ~a") (error-saving-preferences "環境設定を保存時にエラーが発生しました: ~a")
@ -393,7 +413,8 @@ please adhere to these guidelines:
(editor-prefs-panel-label "編集") (editor-prefs-panel-label "編集")
(general-prefs-panel-label "一般") (general-prefs-panel-label "一般")
(highlight-parens "対応する括弧の間を強調表示する") (highlight-parens "対応する括弧の間を強調表示する")
(fixup-parens "括弧を自動修正する") (fixup-open-brackets "左角括弧を自動調整する")
(fixup-close-parens "右括弧を自動調整する")
(flash-paren-match "対応する括弧をフラッシュする") (flash-paren-match "対応する括弧をフラッシュする")
(auto-save-files "ファイルを自動保存する") (auto-save-files "ファイルを自動保存する")
(backup-files "ファイルをバックアップする") (backup-files "ファイルをバックアップする")
@ -404,6 +425,8 @@ please adhere to these guidelines:
(show-status-line "ステータス行を表示する") (show-status-line "ステータス行を表示する")
(count-columns-from-one "桁番号を 1 から数える") (count-columns-from-one "桁番号を 1 から数える")
(display-line-numbers "バッファの行番号を表示 (文字オフセットではなく)") (display-line-numbers "バッファの行番号を表示 (文字オフセットではなく)")
(show-line-and-column-numbers "行番号と桁番号を表示する") ; used for popup menu; right click on line/column box in bottom of drs window
(show-character-offsets "文字オフセットを表示する") ; used for popup menu; right click on line/column box in bottom of drs window
(enable-keybindings-in-menus "メニューのキーバインドを有効にする") (enable-keybindings-in-menus "メニューのキーバインドを有効にする")
(automatically-to-ps "自動的に PostScript ファイルに印刷する") (automatically-to-ps "自動的に PostScript ファイルに印刷する")
(command-as-meta "Command キーを Meta キーとして処理する") ;; macos/macos x only (command-as-meta "Command キーを Meta キーとして処理する") ;; macos/macos x only
@ -462,11 +485,16 @@ please adhere to these guidelines:
(indenting-prefs-panel-label "インデント") (indenting-prefs-panel-label "インデント")
(indenting-prefs-extra-regexp "正規表現") (indenting-prefs-extra-regexp "正規表現")
(square-bracket-prefs-panel-label "角括弧")
; filled with define, lambda, or begin ; filled with define, lambda, or begin
(enter-new-keyword "新しい ~a のようなキーワードを入力してください:") (enter-new-keyword "新しい ~a のようなキーワードを入力してください:")
(x-keyword "~a キーワード") (x-keyword "~a キーワード")
(x-like-keywords "~a のようなキーワード") (x-like-keywords "~a のようなキーワード")
; used in Square bracket panel
(skip-subexpressions "スキップする部分式の個数")
(expected-a-symbol "シンボルでなければなりません: ~a") (expected-a-symbol "シンボルでなければなりません: ~a")
(already-used-keyword "\"~a\" はすでに特別にインデントされるキーワードです") (already-used-keyword "\"~a\" はすでに特別にインデントされるキーワードです")
(add-keyword "追加") (add-keyword "追加")
@ -479,15 +507,22 @@ please adhere to these guidelines:
(repl-error-color "エラー") (repl-error-color "エラー")
;;; find/replace ;;; find/replace
(find-and-replace "検索と置換") (search-next "次")
(find "検索") (search-previous "前")
(replace "置換") (search-match "一致") ;;; this one and the next one are singular/plural variants of each other
(dock "結合") (search-matches "一致")
(undock "分離") (search-replace "置換")
(replace&find-again "置換＋再検索") ;;; need double & to get a single & (search-skip "無視")
(forward "前方") (search-show-replace "置換を表示")
(backward "後方") (search-hide-replace "置換を非表示")
(hide "隠す") (find-case-sensitive "大小文字を区別") ;; the check box in both the docked & undocked search
(find-anchor-based "アンカーを用いて検索")
;; these string constants used to be used by searching,
;; but aren't anymore. They are still used by other tools, tho.
(hide "隠す")
(dock "結合")
(undock "分離")
;;; multi-file-search ;;; multi-file-search
(mfs-multi-file-search-menu-item "ファイルから検索...") (mfs-multi-file-search-menu-item "ファイルから検索...")
@ -621,18 +656,34 @@ please adhere to these guidelines:
(select-all-info "文書全体を選択します") (select-all-info "文書全体を選択します")
(select-all-menu-item "すべて選択(&L)") (select-all-menu-item "すべて選択(&L)")
(find-info "文字列を検索します") (find-menu-item "検索") ;; menu item
(find-menu-item "検索...") (find-info "検索対象ウィンドウと検索バーの間でキーボード フォーカスを移動する")
(find-again-info "直前の検索文字列と同じ文字列を検索します") (find-next-info "検索ウィンドウ内の文字列が次に見つかるまでスキップ")
(find-again-menu-item "再検索") (find-next-menu-item "次を検索")
(find-previous-info "検索ウィンドウ内の文字列が前に見つかるまでスキップ")
(find-previous-menu-item "前を検索")
(show-replace-menu-item "置換を表示")
(hide-replace-menu-item "置換を非表示")
(show/hide-replace-info "置換パネルの表示/非表示を切り替える")
(replace-and-find-again-info "現在のテキストを置換し、直前の検索文字列と同じ文字列を検索します") (replace-menu-item "置換")
(replace-and-find-again-menu-item "置換と再検索") (replace-info "黒い円の中の検索にヒットした部分を置換する")
(replace-all-info "見つかった検索文字列をすべて置換する")
(replace-all-menu-item "すべて置換する")
(find-case-sensitive-info "大小文字を区別する/区別しないを切り替える")
(find-case-sensitive-menu-item "大小文字を区別して検索")
(complete-word "自動補完") ; the complete word menu item in the edit menu (complete-word "自動補完") ; the complete word menu item in the edit menu
(no-completions "... 自動補完できません") ; shows up in the completions menu when there are no completions (in italics) (no-completions "... 自動補完できません") ; shows up in the completions menu when there are no completions (in italics)
(overwrite-mode "上書きモード")
(enable-overwrite-mode-keybindings "上書きモードのキーバインドを有効にする")
(preferences-info "環境設定を行います") (preferences-info "環境設定を行います")
(preferences-menu-item "環境設定...") (preferences-menu-item "環境設定...")
@ -643,10 +694,17 @@ please adhere to these guidelines:
(keybindings-sort-by-name "名前で並べ替え") (keybindings-sort-by-name "名前で並べ替え")
(keybindings-sort-by-key "キーで並べ替え") (keybindings-sort-by-key "キーで並べ替え")
(keybindings-add-user-defined-keybindings "ユーザー定義のキーバインドを追加...") (keybindings-add-user-defined-keybindings "ユーザー定義のキーバインドを追加...")
(keybindings-add-user-defined-keybindings/planet "ユーザー定義のキーバインドを PLaneT から追加...")
(keybindings-menu-remove "~a を削除") (keybindings-menu-remove "~a を削除")
(keybindings-choose-user-defined-file "キーバインドを記述したファイルを選択してください") (keybindings-choose-user-defined-file "キーバインドを記述したファイルを選択してください")
(keybindings-planet-malformed-spec "PLaneT の指定が不正です: ~a") ; the string will be what the user typed in
(keybindings-type-planet-spec "PLaneT の require 指定を入力してください (`require' は入力しないでください)")
; first ~a will be a string naming the file or planet package where the keybindings come from;
; second ~a will be an error message
(keybindings-error-installing-file "キーバインドのインストール時にエラーが発生しました ~a:\n\n~a")
(user-defined-keybinding-error "キーバインド ~a\n\n~a を実行中にエラーが発生しました") (user-defined-keybinding-error "キーバインドを実行中にエラーが発生しました ~a\n\n~a")
(user-defined-keybinding-malformed-file "ファイル ~a には、言語 framework/keybinding-lang で書かれたモジュールが含まれていません。") (user-defined-keybinding-malformed-file "ファイル ~a には、言語 framework/keybinding-lang で書かれたモジュールが含まれていません。")
;; menu items in the "special" menu ;; menu items in the "special" menu
@ -657,12 +715,15 @@ please adhere to these guidelines:
(wrap-text-item "テキストを折り返す") (wrap-text-item "テキストを折り返す")
;; windows menu
(windows-menu-label "ウィンドウ(&W)") (windows-menu-label "ウィンドウ(&W)")
(minimize "最小化") ;; minimize and zoom are only used under mac os x (minimize "最小化") ;; minimize and zoom are only used under mac os x
(zoom "拡大") (zoom "拡大")
(bring-frame-to-front "フレームを前面に移動") ;;; title of dialog (bring-frame-to-front "フレームを前面に移動") ;;; title of dialog
(bring-frame-to-front... "フレームを前面に移動...") ;;; corresponding title of menu item (bring-frame-to-front... "フレームを前面に移動...") ;;; corresponding title of menu item
(most-recent-window "最近使用したウィンドウ") (most-recent-window "最近使用したウィンドウ")
(next-tab "次のタブ")
(prev-tab "前のタブ")
(view-menu-label "表示(&V)") (view-menu-label "表示(&V)")
(show-overview "プログラムの外観を表示") (show-overview "プログラムの外観を表示")
@ -670,7 +731,7 @@ please adhere to these guidelines:
(show-module-browser "モジュール ブラウザを表示") (show-module-browser "モジュール ブラウザを表示")
(hide-module-browser "モジュール ブラウザを非表示") (hide-module-browser "モジュール ブラウザを非表示")
(help-menu-label "ヘルプ(&H)") (help-menu-label "ヘルプ(&H)")
(about-info "このアプリケーションの著作権と詳細情報を表示します") (about-info "このアプリケーションの著作権と詳細情報を表示します")
(about-menu-item "バージョン情報...") (about-menu-item "バージョン情報...")
@ -687,6 +748,12 @@ please adhere to these guidelines:
(quit "終了") (quit "終了")
(are-you-sure-exit "終了してよろしいですか？") (are-you-sure-exit "終了してよろしいですか？")
(are-you-sure-quit "終了してよろしいですか？") (are-you-sure-quit "終了してよろしいですか？")
; these next two are only used in the quit/exit dialog
; on the button whose semantics is "dismiss this dialog".
; they are there to provide more flexibility for translations
; in English, they are just cancel.
(dont-exit "キャンセル")
(dont-quit "キャンセル")
;;; autosaving ;;; autosaving
(error-autosaving "\"~a\" を自動保存中にエラーが発生しました。") ;; ~a will be a filename (error-autosaving "\"~a\" を自動保存中にエラーが発生しました。") ;; ~a will be a filename
@ -765,8 +832,6 @@ please adhere to these guidelines:
(show-interactions-menu-item-label "対話を表示(&I)") (show-interactions-menu-item-label "対話を表示(&I)")
(hide-interactions-menu-item-label "対話を非表示(&I)") (hide-interactions-menu-item-label "対話を非表示(&I)")
(interactions-menu-item-help-string "対話ウィンドウを表示/非表示します") (interactions-menu-item-help-string "対話ウィンドウを表示/非表示します")
(show-toolbar "ツールバーを表示(&T)")
(hide-toolbar "ツールバーを非表示(&T)")
(toolbar "ツールバー") (toolbar "ツールバー")
(toolbar-on-top "ツールバーを上側に表示する") (toolbar-on-top "ツールバーを上側に表示する")
(toolbar-on-left "ツールバーを左側に表示する") (toolbar-on-left "ツールバーを左側に表示する")
@ -799,12 +864,12 @@ please adhere to these guidelines:
(scheme-menu-name "S&cheme") (scheme-menu-name "S&cheme")
(execute-menu-item-label "実行") (execute-menu-item-label "実行")
(execute-menu-item-help-string "定義ウィンドウのプログラムを再開始します") (execute-menu-item-help-string "定義ウィンドウのプログラムを再開始します")
(break-menu-item-label "停止") (ask-quit-menu-item-label "プログラムを停止しますか？")
(break-menu-item-help-string "現在の評価を停止します") (ask-quit-menu-item-help-string "現在の式評価のプライマリ スレッドを停止するには break-thread を使用してください")
(kill-menu-item-label "強制終了") (force-quit-menu-item-label "プログラムを強制終了します")
(kill-menu-item-help-string "現在の評価を強制終了します") (force-quit-menu-item-help-string "現在の式評価を強制終了するには custodian-shutdown-all を使用してください")
(limit-memory-menu-item-label "メモリを制限する...") (limit-memory-menu-item-label "メモリを制限する...")
(limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。") (limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次回に実行するときに有効になります。")
(limit-memory-msg-2 "制限値は 1MB 以上にしてください。") (limit-memory-msg-2 "制限値は 1MB 以上にしてください。")
(limit-memory-unlimited "制限しない") (limit-memory-unlimited "制限しない")
(limit-memory-limited "制限する") (limit-memory-limited "制限する")
@ -827,23 +892,34 @@ please adhere to these guidelines:
(save-a-mzscheme-launcher "MzScheme ランチャの保存") (save-a-mzscheme-launcher "MzScheme ランチャの保存")
(save-a-mred-stand-alone-executable "MrEd スタンドアロン実行ファイルの保存") (save-a-mred-stand-alone-executable "MrEd スタンドアロン実行ファイルの保存")
(save-a-mzscheme-stand-alone-executable "MzScheme スタンドアロン実行ファイルの保存") (save-a-mzscheme-stand-alone-executable "MzScheme スタンドアロン実行ファイルの保存")
(save-a-mred-distribution "MrEd 配布物の保存")
(save-a-mzscheme-distribution "MzScheme 配布物の保存")
(definitions-not-saved "定義ウィンドウが保存されていません。実行ファイルでは定義ウィンドウの最新の保存が使われます。よろしいですか？") (definitions-not-saved "定義ウィンドウが保存されていません。実行ファイルでは定義ウィンドウの最新の保存が使われます。よろしいですか？")
;; The "-explanatory-label" variants are the labels used for the radio buttons in
;; the "Create Executable..." dialog for the "(module ...)" language.
(launcher "ランチャ") (launcher "ランチャ")
(launcher-explanatory-label "Launcher (for this machine only, runs from source)")
(stand-alone "スタンドアロン") (stand-alone "スタンドアロン")
(stand-alone-explanatory-label "Stand-alone (for this machine only, run compiled copy)")
(distribution "Distribution")
(distribution-explanatory-label "Distribution (to install on other machines)")
(executable-type "Type") (executable-type "Type")
(executable-base "Base") (executable-base "Base")
(filename "ファイル名: ") (filename "ファイル名: ")
(create "作成") (create "作成")
;; "choose-an-executable" changed to "specify-a" (please-specify-a-filename "作成するファイル名を指定してください。")
;(please-choose-an-executable-filename "Please choose a filename.") (~a-must-end-with-~a
;; Replaced by generic ~a-must-end-with-~a "~a のファイル名\n\n ~a\n\n は不正です。ファイル名の末尾は \".~a\" でなければなりません。")
;(windows-executables-must-end-with-exe (macosx-executables-must-end-with-app
; "ファイル名\n\n ~a\n\nは正しくありません。Windows では、実行ファイルは .exe という拡張子を持たなければなりません。") "ファイル名\n\n ~a\n\n は不正です。MacOS X では実行ファイルは末尾が .app のディレクトリでなければなりません。")
;(macosx-executables-must-end-with-app
; "ファイル名\n\n ~a\n\nは正しくありません。MacOS X では、実行ファイルは .app という名前で終わるディレクトリでなければなりません。")
(warning-directory-will-be-replaced (warning-directory-will-be-replaced
"警告: ディレクトリ:\n\n ~a\n\nは削除または上書きされます。よろしいですか？") "警告: ディレクトリ:\n\n ~a\n\n を置換します。よろしいですか？")
(distribution-progress-window-title "配布物作成の進行状況")
(creating-executable-progress-status "配布物のための実行ファイルを作成しています...")
(assembling-distribution-files-progress-status "配布物のファイルをまとめています...")
(packing-distribution-progress-status "配布物を展開しています...")
(create-servlet "サーブレットの作成...") (create-servlet "サーブレットの作成...")
@ -869,7 +945,9 @@ please adhere to these guidelines:
(whole-part "整数部") (whole-part "整数部")
(numerator "分子") (numerator "分子")
(denominator "分母") (denominator "分母")
(invalid-number "不正な数値です。正確数で、実数で、整数でない数でないといけません。") (insert-number/bad-whole-part "整数でなければなりません。")
(insert-number/bad-numerator "分子は非負の整数でなければなりません。")
(insert-number/bad-denominator "分母は正の整数でなければなりません。")
(insert-fraction-menu-item-label "分数を挿入...") (insert-fraction-menu-item-label "分数を挿入...")
;; number snip popup menu ;; number snip popup menu
@ -929,6 +1007,7 @@ please adhere to these guidelines:
(decimal-notation-for-rationals "有理数を10進数で表示する") (decimal-notation-for-rationals "有理数を10進数で表示する")
(enforce-primitives-group-box-label "初期束縛") (enforce-primitives-group-box-label "初期束縛")
(enforce-primitives-check-box-label "初期束縛の再定義を禁止する") (enforce-primitives-check-box-label "初期束縛の再定義を禁止する")
(automatically-compile? "ソースファイルを自動的にコンパイルしますか？")
; used in the bottom left of the drscheme frame ; used in the bottom left of the drscheme frame
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only
@ -955,6 +1034,7 @@ please adhere to these guidelines:
(how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one... (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
(pretty-big-scheme "Pretty Big") (pretty-big-scheme "Pretty Big")
(pretty-big-scheme-one-line-summary "syntax と HtDP 言語の関数を追加") (pretty-big-scheme-one-line-summary "syntax と HtDP 言語の関数を追加")
(pretty-big-scheme-one-line-summary "HtDP 言語, mzscheme, mred/mred の構文と関数を追加")
(r5rs-language-name "R5RS") (r5rs-language-name "R5RS")
(r5rs-one-line-summary "純粋な R5RS") (r5rs-one-line-summary "純粋な R5RS")
(expander "Expander") (expander "Expander")
@ -966,6 +1046,7 @@ please adhere to these guidelines:
(no-language-chosen "言語が選択されていません") (no-language-chosen "言語が選択されていません")
(module-language-one-line-summary "実行するとモジュールのコンテキスト内で REPL を作成する。モジュールで宣言された言語を含む。") (module-language-one-line-summary "実行するとモジュールのコンテキスト内で REPL を作成する。モジュールで宣言された言語を含む。")
(module-language-auto-text "#lang 行を自動的に追加する") ;; shows up in the details section of the module language
;;; from the `not a language language' used initially in drscheme. ;;; from the `not a language language' used initially in drscheme.
(must-choose-language "DrScheme は、プログラミング言語を選択しなければプログラムを実行できません。") (must-choose-language "DrScheme は、プログラミング言語を選択しなければプログラムを実行できません。")
@ -1099,6 +1180,7 @@ please adhere to these guidelines:
(module-browser-compiling-defns "モジュール ブラウザ: 定義をコンパイル中です") (module-browser-compiling-defns "モジュール ブラウザ: 定義をコンパイル中です")
(module-browser-show-lib-paths/short "必要なライブラリを含める") ;; check box label in show module browser pane in drscheme window. (module-browser-show-lib-paths/short "必要なライブラリを含める") ;; check box label in show module browser pane in drscheme window.
(module-browser-refresh "更新") ;; button label in show module browser pane in drscheme window. (module-browser-refresh "更新") ;; button label in show module browser pane in drscheme window.
(module-browser-refresh "再表示") ;; button label in show module browser pane in drscheme window.
(module-browser-only-in-plt-and-module-langs (module-browser-only-in-plt-and-module-langs
"モジュール ブラウザは PLT 言語、または、モジュール言語のプログラム (あるいは、それらの言語のモジュールを持つプログラム) でのみ利用可能です。") "モジュール ブラウザは PLT 言語、または、モジュール言語のプログラム (あるいは、それらの言語のモジュールを持つプログラム) でのみ利用可能です。")
(module-browser-name-length "名前の長さ") (module-browser-name-length "名前の長さ")
@ -1204,6 +1286,8 @@ please adhere to these guidelines:
(ml-cp-raise "上へ") (ml-cp-raise "上へ")
(ml-cp-lower "下へ") (ml-cp-lower "下へ")
(ml-always-show-#lang-line "モジュール言語で常に #lang 行を表示する")
;; Profj ;; Profj
(profj-java "Java") (profj-java "Java")
(profj-java-mode "Java モード") (profj-java-mode "Java モード")
@ -1342,4 +1426,29 @@ please adhere to these guidelines:
(gui-tool-show-gui-toolbar "GUI ツールバーを表示") (gui-tool-show-gui-toolbar "GUI ツールバーを表示")
(gui-tool-hide-gui-toolbar "GUI ツールバーを非表示") (gui-tool-hide-gui-toolbar "GUI ツールバーを非表示")
(gui-tool-insert-gui "GUI を挿入") (gui-tool-insert-gui "GUI を挿入")
;; contract violation tracking
; tooltip for new planet icon in drscheme window (must have a planet violation logged to see it)
(show-planet-contract-violations "PLaneT の規約違反を表示する")
; buttons in the dialog that lists the recorded bug reports
(bug-track-report "File Ticket")
(bug-track-forget "Forget")
(bug-track-forget-all "Forget All")
;; planet status messages in the bottom of the drscheme window; the ~a is filled with the name of the package
(planet-downloading "PLaneT: ダウンロード中 ~a...")
(planet-installing "PLaneT: インストール中 ~a...")
(planet-finished "PLaneT: 完了 ~a.")
(planet-no-status "PLaneT") ;; this can happen when there is status shown in a different and then the user switches to a tab where planet hasn't been used
;; string normalization. To see this, paste some text with a ligature into DrScheme
;; the first three strings are in the dialog that appears. The last one is in the preferences dialog
(normalize "Normalize")
(leave-alone "Leave alone")
(normalize-string-info "The string you pasted contains ligatures or other non-normalized characters. Normalize them?")
(normalize-string-preference "Normalize pasted strings")
(ask-about-normalizing-strings "Ask about normalizing strings")
) )

21
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -173,9 +173,10 @@
(wait-for-computation frame)))])) (wait-for-computation frame)))]))
(define (verify-drscheme-frame-frontmost function-name frame) (define (verify-drscheme-frame-frontmost function-name frame)
(unless (and (eq? frame (get-top-level-focus-window)) (let ([tl (get-top-level-focus-window)])
(drscheme-frame? frame)) (unless (and (eq? frame tl)
(error function-name "drscheme frame not frontmost: ~e" frame))) (drscheme-frame? tl))
(error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl))))
(define (clear-definitions frame) (define (clear-definitions frame)
(verify-drscheme-frame-frontmost 'clear-definitions frame) (verify-drscheme-frame-frontmost 'clear-definitions frame)
@ -192,22 +193,24 @@
"Delete"))) "Delete")))
(define (type-in-definitions frame str) (define (type-in-definitions frame str)
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #f)) (put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #f 'type-in-definitions))
(define (type-in-interactions frame str) (define (type-in-interactions frame str)
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #f)) (put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #f 'type-in-interactions))
(define (insert-in-definitions frame str) (define (insert-in-definitions frame str)
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #t)) (put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #t 'insert-in-definitions))
(define (insert-in-interactions frame str) (define (insert-in-interactions frame str)
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #t)) (put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #t 'insert-in-interactions))
(define (put-in-frame get-canvas frame str/sexp just-insert?) (define (put-in-frame get-canvas frame str/sexp just-insert? who)
(unless (and (object? frame) (is-a? frame top-level-window<%>))
(error who "expected a frame or a dialog as the first argument, got ~e" frame))
(let ([str (if (string? str/sexp) (let ([str (if (string? str/sexp)
str/sexp str/sexp
(let ([port (open-output-string)]) (let ([port (open-output-string)])
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(write str/sexp port)) (write str/sexp port))
(get-output-string port)))]) (get-output-string port)))])
(verify-drscheme-frame-frontmost 'put-in-frame frame) (verify-drscheme-frame-frontmost who frame)
(let ([canvas (get-canvas frame)]) (let ([canvas (get-canvas frame)])
(fw:test:new-window canvas) (fw:test:new-window canvas)
(let ([editor (send canvas get-editor)]) (let ([editor (send canvas get-editor)])

116
collects/tests/drscheme/language-test.ss
View File

@ -125,23 +125,20 @@ the settings above should match r5rs
(test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case"))) (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case")))
;
; ;
; ; ;;;;;;; ;;;;;;; ;;;;;;
; ; ;; ;; ;; ;; ;; ;;
; ;;;;;; ; ;; ;; ;;;;; ;; ;; ;; ;
; ; ; ;; ;; ;;;;; ;; ;; ;;;;
; ; ; ;;;;;; ; ;;;;;; ;;;;;
; ; ; ; ; ; ;;; ; ;; ;; ;;;; ;; ;; ;;;
; ;; ;;;; ;; ; ; ;; ;; ;; ;; ;; ; ;;
; ; ; ; ;; ; ;; ;; ;; ;; ;; ;; ;;
; ; ; ; ;; ; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;;
; ; ; ; ; ; ;; ;;
; ; ; ; ; ; ; ;;;;
; ; ;;; ; ;;; ;
;
;
;
(define (r5rs) (define (r5rs)
@ -229,21 +226,23 @@ the settings above should match r5rs
(test-expression "argv" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: argv") (test-expression "argv" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: argv")
(test-expression "(define-syntax app syntax-case)" (test-expression "(define-syntax app syntax-case)"
"{stop-22x22.png} compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: syntax-case"))) "{stop-22x22.png} macro-transformer: only a `syntax-rules' form is allowed in: syntax-case")))
;; ;
;
;
;;;; ;;; ;;; ; ;;; ; ;;; ; ;;; ;;; ; ;;;
; ; ; ; ; ; ; ;; ; ;; ; ; ; ;
; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ;;; ;;;; ;;;;; ;;; ;;;;; ;; ;;; ;;;;
;
;
;;;
;
; ;;; ;;
; ;; ;;
; ;;
; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;;
; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;;
; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;;
; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;;
; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;;
; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;;
; ;; ;;
; ;; ;;
; ;;;;;
(define (beginner) (define (beginner)
(parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")])
@ -395,18 +394,20 @@ the settings above should match r5rs
;; ; ;; ;
; ; ; ; ;;; ;;; ;;;
; ; ; ; ;; ; ;; ;;
;;;; ;;; ;;; ; ; ;;;; ;;;; ; ;;; ;;; ;;; ;;; ; ;; ; ;; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;;
; ; ;;;;; ; ; ; ;;;; ; ; ; ;;;;; ; ; ; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;;
; ;;; ;;; ;;;; ; ;;; ;; ;;; ;;;; ;;; ; ; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;;
; ; ; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;;
; ; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ;
;;; ; ;; ;;;
; ;; ;;;
; ;;;;;
(define (beginner/abbrev) (define (beginner/abbrev)
@ -558,19 +559,20 @@ the settings above should match r5rs
"reference to an identifier before its definition: define-syntax"))) "reference to an identifier before its definition: define-syntax")))
;
; ;; ; ; ;; ;;; ;;
; ; ; ; ;; ;; ;; ;; ;;
; ; ; ; ;; ;; ;;
;;; ; ;;; ;;;;; ;;; ; ;;; ;;; ; ;;; ;;;; ;;; ;;;; ;;;;; ;;; ; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;;
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ;;;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
;;;;; ;;; ;; ;;; ;;; ;;;; ;; ; ;; ;;; ;;; ; ;;;;; ;;; ; ;;; ;;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;
; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;;
;
;
;
(define (intermediate) (define (intermediate)
@ -654,7 +656,7 @@ the settings above should match r5rs
(test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
(test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1") (test-expression "(+ 1)" "1\nThis program should be tested.")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1\nThis program should be tested." "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0")
@ -813,7 +815,7 @@ the settings above should match r5rs
(test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
(test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1") (test-expression "(+ 1)" "1\nThis program should be tested.")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1\nThis program should be tested." "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0")

7
collects/tests/drscheme/module-lang-test-utils.ss
View File

@ -124,7 +124,12 @@
(send interactions-text get-error-ranges))))]))))) (send interactions-text get-error-ranges))))])))))
(define (run-test) (define (run-test)
(set-language-level! '("Module") #t) (set-language-level! '("Module") #f)
(test:set-radio-box-item! "Debugging")
(let ([f (get-top-level-focus-window)])
(test:button-push "OK")
(wait-for-new-frame f))
(for-each single-test (reverse tests)) (for-each single-test (reverse tests))
(clear-definitions drs) (clear-definitions drs)
(send (send drs get-definitions-text) set-modified #f) (send (send drs get-definitions-text) set-modified #f)

3
collects/tests/drscheme/module-lang-test.ss
View File

@ -158,8 +158,7 @@
(test @t{#lang scheme (test @t{#lang scheme
(eval 'cons)} (eval 'cons)}
#f #f
@rx{. compile: bad syntax; reference to top-level identifier is not @rx{. compile: unbound identifier \(and no #%top syntax transformer is bound\) in: cons})
allowed, because no #%top syntax transformer is bound in: cons})
(test @t{(module m (file @in-here{module-lang-test-tmp1.ss}) 1 2 3)} (test @t{(module m (file @in-here{module-lang-test-tmp1.ss}) 1 2 3)}
@t{1} ;; just make sure no errors. @t{1} ;; just make sure no errors.
"1") "1")

175
collects/tests/drscheme/repl-test.ss
View File

@ -804,8 +804,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3"
"procedure application: expected procedure, given: 3; arguments were: 3" "procedure application: expected procedure, given: 3; arguments were: 3"
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3"
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3")
'definitions 'definitions
#f #f
void void
@ -1081,15 +1081,6 @@ This produces an ACK message
(define definitions-canvas (send drscheme-frame get-definitions-canvas)) (define definitions-canvas (send drscheme-frame get-definitions-canvas))
(define execute-button (send drscheme-frame get-execute-button)) (define execute-button (send drscheme-frame get-execute-button))
(define (insert-string string)
(let loop ([n 0])
(unless (= n (string-length string))
(let ([c (string-ref string n)])
(if (char=? c #\newline)
(test:keystroke #\return)
(test:keystroke c)))
(loop (+ n 1)))))
(define wait-for-execute (lambda () (wait-for-button execute-button))) (define wait-for-execute (lambda () (wait-for-button execute-button)))
(define get-int-pos (lambda () (get-text-pos interactions-text))) (define get-int-pos (lambda () (get-text-pos interactions-text)))
@ -1133,10 +1124,10 @@ This produces an ACK message
; of the file "foo.ss". First, we insert its contents into the REPL ; of the file "foo.ss". First, we insert its contents into the REPL
; directly, and second, we use the load command. We compare the ; directly, and second, we use the load command. We compare the
; the results of these operations against expected results. ; the results of these operations against expected results.
(define ((run-single-test execute-text-start escape raw?) in-vector) (define ((run-single-test execute-text-start escape language-cust) in-vector)
;(printf "\n>> testing ~s\n" (test-program in-vector)) ;(printf "\n>> testing ~s\n" (test-program in-vector))
(let* ([program (test-program in-vector)] (let* ([program (test-program in-vector)]
[execute-answer (make-execute-answer in-vector raw?)] [execute-answer (make-execute-answer in-vector language-cust)]
[source-location (test-source-location in-vector)] [source-location (test-source-location in-vector)]
[setup (test-setup in-vector)] [setup (test-setup in-vector)]
[teardown (test-teardown in-vector)] [teardown (test-teardown in-vector)]
@ -1154,16 +1145,18 @@ This produces an ACK message
; load contents of test-file into the REPL, recording ; load contents of test-file into the REPL, recording
; the start and end positions of the text ; the start and end positions of the text
(wait-for-drscheme-frame)
(cond (cond
[(string? program) [(string? program)
(insert-string program)] (insert-in-definitions/newlines drscheme-frame program)]
[(eq? program 'fraction-sum) [(eq? program 'fraction-sum)
(setup-fraction-sum-interactions)] (setup-fraction-sum-interactions)]
[(list? program) [(list? program)
(for-each (for-each
(lambda (item) (lambda (item)
(cond (cond
[(string? item) (insert-string item)] [(string? item) (insert-in-definitions/newlines drscheme-frame item)]
[(eq? item 'left) [(eq? item 'left)
(send definitions-text (send definitions-text
set-position set-position
@ -1182,34 +1175,36 @@ This produces an ACK message
(fetch-output drscheme-frame execute-text-start execute-text-end)]) (fetch-output drscheme-frame execute-text-start execute-text-end)])
; check focus and selection for execute test ; check focus and selection for execute test
(unless raw? (case language-cust
(cond [(raw) (void)]
[(eq? source-location 'definitions) [else
(unless (send definitions-canvas has-focus?) (cond
(printf "FAILED execute test for ~s\n expected definitions to have the focus\n" [(eq? source-location 'definitions)
program))] (unless (send definitions-canvas has-focus?)
[(eq? source-location 'interactions) (printf "FAILED execute test for ~s\n expected definitions to have the focus\n"
(unless (send interactions-canvas has-focus?) program))]
(printf "FAILED execute test for ~s\n expected interactions to have the focus\n" [(eq? source-location 'interactions)
program))] (unless (send interactions-canvas has-focus?)
[(send definitions-canvas has-focus?) (printf "FAILED execute test for ~s\n expected interactions to have the focus\n"
(let ([start (car source-location)] program))]
[finish (cdr source-location)]) [(send definitions-canvas has-focus?)
(let* ([error-ranges (send interactions-text get-error-ranges)] (let ([start (car source-location)]
[error-range (and error-ranges [finish (cdr source-location)])
(not (null? error-ranges)) (let* ([error-ranges (send interactions-text get-error-ranges)]
(car error-ranges))]) [error-range (and error-ranges
(unless (and error-range (not (null? error-ranges))
(= (+ (srcloc-position error-range) -1) (loc-offset start)) (car error-ranges))])
(= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (unless (and error-range
(loc-offset finish))) (= (+ (srcloc-position error-range) -1) (loc-offset start))
(printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" (= (+ (srcloc-position error-range) -1 (srcloc-span error-range))
program (loc-offset finish)))
(and error-range (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
(list (+ (srcloc-position error-range) -1) program
(+ (srcloc-position error-range) -1 (srcloc-span error-range)))) (and error-range
(list (loc-offset start) (list (+ (srcloc-position error-range) -1)
(loc-offset finish))))))])) (+ (srcloc-position error-range) -1 (srcloc-span error-range))))
(list (loc-offset start)
(loc-offset finish))))))])])
; check text for execute test ; check text for execute test
(next-test) (next-test)
@ -1222,7 +1217,7 @@ This produces an ACK message
(failure) (failure)
(printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
program program
raw? language-cust
execute-answer received-execute)) execute-answer received-execute))
(test:new-window interactions-canvas) (test:new-window interactions-canvas)
@ -1238,9 +1233,7 @@ This produces an ACK message
(send interactions-text get-character (send interactions-text get-character
(- (send interactions-text last-position) 1)))) (- (send interactions-text last-position) 1))))
(test:keystroke #\return)) (test:keystroke #\return))
;
(let ([load-test (let ([load-test
(lambda (short-filename load-answer) (lambda (short-filename load-answer)
;; in order to erase the state in the namespace already, we clear (but don't save!) ;; in order to erase the state in the namespace already, we clear (but don't save!)
@ -1252,8 +1245,7 @@ This produces an ACK message
(wait-for-execute) (wait-for-execute)
;; stuff the load command into the REPL ;; stuff the load command into the REPL
(for-each test:keystroke (insert-in-interactions drscheme-frame (format "(load ~s)" short-filename))
(string->list (format "(load ~s)" short-filename)))
;; record current text position, then stuff a CR into the REPL ;; record current text position, then stuff a CR into the REPL
(let ([load-text-start (+ 1 (send interactions-text last-position))]) (let ([load-text-start (+ 1 (send interactions-text last-position))])
@ -1280,11 +1272,11 @@ This produces an ACK message
(printf "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n" (printf "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n"
short-filename short-filename
program load-answer received-load)))))]) program load-answer received-load)))))])
(load-test tmp-load-short-filename (make-load-answer in-vector raw? #f)) (load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f))
(when (file-exists? tmp-load3-filename) (when (file-exists? tmp-load3-filename)
(delete-file tmp-load3-filename)) (delete-file tmp-load3-filename))
(copy-file tmp-load-filename tmp-load3-filename) (copy-file tmp-load-filename tmp-load3-filename)
(load-test tmp-load3-short-filename (make-load-answer in-vector raw? tmp-load3-short-filename))) (load-test tmp-load3-short-filename (make-load-answer in-vector language-cust tmp-load3-short-filename)))
(teardown) (teardown)
@ -1303,17 +1295,27 @@ This produces an ACK message
(printf "tests finished: all ~a tests passed\n" tests) (printf "tests finished: all ~a tests passed\n" tests)
(printf "tests finished: ~a failed out of ~a total\n" failures tests))) (printf "tests finished: ~a failed out of ~a total\n" failures tests)))
(define (run-test-in-language-level raw?) (define (run-test-in-language-level language-cust)
(let ([level (list #rx"Pretty Big")]) (let ([level (list #rx"Pretty Big")])
(printf "running tests ~a debugging\n" (if raw? "without" "with")) (printf "running tests: ~a\n" language-cust)
(if raw? (case language-cust
(begin [(raw)
(set-language-level! level #f) (begin
(test:set-radio-box-item! "No debugging or profiling") (set-language-level! level #f)
(let ([f (get-top-level-focus-window)]) (test:set-radio-box-item! "No debugging or profiling")
(test:button-push "OK") (let ([f (get-top-level-focus-window)])
(wait-for-new-frame f))) (test:button-push "OK")
(set-language-level! level)) (wait-for-new-frame f)))]
[(debug)
(set-language-level! level)]
[(debug/profile)
(begin
(set-language-level! level #f)
(test:set-radio-box-item! "Debugging and profiling")
(let ([f (get-top-level-focus-window)])
(test:button-push "OK")
(wait-for-new-frame f)))])
(random-seed-test) (random-seed-test)
@ -1321,7 +1323,7 @@ This produces an ACK message
(clear-definitions drscheme-frame) (clear-definitions drscheme-frame)
(do-execute drscheme-frame) (do-execute drscheme-frame)
(let/ec escape (let/ec escape
(for-each (run-single-test (get-int-pos) escape raw?) test-data)))) (for-each (run-single-test (get-int-pos) escape language-cust) test-data))))
(define kill-menu-item "Force the Program to Quit") (define kill-menu-item "Force the Program to Quit")
@ -1390,19 +1392,18 @@ This produces an ACK message
(fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output))))) (fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output)))))
(define (random-seed-test) (define (random-seed-test)
(define expression (define expression (format "~s" '(pseudo-random-generator->vector (current-pseudo-random-generator))))
(string->list (format "~a" '(pseudo-random-generator->vector (current-pseudo-random-generator)))))
(next-test) (next-test)
(clear-definitions drscheme-frame) (clear-definitions drscheme-frame)
(do-execute drscheme-frame) (do-execute drscheme-frame)
(wait-for-execute) (wait-for-execute)
(for-each test:keystroke expression) (insert-in-interactions drscheme-frame expression)
(let ([start1 (+ 1 (send interactions-text last-position))]) (let ([start1 (+ 1 (send interactions-text last-position))])
(test:keystroke #\return) (test:keystroke #\return)
(wait-for-execute) (wait-for-execute)
(let ([output1 (fetch-output drscheme-frame start1 (- (get-int-pos) 1))]) (let ([output1 (fetch-output drscheme-frame start1 (- (get-int-pos) 1))])
(for-each test:keystroke expression) (insert-in-interactions drscheme-frame expression)
(let ([start2 (+ 1 (send interactions-text last-position))]) (let ([start2 (+ 1 (send interactions-text last-position))])
(test:keystroke #\return) (test:keystroke #\return)
(wait-for-execute) (wait-for-execute)
@ -1453,27 +1454,45 @@ This produces an ACK message
(delete-file tmp-load-filename)) (delete-file tmp-load-filename))
(save-drscheme-window-as tmp-load-filename) (save-drscheme-window-as tmp-load-filename)
(run-test-in-language-level #f) ;; the debug and debug/profile tests should not differ in their output
(run-test-in-language-level #t) ;; they are both run here because debug uses the automatic-compilation
;; stuff and debug/profile does not (so they use different instantiations
;; of the stacktrace module.
(run-test-in-language-level 'raw)
(run-test-in-language-level 'debug)
(run-test-in-language-level 'debug/profile)
(kill-tests) (kill-tests)
(callcc-test) (callcc-test)
(top-interaction-test) (top-interaction-test)
(final-report) (final-report)
) )
(define (insert-in-definitions/newlines drs str)
(let loop ([strs (regexp-split #rx"\n" str)])
(insert-in-definitions drs (car strs))
(unless (null? (cdr strs))
(test:keystroke #\return)
(loop (cdr strs)))))
(define (make-execute-answer test raw?) (define (make-execute-answer test language-cust)
((if raw? answer-raw-execute answer-debug-execute) ((case language-cust
[(debug debug/profile)
answer-debug-execute]
[(raw)
answer-raw-execute])
(test-answer test))) (test-answer test)))
(define (make-load-answer test raw? src-file) (define (make-load-answer test language-cust src-file)
((if raw? ((case language-cust
(if src-file [(debug debug/profile)
answer-raw-load (if src-file
answer-raw-load-fn) answer-debug-load
(if src-file answer-debug-load-fn)]
answer-debug-load [(raw)
answer-debug-load-fn)) (if src-file
answer-raw-load
answer-raw-load-fn)])
(test-answer test))) (test-answer test)))
(define (string/rx-append a b) (define (string/rx-append a b)

66
collects/tests/mzscheme/cm.ss
View File

@ -12,8 +12,8 @@
(define (try files #; (list (list path content-str compile?) ...) (define (try files #; (list (list path content-str compile?) ...)
recomps #; (list (list (list touch-path ...) recomps #; (list (list (list touch-path ...)
(list rebuild-path ...) (list rebuild-path ...)
(list check-rebuilt-path ...))) (list check-rebuilt-path ...)))
) )
(delete-directory/files dir) (delete-directory/files dir)
(make-directory* dir) (make-directory* dir)
@ -40,30 +40,32 @@
(for-each (lambda (recomp) (for-each (lambda (recomp)
(printf "pausing...\n") (printf "pausing...\n")
(sleep 1) ;; timestamps have a 1-second granularity on most filesystems (sleep 1) ;; timestamps have a 1-second granularity on most filesystems
(for-each (lambda (f) (let ([to-touch (list-ref recomp 0)]
(printf "touching ~a\n" f) [to-make (list-ref recomp 1)])
(with-output-to-file (build-path dir f) (for-each (lambda (f)
#:exists 'append (printf "touching ~a\n" f)
(lambda () (display " ")))) (with-output-to-file (build-path dir f)
(car recomp)) #:exists 'append
(for-each (lambda (f) (lambda () (display " "))))
(printf "re-making ~a\n" f) to-touch)
(managed-compile-zo (build-path dir f))) (for-each (lambda (f)
(cadr recomp)) (printf "re-making ~a\n" f)
(for-each (lambda (f) (managed-compile-zo (build-path dir f)))
(let ([ts (hash-ref timestamps f)] to-make)
[new-ts (for-each (lambda (f)
(file-or-directory-modify-seconds (let ([ts (hash-ref timestamps f)]
(build-path dir "compiled" (path-add-suffix f #".zo")) [new-ts
#f (file-or-directory-modify-seconds
(lambda () -inf.0))] (build-path dir "compiled" (path-add-suffix f #".zo"))
[updated? (lambda (a b) a)]) #f
(test (and (member f (caddr recomp)) #t) (lambda () -inf.0))]
updated? [updated? (lambda (a b) a)])
(new-ts . > . ts) (test (and (member f (caddr recomp)) #t)
f) updated?
(hash-set! timestamps f new-ts))) (new-ts . > . ts)
(map car files))) f)
(hash-set! timestamps f new-ts)))
(map car files))))
recomps))) recomps)))
(try '(("a.ss" "(module a scheme/base (require \"b.ss\" \"d.ss\" \"g.ss\"))" #t) (try '(("a.ss" "(module a scheme/base (require \"b.ss\" \"d.ss\" \"g.ss\"))" #t)
@ -86,6 +88,18 @@
[("i.ss") ("a.ss") ("a.ss" "g.ss" "i.ss")] [("i.ss") ("a.ss") ("a.ss" "g.ss" "i.ss")]
[("h.sch") ("a.ss") ("a.ss" "g.ss")])) [("h.sch") ("a.ss") ("a.ss" "g.ss")]))
;; test manager-skip-file-handler
(parameterize ([manager-skip-file-handler
(λ (x)
(let-values ([(base name dir) (split-path x)])
(cond
[(equal? (path->string name) "b.ss")
(file-or-directory-modify-seconds x)]
[else #f])))])
(try '(("a.ss" "(module a scheme/base (require \"b.ss\"))" #f)
("b.ss" "(module b scheme/base)" #f))
'([("b.ss") ("a.ss") ("a.ss")])))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

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

@ -189,6 +189,8 @@
(test/no-error '(listof any/c)) (test/no-error '(listof any/c))
(test/no-error '(listof (lambda (x) #t))) (test/no-error '(listof (lambda (x) #t)))
(test/no-error '(non-empty-listof any/c))
(test/no-error '(non-empty-listof (lambda (x) #t)))
(test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b")) (test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b"))
@ -3923,6 +3925,14 @@
'pos 'pos
'neg)) 'neg))
(test/spec-passed
'immutable7
'(let ([ct (contract (non-empty-listof (boolean? . -> . boolean?))
(list (λ (x) #t))
'pos
'neg)])
((car ct) #f)))
(test/neg-blame (test/neg-blame
'immutable8 'immutable8
'(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
@ -5511,6 +5521,14 @@ so that propagation occurs.
(test-name '(listof boolean?) (listof boolean?)) (test-name '(listof boolean?) (listof boolean?))
(test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?))) (test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?)))
(test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
(test-name '(non-empty-listof any/c) (non-empty-listof any/c))
(test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
(test-name '(non-empty-listof any/c) (non-empty-listof any/c))
(test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
(test-name '(non-empty-listof (-> boolean? boolean?)) (non-empty-listof (-> boolean? boolean?)))
(test-name '(vectorof boolean?) (vectorof boolean?)) (test-name '(vectorof boolean?) (vectorof boolean?))
(test-name '(vectorof any/c) (vectorof any/c)) (test-name '(vectorof any/c) (vectorof any/c))
@ -5784,6 +5802,10 @@ so that propagation occurs.
(ctest #t contract-first-order-passes? (listof integer?) (list 1)) (ctest #t contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (listof integer?) #f) (ctest #f contract-first-order-passes? (listof integer?) #f)
(ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1))
(ctest #f contract-first-order-passes? (non-empty-listof integer?) (list))
(ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) (ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1)))
(ctest #f contract-first-order-passes? (vector-immutableof integer?) 'x) (ctest #f contract-first-order-passes? (vector-immutableof integer?) 'x)
(ctest #f contract-first-order-passes? (vector-immutableof integer?) '()) (ctest #f contract-first-order-passes? (vector-immutableof integer?) '())