diff --git a/collects/algol60/tool.ss b/collects/algol60/tool.ss index b4c6095c0f..f465abe8bf 100644 --- a/collects/algol60/tool.ss +++ b/collects/algol60/tool.ss @@ -8,7 +8,8 @@ "compile.ss" compiler/embed string-constants - (prefix bd: "bd-tool.ss")) + errortrace/errortrace-lib + (prefix bd: "bd-tool.ss")) (provide tool@) @@ -92,8 +93,7 @@ (lambda () (error-display-handler (drscheme:debug:make-debug-error-display-handler (error-display-handler))) - (current-eval - (drscheme:debug:make-debug-eval-handler (current-eval))) + (current-compile (make-errortrace-compile-handler)) (with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))]) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 4c055625cd..6561a7fa8d 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -8,7 +8,8 @@ profile todo: |# -(require scheme/unit +(require errortrace/errortrace-key + scheme/unit scheme/contract errortrace/stacktrace scheme/class @@ -64,21 +65,15 @@ profile todo: ;; for debugging -- be sure to print to here, not the 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) (define (cms->srclocs cms) (map - (λ (x) (make-srcloc (list-ref x 0) - (list-ref x 1) + (λ (x) (make-srcloc (list-ref x 1) (list-ref x 2) (list-ref x 3) - (list-ref x 4))) - (continuation-mark-set->list cms cm-key))) + (list-ref x 4) + (list-ref x 5))) + (continuation-mark-set->list cms errortrace-key))) ;; error-delta : (instanceof style-delta%) (define error-delta (make-object style-delta% 'change-style 'italic)) @@ -493,7 +488,7 @@ profile todo: ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax ;; 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 (define (with-mark src-stx expr) (let ([source (cond @@ -518,10 +513,10 @@ profile todo: [column (or (syntax-column src-stx) 0)]) (if source (with-syntax ([expr expr] - [mark (list source line column position span)] - [cm-key cm-key]) + [mark (list 'dummy-thing source line column position span)] + [errortrace-key errortrace-key]) (syntax - (with-continuation-mark 'cm-key + (with-continuation-mark 'errortrace-key 'mark expr))) expr))) @@ -1265,8 +1260,8 @@ profile todo: (let ([profile-info (thread-cell-ref current-profile-info)]) (when profile-info (hash-set! profile-info - key - (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) + key + (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) (void)) ;; register-profile-start : sym -> (union #f number) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index fbb18b6e80..ac85aff20b 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -65,7 +65,6 @@ hide-backtrace-window show-backtrace-window open-and-highlight-in-file - get-cm-key small-planet-bitmap diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 299b9dec14..0c4ffd5d82 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1285,6 +1285,16 @@ (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 %) (class % (define/override (on-execute setting run-in-user-thread) @@ -1374,7 +1384,7 @@ (list -200 3) #t (string-constant pretty-big-scheme-one-line-summary) - assume-mixin)) + (λ (%) (assume-mixin (add-errortrace-key-mixin %))))) (add-language (make-simple '(lib "r5rs/lang.ss") "plt:r5rs" @@ -1383,7 +1393,7 @@ (list -200 -1000) #f (string-constant r5rs-one-line-summary) - (lambda (%) (r5rs-mixin (assume-mixin %))))) + (lambda (%) (r5rs-mixin (assume-mixin (add-errortrace-key-mixin %)))))) (add-language (make-simple 'mzscheme diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 30ed22e105..6fcdcf82ee 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -5,25 +5,33 @@ ;; (esp. useful when debugging the users's io) (require "drsig.ss" - string-constants - mzlib/pconvert - mzlib/pretty - mzlib/etc - mzlib/struct - mzlib/class - scheme/file - mzlib/list - compiler/embed - launcher - mred - framework - mrlib/syntax-browser - compiler/distribute - compiler/bundle-dist - "rep.ss") + string-constants + + ;; NOTE: this module instantiates stacktrace itself, so we have + ;; to be careful to not mix that instantiation with the one + ;; drscheme/private/debug.ss does. errortrace-lib's is for the + ;; compilation handling, DrScheme's is for profiling and test coverage + ;; (which do not do compilation) + (prefix-in el: errortrace/errortrace-lib) + + mzlib/pconvert + scheme/pretty + mzlib/struct + scheme/class + scheme/file + scheme/list + compiler/embed + launcher + mred + framework + mrlib/syntax-browser + compiler/distribute + compiler/bundle-dist + "rep.ss") (import [prefix drscheme:debug: drscheme:debug^] [prefix drscheme:tools: drscheme:tools^] + [prefix drscheme:rep: drscheme:rep^] [prefix drscheme:help-desk: drscheme:help-desk^]) (export drscheme:language^) @@ -203,8 +211,9 @@ (define (simple-module-based-language-config-panel _parent #: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% () (parent _parent) (alignment '(center center)))] @@ -238,7 +247,7 @@ (string-constant debugging-and-profiling) (string-constant test-coverage))) (parent dynamic-panel) - (callback (λ (x y) (annotations-callback x y))))] + (callback debugging-radio-box-callback))] [output-style (make-object radio-box% (string-constant output-style-label) (list (string-constant constructor-printing-style) @@ -263,7 +272,7 @@ (string-constant use-pretty-printer-label) output-panel void)]) - + (get-debugging-radio-box debugging) (dynamic-panel-extras dynamic-panel) (case-lambda @@ -412,16 +421,29 @@ (define (initialize-simple-module-based-language setting run-in-user-thread) (run-in-user-thread (λ () + (let ([annotations (simple-settings-annotations setting)]) - (when (memq annotations '(debug debug/profile test-coverage)) - (current-eval - (drscheme:debug:make-debug-eval-handler - (current-eval))) - (error-display-handler - (drscheme:debug:make-debug-error-display-handler - (error-display-handler)))) - (drscheme:debug:profiling-enabled (eq? annotations 'debug/profile)) - (drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage))) + (case annotations + [(debug) + (current-compile (el:make-errortrace-compile-handler)) + (error-display-handler + (drscheme:debug:make-debug-error-display-handler + (error-display-handler))) + (use-compiled-file-paths + (cons (build-path "compiled" "errortrace") + (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 (λ (value port) (let ([converted-value (simple-module-based-language-convert-value value setting)]) @@ -1122,7 +1144,7 @@ (define to-snips null) (define-struct to-snip (predicate? >value setup-thunk)) (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)))) (define (value->snip v) diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss index 0a02240234..421dac2367 100644 --- a/collects/drscheme/private/link.ss +++ b/collects/drscheme/private/link.ss @@ -57,4 +57,3 @@ (prefix drscheme:modes: drscheme:modes^) (prefix drscheme:tracing: drscheme:tracing^)) drscheme-unit@)) - diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index e62705f34f..89a0932e88 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -4,6 +4,7 @@ (require scheme/unit scheme/class scheme/list + scheme/path mred compiler/embed compiler/cm @@ -45,9 +46,10 @@ ;; command-line-args : (vectorof string) ;; auto-text : string (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-full-trace? #t) (define default-auto-text "#lang scheme\n") ;; module-mixin : (implements drscheme:language:language<%>) @@ -68,19 +70,27 @@ (define/override (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) (let ([super-defaults (super default-settings)]) - (apply make-module-language-settings - (append - (vector->list (drscheme:language:simple-settings->vector super-defaults)) - (list '(default) - #() - default-auto-text - default-compilation-on?))))) + (make-module-language-settings + #t 'write 'mixed-fraction-e #f #t 'none ;; simple settings defaults + + '(default) + #() + default-auto-text + default-compilation-on? + default-full-trace?))) ;; default-settings? : -> boolean (define/override (default-settings? settings) + (and (super default-settings? settings) + (equal? (module-language-settings-collection-paths settings) '(default)) (equal? (module-language-settings-command-line-args settings) @@ -90,7 +100,9 @@ ;; (equal? (module-language-settings-auto-text settings) ;; default-auto-text) (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) (let ([super-marshalled (super marshall-settings settings)]) @@ -112,7 +124,10 @@ (list-ref marshalled 3))] [compilation-on? (if (<= marshalled-len 4) 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) (andmap (λ (x) (or (string? x) (symbol? x))) collection-paths) @@ -128,7 +143,8 @@ (list collection-paths command-line-args auto-text - compilation-on?))))))))))) + compilation-on? + full-trace?))))))))))) (define/override (on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread) @@ -142,14 +158,62 @@ settings))]) (when (null? cpaths) (fprintf (current-error-port) - "Warning: your collection paths are empty!\n")) + "WARNING: your collection paths are empty!\n")) (current-library-collection-paths cpaths)) - (when (and (module-language-settings-compilation-on? settings) - (eq? (drscheme:language:simple-settings-annotations settings) 'none)) - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))) - ;[manager-trace-handler (λ (x) (display x) (newline))] - ))) + (compile-context-preservation-enabled (module-language-settings-full-trace? settings)) + + (when (module-language-settings-compilation-on? settings) + (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) (string-constant module-language-one-line-summary)) @@ -320,6 +384,7 @@ (semaphore-post s)))) (semaphore-wait s)) (custodian-shutdown-all (send rep get-user-custodian))) + (define (raise-hopeless-syntax-error . error-args) (with-handlers ([exn? raise-hopeless-exception]) (apply raise-syntax-error '|Module Language| @@ -341,20 +406,41 @@ [alignment '(center center)] [stretchable-height #f] [stretchable-width #f])) - (define compilation-on-radio-box #f) - (define annotations-radio-box #f) + (define compilation-on-check-box #f) + (define compilation-on? #t) + (define save-stacktrace-on-check-box #f) + (define debugging-radio-box #f) (define simple-case-lambda (drscheme:language:simple-module-based-language-config-panel new-parent #: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) - (set! annotations-radio-box (car (send dynamic-panel get-children))) - (set! compilation-on-radio-box (new check-box% - [label (string-constant automatically-compile?)] - [parent dynamic-panel]))))) + (set! compilation-on-check-box + (new check-box% + [label (string-constant automatically-compile)] + [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% [parent new-parent] [label (string-constant ml-cp-collection-paths)])) @@ -409,8 +495,7 @@ (send remove-button enable lb-selection) (send raise-button enable (and lb-selection (not (= lb-selection 0)))) (send lower-button enable - (and lb-selection (not (= lb-selection (- lb-tot 1))))) - (update-compilation-on-radio-box-visibility))) + (and lb-selection (not (= lb-selection (- lb-tot 1))))))) (define (add-callback) (let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path) @@ -499,12 +584,10 @@ (define (install-auto-text 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)) (update-buttons) (install-auto-text default-auto-text) + (update-compilation-checkbox debugging-radio-box) (case-lambda [() @@ -515,13 +598,19 @@ (list (get-collection-paths) (get-command-line-args) (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) (simple-case-lambda settings) (install-collection-paths (module-language-settings-collection-paths settings)) (install-command-line-args (module-language-settings-command-line-args 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)])) ;; transform-module : (union #f path) syntax diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index bb66e58f3e..fc001adc6f 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -117,6 +117,7 @@ TODO run-in-evaluation-thread after-many-evals + on-execute shutdown @@ -134,6 +135,8 @@ TODO reset-pretty-print-width + + get-prompt insert-prompt get-context)) @@ -662,7 +665,7 @@ TODO ;; highlight-errors : (listof srcloc) ;; (union #f (listof srcloc)) ;; -> (void) - (define/public (highlight-errors raw-locs raw-error-arrows) + (define/public (highlight-errors raw-locs [raw-error-arrows #f]) (let* ([cleanup-locs (λ (locs) (let ([ht (make-hasheq)]) @@ -859,7 +862,7 @@ TODO (field (user-language-settings #f) (user-custodian-parent #f) - (memory-killed-thread #f) + (memory-killed-cust-box #f) (user-custodian #f) (custodian-limit (and (custodian-memory-accounting-available?) (preferences:get 'drscheme:child-only-memory-limit))) @@ -912,7 +915,7 @@ TODO (no-user-evaluation-message (get-frame) user-exit-code - (not (thread-running? memory-killed-thread)))) + (not (custodian-box-value memory-killed-cust-box)))) (set! show-no-user-evaluation-message? #t))) (field (need-interaction-cleanup? #f)) @@ -1140,6 +1143,10 @@ TODO (cleanup-interaction) (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/private shutdown-user-custodian ; =Kernel=, =Handler= @@ -1199,9 +1206,7 @@ TODO (set! user-custodian-parent (make-custodian)) (set! user-custodian (parameterize ([current-custodian user-custodian-parent]) (make-custodian))) - (set! memory-killed-thread - (parameterize ([current-custodian user-custodian-parent]) - (thread (λ () (semaphore-wait (make-semaphore 0)))))) + (set! memory-killed-cust-box (make-custodian-box user-custodian-parent #t)) (when custodian-limit (custodian-limit-memory user-custodian-parent custodian-limit @@ -1294,7 +1299,11 @@ TODO (send (drscheme:language-configuration:language-settings-language user-language-settings) on-execute (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)) ;; 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") (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]) (queue-callback (λ () diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index d43fa5d635..091603df4d 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -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 (for-label errortrace/errortrace-key)) + (shutdown-splash) (define-values/invoke-unit/infer drscheme@) (close-splash) @@ -298,7 +300,7 @@ all of the names in the tools library, for use defining keybindings drscheme:debug:error-display-handler/stacktrace (->* (string? any/c) ((or/c false/c (listof srcloc?))) - any) + (or/c #f (listof srcloc?))) ((msg exn) ((stack #f))) @{Displays the error message represented by the string, adding 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 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.}) (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 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 @scheme[error-display-handler] 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 drscheme, this error handler inserts some debugging annotations, calls @scheme[oedh], and then highlights the - 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. + source location of the runtime error. - This function is designed to work in conjunction with - @scheme[drscheme:debug:make-debug-error-display-handler]. + It looks for both stack trace information in the continuation + 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 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.}) - - (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 drscheme:debug:add-prefs-panel (-> void?) @@ -386,15 +361,14 @@ all of the names in the tools library, for use defining keybindings (debug-info) @{This function opens a DrScheme to display @scheme[debug-info]. Only the src the position - and the span fields of the srcloc are considered. - - See also - @scheme[drscheme:debug:get-cm-key].}) + and the span fields of the srcloc are considered.}) (proc-doc/names drscheme:debug:show-backtrace-window (string? - (or/c exn? (listof srcloc?)) + (or/c exn? + (listof srcloc?) + (non-empty-listof (cons/c string? (listof srcloc?)))) . -> . void?) (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, @scheme[dis] is the debug information, extracted from the continuation mark in the exception record, using - @scheme[drscheme:debug:get-cm-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.}) + @scheme[errortrace-key].}) + ; ; diff --git a/collects/errortrace/errortrace-key.ss b/collects/errortrace/errortrace-key.ss index 569f732443..de2d5a5611 100644 --- a/collects/errortrace/errortrace-key.ss +++ b/collects/errortrace/errortrace-key.ss @@ -1,5 +1,30 @@ (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)) - (#%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)) diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index 1c3e056ec4..9fa0f402e4 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/collects/errortrace/errortrace-lib.ss @@ -1,62 +1,143 @@ +#lang scheme/base ;; Poor man's stack-trace-on-exceptions/profiler. ;; See manual for information. -(module errortrace-lib scheme/base - (require "stacktrace.ss" - "errortrace-key.ss" - mzlib/list - mzlib/unit - mzlib/runtime-path - (for-syntax scheme/base)) +(require "stacktrace.ss" + "errortrace-key.ss" + scheme/contract + scheme/unit + scheme/runtime-path + (for-syntax scheme/base)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Test coverage run-time support - (define test-coverage-enabled (make-parameter #f)) +(define oprintf + (let ([op (current-output-port)]) + (λ 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) - (hash-set! test-coverage-info key (mcons expr 0))) +(define test-coverage-state '()) +(define (initialize-test-coverage) (set! test-coverage-state '())) - (define (test-covered key) - (let ([v (hash-ref test-coverage-info key)]) - (set-mcdr! v (add1 (mcdr v))))) +(define (initialize-test-coverage-point expr) + (when (and (syntax-position expr) + (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) - (hash-map test-coverage-info (lambda (k v) (cons (mcar v) (mcdr v))))) +;; get-coverage : -> (values (listof (list src number number)) (listof (list src number number))) +;; 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) - (apply annotate-file name (get-coverage-counts) - (if (null? more) '(#f) more))) +(define (annotate-covered-file filename-path [display-string #f]) + (annotate-file filename-path + (map (λ (c) (cons (car c) (if (cdr c) 1 0))) (get-coverage)) + display-string)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Profiling run-time support - (define profile-thread #f) - (define profile-key (gensym)) +;; The next procedure is called by `annotate' and `annotate-top' to wrap +;; expressions with test suite coverage information. Returning the +;; first argument means no tests coverage information is collected. - (define profiling-enabled (make-parameter #f)) - (define profiling-record-enabled (make-parameter #t)) - (define profile-paths-enabled (make-parameter #f)) +;; test-coverage-point : syntax syntax -> (values syntax info) +;; sets a test coverage point for a single expression +(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 - (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)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Profiling run-time support - (define (initialize-profile-point key name expr) - (hash-set! profile-info key - (vector (box #f) 0 0 (and name (syntax-e name)) expr null))) +(define profile-thread-cell (make-thread-cell #f)) +(define profile-key (gensym)) - (define (register-profile-start key) - (and (profiling-record-enabled) - (let ([v (hash-ref profile-info key)]) +(define thread->profile-table (make-weak-hasheq)) + +(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)]) (vector-set! v 1 (add1 (vector-ref v 1))) (when (profile-paths-enabled) @@ -72,111 +153,119 @@ #f (begin (set-box! b #t) - (current-process-milliseconds))))))) + (current-process-milliseconds)))))))) - (define (register-profile-done key start) - (when start - (let ([v (hash-ref profile-info key)]) - (let ([b (vector-ref v 0)]) - (set-box! b #f) - (vector-set! v 2 - (+ (- (current-process-milliseconds) start) - (vector-ref v 2))))))) +(define (register-profile-done key start) + (when start + (when (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)]) + (set-box! b #f) + (vector-set! v 2 + (+ (- (current-process-milliseconds) start) + (vector-ref v 2))))))))) - (define (get-profile-results) - (hash-map profile-info - (lambda (key val) - (let ([count (vector-ref val 1)] - [time (vector-ref val 2)] - [name (vector-ref val 3)] - [expr (vector-ref val 4)] - [cmss (vector-ref val 5)]) - (list count time name expr - (if (hash? cmss) - (hash-map cmss (lambda (ks v) - (cons v - (map (lambda (k) - (let ([v (cdr (hash-ref profile-info k))]) - (list (vector-ref v 2) - (vector-ref v 3)))) - ks)))) - null)))))) +(define (get-profile-results [t (current-thread)]) + (cond + [(hash-ref thread->profile-table t #f) + => + (λ (profile-info) + (hash-map profile-info + (lambda (key val) + (let ([count (vector-ref val 1)] + [time (vector-ref val 2)] + [name (vector-ref val 3)] + [expr (vector-ref val 4)] + [cmss (vector-ref val 5)]) + (list count time name expr + (if (hash? cmss) + (hash-map cmss (lambda (ks v) + (cons v + (map (lambda (k) + (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 - '(lib "errortrace-key-syntax.ss" "errortrace")) +(define-runtime-path key-syntax + '(lib "errortrace-key-syntax.ss" "errortrace")) - (define dynamic-errortrace-key - (dynamic-require key-syntax 'errortrace-key-syntax)) +(define dynamic-errortrace-key + (dynamic-require key-syntax 'errortrace-key-syntax)) - ;; with-mark : stx stx -> stx - (define (with-mark mark expr) - (with-syntax ([expr expr] - [loc (make-st-mark mark)] - [et-key dynamic-errortrace-key]) - (execute-point - mark - (syntax - (with-continuation-mark - et-key - loc - expr))))) +;; with-mark : stx stx -> stx +(define (with-mark mark expr) + (let ([loc (make-st-mark mark)]) + (if loc + (with-syntax ([expr expr] + [loc loc] + [et-key dynamic-errortrace-key]) + (execute-point + mark + (syntax + (with-continuation-mark et-key + 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) - (let ([i (hash-ref execute-info key)]) - (set-mcdr! i (add1 (mcdr i))))) +(define (register-executed-once key) + (let ([i (hash-ref execute-info key)]) + (set-mcdr! i (add1 (mcdr i))))) - (define (execute-point mark expr) - (if (execute-counts-enabled) - (let ([key (gensym)]) - (hash-set! execute-info key (mcons mark 0)) - (with-syntax ([key (datum->syntax #f key (quote-syntax here))] - [expr expr] - [register-executed-once register-executed-once]);<- 3D! - (syntax - (begin - (register-executed-once 'key) - expr)))) - expr)) +(define (execute-point mark expr) + (if (execute-counts-enabled) + (let ([key (gensym)]) + (hash-set! execute-info key (mcons mark 0)) + (with-syntax ([key (datum->syntax #f key (quote-syntax here))] + [expr expr] + [register-executed-once register-executed-once]);<- 3D! + (syntax + (begin + (register-executed-once 'key) + expr)))) + expr)) - (define (get-execute-counts) - (hash-map execute-info (lambda (k v) (cons (mcar v) - (mcdr v))))) +(define (get-execute-counts) + (hash-map execute-info (lambda (k v) (cons (mcar v) + (mcdr v))))) - (define (annotate-executed-file name . more) - (apply annotate-file name (get-execute-counts) - (if (null? more) '("^.,") more))) +(define (annotate-executed-file name [display-string "^.,"]) + (annotate-file name (get-execute-counts) display-string)) - ;; shared functionality for annotate-executed-file and annotate-covered-file - (define (annotate-file name counts display-string) - (let ([name (path->complete-path name (current-directory))]) - (let* (;; Filter relevant syntaxes - [here (filter (lambda (s) - (and (equal? name (syntax-source (car s))) - (syntax-position (car s)))) - counts)] - ;; Sort them: earlier first, wider if in same position - [sorted (sort here - (lambda (a b) - (let ([ap (syntax-position (car a))] - [bp (syntax-position (car b))]) - (or (< ap bp) - (and (= ap bp) - (> (syntax-span (car a)) - (syntax-span (car b))))))))] - ;; Merge entries with the same position+span - [sorted (if (null? sorted) +;; shared functionality for annotate-executed-file and annotate-covered-file +(define (annotate-file name counts display-string) + (let ([name (path->complete-path name (current-directory))]) + (let* (;; Filter relevant syntaxes + [here (filter (lambda (s) + (and (equal? name (syntax-source (car s))) + (syntax-position (car s)))) + counts)] + ;; Sort them: earlier first, wider if in same position + [sorted (sort here + (lambda (a b) + (let ([ap (syntax-position (car a))] + [bp (syntax-position (car b))]) + (or (< ap bp) + (and (= ap bp) + (> (syntax-span (car a)) + (syntax-span (car b))))))))] + ;; Merge entries with the same position+span + [sorted (if (null? sorted) sorted ; guarantee one element for the next case (let loop ([xs (reverse sorted)] [r '()]) (cond [(null? (cdr xs)) (append xs r)] @@ -191,206 +280,220 @@ (cddr xs)) r)] [else (loop (cdr xs) (cons (car xs) r))])))] - [pic (make-string (file-size name) #\space)] - [display-string - (case display-string - [(#t) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"] - [(#f) "#-"] - [else display-string])] - [many-char (string-ref display-string - (sub1 (string-length display-string)))]) - ;; Fill out picture - (for-each (lambda (s) - (let ([pos (sub1 (syntax-position (car s)))] - [span (syntax-span (car s))] - [key (let ([k (cdr s)]) - (if (< k (string-length display-string)) + [pic (make-string (file-size name) #\space)] + [display-string + (case display-string + [(#t) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"] + [(#f) "#."] + [else display-string])] + [many-char (string-ref display-string + (sub1 (string-length display-string)))]) + ;; Fill out picture + (for-each (lambda (s) + (let ([pos (sub1 (syntax-position (car s)))] + [span (syntax-span (car s))] + [key (let ([k (cdr s)]) + (if (< k (string-length display-string)) (string-ref display-string k) many-char))]) - (let loop ([p pos]) - (unless (= p (+ pos span)) - (string-set! pic p key) - (loop (add1 p)))))) - sorted) - ;; Write annotated file - (with-input-from-file name - (lambda () - (let loop () - (let ([pos (file-position (current-input-port))] - [line (read-line (current-input-port) 'any)]) - (unless (eof-object? line) - (printf "~a\n" line) - (let ([w (string-length line)]) - ;; Blank leading spaces in pic (copy them: works for tabs) - (let loop ([i 0]) - (when (and (< i w) - (char-whitespace? (string-ref line i))) - (string-set! pic (+ pos i) (string-ref line i)) - (loop (add1 i)))) - (printf "~a\n" (substring pic pos (+ pos w)))) - (loop))))))))) + (let loop ([p pos]) + (unless (= p (+ pos span)) + (string-set! pic p key) + (loop (add1 p)))))) + sorted) + ;; Write annotated file + (with-input-from-file name + (lambda () + (let loop () + (let ([pos (file-position (current-input-port))] + [line (read-line (current-input-port) 'any)]) + (unless (eof-object? line) + (printf "~a\n" line) + (let ([w (string-length line)]) + ;; Blank leading spaces in pic (copy them: works for tabs) + (let loop ([i 0]) + (when (and (< i w) + (char-whitespace? (string-ref line i))) + (string-set! pic (+ pos i) (string-ref line i)) + (loop (add1 i)))) + (printf "~a\n" (substring pic pos (+ pos w)))) + (loop))))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Eval handler, exception handler +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Eval handler, exception handler - (define instrumenting-enabled - (make-parameter #t)) - (define error-context-display-depth - (make-parameter 10000 (lambda (x) (and (integer? x) x)))) +(define instrumenting-enabled + (make-parameter #t)) +(define error-context-display-depth + (make-parameter 10000 (lambda (x) (and (integer? x) x)))) - ;; port exn -> void - ;; effect: prints out the context surrounding the exception - (define (print-error-trace p x) - (let loop ([n (error-context-display-depth)] - [l (map st-mark-source - (continuation-mark-set->list (exn-continuation-marks x) - errortrace-key))]) - (cond - [(or (zero? n) (null? l)) (void)] - [(pair? l) - (let* ([stx (car l)] - [source (syntax-source stx)] - [file (cond - [(string? source) source] - [(path? source) - (path->string source)] - [(not source) - #f] - [else - (format "~a" source)])] - [line (syntax-line stx)] - [col (syntax-column stx)] - [pos (syntax-position stx)]) - (fprintf p "~a~a: ~e~n" - (or file "[unknown source]") - (cond - [line (format ":~a:~a" line col)] - [pos (format "::~a" pos)] - [else ""]) - (syntax->datum stx)) - (loop (- n 1) (cdr l)))]))) +;; port exn -> void +;; effect: prints out the context surrounding the exception +(define (print-error-trace p x) + (let loop ([n (error-context-display-depth)] + [l (map st-mark-source + (continuation-mark-set->list (exn-continuation-marks x) + errortrace-key))]) + (cond + [(or (zero? n) (null? l)) (void)] + [(pair? l) + (let* ([stx (car l)] + [source (syntax-source stx)] + [file (cond + [(string? source) source] + [(path? source) + (path->string source)] + [(not source) + #f] + [else + (format "~a" source)])] + [line (syntax-line stx)] + [col (syntax-column stx)] + [pos (syntax-position stx)]) + (fprintf p "~a~a: ~e~n" + (or file "[unknown source]") + (cond + [line (format ":~a:~a" line col)] + [pos (format "::~a" pos)] + [else ""]) + (syntax->datum stx)) + (loop (- n 1) (cdr l)))]))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Profile printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Profile printer - (define (output-profile-results paths? sort-time?) - (profiling-enabled #f) - (error-print-width 50) - (printf "Sorting profile data...~n") - (let* ([sel (if sort-time? cadr car)] - [counts (sort (filter (lambda (c) (positive? (car c))) - (get-profile-results)) - (lambda (a b) (< (sel a) (sel b))))] - [total 0]) - (for-each - (lambda (c) - (set! total (+ total (sel c))) - (printf "=========================================================~n") - (printf "time = ~a : no. = ~a : ~e in ~s~n" - (cadr c) (car c) (caddr c) (cadddr c)) - ;; print call paths - (when paths? - (for-each - (lambda (cms) - (unless (null? (cdr cms)) - (printf " ~e VIA ~e" (car cms) (caadr cms)) - (for-each - (lambda (cm) - (printf " <- ~e" (car cm))) - (cddr cms)) - (printf "~n"))) - (sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b))))))) - counts) - (printf "Total samples: ~a~n" total))) +(define (output-profile-results paths? sort-time?) + (profiling-enabled #f) + (error-print-width 50) + (printf "Sorting profile data...~n") + (let* ([sel (if sort-time? cadr car)] + [counts (sort (filter (lambda (c) (positive? (car c))) + (get-profile-results)) + (lambda (a b) (< (sel a) (sel b))))] + [total 0]) + (for-each + (lambda (c) + (set! total (+ total (sel c))) + (printf "=========================================================~n") + (printf "time = ~a : no. = ~a : ~e in ~s~n" + (cadr c) (car c) (caddr c) (cadddr c)) + ;; print call paths + (when paths? + (for-each + (lambda (cms) + (unless (null? (cdr cms)) + (printf " ~e VIA ~e" (car cms) (caadr cms)) + (for-each + (lambda (cm) + (printf " <- ~e" (car cm))) + (cddr cms)) + (printf "~n"))) + (sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b))))))) + counts) + (printf "Total samples: ~a~n" total))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define orig-inspector (current-code-inspector)) +(define orig-inspector (current-code-inspector)) - (define errortrace-annotate - (lambda (top-e) - (define (normal e) - (let ([ex (expand-syntax e)]) - (annotate-top ex (namespace-base-phase)))) - (syntax-case top-e () - [(mod name . reste) - (and (identifier? #'mod) - (free-identifier=? #'mod (namespace-module-identifier) - (namespace-base-phase))) - (if (eq? (syntax-e #'name) 'errortrace-key) - top-e - (let ([top-e (expand-syntax top-e)]) - (syntax-case top-e (#%plain-module-begin) - [(mod name init-import (#%plain-module-begin body ...)) - (normal - #`(#,(namespace-module-identifier) name init-import - #,(syntax-recertify - #`(#%plain-module-begin - #,((make-syntax-introducer) - #'(#%require errortrace/errortrace-key)) - #,((make-syntax-introducer) - #'(#%require (for-syntax errortrace/errortrace-key))) - body ...) - (list-ref (syntax->list top-e) 3) - orig-inspector - #f)))])))] - [_else - (normal top-e)]))) +(define errortrace-annotate + (lambda (top-e) + (define (normal e) + (annotate-top (expand-syntax e) + (namespace-base-phase))) + (syntax-case top-e () + [(mod name . reste) + (and (identifier? #'mod) + (free-identifier=? #'mod + (namespace-module-identifier) + (namespace-base-phase))) + (if (eq? (syntax-e #'name) 'errortrace-key) + top-e + (let ([top-e (expand-syntax top-e)]) + (initialize-test-coverage) + (syntax-case top-e (#%plain-module-begin) + [(mod name init-import (#%plain-module-begin body ...)) + (add-test-coverage-init-code + (normal + #`(#,(namespace-module-identifier) name init-import + #,(syntax-recertify + #`(#%plain-module-begin + #,((make-syntax-introducer) + (syntax/loc (datum->syntax #f 'x #f) + (#%require errortrace/errortrace-key))) + #,((make-syntax-introducer) + (syntax/loc (datum->syntax #f 'x #f) + (#%require (for-syntax errortrace/errortrace-key)))) + body ...) + (list-ref (syntax->list top-e) 3) + orig-inspector + #f))))])))] + [_else + (normal top-e)]))) - (define errortrace-compile-handler - (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-namespace-anchor orig-namespace) - (define errortrace-error-display-handler - (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))))) +(define (make-errortrace-compile-handler) + (let ([orig (current-compile)] + [reg (namespace-module-registry (current-namespace))]) + (namespace-attach-module (namespace-anchor->namespace orig-namespace) 'scheme/base) + (namespace-attach-module (namespace-anchor->namespace orig-namespace) 'errortrace/errortrace-key) + (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?)))) - (provide errortrace-compile-handler - errortrace-error-display-handler - errortrace-annotate +(define errortrace-compile-handler (make-errortrace-compile-handler)) - print-error-trace - error-context-display-depth +(define errortrace-error-display-handler + (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 - - profiling-enabled - profiling-record-enabled - profile-paths-enabled - get-profile-results - output-profile-results - clear-profile-results - - execute-counts-enabled - get-execute-counts - annotate-executed-file - - ;; use names that are consistent with the above - (rename-out [test-coverage-enabled coverage-counts-enabled]) - get-coverage-counts - annotate-covered-file - - annotate-top)) +(provide/contract + [annotate-covered-file (->* (path-string?) ((or/c string? #t #f)) void?)] + [annotate-executed-file (->* (path-string?) ((or/c string? #t #f)) void?)]) +(provide make-errortrace-compile-handler + errortrace-compile-handler + errortrace-error-display-handler + errortrace-annotate + + print-error-trace + error-context-display-depth + + instrumenting-enabled + + profiling-enabled + profiling-record-enabled + profile-paths-enabled + get-profile-results + output-profile-results + 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) diff --git a/collects/errortrace/errortrace.ss b/collects/errortrace/errortrace.ss index 818d7f1902..b6e353910b 100644 --- a/collects/errortrace/errortrace.ss +++ b/collects/errortrace/errortrace.ss @@ -22,7 +22,8 @@ annotate-executed-file coverage-counts-enabled - get-coverage-counts + get-coverage + test-coverage-info annotate-covered-file) (current-compile errortrace-compile-handler) diff --git a/collects/errortrace/scribblings/errortrace.scrbl b/collects/errortrace/scribblings/errortrace.scrbl index 6520b7942d..92fbe8514d 100644 --- a/collects/errortrace/scribblings/errortrace.scrbl +++ b/collects/errortrace/scribblings/errortrace.scrbl @@ -118,7 +118,12 @@ by a factor of 2 or 3.} @defboolparam[profiling-enabled on?]{ 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?]{ @@ -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 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?]{ @@ -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), 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 -so far: +so far (for the thread @scheme[thd]): @itemize[ @item{the number of times a procedure was called.} @@ -182,7 +188,8 @@ all procedures instrumented for profiling information.} @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 @scheme[instrumenting-enabled] to @scheme[#f] also disables both.} -@deftogether[( - @defproc[(get-coverage-counts) list?] - @defproc[(get-execute-counts) list?])]{ - +@defproc[(get-coverage) (listof (cons/c syntax? boolean?))]{ + +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 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 is the number of times that the -expression has been evaluated. These elements are destructively -modified, so to take a snapshot you will need to copy them.} +expression has been evaluated. +This list is snapshot of the current state of the computation.} @deftogether[( @defproc[(annotate-covered-file [filename-path path-string?] - [display-string (or/c string? false/c) #f]) + [display-string (or/c string? #f) #f]) void?] @defproc[(annotate-executed-file [filename-path path-string?] - [display-string (or/c string? false/c) "^.,"]) + [display-string (or/c string? #t #f) "^.,"]) void?])]{ 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 character is used for expressions that were visited 0 times, the second character for 1 time, ..., and the last character for -expressions that were visited more times. It can also be @scheme[#t] -for a maximal display (@scheme["012...9ABC...Z"]), or @scheme[#f] for -a minimal display (@scheme["#-"]).} +expressions that were visited more times. It can also be +@scheme[#f] for a minimal display, @scheme["#."], or, in +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 when the @schememodname[errortrace/errortrace-lib] module was executed, but first instruments the code for Errortrace information. -The code is instrumented only if @scheme[(namespace-module-registry -(current-namespace))] is the same as when the +The code is instrumented only if +@schemeblock[(namespace-module-registry (current-namespace))] +is the same as when the @schememodname[errortrace/errortrace-lib] module was executed. This procedure is suitable for use as a compilation handler via @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?]{ Displays information about the exception; this procedure is suitable @@ -344,14 +378,17 @@ expression, typically @scheme[(namespace-base-phase)] for a top-level expression.} @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-bindings (st-mark st-mark?)) list?])]{ The @schemeout[st-mark-source] and @schemeout[st-mark-bindings] -functions extract information from a particular kind of value. The -value must be created by @schemeout[make-st-mark]. The -@schemeout[st-mark-source] extracts the value originally provided to +functions extract information from a particular kind of value. +The value must be created by @schemeout[make-st-mark] +(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 binding information (if available) as a list of two element (syntax? 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].} } + +@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. +} diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index d2c6856f02..3d5e69db48 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -1,355 +1,355 @@ -(module stacktrace scheme/base - (require mzlib/unit - syntax/kerncase - syntax/stx - (for-syntax scheme/base)) ; for matching +#lang scheme/base +(require scheme/unit + syntax/kerncase + syntax/stx + (for-syntax scheme/base)) ; for matching - (provide stacktrace@ stacktrace^ stacktrace-imports^) +(provide stacktrace@ stacktrace^ stacktrace-imports^) +(define-signature stacktrace-imports^ + (with-mark + + test-coverage-enabled + test-covered + initialize-test-coverage-point + + profile-key + profiling-enabled + initialize-profile-point + register-profile-start + register-profile-done)) - (define-signature stacktrace-imports^ - (with-mark +(define-signature stacktrace^ + (annotate-top + annotate + make-st-mark + st-mark-source + st-mark-bindings)) - test-coverage-enabled - test-covered - initialize-test-coverage-point - - profile-key - profiling-enabled - initialize-profile-point - register-profile-start - register-profile-done)) - - (define-signature stacktrace^ - (annotate-top - annotate - make-st-mark - st-mark-source - st-mark-bindings)) - - (define-unit stacktrace@ - (import stacktrace-imports^) - (export stacktrace^) - - (define (short-version v depth) - (cond - [(identifier? v) (syntax-e v)] - [(null? v) null] - [(vector? v) (if (zero? depth) - #(....) - (list->vector - (short-version (vector->list v) (sub1 depth))))] - [(box? v) (if (zero? depth) - #&(....) - (box (short-version (unbox v) (sub1 depth))))] - [(pair? v) - (cond - [(zero? depth) '(....)] - [(memq (syntax-e (car v)) '(#%app #%top)) - (short-version (cdr v) depth)] - [else - (cons (short-version (car v) (sub1 depth)) - (short-version (cdr v) (sub1 depth)))])] - [(syntax? v) (short-version (syntax-e v) depth)] - [else v])) - - (define (make-st-mark stx) - (unless (syntax? stx) - (error 'make-st-mark - "expected syntax object as argument, got ~e" stx)) - #`(quote (#,(short-version stx 10) - #,(let ([s (let ([source (syntax-source stx)]) - (cond - [(string? source) source] - [(path? source) (path->string source)] - [(not source) #f] - [else (format "~a" source)]))]) - (and s (string->symbol s))) - #,(syntax-line stx) - #,(syntax-column stx) - #,(syntax-position stx) - #,(syntax-span stx)))) - (define (st-mark-source src) - (datum->syntax #f (car src) (cdr src) #f)) - - (define (st-mark-bindings x) null) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Test case coverage instrumenter - - ;; The next procedure is called by `annotate' and `annotate-top' to wrap - ;; expressions with test suite coverage information. Returning the - ;; first argument means no tests coverage information is collected. - - ;; test-coverage-point : syntax syntax phase -> syntax - ;; sets a test coverage point for a single expression - (define (test-coverage-point body expr phase) - (if (and (test-coverage-enabled) - (zero? phase) - (syntax-position expr)) - (let* ([key (gensym 'test-coverage-point)]) - (initialize-test-coverage-point key expr) - (let ([thunk (test-covered key)]) - (cond - [(procedure? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin (#%plain-app thunk) body))] - [(syntax? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin thunk body))] - [else - body]))) - body)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Profiling instrumenter - - ;; profile-point : - ;; (syntax[list of exprs] symbol-or-#f syntax boolean - ;; -> syntax[list of exprs]) - - ;; This procedure is called by `annotate' and `annotate-top' to wrap - ;; expressions with profile collecting information. Returning the - ;; first argument means no profiling information is collected. - - ;; The second argument is the point's inferred name, if any, the third - ;; argument is the source expression, and the fourth argument is #t for - ;; a transformer expression and #f for a normal expression. - - (define (profile-point bodies name expr phase) - (let ([key (gensym 'profile-point)]) - (initialize-profile-point key name expr) - (with-syntax ([key (datum->syntax #f key (quote-syntax here))] - [start (datum->syntax - #f (gensym) (quote-syntax here))] - [profile-key (datum->syntax - #f profile-key (quote-syntax here))] - [register-profile-start register-profile-start] - [register-profile-done register-profile-done]) - (with-syntax ([rest - (insert-at-tail* - (syntax (#%plain-app register-profile-done 'key start)) - bodies - phase)]) - (syntax - (let ([start (#%plain-app register-profile-start 'key)]) - (with-continuation-mark 'profile-key 'key - (begin . rest)))))))) - - (define (insert-at-tail* e exprs phase) - (let ([new - (rebuild exprs - (let loop ([exprs exprs]) - (if (stx-null? (stx-cdr exprs)) - (list (cons (stx-car exprs) - (insert-at-tail - e (stx-car exprs) phase))) - (loop (stx-cdr exprs)))))]) - (if (syntax? exprs) - (certify exprs new) - new))) - - (define (insert-at-tail se sexpr phase) - (with-syntax ([expr sexpr] - [e se]) - (kernel-syntax-case/phase sexpr phase - ;; negligible time to eval - [id - (identifier? sexpr) - (syntax (begin e expr))] - [(quote _) (syntax (begin e expr))] - [(quote-syntax _) (syntax (begin e expr))] - [(#%top . d) (syntax (begin e expr))] - [(#%variable-reference . d) (syntax (begin e expr))] - - ;; No tail effect, and we want to account for the time - [(#%plain-lambda . _) (syntax (begin0 expr e))] - [(case-lambda . _) (syntax (begin0 expr e))] - [(set! . _) (syntax (begin0 expr e))] - - [(let-values bindings . body) - (insert-at-tail* se sexpr phase)] - [(letrec-values bindings . body) - (insert-at-tail* se sexpr phase)] - - [(begin . _) - (insert-at-tail* se sexpr phase)] - [(with-continuation-mark . _) - (insert-at-tail* se sexpr phase)] - - [(begin0 body ...) - (certify sexpr (syntax (begin0 body ... e)))] - - [(if test then else) - ;; WARNING: se inserted twice! - (certify - sexpr - (rebuild - sexpr - (list - (cons #'then (insert-at-tail se (syntax then) phase)) - (cons #'else (insert-at-tail se (syntax else) phase)))))] - - [(#%plain-app . rest) - (if (stx-null? (syntax rest)) - ;; null constant - (syntax (begin e expr)) - ;; application; exploit guaranteed left-to-right evaluation - (insert-at-tail* se sexpr phase))] - - [_else - (error 'errortrace - "unrecognized (non-top-level) expression form: ~e" - (syntax->datum sexpr))]))) - - (define (profile-annotate-lambda name expr clause bodys-stx phase) - (let* ([bodys (stx->list bodys-stx)] - [bodyl (map (lambda (e) (annotate e phase)) - bodys)]) - (rebuild clause - (if (profiling-enabled) - (let ([prof-expr - (profile-point bodyl name expr phase)]) - ;; Tell rebuild to replace first expressions with - ;; (void), and replace the last expression with - ;; prof-expr: - (let loop ([bodys bodys]) - (if (null? (cdr bodys)) - (list (cons (car bodys) prof-expr)) - (cons (cons (car bodys) #'(#%plain-app void)) - (loop (cdr bodys)))))) - ;; Map 1-to-1: - (map cons bodys bodyl))))) - - (define (keep-lambda-properties orig new) - (let ([p (syntax-property orig 'method-arity-error)] - [p2 (syntax-property orig 'inferred-name)]) - (let ([new (if p - (syntax-property new 'method-arity-error p) - new)]) - (if p2 - (syntax-property new 'inferred-name p2) - new)))) - - (define (annotate-let expr phase varss-stx rhss-stx bodys-stx) - (let ([varss (syntax->list varss-stx)] - [rhss (syntax->list rhss-stx)] - [bodys (syntax->list bodys-stx)]) - (let ([rhsl (map - (lambda (vars rhs) - (annotate-named - (syntax-case vars () - [(id) - (syntax id)] - [_else #f]) - rhs - phase)) - varss - rhss)] - [bodyl (map - (lambda (body) - (annotate body phase)) - bodys)]) - (rebuild expr (append (map cons bodys bodyl) - (map cons rhss rhsl)))))) - - (define (annotate-seq expr bodys-stx annotate phase) - (let* ([bodys (syntax->list bodys-stx)] - [bodyl (map (lambda (b) - (annotate b phase)) - bodys)]) - (rebuild expr (map cons bodys bodyl)))) - - (define orig-inspector (current-code-inspector)) - - (define (certify orig new) - (syntax-recertify new orig orig-inspector #f)) - - (define (rebuild expr replacements) - (let loop ([expr expr] - [same-k (lambda () expr)] - [diff-k (lambda (x) x)]) - (let ([a (assq expr replacements)]) - (if a - (diff-k (cdr a)) - (cond - [(pair? expr) (loop (car expr) - (lambda () - (loop (cdr expr) - same-k - (lambda (y) - (diff-k (cons (car expr) y))))) - (lambda (x) - (loop (cdr expr) - (lambda () - (diff-k (cons x (cdr expr)))) - (lambda (y) - (diff-k (cons x y))))))] - [(vector? expr) - (loop (vector->list expr) - same-k - (lambda (x) (diff-k (list->vector x))))] - [(box? expr) (loop (unbox expr) - same-k - (lambda (x) - (diff-k (box x))))] - [(syntax? expr) (if (identifier? expr) - (same-k) - (loop (syntax-e expr) - same-k - (lambda (x) - (diff-k - (datum->syntax - expr - x - expr)))))] - [else (same-k)]))))) - - (define (append-rebuild expr end) - (cond - [(syntax? expr) - (datum->syntax expr - (append-rebuild (syntax-e expr) end) - expr)] - [(pair? expr) - (cons (car expr) (append-rebuild (cdr expr) end))] - [(null? expr) - (list end)] +(define-unit stacktrace@ + (import stacktrace-imports^) + (export stacktrace^) + + (define (short-version v depth) + (cond + [(identifier? v) (syntax-e v)] + [(null? v) null] + [(vector? v) (if (zero? depth) + #(....) + (list->vector + (short-version (vector->list v) (sub1 depth))))] + [(box? v) (if (zero? depth) + #&(....) + (box (short-version (unbox v) (sub1 depth))))] + [(pair? v) + (cond + [(zero? depth) '(....)] + [(memq (syntax-e (car v)) '(#%app #%top)) + (short-version (cdr v) depth)] [else - (error 'append-rebuild "shouldn't get here")])) + (cons (short-version (car v) (sub1 depth)) + (short-version (cdr v) (sub1 depth)))])] + [(syntax? v) (short-version (syntax-e v) depth)] + [else v])) + + (define (make-st-mark stx) + (unless (syntax? stx) + (error 'make-st-mark + "expected syntax object as argument, got ~e" stx)) + (cond + [(syntax-source stx) + #`(quote (#,(short-version stx 10) + #,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx)))] + [else #f])) + (define (st-mark-source src) + (and src + (datum->syntax #f (car src) (cdr src) #f))) + + (define (st-mark-bindings x) null) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Test case coverage instrumenter + + ;; The next procedure is called by `annotate' and `annotate-top' to wrap + ;; expressions with test suite coverage information. Returning the + ;; first argument means no tests coverage information is collected. + + ;; test-coverage-point : syntax syntax phase -> syntax + ;; sets a test coverage point for a single expression + (define (test-coverage-point body expr phase) + (if (and (test-coverage-enabled) + (zero? phase) + (syntax-position expr)) + (let* ([key (gensym 'test-coverage-point)]) + (initialize-test-coverage-point key expr) + (let ([thunk (test-covered key)]) + (cond + [(procedure? thunk) + (with-syntax ([body body] + [thunk thunk]) + #'(begin (#%plain-app thunk) body))] + [(syntax? thunk) + (with-syntax ([body body] + [thunk thunk]) + #'(begin thunk body))] + [else + body]))) + body)) - (define (one-name names-stx) - (let ([l (syntax->list names-stx)]) - (and (pair? l) - (null? (cdr l)) - (car l)))) - (define (make-annotate top? name) - (lambda (expr phase) - (test-coverage-point - (kernel-syntax-case/phase expr phase - [_ - (identifier? expr) - (let ([b (identifier-binding expr phase)]) - (cond - [(eq? 'lexical b) - ;; lexical variable - no error possile - expr] - [(and (pair? b) (eq? '#%kernel (car b))) - ;; built-in - no error possible - expr] - [else - ;; might be undefined/uninitialized - (with-mark expr expr)]))] - - [(#%top . id) - ;; might be undefined/uninitialized - (with-mark expr expr)] - [(#%variable-reference . _) - ;; no error possible - expr] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Profiling instrumenter + + ;; profile-point : + ;; (syntax[list of exprs] symbol-or-#f syntax boolean + ;; -> syntax[list of exprs]) + + ;; This procedure is called by `annotate' and `annotate-top' to wrap + ;; expressions with profile collecting information. Returning the + ;; first argument means no profiling information is collected. + + ;; The second argument is the point's inferred name, if any, the third + ;; argument is the source expression, and the fourth argument is #t for + ;; a transformer expression and #f for a normal expression. + + (define (profile-point bodies name expr phase) + (let ([key (gensym 'profile-point)]) + (initialize-profile-point key name expr) + (with-syntax ([key (datum->syntax #f key (quote-syntax here))] + [start (datum->syntax + #f (gensym) (quote-syntax here))] + [profile-key (datum->syntax + #f profile-key (quote-syntax here))] + [register-profile-start register-profile-start] + [register-profile-done register-profile-done]) + (with-syntax ([rest + (insert-at-tail* + (syntax (#%plain-app register-profile-done 'key start)) + bodies + phase)]) + (syntax + (let ([start (#%plain-app register-profile-start 'key)]) + (with-continuation-mark 'profile-key 'key + (begin . rest)))))))) + + (define (insert-at-tail* e exprs phase) + (let ([new + (rebuild exprs + (let loop ([exprs exprs]) + (if (stx-null? (stx-cdr exprs)) + (list (cons (stx-car exprs) + (insert-at-tail + e (stx-car exprs) phase))) + (loop (stx-cdr exprs)))))]) + (if (syntax? exprs) + (certify exprs new) + new))) + + (define (insert-at-tail se sexpr phase) + (with-syntax ([expr sexpr] + [e se]) + (kernel-syntax-case/phase sexpr phase + ;; negligible time to eval + [id + (identifier? sexpr) + (syntax (begin e expr))] + [(quote _) (syntax (begin e expr))] + [(quote-syntax _) (syntax (begin e expr))] + [(#%top . d) (syntax (begin e expr))] + [(#%variable-reference . d) (syntax (begin e expr))] + + ;; No tail effect, and we want to account for the time + [(#%plain-lambda . _) (syntax (begin0 expr e))] + [(case-lambda . _) (syntax (begin0 expr e))] + [(set! . _) (syntax (begin0 expr e))] + + [(let-values bindings . body) + (insert-at-tail* se sexpr phase)] + [(letrec-values bindings . body) + (insert-at-tail* se sexpr phase)] + + [(begin . _) + (insert-at-tail* se sexpr phase)] + [(with-continuation-mark . _) + (insert-at-tail* se sexpr phase)] + + [(begin0 body ...) + (certify sexpr (syntax (begin0 body ... e)))] + + [(if test then else) + ;; WARNING: se inserted twice! + (certify + sexpr + (rebuild + sexpr + (list + (cons #'then (insert-at-tail se (syntax then) phase)) + (cons #'else (insert-at-tail se (syntax else) phase)))))] + + [(#%plain-app . rest) + (if (stx-null? (syntax rest)) + ;; null constant + (syntax (begin e expr)) + ;; application; exploit guaranteed left-to-right evaluation + (insert-at-tail* se sexpr phase))] + + [_else + (error 'errortrace + "unrecognized (non-top-level) expression form: ~e" + (syntax->datum sexpr))]))) + + (define (profile-annotate-lambda name expr clause bodys-stx phase) + (let* ([bodys (stx->list bodys-stx)] + [bodyl (map (lambda (e) (annotate e phase)) + bodys)]) + (rebuild clause + (if (profiling-enabled) + (let ([prof-expr + (profile-point bodyl name expr phase)]) + ;; Tell rebuild to replace first expressions with + ;; (void), and replace the last expression with + ;; prof-expr: + (let loop ([bodys bodys]) + (if (null? (cdr bodys)) + (list (cons (car bodys) prof-expr)) + (cons (cons (car bodys) #'(#%plain-app void)) + (loop (cdr bodys)))))) + ;; Map 1-to-1: + (map cons bodys bodyl))))) + + (define (keep-lambda-properties orig new) + (let ([p (syntax-property orig 'method-arity-error)] + [p2 (syntax-property orig 'inferred-name)]) + (let ([new (if p + (syntax-property new 'method-arity-error p) + new)]) + (if p2 + (syntax-property new 'inferred-name p2) + new)))) + + (define (annotate-let expr phase varss-stx rhss-stx bodys-stx) + (let ([varss (syntax->list varss-stx)] + [rhss (syntax->list rhss-stx)] + [bodys (syntax->list bodys-stx)]) + (let ([rhsl (map + (lambda (vars rhs) + (annotate-named + (syntax-case vars () + [(id) + (syntax id)] + [_else #f]) + rhs + phase)) + varss + rhss)] + [bodyl (map + (lambda (body) + (annotate body phase)) + bodys)]) + (rebuild expr (append (map cons bodys bodyl) + (map cons rhss rhsl)))))) + + (define (annotate-seq expr bodys-stx annotate phase) + (let* ([bodys (syntax->list bodys-stx)] + [bodyl (map (lambda (b) + (annotate b phase)) + bodys)]) + (rebuild expr (map cons bodys bodyl)))) + + (define orig-inspector (current-code-inspector)) + + (define (certify orig new) + (syntax-recertify new orig orig-inspector #f)) + + (define (rebuild expr replacements) + (let loop ([expr expr] + [same-k (lambda () expr)] + [diff-k (lambda (x) x)]) + (let ([a (assq expr replacements)]) + (if a + (diff-k (cdr a)) + (cond + [(pair? expr) (loop (car expr) + (lambda () + (loop (cdr expr) + same-k + (lambda (y) + (diff-k (cons (car expr) y))))) + (lambda (x) + (loop (cdr expr) + (lambda () + (diff-k (cons x (cdr expr)))) + (lambda (y) + (diff-k (cons x y))))))] + [(vector? expr) + (loop (vector->list expr) + same-k + (lambda (x) (diff-k (list->vector x))))] + [(box? expr) (loop (unbox expr) + same-k + (lambda (x) + (diff-k (box x))))] + [(syntax? expr) (if (identifier? expr) + (same-k) + (loop (syntax-e expr) + same-k + (lambda (x) + (diff-k + (datum->syntax + expr + x + expr)))))] + [else (same-k)]))))) + + (define (append-rebuild expr end) + (cond + [(syntax? expr) + (datum->syntax expr + (append-rebuild (syntax-e expr) end) + expr)] + [(pair? expr) + (cons (car expr) (append-rebuild (cdr expr) end))] + [(null? expr) + (list end)] + [else + (error 'append-rebuild "shouldn't get here")])) + + (define (one-name names-stx) + (let ([l (syntax->list names-stx)]) + (and (pair? l) + (null? (cdr l)) + (car l)))) + + (define (make-annotate top? name) + (lambda (expr phase) + (test-coverage-point + (kernel-syntax-case/phase expr phase + [_ + (identifier? expr) + (let ([b (identifier-binding expr phase)]) + (cond + [(eq? 'lexical b) + ;; lexical variable - no error possile + expr] + [(and (pair? b) (eq? '#%kernel (car b))) + ;; built-in - no error possible + expr] + [else + ;; might be undefined/uninitialized + (with-mark expr expr)]))] + + [(#%top . id) + ;; might be undefined/uninitialized + (with-mark expr expr)] + [(#%variable-reference . _) + ;; no error possible + expr] + [(define-values names rhs) top? ;; Can't put annotation on the outside @@ -376,191 +376,191 @@ (rebuild expr (list (cons #'rhs with-coverage)))))] - [(begin . exprs) - top? - (certify - expr - (annotate-seq expr - (syntax exprs) - annotate-top phase))] - [(define-syntaxes (name ...) rhs) - top? - (let ([marked (with-mark expr - (annotate-named - (one-name #'(name ...)) - (syntax rhs) - (add1 phase)))]) - (certify - expr - (rebuild expr (list (cons #'rhs marked)))))] - - [(define-values-for-syntax (name ...) rhs) - top? - (let ([marked (with-mark expr - (annotate-named - (one-name (syntax (name ...))) - (syntax rhs) - (add1 phase)))]) - (certify - expr - (rebuild expr (list (cons #'rhs marked)))))] - - [(module name init-import (__plain-module-begin body ...)) - ;; Just wrap body expressions - (let ([bodys (syntax->list (syntax (body ...)))] - [mb (list-ref (syntax->list expr) 3)]) - (let ([bodyl (map (lambda (b) - (annotate-top b 0)) - bodys)]) - (certify - expr - (rebuild - expr - (list (cons - mb - (certify - mb - (rebuild mb (map cons bodys bodyl)))))))))] - - [(#%expression e) - top? - (certify expr #`(#%expression #,(annotate (syntax e) phase)))] - - ;; No way to wrap - [(#%require i ...) expr] - ;; No error possible (and no way to wrap) - [(#%provide i ...) expr] - - - ;; No error possible - [(quote _) - expr] - [(quote-syntax _) - expr] - - ;; Wrap body, also a profile point - [(#%plain-lambda args . body) - (certify - expr - (keep-lambda-properties - expr - (profile-annotate-lambda name expr expr (syntax body) - phase)))] - [(case-lambda clause ...) - (with-syntax ([([args . body] ...) - (syntax (clause ...))]) - (let* ([clauses (syntax->list (syntax (clause ...)))] - [clausel (map - (lambda (body clause) - (profile-annotate-lambda - name expr clause body phase)) - (syntax->list (syntax (body ...))) - clauses)]) - (certify - expr - (keep-lambda-properties - expr - (rebuild expr (map cons clauses clausel))))))] - - ;; Wrap RHSs and body - [(let-values ([vars rhs] ...) . body) - (with-mark expr - (certify - expr - (annotate-let expr phase - (syntax (vars ...)) - (syntax (rhs ...)) - (syntax body))))] - [(letrec-values ([vars rhs] ...) . body) - (with-mark expr - (certify - expr - (annotate-let expr phase - (syntax (vars ...)) - (syntax (rhs ...)) - (syntax body))))] - - ;; Wrap RHS - [(set! var rhs) - (let ([new-rhs (annotate-named - (syntax var) - (syntax rhs) - phase)]) - ;; set! might fail on undefined variable, or too many values: - (with-mark expr - (certify - expr - (rebuild expr (list (cons #'rhs new-rhs))))))] - - ;; Wrap subexpressions only - [(begin e) - ;; Single expression: no mark - (certify - expr - #`(begin #,(annotate (syntax e) phase)))] - [(begin . body) - (with-mark expr - (certify - expr - (annotate-seq expr #'body annotate phase)))] - [(begin0 . body) - (with-mark expr - (certify - expr - (annotate-seq expr #'body annotate phase)))] - [(if tst thn els) - (let ([w-tst (annotate (syntax tst) phase)] - [w-thn (annotate (syntax thn) phase)] - [w-els (annotate (syntax els) phase)]) - (with-mark expr - (certify - expr - (rebuild expr (list (cons #'tst w-tst) - (cons #'thn w-thn) - (cons #'els w-els))))))] - [(if tst thn) - (let ([w-tst (annotate (syntax tst) phase)] - [w-thn (annotate (syntax thn) phase)]) - (with-mark expr - (certify - expr - (rebuild expr (list (cons #'tst w-tst) - (cons #'thn w-thn))))))] - [(with-continuation-mark . body) - (with-mark expr - (certify - expr - (annotate-seq expr (syntax body) - annotate phase)))] - - ;; Wrap whole application, plus subexpressions - [(#%plain-app . body) - (cond - [(stx-null? (syntax body)) - ;; It's a null: - expr] - [(syntax-case* expr (#%plain-app void) - (if (positive? phase) - free-transformer-identifier=? - free-identifier=?) - [(#%plain-app void) #t] - [_else #f]) - ;; It's (void): - expr] - [else - (with-mark expr (certify - expr - (annotate-seq expr (syntax body) - annotate phase)))])] - - [_else - (error 'errortrace "unrecognized expression form~a: ~e" - (if top? " at top-level" "") - (syntax->datum expr))]) - expr - phase))) - - (define annotate (make-annotate #f #f)) - (define annotate-top (make-annotate #t #f)) - (define (annotate-named name expr phase) - ((make-annotate #t name) expr phase)))) + [(begin . exprs) + top? + (certify + expr + (annotate-seq expr + (syntax exprs) + annotate-top phase))] + [(define-syntaxes (name ...) rhs) + top? + (let ([marked (with-mark expr + (annotate-named + (one-name #'(name ...)) + (syntax rhs) + (add1 phase)))]) + (certify + expr + (rebuild expr (list (cons #'rhs marked)))))] + + [(define-values-for-syntax (name ...) rhs) + top? + (let ([marked (with-mark expr + (annotate-named + (one-name (syntax (name ...))) + (syntax rhs) + (add1 phase)))]) + (certify + expr + (rebuild expr (list (cons #'rhs marked)))))] + + [(module name init-import (__plain-module-begin body ...)) + ;; Just wrap body expressions + (let ([bodys (syntax->list (syntax (body ...)))] + [mb (list-ref (syntax->list expr) 3)]) + (let ([bodyl (map (lambda (b) + (annotate-top b 0)) + bodys)]) + (certify + expr + (rebuild + expr + (list (cons + mb + (certify + mb + (rebuild mb (map cons bodys bodyl)))))))))] + + [(#%expression e) + top? + (certify expr #`(#%expression #,(annotate (syntax e) phase)))] + + ;; No way to wrap + [(#%require i ...) expr] + ;; No error possible (and no way to wrap) + [(#%provide i ...) expr] + + + ;; No error possible + [(quote _) + expr] + [(quote-syntax _) + expr] + + ;; Wrap body, also a profile point + [(#%plain-lambda args . body) + (certify + expr + (keep-lambda-properties + expr + (profile-annotate-lambda name expr expr (syntax body) + phase)))] + [(case-lambda clause ...) + (with-syntax ([([args . body] ...) + (syntax (clause ...))]) + (let* ([clauses (syntax->list (syntax (clause ...)))] + [clausel (map + (lambda (body clause) + (profile-annotate-lambda + name expr clause body phase)) + (syntax->list (syntax (body ...))) + clauses)]) + (certify + expr + (keep-lambda-properties + expr + (rebuild expr (map cons clauses clausel))))))] + + ;; Wrap RHSs and body + [(let-values ([vars rhs] ...) . body) + (with-mark expr + (certify + expr + (annotate-let expr phase + (syntax (vars ...)) + (syntax (rhs ...)) + (syntax body))))] + [(letrec-values ([vars rhs] ...) . body) + (with-mark expr + (certify + expr + (annotate-let expr phase + (syntax (vars ...)) + (syntax (rhs ...)) + (syntax body))))] + + ;; Wrap RHS + [(set! var rhs) + (let ([new-rhs (annotate-named + (syntax var) + (syntax rhs) + phase)]) + ;; set! might fail on undefined variable, or too many values: + (with-mark expr + (certify + expr + (rebuild expr (list (cons #'rhs new-rhs))))))] + + ;; Wrap subexpressions only + [(begin e) + ;; Single expression: no mark + (certify + expr + #`(begin #,(annotate (syntax e) phase)))] + [(begin . body) + (with-mark expr + (certify + expr + (annotate-seq expr #'body annotate phase)))] + [(begin0 . body) + (with-mark expr + (certify + expr + (annotate-seq expr #'body annotate phase)))] + [(if tst thn els) + (let ([w-tst (annotate (syntax tst) phase)] + [w-thn (annotate (syntax thn) phase)] + [w-els (annotate (syntax els) phase)]) + (with-mark expr + (certify + expr + (rebuild expr (list (cons #'tst w-tst) + (cons #'thn w-thn) + (cons #'els w-els))))))] + [(if tst thn) + (let ([w-tst (annotate (syntax tst) phase)] + [w-thn (annotate (syntax thn) phase)]) + (with-mark expr + (certify + expr + (rebuild expr (list (cons #'tst w-tst) + (cons #'thn w-thn))))))] + [(with-continuation-mark . body) + (with-mark expr + (certify + expr + (annotate-seq expr (syntax body) + annotate phase)))] + + ;; Wrap whole application, plus subexpressions + [(#%plain-app . body) + (cond + [(stx-null? (syntax body)) + ;; It's a null: + expr] + [(syntax-case* expr (#%plain-app void) + (if (positive? phase) + free-transformer-identifier=? + free-identifier=?) + [(#%plain-app void) #t] + [_else #f]) + ;; It's (void): + expr] + [else + (with-mark expr (certify + expr + (annotate-seq expr (syntax body) + annotate phase)))])] + + [_else + (error 'errortrace "unrecognized expression form~a: ~e" + (if top? " at top-level" "") + (syntax->datum expr))]) + expr + phase))) + + (define annotate (make-annotate #f #f)) + (define annotate-top (make-annotate #t #f)) + (define (annotate-named name expr phase) + ((make-annotate #t name) expr phase))) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index aa0a4b6874..78c30cac1d 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -54,6 +54,37 @@ (link standard-mred@ framework@)) (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 text:autocomplete-append-after (parameter/c string?) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index ec23b69f8f..ea446f8f3f 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -217,7 +217,14 @@ (autocomplete-append-after autocomplete-limit 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^ (basic<%> diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index b626e2d066..d0b1e2fdb9 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -7,17 +7,16 @@ WARNING: printf is rebound in the body of the unit to always |# (require string-constants - mzlib/class - mzlib/match + scheme/unit + scheme/class + scheme/match scheme/path "sig.ss" "../gui-utils.ss" "../preferences.ss" mred/mred-sig mrlib/interactive-value-port - mzlib/list setup/dirs - mzlib/string (prefix-in srfi1: srfi/1)) (require setup/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) (void)) + (define-struct range (start end caret-space? 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 (λ (a-committer) (match a-committer - [($ committer - kr - commit-peeker-evt - done-evt - resp-chan - resp-nack) + [(struct committer + (kr + commit-peeker-evt + done-evt + resp-chan + resp-nack)) (choice-evt (handle-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 (define ((service-committer data peeker-evt) a-committer) (match a-committer - [($ committer - kr commit-peeker-evt - done-evt resp-chan resp-nack) + [(struct committer + (kr commit-peeker-evt + done-evt resp-chan resp-nack)) (let ([size (queue-size data)]) (cond [(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 (define (service-waiter 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 [(and pe (not (eq? pe peeker-evt))) (choice-evt (channel-put-evt resp-chan #f) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 240059e007..47802f3d6e 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -299,7 +299,7 @@ (class canvas% (inherit get-client-size get-dc) (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)) (super-new))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c534c225b1..26ea0a4ce4 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -1356,7 +1356,7 @@ improve method arity mismatch contract violation error messages? false/c printable/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 box-immutable/c box/c promise/c @@ -2087,6 +2087,10 @@ improve method arity mismatch contract violation error messages? (define 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 vector-immutableof diff --git a/collects/scribblings/drscheme/interface-essentials.scrbl b/collects/scribblings/drscheme/interface-essentials.scrbl index 322203abb4..a80a896aa9 100644 --- a/collects/scribblings/drscheme/interface-essentials.scrbl +++ b/collects/scribblings/drscheme/interface-essentials.scrbl @@ -168,21 +168,21 @@ non-Scheme languages. You specify a language in one of two ways: @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 changing the language, click @onscreen{Run} to reset the language in the interactions window. The bottom-left corner of DrScheme's main window also has a shortcut menu item for 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"]. The @menuitem["Language" "Choose Language..."] dialog contains a diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 853e8c4689..b9b09a0691 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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.} +@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?]{ Produces a contract the recognizes pairs first and second elements diff --git a/collects/scribblings/tools/rep.scrbl b/collects/scribblings/tools/rep.scrbl index 3f1c1d4c00..6d5eebc5d1 100644 --- a/collects/scribblings/tools/rep.scrbl +++ b/collects/scribblings/tools/rep.scrbl @@ -2,6 +2,7 @@ @(require "common.ss") @(tools-title "rep") + @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) (or/c false/c (list/c (is-a?/c text:basic%) number? number?))]{ @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?]{ Call this method to highlight errors associated with this repl. See also diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 67384a6ae7..c1f3fae78c 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -1009,7 +1009,11 @@ please adhere to these guidelines: (decimal-notation-for-rationals "Use decimal notation for rationals") (enforce-primitives-group-box-label "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 the popup menu from the just above; greyed out and only diff --git a/collects/string-constants/japanese-string-constants.ss b/collects/string-constants/japanese-string-constants.ss index 57478214f7..92de2fb69c 100644 --- a/collects/string-constants/japanese-string-constants.ss +++ b/collects/string-constants/japanese-string-constants.ss @@ -191,6 +191,7 @@ please adhere to these guidelines: (cs-status-loading-docs-index "構文の検証: ドキュメントの索引をロードしています") (cs-mouse-over-import "束縛 ~s が ~s からインポートされました") (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-imported-variable "インポート変数") @@ -241,6 +242,11 @@ please adhere to these guidelines: (erase-log-directory-contents "記録先のディレクトリ ~a の内容を消去しますか？") (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 (mode-submenu-label "モード") (scheme-mode "Scheme モード") @@ -320,6 +326,18 @@ please adhere to these guidelines: ;; in the Help Desk language dialog, title on the right. (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 (http-proxy "HTTP プロキシ") @@ -372,13 +390,15 @@ please adhere to these guidelines: ;;; about box (about-drscheme-frame-title "DrScheme について") - ;;; save file in particular format prompting. (save-as-plain-text "このファイルをプレーンテキストで保存しますか？") (save-in-drs-format "このファイルを DrScheme 専用のバイナリ形式で保存しますか？") (yes "はい") (no "いいえ") + ;; saving image (right click on an image to see the text) + (save-image "画像を保存する...") + ;;; preferences (preferences "環境設定") (error-saving-preferences "環境設定を保存時にエラーが発生しました: ~a") @@ -393,7 +413,8 @@ please adhere to these guidelines: (editor-prefs-panel-label "編集") (general-prefs-panel-label "一般") (highlight-parens "対応する括弧の間を強調表示する") - (fixup-parens "括弧を自動修正する") + (fixup-open-brackets "左角括弧を自動調整する") + (fixup-close-parens "右括弧を自動調整する") (flash-paren-match "対応する括弧をフラッシュする") (auto-save-files "ファイルを自動保存する") (backup-files "ファイルをバックアップする") @@ -404,6 +425,8 @@ please adhere to these guidelines: (show-status-line "ステータス行を表示する") (count-columns-from-one "桁番号を 1 から数える") (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 "メニューのキーバインドを有効にする") (automatically-to-ps "自動的に PostScript ファイルに印刷する") (command-as-meta "Command キーを Meta キーとして処理する") ;; macos/macos x only @@ -462,11 +485,16 @@ please adhere to these guidelines: (indenting-prefs-panel-label "インデント") (indenting-prefs-extra-regexp "正規表現") + (square-bracket-prefs-panel-label "角括弧") + ; filled with define, lambda, or begin (enter-new-keyword "新しい ~a のようなキーワードを入力してください:") (x-keyword "~a キーワード") (x-like-keywords "~a のようなキーワード") + ; used in Square bracket panel + (skip-subexpressions "スキップする部分式の個数") + (expected-a-symbol "シンボルでなければなりません: ~a") (already-used-keyword "\"~a\" はすでに特別にインデントされるキーワードです") (add-keyword "追加") @@ -479,15 +507,22 @@ please adhere to these guidelines: (repl-error-color "エラー") ;;; find/replace - (find-and-replace "検索と置換") - (find "検索") - (replace "置換") - (dock "結合") - (undock "分離") - (replace&find-again "置換＋再検索") ;;; need double & to get a single & - (forward "前方") - (backward "後方") - (hide "隠す") + (search-next "次") + (search-previous "前") + (search-match "一致") ;;; this one and the next one are singular/plural variants of each other + (search-matches "一致") + (search-replace "置換") + (search-skip "無視") + (search-show-replace "置換を表示") + (search-hide-replace "置換を非表示") + (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 (mfs-multi-file-search-menu-item "ファイルから検索...") @@ -621,18 +656,34 @@ please adhere to these guidelines: (select-all-info "文書全体を選択します") (select-all-menu-item "すべて選択(&L)") - (find-info "文字列を検索します") - (find-menu-item "検索...") + (find-menu-item "検索") ;; menu item + (find-info "検索対象ウィンドウと検索バーの間でキーボード フォーカスを移動する") - (find-again-info "直前の検索文字列と同じ文字列を検索します") - (find-again-menu-item "再検索") + (find-next-info "検索ウィンドウ内の文字列が次に見つかるまでスキップ") + (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-and-find-again-menu-item "置換と再検索") + (replace-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 (no-completions "... 自動補完できません") ; shows up in the completions menu when there are no completions (in italics) - + + (overwrite-mode "上書きモード") + (enable-overwrite-mode-keybindings "上書きモードのキーバインドを有効にする") + (preferences-info "環境設定を行います") (preferences-menu-item "環境設定...") @@ -643,10 +694,17 @@ please adhere to these guidelines: (keybindings-sort-by-name "名前で並べ替え") (keybindings-sort-by-key "キーで並べ替え") (keybindings-add-user-defined-keybindings "ユーザー定義のキーバインドを追加...") + (keybindings-add-user-defined-keybindings/planet "ユーザー定義のキーバインドを PLaneT から追加...") (keybindings-menu-remove "~a を削除") (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 で書かれたモジュールが含まれていません。") ;; menu items in the "special" menu @@ -657,12 +715,15 @@ please adhere to these guidelines: (wrap-text-item "テキストを折り返す") + ;; windows menu (windows-menu-label "ウィンドウ(&W)") (minimize "最小化") ;; minimize and zoom are only used under mac os x (zoom "拡大") (bring-frame-to-front "フレームを前面に移動") ;;; title of dialog (bring-frame-to-front... "フレームを前面に移動...") ;;; corresponding title of menu item (most-recent-window "最近使用したウィンドウ") + (next-tab "次のタブ") + (prev-tab "前のタブ") (view-menu-label "表示(&V)") (show-overview "プログラムの外観を表示") @@ -670,7 +731,7 @@ please adhere to these guidelines: (show-module-browser "モジュール ブラウザを表示") (hide-module-browser "モジュール ブラウザを非表示") - (help-menu-label "ヘルプ(&H)") + (help-menu-label "ヘルプ(&H)") (about-info "このアプリケーションの著作権と詳細情報を表示します") (about-menu-item "バージョン情報...") @@ -687,6 +748,12 @@ please adhere to these guidelines: (quit "終了") (are-you-sure-exit "終了してよろしいですか？") (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 (error-autosaving "\"~a\" を自動保存中にエラーが発生しました。") ;; ~a will be a filename @@ -765,8 +832,6 @@ please adhere to these guidelines: (show-interactions-menu-item-label "対話を表示(&I)") (hide-interactions-menu-item-label "対話を非表示(&I)") (interactions-menu-item-help-string "対話ウィンドウを表示/非表示します") - (show-toolbar "ツールバーを表示(&T)") - (hide-toolbar "ツールバーを非表示(&T)") (toolbar "ツールバー") (toolbar-on-top "ツールバーを上側に表示する") (toolbar-on-left "ツールバーを左側に表示する") @@ -799,12 +864,12 @@ please adhere to these guidelines: (scheme-menu-name "S&cheme") (execute-menu-item-label "実行") (execute-menu-item-help-string "定義ウィンドウのプログラムを再開始します") - (break-menu-item-label "停止") - (break-menu-item-help-string "現在の評価を停止します") - (kill-menu-item-label "強制終了") - (kill-menu-item-help-string "現在の評価を強制終了します") + (ask-quit-menu-item-label "プログラムを停止しますか？") + (ask-quit-menu-item-help-string "現在の式評価のプライマリ スレッドを停止するには break-thread を使用してください") + (force-quit-menu-item-label "プログラムを強制終了します") + (force-quit-menu-item-help-string "現在の式評価を強制終了するには custodian-shutdown-all を使用してください") (limit-memory-menu-item-label "メモリを制限する...") - (limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。") + (limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次回に実行するときに有効になります。") (limit-memory-msg-2 "制限値は 1MB 以上にしてください。") (limit-memory-unlimited "制限しない") (limit-memory-limited "制限する") @@ -827,23 +892,34 @@ please adhere to these guidelines: (save-a-mzscheme-launcher "MzScheme ランチャの保存") (save-a-mred-stand-alone-executable "MrEd スタンドアロン実行ファイルの保存") (save-a-mzscheme-stand-alone-executable "MzScheme スタンドアロン実行ファイルの保存") + (save-a-mred-distribution "MrEd 配布物の保存") + (save-a-mzscheme-distribution "MzScheme 配布物の保存") (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-explanatory-label "Launcher (for this machine only, runs from source)") (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-base "Base") (filename "ファイル名: ") (create "作成") - ;; "choose-an-executable" changed to "specify-a" - ;(please-choose-an-executable-filename "Please choose a filename.") - ;; Replaced by generic ~a-must-end-with-~a - ;(windows-executables-must-end-with-exe - ; "ファイル名\n\n ~a\n\nは正しくありません。Windows では、実行ファイルは .exe という拡張子を持たなければなりません。") - ;(macosx-executables-must-end-with-app - ; "ファイル名\n\n ~a\n\nは正しくありません。MacOS X では、実行ファイルは .app という名前で終わるディレクトリでなければなりません。") + (please-specify-a-filename "作成するファイル名を指定してください。") + (~a-must-end-with-~a + "~a のファイル名\n\n ~a\n\n は不正です。ファイル名の末尾は \".~a\" でなければなりません。") + (macosx-executables-must-end-with-app + "ファイル名\n\n ~a\n\n は不正です。MacOS X では実行ファイルは末尾が .app のディレクトリでなければなりません。") (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 "サーブレットの作成...") @@ -869,7 +945,9 @@ please adhere to these guidelines: (whole-part "整数部") (numerator "分子") (denominator "分母") - (invalid-number "不正な数値です。正確数で、実数で、整数でない数でないといけません。") + (insert-number/bad-whole-part "整数でなければなりません。") + (insert-number/bad-numerator "分子は非負の整数でなければなりません。") + (insert-number/bad-denominator "分母は正の整数でなければなりません。") (insert-fraction-menu-item-label "分数を挿入...") ;; number snip popup menu @@ -929,6 +1007,7 @@ please adhere to these guidelines: (decimal-notation-for-rationals "有理数を10進数で表示する") (enforce-primitives-group-box-label "初期束縛") (enforce-primitives-check-box-label "初期束縛の再定義を禁止する") + (automatically-compile? "ソースファイルを自動的にコンパイルしますか？") ; used in the bottom left of the drscheme frame ; 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... (pretty-big-scheme "Pretty Big") (pretty-big-scheme-one-line-summary "syntax と HtDP 言語の関数を追加") + (pretty-big-scheme-one-line-summary "HtDP 言語, mzscheme, mred/mred の構文と関数を追加") (r5rs-language-name "R5RS") (r5rs-one-line-summary "純粋な R5RS") (expander "Expander") @@ -966,6 +1046,7 @@ please adhere to these guidelines: (no-language-chosen "言語が選択されていません") (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. (must-choose-language "DrScheme は、プログラミング言語を選択しなければプログラムを実行できません。") @@ -1099,6 +1180,7 @@ please adhere to these guidelines: (module-browser-compiling-defns "モジュール ブラウザ: 定義をコンパイル中です") (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-only-in-plt-and-module-langs "モジュール ブラウザは PLT 言語、または、モジュール言語のプログラム (あるいは、それらの言語のモジュールを持つプログラム) でのみ利用可能です。") (module-browser-name-length "名前の長さ") @@ -1204,6 +1286,8 @@ please adhere to these guidelines: (ml-cp-raise "上へ") (ml-cp-lower "下へ") + (ml-always-show-#lang-line "モジュール言語で常に #lang 行を表示する") + ;; Profj (profj-java "Java") (profj-java-mode "Java モード") @@ -1342,4 +1426,29 @@ please adhere to these guidelines: (gui-tool-show-gui-toolbar "GUI ツールバーを表示") (gui-tool-hide-gui-toolbar "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") + ) diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index 7112f0c6ac..1985165305 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -173,9 +173,10 @@ (wait-for-computation frame)))])) (define (verify-drscheme-frame-frontmost function-name frame) - (unless (and (eq? frame (get-top-level-focus-window)) - (drscheme-frame? frame)) - (error function-name "drscheme frame not frontmost: ~e" frame))) + (let ([tl (get-top-level-focus-window)]) + (unless (and (eq? frame tl) + (drscheme-frame? tl)) + (error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl)))) (define (clear-definitions frame) (verify-drscheme-frame-frontmost 'clear-definitions frame) @@ -192,22 +193,24 @@ "Delete"))) (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) - (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) - (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) - (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) str/sexp (let ([port (open-output-string)]) (parameterize ([current-output-port port]) (write str/sexp port)) (get-output-string port)))]) - (verify-drscheme-frame-frontmost 'put-in-frame frame) + (verify-drscheme-frame-frontmost who frame) (let ([canvas (get-canvas frame)]) (fw:test:new-window canvas) (let ([editor (send canvas get-editor)]) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 2b39494008..a4265d191c 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -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"))) - -; -; -; -; ;;;;;; -; ; -; ; -; ; ; ; ; ; ;;; -; ;; ;;;; ;; ; -; ; ; ; ;; -; ; ; ; ;; -; ; ; ; ; -; ; ; ; ; ; -; ; ;;; ; ;;; -; -; -; +; +; +; ;;;;;;; ;;;;;;; ;;;;;; +; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;;;;; ;; ;; ;;;; +; ;;;;;; ; ;;;;;; ;;;;; +; ;; ;; ;;;; ;; ;; ;;; +; ;; ;; ;; ;; ;; ; ;; +; ;; ;; ;; ;; ;; ;; ;; +; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;; +; ;; ;; +; ;;;; +; (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 "(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) (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) @@ -395,18 +394,20 @@ the settings above should match r5rs -;; ; ;; -; ; ; -; ; ; -;;;; ;;; ;;; ; ; ;;;; ;;;; ; ;;; ;;; ;;; ;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;;;;; ; ; ; ;;;; ; ; ; ;;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; -; ;;; ;;; ;;;; ; ;;; ;; ;;; ;;;; ;;; ; -; ; -; -;;; +; +; ;;; ;;; ;;; +; ;; ; ;; ;; +; ;; ; ;; ;; +; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ; +; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;; +; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;; +; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ; +; ;; ;;; +; ;; ;;; +; ;;;;; (define (beginner/abbrev) @@ -558,19 +559,20 @@ the settings above should match r5rs "reference to an identifier before its definition: define-syntax"))) - -; ;; ; -; ; ; -; ; ; -;;; ; ;;; ;;;;; ;;; ; ;;; ;;; ; ;;; ;;;; ;;; ;;;; ;;;;; ;;; -; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ;;;; ; ;;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -;;;;; ;;; ;; ;;; ;;; ;;;; ;; ; ;; ;;; ;;; ; ;;;;; ;;; ; ;;; ;;; - - - +; +; ;; ;;; ;; +; ;; ;; ;; ;; ;; +; ;; ;; ;; +; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;; +; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ; +; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;; +; +; +; (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 "(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 "(+ 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 "#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 "(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 "(+ 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 "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index 3fd5c12c65..7b7cf273fe 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -124,7 +124,12 @@ (send interactions-text get-error-ranges))))]))))) (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)) (clear-definitions drs) (send (send drs get-definitions-text) set-modified #f) diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index ba0db50f6f..e2a034e6b4 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -158,8 +158,7 @@ (test @t{#lang scheme (eval 'cons)} #f - @rx{. compile: bad syntax; reference to top-level identifier is not - allowed, because no #%top syntax transformer is bound in: cons}) + @rx{. compile: unbound identifier \(and no #%top syntax transformer is bound\) in: cons}) (test @t{(module m (file @in-here{module-lang-test-tmp1.ss}) 1 2 3)} @t{1} ;; just make sure no errors. "1") diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 7130be894e..4df6ea15d4 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -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} repl-test-tmp3.ss:3:13: 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: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:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3") 'definitions #f void @@ -1081,15 +1081,6 @@ This produces an ACK message (define definitions-canvas (send drscheme-frame get-definitions-canvas)) (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 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 ; directly, and second, we use the load command. We compare the ; 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)) (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)] [setup (test-setup 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 ; the start and end positions of the text + (wait-for-drscheme-frame) + (cond [(string? program) - (insert-string program)] + (insert-in-definitions/newlines drscheme-frame program)] [(eq? program 'fraction-sum) (setup-fraction-sum-interactions)] [(list? program) (for-each (lambda (item) (cond - [(string? item) (insert-string item)] + [(string? item) (insert-in-definitions/newlines drscheme-frame item)] [(eq? item 'left) (send definitions-text set-position @@ -1182,34 +1175,36 @@ This produces an ACK message (fetch-output drscheme-frame execute-text-start execute-text-end)]) ; check focus and selection for execute test - (unless raw? - (cond - [(eq? source-location 'definitions) - (unless (send definitions-canvas has-focus?) - (printf "FAILED execute test for ~s\n expected definitions to have the focus\n" - program))] - [(eq? source-location 'interactions) - (unless (send interactions-canvas has-focus?) - (printf "FAILED execute test for ~s\n expected interactions to have the focus\n" - program))] - [(send definitions-canvas has-focus?) - (let ([start (car source-location)] - [finish (cdr source-location)]) - (let* ([error-ranges (send interactions-text get-error-ranges)] - [error-range (and error-ranges - (not (null? error-ranges)) - (car error-ranges))]) - (unless (and error-range - (= (+ (srcloc-position error-range) -1) (loc-offset start)) - (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) - (loc-offset finish))) - (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" - program - (and error-range - (list (+ (srcloc-position error-range) -1) - (+ (srcloc-position error-range) -1 (srcloc-span error-range)))) - (list (loc-offset start) - (loc-offset finish))))))])) + (case language-cust + [(raw) (void)] + [else + (cond + [(eq? source-location 'definitions) + (unless (send definitions-canvas has-focus?) + (printf "FAILED execute test for ~s\n expected definitions to have the focus\n" + program))] + [(eq? source-location 'interactions) + (unless (send interactions-canvas has-focus?) + (printf "FAILED execute test for ~s\n expected interactions to have the focus\n" + program))] + [(send definitions-canvas has-focus?) + (let ([start (car source-location)] + [finish (cdr source-location)]) + (let* ([error-ranges (send interactions-text get-error-ranges)] + [error-range (and error-ranges + (not (null? error-ranges)) + (car error-ranges))]) + (unless (and error-range + (= (+ (srcloc-position error-range) -1) (loc-offset start)) + (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) + (loc-offset finish))) + (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" + program + (and error-range + (list (+ (srcloc-position error-range) -1) + (+ (srcloc-position error-range) -1 (srcloc-span error-range)))) + (list (loc-offset start) + (loc-offset finish))))))])]) ; check text for execute test (next-test) @@ -1222,7 +1217,7 @@ This produces an ACK message (failure) (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" program - raw? + language-cust execute-answer received-execute)) (test:new-window interactions-canvas) @@ -1238,9 +1233,7 @@ This produces an ACK message (send interactions-text get-character (- (send interactions-text last-position) 1)))) (test:keystroke #\return)) - - ; - + (let ([load-test (lambda (short-filename load-answer) ;; 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) ;; stuff the load command into the REPL - (for-each test:keystroke - (string->list (format "(load ~s)" short-filename))) + (insert-in-interactions drscheme-frame (format "(load ~s)" short-filename)) ;; record current text position, then stuff a CR into the REPL (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" short-filename 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) (delete-file 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) @@ -1303,17 +1295,27 @@ This produces an ACK message (printf "tests finished: all ~a tests passed\n" 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")]) - (printf "running tests ~a debugging\n" (if raw? "without" "with")) - (if raw? - (begin - (set-language-level! level #f) - (test:set-radio-box-item! "No debugging or profiling") - (let ([f (get-top-level-focus-window)]) - (test:button-push "OK") - (wait-for-new-frame f))) - (set-language-level! level)) + (printf "running tests: ~a\n" language-cust) + (case language-cust + [(raw) + (begin + (set-language-level! level #f) + (test:set-radio-box-item! "No debugging or profiling") + (let ([f (get-top-level-focus-window)]) + (test:button-push "OK") + (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) @@ -1321,7 +1323,7 @@ This produces an ACK message (clear-definitions drscheme-frame) (do-execute drscheme-frame) (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") @@ -1390,19 +1392,18 @@ This produces an ACK message (fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output))))) (define (random-seed-test) - (define expression - (string->list (format "~a" '(pseudo-random-generator->vector (current-pseudo-random-generator))))) + (define expression (format "~s" '(pseudo-random-generator->vector (current-pseudo-random-generator)))) (next-test) (clear-definitions drscheme-frame) (do-execute drscheme-frame) (wait-for-execute) - (for-each test:keystroke expression) + (insert-in-interactions drscheme-frame expression) (let ([start1 (+ 1 (send interactions-text last-position))]) (test:keystroke #\return) (wait-for-execute) (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))]) (test:keystroke #\return) (wait-for-execute) @@ -1453,27 +1454,45 @@ This produces an ACK message (delete-file tmp-load-filename)) (save-drscheme-window-as tmp-load-filename) - (run-test-in-language-level #f) - (run-test-in-language-level #t) + ;; the debug and debug/profile tests should not differ in their output + ;; 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) (callcc-test) (top-interaction-test) (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?) - ((if raw? answer-raw-execute answer-debug-execute) +(define (make-execute-answer test language-cust) + ((case language-cust + [(debug debug/profile) + answer-debug-execute] + [(raw) + answer-raw-execute]) (test-answer test))) -(define (make-load-answer test raw? src-file) - ((if raw? - (if src-file - answer-raw-load - answer-raw-load-fn) - (if src-file - answer-debug-load - answer-debug-load-fn)) +(define (make-load-answer test language-cust src-file) + ((case language-cust + [(debug debug/profile) + (if src-file + answer-debug-load + answer-debug-load-fn)] + [(raw) + (if src-file + answer-raw-load + answer-raw-load-fn)]) (test-answer test))) (define (string/rx-append a b) diff --git a/collects/tests/mzscheme/cm.ss b/collects/tests/mzscheme/cm.ss index 094df657c3..ce6d5b807a 100644 --- a/collects/tests/mzscheme/cm.ss +++ b/collects/tests/mzscheme/cm.ss @@ -12,8 +12,8 @@ (define (try files #; (list (list path content-str compile?) ...) recomps #; (list (list (list touch-path ...) - (list rebuild-path ...) - (list check-rebuilt-path ...))) + (list rebuild-path ...) + (list check-rebuilt-path ...))) ) (delete-directory/files dir) (make-directory* dir) @@ -40,30 +40,32 @@ (for-each (lambda (recomp) (printf "pausing...\n") (sleep 1) ;; timestamps have a 1-second granularity on most filesystems - (for-each (lambda (f) - (printf "touching ~a\n" f) - (with-output-to-file (build-path dir f) - #:exists 'append - (lambda () (display " ")))) - (car recomp)) - (for-each (lambda (f) - (printf "re-making ~a\n" f) - (managed-compile-zo (build-path dir f))) - (cadr recomp)) - (for-each (lambda (f) - (let ([ts (hash-ref timestamps f)] - [new-ts - (file-or-directory-modify-seconds - (build-path dir "compiled" (path-add-suffix f #".zo")) - #f - (lambda () -inf.0))] - [updated? (lambda (a b) a)]) - (test (and (member f (caddr recomp)) #t) - updated? - (new-ts . > . ts) - f) - (hash-set! timestamps f new-ts))) - (map car files))) + (let ([to-touch (list-ref recomp 0)] + [to-make (list-ref recomp 1)]) + (for-each (lambda (f) + (printf "touching ~a\n" f) + (with-output-to-file (build-path dir f) + #:exists 'append + (lambda () (display " ")))) + to-touch) + (for-each (lambda (f) + (printf "re-making ~a\n" f) + (managed-compile-zo (build-path dir f))) + to-make) + (for-each (lambda (f) + (let ([ts (hash-ref timestamps f)] + [new-ts + (file-or-directory-modify-seconds + (build-path dir "compiled" (path-add-suffix f #".zo")) + #f + (lambda () -inf.0))] + [updated? (lambda (a b) a)]) + (test (and (member f (caddr recomp)) #t) + updated? + (new-ts . > . ts) + f) + (hash-set! timestamps f new-ts))) + (map car files)))) recomps))) (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")] [("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) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index f239b5ec3a..b300833cca 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -189,6 +189,8 @@ (test/no-error '(listof any/c)) (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")) @@ -3923,6 +3925,14 @@ 'pos 'neg)) + (test/spec-passed + 'immutable7 + '(let ([ct (contract (non-empty-listof (boolean? . -> . boolean?)) + (list (λ (x) #t)) + 'pos + 'neg)]) + ((car ct) #f))) + (test/neg-blame 'immutable8 '(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? 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 any/c) (vectorof any/c)) @@ -5784,6 +5802,10 @@ so that propagation occurs. (ctest #t contract-first-order-passes? (listof integer?) (list 1)) (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 #f contract-first-order-passes? (vector-immutableof integer?) 'x) (ctest #f contract-first-order-passes? (vector-immutableof integer?) '())