From 612f26972e6bd7ffa983b0914d637ad7cde16026 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 29 May 2008 04:55:43 +0000 Subject: [PATCH] improved the error reporting in the REPL and misc other minor changes svn: r10014 --- collects/drscheme/private/debug.ss | 3872 +++++++++-------- collects/drscheme/private/drsig.ss | 16 +- collects/drscheme/private/language.ss | 54 +- collects/drscheme/private/module-language.ss | 3 +- collects/drscheme/private/rep.ss | 3544 ++++++++------- collects/drscheme/syncheck.ss | 11 +- collects/drscheme/tool-lib.ss | 36 +- collects/icons/stop-16x16.png | Bin 0 -> 836 bytes collects/icons/stop-multi.png | Bin 1818 -> 1113 bytes .../english-string-constants.ss | 5 + collects/tests/drscheme/drscheme-test-util.ss | 2 +- collects/tests/drscheme/language-test.ss | 2471 ++++++----- collects/tests/drscheme/module-lang-test.ss | 12 +- collects/tests/drscheme/repl-test.ss | 2612 ++++++----- doc/release-notes/drscheme/HISTORY.txt | 4 + 15 files changed, 6484 insertions(+), 6158 deletions(-) create mode 100644 collects/icons/stop-16x16.png diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 1dd83532ac..8a5f50bdc3 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -6,1949 +6,1967 @@ profile todo: |# -(module debug mzscheme - (require mzlib/unit - (lib "stacktrace.ss" "errortrace") - mzlib/class - mzlib/list - mzlib/etc - mzlib/file - "drsig.ss" - framework - mred - string-constants - (lib "bday.ss" "framework" "private") - "bindings-browser.ss") +#lang scheme/base + +(require scheme/unit + errortrace/stacktrace + scheme/class + scheme/path + framework + scheme/gui/base + string-constants + framework/private/bday + "drsig.ss" + "bindings-browser.ss" + (for-syntax scheme/base)) + +(define orig (current-output-port)) + +(provide debug@) +(define-unit debug@ + (import [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix drscheme:init: drscheme:init^]) + (export drscheme:debug^) - (define orig (current-output-port)) - (provide debug@) - (define-unit debug@ - (import [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix drscheme:init: drscheme:init^]) - (export drscheme:debug^) - - - (define (printf . args) (apply fprintf orig args)) - - -; -; -; ; -; ; ; -; ; -; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;; -; ;; ; ; ; ; ;; ; ; ; ; ;; ; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ;; ; ;; ; ; ; ; ; ; -; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ; -; ; -; ;;; -; - - ;; type debug-source = (union symbol (instanceof editor<%>)) - - ;; original-output-port : output-port - ;; 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) - (list-ref x 2) - (list-ref x 3) - (list-ref x 4))) - (continuation-mark-set->list cms cm-key))) - - ;; error-delta : (instanceof style-delta%) - (define error-delta (make-object style-delta% 'change-style 'italic)) - (send error-delta set-delta-foreground (make-object color% 255 0 0)) - - ;; get-error-color : -> (instanceof color%) - (define get-error-color - (let ([w-o-b (make-object color% 63 0 0)] - [b-o-w (make-object color% "PINK")]) - (λ () - (if (preferences:get 'framework:white-on-black?) - w-o-b - b-o-w)))) - - (define (clickable-snip-mixin snip%) - (class snip% - (init-rest args) - (inherit get-flags set-flags get-admin get-extent) - - (define callback void) - (define/public (set-callback cb) (set! callback cb)) - (define/public (get-callback) callback) - - (define grabbed? #f) - (define clicked? #f) - (define mouse-x #f) - (define mouse-y #f) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (super draw dc x y left top right bottom dx dy draw-caret) - (when clicked? - (let ([brush (send dc get-brush)] - [pen (send dc get-pen)]) - (let-values ([(w h) (get-w/h dc)]) - (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite)) - (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) - (send dc draw-rectangle x y w h) - (send dc set-pen pen) - (send dc set-brush brush))))) - - (define/override (on-event dc x y editorx editory evt) - (cond - [(send evt button-down? 'left) - (set! grabbed? #t) - (set! clicked? #t) - (set! mouse-x x) - (invalidate dc)] - [(send evt leaving?) - (set! clicked? #f) - (set! mouse-x #f) - (set! mouse-y #f) - (invalidate dc)] - [(send evt button-up? 'left) - (when clicked? - (callback)) - (set! grabbed? #f) - (set! clicked? #f) - (invalidate dc)])) - - (define/private (invalidate dc) - (let ([admin (get-admin)]) - (when admin - (let-values ([(w h) (get-w/h dc)]) - (send admin needs-update this 0 0 w h))))) - - (define/private (get-w/h dc) - (let ([wb (box 0)] - [hb (box 0)]) - ;; know that the snip is the same size everywhere, - ;; so just use (0,0) for its position - (get-extent dc 0 0 wb hb #f #f #f #f) - (values (unbox wb) - (unbox hb)))) - - (apply super-make-object args) - (set-flags (cons 'handles-events (get-flags))))) - - (define clickable-image-snip% (clickable-snip-mixin image-snip%)) - (define clickable-string-snip% - (class (clickable-snip-mixin string-snip%) - (inherit get-callback set-callback) - (init-field str) - (define/override (copy) - (let ([n (new clickable-string-snip% [str str])]) - (send n set-callback (get-callback)) - n)) - (super-make-object str))) - - ;; make-note% : string -> (union class #f) - (define (make-note% filename flag) - (let ([bitmap (make-object bitmap% - (build-path (collection-path "icons") filename) - flag)]) - (and (send bitmap ok?) - (letrec ([note% - (class clickable-image-snip% - (inherit get-callback) - (define/public (get-image-name) filename) - (define/override (copy) - (let ([n (new note%)]) - (send n set-callback (get-callback)) - n)) - (super-make-object bitmap))]) - note%)))) - - (define bug-note% (make-note% "stop-multi.png" 'png/mask)) - (define mf-note% (make-note% "mf.gif" 'gif)) - (define file-note% (make-note% "stop-32x32.png" 'gif)) - - ;; display-stats : (syntax -> syntax) - ;; count the number of syntax expressions & number of with-continuation-marks in an - ;; expanded expression ... except that it counts keywords, too. - ;; returns its argument. - ;(define (display-stats stx) - ; (let ([exps 0] - ; [wcms 0]) - ; (let loop ([stx stx]) - ; (kernel-syntax-case stx () - ; [(#%with-continuation-mark key mark body) - ; (set! wcms (+ wcms 1)) - ; (loop #`body)] - ; [(subexps ...) - ; (set! exps (+ exps 1)) - ; (for-each loop (syntax->list stx))] - ; [exp - ; (set! exps (+ exps 1))])) - ; (fprintf (current-error-port) "exps: ~v\nwcms: ~v\n" exps wcms)) - ; stx) - - ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value - ;; adds debugging information to `sexp' and calls `oe' - (define (make-debug-eval-handler oe) - (let ([debug-tool-eval-handler - (λ (orig-exp) - (if (compiled-expression? (if (syntax? orig-exp) - (syntax-e orig-exp) - orig-exp)) - (oe orig-exp) - (let loop ([exp (if (syntax? orig-exp) - orig-exp - (namespace-syntax-introduce - (datum->syntax-object #f orig-exp)))]) - (let ([top-e (expand-syntax-to-top-form exp)]) - (syntax-case top-e (begin) - [(begin expr ...) - ;; Found a `begin', so expand/eval each contained - ;; expression one at a time - (let i-loop ([exprs (syntax->list #'(expr ...))] - [last-one (list (void))]) - (cond - [(null? exprs) - (apply values last-one)] - [else - (i-loop (cdr exprs) - (call-with-values - (λ () - (call-with-continuation-prompt - (λ () (loop (car exprs))) - (default-continuation-prompt-tag) - (λ args - (apply - abort-current-continuation - (default-continuation-prompt-tag) - args)))) - list))]))] - [_else - ;; Not `begin', so proceed with normal expand and eval - (let* ([annotated (annotate-top (expand-syntax top-e) #f)]) - (oe annotated))])))))]) - debug-tool-eval-handler)) - - ;; make-debug-error-display-handler/text : (-> (union #f (is-a?/c text%))) - ;; ((listof (list text% number number)) -> void) - ;; (string (union TST exn) -> void) - ;; -> string (union TST exn) - ;; -> void - (define (make-debug-error-display-handler/text get-rep highlight-errors orig-error-display-handler) - (define (debug-error-display-handler msg exn) - (let ([rep (get-rep)]) - (cond - [rep - (show-error-and-highlight - msg - exn - (λ (srcs-to-display cms) - (parameterize ([current-eventspace drscheme:init:system-eventspace]) - (queue-callback - (λ () - ;; need to make sure that the user's eventspace is still the same - ;; and still running here? - (highlight-errors rep srcs-to-display cms))))))] - [else - (orig-error-display-handler msg exn)]))) - debug-error-display-handler) - - (define (print-bug-to-stderr msg cms) - (when (port-writes-special? (current-error-port)) - (let ([note% (if (mf-bday?) mf-note% bug-note%)]) - (when note% - (let ([note (new note%)]) - (send note set-callback (λ () (show-backtrace-window msg cms))) - (write-special note (current-error-port)) - (display #\space (current-error-port)) ))))) - - (define (show-error-and-highlight msg exn highlight-errors) - (let ([cms - (and (exn? exn) - (continuation-mark-set? (exn-continuation-marks exn)) - (cms->srclocs (exn-continuation-marks exn)))]) - (when (and cms - (pair? cms)) - (print-bug-to-stderr msg cms)) - (let ([srcs-to-display (find-src-to-display exn cms)]) - (for-each display-srcloc-in-error srcs-to-display) - (display msg (current-error-port)) - (when (exn:fail:syntax? exn) - (show-syntax-error-context (current-error-port) exn)) - (newline (current-error-port)) - - ;; need to flush here so that error annotations inserted in next line - ;; don't get erased if this output were to happen after the insertion - (flush-output (current-error-port)) - - (highlight-errors srcs-to-display cms)))) - - ;; display-srcloc-in-error : text% -> src-loc -> void - ;; prints out the src location information for src-to-display - ;; as it would appear in an error message - (define (display-srcloc-in-error src-to-display) - (let* ([raw-src (srcloc-source src-to-display)] - [src (let ([defns-text (let ([rep (drscheme:rep:current-rep)]) - (and (is-a? rep drscheme:rep:text<%>) - (send rep get-definitions-text)))]) - (and (not (and defns-text - (send defns-text port-name-matches? raw-src))) - raw-src))]) - - (when (and (path? src) file-note%) - (when (port-writes-special? (current-error-port)) - (let ([note (new file-note%)]) - (send note set-callback - (λ () (open-and-highlight-in-file src-to-display))) - (write-special note (current-error-port)) - (display #\space (current-error-port)))) - (display (path->string (find-relative-path (current-directory) - (normalize-path src))) - (current-error-port)) - (let ([line (srcloc-line src-to-display)] - [col (srcloc-column src-to-display)] - [pos (srcloc-position src-to-display)]) - (cond - [(and (number? line) (number? col)) - (fprintf (current-error-port) ":~a:~a" line col)] - [pos - (fprintf (current-error-port) "::~a" pos)])) - (display ": " (current-error-port))))) - - ;; find-src-to-display : exn (union #f (listof srcloc)) - ;; -> (listof srclocs) - ;; finds the source location to display, choosing between - ;; the stack trace and the exception record. - (define (find-src-to-display exn cms) - (let ([has-info? - (λ (srcloc) - (ormap (λ (f) (f srcloc)) - (list srcloc-column - srcloc-line - srcloc-position - srcloc-source - #;srcloc-span)))]) ;; don't consider span alone to count as `info' - (cond - [(and (exn:srclocs? exn) - (ormap has-info? ((exn:srclocs-accessor exn) exn))) - ((exn:srclocs-accessor exn) exn)] - [(pair? cms) (list (car cms))] - [else '()]))) - - - (define (show-syntax-error-context port exn) - (let ([error-text-style-delta (make-object style-delta%)] - [send-out - (λ (msg f) - (if (port-writes-special? (current-error-port)) - (let ([snp (make-object string-snip% msg)]) - (f snp) - (write-special snp (current-error-port))) - (display msg (current-error-port))))]) - (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) - (send-out " in:" void) - (let ([show-one - (λ (expr) - (display " " (current-error-port)) - (send-out (format "~s" (syntax-object->datum expr)) - (λ (snp) - (send snp set-style - (send the-style-list find-or-create-style - (send snp get-style) - error-text-style-delta)))))] - [exprs (exn:fail:syntax-exprs exn)]) - (cond - [(null? exprs) (void)] - [(null? (cdr exprs)) (show-one (car exprs))] - [else - (for-each (λ (expr) - (display "\n " (current-error-port)) - (show-one expr)) - exprs)])))) - - ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void - ;; adds in the bug icon, if there are contexts to display - (define (make-debug-error-display-handler orig-error-display-handler) - (make-debug-error-display-handler/text - (λ () - (let ([rep (drscheme:rep:current-rep)]) - (and (is-a? rep drscheme:rep:text<%>) - (eq? (send rep get-err-port) (current-error-port)) - rep))) - (λ (rep errs arrows) (send rep highlight-errors errs arrows)) - orig-error-display-handler)) - - - ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void) - ;; inserts `note' and a space at the end of `rep' - ;; also sets a clickback on the inserted `note' (but not the space). - (define (insert/clickback rep note clickback) - (let ([before (send rep last-position)]) - (send rep insert (if (string? note) - note - (send note copy)) - before before) - (let ([after (send rep last-position)]) - (send rep insert #\space after after) - (send rep set-clickback before after - (λ (txt start end) - (clickback)))))) - - ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax - ;; a member of stacktrace-imports^ - ;; guarantees that the continuation marks associated with cm-key are - ;; members of the debug-source type, after unwrapped with st-mark-source - (define (with-mark src-stx expr) - (let ([source (cond - [(path? (syntax-source src-stx)) - (syntax-source src-stx)] - [(is-a? (syntax-source src-stx) editor<%>) - (syntax-source src-stx)] - [else - (let* ([rep (drscheme:rep:current-rep)]) - (and - rep - (let ([defs (send rep get-definitions-text)]) - (cond - [(send rep port-name-matches? (syntax-source src-stx)) - rep] - [(send defs port-name-matches? (syntax-source src-stx)) - defs] - [else #f]))))])] - [position (or (syntax-position src-stx) 0)] - [span (or (syntax-span src-stx) 0)] - [line (or (syntax-line src-stx) 0)] - [column (or (syntax-column src-stx) 0)]) - (if source - (with-syntax ([expr expr] - [mark (list source line column position span)] - [cm-key cm-key]) - (syntax - (with-continuation-mark 'cm-key - 'mark - expr))) - expr))) - - ;; current-backtrace-window : (union #f (instanceof frame:basic<%>)) - ;; the currently visible backtrace window, or #f, if none - (define current-backtrace-window #f) - - ;; reset-backtrace-window : -> void - ;; effect: updates current-backtrace-window - ;; closes the current backtrace window and creates a new (unshown) one - (define (reset-backtrace-window) - (when current-backtrace-window - (send current-backtrace-window close) - (set! current-backtrace-window #f)) + (define (printf . args) (apply fprintf orig args)) + + + ; + ; + ; ; + ; ; ; + ; ; + ; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;; + ; ;; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ; + ; ; + ; ;;; + ; + + ;; type debug-source = (union symbol (instanceof editor<%>)) + + ;; original-output-port : output-port + ;; 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) + (list-ref x 2) + (list-ref x 3) + (list-ref x 4))) + (continuation-mark-set->list cms cm-key))) + + ;; error-delta : (instanceof style-delta%) + (define error-delta (make-object style-delta% 'change-style 'italic)) + (send error-delta set-delta-foreground (make-object color% 255 0 0)) + + ;; get-error-color : -> (instanceof color%) + (define get-error-color + (let ([w-o-b (make-object color% 63 0 0)] + [b-o-w (make-object color% "PINK")]) + (λ () + (if (preferences:get 'framework:white-on-black?) + w-o-b + b-o-w)))) + + (define arrow-cursor (make-object cursor% 'arrow)) + (define (clickable-snip-mixin snip%) + (class snip% + (init-rest args) + (inherit get-flags set-flags get-admin get-extent) - (set! current-backtrace-window - (make-object backtrace-frame% - (string-constant backtrace-window-title) - #f - (preferences:get 'drscheme:backtrace-window-width) - (preferences:get 'drscheme:backtrace-window-height) - (preferences:get 'drscheme:backtrace-window-x) - (preferences:get 'drscheme:backtrace-window-y)))) - - ;; hide-backtrace-window : -> void - (define (hide-backtrace-window) - (when current-backtrace-window - (send current-backtrace-window close) - (set! current-backtrace-window #f))) - - ;; backtrace-frame% : (extends frame:basic<%>) - (define backtrace-frame% - (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) - (define/override (on-size x y) - (preferences:set 'drscheme:backtrace-window-width x) - (preferences:set 'drscheme:backtrace-window-height y) - (super on-size x y)) - (define/override (on-move x y) - (preferences:set 'drscheme:backtrace-window-x x) - (preferences:set 'drscheme:backtrace-window-y y) - (super on-move x y)) - (define/override (edit-menu:between-find-and-preferences edit-menu) (void)) - (define/override (edit-menu:between-select-all-and-find edit-menu) (void)) - (define/override (file-menu:between-save-as-and-print file-menu) (void)) - (define/augment (on-close) - (set! current-backtrace-window #f) - (inner (void) on-close)) - (super-new))) - - ;; show-backtrace-window : string - ;; (listof srcloc?) - ;; -> - ;; void - (define (show-backtrace-window error-text dis/exn) - (let ([dis (if (exn? dis/exn) - (cms->srclocs (exn-continuation-marks dis/exn)) - dis/exn)]) - (reset-backtrace-window) - (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))] - [mf-bday-note (when (mf-bday?) - (instantiate message% () - (label (string-constant happy-birthday-matthias)) - (parent (send current-backtrace-window get-area-container))))] - [ec (make-object (canvas:color-mixin canvas:wide-snip%) - (send current-backtrace-window get-area-container) - text)] - [di-vec (list->vector dis)] - [index 0] - [how-many-at-once 15] - [show-next-dis - (λ () - (let ([start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) - (send text begin-edit-sequence) - (send text set-position (send text last-position)) - (let loop ([n index]) - (cond - [(and (< n (vector-length di-vec)) - (< n (+ index how-many-at-once))) - (show-frame ec text (vector-ref di-vec n)) - (loop (+ n 1))] - [else - (set! index n)])) - - ;; add 'more frames' link - (when (< index (vector-length di-vec)) - (let ([end-of-current (send text last-position)]) - (send text insert #\newline) - (let ([hyper-start (send text last-position)]) - (send text insert - (let* ([num-left - (- (vector-length di-vec) - index)] - [num-to-show - (min how-many-at-once - num-left)]) - (if (= num-left 1) - (string-constant last-stack-frame) - (format (if (num-left . <= . num-to-show) - (string-constant last-stack-frames) - (string-constant next-stack-frames)) - num-to-show)))) - (let ([hyper-end (send text last-position)]) - (send text change-style (gui-utils:get-clickback-delta - (preferences:get 'framework:white-on-black?)) - hyper-start hyper-end) - (send text set-clickback - hyper-start hyper-end - (λ x - (send text begin-edit-sequence) - (send text lock #f) - (send text delete end-of-current (send text last-position)) - (show-next-dis) - (send text set-position - (send text last-position) - (send text last-position)) - (send text lock #t) - (send text end-edit-sequence))) - - (send text insert #\newline) - (send text set-paragraph-alignment (send text last-paragraph) 'center))))) - - (send text set-position start-pos end-pos) - (send text end-edit-sequence)))]) - (send current-backtrace-window set-alignment 'center 'center) - (send current-backtrace-window reflow-container) - (send text auto-wrap #t) - (send text set-autowrap-bitmap #f) - (send text insert error-text) - (send text insert "\n\n") - (send text change-style error-delta 0 (- (send text last-position) 1)) - (show-next-dis) - (send text set-position 0 0) - (send text lock #t) - (send text hide-caret #t) - (send current-backtrace-window show #t)))) - - ;; show-frame : (instanceof editor-canvas%) - ;; (instanceof text%) - ;; st-mark? - ;; -> - ;; void - ;; shows one frame of the continuation - (define (show-frame editor-canvas text di) - (let* ([debug-source (srcloc-source di)] - [line (srcloc-line di)] - [column (srcloc-column di)] - [start (srcloc-position di)] - [span (srcloc-span di)] - [fn (get-filename debug-source)] - [start-pos (send text last-position)]) - - ;; make hyper link to the file - (send text insert (format "~a: ~a:~a" fn line column)) - (let ([end-pos (send text last-position)]) - (send text insert " ") - (send text change-style - (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?)) - start-pos - end-pos) - (send text set-clickback - start-pos end-pos - (λ x - (open-and-highlight-in-file (make-srcloc debug-source #f #f start span))))) - - ;; make bindings hier-list - (let ([bindings (st-mark-bindings di)]) - (when (not (null? bindings)) - (send text insert (render-bindings/snip bindings)))) - (send text insert #\newline) - - (insert-context editor-canvas text debug-source start span) - (send text insert #\newline))) - - ;; insert-context : (instanceof editor-canvas%) - ;; (instanceof text%) - ;; debug-info - ;; number - ;; -> - ;; void - (define (insert-context editor-canvas text file start span) - (let-values ([(from-text close-text) - (cond - [(symbol? file) - ;; can this case happen? - (let ([text (new text:basic%)]) - (if (send text load-file (symbol->string file)) - (values text - (λ () (send text on-close))) - (values #f (λ () (void)))))] - [(path? file) - (let ([text (new text:basic%)]) - (if (send text load-file file) - (values text - (λ () (send text on-close))) - (values #f (λ () (void)))))] - [(is-a? file editor<%>) - (values file void)] - [else (error 'insert-context "unknown file spec ~e" file)])]) - (when from-text - (let* ([finish (+ start span -1)] - [context-text (copy/highlight-text from-text start finish)]) - (send context-text lock #t) - (send context-text hide-caret #t) - (send text insert " ") - (let ([snip (make-object editor-snip% context-text)]) - (send snip use-style-background #t) - (send editor-canvas add-wide-snip snip) - (let ([p (send text last-position)]) - (send text insert snip p p) - (send text insert #\newline) - (when (preferences:get 'framework:white-on-black?) - (send text change-style white-on-black-style p (+ p 1)))))) - (close-text)))) - - (define white-on-black-style (make-object style-delta%)) - (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white")) - - ;; copy/highlight-text : text number number -> text - ;; copies the range from `start' to `finish', including the entire paragraph at - ;; each end and highlights the characters corresponding the original range, - ;; in the resulting text - (define (copy/highlight-text from-text start finish) - (let* ([to-text (new text:standard-style-list%)] - [para-start-pos (send from-text paragraph-start-position - (send from-text position-paragraph start))] - [para-end-pos (send from-text paragraph-end-position - (send from-text position-paragraph - finish))] - [from-start (- start para-start-pos)] - [from-end (+ from-start (- finish start))]) - (send from-text split-snip para-start-pos) - (send from-text split-snip para-end-pos) - (let loop ([snip (send from-text find-snip para-start-pos 'after-or-none)]) - (when (and snip - (< (send from-text get-snip-position snip) para-end-pos)) - (send to-text insert (send snip copy)) - (loop (send snip next)))) - (send to-text highlight-range (- from-start 1) from-end (get-error-color) #f #f 'high) - to-text)) - - ;; get-filename : debug-source -> string - (define (get-filename file) - (cond - [(symbol? file) (symbol->string file)] - [(path? file) (path->string file)] - [(is-a? file editor<%>) - (get-filename-from-editor file)])) - - ;; get-filename-from-editor : (is-a?/c editor<%>) -> string - (define (get-filename-from-editor editor) - (let* ([untitled (string-constant unknown-debug-frame)] - [canvas (send editor get-canvas)] - [frame (and canvas (send canvas get-top-level-window))]) - (if (is-a? frame drscheme:unit:frame%) - (let ([filename (send (send frame get-definitions-text) get-filename)]) - (cond - [(and filename (eq? editor (send frame get-interactions-text))) - (format (string-constant files-interactions) filename)] - [(eq? editor (send frame get-interactions-text)) - (string-constant current-interactions)] - [filename filename] - [else (string-constant current-definitions)])) - (or (send editor get-filename) - untitled)))) - - ;; open-and-highlight-in-file : srcloc -> void - (define (open-and-highlight-in-file srcloc) - (let* ([debug-source (srcloc-source srcloc)] - [position (srcloc-position srcloc)] - [span (srcloc-span srcloc)] - [frame (cond - [(path? debug-source) (handler:edit-file debug-source)] - [(is-a? debug-source editor<%>) - (let ([canvas (send debug-source get-canvas)]) - (and canvas - (send canvas get-top-level-window)))])] - [editor (cond - [(path? debug-source) - (cond - [(and frame (is-a? frame drscheme:unit:frame%)) - (send frame get-definitions-text)] - [(and frame (is-a? frame frame:editor<%>)) - (send frame get-editor)] - [else #f])] - [(is-a? debug-source editor<%>) debug-source])] - [rep (and (is-a? frame drscheme:unit:frame%) - (send frame get-interactions-text))]) - (when frame - (send frame show #t)) - (when (and rep editor) - (when (is-a? editor text:basic<%>) - (send rep highlight-error editor position (+ position span)) - (send editor set-caret-owner #f 'global))))) - - - - ; - ; - ; - ; - ; - ; ; ; - ; ;;;; ;;; ;;; ;;;; ;;; ;;; ; ; ;;; ; ; ;;; ;; ; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; - ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;;;; ;; ; ; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; - ; ;; ;;;; ;;; ;; ;;; ;;; ; ;;;; ; ;;;;; ;; ; ;;;; - ; ; - ; ; ; - ; ;;;; - - - (define test-coverage-enabled (make-parameter #f)) - - (define current-test-coverage-info (make-thread-cell #f)) - - (define (initialize-test-coverage-point key expr) - (unless (hash-table? (thread-cell-ref current-test-coverage-info)) - (let ([rep (drscheme:rep:current-rep)]) - (when rep - (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) - (when (eq? ut (current-thread)) - (let ([ht (make-hash-table)]) - (thread-cell-set! current-test-coverage-info ht) - (send rep set-test-coverage-info ht))))))) - (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when (hash-table? ht) - ;; if rep isn't around, we don't do test coverage... - ;; this can happen when check syntax expands, for example - (hash-table-put! ht key (mcons #f expr))))) - - (define (test-covered key) - (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when (hash-table? ht) ;; as in the `when' test in `initialize-test-coverage-point' - (let ([v (hash-table-get ht key)]) - (set-mcar! v #t))))) - - (define test-coverage-interactions-text<%> - (interface () - set-test-coverage-info - get-test-coverage-info)) - - (define test-coverage-tab<%> - (interface () - show-test-coverage-annotations ;; hash-table (union #f style) (union #f style) boolean -> void - get-test-coverage-info-visible? - ask-about-clearing-test-coverage?)) - - (define test-coverage-interactions-text-mixin - (mixin (drscheme:rep:text<%> text:basic<%>) (test-coverage-interactions-text<%>) - (inherit get-context) - (field [test-coverage-info #f] - [test-coverage-on-style #f] - [test-coverage-off-style #f] - [ask-about-reset? #f]) - (define/public set-test-coverage-info - (opt-lambda (ht [on-style #f] [off-style #f] [ask? #t]) - (set! test-coverage-info ht) - (set! test-coverage-on-style on-style) - (set! test-coverage-off-style off-style) - (set! ask-about-reset? ask?))) - (define/public (get-test-coverage-info) - test-coverage-info) - - (inherit get-top-level-window) - (define/augment (after-many-evals) - (when test-coverage-info - (send (get-context) show-test-coverage-annotations - test-coverage-info - test-coverage-on-style - test-coverage-off-style - ask-about-reset?)) - (inner (void) after-many-evals)) - - (super-new))) - - (define test-coverage-definitions-text-mixin - (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () - (inherit get-canvas get-tab) - - (define/private (clear-test-coverage?) - (if (preferences:get 'drscheme:test-coverage-ask-about-clearing?) - (let ([msg-box-result - (message-box/custom - (string-constant drscheme) - (string-constant test-coverage-clear?) - (string-constant yes) - (string-constant no) - (string-constant test-coverage-clear-and-do-not-ask-again) - (send (get-canvas) get-top-level-window) - '(default=1) - 2)]) - (case msg-box-result - [(1) #t] - [(2) #f] - [(3) - (preferences:set 'drscheme:test-coverage-ask-about-clearing? #f) - #t])) - #t)) - - (define/public (clear-test-coverage) - (let ([tab (get-tab)]) - (when (send tab get-test-coverage-info-visible?) - (send tab clear-test-coverage-display) - (let ([it (send tab get-ints)]) - (when (is-a? it test-coverage-interactions-text<%>) - (send it set-test-coverage-info #f)))))) - - (define/private (can-clear-coverage?) - (let ([tab (get-tab)]) - (or (not tab) - (not (send tab get-test-coverage-info-visible?)) - (not (send tab ask-about-clearing-test-coverage?)) - (clear-test-coverage?)))) - - (define/augment (can-insert? x y) - (and (inner #t can-insert? x y) - (can-clear-coverage?))) - - (define/augment (can-delete? x y) - (and (inner #t can-delete? x y) - (can-clear-coverage?))) - - (define/augment (after-insert x y) - (inner (void) after-insert x y) - (clear-test-coverage)) - - (define/augment (after-delete x y) - (inner (void) after-delete x y) - (clear-test-coverage)) - - (super-new))) - - (define test-covered-style-delta (make-object style-delta%)) - (send test-covered-style-delta set-delta-foreground "forest green") - - (define test-not-covered-style-delta (make-object style-delta%)) - (send test-not-covered-style-delta set-delta-foreground "firebrick") - - (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color)) - - (define test-coverage-tab-mixin - (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) (test-coverage-tab<%>) - - (field [internal-clear-test-coverage-display #f]) - - (define/public (clear-test-coverage-display) - (when internal-clear-test-coverage-display - (internal-clear-test-coverage-display) - (set! internal-clear-test-coverage-display #f))) - - (field [ask-about-reset? #t]) - (define/public (ask-about-clearing-test-coverage?) ask-about-reset?) - - (define/public (get-test-coverage-info-visible?) - (not (not internal-clear-test-coverage-display))) - - (define/public (show-test-coverage-annotations ht on-style off-style ask?) - (set! ask-about-reset? ask?) - (let* ([edit-sequence-ht (make-hash-table)] - [locked-ht (make-hash-table)] - [already-frozen-ht (make-hash-table)] - [actions-ht (make-hash-table 'equal)] - [on/syntaxes (hash-table-map ht (λ (_ pr) pr))] - - ;; can-annotate : (listof (list boolean srcloc)) - ;; boolean is #t => code was run - ;; #f => code was not run - ;; remove those that cannot be annotated - [can-annotate - (filter values - (map (λ (pr) - (let ([stx (mcdr pr)]) - (and (syntax? stx) - (let ([src (syntax-source stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (and pos - span - (send (get-defs) port-name-matches? src) - (list (mcar pr) (make-srcloc (get-defs) #f #f pos span))))))) - on/syntaxes))] - - ;; filtered : (listof (list boolean srcloc)) - ;; remove redundant expressions - [filtered - (let (;; actions-ht : (list src number number) -> (list boolean syntax) - [actions-ht (make-hash-table 'equal)]) - (for-each - (λ (pr) - (let* ([on? (list-ref pr 0)] - [key (list-ref pr 1)] - [old (hash-table-get actions-ht key 'nothing)]) - (cond - [(eq? old 'nothing) (hash-table-put! actions-ht key on?)] - [old ;; recorded as executed - (void)] - [(not old) ;; recorded as unexected - (when on? - (hash-table-put! actions-ht key #t))]))) - can-annotate) - (hash-table-map actions-ht (λ (k v) (list v k))))]) - - ;; if everything is covered *and* no coloring has been done, do no coloring. - (unless (and (andmap car filtered) - (not (get-test-coverage-info-visible?))) - - (let (;; sorted : (listof (list boolean srcloc)) - ;; sorting predicate: - ;; x < y if - ;; x's span is bigger than y's (ie, do larger expressions first) - ;; unless x and y are the same source location. - ;; in that case, color red first and then green - [sorted - (sort - filtered - (λ (x y) - (let* ([x-on (list-ref x 0)] - [y-on (list-ref y 0)] - [x-srcloc (list-ref x 1)] - [y-srcloc (list-ref y 1)] - [x-pos (srcloc-position x-srcloc)] - [y-pos (srcloc-position y-srcloc)] - [x-span (srcloc-span x-srcloc)] - [y-span (srcloc-span y-srcloc)]) + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/public (get-callback) callback) + + (define grabbed? #f) + (define clicked? #f) + (define mouse-x #f) + (define mouse-y #f) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (super draw dc x y left top right bottom dx dy draw-caret) + (when clicked? + (let ([brush (send dc get-brush)] + [pen (send dc get-pen)]) + (let-values ([(w h) (get-w/h dc)]) + (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite)) + (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) + (send dc draw-rectangle x y w h) + (send dc set-pen pen) + (send dc set-brush brush))))) + + (define/override (on-event dc x y editorx editory evt) + (cond + [(send evt button-down? 'left) + (set! grabbed? #t) + (set! clicked? #t) + (set! mouse-x x) + (invalidate dc)] + [(send evt leaving?) + (set! clicked? #f) + (set! mouse-x #f) + (set! mouse-y #f) + (invalidate dc)] + [(send evt button-up? 'left) + (when clicked? + (callback)) + (set! grabbed? #f) + (set! clicked? #f) + (invalidate dc)])) + + (define/private (invalidate dc) + (let ([admin (get-admin)]) + (when admin + (let-values ([(w h) (get-w/h dc)]) + (send admin needs-update this 0 0 w h))))) + + (define/private (get-w/h dc) + (let ([wb (box 0)] + [hb (box 0)]) + ;; know that the snip is the same size everywhere, + ;; so just use (0,0) for its position + (get-extent dc 0 0 wb hb #f #f #f #f) + (values (unbox wb) + (unbox hb)))) + + (define/override (adjust-cursor dc x y editorx editory event) + arrow-cursor) + + (apply super-make-object args) + (set-flags (cons 'handles-events (get-flags))))) + + (define clickable-image-snip% (clickable-snip-mixin image-snip%)) + (define clickable-string-snip% + (class (clickable-snip-mixin string-snip%) + (inherit get-callback set-callback) + (init-field str) + (define/override (copy) + (let ([n (new clickable-string-snip% [str str])]) + (send n set-callback (get-callback)) + n)) + (super-make-object str))) + + ;; make-note% : string -> (union class #f) + (define (make-note% filename flag) + (let ([bitmap (make-object bitmap% + (build-path (collection-path "icons") filename) + flag)]) + (and (send bitmap ok?) + (letrec ([note% + (class clickable-image-snip% + (inherit get-callback) + (define/public (get-image-name) filename) + (define/override (copy) + (let ([n (new note%)]) + (send n set-callback (get-callback)) + n)) + (super-make-object bitmap))]) + note%)))) + + (define bug-note% (make-note% "stop-multi.png" 'png/mask)) + (define mf-note% (make-note% "mf.gif" 'gif)) + (define file-note% (make-note% "stop-22x22.png" 'png/mask)) + + ;; display-stats : (syntax -> syntax) + ;; count the number of syntax expressions & number of with-continuation-marks in an + ;; expanded expression ... except that it counts keywords, too. + ;; returns its argument. + ;(define (display-stats stx) + ; (let ([exps 0] + ; [wcms 0]) + ; (let loop ([stx stx]) + ; (kernel-syntax-case stx () + ; [(#%with-continuation-mark key mark body) + ; (set! wcms (+ wcms 1)) + ; (loop #`body)] + ; [(subexps ...) + ; (set! exps (+ exps 1)) + ; (for-each loop (syntax->list stx))] + ; [exp + ; (set! exps (+ exps 1))])) + ; (fprintf (current-error-port) "exps: ~v\nwcms: ~v\n" exps wcms)) + ; stx) + + ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value + ;; adds debugging information to `sexp' and calls `oe' + (define (make-debug-eval-handler oe) + (let ([debug-tool-eval-handler + (λ (orig-exp) + (if (compiled-expression? (if (syntax? orig-exp) + (syntax-e orig-exp) + orig-exp)) + (oe orig-exp) + (let loop ([exp (if (syntax? orig-exp) + orig-exp + (namespace-syntax-introduce + (datum->syntax #f orig-exp)))]) + (let ([top-e (expand-syntax-to-top-form exp)]) + (syntax-case top-e (begin) + [(begin expr ...) + ;; Found a `begin', so expand/eval each contained + ;; expression one at a time + (let i-loop ([exprs (syntax->list #'(expr ...))] + [last-one (list (void))]) (cond - [(and (= x-pos y-pos) - (= x-span x-span)) - (or y-on - (not x-on))] - [else (>= x-span y-span)]))))]) - - ;; turn on edit-sequences in all editors to be touched by new annotations - ;; also fill in the edit-sequence-ht - (for-each - (λ (pr) - (let ([src (srcloc-source (list-ref pr 1))]) - (hash-table-get - edit-sequence-ht - src - (λ () - (hash-table-put! edit-sequence-ht src #f) - (send src begin-edit-sequence #f) - (when (send src is-locked?) - (hash-table-put! locked-ht src #t) - (send src lock #f)))))) - sorted) - - ;; clear out old annotations (and thaw colorers) - (when internal-clear-test-coverage-display - (internal-clear-test-coverage-display) - (set! internal-clear-test-coverage-display #f)) - - ;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw) - (hash-table-for-each - edit-sequence-ht - (λ (src _) - (if (send src is-frozen?) - (hash-table-put! already-frozen-ht src #t) - (send src freeze-colorer)))) - - ;; set new annotations - (for-each - (λ (pr) - (let ([on? (list-ref pr 0)] - [srcloc (list-ref pr 1)]) - (let* ([src (srcloc-source srcloc)] - [pos (srcloc-position srcloc)] - [span (srcloc-span srcloc)]) - (send src change-style - (if on? - (or on-style test-covered-style-delta) - (or off-style test-not-covered-style-delta)) - (- pos 1) - (+ (- pos 1) span) - #f)))) - sorted) - - ;; relock editors - (hash-table-for-each - locked-ht - (λ (txt _) (send txt lock #t))) - - ;; end edit sequences - (hash-table-for-each - edit-sequence-ht - (λ (txt _) (send txt end-edit-sequence))) - - ;; save thunk to reset these new annotations - (set! internal-clear-test-coverage-display - (λ () - (hash-table-for-each - edit-sequence-ht - (λ (txt _) - (send txt begin-edit-sequence #f))) - (hash-table-for-each - edit-sequence-ht - (λ (txt _) + [(null? exprs) + (apply values last-one)] + [else + (i-loop (cdr exprs) + (call-with-values + (λ () + (call-with-continuation-prompt + (λ () (loop (car exprs))) + (default-continuation-prompt-tag) + (λ args + (apply + abort-current-continuation + (default-continuation-prompt-tag) + args)))) + list))]))] + [_else + ;; Not `begin', so proceed with normal expand and eval + (let* ([annotated (annotate-top (expand-syntax top-e) #f)]) + (oe annotated))])))))]) + debug-tool-eval-handler)) + + ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void + ;; adds in the bug icon, if there are contexts to display + (define (make-debug-error-display-handler orig-error-display-handler) + (define (debug-error-display-handler msg exn) + (let ([rep (drscheme:rep:current-rep)]) + (cond + [rep + (error-display-handler/stacktrace + msg + exn + (and (exn? exn) + (continuation-mark-set? (exn-continuation-marks exn)) + (cms->srclocs (exn-continuation-marks exn))))] + [else + (orig-error-display-handler msg exn)]))) + debug-error-display-handler) + + ;; error-display-handler/stacktrace : string any (listof srcloc) -> void + (define (error-display-handler/stacktrace msg exn [pre-stack #f]) + (let* ([stack (or pre-stack + (if (exn? exn) + (map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn)))) + '()))] + [src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + (if (null? stack) + '() + (list (car stack))))]) + (unless (null? stack) + (print-bug-to-stderr msg stack)) + (display-srclocs-in-error src-locs) + (display msg (current-error-port)) + (when (exn:fail:syntax? exn) + (show-syntax-error-context (current-error-port) exn)) + (newline (current-error-port)) + (flush-output (current-error-port)) + (let ([rep (drscheme:rep:current-rep)]) + (when (and (is-a? rep drscheme:rep:text<%>) + (eq? (current-error-port) + (send rep get-err-port))) + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback + (λ () + ;; need to make sure that the user's eventspace is still the same + ;; and still running here? + (send rep highlight-errors src-locs stack)))))))) + + (define (print-bug-to-stderr msg cms) + (when (port-writes-special? (current-error-port)) + (let ([note% (if (mf-bday?) mf-note% bug-note%)]) + (when note% + (let ([note (new note%)]) + (send note set-callback (λ () (show-backtrace-window msg cms))) + (write-special note (current-error-port)) + (display #\space (current-error-port))))))) + + ;; display-srclocs-in-error : (listof src-loc) -> void + ;; prints out the src location information for src-to-display + ;; as it would appear in an error message + (define (display-srclocs-in-error srcs-to-display) + (unless (null? srcs-to-display) + (let ([src-to-display (car srcs-to-display)]) + (let* ([src (srcloc-source src-to-display)] + [line (srcloc-line src-to-display)] + [col (srcloc-column src-to-display)] + [pos (srcloc-position src-to-display)] + [do-icon + (λ () + (when file-note% + (when (port-writes-special? (current-error-port)) + (let ([note (new file-note%)]) + (send note set-callback + (λ () (open-and-highlight-in-file srcs-to-display))) + (write-special note (current-error-port)) + (display #\space (current-error-port))))))] + [do-src + (λ () + (cond + [(path? src) + (display (path->string (find-relative-path (current-directory) + (normalize-path src))) + (current-error-port))] + [else + (display "" (current-error-port))]))] + [do-line/col (λ () (fprintf (current-error-port) ":~a:~a" line col))] + [do-pos (λ () (fprintf (current-error-port) "::~a" pos))] + [src-loc-in-defs/ints? + (let ([rep (drscheme:rep:current-rep)]) + (and rep + (is-a? rep drscheme:rep:text<%>) + (let ([defs (send rep get-definitions-text)]) + (or (send rep port-name-matches? src) + (eq? rep src) + (send defs port-name-matches? src) + (eq? defs src)))))]) + (cond + [(and src line col) + (do-icon) + (unless src-loc-in-defs/ints? + (do-src) + (do-line/col) + (display ": " (current-error-port)))] + [(and src pos) + (do-icon) + (unless src-loc-in-defs/ints? + (do-src) + (do-pos) + (display ": " (current-error-port)))]))))) + + ;; find-src-to-display : exn (union #f (listof srcloc)) + ;; -> (listof srclocs) + ;; finds the source location to display, choosing between + ;; the stack trace and the exception record. + (define (find-src-to-display exn cms) + (let ([has-info? + (λ (srcloc) + (ormap (λ (f) (f srcloc)) + (list srcloc-column + srcloc-line + srcloc-position + srcloc-source + #;srcloc-span)))]) ;; don't consider span alone to count as `info' + (cond + [(and (exn:srclocs? exn) + (ormap has-info? ((exn:srclocs-accessor exn) exn))) + ((exn:srclocs-accessor exn) exn)] + [(pair? cms) (list (car cms))] + [else '()]))) + + (define (show-syntax-error-context port exn) + (let ([error-text-style-delta (make-object style-delta%)] + [send-out + (λ (msg f) + (if (port-writes-special? (current-error-port)) + (let ([snp (make-object string-snip% msg)]) + (f snp) + (write-special snp (current-error-port))) + (display msg (current-error-port))))]) + (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) + (send-out " in:" void) + (let ([show-one + (λ (expr) + (display " " (current-error-port)) + (send-out (format "~s" (syntax->datum expr)) + (λ (snp) + (send snp set-style + (send the-style-list find-or-create-style + (send snp get-style) + error-text-style-delta)))))] + [exprs (exn:fail:syntax-exprs exn)]) + (cond + [(null? exprs) (void)] + [(null? (cdr exprs)) (show-one (car exprs))] + [else + (for-each (λ (expr) + (display "\n " (current-error-port)) + (show-one expr)) + exprs)])))) + + + ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void) + ;; inserts `note' and a space at the end of `rep' + ;; also sets a clickback on the inserted `note' (but not the space). + (define (insert/clickback rep note clickback) + (let ([before (send rep last-position)]) + (send rep insert (if (string? note) + note + (send note copy)) + before before) + (let ([after (send rep last-position)]) + (send rep insert #\space after after) + (send rep set-clickback before after + (λ (txt start end) + (clickback)))))) + + ;; with-mark : mark-stx syntax (any? -> syntax) -> syntax + ;; a member of stacktrace-imports^ + ;; guarantees that the continuation marks associated with cm-key are + ;; members of the debug-source type, after unwrapped with st-mark-source + (define (with-mark src-stx expr) + (let ([source (cond + [(path? (syntax-source src-stx)) + (syntax-source src-stx)] + [(is-a? (syntax-source src-stx) editor<%>) + (syntax-source src-stx)] + [else + (let* ([rep (drscheme:rep:current-rep)]) + (and + rep + (let ([defs (send rep get-definitions-text)]) + (cond + [(send rep port-name-matches? (syntax-source src-stx)) + rep] + [(send defs port-name-matches? (syntax-source src-stx)) + defs] + [else #f]))))])] + [position (or (syntax-position src-stx) 0)] + [span (or (syntax-span src-stx) 0)] + [line (or (syntax-line src-stx) 0)] + [column (or (syntax-column src-stx) 0)]) + (if source + (with-syntax ([expr expr] + [mark (list source line column position span)] + [cm-key cm-key]) + (syntax + (with-continuation-mark 'cm-key + 'mark + expr))) + expr))) + + ;; current-backtrace-window : (union #f (instanceof frame:basic<%>)) + ;; the currently visible backtrace window, or #f, if none + (define current-backtrace-window #f) + + ;; reset-backtrace-window : -> void + ;; effect: updates current-backtrace-window + ;; closes the current backtrace window and creates a new (unshown) one + (define (reset-backtrace-window) + (when current-backtrace-window + (send current-backtrace-window close) + (set! current-backtrace-window #f)) + + (set! current-backtrace-window + (make-object backtrace-frame% + (string-constant backtrace-window-title) + #f + (preferences:get 'drscheme:backtrace-window-width) + (preferences:get 'drscheme:backtrace-window-height) + (preferences:get 'drscheme:backtrace-window-x) + (preferences:get 'drscheme:backtrace-window-y)))) + + ;; hide-backtrace-window : -> void + (define (hide-backtrace-window) + (when current-backtrace-window + (send current-backtrace-window close) + (set! current-backtrace-window #f))) + + ;; backtrace-frame% : (extends frame:basic<%>) + (define backtrace-frame% + (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) + (define/override (on-size x y) + (preferences:set 'drscheme:backtrace-window-width x) + (preferences:set 'drscheme:backtrace-window-height y) + (super on-size x y)) + (define/override (on-move x y) + (preferences:set 'drscheme:backtrace-window-x x) + (preferences:set 'drscheme:backtrace-window-y y) + (super on-move x y)) + (define/override (edit-menu:between-find-and-preferences edit-menu) (void)) + (define/override (edit-menu:between-select-all-and-find edit-menu) (void)) + (define/override (file-menu:between-save-as-and-print file-menu) (void)) + (define/augment (on-close) + (set! current-backtrace-window #f) + (inner (void) on-close)) + (super-new))) + + ;; show-backtrace-window : string + ;; (listof srcloc?) + ;; -> + ;; void + (define (show-backtrace-window error-text dis/exn) + (let ([dis (if (exn? dis/exn) + (cms->srclocs (exn-continuation-marks dis/exn)) + dis/exn)]) + (reset-backtrace-window) + (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))] + [mf-bday-note (when (mf-bday?) + (instantiate message% () + (label (string-constant happy-birthday-matthias)) + (parent (send current-backtrace-window get-area-container))))] + [ec (make-object (canvas:color-mixin canvas:wide-snip%) + (send current-backtrace-window get-area-container) + text)] + [di-vec (list->vector dis)] + [index 0] + [how-many-at-once 15] + [show-next-dis + (λ () + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (send text begin-edit-sequence) + (send text set-position (send text last-position)) + (let loop ([n index]) + (cond + [(and (< n (vector-length di-vec)) + (< n (+ index how-many-at-once))) + (show-frame ec text (vector-ref di-vec n)) + (loop (+ n 1))] + [else + (set! index n)])) + + ;; add 'more frames' link + (when (< index (vector-length di-vec)) + (let ([end-of-current (send text last-position)]) + (send text insert #\newline) + (let ([hyper-start (send text last-position)]) + (send text insert + (let* ([num-left + (- (vector-length di-vec) + index)] + [num-to-show + (min how-many-at-once + num-left)]) + (if (= num-left 1) + (string-constant last-stack-frame) + (format (if (num-left . <= . num-to-show) + (string-constant last-stack-frames) + (string-constant next-stack-frames)) + num-to-show)))) + (let ([hyper-end (send text last-position)]) + (send text change-style (gui-utils:get-clickback-delta + (preferences:get 'framework:white-on-black?)) + hyper-start hyper-end) + (send text set-clickback + hyper-start hyper-end + (λ x + (send text begin-edit-sequence) + (send text lock #f) + (send text delete end-of-current (send text last-position)) + (show-next-dis) + (send text set-position + (send text last-position) + (send text last-position)) + (send text lock #t) + (send text end-edit-sequence))) + + (send text insert #\newline) + (send text set-paragraph-alignment (send text last-paragraph) 'center))))) + + (send text set-position start-pos end-pos) + (send text end-edit-sequence)))]) + (send current-backtrace-window set-alignment 'center 'center) + (send current-backtrace-window reflow-container) + (send text auto-wrap #t) + (send text set-autowrap-bitmap #f) + (send text insert error-text) + (send text insert "\n\n") + (send text change-style error-delta 0 (- (send text last-position) 1)) + (show-next-dis) + (send text set-position 0 0) + (send text lock #t) + (send text hide-caret #t) + (send current-backtrace-window show #t)))) + + ;; show-frame : (instanceof editor-canvas%) + ;; (instanceof text%) + ;; st-mark? + ;; -> + ;; void + ;; shows one frame of the continuation + (define (show-frame editor-canvas text di) + (let* ([debug-source (srcloc-source di)] + [line (srcloc-line di)] + [column (srcloc-column di)] + [start (srcloc-position di)] + [span (srcloc-span di)] + [fn (get-filename debug-source)] + [start-pos (send text last-position)]) + + ;; make hyper link to the file + (send text insert (format "~a: ~a:~a" fn line column)) + (let ([end-pos (send text last-position)]) + (send text insert " ") + (send text change-style + (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?)) + start-pos + end-pos) + (send text set-clickback + start-pos end-pos + (λ x + (open-and-highlight-in-file (list (make-srcloc debug-source #f #f start span)))))) + + ;; make bindings hier-list + (let ([bindings (st-mark-bindings di)]) + (when (not (null? bindings)) + (send text insert (render-bindings/snip bindings)))) + (send text insert #\newline) + + (insert-context editor-canvas text debug-source start span) + (send text insert #\newline))) + + ;; insert-context : (instanceof editor-canvas%) + ;; (instanceof text%) + ;; debug-info + ;; number + ;; -> + ;; void + (define (insert-context editor-canvas text file start span) + (let-values ([(from-text close-text) + (cond + [(symbol? file) + ;; can this case happen? + (let ([text (new text:basic%)]) + (if (send text load-file (symbol->string file)) + (values text + (λ () (send text on-close))) + (values #f (λ () (void)))))] + [(path? file) + (let ([text (new text:basic%)]) + (if (send text load-file file) + (values text + (λ () (send text on-close))) + (values #f (λ () (void)))))] + [(is-a? file editor<%>) + (values file void)] + [else (error 'insert-context "unknown file spec ~e" file)])]) + (when from-text + (let* ([finish (+ start span -1)] + [context-text (copy/highlight-text from-text start finish)]) + (send context-text lock #t) + (send context-text hide-caret #t) + (send text insert " ") + (let ([snip (make-object editor-snip% context-text)]) + (send snip use-style-background #t) + (send editor-canvas add-wide-snip snip) + (let ([p (send text last-position)]) + (send text insert snip p p) + (send text insert #\newline) + (when (preferences:get 'framework:white-on-black?) + (send text change-style white-on-black-style p (+ p 1)))))) + (close-text)))) + + (define white-on-black-style (make-object style-delta%)) + (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white")) + + ;; copy/highlight-text : text number number -> text + ;; copies the range from `start' to `finish', including the entire paragraph at + ;; each end and highlights the characters corresponding the original range, + ;; in the resulting text + (define (copy/highlight-text from-text start finish) + (let* ([to-text (new text:standard-style-list%)] + [para-start-pos (send from-text paragraph-start-position + (send from-text position-paragraph start))] + [para-end-pos (send from-text paragraph-end-position + (send from-text position-paragraph + finish))] + [from-start (- start para-start-pos)] + [from-end (+ from-start (- finish start))]) + (send from-text split-snip para-start-pos) + (send from-text split-snip para-end-pos) + (let loop ([snip (send from-text find-snip para-start-pos 'after-or-none)]) + (when (and snip + (< (send from-text get-snip-position snip) para-end-pos)) + (send to-text insert (send snip copy)) + (loop (send snip next)))) + (send to-text highlight-range (- from-start 1) from-end (get-error-color) #f #f 'high) + to-text)) + + ;; get-filename : debug-source -> string + (define (get-filename file) + (cond + [(symbol? file) (symbol->string file)] + [(path? file) (path->string file)] + [(is-a? file editor<%>) + (get-filename-from-editor file)])) + + ;; get-filename-from-editor : (is-a?/c editor<%>) -> string + (define (get-filename-from-editor editor) + (let* ([untitled (string-constant unknown-debug-frame)] + [canvas (send editor get-canvas)] + [frame (and canvas (send canvas get-top-level-window))]) + (if (is-a? frame drscheme:unit:frame%) + (let ([filename (send (send frame get-definitions-text) get-filename)]) + (cond + [(and filename (eq? editor (send frame get-interactions-text))) + (format (string-constant files-interactions) filename)] + [(eq? editor (send frame get-interactions-text)) + (string-constant current-interactions)] + [filename filename] + [else (string-constant current-definitions)])) + (or (send editor get-filename) + untitled)))) + + ;; open-and-highlight-in-file : srcloc -> void + (define (open-and-highlight-in-file srclocs) + (let ([sources (filter values (map srcloc-source srclocs))]) + (unless (null? sources) + (let* ([debug-source (car sources)] + [same-src-srclocs + (filter (λ (x) (eq? debug-source (srcloc-source x))) + srclocs)] + [frame (cond + [(path? debug-source) (handler:edit-file debug-source)] + [(is-a? debug-source editor<%>) + (let ([canvas (send debug-source get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [else #f])] + [editor (cond + [(path? debug-source) + (cond + [(and frame (is-a? frame drscheme:unit:frame%)) + (send frame get-definitions-text)] + [(and frame (is-a? frame frame:editor<%>)) + (send frame get-editor)] + [else #f])] + [(is-a? debug-source editor<%>) debug-source])] + [rep (and (is-a? frame drscheme:unit:frame%) + (send frame get-interactions-text))]) + (when frame + (send frame show #t)) + (when (and rep editor) + (when (is-a? editor text:basic<%>) + (send rep highlight-errors same-src-srclocs '()) + (send editor set-caret-owner #f 'global))))))) + + + + ; + ; + ; + ; + ; + ; ; ; + ; ;;;; ;;; ;;; ;;;; ;;; ;;; ; ; ;;; ; ; ;;; ;; ; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; + ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;;;; ;; ; ; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; + ; ;; ;;;; ;;; ;; ;;; ;;; ; ;;;; ; ;;;;; ;; ; ;;;; + ; ; + ; ; ; + ; ;;;; + + + (define test-coverage-enabled (make-parameter #f)) + + (define current-test-coverage-info (make-thread-cell #f)) + + (define (initialize-test-coverage-point key expr) + (unless (hash? (thread-cell-ref current-test-coverage-info)) + (let ([rep (drscheme:rep:current-rep)]) + (when rep + (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) + (when (eq? ut (current-thread)) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-test-coverage-info ht) + (send rep set-test-coverage-info ht))))))) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when (hash? ht) + ;; if rep isn't around, we don't do test coverage... + ;; this can happen when check syntax expands, for example + (hash-set! ht key (mcons #f expr))))) + + (define (test-covered key) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point' + (let ([v (hash-ref ht key)]) + (set-mcar! v #t))))) + + (define test-coverage-interactions-text<%> + (interface () + set-test-coverage-info + get-test-coverage-info)) + + (define test-coverage-tab<%> + (interface () + show-test-coverage-annotations ;; hash-table (union #f style) (union #f style) boolean -> void + get-test-coverage-info-visible? + ask-about-clearing-test-coverage?)) + + (define test-coverage-interactions-text-mixin + (mixin (drscheme:rep:text<%> text:basic<%>) (test-coverage-interactions-text<%>) + (inherit get-context) + (field [test-coverage-info #f] + [test-coverage-on-style #f] + [test-coverage-off-style #f] + [ask-about-reset? #f]) + (define/public set-test-coverage-info + (λ (ht [on-style #f] [off-style #f] [ask? #t]) + (set! test-coverage-info ht) + (set! test-coverage-on-style on-style) + (set! test-coverage-off-style off-style) + (set! ask-about-reset? ask?))) + (define/public (get-test-coverage-info) + test-coverage-info) + + (inherit get-top-level-window) + (define/augment (after-many-evals) + (when test-coverage-info + (send (get-context) show-test-coverage-annotations + test-coverage-info + test-coverage-on-style + test-coverage-off-style + ask-about-reset?)) + (inner (void) after-many-evals)) + + (super-new))) + + (define test-coverage-definitions-text-mixin + (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () + (inherit get-canvas get-tab) + + (define/private (clear-test-coverage?) + (if (preferences:get 'drscheme:test-coverage-ask-about-clearing?) + (let ([msg-box-result + (message-box/custom + (string-constant drscheme) + (string-constant test-coverage-clear?) + (string-constant yes) + (string-constant no) + (string-constant test-coverage-clear-and-do-not-ask-again) + (send (get-canvas) get-top-level-window) + '(default=1) + 2)]) + (case msg-box-result + [(1) #t] + [(2) #f] + [(3) + (preferences:set 'drscheme:test-coverage-ask-about-clearing? #f) + #t])) + #t)) + + (define/public (clear-test-coverage) + (let ([tab (get-tab)]) + (when (send tab get-test-coverage-info-visible?) + (send tab clear-test-coverage-display) + (let ([it (send tab get-ints)]) + (when (is-a? it test-coverage-interactions-text<%>) + (send it set-test-coverage-info #f)))))) + + (define/private (can-clear-coverage?) + (let ([tab (get-tab)]) + (or (not tab) + (not (send tab get-test-coverage-info-visible?)) + (not (send tab ask-about-clearing-test-coverage?)) + (clear-test-coverage?)))) + + (define/augment (can-insert? x y) + (and (inner #t can-insert? x y) + (can-clear-coverage?))) + + (define/augment (can-delete? x y) + (and (inner #t can-delete? x y) + (can-clear-coverage?))) + + (define/augment (after-insert x y) + (inner (void) after-insert x y) + (clear-test-coverage)) + + (define/augment (after-delete x y) + (inner (void) after-delete x y) + (clear-test-coverage)) + + (super-new))) + + (define test-covered-style-delta (make-object style-delta%)) + (send test-covered-style-delta set-delta-foreground "forest green") + + (define test-not-covered-style-delta (make-object style-delta%)) + (send test-not-covered-style-delta set-delta-foreground "firebrick") + + (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color)) + + (define test-coverage-tab-mixin + (mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) (test-coverage-tab<%>) + + (field [internal-clear-test-coverage-display #f]) + + (define/public (clear-test-coverage-display) + (when internal-clear-test-coverage-display + (internal-clear-test-coverage-display) + (set! internal-clear-test-coverage-display #f))) + + (field [ask-about-reset? #t]) + (define/public (ask-about-clearing-test-coverage?) ask-about-reset?) + + (define/public (get-test-coverage-info-visible?) + (not (not internal-clear-test-coverage-display))) + + (define/public (show-test-coverage-annotations ht on-style off-style ask?) + (set! ask-about-reset? ask?) + (let* ([edit-sequence-ht (make-hasheq)] + [locked-ht (make-hasheq)] + [already-frozen-ht (make-hasheq)] + [actions-ht (make-hash)] + [on/syntaxes (hash-map ht (λ (_ pr) pr))] + + ;; can-annotate : (listof (list boolean srcloc)) + ;; boolean is #t => code was run + ;; #f => code was not run + ;; remove those that cannot be annotated + [can-annotate + (filter values + (map (λ (pr) + (let ([stx (mcdr pr)]) + (and (syntax? stx) + (let ([src (syntax-source stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (and pos + span + (send (get-defs) port-name-matches? src) + (list (mcar pr) (make-srcloc (get-defs) #f #f pos span))))))) + on/syntaxes))] + + ;; filtered : (listof (list boolean srcloc)) + ;; remove redundant expressions + [filtered + (let (;; actions-ht : (list src number number) -> (list boolean syntax) + [actions-ht (make-hash)]) + (for-each + (λ (pr) + (let* ([on? (list-ref pr 0)] + [key (list-ref pr 1)] + [old (hash-ref actions-ht key 'nothing)]) + (cond + [(eq? old 'nothing) (hash-set! actions-ht key on?)] + [old ;; recorded as executed + (void)] + [(not old) ;; recorded as unexected + (when on? + (hash-set! actions-ht key #t))]))) + can-annotate) + (hash-map actions-ht (λ (k v) (list v k))))]) + + ;; if everything is covered *and* no coloring has been done, do no coloring. + (unless (and (andmap car filtered) + (not (get-test-coverage-info-visible?))) + + (let (;; sorted : (listof (list boolean srcloc)) + ;; sorting predicate: + ;; x < y if + ;; x's span is bigger than y's (ie, do larger expressions first) + ;; unless x and y are the same source location. + ;; in that case, color red first and then green + [sorted + (sort + filtered + (λ (x y) + (let* ([x-on (list-ref x 0)] + [y-on (list-ref y 0)] + [x-srcloc (list-ref x 1)] + [y-srcloc (list-ref y 1)] + [x-pos (srcloc-position x-srcloc)] + [y-pos (srcloc-position y-srcloc)] + [x-span (srcloc-span x-srcloc)] + [y-span (srcloc-span y-srcloc)]) + (cond + [(and (= x-pos y-pos) + (= x-span x-span)) + (or y-on + (not x-on))] + [else (>= x-span y-span)]))))]) + + ;; turn on edit-sequences in all editors to be touched by new annotations + ;; also fill in the edit-sequence-ht + (for-each + (λ (pr) + (let ([src (srcloc-source (list-ref pr 1))]) + (hash-ref + edit-sequence-ht + src + (λ () + (hash-set! edit-sequence-ht src #f) + (send src begin-edit-sequence #f) + (when (send src is-locked?) + (hash-set! locked-ht src #t) + (send src lock #f)))))) + sorted) + + ;; clear out old annotations (and thaw colorers) + (when internal-clear-test-coverage-display + (internal-clear-test-coverage-display) + (set! internal-clear-test-coverage-display #f)) + + ;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw) + (hash-for-each + edit-sequence-ht + (λ (src _) + (if (send src is-frozen?) + (hash-set! already-frozen-ht src #t) + (send src freeze-colorer)))) + + ;; set new annotations + (for-each + (λ (pr) + (let ([on? (list-ref pr 0)] + [srcloc (list-ref pr 1)]) + (let* ([src (srcloc-source srcloc)] + [pos (srcloc-position srcloc)] + [span (srcloc-span srcloc)]) + (send src change-style + (if on? + (or on-style test-covered-style-delta) + (or off-style test-not-covered-style-delta)) + (- pos 1) + (+ (- pos 1) span) + #f)))) + sorted) + + ;; relock editors + (hash-for-each + locked-ht + (λ (txt _) (send txt lock #t))) + + ;; end edit sequences + (hash-for-each + edit-sequence-ht + (λ (txt _) (send txt end-edit-sequence))) + + ;; save thunk to reset these new annotations + (set! internal-clear-test-coverage-display + (λ () + (hash-for-each + edit-sequence-ht + (λ (txt _) + (send txt begin-edit-sequence #f))) + (hash-for-each + edit-sequence-ht + (λ (txt _) + (let ([locked? (send txt is-locked?)]) + (when locked? (send txt lock #f)) + (send txt change-style + erase-test-coverage-style-delta + 0 + (send txt last-position) + #f) + (when locked? (send txt lock #t))))) + (hash-for-each + edit-sequence-ht + (λ (txt _) + (unless (hash-ref already-frozen-ht txt #f) (let ([locked? (send txt is-locked?)]) (when locked? (send txt lock #f)) - (send txt change-style - erase-test-coverage-style-delta - 0 - (send txt last-position) - #f) - (when locked? (send txt lock #t))))) - (hash-table-for-each - edit-sequence-ht - (λ (txt _) - (unless (hash-table-get already-frozen-ht txt #f) - (let ([locked? (send txt is-locked?)]) - (when locked? (send txt lock #f)) - (send txt thaw-colorer) - (when locked? (send txt lock #t)))) - (send txt end-edit-sequence))))))))) - - (inherit get-defs) - (define/augment (clear-annotations) - (inner (void) clear-annotations) - (send (get-defs) clear-test-coverage)) - - (super-new))) - - - - - -; -; -; ;;; ;;; -; ; ; ; ; -; ; ; -; ; ;; ; ;;; ;;; ;;;;;; ;;; ; ;;; ; ;; ;; ; -; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ; ; ; ; ;; -; ; ;; ; ;;; ; ; ; ; ; ; ;; ; -; ; ; -; ; ;;; -; + (send txt thaw-colorer) + (when locked? (send txt lock #t)))) + (send txt end-edit-sequence))))))))) + + (inherit get-defs) + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (send (get-defs) clear-test-coverage)) + + (super-new))) - - (define profile-key (gensym)) - - ;; prof-info = - ;; (make-prof-info - ;; boolean ;; protect against nested calls - ;; number[number of calls] - ;; number[time spent in all calls] - ;; (union #f symbol) - ;; expression) - (define-struct prof-info (nest num time name expr)) - - ;; copy-prof-info : prof-info -> prof-info - (define (copy-prof-info prof-info) - (make-prof-info (prof-info-nest prof-info) - (prof-info-num prof-info) - (prof-info-time prof-info) - (prof-info-name prof-info) - (prof-info-expr prof-info))) - - ;; any-info? : prof-info -> boolean - (define (any-info? prof-info) - (or (not (zero? (prof-info-num prof-info))) - (not (zero? (prof-info-time prof-info))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; profiling runtime support - - ;; parameter - ;; imported into errortrace - (define profiling-enabled (make-parameter #f)) - - ;; holds a hash-table for the profiling information - (define current-profile-info (make-thread-cell #f)) - - - ;; initialize-profile-point : sym syntax syntax -> void - ;; called during compilation to register this point as - ;; a profile point. - ;; =user= - ;; imported into errortrace - (define (initialize-profile-point key name expr) - (unless (thread-cell-ref current-profile-info) - (let ([rep (drscheme:rep:current-rep)]) - (when rep - (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) - (when (eq? ut (current-thread)) - (let ([ht (make-hash-table)]) - (thread-cell-set! current-profile-info ht) - (send (send rep get-context) add-profile-info ht))))))) - (let ([profile-info (thread-cell-ref current-profile-info)]) - (when profile-info - (hash-table-put! profile-info - key - (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) - (void)) - - ;; register-profile-start : sym -> (union #f number) - ;; =user= - ;; imported into errortrace - (define (register-profile-start key) + + + + + ; + ; + ; ;;; ;;; + ; ; ; ; ; + ; ; ; + ; ; ;; ; ;;; ;;; ;;;;;; ;;; ; ;;; ; ;; ;; ; + ; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; + ; ; ;; ; ;;; ; ; ; ; ; ; ;; ; + ; ; ; + ; ; ;;; + ; + + + (define profile-key (gensym)) + + ;; prof-info = + ;; (make-prof-info + ;; boolean ;; protect against nested calls + ;; number[number of calls] + ;; number[time spent in all calls] + ;; (union #f symbol) + ;; expression) + (define-struct prof-info (nest num time name expr) #:mutable) + + ;; copy-prof-info : prof-info -> prof-info + (define (copy-prof-info prof-info) + (make-prof-info (prof-info-nest prof-info) + (prof-info-num prof-info) + (prof-info-time prof-info) + (prof-info-name prof-info) + (prof-info-expr prof-info))) + + ;; any-info? : prof-info -> boolean + (define (any-info? prof-info) + (or (not (zero? (prof-info-num prof-info))) + (not (zero? (prof-info-time prof-info))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; profiling runtime support + + ;; parameter + ;; imported into errortrace + (define profiling-enabled (make-parameter #f)) + + ;; holds a hash-table for the profiling information + (define current-profile-info (make-thread-cell #f)) + + + ;; initialize-profile-point : sym syntax syntax -> void + ;; called during compilation to register this point as + ;; a profile point. + ;; =user= + ;; imported into errortrace + (define (initialize-profile-point key name expr) + (unless (thread-cell-ref current-profile-info) + (let ([rep (drscheme:rep:current-rep)]) + (when rep + (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) + (when (eq? ut (current-thread)) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-profile-info ht) + (send (send rep get-context) add-profile-info ht))))))) + (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)))) + (void)) + + ;; register-profile-start : sym -> (union #f number) + ;; =user= + ;; imported into errortrace + (define (register-profile-start key) + (let ([ht (thread-cell-ref current-profile-info)]) + (when ht + (let ([info (hash-ref ht key)]) + (set-prof-info-num! info (+ (prof-info-num info) 1)) + (if (prof-info-nest info) + #f + (begin + (set-prof-info-nest! info #t) + (current-process-milliseconds))))))) + + ;; register-profile-done : sym (union #f number) -> void + ;; =user= + ;; imported into errortrace + (define (register-profile-done key start) + (when start (let ([ht (thread-cell-ref current-profile-info)]) (when ht - (let ([info (hash-table-get ht key)]) - (set-prof-info-num! info (+ (prof-info-num info) 1)) - (if (prof-info-nest info) - #f - (begin - (set-prof-info-nest! info #t) - (current-process-milliseconds))))))) - - ;; register-profile-done : sym (union #f number) -> void - ;; =user= - ;; imported into errortrace - (define (register-profile-done key start) - (when start - (let ([ht (thread-cell-ref current-profile-info)]) - (when ht - (let ([info (hash-table-get ht key)]) - (set-prof-info-nest! info #f) - (set-prof-info-time! info - (+ (- (current-process-milliseconds) start) - (prof-info-time info))))))) - (void)) - - (define (get-color-value/pref val max-val drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale) - (let* ([adjust - (case drscheme:profile:scale - [(sqrt) sqrt] - [(square) (λ (x) (* x x))] - [(linear) (λ (x) x)])] - [factor (adjust (if (zero? max-val) 0 (/ val max-val)))] - [get-rgb-value - (λ (sel) - (let ([small (sel drscheme:profile:low-color)] - [big (sel drscheme:profile:high-color)]) - (inexact->exact (floor (+ (* factor (- big small)) small)))))]) - (make-object color% - (get-rgb-value (λ (x) (send x red))) - (get-rgb-value (λ (x) (send x green))) - (get-rgb-value (λ (x) (send x blue)))))) - - ;; get-color-value : number number -> (is-a?/c color%) - ;; returns the profiling color - ;; for `val' if `max-val' is the largest - ;; of any profiling amount. - (define (get-color-value val max-val) - (get-color-value/pref val - max-val - (preferences:get 'drscheme:profile:low-color) - (preferences:get 'drscheme:profile:high-color) - (preferences:get 'drscheme:profile:scale))) - - ;; extract-maximum : (listof prof-info) -> number - ;; gets the maximum value of the currently preferred profiling info. - (define (extract-maximum infos) - (let ([max-value 0] - [sel (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) - prof-info-time - prof-info-num)]) - (for-each - (λ (val) - (set! max-value (max max-value (sel val)))) - infos) - max-value)) - - ;; profile-definitions-mixin : mixin - (define profile-definitions-text-mixin - (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () - (inherit get-canvas get-tab) - - (define/augment (can-insert? x y) - (and (inner #t can-insert? x y) - (can-reset-profile?))) - - (define/augment (can-delete? x y) - (and (inner #t can-delete? x y) - (can-reset-profile?))) - - (define/augment (on-insert x y) - (inner (void) on-insert x y) - (do-reset-profile)) - - (define/augment (on-delete x y) - (inner (void) on-delete x y) - (do-reset-profile)) - - (define/private (can-reset-profile?) - (let ([canvas (get-canvas)]) - (or (not canvas) - (let ([frame (send canvas get-top-level-window)]) - (or (not (send frame get-profile-info-visible?)) - (eq? (message-box (string-constant drscheme) - (string-constant profiling-clear?) - frame - '(yes-no)) - 'yes)))))) - - (define/private (do-reset-profile) - (send (get-tab) reset-profile)) - - (super-new))) - - (define profile-interactions-tab<%> - (interface () - add-profile-info)) - - (define-local-member-name + (let ([info (hash-ref ht key)]) + (set-prof-info-nest! info #f) + (set-prof-info-time! info + (+ (- (current-process-milliseconds) start) + (prof-info-time info))))))) + (void)) + + (define (get-color-value/pref val max-val drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale) + (let* ([adjust + (case drscheme:profile:scale + [(sqrt) sqrt] + [(square) (λ (x) (* x x))] + [(linear) (λ (x) x)])] + [factor (adjust (if (zero? max-val) 0 (/ val max-val)))] + [get-rgb-value + (λ (sel) + (let ([small (sel drscheme:profile:low-color)] + [big (sel drscheme:profile:high-color)]) + (inexact->exact (floor (+ (* factor (- big small)) small)))))]) + (make-object color% + (get-rgb-value (λ (x) (send x red))) + (get-rgb-value (λ (x) (send x green))) + (get-rgb-value (λ (x) (send x blue)))))) + + ;; get-color-value : number number -> (is-a?/c color%) + ;; returns the profiling color + ;; for `val' if `max-val' is the largest + ;; of any profiling amount. + (define (get-color-value val max-val) + (get-color-value/pref val + max-val + (preferences:get 'drscheme:profile:low-color) + (preferences:get 'drscheme:profile:high-color) + (preferences:get 'drscheme:profile:scale))) + + ;; extract-maximum : (listof prof-info) -> number + ;; gets the maximum value of the currently preferred profiling info. + (define (extract-maximum infos) + (let ([max-value 0] + [sel (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) + prof-info-time + prof-info-num)]) + (for-each + (λ (val) + (set! max-value (max max-value (sel val)))) + infos) + max-value)) + + ;; profile-definitions-mixin : mixin + (define profile-definitions-text-mixin + (mixin ((class->interface text%) drscheme:unit:definitions-text<%>) () + (inherit get-canvas get-tab) - ;; tab methods - reset-profile ;; erases profile display & information - hide-profile ;; hides profiling info, but it is still here to be shown again - show-profile ;; shows the profile info, if there is any to show - refresh-profile ;; shows current info in profile window - get-profile-info-text - can-show-profile? - get-sort-mode ;; indicates if the results are currently shown sorted by time, or not - set-sort-mode ;; updates the sort mode flag (only called by the gui control callback) + (define/augment (can-insert? x y) + (and (inner #t can-insert? x y) + (can-reset-profile?))) - ;; frame methods - hide-profile-gui - show-profile-gui + (define/augment (can-delete? x y) + (and (inner #t can-delete? x y) + (can-reset-profile?))) - ;; frame and tab methods - get-profile-info-visible? - ; on frame, indicates if the gui stuff shows up currently - ; on tab, indicates if the user has asked for the gui to show up. - ) + (define/augment (on-insert x y) + (inner (void) on-insert x y) + (do-reset-profile)) + + (define/augment (on-delete x y) + (inner (void) on-delete x y) + (do-reset-profile)) + + (define/private (can-reset-profile?) + (let ([canvas (get-canvas)]) + (or (not canvas) + (let ([frame (send canvas get-top-level-window)]) + (or (not (send frame get-profile-info-visible?)) + (eq? (message-box (string-constant drscheme) + (string-constant profiling-clear?) + frame + '(yes-no)) + 'yes)))))) + + (define/private (do-reset-profile) + (send (get-tab) reset-profile)) + + (super-new))) + + (define profile-interactions-tab<%> + (interface () + add-profile-info)) + + (define-local-member-name - (define profile-tab-mixin - (mixin (drscheme:unit:tab<%>) (profile-interactions-tab<%>) - (define profile-info-visible? #f) - (define/public (get-profile-info-visible?) profile-info-visible?) - - (define sort-mode (preferences:get 'drscheme:profile-how-to-count)) - (define/public (get-sort-mode) sort-mode) - (define/public (set-sort-mode mode) (set! sort-mode mode)) - - (inherit get-frame is-current-tab?) - ;; profile-info : (listof hashtable[symbol -o> prof-info]) - (define profile-info '()) - (define/public (add-profile-info ht) (set! profile-info (cons ht profile-info))) - - (define/public (show-profile) - (unless profile-info-visible? - (set! profile-info-visible? #t) - (send (get-frame) show-profile-gui))) - - (define/public (hide-profile) + ;; tab methods + reset-profile ;; erases profile display & information + hide-profile ;; hides profiling info, but it is still here to be shown again + show-profile ;; shows the profile info, if there is any to show + refresh-profile ;; shows current info in profile window + get-profile-info-text + can-show-profile? + get-sort-mode ;; indicates if the results are currently shown sorted by time, or not + set-sort-mode ;; updates the sort mode flag (only called by the gui control callback) + + ;; frame methods + hide-profile-gui + show-profile-gui + + ;; frame and tab methods + get-profile-info-visible? + ; on frame, indicates if the gui stuff shows up currently + ; on tab, indicates if the user has asked for the gui to show up. + ) + + (define profile-tab-mixin + (mixin (drscheme:unit:tab<%>) (profile-interactions-tab<%>) + (define profile-info-visible? #f) + (define/public (get-profile-info-visible?) profile-info-visible?) + + (define sort-mode (preferences:get 'drscheme:profile-how-to-count)) + (define/public (get-sort-mode) sort-mode) + (define/public (set-sort-mode mode) (set! sort-mode mode)) + + (inherit get-frame is-current-tab?) + ;; profile-info : (listof hashtable[symbol -o> prof-info]) + (define profile-info '()) + (define/public (add-profile-info ht) (set! profile-info (cons ht profile-info))) + + (define/public (show-profile) + (unless profile-info-visible? + (set! profile-info-visible? #t) + (send (get-frame) show-profile-gui))) + + (define/public (hide-profile) + (when profile-info-visible? + (set! profile-info-visible? #f) + (send profile-info-text clear-profile-display) + (when (is-current-tab?) + (send (get-frame) hide-profile-gui)))) + + (define/public (reset-profile) + (hide-profile) + (set! profile-info '())) + + (define/public (refresh-profile) + (send profile-info-text refresh-profile profile-info)) + + ;; can-show-profile? : -> boolean + ;; indicates if there is any profiling information to be shown. + (define/public (can-show-profile?) + (let/ec esc-k + (for-each + (λ (ht) + (hash-for-each + ht + (λ (key v) + (when (any-info? v) + (esc-k #t))))) + profile-info) + #f)) + + (define profile-info-text (new profile-text% (tab this))) + (define/public (get-profile-info-text) profile-info-text) + + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (reset-profile)) + + (super-new))) + + ;; profile-unit-frame-mixin : mixin + ;; adds profiling to the unit frame + (define profile-unit-frame-mixin + (mixin (drscheme:unit:frame<%> drscheme:frame:<%>) () + + (inherit get-interactions-text get-current-tab) + + ;; update-shown : -> void + ;; updates the state of the profile item's show menu + (define/override (update-shown) + (super update-shown) + (send show-profile-menu-item set-label + (if profile-info-visible? + (string-constant profiling-hide-profile) + (string-constant profiling-show-profile)))) + + ;; add-show-menu-items : menu -> void + ;; adds the show profile menu item + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show-profile-menu-item + (instantiate menu:can-restore-menu-item% () + (label (string-constant profiling-hide-profile)) + (parent show-menu) + (callback + (λ (x y) + (show-profile-menu-callback)))))) + + (define show-profile-menu-item #f) + (define profile-gui-constructed? #f) + + ;; get-profile-info-visible? : -> boolean + ;; returns #t when the profiling information is visible in the frame. + (define/public (get-profile-info-visible?) profile-info-visible?) + + (field [profile-info-outer-panel #f]) + (define/override (make-root-area-container % parent) + (set! profile-info-outer-panel + (super make-root-area-container + vertical-panel% + parent)) + (make-object % profile-info-outer-panel)) + + (define/private (show-profile-menu-callback) + (cond + [profile-info-visible? + (send (get-current-tab) hide-profile)] + [(send (get-current-tab) can-show-profile?) + (send (get-current-tab) show-profile) + (send (get-current-tab) refresh-profile)] + [else + (message-box (string-constant drscheme) + (string-constant profiling-no-information-available))])) + + (define/public (hide-profile-gui) + (when profile-gui-constructed? (when profile-info-visible? - (set! profile-info-visible? #f) - (send profile-info-text clear-profile-display) - (when (is-current-tab?) - (send (get-frame) hide-profile-gui)))) - - (define/public (reset-profile) - (hide-profile) - (set! profile-info '())) - - (define/public (refresh-profile) - (send profile-info-text refresh-profile profile-info)) - - ;; can-show-profile? : -> boolean - ;; indicates if there is any profiling information to be shown. - (define/public (can-show-profile?) - (let/ec esc-k - (for-each - (λ (ht) - (hash-table-for-each - ht - (λ (key v) - (when (any-info? v) - (esc-k #t))))) - profile-info) - #f)) - - (define profile-info-text (new profile-text% (tab this))) - (define/public (get-profile-info-text) profile-info-text) - - (define/augment (clear-annotations) - (inner (void) clear-annotations) - (reset-profile)) - - (super-new))) - - ;; profile-unit-frame-mixin : mixin - ;; adds profiling to the unit frame - (define profile-unit-frame-mixin - (mixin (drscheme:unit:frame<%> drscheme:frame:<%>) () - - (inherit get-interactions-text get-current-tab) - - ;; update-shown : -> void - ;; updates the state of the profile item's show menu - (define/override (update-shown) - (super update-shown) - (send show-profile-menu-item set-label - (if profile-info-visible? - (string-constant profiling-hide-profile) - (string-constant profiling-show-profile)))) - - ;; add-show-menu-items : menu -> void - ;; adds the show profile menu item - (define/override (add-show-menu-items show-menu) - (super add-show-menu-items show-menu) - (set! show-profile-menu-item - (instantiate menu:can-restore-menu-item% () - (label (string-constant profiling-hide-profile)) - (parent show-menu) - (callback - (λ (x y) - (show-profile-menu-callback)))))) - - (define show-profile-menu-item #f) - (define profile-gui-constructed? #f) - - ;; get-profile-info-visible? : -> boolean - ;; returns #t when the profiling information is visible in the frame. - (define/public (get-profile-info-visible?) profile-info-visible?) - - (field [profile-info-outer-panel #f]) - (define/override (make-root-area-container % parent) - (set! profile-info-outer-panel - (super make-root-area-container - vertical-panel% - parent)) - (make-object % profile-info-outer-panel)) - - (define/private (show-profile-menu-callback) - (cond - [profile-info-visible? - (send (get-current-tab) hide-profile)] - [(send (get-current-tab) can-show-profile?) - (send (get-current-tab) show-profile) - (send (get-current-tab) refresh-profile)] - [else - (message-box (string-constant drscheme) - (string-constant profiling-no-information-available))])) - - (define/public (hide-profile-gui) - (when profile-gui-constructed? - (when profile-info-visible? - (send profile-info-outer-panel change-children - (λ (l) - (remq profile-info-panel l))) - (set! profile-info-visible? #f) - (update-shown)))) - - (define/public (show-profile-gui) - (unless profile-info-visible? - (construct-profile-gui) (send profile-info-outer-panel change-children (λ (l) - (append (remq profile-info-panel l) - (list profile-info-panel)))) - (set! profile-info-visible? #t) - (send profile-info-editor-canvas set-editor (send (get-current-tab) get-profile-info-text)) - (send (get-current-tab) refresh-profile) - (update-shown))) - - (field (profile-info-visible? #f)) - - (define/augment (on-tab-change from-tab to-tab) - (inner (void) on-tab-change from-tab to-tab) - (cond - [(and (not profile-info-visible?) - (send to-tab get-profile-info-visible?)) - (show-profile-gui)] - [(and profile-info-visible? - (not (send to-tab get-profile-info-visible?))) - (hide-profile-gui)]) - (when profile-choice - (send profile-choice set-selection - (profile-mode->selection - (send to-tab get-sort-mode)))) - (when profile-info-editor-canvas - (send profile-info-editor-canvas set-editor - (and (send to-tab can-show-profile?) - (send to-tab get-profile-info-text))))) - - (super-new) - - (define profile-info-panel #f) - (define profile-info-editor-canvas #f) - (define profile-choice #f) - - (inherit begin-container-sequence end-container-sequence) - (define/private (construct-profile-gui) - (unless profile-gui-constructed? - (set! profile-gui-constructed? #t) - (begin-container-sequence) - (let () - (define _2 - (set! profile-info-panel (instantiate horizontal-panel% () - (parent profile-info-outer-panel) - (stretchable-height #f)))) - (define profile-left-side (instantiate vertical-panel% (profile-info-panel))) - (define _3 - (set! profile-info-editor-canvas (new canvas:basic% - (parent profile-info-panel) - (editor (send (get-current-tab) get-profile-info-text))))) - (define profile-message (instantiate message% () - (label (string-constant profiling)) - (parent profile-left-side))) - (define _4 - (set! profile-choice (instantiate radio-box% () - (label #f) - (parent profile-left-side) - (callback - (λ (x y) - (let ([mode (profile-selection->mode (send profile-choice get-selection))]) - (preferences:set 'drscheme:profile-how-to-count mode) - (send (get-current-tab) set-sort-mode mode) - (send (get-current-tab) refresh-profile)))) - (choices (list (string-constant profiling-time) - (string-constant profiling-number)))))) - (define _1 - (send profile-choice set-selection - (case (preferences:get 'drscheme:profile-how-to-count) - [(time) 0] - [(count) 1]))) - (define update-profile-button - (instantiate button% () - (label (string-constant profiling-update)) - (parent profile-left-side) - (callback - (λ (x y) - (send (get-current-tab) refresh-profile))))) - (define hide-profile-button - (instantiate button% () - (label (string-constant profiling-hide-profile)) - (parent profile-left-side) - (callback - (λ (x y) - (send (get-current-tab) hide-profile))))) - (send profile-choice set-selection - (profile-mode->selection (preferences:get 'drscheme:profile-how-to-count))) - - (send profile-left-side stretchable-width #f) - - (let ([wid (max (send update-profile-button get-width) - (send hide-profile-button get-width) - (send profile-choice get-width) - (send profile-message get-width))]) - (send update-profile-button min-width wid) - (send hide-profile-button min-width wid) - (send profile-choice min-width wid)) - (send profile-left-side set-alignment 'left 'center) - - ;; hide profiling info initially, but reflow the container - ;; so that the invisible children get the right size. - (send this reflow-container) - (send profile-info-outer-panel change-children - (λ (l) - (remq profile-info-panel l)))) - (end-container-sequence))))) - - (define (profile-selection->mode sel) - (case sel - [(0) 'time] - [(1) 'count])) - - (define (profile-mode->selection mode) - (case mode - [(time) 0] - [(count) 1])) - - ;; profile-text% : extends text:basic% - ;; this class keeps track of a single thread's - ;; profiling information. these methods are not - ;; to be called directly, but only by the frame class, since - ;; they do not completely implement the abstraction for the - ;; GUI. They only manage the profiling information reported - ;; in the bottom window - (define profile-text% - (class text:basic% - (init-field tab) - - ;; clear-profile-display : -> void - ;; clears out the GUI showing the profile results - (define/public (clear-profile-display) - (begin-edit-sequence) - (let ([locked? (is-locked?)]) - (lock #f) - (clear-old-results) - (erase) - (lock locked?) - (end-edit-sequence))) - - (inherit lock is-locked? - get-canvas hide-caret get-snip-location - begin-edit-sequence end-edit-sequence - erase insert) - - ;; clear-old-results : -> void - ;; removes the profile highlighting - (field [clear-old-results void]) - - ;; refresh-profile : (listof hashtable[...]) -> void - ;; does the work to erase any existing profile info - ;; and make new profiling info. - (define/public (refresh-profile profile-info) - (begin-edit-sequence) - (lock #f) - (erase) - (clear-old-results) - (let* (;; must copy them here in case the program is still running - ;; and thus updating them. - [infos '()] - [_ (let loop ([profile-info profile-info]) - (cond - [(null? profile-info) (void)] - [else - (let ([ht (car profile-info)]) - (hash-table-for-each - ht - (λ (key val) - (when (any-info? val) - (set! infos (cons (copy-prof-info val) infos)))))) - (loop (cdr profile-info))]))] - - ;; each editor that gets some highlighting is put - ;; into this table and an edit sequence is begun for it. - ;; after all ranges are updated, the edit sequences are all closed. - [in-edit-sequence (make-hash-table)] - [clear-highlight void] - [max-value (extract-maximum infos)] - [show-highlight - (λ (info) - (let* ([expr (prof-info-expr info)] - [src (syntax-source expr)] - [pos (syntax-position expr)] - [span (syntax-span expr)]) - (when (and src - (is-a? src text:basic<%>) - (number? pos) - (number? span)) - (unless (hash-table-get in-edit-sequence src (λ () #f)) - (hash-table-put! in-edit-sequence src #t) - (send src begin-edit-sequence)) - (let* ([color (get-color-value - (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) - (prof-info-time info) - (prof-info-num info)) - max-value)] - [clr (send src highlight-range (- pos 1) (+ pos span -1) color)]) - (let ([old-thnk clear-highlight]) - (set! clear-highlight - (λ () - (clr) - (old-thnk))))))))] - [smaller-range? - (λ (x y) - (let ([x-span (syntax-span (prof-info-expr x))] - [y-span (syntax-span (prof-info-expr y))]) - (if (and x-span y-span) - (< x-span y-span) - #f)))] - - [show-line - (λ (info newline? highlight-line?) - (let* ([expr (prof-info-expr info)] - [expr-src (syntax-source expr)] - [count (prof-info-num info)] - [time (prof-info-time info)] - [name (prof-info-name info)]) - (when newline? (send src-loc-editor insert "\n")) - (when highlight-line? (small-blank-line src-loc-editor)) - (let ([before (send src-loc-editor last-position)]) - (insert-profile-src-loc src-loc-editor expr name) - (let ([after (send src-loc-editor last-position)]) - (cond - [(string? expr-src) - (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) - (let ([after (send src-loc-editor last-position)]) - (send src-loc-editor set-clickback - before after - (λ (text start end) - (open-file-and-goto-position expr-src (syntax-position expr)))))] - [(is-a? expr-src editor:basic<%>) - (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) - (send src-loc-editor set-clickback - before after - (λ (text start end) - (let ([window (send expr-src get-top-level-window)] - [pos (syntax-position expr)]) - (when window (send window show #t)) - (when pos (send expr-src set-position (- pos 1))) - (send expr-src set-caret-owner #f 'global))))] - [else (void)]))) - - (when newline? (send time-editor insert "\n")) - (when highlight-line? (small-blank-line time-editor)) - (send time-editor insert (format "~a" time)) - (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right) - - (when newline? (send count-editor insert "\n")) - (when highlight-line? (small-blank-line count-editor)) - (send count-editor insert (format "~a" count)) - (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))] - - [bigger-value? - (λ (x y) - (let ([sel (if (eq? 'count (preferences:get 'drscheme:profile-how-to-count)) - prof-info-num - prof-info-time)]) - (> (sel x) (sel y))))] - - [cleanup-editor - (λ (ed) - (let* ([ed-admin (send ed get-admin)] - [snip (send ed-admin get-snip)] - [bl (box 0)] - [br (box 0)]) - (get-snip-location snip bl #f #f) - (get-snip-location snip br #f #t) - (let ([w (+ (- (unbox br) (unbox bl)) 4)]) - (send ed set-max-width w) - (send ed set-min-width w))) - (send ed hide-caret #t) - (send ed lock #t))] - - [top-infos (top 100 (sort infos bigger-value?))]) - (for-each show-highlight top-infos) - (initialize-editors) - (let loop ([infos top-infos] - [newline? #f] - [highlight-counter 0]) - (cond - [(null? infos) (void)] - [else - (show-line (car infos) newline? (and newline? (zero? highlight-counter))) - (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))])) - (cleanup-editor count-editor) - (cleanup-editor time-editor) - (cleanup-editor src-loc-editor) + (remq profile-info-panel l))) + (set! profile-info-visible? #f) + (update-shown)))) + + (define/public (show-profile-gui) + (unless profile-info-visible? + (construct-profile-gui) + (send profile-info-outer-panel change-children + (λ (l) + (append (remq profile-info-panel l) + (list profile-info-panel)))) + (set! profile-info-visible? #t) + (send profile-info-editor-canvas set-editor (send (get-current-tab) get-profile-info-text)) + (send (get-current-tab) refresh-profile) + (update-shown))) + + (field (profile-info-visible? #f)) + + (define/augment (on-tab-change from-tab to-tab) + (inner (void) on-tab-change from-tab to-tab) + (cond + [(and (not profile-info-visible?) + (send to-tab get-profile-info-visible?)) + (show-profile-gui)] + [(and profile-info-visible? + (not (send to-tab get-profile-info-visible?))) + (hide-profile-gui)]) + (when profile-choice + (send profile-choice set-selection + (profile-mode->selection + (send to-tab get-sort-mode)))) + (when profile-info-editor-canvas + (send profile-info-editor-canvas set-editor + (and (send to-tab can-show-profile?) + (send to-tab get-profile-info-text))))) + + (super-new) + + (define profile-info-panel #f) + (define profile-info-editor-canvas #f) + (define profile-choice #f) + + (inherit begin-container-sequence end-container-sequence) + (define/private (construct-profile-gui) + (unless profile-gui-constructed? + (set! profile-gui-constructed? #t) + (begin-container-sequence) + (let () + (define _2 + (set! profile-info-panel (instantiate horizontal-panel% () + (parent profile-info-outer-panel) + (stretchable-height #f)))) + (define profile-left-side (instantiate vertical-panel% (profile-info-panel))) + (define _3 + (set! profile-info-editor-canvas (new canvas:basic% + (parent profile-info-panel) + (editor (send (get-current-tab) get-profile-info-text))))) + (define profile-message (instantiate message% () + (label (string-constant profiling)) + (parent profile-left-side))) + (define _4 + (set! profile-choice (instantiate radio-box% () + (label #f) + (parent profile-left-side) + (callback + (λ (x y) + (let ([mode (profile-selection->mode (send profile-choice get-selection))]) + (preferences:set 'drscheme:profile-how-to-count mode) + (send (get-current-tab) set-sort-mode mode) + (send (get-current-tab) refresh-profile)))) + (choices (list (string-constant profiling-time) + (string-constant profiling-number)))))) + (define _1 + (send profile-choice set-selection + (case (preferences:get 'drscheme:profile-how-to-count) + [(time) 0] + [(count) 1]))) + (define update-profile-button + (instantiate button% () + (label (string-constant profiling-update)) + (parent profile-left-side) + (callback + (λ (x y) + (send (get-current-tab) refresh-profile))))) + (define hide-profile-button + (instantiate button% () + (label (string-constant profiling-hide-profile)) + (parent profile-left-side) + (callback + (λ (x y) + (send (get-current-tab) hide-profile))))) + (send profile-choice set-selection + (profile-mode->selection (preferences:get 'drscheme:profile-how-to-count))) - (hash-table-for-each - in-edit-sequence - (λ (key val) - (send key end-edit-sequence))) - (set! clear-old-results - (λ () - (hash-table-for-each - in-edit-sequence - (λ (key val) (send key begin-edit-sequence))) - (clear-highlight) - (hash-table-for-each - in-edit-sequence - (λ (key val) (send key end-edit-sequence))) - (set! clear-old-results void)))) - (lock #t) - (end-edit-sequence) - (let ([canvas (get-canvas)]) - (when canvas - (send canvas scroll-to 0 0 1 1 #t 'start)))) - - ;; top : number (listof X) -> (listof X) - ;; extracts the first `n' elements from a list. - (define/private (top n lst) - (let loop ([n n] - [lst lst]) + (send profile-left-side stretchable-width #f) + + (let ([wid (max (send update-profile-button get-width) + (send hide-profile-button get-width) + (send profile-choice get-width) + (send profile-message get-width))]) + (send update-profile-button min-width wid) + (send hide-profile-button min-width wid) + (send profile-choice min-width wid)) + (send profile-left-side set-alignment 'left 'center) + + ;; hide profiling info initially, but reflow the container + ;; so that the invisible children get the right size. + (send this reflow-container) + (send profile-info-outer-panel change-children + (λ (l) + (remq profile-info-panel l)))) + (end-container-sequence))))) + + (define (profile-selection->mode sel) + (case sel + [(0) 'time] + [(1) 'count])) + + (define (profile-mode->selection mode) + (case mode + [(time) 0] + [(count) 1])) + + ;; profile-text% : extends text:basic% + ;; this class keeps track of a single thread's + ;; profiling information. these methods are not + ;; to be called directly, but only by the frame class, since + ;; they do not completely implement the abstraction for the + ;; GUI. They only manage the profiling information reported + ;; in the bottom window + (define profile-text% + (class text:basic% + (init-field tab) + + ;; clear-profile-display : -> void + ;; clears out the GUI showing the profile results + (define/public (clear-profile-display) + (begin-edit-sequence) + (let ([locked? (is-locked?)]) + (lock #f) + (clear-old-results) + (erase) + (lock locked?) + (end-edit-sequence))) + + (inherit lock is-locked? + get-canvas hide-caret get-snip-location + begin-edit-sequence end-edit-sequence + erase insert) + + ;; clear-old-results : -> void + ;; removes the profile highlighting + (field [clear-old-results void]) + + ;; refresh-profile : (listof hashtable[...]) -> void + ;; does the work to erase any existing profile info + ;; and make new profiling info. + (define/public (refresh-profile profile-info) + (begin-edit-sequence) + (lock #f) + (erase) + (clear-old-results) + (let* (;; must copy them here in case the program is still running + ;; and thus updating them. + [infos '()] + [_ (let loop ([profile-info profile-info]) + (cond + [(null? profile-info) (void)] + [else + (let ([ht (car profile-info)]) + (hash-for-each + ht + (λ (key val) + (when (any-info? val) + (set! infos (cons (copy-prof-info val) infos)))))) + (loop (cdr profile-info))]))] + + ;; each editor that gets some highlighting is put + ;; into this table and an edit sequence is begun for it. + ;; after all ranges are updated, the edit sequences are all closed. + [in-edit-sequence (make-hasheq)] + [clear-highlight void] + [max-value (extract-maximum infos)] + [show-highlight + (λ (info) + (let* ([expr (prof-info-expr info)] + [src (syntax-source expr)] + [pos (syntax-position expr)] + [span (syntax-span expr)]) + (when (and src + (is-a? src text:basic<%>) + (number? pos) + (number? span)) + (unless (hash-ref in-edit-sequence src (λ () #f)) + (hash-set! in-edit-sequence src #t) + (send src begin-edit-sequence)) + (let* ([color (get-color-value + (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) + (prof-info-time info) + (prof-info-num info)) + max-value)] + [clr (send src highlight-range (- pos 1) (+ pos span -1) color)]) + (let ([old-thnk clear-highlight]) + (set! clear-highlight + (λ () + (clr) + (old-thnk))))))))] + [smaller-range? + (λ (x y) + (let ([x-span (syntax-span (prof-info-expr x))] + [y-span (syntax-span (prof-info-expr y))]) + (if (and x-span y-span) + (< x-span y-span) + #f)))] + + [show-line + (λ (info newline? highlight-line?) + (let* ([expr (prof-info-expr info)] + [expr-src (syntax-source expr)] + [count (prof-info-num info)] + [time (prof-info-time info)] + [name (prof-info-name info)]) + (when newline? (send src-loc-editor insert "\n")) + (when highlight-line? (small-blank-line src-loc-editor)) + (let ([before (send src-loc-editor last-position)]) + (insert-profile-src-loc src-loc-editor expr name) + (let ([after (send src-loc-editor last-position)]) + (cond + [(string? expr-src) + (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) + (let ([after (send src-loc-editor last-position)]) + (send src-loc-editor set-clickback + before after + (λ (text start end) + (open-file-and-goto-position expr-src (syntax-position expr)))))] + [(is-a? expr-src editor:basic<%>) + (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) + (send src-loc-editor set-clickback + before after + (λ (text start end) + (let ([window (send expr-src get-top-level-window)] + [pos (syntax-position expr)]) + (when window (send window show #t)) + (when pos (send expr-src set-position (- pos 1))) + (send expr-src set-caret-owner #f 'global))))] + [else (void)]))) + + (when newline? (send time-editor insert "\n")) + (when highlight-line? (small-blank-line time-editor)) + (send time-editor insert (format "~a" time)) + (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right) + + (when newline? (send count-editor insert "\n")) + (when highlight-line? (small-blank-line count-editor)) + (send count-editor insert (format "~a" count)) + (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))] + + [bigger-value? + (λ (x y) + (let ([sel (if (eq? 'count (preferences:get 'drscheme:profile-how-to-count)) + prof-info-num + prof-info-time)]) + (> (sel x) (sel y))))] + + [cleanup-editor + (λ (ed) + (let* ([ed-admin (send ed get-admin)] + [snip (send ed-admin get-snip)] + [bl (box 0)] + [br (box 0)]) + (get-snip-location snip bl #f #f) + (get-snip-location snip br #f #t) + (let ([w (+ (- (unbox br) (unbox bl)) 4)]) + (send ed set-max-width w) + (send ed set-min-width w))) + (send ed hide-caret #t) + (send ed lock #t))] + + [top-infos (top 100 (sort infos bigger-value?))]) + (for-each show-highlight top-infos) + (initialize-editors) + (let loop ([infos top-infos] + [newline? #f] + [highlight-counter 0]) (cond - [(null? lst) null] - [(= 0 n) null] - [else (cons (car lst) (loop (- n 1) (cdr lst)))]))) - - (field (src-loc-editor #f) - (time-editor #f) - (count-editor #f)) - (define/private (clear-editors) - (set! src-loc-editor #f) - (set! time-editor #f) - (set! count-editor #f)) - (define/private (initialize-editors) - (set! src-loc-editor (instantiate text% ())) - (set! time-editor (instantiate text% ())) - (set! count-editor (instantiate text% ())) - (send src-loc-editor set-styles-sticky #f) - (send time-editor set-styles-sticky #f) - (send count-editor set-styles-sticky #f) - (insert (instantiate editor-snip% (time-editor))) - (insert (instantiate editor-snip% (count-editor))) - (insert (instantiate editor-snip% (src-loc-editor))) - (insert-title (string-constant profiling-col-function) src-loc-editor) - (insert-title (string-constant profiling-col-time-in-msec) time-editor) - (insert-title (string-constant profiling-col-calls) count-editor)) - - (define/private (insert-title str txt) - (send txt insert str) - (send txt insert "\n") - (send txt change-style bold-delta 0 (- (send txt last-position) 1)) - (send txt set-paragraph-alignment 0 'center)) - - (super-new) - (hide-caret #t))) - - ;; format-percentage : number[0 <= n <= 1] -> string - ;; formats the number as a percentage string with trailing zeros, - ;; to 3 decimal places. - (define (format-percentage n) - (let* ([number-of-places 3] - [whole-part (floor (* n 100))] - [decimal-part (- (* n 100) whole-part)] - [truncated/moved-decimal-part (floor (* (expt 10 number-of-places) decimal-part))] - [pad - (λ (str) - (if ((string-length str) . < . number-of-places) - (string-append (make-string (- number-of-places (string-length str)) #\0) - str) - str))]) - (string-append (format "~a" whole-part) - "." - (pad (format "~a" truncated/moved-decimal-part))))) - - (define (small-blank-line txt) - (let ([before (send txt last-position)]) + [(null? infos) (void)] + [else + (show-line (car infos) newline? (and newline? (zero? highlight-counter))) + (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))])) + (cleanup-editor count-editor) + (cleanup-editor time-editor) + (cleanup-editor src-loc-editor) + + (hash-for-each + in-edit-sequence + (λ (key val) + (send key end-edit-sequence))) + (set! clear-old-results + (λ () + (hash-for-each + in-edit-sequence + (λ (key val) (send key begin-edit-sequence))) + (clear-highlight) + (hash-for-each + in-edit-sequence + (λ (key val) (send key end-edit-sequence))) + (set! clear-old-results void)))) + (lock #t) + (end-edit-sequence) + (let ([canvas (get-canvas)]) + (when canvas + (send canvas scroll-to 0 0 1 1 #t 'start)))) + + ;; top : number (listof X) -> (listof X) + ;; extracts the first `n' elements from a list. + (define/private (top n lst) + (let loop ([n n] + [lst lst]) + (cond + [(null? lst) null] + [(= 0 n) null] + [else (cons (car lst) (loop (- n 1) (cdr lst)))]))) + + (field (src-loc-editor #f) + (time-editor #f) + (count-editor #f)) + (define/private (clear-editors) + (set! src-loc-editor #f) + (set! time-editor #f) + (set! count-editor #f)) + (define/private (initialize-editors) + (set! src-loc-editor (instantiate text% ())) + (set! time-editor (instantiate text% ())) + (set! count-editor (instantiate text% ())) + (send src-loc-editor set-styles-sticky #f) + (send time-editor set-styles-sticky #f) + (send count-editor set-styles-sticky #f) + (insert (instantiate editor-snip% (time-editor))) + (insert (instantiate editor-snip% (count-editor))) + (insert (instantiate editor-snip% (src-loc-editor))) + (insert-title (string-constant profiling-col-function) src-loc-editor) + (insert-title (string-constant profiling-col-time-in-msec) time-editor) + (insert-title (string-constant profiling-col-calls) count-editor)) + + (define/private (insert-title str txt) + (send txt insert str) (send txt insert "\n") - (let ([after (send txt last-position)]) - (send txt change-style small-font-style before after)))) - - (define small-font-style (make-object style-delta% 'change-size 6)) - - ;; bold-delta : style-delta - (define bold-delta (make-object style-delta% 'change-bold)) - - ;; insert-profile-src-loc : syntax name -> string - (define (insert-profile-src-loc editor stx name) - (cond - [name - (let ([before (send editor last-position)]) - (send editor insert (format "~a" name)))] - [else - (let* ([src (syntax-source stx)] - [filename - (cond - [(string? src) src] - [(is-a? src editor<%>) (get-filename-from-editor src)] - [else (string-constant profiling-unknown-src)])] - [col (syntax-column stx)] - [line (syntax-line stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)] - [src - (cond - [(and col line) - (format "~a: ~a.~a" filename line col)] - [pos - (format "~a: ~a" filename pos)] - [else - filename])]) - (send editor insert src))])) - - ;; open-file-and-goto-position : string (union #f number) -> void - (define (open-file-and-goto-position filename pos) - (let ([frame (handler:edit-file filename)]) - (when (and frame - pos - (is-a? frame drscheme:unit:frame%)) - (let ([defs (send frame get-definitions-text)]) - (send defs set-position (- pos 1)))))) - - ;; get-src-filename : tst -> (union #f string) - (define (get-src-filename src) - (cond - [(string? src) src] - [(is-a? src text%) - (send src get-filename)] - [else #f])) - - ;; get-src-loc : syntax -> string - (define (get-src-loc expr) - (cond - [(and (number? (syntax-line expr)) - (number? (syntax-column expr)) - (number? (syntax-span expr))) - (format " ~a.~a [~a]" - (syntax-line expr) - (syntax-column expr) - (syntax-span expr))] - [(and (number? (syntax-position expr)) - (number? (syntax-span expr))) - (format " ~a-~a" - (syntax-position expr) - (syntax-span expr))] - [else ""])) - - (define (add-prefs-panel) - (preferences:add-panel - (string-constant profiling) - (λ (s-parent) - (letrec ([parent (make-object vertical-panel% s-parent)] - [msg (make-object message% - (string-constant profiling-color-config) - parent)] - [hp (make-object horizontal-pane% parent)] - [low (make-object button% (string-constant profiling-low-color) hp - (λ (x y) (color-callback #t)))] - [color-bar (make-object color-bar% hp)] - [high (make-object button% (string-constant profiling-high-color) hp - (λ (x y) (color-callback #f)))] - - [scale (instantiate radio-box% () - (label (string-constant profiling-scale)) - (parent parent) - (callback (λ (x y) (scale-callback))) - (choices - (list (string-constant profiling-sqrt) - (string-constant profiling-linear) - (string-constant profiling-square))))] - - [color-callback - (λ (low?) - (let ([color (get-color-from-user - (if low? - (string-constant profiling-choose-low-color) - (string-constant profiling-choose-high-color)) - #f - (preferences:get - (if low? - 'drscheme:profile:low-color - 'drscheme:profile:high-color)))]) - (when color - (preferences:set - (if low? 'drscheme:profile:low-color 'drscheme:profile:high-color) - color))))] - [scale-callback - (λ () - (preferences:set - 'drscheme:profile:scale - (case (send scale get-selection) - [(0) 'sqrt] - [(1) 'linear] - [(2) 'square])))]) - (preferences:add-callback - 'drscheme:profile:scale - (λ (p v) - (send scale set-selection - (case v - [(sqrt) 0] - [(linear) 1] - [(square) 2])))) - (send parent set-alignment 'left 'center) - (send hp stretchable-height #f) - parent)))) - - (define color-bar% - (class canvas% - (inherit get-client-size get-dc) - (field [pen (make-object pen% "black" 1 'solid)] - [in-on-paint? #f]) - (define/override (on-paint) - (set! in-on-paint? #t) - (let* ([dc (get-dc)] - [dummy-pen (send dc get-pen)] - [drscheme:profile:low-color (preferences:get 'drscheme:profile:low-color)] - [drscheme:profile:high-color (preferences:get 'drscheme:profile:high-color)] - [drscheme:profile:scale (preferences:get 'drscheme:profile:scale)]) - (let-values ([(w h) (get-client-size)]) - (let loop ([n 0]) - (when (n . <= . w) - (send pen set-color - (get-color-value/pref n w drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale)) - (send dc set-pen pen) - (send dc draw-line n 0 n h) - (send dc set-pen dummy-pen) - (loop (+ n 1)))) - (let-values ([(tw th ta td) (send dc get-text-extent - (string-constant profiling-example-text))]) - (send dc draw-text - (string-constant profiling-example-text) - (floor (- (/ w 2) (/ tw 2))) - (floor (- (/ h 2) (/ th 2))))))) - (set! in-on-paint? #f)) - - ;; queue callbacks here so that the preferences - ;; values are actually set by the time on-paint - ;; is called. - (preferences:add-callback - 'drscheme:profile:scale - (λ (p v) - (unless in-on-paint? - (queue-callback - (λ () - (on-paint)))))) - (preferences:add-callback - 'drscheme:profile:low-color - (λ (p v) - (unless in-on-paint? - (queue-callback - (λ () - (on-paint)))))) - (preferences:add-callback - 'drscheme:profile:high-color - (λ (p v) - (unless in-on-paint? - (queue-callback - (λ () - (on-paint)))))) - - (super-instantiate ()))) - - - - (define-values/invoke-unit/infer stacktrace@))) + (send txt change-style bold-delta 0 (- (send txt last-position) 1)) + (send txt set-paragraph-alignment 0 'center)) + + (super-new) + (hide-caret #t))) + + ;; format-percentage : number[0 <= n <= 1] -> string + ;; formats the number as a percentage string with trailing zeros, + ;; to 3 decimal places. + (define (format-percentage n) + (let* ([number-of-places 3] + [whole-part (floor (* n 100))] + [decimal-part (- (* n 100) whole-part)] + [truncated/moved-decimal-part (floor (* (expt 10 number-of-places) decimal-part))] + [pad + (λ (str) + (if ((string-length str) . < . number-of-places) + (string-append (make-string (- number-of-places (string-length str)) #\0) + str) + str))]) + (string-append (format "~a" whole-part) + "." + (pad (format "~a" truncated/moved-decimal-part))))) + + (define (small-blank-line txt) + (let ([before (send txt last-position)]) + (send txt insert "\n") + (let ([after (send txt last-position)]) + (send txt change-style small-font-style before after)))) + + (define small-font-style (make-object style-delta% 'change-size 6)) + + ;; bold-delta : style-delta + (define bold-delta (make-object style-delta% 'change-bold)) + + ;; insert-profile-src-loc : syntax name -> string + (define (insert-profile-src-loc editor stx name) + (cond + [name + (let ([before (send editor last-position)]) + (send editor insert (format "~a" name)))] + [else + (let* ([src (syntax-source stx)] + [filename + (cond + [(string? src) src] + [(is-a? src editor<%>) (get-filename-from-editor src)] + [else (string-constant profiling-unknown-src)])] + [col (syntax-column stx)] + [line (syntax-line stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)] + [src + (cond + [(and col line) + (format "~a: ~a.~a" filename line col)] + [pos + (format "~a: ~a" filename pos)] + [else + filename])]) + (send editor insert src))])) + + ;; open-file-and-goto-position : string (union #f number) -> void + (define (open-file-and-goto-position filename pos) + (let ([frame (handler:edit-file filename)]) + (when (and frame + pos + (is-a? frame drscheme:unit:frame%)) + (let ([defs (send frame get-definitions-text)]) + (send defs set-position (- pos 1)))))) + + ;; get-src-filename : tst -> (union #f string) + (define (get-src-filename src) + (cond + [(string? src) src] + [(is-a? src text%) + (send src get-filename)] + [else #f])) + + ;; get-src-loc : syntax -> string + (define (get-src-loc expr) + (cond + [(and (number? (syntax-line expr)) + (number? (syntax-column expr)) + (number? (syntax-span expr))) + (format " ~a.~a [~a]" + (syntax-line expr) + (syntax-column expr) + (syntax-span expr))] + [(and (number? (syntax-position expr)) + (number? (syntax-span expr))) + (format " ~a-~a" + (syntax-position expr) + (syntax-span expr))] + [else ""])) + + (define (add-prefs-panel) + (preferences:add-panel + (string-constant profiling) + (λ (s-parent) + (letrec ([parent (make-object vertical-panel% s-parent)] + [msg (make-object message% + (string-constant profiling-color-config) + parent)] + [hp (make-object horizontal-pane% parent)] + [low (make-object button% (string-constant profiling-low-color) hp + (λ (x y) (color-callback #t)))] + [color-bar (make-object color-bar% hp)] + [high (make-object button% (string-constant profiling-high-color) hp + (λ (x y) (color-callback #f)))] + + [scale (instantiate radio-box% () + (label (string-constant profiling-scale)) + (parent parent) + (callback (λ (x y) (scale-callback))) + (choices + (list (string-constant profiling-sqrt) + (string-constant profiling-linear) + (string-constant profiling-square))))] + + [color-callback + (λ (low?) + (let ([color (get-color-from-user + (if low? + (string-constant profiling-choose-low-color) + (string-constant profiling-choose-high-color)) + #f + (preferences:get + (if low? + 'drscheme:profile:low-color + 'drscheme:profile:high-color)))]) + (when color + (preferences:set + (if low? 'drscheme:profile:low-color 'drscheme:profile:high-color) + color))))] + [scale-callback + (λ () + (preferences:set + 'drscheme:profile:scale + (case (send scale get-selection) + [(0) 'sqrt] + [(1) 'linear] + [(2) 'square])))]) + (preferences:add-callback + 'drscheme:profile:scale + (λ (p v) + (send scale set-selection + (case v + [(sqrt) 0] + [(linear) 1] + [(square) 2])))) + (send parent set-alignment 'left 'center) + (send hp stretchable-height #f) + parent)))) + + (define color-bar% + (class canvas% + (inherit get-client-size get-dc) + (field [pen (make-object pen% "black" 1 'solid)] + [in-on-paint? #f]) + (define/override (on-paint) + (set! in-on-paint? #t) + (let* ([dc (get-dc)] + [dummy-pen (send dc get-pen)] + [drscheme:profile:low-color (preferences:get 'drscheme:profile:low-color)] + [drscheme:profile:high-color (preferences:get 'drscheme:profile:high-color)] + [drscheme:profile:scale (preferences:get 'drscheme:profile:scale)]) + (let-values ([(w h) (get-client-size)]) + (let loop ([n 0]) + (when (n . <= . w) + (send pen set-color + (get-color-value/pref n w drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale)) + (send dc set-pen pen) + (send dc draw-line n 0 n h) + (send dc set-pen dummy-pen) + (loop (+ n 1)))) + (let-values ([(tw th ta td) (send dc get-text-extent + (string-constant profiling-example-text))]) + (send dc draw-text + (string-constant profiling-example-text) + (floor (- (/ w 2) (/ tw 2))) + (floor (- (/ h 2) (/ th 2))))))) + (set! in-on-paint? #f)) + + ;; queue callbacks here so that the preferences + ;; values are actually set by the time on-paint + ;; is called. + (preferences:add-callback + 'drscheme:profile:scale + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + (preferences:add-callback + 'drscheme:profile:low-color + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + (preferences:add-callback + 'drscheme:profile:high-color + (λ (p v) + (unless in-on-paint? + (queue-callback + (λ () + (on-paint)))))) + + (super-instantiate ()))) + + + + (define-values/invoke-unit/infer stacktrace@)) \ No newline at end of file diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 202b30833e..53fb85803a 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -52,26 +52,26 @@ test-coverage-tab-mixin)) (define-signature drscheme:debug^ extends drscheme:debug-cm^ (make-debug-error-display-handler - make-debug-error-display-handler/text make-debug-eval-handler - hide-backtrace-window - print-bug-to-stderr + error-display-handler/stacktrace test-coverage-enabled - profiling-enabled add-prefs-panel get-error-color - show-error-and-highlight - open-and-highlight-in-file + hide-backtrace-window show-backtrace-window + open-and-highlight-in-file get-cm-key - display-srcloc-in-error - show-syntax-error-context)) + ;show-error-and-highlight + ;print-bug-to-stderr + ;display-srclocs-in-error + ;show-syntax-error-context + )) (define-signature drscheme:module-langauge-cm^ (module-language<%>)) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 4f7082915f..5673bbfc0d 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -19,7 +19,8 @@ framework (lib "syntax-browser.ss" "mrlib") compiler/distribute - compiler/bundle-dist) + compiler/bundle-dist + "rep.ss") (import [prefix drscheme:debug: drscheme:debug^] [prefix drscheme:tools: drscheme:tools^] @@ -106,21 +107,6 @@ get-reader)) - - ; ;;; - ; - ; - ;;; ;;; ;;; ; ; ;;; ; ;;; - ; ; ; ; ; ; ; ; ; ; ; - ;;; ; ; ; ; ; ; ; ;;;;; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; - ;;; ;;;;; ;; ; ;; ;;;; ;;;;;; ;;; - ; - ; - ;;; - - (define simple-module-based-language% (class* object% (simple-module-based-language<%>) (init-field module @@ -131,7 +117,8 @@ (documentation-reference #f) (reader (λ (src port) (let ([v (parameterize ([read-accept-reader #t]) - (read-syntax src port))]) + (with-stacktrace-name + (read-syntax src port)))]) (if (eof-object? v) v (namespace-syntax-introduce v))))) @@ -149,19 +136,6 @@ - ;; ;;; ;; ;; - ; ; ; ; - ; ; ; ; ; - ; ;;; ; ;;; ;;;; ;; ;; ; ;;; ;;;; ;;;; ;;; ;;; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ;;;;; ; ; ;;;; ;;; ;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;; ; ;; ;;; ;;; ; ;;; ; ;;;;;; ;;; ; ;;; ;;; ; ;;; ;;; ;;; ; - - - - ;; simple-module-based-language->module-based-language : module-based-language<%> ;; transforms a simple-module-based-language into a module-based-language<%> (define simple-module-based-language->module-based-language-mixin @@ -502,23 +476,6 @@ (read-case-sensitive ,(simple-settings-case-sensitive setting))))) - - - ;;; - ; - ; ; - ; ; ;;;; ; ;;; ;;; ;;; ;; ;;;; ;;; ; ;;; - ; ; ; ;; ; ; ; ; ; ; ; ; ; ; - ;;;;; ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;;;; ;;; ;;;; ;; ;;;; ;;; ; ;;; ; ;;;; ;;; - ; ; - ; ; - ;;; ;;; - - - ;; module-based-language->language : module-based-language -> language<%> ;; given a module-based-language, implements a language (define module-based-language->language-mixin @@ -1147,7 +1104,8 @@ (namespace-syntax-introduce (datum->syntax #f - (cons '#%top-interaction s))) + (cons '#%top-interaction s) + s)) s)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 8223431967..969ae23739 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -424,8 +424,7 @@ stx)) ;; rewrite the module to use the scheme/base version of `module' (values v-name - #`(#,(datum->syntax #'here 'module) - name lang bodies ...)))] + #`(#,(datum->syntax #'here 'module) name lang bodies ...)))] [else (raise-syntax-error 'module-language "only module expressions are allowed" diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index d00b1d1fdd..fc03d75389 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -1,3 +1,5 @@ +#lang scheme/base + #| TODO @@ -17,1770 +19,1734 @@ TODO ;; original stdin/stdout of drscheme, instead of the ;; user's io ports, to aid any debugging printouts. ;; (esp. useful when debugging the users's io) -(module rep mzscheme - (require mzlib/class - mzlib/file - mzlib/pretty - mzlib/etc - mzlib/list - mzlib/port - mzlib/unit - "drsig.ss" - string-constants - mred - framework - (lib "external.ss" "browser") - (lib "default-lexer.ss" "syntax-color")) - - (provide rep@) - (define-struct unsaved-editor (editor)) +(require scheme/class + scheme/path + scheme/pretty + scheme/unit + scheme/list + "drsig.ss" + string-constants + setup/xref + scheme/gui/base + framework + browser/external) + +(provide rep@ with-stacktrace-name) + +(define-struct unsaved-editor (editor)) + +(define stacktrace-runtime-name + (string->uninterned-symbol "this-is-the-funny-name")) + +;; this function wraps its argument expression in some code in a non-tail manner +;; so that a new name gets put onto the mzscheme stack. DrScheme's exception +;; handlers trims the stack starting at this point to avoid showing drscheme's +;; internals on the stack in the REPL. +(define call-with-stacktrace-name + (eval `(let ([,stacktrace-runtime-name + (lambda (thunk) + (begin0 + (thunk) + (void)))]) + ,stacktrace-runtime-name) + (make-base-namespace))) + +(define-syntax-rule (with-stacktrace-name expr) + (call-with-stacktrace-name (lambda () expr))) + +(define no-breaks-break-parameterization + (parameterize-break + #f + (current-break-parameterization))) + +(define-unit rep@ + (import (prefix drscheme:init: drscheme:init^) + (prefix drscheme:language-configuration: drscheme:language-configuration/internal^) + (prefix drscheme:language: drscheme:language^) + (prefix drscheme:app: drscheme:app^) + (prefix drscheme:frame: drscheme:frame^) + (prefix drscheme:unit: drscheme:unit^) + (prefix drscheme:text: drscheme:text^) + (prefix drscheme:help-desk: drscheme:help-desk^) + (prefix drscheme:debug: drscheme:debug^) + [prefix drscheme:eval: drscheme:eval^]) + (export (rename drscheme:rep^ + [-text% text%] + [-text<%> text<%>])) - (define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name")) + (define -text<%> + (interface ((class->interface text%) + text:ports<%> + editor:file<%> + scheme:text<%> + color:text<%> + text:ports<%>) + reset-highlighting + highlight-errors + highlight-errors/exn + + get-user-custodian + get-user-eventspace + get-user-thread + get-user-namespace + + get-definitions-text + + kill-evaluation + + display-results + + run-in-evaluation-thread + after-many-evals + + shutdown + + get-error-ranges + reset-error-ranges + + reset-console + + copy-prev-previous-expr + copy-next-previous-expr + copy-previous-expr + + + initialize-console + + reset-pretty-print-width + + get-prompt + insert-prompt + get-context)) - ;; this macro wraps its argument expression in some code in a non-tail manner - ;; so that a new name gets put onto the mzscheme stack. DrScheme's exception - ;; handlers trims the stack starting at this point to avoid showing drscheme's - ;; internals on the stack in the REPL. - (define-syntax (with-stacktrace-name stx) - (syntax-case stx () - [(_ e) - (with-syntax ([my-funny-name (syntax-local-value #'stacktrace-name)]) - (syntax - (let ([my-funny-name (λ () (begin0 e (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) - (random 1))))]) - ((if (zero? (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) - (random 1))) - my-funny-name - values)))))])) + (define context<%> + (interface () + ensure-rep-shown ;; (interactions-text -> void) + ;; make the rep visible in the frame + + needs-execution ;; (-> boolean) + ;; ask if things have changed that would mean the repl is out + ;; of sync with the program being executed in it. + + enable-evaluation ;; (-> void) + ;; make the context enable all methods of evaluation + ;; (disable buttons, menus, etc) + + disable-evaluation ;; (-> void) + ;; make the context enable all methods of evaluation + ;; (disable buttons, menus, etc) + + set-breakables ;; (union thread #f) (union custodian #f) -> void + ;; the context might initiate breaks or kills to + ;; the thread passed to this function + + get-breakables ;; -> (values (union thread #f) (union custodian #f)) + ;; returns the last values passed to set-breakables. + + reset-offer-kill ;; (-> void) + ;; the next time the break button is pushed, it will only + ;; break. (if the break button is clicked twice without + ;; this method being called in between, it will offer to + ;; kill the user's program) + + update-running ;; (boolean -> void) + ;; a callback to indicate that the repl may have changed its running state + ;; use the repls' get-in-evaluation? method to find out what the current state is. + + clear-annotations ;; (-> void) + ;; clear any error highlighting context + + get-directory ;; (-> (union #f string[existing directory])) + ;; returns the directory that should be the default for + ;; the `current-directory' and `current-load-relative-directory' + ;; parameters in the repl. + )) - (define stacktrace-runtime-name - (let-syntax ([m (λ (x) (with-syntax ([x (syntax-local-value #'stacktrace-name)]) - (syntax 'x)))]) - (m))) + (define sized-snip<%> + (interface ((class->interface snip%)) + ;; get-character-width : -> number + ;; returns the number of characters wide the snip is, + ;; for use in pretty printing the snip. + get-character-width)) - (define no-breaks-break-parameterization - (parameterize-break - #f - (current-break-parameterization))) + ;; current-language-settings : (parameter language-setting) + ;; set to the current language and its setting on the user's thread. + (define current-language-settings (make-parameter #f)) - (define-unit rep@ - (import (prefix drscheme:init: drscheme:init^) - (prefix drscheme:language-configuration: drscheme:language-configuration/internal^) - (prefix drscheme:language: drscheme:language^) - (prefix drscheme:app: drscheme:app^) - (prefix drscheme:frame: drscheme:frame^) - (prefix drscheme:unit: drscheme:unit^) - (prefix drscheme:text: drscheme:text^) - (prefix drscheme:help-desk: drscheme:help-desk^) - (prefix drscheme:debug: drscheme:debug^) - [prefix drscheme:eval: drscheme:eval^]) - (export (rename drscheme:rep^ - [-text% text%] - [-text<%> text<%>])) - - (define -text<%> - (interface ((class->interface text%) - text:ports<%> - editor:file<%> - scheme:text<%> - color:text<%> - text:ports<%>) - reset-highlighting - highlight-errors - highlight-errors/exn - - get-user-custodian - get-user-eventspace - get-user-thread - get-user-namespace - - get-definitions-text - - kill-evaluation - - display-results - - run-in-evaluation-thread - after-many-evals - - shutdown - - get-error-ranges - reset-error-ranges - - reset-console - - copy-prev-previous-expr - copy-next-previous-expr - copy-previous-expr - - - initialize-console - - reset-pretty-print-width - - get-prompt - insert-prompt - get-context)) - - (define context<%> - (interface () - ensure-rep-shown ;; (interactions-text -> void) - ;; make the rep visible in the frame - - needs-execution ;; (-> boolean) - ;; ask if things have changed that would mean the repl is out - ;; of sync with the program being executed in it. - - enable-evaluation ;; (-> void) - ;; make the context enable all methods of evaluation - ;; (disable buttons, menus, etc) - - disable-evaluation ;; (-> void) - ;; make the context enable all methods of evaluation - ;; (disable buttons, menus, etc) - - set-breakables ;; (union thread #f) (union custodian #f) -> void - ;; the context might initiate breaks or kills to - ;; the thread passed to this function - - get-breakables ;; -> (values (union thread #f) (union custodian #f)) - ;; returns the last values passed to set-breakables. - - reset-offer-kill ;; (-> void) - ;; the next time the break button is pushed, it will only - ;; break. (if the break button is clicked twice without - ;; this method being called in between, it will offer to - ;; kill the user's program) - - update-running ;; (boolean -> void) - ;; a callback to indicate that the repl may have changed its running state - ;; use the repls' get-in-evaluation? method to find out what the current state is. - - clear-annotations ;; (-> void) - ;; clear any error highlighting context - - get-directory ;; (-> (union #f string[existing directory])) - ;; returns the directory that should be the default for - ;; the `current-directory' and `current-load-relative-directory' - ;; parameters in the repl. - )) - - (define sized-snip<%> - (interface ((class->interface snip%)) - ;; get-character-width : -> number - ;; returns the number of characters wide the snip is, - ;; for use in pretty printing the snip. - get-character-width)) - - ;; current-language-settings : (parameter language-setting) - ;; set to the current language and its setting on the user's thread. - (define current-language-settings (make-parameter #f)) - - ;; current-rep : (parameter (union #f (instanceof rep:text%))) - ;; the repl that controls the evaluation in this thread. - (define current-rep (make-parameter #f)) - - ;; a port that accepts values for printing in the repl - (define current-value-port (make-parameter #f)) - - ;; drscheme-error-display-handler : (string (union #f exn) -> void - ;; =User= - ;; the timing is a little tricky here. - ;; the file icon must appear before the error message in the text, so that happens first. - ;; the highlight must be set after the error message, because inserting into the text resets - ;; the highlighting. - (define (drscheme-error-display-handler msg exn) - (let* ([cut-stack (if (and (exn? exn) - (main-user-eventspace-thread?)) - (cut-out-top-of-stack exn) - '())] - [srclocs-stack (filter values (map cdr cut-stack))] - [stack - (filter - values - (map (λ (srcloc) - (let ([source (srcloc-source srcloc)] - [pos (srcloc-position srcloc)] - [span (srcloc-span srcloc)]) - (and source pos span - srcloc))) - srclocs-stack))] - [src-locs (if (exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn) - (if (null? stack) - '() - (list (car srclocs-stack))))]) - - ;; for use in debugging the stack trace stuff - #; - (when (exn? exn) - (print-struct #t) - (for-each - (λ (frame) (printf " ~s\n" frame)) - (continuation-mark-set->context (exn-continuation-marks exn))) - (printf "\n")) - - (unless (null? stack) - (drscheme:debug:print-bug-to-stderr msg stack)) - (for-each drscheme:debug:display-srcloc-in-error src-locs) - (display msg (current-error-port)) - (when (exn:fail:syntax? exn) - (drscheme:debug:show-syntax-error-context (current-error-port) exn)) - (newline (current-error-port)) - (flush-output (current-error-port)) - (let ([rep (current-rep)]) - (when (and (is-a? rep -text<%>) - (eq? (current-error-port) (send rep get-err-port))) - (parameterize ([current-eventspace drscheme:init:system-eventspace]) - (queue-callback - (λ () - (send rep highlight-errors src-locs stack)))))))) - - (define (main-user-eventspace-thread?) - (let ([rep (current-rep)]) - (and rep - (eq? (eventspace-handler-thread (send rep get-user-eventspace)) - (current-thread))))) - - (define (cut-out-top-of-stack exn) - (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))]) - (let loop ([stack initial-stack]) - (cond - [(null? stack) - (unless (exn:break? exn) - ;; give break exn's a free pass on this one. - ;; sometimes they get raised in a funny place. - ;; (see call-with-break-parameterization below) - (unless (null? initial-stack) - ;; sometimes, mzscheme just doesn't have any backtrace all. in that case, - ;; don't print anything either. - (fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))) - initial-stack] - [else - (let ([top (car stack)]) - (cond - [(cut-here? top) null] - [else (cons top (loop (cdr stack)))]))])))) - - ;; is-cut? : any symbol -> boolean - ;; determines if this stack entry is really - (define (cut-here? top) - (and (pair? top) - (let* ([fn-name (car top)] - [srcloc (cdr top)] - [source (and srcloc (srcloc-source srcloc))]) - (and (eq? fn-name stacktrace-runtime-name) - (path? source) - (let loop ([path source] - [pieces '(#"rep.ss" #"private" #"drscheme" #"collects")]) - (cond - [(null? pieces) #t] - [else - (let-values ([(base name dir?) (split-path path)]) - (and (equal? (path-element->bytes name) (car pieces)) - (loop base (cdr pieces))))])))))) - - (define drs-bindings-keymap (make-object keymap:aug-keymap%)) + ;; current-rep : (parameter (union #f (instanceof rep:text%))) + ;; the repl that controls the evaluation in this thread. + (define current-rep (make-parameter #f)) + + ;; a port that accepts values for printing in the repl + (define current-value-port (make-parameter #f)) + + ;; drscheme-error-display-handler : (string (union #f exn) -> void + ;; =User= + ;; the timing is a little tricky here. + ;; the file icon must appear before the error message in the text, so that happens first. + ;; the highlight must be set after the error message, because inserting into the text resets + ;; the highlighting. + (define (drscheme-error-display-handler msg exn) + (let* ([cut-stack (if (and (exn? exn) + (main-user-eventspace-thread?)) + (cut-out-top-of-stack exn) + '())] + [srclocs-stack (filter values (map cdr cut-stack))] + [stack + (filter + values + (map (λ (srcloc) + (let ([source (srcloc-source srcloc)] + [pos (srcloc-position srcloc)] + [span (srcloc-span srcloc)]) + (and source pos span + srcloc))) + srclocs-stack))] + [src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + (if (null? stack) + '() + (list (car srclocs-stack))))]) + + ;; for use in debugging the stack trace stuff + #; + (when (exn? exn) + (print-struct #t) + (for-each + (λ (frame) (printf " ~s\n" frame)) + (continuation-mark-set->context (exn-continuation-marks exn))) + (printf "\n")) + + (drscheme:debug:error-display-handler/stacktrace msg exn stack))) + + (define (main-user-eventspace-thread?) + (let ([rep (current-rep)]) + (and rep + (eq? (eventspace-handler-thread (send rep get-user-eventspace)) + (current-thread))))) + + (define (cut-out-top-of-stack exn) + (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))]) + (let loop ([stack initial-stack]) + (cond + [(null? stack) + (unless (exn:break? exn) + ;; give break exn's a free pass on this one. + ;; sometimes they get raised in a funny place. + ;; (see call-with-break-parameterization below) + (unless (null? initial-stack) + ;; sometimes, mzscheme just doesn't have any backtrace all. in that case, + ;; don't print anything either. + (fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))) + initial-stack] + [else + (let ([top (car stack)]) + (cond + [(cut-here? top) null] + [else (cons top (loop (cdr stack)))]))])))) + + ;; is-cut? : any symbol -> boolean + ;; determines if this stack entry is drscheme's barrier in the stacktrace + (define (cut-here? top) + (and (pair? top) + (let ([fn-name (car top)]) + (eq? fn-name stacktrace-runtime-name)))) + + (define drs-bindings-keymap (make-object keymap:aug-keymap%)) + + (let ([with-drs-frame + (λ (obj f) + (when (is-a? obj editor<%>) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame drscheme:unit:frame%) + (f frame)))))))]) (send drs-bindings-keymap add-function "search-help-desk" (λ (obj evt) - (cond - [(is-a? obj text%) - (let* ([start (send obj get-start-position)] - [end (send obj get-end-position)] - [str (if (= start end) - (drscheme:unit:find-symbol obj start) - (send obj get-text start end))]) - (if (equal? "" str) - (drscheme:help-desk:help-desk) - (let ([language (let ([canvas (send obj get-canvas)]) - (and canvas - (let ([tlw (send canvas get-top-level-window)]) - (and (is-a? tlw drscheme:unit:frame<%>) - (send (send tlw get-definitions-text) - get-next-settings)))))]) - (drscheme:help-desk:help-desk str))))] - [else - (drscheme:help-desk:help-desk)]))) - (let ([with-drs-frame - (λ (obj f) - (when (is-a? obj editor<%>) - (let ([canvas (send obj get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame drscheme:unit:frame%) - (f frame)))))))]) - + (with-drs-frame + obj + (λ (frame) + (cond + [(is-a? obj text%) + + ;; this just uses the thunk argument of load-collections-xref in order + ;; to ensure that there is some GUI feedback the first time the help + ;; desk index is loaded. + (when frame + (let ([id 'loading-docs]) + (send frame open-status-line id) + (load-collections-xref + (λ () + (send frame update-status-line id (string-constant help-desk-loading-documentation-index)))) + (send frame close-status-line id))) + + (let* ([start (send obj get-start-position)] + [end (send obj get-end-position)] + [str (if (= start end) + (drscheme:unit:find-symbol obj start) + (send obj get-text start end))]) + (if (equal? "" str) + (drscheme:help-desk:help-desk) + (let ([language (let ([canvas (send obj get-canvas)]) + (and canvas + (let ([tlw (send canvas get-top-level-window)]) + (and (is-a? tlw drscheme:unit:frame<%>) + (send (send tlw get-definitions-text) + get-next-settings)))))]) + (drscheme:help-desk:help-desk str))))] + [else + (drscheme:help-desk:help-desk)]))))) + + (send drs-bindings-keymap add-function + "execute" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) + (send frame execute-callback))))) + + (let ([shift-focus + (λ (adjust frame) + (let ([candidates (adjust (append + (send frame get-definitions-canvases) + (send frame get-interactions-canvases)))]) + (let loop ([cs candidates]) + (cond + [(null? cs) (send (car candidates) focus)] + [else + (let ([c (car cs)]) + (if (send c has-focus?) + (send (if (null? (cdr cs)) + (car candidates) + (cadr cs)) + focus) + (loop (cdr cs))))]))))]) (send drs-bindings-keymap add-function - "execute" - (λ (obj evt) - (with-drs-frame - obj - (λ (frame) - (send frame execute-callback))))) - - (let ([shift-focus - (λ (adjust frame) - (let ([candidates (adjust (append - (send frame get-definitions-canvases) - (send frame get-interactions-canvases)))]) - (let loop ([cs candidates]) - (cond - [(null? cs) (send (car candidates) focus)] - [else - (let ([c (car cs)]) - (if (send c has-focus?) - (send (if (null? (cdr cs)) - (car candidates) - (cadr cs)) - focus) - (loop (cdr cs))))]))))]) - (send drs-bindings-keymap add-function - "toggle-focus-between-definitions-and-interactions" - (λ (obj evt) - (with-drs-frame - obj - (λ (frame) (shift-focus values frame))))) - (send drs-bindings-keymap add-function - "toggle-focus-between-definitions-and-interactions backwards" - (λ (obj evt) - (with-drs-frame - obj - (λ (frame) (shift-focus reverse frame)))))) - (send drs-bindings-keymap add-function - "next-tab" + "toggle-focus-between-definitions-and-interactions" (λ (obj evt) (with-drs-frame obj - (λ (frame) (send frame next-tab))))) + (λ (frame) (shift-focus values frame))))) (send drs-bindings-keymap add-function - "prev-tab" + "toggle-focus-between-definitions-and-interactions backwards" (λ (obj evt) (with-drs-frame obj - (λ (frame) (send frame prev-tab)))))) - - (send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions") - (send drs-bindings-keymap map-function "c:x;p" "toggle-focus-between-definitions-and-interactions backwards") - (send drs-bindings-keymap map-function "c:f6" "toggle-focus-between-definitions-and-interactions") - (send drs-bindings-keymap map-function "f5" "execute") - (send drs-bindings-keymap map-function "f1" "search-help-desk") - (send drs-bindings-keymap map-function "c:tab" "next-tab") - (send drs-bindings-keymap map-function "c:s:tab" "prev-tab") - (send drs-bindings-keymap map-function "d:s:right" "next-tab") - (send drs-bindings-keymap map-function "d:s:left" "prev-tab") - (send drs-bindings-keymap map-function "c:pagedown" "next-tab") - (send drs-bindings-keymap map-function "c:pageup" "prev-tab") - - (define (get-drs-bindings-keymap) drs-bindings-keymap) - - ;; drs-bindings-keymap-mixin : - ;; ((implements editor:keymap<%>) -> (implements editor:keymap<%>)) - ;; for any x that is an instance of the resulting class, - ;; (is-a? (send (send x get-canvas) get-top-level-frame) drscheme:unit:frame%) - (define drs-bindings-keymap-mixin - (mixin (editor:keymap<%>) (editor:keymap<%>) - (define/override (get-keymaps) - (cons drs-bindings-keymap (super get-keymaps))) - (super-instantiate ()))) - - ;; Max length of output queue (user's thread blocks if the - ;; queue is full): - (define output-limit-size 2000) - - (define (printf . args) (apply fprintf drscheme:init:original-output-port args)) - - (define setup-scheme-interaction-mode-keymap - (λ (keymap) - (send keymap add-function "put-previous-sexp" - (λ (text event) - (send text copy-prev-previous-expr))) - (send keymap add-function "put-next-sexp" - (λ (text event) - (send text copy-next-previous-expr))) - - (keymap:send-map-function-meta keymap "p" "put-previous-sexp") - (keymap:send-map-function-meta keymap "n" "put-next-sexp") - (send keymap map-function "c:up" "put-previous-sexp") - (send keymap map-function "c:down" "put-next-sexp"))) - - (define scheme-interaction-mode-keymap (make-object keymap:aug-keymap%)) - (setup-scheme-interaction-mode-keymap scheme-interaction-mode-keymap) - - (define drs-font-delta (make-object style-delta% 'change-family 'decorative)) - - (define output-delta (make-object style-delta%)) ; used to be 'change-weight 'bold - (define result-delta (make-object style-delta%)) ; used to be 'change-weight 'bold - (define error-delta (make-object style-delta% - 'change-style - 'italic)) - (send error-delta set-delta-foreground (make-object color% 255 0 0)) - (send result-delta set-delta-foreground (make-object color% 0 0 175)) - (send output-delta set-delta-foreground (make-object color% 150 0 150)) - - (define error-text-style-delta (make-object style-delta%)) - (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) - - (define grey-delta (make-object style-delta%)) - (send grey-delta set-delta-foreground "GREY") - - (define welcome-delta (make-object style-delta% 'change-family 'decorative)) - (define click-delta (gui-utils:get-clickback-delta)) - (define red-delta (make-object style-delta%)) - (define dark-green-delta (make-object style-delta%)) - (send* red-delta - (copy welcome-delta) - (set-delta-foreground "RED")) - (send* dark-green-delta - (copy welcome-delta) - (set-delta-foreground "dark green")) - (define warning-style-delta (make-object style-delta% 'change-bold)) - (send* warning-style-delta - (set-delta-foreground "BLACK") - (set-delta-background "YELLOW")) - (define (get-welcome-delta) welcome-delta) - (define (get-dark-green-delta) dark-green-delta) - - ;; is-default-settings? : language-settings -> boolean - ;; determines if the settings in `language-settings' - ;; correspond to the default settings of the language. - (define (is-default-settings? language-settings) - (send (drscheme:language-configuration:language-settings-language language-settings) - default-settings? - (drscheme:language-configuration:language-settings-settings language-settings))) - - (define (extract-language-name language-settings) - (send (drscheme:language-configuration:language-settings-language language-settings) - get-language-name)) - (define (extract-language-style-delta language-settings) - (send (drscheme:language-configuration:language-settings-language language-settings) - get-style-delta)) - (define (extract-language-url language-settings) - (send (drscheme:language-configuration:language-settings-language language-settings) - get-language-url)) - - (define-struct sexp (left right prompt)) - - (define console-max-save-previous-exprs 30) - (let* ([list-of? (λ (p?) - (λ (l) - (and (list? l) - (andmap p? l))))] - [snip/string? (λ (s) (or (is-a? s snip%) (string? s)))] - [list-of-snip/strings? (list-of? snip/string?)] - [list-of-lists-of-snip/strings? (list-of? list-of-snip/strings?)]) - (preferences:set-default - 'drscheme:console-previous-exprs - null - list-of-lists-of-snip/strings?)) - (let ([marshall - (λ (lls) - (map (λ (ls) - (list - (apply - string-append - (reverse - (map (λ (s) - (cond - [(is-a? s string-snip%) - (send s get-text 0 (send s get-count))] - [(string? s) s] - [else "'non-string-snip"])) - ls))))) - lls))] - [unmarshall (λ (x) x)]) - (preferences:set-un/marshall - 'drscheme:console-previous-exprs - marshall unmarshall)) - - (define color? ((get-display-depth) . > . 8)) - - ;; instances of this interface provide a context for a rep:text% - ;; its connection to its graphical environment (ie frame) for - ;; error display and status infromation is all mediated - ;; through an instance of this interface. - - (define file-icon - (let ([bitmap - (make-object bitmap% - (build-path (collection-path "icons") "file.gif"))]) - (if (send bitmap ok?) - (make-object image-snip% bitmap) - (make-object string-snip% "[open file]")))) - - - ;; insert/delta : (instanceof text%) (union snip string) (listof style-delta%) *-> (values number number) - ;; inserts the string/stnip into the text at the end and changes the - ;; style of the newly inserted text based on the style deltas. - (define (insert/delta text s . deltas) - (let ([before (send text last-position)]) - (send text insert s before before #f) - (let ([after (send text last-position)]) - (for-each (λ (delta) - (when (is-a? delta style-delta%) - (send text change-style delta before after))) - deltas) - (values before after)))) - - (define text-mixin - (mixin ((class->interface text%) - text:ports<%> - editor:file<%> - scheme:text<%> - color:text<%> - text:ports<%>) - (-text<%>) - (init-field context) - (inherit auto-wrap - begin-edit-sequence - change-style - clear-box-input-port - clear-undos - clear-input-port - clear-output-ports - delete - delete/io - end-edit-sequence - erase - find-snip - find-string - freeze-colorer - get-active-canvas - get-admin - get-can-close-parent - get-canvases - get-character - get-end-position - get-err-port - get-extent - get-focus-snip - get-in-port - get-in-box-port - get-insertion-point - get-out-port - get-regions - get-snip-position - get-start-position - get-styles-fixed - get-style-list - get-text - get-top-level-window - get-unread-start-point - get-value-port - in-edit-sequence? - insert - insert-before - insert-between - invalidate-bitmap-cache - is-frozen? - is-locked? - last-position - line-location - lock - paragraph-start-position - position-line - position-paragraph - release-snip - reset-input-box - reset-regions - run-after-edit-sequence - scroll-to-position - send-eof-to-in-port - set-allow-edits - set-caret-owner - set-clickback - set-insertion-point - set-position - set-styles-sticky - set-styles-fixed - set-unread-start-point - split-snip - thaw-colorer) - - (define definitions-text 'not-yet-set-definitions-text) - (define/public (set-definitions-text dt) (set! definitions-text dt)) - (define/public (get-definitions-text) definitions-text) - - (unless (is-a? context context<%>) - (error 'drscheme:rep:text% - "expected an object that implements drscheme:rep:context<%> as initialization argument, got: ~e" - context)) - - (define/public (get-context) context) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; - ;;; User -> Kernel ;;; - ;;; ;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; =User= (probably doesn't matter) - (define/private queue-system-callback - (opt-lambda (ut thunk [always? #f]) - (parameterize ([current-eventspace drscheme:init:system-eventspace]) - (queue-callback - (λ () - (when (or always? (eq? ut (get-user-thread))) - (thunk))) - #f)))) - - ;; =User= - (define/private queue-system-callback/sync - (λ (ut thunk) - (let ([s (make-semaphore 0)]) - (queue-system-callback - ut - (λ () - (when (eq? ut (get-user-thread)) - (thunk)) - (semaphore-post s)) - #t) - (semaphore-wait s)))) - - ;; display-results : (listof TST) -> void - ;; prints each element of anss that is not void as values in the REPL. - (define/public (display-results anss) ; =User=, =Handler=, =Breaks= - (display-results/void (filter (λ (x) (not (void? x))) anss))) - - ;; display-results : (listof TST) -> void - ;; prints each element of anss that is not void as values in the REPL. - (define/public (display-results/void anss) ; =User=, =Handler=, =Breaks= - (for-each - (λ (v) - (let* ([ls (current-language-settings)] - [lang (drscheme:language-configuration:language-settings-language ls)] - [settings (drscheme:language-configuration:language-settings-settings ls)]) - (send lang render-value/format - v - settings - (get-value-port) - (get-repl-char-width)))) - anss)) - - ;; get-repl-char-width : -> (and/c exact? integer?) - ;; returns the width of the repl in characters, or 80 if the - ;; answer cannot be found. - (define/private (get-repl-char-width) - (let ([admin (get-admin)] - [standard (send (get-style-list) find-named-style "Standard")]) - (if (and admin standard) - (let ([bw (box 0)]) - (send admin get-view #f #f bw #f) - (let* ([dc (send admin get-dc)] - [standard-font (send standard get-font)] - [old-font (send dc get-font)]) - (send dc set-font standard-font) - (let* ([char-width (send dc get-char-width)] - [answer (inexact->exact (floor (/ (unbox bw) char-width)))]) - (send dc set-font old-font) - answer))) - 80))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; - ;;; Error Highlighting ;;; - ;;; ;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) - (define error-ranges #f) - (define/public (get-error-ranges) error-ranges) - (define internal-reset-callback void) - (define internal-reset-error-arrows-callback void) - (define/public (reset-error-ranges) - (internal-reset-callback) - (internal-reset-error-arrows-callback)) - - ;; highlight-error : file number number -> void - (define/public (highlight-error file start end) - (highlight-errors (list (make-srcloc file #f #f start (- end start))) #f)) - - ;; highlight-errors/exn : exn -> void - ;; highlights all of the errors associated with the exn (incl. arrows) - (define/public (highlight-errors/exn exn) - (let ([locs (cond - [(exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn)] - [else '()])]) - (highlight-errors locs #f))) - - ;; =Kernel= =handler= - ;; highlight-errors : (listof srcloc) - ;; (union #f (listof srcloc)) - ;; -> (void) - (define/public (highlight-errors raw-locs raw-error-arrows) - (let* ([cleanup-locs - (λ (locs) - (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>) - (number? (srcloc-position loc)) - (number? (srcloc-span loc)))) - (map (λ (srcloc) - (cond - [(send definitions-text port-name-matches? (srcloc-source srcloc)) - (make-srcloc definitions-text - (srcloc-line srcloc) - (srcloc-column srcloc) - (srcloc-position srcloc) - (srcloc-span srcloc))] - [(unsaved-editor? (srcloc-source srcloc)) - (make-srcloc (unsaved-editor-editor (srcloc-source srcloc)) - (srcloc-line srcloc) - (srcloc-column srcloc) - (srcloc-position srcloc) - (srcloc-span srcloc))] - [else srcloc])) - locs)))] - [locs (cleanup-locs raw-locs)] - [error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))]) - (reset-highlighting) - - (set! error-ranges locs) - - (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs) - - (when color? - (let ([resets - (map (λ (loc) - (let* ([file (srcloc-source loc)] - [start (- (srcloc-position loc) 1)] - [span (srcloc-span loc)] - [finish (+ start span)]) - (send file highlight-range start finish (drscheme:debug:get-error-color) #f #f 'high))) - locs)]) - - (when (and definitions-text error-arrows) - (let ([filtered-arrows - (remove-duplicate-error-arrows - (filter - (λ (arr) (embedded-in? (srcloc-source arr) definitions-text)) - error-arrows))]) - (send definitions-text set-error-arrows filtered-arrows))) - - (set! internal-reset-callback - (λ () - (set! error-ranges #f) - (when definitions-text - (send definitions-text set-error-arrows #f)) - (set! internal-reset-callback void) - (for-each (λ (x) (x)) resets))))) - - (let* ([first-loc (and (pair? locs) (car locs))] - [first-file (and first-loc (srcloc-source first-loc))] - [first-start (and first-loc (- (srcloc-position first-loc) 1))] - [first-span (and first-loc (srcloc-span first-loc))]) - - (when first-loc - (let ([first-finish (+ first-start first-span)]) - (when (eq? first-file definitions-text) ;; only move set the cursor in the defs window - (send first-file set-position first-start first-start)) - (send first-file scroll-to-position first-start #f first-finish))) - - (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) - - (when first-loc - (send first-file set-caret-owner (get-focus-snip) 'global))))) - - (define/public (reset-highlighting) - (reset-error-ranges)) - - ;; remove-duplicate-error-arrows : (listof X) -> (listof X) - ;; duplicate arrows point from and to the same place -- only - ;; need one arrow for each pair of locations they point to. - (define/private (remove-duplicate-error-arrows error-arrows) - (let ([ht (make-hash-table 'equal)]) - (let loop ([arrs error-arrows] - [n 0]) - (unless (null? arrs) - (hash-table-put! ht (car arrs) n) - (loop (cdr arrs) (+ n 1)))) - (let* ([unsorted (hash-table-map ht list)] - [sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))] - [arrs (map car sorted)]) - arrs))) - - (define/private (embedded-in? txt-inner txt-outer) - (let loop ([txt-inner txt-inner]) - (cond - [(eq? txt-inner txt-outer) #t] - [else (let ([admin (send txt-inner get-admin)]) - (and (is-a? admin editor-snip-editor-admin<%>) - (loop (send (send (send admin get-snip) get-admin) get-editor))))]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; specialization - ;; - - (define/override (after-io-insertion) - (super after-io-insertion) - (let ([canvas (get-active-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (let ([tab (send definitions-text get-tab)]) - (when (eq? (send frame get-current-tab) tab) - (send context ensure-rep-shown this))))))) - - (define/augment (after-insert start len) - (inner (void) after-insert start len) - (cond - [(in-edit-sequence?) - (set! had-an-insert (cons (cons start len) had-an-insert))] - [else (update-after-insert start len)])) - - ;; private field - (define had-an-insert '()) - - (define/augment (after-edit-sequence) - (inner (void) after-edit-sequence) - (let ([to-clean had-an-insert]) - (set! had-an-insert '()) - (for-each - (lambda (pr) - (update-after-insert (car pr) (cdr pr))) - to-clean))) - - (define/private (update-after-insert start len) - (unless inserting-prompt? - (reset-highlighting)) - (when (and prompt-position (< start prompt-position)) - - ;; trim extra space, according to preferences - #; - (let* ([start (get-repl-header-end)] - [end (get-insertion-point)] - [space (- end start)] - [pref (preferences:get 'drscheme:repl-buffer-size)]) - (when (car pref) - (let ([max-space (* 1000 (cdr pref))]) - (when (space . > . max-space) - (let ([to-delete-end (+ start (- space max-space))]) - (delete/io start to-delete-end)))))) - - (set! prompt-position (get-unread-start-point)) - (reset-regions (append (all-but-last (get-regions)) - (list (list prompt-position 'end)))))) - - (define/augment (after-delete x y) - (unless inserting-prompt? - (reset-highlighting)) - (inner (void) after-delete x y)) - - (define/override get-keymaps - (λ () - (cons scheme-interaction-mode-keymap (super get-keymaps)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; - ;;; Evaluation ;;; - ;;; ;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define/public (eval-busy?) - (not (and (get-user-thread) - (thread-running? (get-user-thread))))) - - (field (user-language-settings #f) - (user-custodian-parent #f) - (memory-killed-thread #f) - (user-custodian #f) - (custodian-limit (and (custodian-memory-accounting-available?) - (preferences:get 'drscheme:limit-memory))) - (user-eventspace-box (make-weak-box #f)) - (user-namespace-box (make-weak-box #f)) - (user-eventspace-main-thread #f) - (user-break-parameterization #f) - - ;; user-exit-code (union #f (integer-in 0 255)) - ;; #f indicates that exit wasn't called. Integer indicates exit code - (user-exit-code #f)) - - (define/public (get-user-language-settings) user-language-settings) - (define/public (get-user-custodian) user-custodian) - (define/public (get-user-eventspace) (weak-box-value user-eventspace-box)) - (define/public (get-user-thread) user-eventspace-main-thread) - (define/public (get-user-namespace) (weak-box-value user-namespace-box)) - (define/pubment (get-user-break-parameterization) user-break-parameterization) ;; final method - (define/pubment (get-custodian-limit) custodian-limit) - (define/pubment (set-custodian-limit c) (set! custodian-limit c)) - (field (in-evaluation? #f) - (ask-about-kill? #f)) - (define/public (get-in-evaluation?) in-evaluation?) - - (define/private (insert-warning message) - (begin-edit-sequence) - (let ([start (get-insertion-point)]) - (insert-before message) - (let ([end (get-insertion-point)]) - (change-style warning-style-delta start end))) - (insert-before "\n") - (end-edit-sequence)) - - (field (already-warned? #f)) - - (define/private (cleanup) - (set! in-evaluation? #f) - (update-running #f) - (unless (and (get-user-thread) (thread-running? (get-user-thread))) - (lock #t) - (unless shutting-down? - (no-user-evaluation-message - (let ([canvas (get-active-canvas)]) - (and canvas - (send canvas get-top-level-window))) - user-exit-code - (not (thread-running? memory-killed-thread)))))) - (field (need-interaction-cleanup? #f)) - - (define/private (no-user-evaluation-message frame exit-code memory-killed?) - (let* ([new-limit (and custodian-limit (+ (* 1024 1024 128) custodian-limit))] - [ans (message-box/custom - (string-constant evaluation-terminated) - (string-append - (string-constant evaluation-terminated-explanation) - (if exit-code - (string-append - "\n\n" - (if (zero? exit-code) - (string-constant exited-successfully) - (format (string-constant exited-with-error-code) exit-code))) - "") - (if memory-killed? - (string-append - "\n\n" - (string-constant program-ran-out-of-memory)) - "")) - (string-constant ok) - #f - (and memory-killed? - new-limit - (format "Increase memory limit to ~a megabytes" - (floor (/ new-limit 1024 1024)))) - frame - '(default=1 stop) - )]) - (when (equal? ans 3) - (set-custodian-limit new-limit) - (preferences:set 'drscheme:limit-memory new-limit)) - (void))) - - (define/private (cleanup-interaction) ; =Kernel=, =Handler= - (set! need-interaction-cleanup? #f) - (begin-edit-sequence) - (set-caret-owner #f 'display) - (cleanup) - (end-edit-sequence) - (send context set-breakables #f #f) - (send context enable-evaluation)) - - (define/augment (submit-to-port? key) - (and prompt-position - (only-whitespace-after-insertion-point) - (submit-predicate this prompt-position))) - - (define/private (only-whitespace-after-insertion-point) - (let ([start (get-start-position)] - [end (get-end-position)]) - (and (= start end) - (let loop ([pos start]) - (cond - [(= pos (last-position)) #t] - [else (and (char-whitespace? (get-character pos)) - (loop (+ pos 1)))]))))) - - (define/augment (on-submit) - (inner (void) on-submit) - (when (and (get-user-thread) - (thread-running? (get-user-thread))) - ;; the -2 drops the last newline from history (why -2 and not -1?!) - (save-interaction-in-history prompt-position (- (last-position) 2)) - - (let* ([old-regions (get-regions)] - [abl (all-but-last old-regions)] - [lst (car (last-pair old-regions))]) - (reset-regions (append abl (list (list (list-ref lst 0) (last-position)))))) - - (let ([needs-execution (send context needs-execution)]) - (when (if (preferences:get 'drscheme:execute-warning-once) - (and (not already-warned?) - needs-execution) - needs-execution) - (set! already-warned? #t) - (insert-warning needs-execution))) - - ;; lets us know we are done with this one interaction - ;; (since there may be multiple expressions at the prompt) - (send-eof-to-in-port) - - (set! prompt-position #f) - (evaluate-from-port - (get-in-port) - #f + (λ (frame) (shift-focus reverse frame)))))) + (send drs-bindings-keymap add-function + "next-tab" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (send frame next-tab))))) + (send drs-bindings-keymap add-function + "prev-tab" + (λ (obj evt) + (with-drs-frame + obj + (λ (frame) (send frame prev-tab)))))) + + (send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions") + (send drs-bindings-keymap map-function "c:x;p" "toggle-focus-between-definitions-and-interactions backwards") + (send drs-bindings-keymap map-function "c:f6" "toggle-focus-between-definitions-and-interactions") + (send drs-bindings-keymap map-function "f5" "execute") + (send drs-bindings-keymap map-function "f1" "search-help-desk") + (send drs-bindings-keymap map-function "c:tab" "next-tab") + (send drs-bindings-keymap map-function "c:s:tab" "prev-tab") + (send drs-bindings-keymap map-function "d:s:right" "next-tab") + (send drs-bindings-keymap map-function "d:s:left" "prev-tab") + (send drs-bindings-keymap map-function "c:pagedown" "next-tab") + (send drs-bindings-keymap map-function "c:pageup" "prev-tab") + + (define (get-drs-bindings-keymap) drs-bindings-keymap) + + ;; drs-bindings-keymap-mixin : + ;; ((implements editor:keymap<%>) -> (implements editor:keymap<%>)) + ;; for any x that is an instance of the resulting class, + ;; (is-a? (send (send x get-canvas) get-top-level-frame) drscheme:unit:frame%) + (define drs-bindings-keymap-mixin + (mixin (editor:keymap<%>) (editor:keymap<%>) + (define/override (get-keymaps) + (cons drs-bindings-keymap (super get-keymaps))) + (super-instantiate ()))) + + ;; Max length of output queue (user's thread blocks if the + ;; queue is full): + (define output-limit-size 2000) + + (define (printf . args) (apply fprintf drscheme:init:original-output-port args)) + + (define setup-scheme-interaction-mode-keymap + (λ (keymap) + (send keymap add-function "put-previous-sexp" + (λ (text event) + (send text copy-prev-previous-expr))) + (send keymap add-function "put-next-sexp" + (λ (text event) + (send text copy-next-previous-expr))) + + (keymap:send-map-function-meta keymap "p" "put-previous-sexp") + (keymap:send-map-function-meta keymap "n" "put-next-sexp") + (send keymap map-function "c:up" "put-previous-sexp") + (send keymap map-function "c:down" "put-next-sexp"))) + + (define scheme-interaction-mode-keymap (make-object keymap:aug-keymap%)) + (setup-scheme-interaction-mode-keymap scheme-interaction-mode-keymap) + + (define drs-font-delta (make-object style-delta% 'change-family 'decorative)) + + (define output-delta (make-object style-delta%)) ; used to be 'change-weight 'bold + (define result-delta (make-object style-delta%)) ; used to be 'change-weight 'bold + (define error-delta (make-object style-delta% + 'change-style + 'italic)) + (send error-delta set-delta-foreground (make-object color% 255 0 0)) + (send result-delta set-delta-foreground (make-object color% 0 0 175)) + (send output-delta set-delta-foreground (make-object color% 150 0 150)) + + (define error-text-style-delta (make-object style-delta%)) + (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) + + (define grey-delta (make-object style-delta%)) + (send grey-delta set-delta-foreground "GREY") + + (define welcome-delta (make-object style-delta% 'change-family 'decorative)) + (define click-delta (gui-utils:get-clickback-delta)) + (define red-delta (make-object style-delta%)) + (define dark-green-delta (make-object style-delta%)) + (send* red-delta + (copy welcome-delta) + (set-delta-foreground "RED")) + (send* dark-green-delta + (copy welcome-delta) + (set-delta-foreground "dark green")) + (define warning-style-delta (make-object style-delta% 'change-bold)) + (send* warning-style-delta + (set-delta-foreground "BLACK") + (set-delta-background "YELLOW")) + (define (get-welcome-delta) welcome-delta) + (define (get-dark-green-delta) dark-green-delta) + + ;; is-default-settings? : language-settings -> boolean + ;; determines if the settings in `language-settings' + ;; correspond to the default settings of the language. + (define (is-default-settings? language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + default-settings? + (drscheme:language-configuration:language-settings-settings language-settings))) + + (define (extract-language-name language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-language-name)) + (define (extract-language-style-delta language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-style-delta)) + (define (extract-language-url language-settings) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-language-url)) + + (define-struct sexp (left right prompt)) + + (define console-max-save-previous-exprs 30) + (let* ([list-of? (λ (p?) + (λ (l) + (and (list? l) + (andmap p? l))))] + [snip/string? (λ (s) (or (is-a? s snip%) (string? s)))] + [list-of-snip/strings? (list-of? snip/string?)] + [list-of-lists-of-snip/strings? (list-of? list-of-snip/strings?)]) + (preferences:set-default + 'drscheme:console-previous-exprs + null + list-of-lists-of-snip/strings?)) + (let ([marshall + (λ (lls) + (map (λ (ls) + (list + (apply + string-append + (reverse + (map (λ (s) + (cond + [(is-a? s string-snip%) + (send s get-text 0 (send s get-count))] + [(string? s) s] + [else "'non-string-snip"])) + ls))))) + lls))] + [unmarshall (λ (x) x)]) + (preferences:set-un/marshall + 'drscheme:console-previous-exprs + marshall unmarshall)) + + (define color? ((get-display-depth) . > . 8)) + + ;; instances of this interface provide a context for a rep:text% + ;; its connection to its graphical environment (ie frame) for + ;; error display and status infromation is all mediated + ;; through an instance of this interface. + + (define file-icon + (let ([bitmap + (make-object bitmap% + (build-path (collection-path "icons") "file.gif"))]) + (if (send bitmap ok?) + (make-object image-snip% bitmap) + (make-object string-snip% "[open file]")))) + + + ;; insert/delta : (instanceof text%) (union snip string) (listof style-delta%) *-> (values number number) + ;; inserts the string/stnip into the text at the end and changes the + ;; style of the newly inserted text based on the style deltas. + (define (insert/delta text s . deltas) + (let ([before (send text last-position)]) + (send text insert s before before #f) + (let ([after (send text last-position)]) + (for-each (λ (delta) + (when (is-a? delta style-delta%) + (send text change-style delta before after))) + deltas) + (values before after)))) + + (define text-mixin + (mixin ((class->interface text%) + text:ports<%> + editor:file<%> + scheme:text<%> + color:text<%> + text:ports<%>) + (-text<%>) + (init-field context) + (inherit auto-wrap + begin-edit-sequence + change-style + clear-box-input-port + clear-undos + clear-input-port + clear-output-ports + delete + delete/io + end-edit-sequence + erase + find-snip + find-string + freeze-colorer + get-active-canvas + get-admin + get-can-close-parent + get-canvases + get-character + get-end-position + get-err-port + get-extent + get-focus-snip + get-in-port + get-in-box-port + get-insertion-point + get-out-port + get-regions + get-snip-position + get-start-position + get-styles-fixed + get-style-list + get-text + get-top-level-window + get-unread-start-point + get-value-port + in-edit-sequence? + insert + insert-before + insert-between + invalidate-bitmap-cache + is-frozen? + is-locked? + last-position + line-location + lock + paragraph-start-position + position-line + position-paragraph + release-snip + reset-input-box + reset-regions + run-after-edit-sequence + scroll-to-position + send-eof-to-in-port + set-allow-edits + set-caret-owner + set-clickback + set-insertion-point + set-position + set-styles-sticky + set-styles-fixed + set-unread-start-point + split-snip + thaw-colorer) + + (define definitions-text 'not-yet-set-definitions-text) + (define/public (set-definitions-text dt) (set! definitions-text dt)) + (define/public (get-definitions-text) definitions-text) + + (unless (is-a? context context<%>) + (error 'drscheme:rep:text% + "expected an object that implements drscheme:rep:context<%> as initialization argument, got: ~e" + context)) + + (define/public (get-context) context) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; User -> Kernel ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; =User= (probably doesn't matter) + (define/private queue-system-callback + (λ (ut thunk [always? #f]) + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback (λ () - ;; clear out the eof object if it wasn't consumed - (clear-input-port))))) - - (inherit get-backward-sexp) - (define/override (on-local-char key) - (let ([start (get-start-position)] - [end (get-end-position)] - [code (send key get-key-code)]) - (cond - [(not (or (eq? code 'numpad-enter) - (equal? code #\return) - (equal? code #\newline))) - (super on-local-char key)] - [(not prompt-position) - ;; evaluating? just drop the keypress - (void)] - [(and (< end prompt-position) - (= start end) - (get-backward-sexp end)) - => - (λ (sexp-start) - (copy-down sexp-start end))] - [(and (< end prompt-position) - (not (= start end))) - (copy-down start end)] - [else - (super on-local-char key)]))) - - (define/private (copy-down start end) - (begin-edit-sequence) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip start 'after-or-none)]) - (when snip - (let ([pos (+ (get-snip-position snip) - (send snip get-count))]) - (when (<= pos end) - (insert (send snip copy) (last-position) (last-position)) - (loop (send snip next)))))) - (set-position (last-position) (last-position)) - (end-edit-sequence)) - - ;; prompt-position : (union #f integer) - ;; the position just after the last prompt - (field (prompt-position #f)) - (define inserting-prompt? #f) - (define/public (get-prompt) "> ") - (define/public (insert-prompt) - (set! inserting-prompt? #t) - (begin-edit-sequence) - (reset-input-box) - (let* ([pmt (get-prompt)] - [prompt-space (string-length pmt)]) - - ;; insert the prompt, possibly inserting a newline first - (let* ([usp (get-unread-start-point)] - [usp-para (position-paragraph usp)] - [usp-para-start (paragraph-start-position usp-para)]) - (unless (equal? usp usp-para-start) - (insert-between "\n") - (set! prompt-space (+ prompt-space 1))) - (insert-between pmt)) - - (let ([sp (get-unread-start-point)]) - (set! prompt-position sp) - (reset-regions (append (get-regions) (list (list sp 'end)))))) - (end-edit-sequence) - (set! inserting-prompt? #f)) - - (field [submit-predicate (λ (text prompt-position) #t)]) - (define/public (set-submit-predicate p) - (set! submit-predicate p)) - - (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler= - (send context disable-evaluation) - (send context reset-offer-kill) - (send context set-breakables (get-user-thread) (get-user-custodian)) - (reset-pretty-print-width) - (set! in-evaluation? #t) - (update-running #t) - (set! need-interaction-cleanup? #t) + (when (or always? (eq? ut (get-user-thread))) + (thunk))) + #f)))) + + ;; =User= + (define/private queue-system-callback/sync + (λ (ut thunk) + (let ([s (make-semaphore 0)]) + (queue-system-callback + ut + (λ () + (when (eq? ut (get-user-thread)) + (thunk)) + (semaphore-post s)) + #t) + (semaphore-wait s)))) + + ;; display-results : (listof TST) -> void + ;; prints each element of anss that is not void as values in the REPL. + (define/public (display-results anss) ; =User=, =Handler=, =Breaks= + (display-results/void (filter (λ (x) (not (void? x))) anss))) + + ;; display-results : (listof TST) -> void + ;; prints each element of anss that is not void as values in the REPL. + (define/public (display-results/void anss) ; =User=, =Handler=, =Breaks= + (for-each + (λ (v) + (let* ([ls (current-language-settings)] + [lang (drscheme:language-configuration:language-settings-language ls)] + [settings (drscheme:language-configuration:language-settings-settings ls)]) + (send lang render-value/format + v + settings + (get-value-port) + (get-repl-char-width)))) + anss)) + + ;; get-repl-char-width : -> (and/c exact? integer?) + ;; returns the width of the repl in characters, or 80 if the + ;; answer cannot be found. + (define/private (get-repl-char-width) + (let ([admin (get-admin)] + [standard (send (get-style-list) find-named-style "Standard")]) + (if (and admin standard) + (let ([bw (box 0)]) + (send admin get-view #f #f bw #f) + (let* ([dc (send admin get-dc)] + [standard-font (send standard get-font)] + [old-font (send dc get-font)]) + (send dc set-font standard-font) + (let* ([char-width (send dc get-char-width)] + [answer (inexact->exact (floor (/ (unbox bw) char-width)))]) + (send dc set-font old-font) + answer))) + 80))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Error Highlighting ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) + (define error-ranges #f) + (define/public (get-error-ranges) error-ranges) + (define internal-reset-callback void) + (define internal-reset-error-arrows-callback void) + (define/public (reset-error-ranges) + (internal-reset-callback) + (internal-reset-error-arrows-callback)) + + ;; highlight-error : file number number -> void + (define/public (highlight-error file start end) + (highlight-errors (list (make-srcloc file #f #f start (- end start))) #f)) + + ;; highlight-errors/exn : exn -> void + ;; highlights all of the errors associated with the exn (incl. arrows) + (define/public (highlight-errors/exn exn) + (let ([locs (cond + [(exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn)] + [else '()])]) + (highlight-errors locs #f))) + + ;; =Kernel= =handler= + ;; highlight-errors : (listof srcloc) + ;; (union #f (listof srcloc)) + ;; -> (void) + (define/public (highlight-errors raw-locs raw-error-arrows) + (let* ([cleanup-locs + (λ (locs) + (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>) + (number? (srcloc-position loc)) + (number? (srcloc-span loc)))) + (map (λ (srcloc) + (cond + [(send definitions-text port-name-matches? (srcloc-source srcloc)) + (make-srcloc definitions-text + (srcloc-line srcloc) + (srcloc-column srcloc) + (srcloc-position srcloc) + (srcloc-span srcloc))] + [(unsaved-editor? (srcloc-source srcloc)) + (make-srcloc (unsaved-editor-editor (srcloc-source srcloc)) + (srcloc-line srcloc) + (srcloc-column srcloc) + (srcloc-position srcloc) + (srcloc-span srcloc))] + [else srcloc])) + locs)))] + [locs (cleanup-locs raw-locs)] + [error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))]) + (reset-highlighting) - (run-in-evaluation-thread - (λ () ; =User=, =Handler=, =No-Breaks= - (let* ([settings (current-language-settings)] - [lang (drscheme:language-configuration:language-settings-language settings)] - [settings (drscheme:language-configuration:language-settings-settings settings)] - [dummy-value (box #f)] - [get-sexp/syntax/eof - (if complete-program? - (send lang front-end/complete-program port settings) - (send lang front-end/interaction port settings))]) - - ; Evaluate the user's expression. We're careful to turn on - ; breaks as we go in and turn them off as we go out. - ; (Actually, we adjust breaks however the user wanted it.) - - (call-with-continuation-prompt - (λ () - (call-with-break-parameterization - user-break-parameterization - (λ () - (let loop () - (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))]) - (unless (eof-object? sexp/syntax/eof) - (call-with-values - (λ () - (call-with-continuation-prompt - (λ () (with-stacktrace-name (eval-syntax sexp/syntax/eof))) - (default-continuation-prompt-tag) - (and complete-program? - (λ args - (abort-current-continuation - (default-continuation-prompt-tag)))))) - (λ x (display-results x))) - (loop))))))) - (default-continuation-prompt-tag) - (λ args (void))) - - (set! in-evaluation? #f) - (update-running #f) - (cleanup) - (flush-output (get-value-port)) - (queue-system-callback/sync - (get-user-thread) - (λ () ; =Kernel=, =Handler= - (after-many-evals) - (cleanup-interaction) - (insert-prompt))))))) + (set! error-ranges locs) + + (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs) + + (when color? + (let ([resets + (map (λ (loc) + (let* ([file (srcloc-source loc)] + [start (- (srcloc-position loc) 1)] + [span (srcloc-span loc)] + [finish (+ start span)]) + (send file highlight-range start finish (drscheme:debug:get-error-color) #f #f 'high))) + locs)]) + + (when (and definitions-text error-arrows) + (let ([filtered-arrows + (remove-duplicate-error-arrows + (filter + (λ (arr) (embedded-in? (srcloc-source arr) definitions-text)) + error-arrows))]) + (send definitions-text set-error-arrows filtered-arrows))) + + (set! internal-reset-callback + (λ () + (set! error-ranges #f) + (when definitions-text + (send definitions-text set-error-arrows #f)) + (set! internal-reset-callback void) + (for-each (λ (x) (x)) resets))))) + + (let* ([first-loc (and (pair? locs) (car locs))] + [first-file (and first-loc (srcloc-source first-loc))] + [first-start (and first-loc (- (srcloc-position first-loc) 1))] + [first-span (and first-loc (srcloc-span first-loc))]) + + (when first-loc + (let ([first-finish (+ first-start first-span)]) + (when (eq? first-file definitions-text) ;; only move set the cursor in the defs window + (send first-file set-position first-start first-start)) + (send first-file scroll-to-position first-start #f first-finish))) + + (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) + + (when first-loc + (send first-file set-caret-owner (get-focus-snip) 'global))))) + + (define/public (reset-highlighting) + (reset-error-ranges)) + + ;; remove-duplicate-error-arrows : (listof X) -> (listof X) + ;; duplicate arrows point from and to the same place -- only + ;; need one arrow for each pair of locations they point to. + (define/private (remove-duplicate-error-arrows error-arrows) + (let ([ht (make-hash)]) + (let loop ([arrs error-arrows] + [n 0]) + (unless (null? arrs) + (hash-set! ht (car arrs) n) + (loop (cdr arrs) (+ n 1)))) + (let* ([unsorted (hash-map ht list)] + [sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))] + [arrs (map car sorted)]) + arrs))) + + (define/private (embedded-in? txt-inner txt-outer) + (let loop ([txt-inner txt-inner]) + (cond + [(eq? txt-inner txt-outer) #t] + [else (let ([admin (send txt-inner get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (loop (send (send (send admin get-snip) get-admin) get-editor))))]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; specialization + ;; + + (define/override (after-io-insertion) + (super after-io-insertion) + (let ([canvas (get-active-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (let ([tab (send definitions-text get-tab)]) + (when (eq? (send frame get-current-tab) tab) + (send context ensure-rep-shown this))))))) + + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (cond + [(in-edit-sequence?) + (set! had-an-insert (cons (cons start len) had-an-insert))] + [else (update-after-insert start len)])) + + ;; private field + (define had-an-insert '()) + + (define/augment (after-edit-sequence) + (inner (void) after-edit-sequence) + (let ([to-clean had-an-insert]) + (set! had-an-insert '()) + (for-each + (lambda (pr) + (update-after-insert (car pr) (cdr pr))) + to-clean))) + + (define/private (update-after-insert start len) + (unless inserting-prompt? + (reset-highlighting)) + (when (and prompt-position (< start prompt-position)) + + ;; trim extra space, according to preferences + #; + (let* ([start (get-repl-header-end)] + [end (get-insertion-point)] + [space (- end start)] + [pref (preferences:get 'drscheme:repl-buffer-size)]) + (when (car pref) + (let ([max-space (* 1000 (cdr pref))]) + (when (space . > . max-space) + (let ([to-delete-end (+ start (- space max-space))]) + (delete/io start to-delete-end)))))) + + (set! prompt-position (get-unread-start-point)) + (reset-regions (append (all-but-last (get-regions)) + (list (list prompt-position 'end)))))) + + (define/augment (after-delete x y) + (unless inserting-prompt? + (reset-highlighting)) + (inner (void) after-delete x y)) + + (define/override get-keymaps + (λ () + (cons scheme-interaction-mode-keymap (super get-keymaps)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Evaluation ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define/public (eval-busy?) + (not (and (get-user-thread) + (thread-running? (get-user-thread))))) + + (field (user-language-settings #f) + (user-custodian-parent #f) + (memory-killed-thread #f) + (user-custodian #f) + (custodian-limit (and (custodian-memory-accounting-available?) + (preferences:get 'drscheme:limit-memory))) + (user-eventspace-box (make-weak-box #f)) + (user-namespace-box (make-weak-box #f)) + (user-eventspace-main-thread #f) + (user-break-parameterization #f) + + ;; user-exit-code (union #f (integer-in 0 255)) + ;; #f indicates that exit wasn't called. Integer indicates exit code + (user-exit-code #f)) + + (define/public (get-user-language-settings) user-language-settings) + (define/public (get-user-custodian) user-custodian) + (define/public (get-user-eventspace) (weak-box-value user-eventspace-box)) + (define/public (get-user-thread) user-eventspace-main-thread) + (define/public (get-user-namespace) (weak-box-value user-namespace-box)) + (define/pubment (get-user-break-parameterization) user-break-parameterization) ;; final method + (define/pubment (get-custodian-limit) custodian-limit) + (define/pubment (set-custodian-limit c) (set! custodian-limit c)) + (field (in-evaluation? #f) + (ask-about-kill? #f)) + (define/public (get-in-evaluation?) in-evaluation?) + + (define/private (insert-warning message) + (begin-edit-sequence) + (let ([start (get-insertion-point)]) + (insert-before message) + (let ([end (get-insertion-point)]) + (change-style warning-style-delta start end))) + (insert-before "\n") + (end-edit-sequence)) + + (field (already-warned? #f)) + + (define/private (cleanup) + (set! in-evaluation? #f) + (update-running #f) + (unless (and (get-user-thread) (thread-running? (get-user-thread))) + (lock #t) + (unless shutting-down? + (no-user-evaluation-message + (let ([canvas (get-active-canvas)]) + (and canvas + (send canvas get-top-level-window))) + user-exit-code + (not (thread-running? memory-killed-thread)))))) + (field (need-interaction-cleanup? #f)) + + (define/private (no-user-evaluation-message frame exit-code memory-killed?) + (let* ([new-limit (and custodian-limit (+ (* 1024 1024 128) custodian-limit))] + [ans (message-box/custom + (string-constant evaluation-terminated) + (string-append + (string-constant evaluation-terminated-explanation) + (if exit-code + (string-append + "\n\n" + (if (zero? exit-code) + (string-constant exited-successfully) + (format (string-constant exited-with-error-code) exit-code))) + "") + (if memory-killed? + (string-append + "\n\n" + (string-constant program-ran-out-of-memory)) + "")) + (string-constant ok) + #f + (and memory-killed? + new-limit + (format "Increase memory limit to ~a megabytes" + (floor (/ new-limit 1024 1024)))) + frame + '(default=1 stop) + )]) + (when (equal? ans 3) + (set-custodian-limit new-limit) + (preferences:set 'drscheme:limit-memory new-limit)) + (void))) + + (define/private (cleanup-interaction) ; =Kernel=, =Handler= + (set! need-interaction-cleanup? #f) + (begin-edit-sequence) + (set-caret-owner #f 'display) + (cleanup) + (end-edit-sequence) + (send context set-breakables #f #f) + (send context enable-evaluation)) + + (define/augment (submit-to-port? key) + (and prompt-position + (only-whitespace-after-insertion-point) + (submit-predicate this prompt-position))) + + (define/private (only-whitespace-after-insertion-point) + (let ([start (get-start-position)] + [end (get-end-position)]) + (and (= start end) + (let loop ([pos start]) + (cond + [(= pos (last-position)) #t] + [else (and (char-whitespace? (get-character pos)) + (loop (+ pos 1)))]))))) + + (define/augment (on-submit) + (inner (void) on-submit) + (when (and (get-user-thread) + (thread-running? (get-user-thread))) + ;; the -2 drops the last newline from history (why -2 and not -1?!) + (save-interaction-in-history prompt-position (- (last-position) 2)) + + (let* ([old-regions (get-regions)] + [abl (all-but-last old-regions)] + [lst (last old-regions)]) + (reset-regions (append abl (list (list (list-ref lst 0) (last-position)))))) + + (let ([needs-execution (send context needs-execution)]) + (when (if (preferences:get 'drscheme:execute-warning-once) + (and (not already-warned?) + needs-execution) + needs-execution) + (set! already-warned? #t) + (insert-warning needs-execution))) + + ;; lets us know we are done with this one interaction + ;; (since there may be multiple expressions at the prompt) + (send-eof-to-in-port) + + (set! prompt-position #f) + (evaluate-from-port + (get-in-port) + #f + (λ () + ;; clear out the eof object if it wasn't consumed + (clear-input-port))))) + + (inherit get-backward-sexp) + (define/override (on-local-char key) + (let ([start (get-start-position)] + [end (get-end-position)] + [code (send key get-key-code)]) + (cond + [(not (or (eq? code 'numpad-enter) + (equal? code #\return) + (equal? code #\newline))) + (super on-local-char key)] + [(not prompt-position) + ;; evaluating? just drop the keypress + (void)] + [(and (< end prompt-position) + (= start end) + (get-backward-sexp end)) + => + (λ (sexp-start) + (copy-down sexp-start end))] + [(and (< end prompt-position) + (not (= start end))) + (copy-down start end)] + [else + (super on-local-char key)]))) + + (define/private (copy-down start end) + (begin-edit-sequence) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip start 'after-or-none)]) + (when snip + (let ([pos (+ (get-snip-position snip) + (send snip get-count))]) + (when (<= pos end) + (insert (send snip copy) (last-position) (last-position)) + (loop (send snip next)))))) + (set-position (last-position) (last-position)) + (end-edit-sequence)) + + ;; prompt-position : (union #f integer) + ;; the position just after the last prompt + (field (prompt-position #f)) + (define inserting-prompt? #f) + (define/public (get-prompt) "> ") + (define/public (insert-prompt) + (set! inserting-prompt? #t) + (begin-edit-sequence) + (reset-input-box) + (let* ([pmt (get-prompt)] + [prompt-space (string-length pmt)]) + + ;; insert the prompt, possibly inserting a newline first + (let* ([usp (get-unread-start-point)] + [usp-para (position-paragraph usp)] + [usp-para-start (paragraph-start-position usp-para)]) + (unless (equal? usp usp-para-start) + (insert-between "\n") + (set! prompt-space (+ prompt-space 1))) + (insert-between pmt)) + + (let ([sp (get-unread-start-point)]) + (set! prompt-position sp) + (reset-regions (append (get-regions) (list (list sp 'end)))))) + (end-edit-sequence) + (set! inserting-prompt? #f)) + + (field [submit-predicate (λ (text prompt-position) #t)]) + (define/public (set-submit-predicate p) + (set! submit-predicate p)) + + (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler= + (send context disable-evaluation) + (send context reset-offer-kill) + (send context set-breakables (get-user-thread) (get-user-custodian)) + (reset-pretty-print-width) + (set! in-evaluation? #t) + (update-running #t) + (set! need-interaction-cleanup? #t) - (define/pubment (after-many-evals) (inner (void) after-many-evals)) - - (define/private shutdown-user-custodian ; =Kernel=, =Handler= - ; Use this procedure to shutdown when in the middle of other cleanup - ; operations, such as when the user clicks "Execute". - ; Don't use it to kill a thread where other, external cleanup - ; actions must occur (e.g., the exit handler for the user's - ; thread). In that case, shut down user-custodian directly. - (λ () - (when user-custodian - (custodian-shutdown-all user-custodian)) - (set! user-custodian #f) - (set! user-eventspace-main-thread #f))) - - (define/public (kill-evaluation) ; =Kernel=, =Handler= + (run-in-evaluation-thread + (λ () ; =User=, =Handler=, =No-Breaks= + (let* ([settings (current-language-settings)] + [lang (drscheme:language-configuration:language-settings-language settings)] + [settings (drscheme:language-configuration:language-settings-settings settings)] + [dummy-value (box #f)] + [get-sexp/syntax/eof + (if complete-program? + (send lang front-end/complete-program port settings) + (send lang front-end/interaction port settings))]) + + ; Evaluate the user's expression. We're careful to turn on + ; breaks as we go in and turn them off as we go out. + ; (Actually, we adjust breaks however the user wanted it.) + + (call-with-continuation-prompt + (λ () + (call-with-break-parameterization + user-break-parameterization + (λ () + (let loop () + (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))]) + (unless (eof-object? sexp/syntax/eof) + (call-with-values + (λ () + (call-with-continuation-prompt + (λ () (with-stacktrace-name (eval-syntax sexp/syntax/eof))) + (default-continuation-prompt-tag) + (and complete-program? + (λ args + (abort-current-continuation + (default-continuation-prompt-tag)))))) + (λ x (display-results x))) + (loop))))))) + (default-continuation-prompt-tag) + (λ args (void))) + + (set! in-evaluation? #f) + (update-running #f) + (cleanup) + (flush-output (get-value-port)) + (queue-system-callback/sync + (get-user-thread) + (λ () ; =Kernel=, =Handler= + (after-many-evals) + (cleanup-interaction) + (insert-prompt))))))) + + (define/pubment (after-many-evals) (inner (void) after-many-evals)) + + (define/private shutdown-user-custodian ; =Kernel=, =Handler= + ; Use this procedure to shutdown when in the middle of other cleanup + ; operations, such as when the user clicks "Execute". + ; Don't use it to kill a thread where other, external cleanup + ; actions must occur (e.g., the exit handler for the user's + ; thread). In that case, shut down user-custodian directly. + (λ () (when user-custodian (custodian-shutdown-all user-custodian)) - (set! user-custodian #f)) + (set! user-custodian #f) + (set! user-eventspace-main-thread #f))) + + (define/public (kill-evaluation) ; =Kernel=, =Handler= + (when user-custodian + (custodian-shutdown-all user-custodian)) + (set! user-custodian #f)) + + (field (eval-thread-thunks null) + (eval-thread-state-sema 'not-yet-state-sema) + (eval-thread-queue-sema 'not-yet-thread-sema) + + (cleanup-sucessful 'not-yet-cleanup-sucessful) + (cleanup-semaphore 'not-yet-cleanup-semaphore) + (thread-grace 'not-yet-thread-grace) + (thread-killed 'not-yet-thread-killed)) + (define/private (initialize-killed-thread) ; =Kernel= + (when (thread? thread-killed) + (kill-thread thread-killed)) + (set! thread-killed + (thread + (λ () ; =Kernel= + (let ([ut (get-user-thread)]) + (thread-wait ut) + (queue-system-callback + ut + (λ () ; =Kernel=, =Handler= + (if need-interaction-cleanup? + (cleanup-interaction) + (cleanup))))))))) + + (define/public (run-in-evaluation-thread thunk) ; =Kernel= + (semaphore-wait eval-thread-state-sema) + (set! eval-thread-thunks (append eval-thread-thunks (list thunk))) + (semaphore-post eval-thread-state-sema) + (semaphore-post eval-thread-queue-sema)) + + (define/private (init-evaluation-thread) ; =Kernel= + (set! user-language-settings (send definitions-text get-next-settings)) - (field (eval-thread-thunks null) - (eval-thread-state-sema 'not-yet-state-sema) - (eval-thread-queue-sema 'not-yet-thread-sema) - - (cleanup-sucessful 'not-yet-cleanup-sucessful) - (cleanup-semaphore 'not-yet-cleanup-semaphore) - (thread-grace 'not-yet-thread-grace) - (thread-killed 'not-yet-thread-killed)) - (define/private (initialize-killed-thread) ; =Kernel= - (when (thread? thread-killed) - (kill-thread thread-killed)) - (set! thread-killed - (thread - (λ () ; =Kernel= - (let ([ut (get-user-thread)]) - (thread-wait ut) - (queue-system-callback - ut - (λ () ; =Kernel=, =Handler= - (if need-interaction-cleanup? - (cleanup-interaction) - (cleanup))))))))) - - (define/public (run-in-evaluation-thread thunk) ; =Kernel= - (semaphore-wait eval-thread-state-sema) - (set! eval-thread-thunks (append eval-thread-thunks (list thunk))) - (semaphore-post eval-thread-state-sema) - (semaphore-post eval-thread-queue-sema)) - - (define/private (init-evaluation-thread) ; =Kernel= - (set! user-language-settings (send definitions-text get-next-settings)) + (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)))))) + (when custodian-limit + (custodian-limit-memory user-custodian-parent + custodian-limit + user-custodian-parent)) + (let ([user-eventspace (parameterize ([current-custodian user-custodian]) + (make-eventspace))]) + (set! user-eventspace-box (make-weak-box user-eventspace)) + (set! user-break-parameterization (parameterize-break + #t + (current-break-parameterization))) + (set! eval-thread-thunks null) + (set! eval-thread-state-sema (make-semaphore 1)) + (set! eval-thread-queue-sema (make-semaphore 0)) + (set! user-exit-code #f) - (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)))))) - (when custodian-limit - (custodian-limit-memory user-custodian-parent - custodian-limit - user-custodian-parent)) - (let ([user-eventspace (parameterize ([current-custodian user-custodian]) - (make-eventspace))]) - (set! user-eventspace-box (make-weak-box user-eventspace)) - (set! user-break-parameterization (parameterize-break - #t - (current-break-parameterization))) - (set! eval-thread-thunks null) - (set! eval-thread-state-sema (make-semaphore 1)) - (set! eval-thread-queue-sema (make-semaphore 0)) - (set! user-exit-code #f) + (let* ([init-thread-complete (make-semaphore 0)] + [goahead (make-semaphore)]) - (let* ([init-thread-complete (make-semaphore 0)] - [goahead (make-semaphore)]) - - ; setup standard parameters - (let ([snip-classes - ; the snip-classes in the DrScheme eventspace's snip-class-list - (drscheme:eval:get-snip-classes)] - [drs-eventspace (current-eventspace)]) - (queue-user/wait - (λ () ; =User=, =No-Breaks= - ; No user code has been evaluated yet, so we're in the clear... - (break-enabled #f) - (set! user-eventspace-main-thread (current-thread)) - - (let ([drscheme-exit-handler - (λ (x) - (parameterize-break - #f - (let ([s (make-semaphore)]) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (set! user-exit-code - (if (and (integer? x) - (<= 0 x 255)) - x - 0)) - (semaphore-post s)))) - (semaphore-wait s) - (custodian-shutdown-all user-custodian))))]) - (exit-handler drscheme-exit-handler)) - (initialize-parameters snip-classes)))) - - ;; disable breaks until an evaluation actually occurs - (send context set-breakables #f #f) - - ;; initialize the language - (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))]) - run-on-user-thread)) - - ;; setup the special repl values - (let ([raised-exn? #f] - [exn #f]) - (queue-user/wait - (λ () ; =User=, =No-Breaks= - (with-handlers ((void (λ (x) - (set! exn x) - (set! raised-exn? #t)))) - (drscheme:language:setup-setup-values)))) - (when raised-exn? - (fprintf - (current-error-port) - "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n") - (raise exn))) - - (parameterize ([current-eventspace user-eventspace]) - (queue-callback - (λ () - (set! in-evaluation? #f) - (update-running #f) - (send context set-breakables #f #f) - - ;; after this returns, future event dispatches - ;; will use the user's break parameterization - (initialize-dispatch-handler) - - ;; let init-thread procedure return, - ;; now that parameters are set - (semaphore-post init-thread-complete) - - ; We're about to start running user code. - - ; Pause to let killed-thread get initialized - (semaphore-wait goahead) - - (let loop () ; =User=, =Handler=, =No-Breaks= - ; Wait for something to do - (unless (semaphore-try-wait? eval-thread-queue-sema) - ; User event callbacks run here; we turn on - ; breaks in the dispatch handler. - (yield eval-thread-queue-sema)) - ; About to eval something - (semaphore-wait eval-thread-state-sema) - (let ([thunk (car eval-thread-thunks)]) - (set! eval-thread-thunks (cdr eval-thread-thunks)) - (semaphore-post eval-thread-state-sema) - ; This thunk evals the user's expressions with appropriate - ; protections. - (thunk)) - (loop))))) - (semaphore-wait init-thread-complete) - ; Start killed-thread - (initialize-killed-thread) - ; Let user expressions go... - (semaphore-post goahead)))) - - (define/private (queue-user/wait thnk) - (let ([wait (make-semaphore 0)]) - (parameterize ([current-eventspace (get-user-eventspace)]) + ; setup standard parameters + (let ([snip-classes + ; the snip-classes in the DrScheme eventspace's snip-class-list + (drscheme:eval:get-snip-classes)] + [drs-eventspace (current-eventspace)]) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + ; No user code has been evaluated yet, so we're in the clear... + (break-enabled #f) + (set! user-eventspace-main-thread (current-thread)) + + (let ([drscheme-exit-handler + (λ (x) + (parameterize-break + #f + (let ([s (make-semaphore)]) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (set! user-exit-code + (if (and (integer? x) + (<= 0 x 255)) + x + 0)) + (semaphore-post s)))) + (semaphore-wait s) + (custodian-shutdown-all user-custodian))))]) + (exit-handler drscheme-exit-handler)) + (initialize-parameters snip-classes)))) + + ;; disable breaks until an evaluation actually occurs + (send context set-breakables #f #f) + + ;; initialize the language + (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))]) + run-on-user-thread)) + + ;; setup the special repl values + (let ([raised-exn? #f] + [exn #f]) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (with-handlers ((void (λ (x) + (set! exn x) + (set! raised-exn? #t)))) + (drscheme:language:setup-setup-values)))) + (when raised-exn? + (fprintf + (current-error-port) + "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n") + (raise exn))) + + (parameterize ([current-eventspace user-eventspace]) (queue-callback (λ () - (thnk) - (semaphore-post wait)))) - (semaphore-wait wait))) - - (field (shutting-down? #f)) - - (define/override (allow-close-with-no-filename?) #t) - (define/augment (can-close?) - (and (cond - [in-evaluation? - (equal? (message-box/custom - (string-constant drscheme) - (string-constant program-is-still-running) - (string-constant close-anyway) - (string-constant cancel) - #f - (or (get-top-level-window) (get-can-close-parent)) - '(default=1 caution) - 2) - 1)] - [(let ([user-eventspace (get-user-eventspace)]) - (and user-eventspace - (parameterize ([current-eventspace user-eventspace]) - (not (null? (get-top-level-windows)))))) - (equal? (message-box/custom - (string-constant drscheme) - (string-constant program-has-open-windows) - (string-constant close-anyway) - (string-constant cancel) - #f - (or (get-top-level-window) (get-can-close-parent)) - '(default=1 caution) - 2) - 1)] - [else #t]) - (inner #t can-close?))) - - (define/augment (on-close) - (shutdown) - (preferences:set 'drscheme:console-previous-exprs - (trim-previous-exprs - (append - (preferences:get 'drscheme:console-previous-exprs) - local-previous-exprs))) - (inner (void) on-close)) - - (define/public (shutdown) ; =Kernel=, =Handler= - (set! shutting-down? #t) - (when (thread? thread-killed) - (kill-thread thread-killed) - (set! thread-killed #f)) - (shutdown-user-custodian)) - - (define/private update-running ; =User=, =Handler=, =No-Breaks= - (λ (bool) - (queue-system-callback - (get-user-thread) + (set! in-evaluation? #f) + (update-running #f) + (send context set-breakables #f #f) + + ;; after this returns, future event dispatches + ;; will use the user's break parameterization + (initialize-dispatch-handler) + + ;; let init-thread procedure return, + ;; now that parameters are set + (semaphore-post init-thread-complete) + + ; We're about to start running user code. + + ; Pause to let killed-thread get initialized + (semaphore-wait goahead) + + (let loop () ; =User=, =Handler=, =No-Breaks= + ; Wait for something to do + (unless (semaphore-try-wait? eval-thread-queue-sema) + ; User event callbacks run here; we turn on + ; breaks in the dispatch handler. + (yield eval-thread-queue-sema)) + ; About to eval something + (semaphore-wait eval-thread-state-sema) + (let ([thunk (car eval-thread-thunks)]) + (set! eval-thread-thunks (cdr eval-thread-thunks)) + (semaphore-post eval-thread-state-sema) + ; This thunk evals the user's expressions with appropriate + ; protections. + (thunk)) + (loop))))) + (semaphore-wait init-thread-complete) + ; Start killed-thread + (initialize-killed-thread) + ; Let user expressions go... + (semaphore-post goahead)))) + + (define/private (queue-user/wait thnk) + (let ([wait (make-semaphore 0)]) + (parameterize ([current-eventspace (get-user-eventspace)]) + (queue-callback (λ () - (send context update-running bool))))) + (thnk) + (semaphore-post wait)))) + (semaphore-wait wait))) + + (field (shutting-down? #f)) + + (define/override (allow-close-with-no-filename?) #t) + (define/augment (can-close?) + (and (cond + [in-evaluation? + (equal? (message-box/custom + (string-constant drscheme) + (string-constant program-is-still-running) + (string-constant close-anyway) + (string-constant cancel) + #f + (or (get-top-level-window) (get-can-close-parent)) + '(default=1 caution) + 2) + 1)] + [(let ([user-eventspace (get-user-eventspace)]) + (and user-eventspace + (parameterize ([current-eventspace user-eventspace]) + (not (null? (get-top-level-windows)))))) + (equal? (message-box/custom + (string-constant drscheme) + (string-constant program-has-open-windows) + (string-constant close-anyway) + (string-constant cancel) + #f + (or (get-top-level-window) (get-can-close-parent)) + '(default=1 caution) + 2) + 1)] + [else #t]) + (inner #t can-close?))) + + (define/augment (on-close) + (shutdown) + (preferences:set 'drscheme:console-previous-exprs + (trim-previous-exprs + (append + (preferences:get 'drscheme:console-previous-exprs) + local-previous-exprs))) + (inner (void) on-close)) + + (define/public (shutdown) ; =Kernel=, =Handler= + (set! shutting-down? #t) + (when (thread? thread-killed) + (kill-thread thread-killed) + (set! thread-killed #f)) + (shutdown-user-custodian)) + + (define/private update-running ; =User=, =Handler=, =No-Breaks= + (λ (bool) + (queue-system-callback + (get-user-thread) + (λ () + (send context update-running bool))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; Execution ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; initialize-paramters : (listof snip-class%) -> void + (define/private (initialize-parameters snip-classes) ; =User= - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; - ;;; Execution ;;; - ;;; ;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (current-language-settings user-language-settings) + (error-print-source-location #f) + (error-display-handler drscheme-error-display-handler) + (current-load-relative-directory #f) + (current-custodian user-custodian) + (current-load text-editor-load-handler) - ;; initialize-paramters : (listof snip-class%) -> void - (define/private (initialize-parameters snip-classes) ; =User= - - (current-language-settings user-language-settings) - (error-print-source-location #f) - (error-display-handler drscheme-error-display-handler) - (current-load-relative-directory #f) - (current-custodian user-custodian) - (current-load text-editor-load-handler) - - (drscheme:eval:set-basic-parameters snip-classes) - (current-rep this) - (let ([dir (or (send context get-directory) - drscheme:init:first-dir)]) - (current-directory dir) - (current-load-relative-directory dir)) - - (set! user-namespace-box (make-weak-box (current-namespace))) - - (current-output-port (get-out-port)) - (current-error-port (get-err-port)) - (current-value-port (get-value-port)) - (current-input-port (get-in-box-port)) - - (current-print (lambda (v) - (display-results (list v))))) + (drscheme:eval:set-basic-parameters snip-classes) + (current-rep this) + (let ([dir (or (send context get-directory) + drscheme:init:first-dir)]) + (current-directory dir) + (current-load-relative-directory dir)) - (define/private (initialize-dispatch-handler) ;;; =User= - (let* ([primitive-dispatch-handler (event-dispatch-handler)]) - (event-dispatch-handler - (rec drscheme-event-dispatch-handler ; <= a name for #<...> printout - (λ (eventspace) ; =User=, =Handler= - ; Breaking is enabled if the user turned on breaks and - ; is in a `yield'. If we get a break, that's ok, because - ; the kernel never queues an event in the user's eventspace. - (cond - [(eq? eventspace (get-user-eventspace)) - ; =User=, =Handler= - - ; We must distinguish between "top-level" events and - ; those within `yield' in the user's program. - (cond - [(not in-evaluation?) - ;; at this point, we must not be in a nested dispatch, so we can - ;; just disable breaks and rely on call-with-break-parameterization - ;; to restore them to the user's setting. - (call-with-break-parameterization - no-breaks-break-parameterization - (λ () - ; =No-Breaks= - (send context reset-offer-kill) - (send context set-breakables (get-user-thread) (get-user-custodian)) - (call-with-continuation-prompt - (λ () ; =User=, =Handler=, =No-Breaks= - (call-with-break-parameterization - user-break-parameterization - (λ () (primitive-dispatch-handler eventspace))))) + (set! user-namespace-box (make-weak-box (current-namespace))) + + (current-output-port (get-out-port)) + (current-error-port (get-err-port)) + (current-value-port (get-value-port)) + (current-input-port (get-in-box-port)) + + (current-print (lambda (v) + (display-results (list v))))) + + (define/private (initialize-dispatch-handler) ;;; =User= + (let* ([primitive-dispatch-handler (event-dispatch-handler)]) + (event-dispatch-handler + (letrec ([drscheme-event-dispatch-handler ; <= a name for #<...> printout + (λ (eventspace) ; =User=, =Handler= + ; Breaking is enabled if the user turned on breaks and + ; is in a `yield'. If we get a break, that's ok, because + ; the kernel never queues an event in the user's eventspace. + (cond + [(eq? eventspace (get-user-eventspace)) + ; =User=, =Handler= - ;; in principle, the line below might cause - ;; "race conditions" in the GUI. That is, there might - ;; be many little events that the user won't quite - ;; be able to break. - (send context set-breakables #f #f)))] - [else - ; Nested dispatch; don't adjust interface - (primitive-dispatch-handler eventspace)])] - [else - ; =User=, =Non-Handler=, =No-Breaks= - (primitive-dispatch-handler eventspace)])))))) + ; We must distinguish between "top-level" events and + ; those within `yield' in the user's program. + (cond + [(not in-evaluation?) + ;; at this point, we must not be in a nested dispatch, so we can + ;; just disable breaks and rely on call-with-break-parameterization + ;; to restore them to the user's setting. + (call-with-break-parameterization + no-breaks-break-parameterization + (λ () + ; =No-Breaks= + (send context reset-offer-kill) + (send context set-breakables (get-user-thread) (get-user-custodian)) + (call-with-continuation-prompt + (λ () ; =User=, =Handler=, =No-Breaks= + (call-with-break-parameterization + user-break-parameterization + (λ () (primitive-dispatch-handler eventspace))))) + + ;; in principle, the line below might cause + ;; "race conditions" in the GUI. That is, there might + ;; be many little events that the user won't quite + ;; be able to break. + (send context set-breakables #f #f)))] + [else + ; Nested dispatch; don't adjust interface + (primitive-dispatch-handler eventspace)])] + [else + ; =User=, =Non-Handler=, =No-Breaks= + (primitive-dispatch-handler eventspace)]))]) + drscheme-event-dispatch-handler)))) + + (define/public (new-empty-console) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (send (drscheme:language-configuration:language-settings-language user-language-settings) + first-opened)))) + + (define/public (reset-console) + (when (thread? thread-killed) + (kill-thread thread-killed)) + (send context clear-annotations) + (drscheme:debug:hide-backtrace-window) + (shutdown-user-custodian) + (clear-input-port) + (clear-box-input-port) + (clear-output-ports) + (set-allow-edits #t) - (define/public (new-empty-console) - (queue-user/wait - (λ () ; =User=, =No-Breaks= - (send (drscheme:language-configuration:language-settings-language user-language-settings) - first-opened)))) + ;; in case the last evaluation thread was killed, clean up some state. + (lock #f) + (set! in-evaluation? #f) + (update-running #f) - (define/public (reset-console) - (when (thread? thread-killed) - (kill-thread thread-killed)) - (send context clear-annotations) - (drscheme:debug:hide-backtrace-window) - (shutdown-user-custodian) - (clear-input-port) - (clear-box-input-port) - (clear-output-ports) - (set-allow-edits #t) - - ;; in case the last evaluation thread was killed, clean up some state. - (lock #f) - (set! in-evaluation? #f) - (update-running #f) - - ;; clear out repl first before doing any work. - (begin-edit-sequence) - (set! prompt-position #f) - (reset-input-box) - (delete (paragraph-start-position 1) (last-position)) - (end-edit-sequence) - - ;; must init-evaluation-thread before determining - ;; the language's name, since this updates user-language-settings - (init-evaluation-thread) - - (begin-edit-sequence) - (set-position (last-position) (last-position)) - - (set! setting-up-repl? #t) - (insert/delta this (string-append (string-constant language) ": ") welcome-delta) - (let-values (((before after) - (insert/delta - this - (extract-language-name user-language-settings) - dark-green-delta - (extract-language-style-delta user-language-settings))) - ((url) (extract-language-url user-language-settings))) - (when url - (set-clickback before after (λ args (send-url url)) - click-delta))) - (unless (is-default-settings? user-language-settings) - (insert/delta this (string-append " " (string-constant custom)) dark-green-delta)) - (when custodian-limit - (insert/delta this - "; memory limit: " - welcome-delta) - (insert/delta this - (format "~a megabytes" (floor (/ custodian-limit 1024 1024))) - dark-green-delta)) - (insert/delta this ".\n" welcome-delta) - - (let ([osf (get-styles-fixed)]) - (set-styles-fixed #f) - (send (drscheme:language-configuration:language-settings-language user-language-settings) - extra-repl-information - (drscheme:language-configuration:language-settings-settings user-language-settings) - (open-output-text-editor this 'end)) - (set-styles-fixed osf)) - - (set! setting-up-repl? #f) - - (set! already-warned? #f) - (reset-regions (list (list (last-position) (last-position)))) - (set-unread-start-point (last-position)) - (set-insertion-point (last-position)) - (set-allow-edits #f) - (set! repl-header-end #f) - (end-edit-sequence)) + ;; clear out repl first before doing any work. + (begin-edit-sequence) + (set! prompt-position #f) + (reset-input-box) + (delete (paragraph-start-position 1) (last-position)) + (end-edit-sequence) - (define/public (initialize-console) - (begin-edit-sequence) - (freeze-colorer) - (set! setting-up-repl? #t) - (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta) - (let-values ([(before after) - (insert/delta this - (string-constant drscheme) - click-delta - drs-font-delta)]) - (insert/delta this (format (string-append ", " (string-constant version) " ~a [~a].\n") - (version:version) (system-type 'gc)) - welcome-delta) - (set-clickback before after - (λ args (drscheme:app:about-drscheme)) - click-delta)) - (set! setting-up-repl? #f) - (thaw-colorer) - (send context disable-evaluation) - (reset-console) - - (queue-user/wait - (λ () ; =User=, =No-Breaks= - (send (drscheme:language-configuration:language-settings-language user-language-settings) - first-opened))) - - (insert-prompt) - (send context enable-evaluation) - (end-edit-sequence) - (clear-undos)) + ;; must init-evaluation-thread before determining + ;; the language's name, since this updates user-language-settings + (init-evaluation-thread) - ;; avoid calling paragraph-start-position very often. - (define repl-header-end #f) - (define/private (get-repl-header-end) - (if repl-header-end - repl-header-end - (begin (set! repl-header-end (paragraph-start-position 2)) - repl-header-end))) + (begin-edit-sequence) + (set-position (last-position) (last-position)) - (define setting-up-repl? #f) - (define/augment (can-change-style? start len) - (and (inner #t can-change-style? start len) - (or setting-up-repl? - (start . >= . (get-repl-header-end))))) + (set! setting-up-repl? #t) + (insert/delta this (string-append (string-constant language) ": ") welcome-delta) + (let-values (((before after) + (insert/delta + this + (extract-language-name user-language-settings) + dark-green-delta + (extract-language-style-delta user-language-settings))) + ((url) (extract-language-url user-language-settings))) + (when url + (set-clickback before after (λ args (send-url url)) + click-delta))) + (unless (is-default-settings? user-language-settings) + (insert/delta this (string-append " " (string-constant custom)) dark-green-delta)) + (when custodian-limit + (insert/delta this + "; memory limit: " + welcome-delta) + (insert/delta this + (format "~a megabytes" (floor (/ custodian-limit 1024 1024))) + dark-green-delta)) + (insert/delta this ".\n" welcome-delta) - (define/private (last-str l) - (if (null? (cdr l)) - (car l) - (last-str (cdr l)))) + (let ([osf (get-styles-fixed)]) + (set-styles-fixed #f) + (send (drscheme:language-configuration:language-settings-language user-language-settings) + extra-repl-information + (drscheme:language-configuration:language-settings-settings user-language-settings) + (open-output-text-editor this 'end)) + (set-styles-fixed osf)) - (field (previous-expr-pos -1)) + (set! setting-up-repl? #f) - (define/public (copy-previous-expr) - (when prompt-position - (let ([snip/strings (list-ref (get-previous-exprs) previous-expr-pos)]) - (begin-edit-sequence) - (delete prompt-position (last-position) #f) - (for-each (λ (snip/string) - (insert (if (is-a? snip/string snip%) - (send snip/string copy) - snip/string) - prompt-position)) - snip/strings) - (set-position (last-position)) - (end-edit-sequence)))) + (set! already-warned? #f) + (reset-regions (list (list (last-position) (last-position)))) + (set-unread-start-point (last-position)) + (set-insertion-point (last-position)) + (set-allow-edits #f) + (set! repl-header-end #f) + (end-edit-sequence)) + + (define/public (initialize-console) + (begin-edit-sequence) + (freeze-colorer) + (set! setting-up-repl? #t) + (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta) + (let-values ([(before after) + (insert/delta this + (string-constant drscheme) + click-delta + drs-font-delta)]) + (insert/delta this (format (string-append ", " (string-constant version) " ~a [~a].\n") + (version:version) (system-type 'gc)) + welcome-delta) + (set-clickback before after + (λ args (drscheme:app:about-drscheme)) + click-delta)) + (set! setting-up-repl? #f) + (thaw-colorer) + (send context disable-evaluation) + (reset-console) - (define/public (copy-next-previous-expr) - (let ([previous-exprs (get-previous-exprs)]) - (unless (null? previous-exprs) - (set! previous-expr-pos - (if (< (add1 previous-expr-pos) (length previous-exprs)) - (add1 previous-expr-pos) - 0)) - (copy-previous-expr)))) - (define/public (copy-prev-previous-expr) - (let ([previous-exprs (get-previous-exprs)]) - (unless (null? previous-exprs) - (set! previous-expr-pos - (if (previous-expr-pos . <= . 0) - (sub1 (length previous-exprs)) - (sub1 previous-expr-pos))) - (copy-previous-expr)))) + (queue-user/wait + (λ () ; =User=, =No-Breaks= + (send (drscheme:language-configuration:language-settings-language user-language-settings) + first-opened))) - ;; private fields - (define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs)) - (define local-previous-exprs null) - (define/private (get-previous-exprs) - (append global-previous-exprs local-previous-exprs)) - (define/private (add-to-previous-exprs snips) - (let* ([new-previous-exprs - (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)]) - (let loop ([l trimmed-previous-exprs]) - (if (null? l) - (list snips) - (cons (car l) (loop (cdr l))))))]) - (set! local-previous-exprs new-previous-exprs))) - - (define/private (trim-previous-exprs lst) - (if ((length lst). >= . console-max-save-previous-exprs) - (cdr lst) - lst)) - - (define/private (save-interaction-in-history start end) - (split-snip start) - (split-snip end) - (let ([snips - (let loop ([snip (find-snip start 'after-or-none)] - [snips null]) - (cond - [(not snip) snips] - [((get-snip-position snip) . <= . end) - (loop (send snip next) - (cons (send snip copy) snips))] - [else snips]))]) - (set! previous-expr-pos -1) - (add-to-previous-exprs snips))) - - (define/public (reset-pretty-print-width) - (let* ([standard (send (get-style-list) find-named-style "Standard")]) - (when standard - (let* ([admin (get-admin)] - [width - (let ([bw (box 0)] - [b2 (box 0)]) - (send admin get-view b2 b2 bw b2) - (unbox bw))] - [dc (send admin get-dc)] - [new-font (send standard get-font)] - [old-font (send dc get-font)]) - (send dc set-font new-font) - (let* ([char-width (send dc get-char-width)] - [min-columns 50] - [new-columns (max min-columns - (floor (/ width char-width)))]) - (send dc set-font old-font) - (pretty-print-columns new-columns)))))) - (super-new) - (auto-wrap #t) - (set-styles-sticky #f) - - (inherit set-max-undo-history) - (set-max-undo-history 'forever))) - - (define (all-but-last lst) - (let loop ([o lst]) - (cond - [(null? o) null] - [(null? (cdr o)) null] - [else (cons (car o) (loop (cdr o)))]))) - - (define input-delta (make-object style-delta%)) - (send input-delta set-delta-foreground (make-object color% 0 150 0)) - - ;; insert-error-in-text : (is-a?/c text%) - ;; (union #f (is-a?/c drscheme:rep:text<%>)) - ;; string? - ;; exn? - ;; (union false? (and/c string? directory-exists?)) - ;; -> - ;; void? - (define (insert-error-in-text text interactions-text msg exn user-dir) - (insert-error-in-text/highlight-errors - text - (λ (l) (send interactions-text highlight-errors l)) - msg - exn - user-dir)) - - ;; insert-error-in-text/highlight-errors : (is-a?/c text%) - ;; ((listof (list text% number number)) -> void) - ;; string? - ;; exn? - ;; (union false? (and/c string? directory-exists?)) - ;; -> - ;; void? - (define (insert-error-in-text/highlight-errors text highlight-errors msg exn user-dir) - (let ([locked? (send text is-locked?)] - [insert-file-name/icon - ;; insert-file-name/icon : string number number number number -> void - (λ (source-name start span row col) - (let ([range-spec - (cond - [(and row col) - (format ":~a:~a" row col)] - [start - (format "::~a" start)] - [else ""])]) + (insert-prompt) + (send context enable-evaluation) + (end-edit-sequence) + (clear-undos)) + + ;; avoid calling paragraph-start-position very often. + (define repl-header-end #f) + (define/private (get-repl-header-end) + (if repl-header-end + repl-header-end + (begin (set! repl-header-end (paragraph-start-position 2)) + repl-header-end))) + + (define setting-up-repl? #f) + (define/augment (can-change-style? start len) + (and (inner #t can-change-style? start len) + (or setting-up-repl? + (start . >= . (get-repl-header-end))))) + + (define/private (last-str l) + (if (null? (cdr l)) + (car l) + (last-str (cdr l)))) + + (field (previous-expr-pos -1)) + + (define/public (copy-previous-expr) + (when prompt-position + (let ([snip/strings (list-ref (get-previous-exprs) previous-expr-pos)]) + (begin-edit-sequence) + (delete prompt-position (last-position) #f) + (for-each (λ (snip/string) + (insert (if (is-a? snip/string snip%) + (send snip/string copy) + snip/string) + prompt-position)) + snip/strings) + (set-position (last-position)) + (end-edit-sequence)))) + + (define/public (copy-next-previous-expr) + (let ([previous-exprs (get-previous-exprs)]) + (unless (null? previous-exprs) + (set! previous-expr-pos + (if (< (add1 previous-expr-pos) (length previous-exprs)) + (add1 previous-expr-pos) + 0)) + (copy-previous-expr)))) + (define/public (copy-prev-previous-expr) + (let ([previous-exprs (get-previous-exprs)]) + (unless (null? previous-exprs) + (set! previous-expr-pos + (if (previous-expr-pos . <= . 0) + (sub1 (length previous-exprs)) + (sub1 previous-expr-pos))) + (copy-previous-expr)))) + + ;; private fields + (define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs)) + (define local-previous-exprs null) + (define/private (get-previous-exprs) + (append global-previous-exprs local-previous-exprs)) + (define/private (add-to-previous-exprs snips) + (let* ([new-previous-exprs + (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)]) + (let loop ([l trimmed-previous-exprs]) + (if (null? l) + (list snips) + (cons (car l) (loop (cdr l))))))]) + (set! local-previous-exprs new-previous-exprs))) + + (define/private (trim-previous-exprs lst) + (if ((length lst). >= . console-max-save-previous-exprs) + (cdr lst) + lst)) + + (define/private (save-interaction-in-history start end) + (split-snip start) + (split-snip end) + (let ([snips + (let loop ([snip (find-snip start 'after-or-none)] + [snips null]) (cond - [(file-exists? source-name) - (let* ([normalized-name (normalize-path source-name)] - [short-name (if user-dir - (find-relative-path user-dir normalized-name) - source-name)]) - (let-values ([(icon-start icon-end) (insert/delta text (send file-icon copy))] - [(space-start space-end) (insert/delta text " ")] - [(name-start name-end) (insert/delta text short-name)] - [(range-start range-end) (insert/delta text range-spec)] - [(colon-start colon-ent) (insert/delta text ": ")]) - (when (number? start) - (send text set-clickback icon-start range-end - (λ (_1 _2 _3) - (open-file-and-highlight normalized-name - (- start 1) - (if span - (+ start -1 span) - start)))))))] - [else - (insert/delta text source-name) - (insert/delta text range-spec) - (insert/delta text ": ")])))]) - (send text begin-edit-sequence) - (send text lock #f) - (cond - [(exn:fail:syntax? exn) - (for-each - (λ (expr) - (let ([src (and (syntax? expr) (syntax-source expr))] - [pos (and (syntax? expr) (syntax-position expr))] - [span (and (syntax? expr) (syntax-span expr))] - [col (and (syntax? expr) (syntax-column expr))] - [line (and (syntax? expr) (syntax-line expr))]) - (when (and (string? src) - (number? pos) - (number? span) - (number? line) - (number? col)) - (insert-file-name/icon src pos span line col)) - (insert/delta text (format "~a" (exn-message exn)) error-delta) - (when (syntax? expr) - (insert/delta text " in: ") - (insert/delta text (format "~s" (syntax-object->datum expr)) error-text-style-delta)) - (insert/delta text "\n") - (when (and (is-a? src text:basic%) - (number? pos) - (number? span)) - (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))) - (exn:fail:syntax-exprs exn))] - [(exn:fail:read? exn) - '(let ([src (exn:read-source exn)] - [pos (exn:read-position exn)] - [span (exn:read-span exn)] - [line (exn:read-line exn)] - [col (exn:read-column exn)]) + [(not snip) snips] + [((get-snip-position snip) . <= . end) + (loop (send snip next) + (cons (send snip copy) snips))] + [else snips]))]) + (set! previous-expr-pos -1) + (add-to-previous-exprs snips))) + + (define/public (reset-pretty-print-width) + (let* ([standard (send (get-style-list) find-named-style "Standard")]) + (when standard + (let* ([admin (get-admin)] + [width + (let ([bw (box 0)] + [b2 (box 0)]) + (send admin get-view b2 b2 bw b2) + (unbox bw))] + [dc (send admin get-dc)] + [new-font (send standard get-font)] + [old-font (send dc get-font)]) + (send dc set-font new-font) + (let* ([char-width (send dc get-char-width)] + [min-columns 50] + [new-columns (max min-columns + (floor (/ width char-width)))]) + (send dc set-font old-font) + (pretty-print-columns new-columns)))))) + (super-new) + (auto-wrap #t) + (set-styles-sticky #f) + + (inherit set-max-undo-history) + (set-max-undo-history 'forever))) + + (define (all-but-last lst) + (let loop ([o lst]) + (cond + [(null? o) null] + [(null? (cdr o)) null] + [else (cons (car o) (loop (cdr o)))]))) + + (define input-delta (make-object style-delta%)) + (send input-delta set-delta-foreground (make-object color% 0 150 0)) + + ;; insert-error-in-text : (is-a?/c text%) + ;; (union #f (is-a?/c drscheme:rep:text<%>)) + ;; string? + ;; exn? + ;; (union false? (and/c string? directory-exists?)) + ;; -> + ;; void? + (define (insert-error-in-text text interactions-text msg exn user-dir) + (insert-error-in-text/highlight-errors + text + (λ (l) (send interactions-text highlight-errors l)) + msg + exn + user-dir)) + + ;; insert-error-in-text/highlight-errors : (is-a?/c text%) + ;; ((listof (list text% number number)) -> void) + ;; string? + ;; exn? + ;; (union false? (and/c string? directory-exists?)) + ;; -> + ;; void? + (define (insert-error-in-text/highlight-errors text highlight-errors msg exn user-dir) + (let ([locked? (send text is-locked?)] + [insert-file-name/icon + ;; insert-file-name/icon : string number number number number -> void + (λ (source-name start span row col) + (let ([range-spec + (cond + [(and row col) + (format ":~a:~a" row col)] + [start + (format "::~a" start)] + [else ""])]) + (cond + [(file-exists? source-name) + (let* ([normalized-name (normalize-path source-name)] + [short-name (if user-dir + (find-relative-path user-dir normalized-name) + source-name)]) + (let-values ([(icon-start icon-end) (insert/delta text (send file-icon copy))] + [(space-start space-end) (insert/delta text " ")] + [(name-start name-end) (insert/delta text short-name)] + [(range-start range-end) (insert/delta text range-spec)] + [(colon-start colon-ent) (insert/delta text ": ")]) + (when (number? start) + (send text set-clickback icon-start range-end + (λ (_1 _2 _3) + (open-file-and-highlight normalized-name + (- start 1) + (if span + (+ start -1 span) + start)))))))] + [else + (insert/delta text source-name) + (insert/delta text range-spec) + (insert/delta text ": ")])))]) + (send text begin-edit-sequence) + (send text lock #f) + (cond + [(exn:fail:syntax? exn) + (for-each + (λ (expr) + (let ([src (and (syntax? expr) (syntax-source expr))] + [pos (and (syntax? expr) (syntax-position expr))] + [span (and (syntax? expr) (syntax-span expr))] + [col (and (syntax? expr) (syntax-column expr))] + [line (and (syntax? expr) (syntax-line expr))]) (when (and (string? src) (number? pos) (number? span) @@ -1788,65 +1754,87 @@ TODO (number? col)) (insert-file-name/icon src pos span line col)) (insert/delta text (format "~a" (exn-message exn)) error-delta) + (when (syntax? expr) + (insert/delta text " in: ") + (insert/delta text (format "~s" (syntax->datum expr)) error-text-style-delta)) (insert/delta text "\n") (when (and (is-a? src text:basic%) (number? pos) (number? span)) - (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))] - [(exn? exn) - (insert/delta text (format "~a" (exn-message exn)) error-delta) - (insert/delta text "\n")] - [else - (insert/delta text "uncaught exception: " error-delta) - (insert/delta text (format "~s" exn) error-delta) - (insert/delta text "\n")]) - (send text lock locked?) - (send text end-edit-sequence))) - - - ;; open-file-and-highlight : string (union number #f) (union number #f) - ;; =Kernel, =Handler= - ;; opens the file named by filename. If position is #f, - ;; doesn't highlight anything. If position is a number and other-position - ;; is #f, highlights the range from position to the end of sexp. - ;; if other-position is a number, highlights from position to - ;; other position. - (define (open-file-and-highlight filename position other-position) - (let ([file (handler:edit-file filename)]) - (when (and (is-a? file drscheme:unit:frame%) - position) - (if other-position - (send (send file get-interactions-text) - highlight-error - (send file get-definitions-text) - position - other-position) - (send (send file get-interactions-text) - highlight-error/forward-sexp - (send file get-definitions-text) - position))))) - - (define drs-autocomplete-mixin - (λ (get-defs x) - (class (text:autocomplete-mixin x) - (define/override (get-all-words) - (let* ([definitions-text (get-defs this)] - [settings (send definitions-text get-next-settings)] - [language (drscheme:language-configuration:language-settings-language settings)]) - (send language capability-value 'drscheme:autocomplete-words))) - (super-new)))) - - (define -text% - (drs-bindings-keymap-mixin - (text-mixin - (text:ports-mixin - (scheme:text-mixin - (color:text-mixin - (text:info-mixin - (editor:info-mixin - (text:searching-mixin - (mode:host-text-mixin - (drs-autocomplete-mixin - (λ (txt) (send txt get-definitions-text)) - (text:foreground-color-mixin - text:clever-file-format%)))))))))))))) + (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))) + (exn:fail:syntax-exprs exn))] + [(exn:fail:read? exn) + '(let ([src (exn:read-source exn)] + [pos (exn:read-position exn)] + [span (exn:read-span exn)] + [line (exn:read-line exn)] + [col (exn:read-column exn)]) + (when (and (string? src) + (number? pos) + (number? span) + (number? line) + (number? col)) + (insert-file-name/icon src pos span line col)) + (insert/delta text (format "~a" (exn-message exn)) error-delta) + (insert/delta text "\n") + (when (and (is-a? src text:basic%) + (number? pos) + (number? span)) + (highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))] + [(exn? exn) + (insert/delta text (format "~a" (exn-message exn)) error-delta) + (insert/delta text "\n")] + [else + (insert/delta text "uncaught exception: " error-delta) + (insert/delta text (format "~s" exn) error-delta) + (insert/delta text "\n")]) + (send text lock locked?) + (send text end-edit-sequence))) + + + ;; open-file-and-highlight : string (union number #f) (union number #f) + ;; =Kernel, =Handler= + ;; opens the file named by filename. If position is #f, + ;; doesn't highlight anything. If position is a number and other-position + ;; is #f, highlights the range from position to the end of sexp. + ;; if other-position is a number, highlights from position to + ;; other position. + (define (open-file-and-highlight filename position other-position) + (let ([file (handler:edit-file filename)]) + (when (and (is-a? file drscheme:unit:frame%) + position) + (if other-position + (send (send file get-interactions-text) + highlight-error + (send file get-definitions-text) + position + other-position) + (send (send file get-interactions-text) + highlight-error/forward-sexp + (send file get-definitions-text) + position))))) + + (define drs-autocomplete-mixin + (λ (get-defs x) + (class (text:autocomplete-mixin x) + (define/override (get-all-words) + (let* ([definitions-text (get-defs this)] + [settings (send definitions-text get-next-settings)] + [language (drscheme:language-configuration:language-settings-language settings)]) + (send language capability-value 'drscheme:autocomplete-words))) + (super-new)))) + + (define -text% + (drs-bindings-keymap-mixin + (text-mixin + (text:ports-mixin + (scheme:text-mixin + (color:text-mixin + (text:info-mixin + (editor:info-mixin + (text:searching-mixin + (mode:host-text-mixin + (drs-autocomplete-mixin + (λ (txt) (send txt get-definitions-text)) + (text:foreground-color-mixin + text:clever-file-format%))))))))))))) \ No newline at end of file diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 364a808f52..8e51b17be7 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1124,13 +1124,10 @@ If the namespace does not, they are colored the unbound color. (λ () ;; =drs= (show-error-report/tab)))) - (drscheme:debug:show-error-and-highlight - msg exn - (λ (src-to-display cms) ;; =user= - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - (send (send the-tab get-ints) highlight-errors src-to-display cms)))))) + (drscheme:debug:error-display-handler/stacktrace + msg + exn + '()) (semaphore-post error-display-semaphore))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 20e3f35e0f..6100d0db74 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -296,18 +296,20 @@ all of the names in the tools library, for use defining keybindings ; ;;;; (proc-doc/names - drscheme:debug:show-error-and-highlight - (-> string? - (or/c any/c exn?) - (-> (listof srcloc?) (or/c false/c (listof (list/c (is-a?/c text%) number? number?))) any) - any) - (msg exn highlight-errors) - @{The first two arguments are the same as the arguments to the error-display-handler. - This function prints the error message to the current-error-port, like the default error-display-handler - and also calls @scheme[highlight-errors] to do error highlighting. It is be passed the stack trace - for the error message. - - This function should be called on the same thread/eventspace where the error happened.}) + drscheme:debug:error-display-handler/stacktrace + (->* (string? any/c) + ((or/c false/c (listof srcloc?))) + any) + ((msg exn) ((stack #f))) + @{Displays the error message represented by the string, adding + embellishments like those that appears in the DrScheme REPL, + specifically a clickable icon for the stack trace (if the srcloc location is not empty), + 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. + + This should be called in the same eventspace and on the same thread as the error.}) (proc-doc/names drscheme:debug:make-debug-error-display-handler @@ -323,7 +325,7 @@ all of the names in the tools library, for use defining keybindings @scheme[drscheme:debug:make-debug-eval-handler]. See also MzScheme's - MzLink{mz:p:error-display-handler}{error-display-handler} + @scheme[error-display-handler] parameter. If the current-error-port is the definitions window in @@ -345,7 +347,7 @@ all of the names in the tools library, for use defining keybindings This function is designed to work in conjunction with @scheme[drscheme:debug:make-debug-error-display-handler]. - See also MzScheme's MzLink{mz:p:eval-handler}{eval-handler} + See also MzScheme's @scheme[eval-handler] parameter. The resulting eval-handler expands and annotates the input @@ -384,10 +386,8 @@ all of the names in the tools library, for use defining keybindings (srcloc? . -> . void?) (debug-info) @{This function opens a DrScheme to display - @scheme[debug-info]. The first element in - the cons indicates where the file is - and the two number indicate a range of - text to show. + @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].}) diff --git a/collects/icons/stop-16x16.png b/collects/icons/stop-16x16.png new file mode 100644 index 0000000000000000000000000000000000000000..28070132eba29fb1c1a51038f3496b2331b09303 GIT binary patch literal 836 zcmV-K1H1f*P)eEicNqUih0nEyh3-Pw6w zE?yLwpBI^%6PcZjb8b%L_HAj6jt0jq>%{XQ{ok4y+qUhS4^N-|fJ291brqgGfmRFF z*WuYSux*Te`?NQT#n-hPH|&X4YXT6x8+v~2@BjIok&!nU8iG;@90!(`V&M9E+z$+Z z>!NZw_V@J-?Vg?8{d=wUn|>;t{_?$(C*LKPBXAs4R~O2%z;)r_Lr5lJa1d-8(KMn; z1H3NthC^eJRAnDu&xW;GfnQ&VvFZcJRMgc=@>c?g2|Kst>Y z9tOhzrJzuNR0_wkIy7rz!=zk>OP9bj;pox$?|L21oPo1v!S`Y7RycPK4j+a@0x}s= zTec*%WlamBd>)cX{O#M3WD**Uc=^#ISXe+VT!1hn>guA|(*yZDQ8vqByB+9>Ff6?c z2eQ4rnD_4^%_eGk8dg@Iw-<^<@I1l?5Adg^uy5U>t?Mkz%<%2%>Ua7){26R)6!tWm zuVi=aLifB_roO%y?7FBz0nPI;*47BZkb76I@Kv>X{udb40sk);f81=!z{<-0bbr5M z=T6Aykz5YRW|2gKD3u~yTB0&GCL`7A7eB#gfd7J<-i8y4wjDI`d0BH^X>@kVn(InE zmy^2V$UR*T--1tGaNuT3zN%@*UNejXzG(^~v6Q}#E~2KP{0IE_{Qf^I`a3r@XP9{a O0000kbCX)=5Jwh{Dto2wcd&wsE{G#d5%cIs5y*43-Op}HC-Ct-RTY&NSZlYzWE$jL!& z+@KrIY&&`Kl&e526#c;UqH<3E>GR#vcS6RcT7&*{@AONWQ|qG=YMY33-0!@^s? zzPa4txEdT8xv}Bw+5KLxHv*u#8XMbcmMuHPk|m@|O0);puC-Tx4DZ%0BRDqJT(xp# zYnQ{({AE*93xH;iMi-$J(NM@6Y;OLkdc}%^R8>JF0-+GReQRYX1gR8`-MjTKmM?Gp z^~#kq#@N{Wu57wt*j|l~7fn2Ve0STPJr-UdKu<@gqlTPt)UZyFDEKWIUUmNZ8G(sSo0@bSXS~1n=HiQxz1zh7F);s2w|~ zcDql^;pw#{B@J2OFt3xz(u$os>+t!=_0+hpH>F4E3aJymiW^gzVO~V`+L9^Ld zm!H3`_t~?5wAjXt1IYz=OiiKs`ba;0iU9b0P*nw$mEd$DBBXkIQO}=S!tL&ciHXm& zuZ|sSN%;MCeQL@^Gz#%JdNPTvyPHgJFJc(r^@7uhIWt4LtBb6`L9`bypuHV>dm)v| zvbkKYL{@2OMxH#$B9j4K2S7`wQE%RWVa&g&R0{j(DC*ul7#xK6@4@XxW@fTAfLK}C zKr$Y;)87vxBQQP=fdHzu7L}D{c@0n=5307-@}N@l{&S>K*@y`7c-(cXu<*X*;`h)5(Na^i%@xpN|^l=b%dwaC7GB5T)*tXd_(y1HL9fH^!fHy2zk(#6Gy z+YPZ8T(|(QUct~1($)rsfmu*MqOcHrK1`2?w~(>Tc_mg>HZb(?VND*_9jeg6DWZEhl$%av%jbm_a_j~w~&?_f~UN?{Zg zVdmvw`u&)T7GdV+V-y#Yo}Fc+qeK2Ubm)g~FJ3(CbUJ4ck^kkL*4Cq=+1Z(x*DKSx zxf1jFWI8ujq8^V#Jsugh*^HYlElmsmsQ(`Sx#;ff+!g8T+iL2%RbZN6nkds$p7Qcw fO@00Kh4udePiIvcU3{1T00000NkvXXu0mjfci=0- literal 1818 zcmV+#2j%#QP)W&Et3IfA~nE_^)bLM>e$ALiyto_F~d2@2k z`=0mrU7qhE2_cxuuC}$=%}q_EiV(6SN!ndOA!LIr$E0VUJ(272M5io}VA51Vo!74$ zJ2!6JRZ?8ML0BxH-K~Sc0Kp)~ySn~fvS&}N)9KVE6}g|#nPbONU0b&v&#A4QhsOia zdoBELyN&hQ*7avlGsq1)~upX+l5>D3jfseh%i64KM5vQjS&T>bXjE9Uz8UPTBb zNzw)L@*ph@gutL_NHb^VoMmn!wzt!{l>!Y4Ia~7sdpYBdcPuE?N+$p1@?vz-}?eP2E=bD;2(zCMc zw$f5-{<(82{-dh0E_ucHiy1L*|pYN0w4%-sbWNmcRf~x9-jf~LL(sJanKwz=+wb!gzEKphs zvuDHLpq?{4tozUqghDWPE|ipj-A=~aZ>Ky`R`$p*hY!!1)T5Z9n9wwWp-||=p+mo{ zE-$a3vQkHP*)ko9q9U$(y;DQs_1+CdO^v(mz=3^-)~(CB6AGgijhgX#Inv#Iesy8t z63WZr_HCj@BeJSu9D}0&qmM*MadE|@ogx^F?-a*=_~C3?b+yx3Rh7EDq2Yt({rms5 zYSX5x`Wz{WiEG!0Ns>lh-UEZesDgye2CB+~ghGy`qy*YyF;ufzJV+?yyt1-O?Lq`^ zMk0(uaj>cB`lxbv5MV#6L%Sdr|A_F?Dq4_+PpNt*xlRV3ItZM{K|v$}fPG*9?UPSX zZ`_y!T%^4nzWfrKs=~kk?A;3u4f;}$Wz=xkW*ko*hvN1a6hxys^5f@^qF^m3(2tP> zvu0&MQW7*a>StIaLVU@nDq1vZiT5ZG3OYLUc?yNV=YxkIhK(EbLov~&O@l34^!bt` zolvV4%w{l|umu86gb;W6KR0YxBV<_!i$#dkR3Th0Azpr22vrqvQxqXyd{Jnxyds3A zO?;0=g?QlwA#!ttm^Dj?j0_>t(!_Ub*KU^+8yAPdYz9puR$UG6y*IHVL?ZCgOK{-= z(#eysZ5t?x9y6KX(@#-WuGFEjS|K?Z1&ot~#-WHg9N=&eJ$#tRH{a;N{(jiHRUg*; ze3&x_y1R*O-;Nl=-~YuIM9!Q6rxRQ*{ud6@=W^Ycblp1k(@*I)tExKk4ThBB++3`( zjH+o!>(^uOdUYBzGxh71*$lFb=<7oE08n4fXW8Xgalo!Z@ z-+!MK*u44Yf}x=~vr9@yPEFN^Y{m@8$k2gEO47vuVljl@kJi(J!EPrK2ynT%8E+)w z6FYZ4x_0yCD^m&qTsVK;cK-S2>la?UxHfa?QqmuKNH6Yk>4-a>V7G%T>+3BTgrOlq z?d^2c*K;N-GzDA_5c6?07*qo IM6N<$f;;k)rvLx| diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 6e329987f5..68bfca27d9 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -329,6 +329,11 @@ please adhere to these guidelines: (help-desk-this-is-just-example-text "This is just example text for setting the font size. Open Help Desk proper (from Help menu) to follow these links.") + ;; 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: loading documentation index") + ;; Help desk htty proxy (http-proxy "HTTP Proxy") (proxy-direct-connection "Direct connection") diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index a4e02a8e62..e6f4f329f2 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -14,7 +14,7 @@ mzlib/etc (lib "gui.ss" "tests" "utils") mzlib/contract) - + (provide/contract [use-get/put-dialog ((-> any) path? . -> . void?)]) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 68adf4b9e3..1da34317f3 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -11,218 +11,121 @@ the settings above should match r5rs |# -(module language-test mzscheme - (require "drscheme-test-util.ss" - (lib "gui.ss" "tests" "utils") - mzlib/class - mzlib/list - mred - framework - (prefix fw: framework)) - - (provide run-test) +#lang scheme - (define language (make-parameter "<>")) - - ;; set-language : boolean -> void - (define (set-language close-dialog?) - (set-language-level! (language) close-dialog?)) +(require "drscheme-test-util.ss" + (lib "gui.ss" "tests" "utils") + mred + framework + (prefix-in fw: framework)) - - - ;; - ; - ; -;;; ; ; ;;; ;;; ;;;; - ; ; ; ; ; ; ; ; - ; ; ; ; ;;;;; ; ; - ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; -;; ; ;; ;;;; ;;; ;;; ; - +(provide run-test) - #: - (define (mred) - (parameterize ([language (list "PLT" (regexp "Graphical"))]) - (check-top-of-repl) +(define language (make-parameter "<>")) - (generic-settings #f) - (generic-output #t #t #t) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - - (test-expression '("(equal? (list " image ") (list " image "))") - "#f") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression 'xml "(a () (b ()))") - - (test-expression "(define-struct spider (legs))(make-spider 4)" "#") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" "{bug09.png} reference to undefined identifier: shared") - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "{bug09.png} reference to undefined identifier: true") - (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" "{bug09.png} +: expects type as 1st argument, given: (1); other arguments were: 2") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression - "(local ((define x x)) 1)" - #rx"define: not allowed in an expression context") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "{bug09.png} car: expects argument of type ; given ()") - - (test-expression "argv" "#0()") - - (test-expression "(define-syntax app syntax-case)" "syntax-case: bad syntax in: syntax-case"))) +;; set-language : boolean -> void +(define (set-language close-dialog?) + (set-language-level! (language) close-dialog?)) - - ;; - ; - ; -;;; ; ;;;;; ;;; ;;; ; ;; ;;; ;;; ; ;;; - ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; - ; ; ; ; ;;; ; ; ; ;;;;; ; ; ; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -;; ; ;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; - - - - (define (pretty-big) - (parameterize ([language (list "Pretty Big (includes MrEd and Advanced Student)")]) +; +; +; +; ; ; ;;;; ;; +; ;; ;; ;;;; ;; +; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;;;; +; ;;;;;;;; ;;;;;;; ;;;;; ;;;;;; ;;;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;;;;;;; ;;;; ;;; ;;;; +; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;; ;;;; ;;;;;;; +; ;;;;;;;; ;;;; ;;;;;; ;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ; ;;;; +; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;; +; - (check-top-of-repl) +(define (pretty-big) + (parameterize ([language (list "Pretty Big (includes MrEd and Advanced Student)")]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #t #t) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#f") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression "(define-struct spider (legs))(make-spider 4)" "#") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" (regexp "class: bad syntax in: class")) + (test-expression "shared" (regexp "shared: bad syntax in: shared")) + + (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression "call/cc" "#") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" "#t") + (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#f") + (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined identifier: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "1") + (test-expression "(letrec ([x x]) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + + (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" "{stop-multi.png} {stop-22x22.png} car: expects argument of type ; given ()") + + (test-expression "(current-command-line-arguments)" "#()") + (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case"))) - (generic-settings #f) - (generic-output #t #t #t) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#f") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" "#") - - (test-expression "(sqrt -1)" "0+1i") - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" (regexp "shared: bad syntax in: shared")) - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "#t") - (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" "{bug09.png} +: expects type as 1st argument, given: (1); other arguments were: 2") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" "1") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "{bug09.png} car: expects argument of type ; given ()") - - (test-expression "(current-command-line-arguments)" "#()") - (test-expression "(define-syntax app syntax-case)" "syntax-case: bad syntax in: syntax-case"))) - - - ; ; ; @@ -240,1027 +143,1221 @@ the settings above should match r5rs ; ; - - (define (r5rs) - (parameterize ([language (list (regexp "R5RS"))]) - (check-top-of-repl) +(define (r5rs) + (parameterize ([language (list (regexp "R5RS"))]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #t #t) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#f") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression + "(define-struct spider (legs))(make-spider 4)" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: define-struct" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: define-struct\n{stop-multi.png} {stop-22x22.png} reference to undefined identifier: make-spider") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: class") + (test-expression "shared" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: shared") + + (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression "call/cc" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: call/cc") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") + + (test-expression "(time 1)" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: time") + + (test-expression "true" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: true") + (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined identifier: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond ((= 1 2) 3))" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" + "((1 . 1) (1 . 1))") + (test-expression + "(local ((define x x)) 1)" + #rx"define: not allowed in an expression context") + (test-expression "(letrec ((x x)) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + + (test-expression "(let ((f (lambda (x) x))) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" + "{stop-multi.png} {stop-22x22.png} mcar: expects argument of type ; given ()") + + (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"))) - (generic-settings #f) - (generic-output #t #t #t) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#f") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "{bug09.png} reference to undefined identifier: define-struct" - "{bug09.png} reference to undefined identifier: define-struct\n{bug09.png} reference to undefined identifier: make-spider") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" "{bug09.png} reference to undefined identifier: class") - (test-expression "shared" "{bug09.png} reference to undefined identifier: shared") - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "{bug09.png} reference to undefined identifier: call/cc") - - (test-expression "(error 'a \"~a\" 1)" "{bug09.png} reference to undefined identifier: error") - (test-expression "(error \"a\" \"a\")" "{bug09.png} reference to undefined identifier: error") - - (test-expression "(time 1)" - "{bug09.png} reference to undefined identifier: time") - - (test-expression "true" "{bug09.png} reference to undefined identifier: true") - (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond ((= 1 2) 3))" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" "{bug09.png} +: expects type as 1st argument, given: (1); other arguments were: 2") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" - "((1 . 1) (1 . 1))") - (test-expression - "(local ((define x x)) 1)" - #rx"define: not allowed in an expression context") - (test-expression "(letrec ((x x)) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - - (test-expression "(let ((f (lambda (x) x))) f)" "#") - (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" - "{bug09.png} mcar: expects argument of type ; given ()") - - (test-expression "argv" "{bug09.png} reference to undefined identifier: argv") - (test-expression "(define-syntax app syntax-case)" - "compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: syntax-case"))) - ;; ; - ; - ; - ;;;; ;;; ;;; ; ;;; ; ;;; ; ;;; ;;; ; ;;; - ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; - ; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; +; +;;;; ;;; ;;; ; ;;; ; ;;; ; ;;; ;;; ; ;;; +; ; ; ; ; ; ; ;; ; ;; ; ; ; ; +; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ;;;; ;;;;; ;;; ;;;;; ;; ;;; ;;;; - ; - ; - ;;; +; +; +;;; - - (define (beginner) - (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) - (check-top-of-repl) - (generic-settings #t) - (generic-output #f #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) +(define (beginner) + (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|\nThis program should be tested." + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true\nThis program should be tested." + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "define: cannot redefine name: x") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)\nThis program should be tested." + "define-struct: cannot redefine name: spider\n(make-spider 4)") + + (test-expression "(sqrt -1)" + "0+1i\nThis program should be tested." + "0+1i\n") + + (test-expression "class" + "class: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: class") + (test-expression "shared" + "shared: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-expression "call/cc" + "call/cc: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: call/cc") + + (test-expression "(error 'a \"~a\" 1)" + "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") + (test-expression "(error \"a\" \"a\")" + "error: expected a symbol and a string, got \"a\" and \"a\"") + + (test-expression "(time 1)" + "time: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: time") + + (test-expression "true" + "true\nThis program should be tested." + "true") + (test-expression "mred^" + "mred^: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: mred^") + (test-expression "(eq? 'a 'A)" + "false\nThis program should be tested." + "false") + (test-expression "(set! x 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(define qqq 2) (set! qqq 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + + (test-expression "(cond [(= 1 2) 3])" + "cond: all question results were false") + (test-expression "(cons 1 2)" + "cons: second argument must be of type , given 1 and 2") + (test-expression "(+ (list 1) 2)" + "+: expects type as 1st argument, given: (cons 1 empty); other arguments were: 2") + (test-expression "'(1)" + "quote: expected a name after a ', found something else") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(cons (cons 1 empty) (cons (cons 1 empty) empty))\nThis program should be tested." + "define: cannot redefine name: shrd\n(cons (cons 1 empty) (cons (cons 1 empty) empty))") + (test-expression "(local ((define x x)) 1)" + "local: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (test-expression "(letrec ([x x]) 1)" + "letrec: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (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.0" "1\nThis program should be tested." "1") + (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}\nThis program should be tested." + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}\nThis program should be tested." + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}\nThis program should be tested." + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}\nThis program should be tested." + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}\nThis program should be tested." + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}\nThis program should be tested." + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}\nThis program should be tested." + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}\nThis program should be tested." + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i\nThis program should be tested." + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i\nThis program should be tested." + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" + "true\nThis program should be tested." + "true") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "let: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (test-expression ",1" + "read: illegal use of comma") + + (test-expression "(list 1)" + "(cons 1 empty)\nThis program should be tested." + "(cons 1 empty)") + (test-expression "(car (list))" "car: expects argument of type ; given empty") + + (test-expression "argv" + "argv: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: argv") + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: define-syntax"))) - (test-expression "'|.|" "'.") - (test-expression '("(equal? (list " image ") (list " image "))") - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "define: cannot redefine name: x") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "define-struct: cannot redefine name: spider\n(make-spider 4)") - - (test-expression "(sqrt -1)" "0+1i") - (test-expression "class" - "class: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: class") - (test-expression "shared" - "shared: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: shared") - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-expression "call/cc" - "call/cc: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: call/cc") - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" - "time: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: time") - - (test-expression "true" "true") - (test-expression "mred^" - "mred^: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(define qqq 2) (set! qqq 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (cons 1 empty); other arguments were: 2") - (test-expression "'(1)" "quote: expected a name after a ', found something else") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(cons (cons 1 empty) (cons (cons 1 empty) empty))" - "define: cannot redefine name: shrd\n(cons (cons 1 empty) (cons (cons 1 empty) empty))") - (test-expression "(local ((define x x)) 1)" - "local: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (test-expression "(letrec ([x x]) 1)" - "letrec: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (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.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "4/3" "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i") - (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "let: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (test-expression ",1" - "read: illegal use of comma") - - (test-expression "(list 1)" "(cons 1 empty)") - (test-expression "(car (list))" "car: expects argument of type ; given empty") - - (test-expression "argv" - "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv") - (test-expression "(define-syntax app syntax-case)" - "define-syntax: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: define-syntax"))) - - - ;; ; ;; - ; ; ; - ; ; ; - ;;;; ;;; ;;; ; ; ;;;; ;;;; ; ;;; ;;; ;;; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ;;;;; ; ; ; ;;;; ; ; ; ;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; +; ; ; +; ; ; +;;;; ;;; ;;; ; ; ;;;; ;;;; ; ;;; ;;; ;;; ;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;;;; ; ; ; ;;;; ; ; ; ;;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;;; ;;; ;;;; ; ;;; ;; ;;; ;;;; ;;; ; - ; ; - ; - ;;; +; ; +; +;;; - (define (beginner/abbrev) - (parameterize ([language (list "How to Design Programs" - #rx"Beginning Student with List Abbreviations(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "'.") - (test-expression '("(equal? (list " image ") (list " image "))") - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "define: cannot redefine name: x") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "define-struct: cannot redefine name: spider\n(make-spider 4)") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" - "class: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: class") - (test-expression "shared" - "shared: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-expression "call/cc" - "call/cc: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: call/cc") - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" - "time: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: time") - - (test-expression "true" "true") - (test-expression "mred^" - "mred^: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(define qqq 2) (set! qqq 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "define: cannot redefine name: shrd\n(list (list 1) (list 1))") - (test-expression "(local ((define x x)) 1)" - "local: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (test-expression "(letrec ([x x]) 1)" - "letrec: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (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.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "4/3" "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i") - (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "let: name is not defined, not a parameter, and not a primitive name" - "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") - (test-expression ",1" - "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") - - (test-expression "(list 1)" "(list 1)") - (test-expression "(car (list))" "car: expects argument of type ; given empty") - - (test-expression "argv" - "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv") - - (test-expression "(define-syntax app syntax-case)" - "define-syntax: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: define-syntax"))) +(define (beginner/abbrev) + (parameterize ([language (list "How to Design Programs" + #rx"Beginning Student with List Abbreviations(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|\nThis program should be tested." + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true\nThis program should be tested." + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "define: cannot redefine name: x") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)\nThis program should be tested." + "define-struct: cannot redefine name: spider\n(make-spider 4)") + + (test-expression "(sqrt -1)" + "0+1i\nThis program should be tested." + "0+1i") + + (test-expression "class" + "class: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: class") + (test-expression "shared" + "shared: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-expression "call/cc" + "call/cc: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: call/cc") + + (test-expression "(error 'a \"~a\" 1)" + "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") + (test-expression "(error \"a\" \"a\")" + "error: expected a symbol and a string, got \"a\" and \"a\"") + + (test-expression "(time 1)" + "time: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: time") + + (test-expression "true" + "true\nThis program should be tested." + "true") + (test-expression "mred^" + "mred^: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: mred^") + (test-expression "(eq? 'a 'A)" + "false\nThis program should be tested." + "false") + (test-expression "(set! x 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(define qqq 2) (set! qqq 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") + (test-expression "'(1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))\nThis program should be tested." + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") + (test-expression "(local ((define x x)) 1)" + "local: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (test-expression "(letrec ([x x]) 1)" + "letrec: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (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.0" "1\nThis program should be tested." "1") + (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}\nThis program should be tested." + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}\nThis program should be tested." + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}\nThis program should be tested." + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}\nThis program should be tested." + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}\nThis program should be tested." + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}\nThis program should be tested." + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}\nThis program should be tested." + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}\nThis program should be tested." + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i\nThis program should be tested." + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i\nThis program should be tested." + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" + "true\nThis program should be tested." + "true") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "let: name is not defined, not a parameter, and not a primitive name" + "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") + (test-expression ",1" + "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(car (list))" "car: expects argument of type ; given empty") + + (test-expression "argv" + "argv: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: argv") + + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: define-syntax"))) - - ; ;; ; - ; ; ; - ; ; ; - ;;; ; ;;; ;;;;; ;;; ; ;;; ;;; ; ;;; ;;;; ;;; ;;;; ;;;;; ;;; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ;;;; ; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;;;; ;;; ;; ;;; ;;; ;;;; ;; ; ;; ;;; ;;; ; ;;;;; ;;; ; ;;; ;;; - - - + +; ;; ; +; ; ; +; ; ; +;;; ; ;;; ;;;;; ;;; ; ;;; ;;; ; ;;; ;;;; ;;; ;;;; ;;;;; ;;; +; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ;;;; ; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +;;;;; ;;; ;; ;;; ;;; ;;;; ;; ; ;; ;;; ;;; ; ;;;;; ;;; ; ;;; ;;; - (define (intermediate) - (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "'.") - (test-expression '("(equal? (list " image ") (list " image "))") - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "define: cannot redefine name: x") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "define-struct: cannot redefine name: spider\n(make-spider 4)") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" - "class: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: class") - (test-expression "shared" - "shared: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-expression "call/cc" - "call/cc: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: call/cc") - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "true") - (test-expression "mred^" - "mred^: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(define qqq 2) (set! qqq 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "define: cannot redefine name: shrd\n(list (list 1) (list 1))") - (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.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "4/3" "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i") - (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - - (test-expression "(let ([f (lambda (x) x)]) f)" "function:f") - (test-expression ",1" - "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") - - (test-expression "(list 1)" "(list 1)") - (test-expression "(car (list))" "car: expects argument of type ; given empty") - (test-expression "argv" - "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv") - - (test-expression "(define-syntax app syntax-case)" - "define-syntax: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: define-syntax"))) - - ; ; ;;; ;; ;; - ; ; ; ; ; - ; ; ; ; ; - ;;; ; ;;; ;;;;; ; ; ;;;; ;;; ; ;;;; ;;;; ;;;; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;;;; ;;; ;; ;;; ; ;;;;;; ;;; ;;; ; ;;; ;;; ;;; ; ;;; ; - ; - - + +(define (intermediate) + (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|\nThis program should be tested." + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true\nThis program should be tested." + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "define: cannot redefine name: x") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)\nThis program should be tested." + "define-struct: cannot redefine name: spider\n(make-spider 4)") + + (test-expression "(sqrt -1)" + "0+1i\nThis program should be tested." + "0+1i") + + (test-expression "class" + "class: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: class") + (test-expression "shared" + "shared: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-expression "call/cc" + "call/cc: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: call/cc") + + (test-expression "(error 'a \"~a\" 1)" + "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") + (test-expression "(error \"a\" \"a\")" + "error: expected a symbol and a string, got \"a\" and \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true\nThis program should be tested." + "true") + (test-expression "mred^" + "mred^: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: mred^") + (test-expression "(eq? 'a 'A)" + "false\nThis program should be tested." + "false") + (test-expression "(set! x 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(define qqq 2) (set! qqq 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") + (test-expression "'(1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))\nThis program should be tested." + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") + (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.0" "1\nThis program should be tested." "1") + (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}\nThis program should be tested." + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}\nThis program should be tested." + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}\nThis program should be tested." + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}\nThis program should be tested." + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}\nThis program should be tested." + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}\nThis program should be tested." + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}\nThis program should be tested." + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}\nThis program should be tested." + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i\nThis program should be tested." + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i\nThis program should be tested." + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" + "true\nThis program should be tested." + "true") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "function:f\nThis program should be tested." + "function:f") + (test-expression ",1" + "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(car (list))" "car: expects argument of type ; given empty") + (test-expression "argv" + "argv: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: argv") + + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: define-syntax"))) - (define (intermediate/lambda) - (parameterize ([language (list "How to Design Programs" - #rx"Intermediate Student with lambda(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "'.") - (test-expression '("(equal? (list " image ") (list " image "))") - "true") - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "define: cannot redefine name: x") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "define-struct: cannot redefine name: spider\n(make-spider 4)") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" - "class: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: class") - (test-expression "shared" - "shared: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-expression "call/cc" - "call/cc: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: call/cc") - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "true") - (test-expression "mred^" - "mred^: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(define qqq 2) (set! qqq 1)" - "set!: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "define: cannot redefine name: shrd\n(list (list 1) (list 1))") - (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.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "4/3" "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i") - (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - - (test-expression "(let ([f (lambda (x) x)]) f)" "(lambda (a1) ...)") - (test-expression ",1" - "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") - (test-expression "(list 1)" "(list 1)") - (test-expression "(car (list))" "car: expects argument of type ; given empty") - (test-expression "argv" - "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv") - - (test-expression "(define-syntax app syntax-case)" - "define-syntax: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: define-syntax"))) - - - - ;; ;; - ; ; - ; ; - ;;;; ;;;; ;;; ;;; ;;;; ; ;;; ;;; ;;; ;;;; - ; ; ; ; ; ; ;; ; ; ; ; ; ; ; - ;;;; ; ; ; ; ;;;; ; ; ; ;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; - ;;; ; ;;; ; ; ;;; ;;;; ;; ;;; ;;; ;;; ; - - - +; +; +; +; ;; ; ;;;;;; ;;;; ;;;; +; ;; ;; ;;;;;; ;;;; ;;;; +; ;;;; ;;; ;;;;; ;;;;;; ;;;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;; ;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; +; ;; +; +; - (define (advanced) - (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #t #t) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "'.") - (test-expression '("(equal? (list " image ") (list " image "))") - "true") - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "define: cannot redefine name: x") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "define-struct: cannot redefine name: spider\n(make-spider 4)") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" - "class: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: class") - - (test-expression "shared" "shared: found a use of `shared' that does not follow an open parenthesis") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-expression "call/cc" - "call/cc: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: call/cc") - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "true") - (test-expression "mred^" - "mred^: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" - "x: name is not defined" - "set!: cannot set identifier before its definition: x") - (test-expression "(define qqq 2) (set! qqq 1)" - "(void)" - "define: cannot redefine name: qqq\n(void)") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(shared ((-1- (list 1))) (list -1- -1-))" - "define: cannot redefine name: shrd\n(shared ((-1- (list 1))) (list -1- -1-))") - (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.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "4/3" "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i") - (test-expression "779625/32258" "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - - (test-expression "(let ([f (lambda (x) x)]) f)" "(lambda (a1) ...)") - (test-expression ",1" - "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") - - (test-expression "(list 1)" "(list 1)") - (test-expression "(car (list))" "car: expects argument of type ; given empty") - (test-expression "argv" - "argv: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: argv") - - (test-expression "(define-syntax app syntax-case)" - "define-syntax: name is not defined, not a parameter, and not a primitive name" - "reference to an identifier before its definition: define-syntax"))) - - - - ; - ; - ;;; ;; ;; ; ;;; ; ;;; ;;; ; ;;; ;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; - ;;; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;; ;;; ; ;;;; ;;;; ;;; ;;;; ;;; - ; ; - ; ; - ;;; ;;; +(define (intermediate/lambda) + (parameterize ([language (list "How to Design Programs" + #rx"Intermediate Student with lambda(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|\nThis program should be tested." + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true\nThis program should be tested." + "true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "define: cannot redefine name: x") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)\nThis program should be tested." + "define-struct: cannot redefine name: spider\n(make-spider 4)") + + (test-expression "(sqrt -1)" + "0+1i\nThis program should be tested." + "0+1i") + + (test-expression "class" + "class: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: class") + (test-expression "shared" + "shared: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-expression "call/cc" + "call/cc: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: call/cc") + + (test-expression "(error 'a \"~a\" 1)" + "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") + (test-expression "(error \"a\" \"a\")" + "error: expected a symbol and a string, got \"a\" and \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true\nThis program should be tested." + "true") + (test-expression "mred^" + "mred^: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: mred^") + (test-expression "(eq? 'a 'A)" + "false\nThis program should be tested." + "false") + (test-expression "(set! x 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(define qqq 2) (set! qqq 1)" + "set!: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") + (test-expression "'(1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))\nThis program should be tested." + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") + (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.0" "1\nThis program should be tested." "1") + (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}\nThis program should be tested." + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}\nThis program should be tested." + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}\nThis program should be tested." + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}\nThis program should be tested." + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}\nThis program should be tested." + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}\nThis program should be tested." + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}\nThis program should be tested." + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}\nThis program should be tested." + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" "0+1/3i\nThis program should be tested." "0+1/3i") + (test-expression "+1/2i" "0+0.5i\nThis program should be tested." "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" + "true\nThis program should be tested." + "true") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "(lambda (a1) ...)\nThis program should be tested." + "(lambda (a1) ...)") + (test-expression ",1" + "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(car (list))" "car: expects argument of type ; given empty") + (test-expression "argv" + "argv: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: argv") + + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: define-syntax"))) - (define (prepare-for-test-expression) - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (sleep 1) ;; this shouldn't be neccessary.... - (do-execute drs))) - - ;; test-setting : (-> void) string string string -> void - ;; opens the language dialog, runs `set-setting' - ;; closes the language dialog, executes, - ;; makes sure that `expression' produces - ;; `result'. `set-setting' is expected to click around - ;; in the language dialog. - ;; `setting-name' is used in the error message when the test fails. - (define (test-setting set-setting setting-name expression result) - (set-language #f) - (set-setting) - (let ([f (get-top-level-focus-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)) - (let* ([drs (get-top-level-focus-window)] - [interactions (send drs get-interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output drs)]) - (unless (string=? result got) - (printf "FAILED: ~s ~s ~s test~n expected: ~a~n got: ~a~n" - (language) setting-name expression result got))))) - - (define (test-hash-bang) - (let* ([expression "#!/bin/sh\n1"] - [result "1"] - [drs (get-top-level-focus-window)] - [interactions (send drs get-interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output drs)]) - (unless (string=? "1" got) - (printf "FAILED: ~s ~a test~n expected: ~a~n got: ~a~n" - (language) expression result got))))) - - (define (check-top-of-repl) - (let ([drs (wait-for-drscheme-frame)]) - (set-language #t) - (with-handlers ([exn:fail? void]) - (fw:test:menu-select "Testing" "Disable tests")) - (do-execute drs) - (let* ([interactions (send drs get-interactions-text)] - [short-lang (car (last-pair (language)))] - [get-line (lambda (n) (send interactions get-text - (send interactions paragraph-start-position n) - (send interactions paragraph-end-position n)))] - [line0-expect (format "Welcome to DrScheme, version ~a [3m]." (version:version))] - [line1-expect - (if (string? short-lang) - (format "Language: ~a" short-lang) - short-lang)] - [line0-got (get-line 0)] - [line1-got (get-line 1)]) - (unless (and (string=? line0-expect line0-got) - (if (string? short-lang) - (string=? line1-expect (substring line1-got - 0 - (min (string-length line1-expect) - (string-length line1-got)))) - (regexp-match line1-expect line1-got))) - (printf "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" - line0-expect line1-expect - line0-got line1-got) - (error 'language-test.ss "failed get top of repl test"))))) - - ;; teaching-language-fraction-output - ;; tests that the teaching langauges properly handle repeating decimals - (define (teaching-language-fraction-output) - (test-setting - (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions")) - "Fraction Style -- Mixed fractions" - "4/3" - "{number 4/3 \"1 1/3\" mixed}") - (test-setting - (lambda () (fw:test:set-radio-box! "Fraction Style" "Repeating decimals")) - "Fraction Style -- Repeating decimals" - "4/3" - "{number 4/3 \"1.3\" decimal}")) - - ;; plt-language-fraction-output : -> void - ;; tests that the PLT languages properly handle repeating decimals - (define (plt-language-fraction-output) - (test-setting - (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f)) - "Use decimal notation for rationals -- #f" - "4/3 1/2 -1/3" - "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}") - (test-setting - (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) - "Use decimal notation for rationals -- #t" - "4/3 1/2 -1/3" - "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}")) - - (define (generic-settings false/true?) - (test-setting - (lambda () (fw:test:set-check-box! "Case sensitive" #t)) - "Case sensitive -- #t" - "(eq? 'g 'G)" (if false/true? "false" "#f")) - (test-setting - (lambda () (fw:test:set-check-box! "Case sensitive" #f)) - "Case sensitive -- #f" - "(eq? 'g 'G)" (if false/true? "true" "#t"))) - - (define (generic-output list? quasi-quote? has-sharing?) - (let* ([drs (wait-for-drscheme-frame)] - [expression (format "(define x (list 2))~n(list x x)")] - [set-output-choice - (lambda (option show-sharing pretty?) - (set-language #f) - (fw:test:set-radio-box! "Output Style" option) - (when (and has-sharing? show-sharing) - (fw:test:set-check-box! - "Show sharing in values" - (if (eq? show-sharing 'on) #t #f))) +; +; +; +; ;;;; ;;;; +; ;;;; ;;;; +; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;; ;;; ;;;;;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; +; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; +; ;; ;;;; ;;;;;;;;; ;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; +; ;; ;;;; ;;;;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;; +; +; +; + + +(define (advanced) + (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #t #t) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|\nThis program should be tested." + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true\nThis program should be tested." + "true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "define: cannot redefine name: x") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)\nThis program should be tested." + "define-struct: cannot redefine name: spider\n(make-spider 4)") + + (test-expression "(sqrt -1)" + "0+1i\nThis program should be tested." + "0+1i") + + (test-expression "class" + "class: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: class") + + (test-expression "shared" "shared: found a use of `shared' that does not follow an open parenthesis") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-expression "call/cc" + "call/cc: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: call/cc") + + (test-expression "(error 'a \"~a\" 1)" + "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") + (test-expression "(error \"a\" \"a\")" + "error: expected a symbol and a string, got \"a\" and \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true\nThis program should be tested." + "true") + (test-expression "mred^" + "mred^: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: mred^") + (test-expression "(eq? 'a 'A)" + "false\nThis program should be tested." + "false") + (test-expression "(set! x 1)" + "x: name is not defined" + "set!: cannot set identifier before its definition: x") + (test-expression "(define qqq 2) (set! qqq 1)" + "(void)\nThis program should be tested." + "define: cannot redefine name: qqq\n(void)") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects type as 1st argument, given: (list 1); other arguments were: 2") + (test-expression "'(1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(shared ((-1- (list 1))) (list -1- -1-))\nThis program should be tested." + "define: cannot redefine name: shrd\n(shared ((-1- (list 1))) (list -1- -1-))") + (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.0" "1\nThis program should be tested." "1") + (test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}\nThis program should be tested." + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}\nThis program should be tested." + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}\nThis program should be tested." + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}\nThis program should be tested." + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}\nThis program should be tested." + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}\nThis program should be tested." + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}\nThis program should be tested." + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}\nThis program should be tested." + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i\nThis program should be tested." + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i\nThis program should be tested." + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" + "true\nThis program should be tested." + "true") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "(lambda (a1) ...)\nThis program should be tested." + "(lambda (a1) ...)") + (test-expression ",1" + "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)\nThis program should be tested." + "(list 1)") + (test-expression "(car (list))" "car: expects argument of type ; given empty") + (test-expression "argv" + "argv: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: argv") + + (test-expression "(define-syntax app syntax-case)" + "define-syntax: name is not defined, not a parameter, and not a primitive name" + "reference to an identifier before its definition: define-syntax"))) + + + + +(define (prepare-for-test-expression) + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (sleep 1) ;; this shouldn't be neccessary.... + (do-execute drs))) + +;; test-setting : (-> void) string string string -> void +;; opens the language dialog, runs `set-setting' +;; closes the language dialog, executes, +;; makes sure that `expression' produces +;; `result'. `set-setting' is expected to click around +;; in the language dialog. +;; `setting-name' is used in the error message when the test fails. +(define (test-setting set-setting setting-name expression result) + (set-language #f) + (set-setting) + (let ([f (get-top-level-focus-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (let* ([drs (get-top-level-focus-window)] + [interactions (send drs get-interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output/should-be-tested drs)]) + (unless (string=? result got) + (printf "FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n" + (language) setting-name expression result got))))) + +(define (test-hash-bang) + (let* ([expression "#!/bin/sh\n1"] + [result "1"] + [drs (get-top-level-focus-window)] + [interactions (send drs get-interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output/should-be-tested drs)]) + (unless (string=? "1" got) + (printf "FAILED: ~s ~a test~n expected: ~s~n got: ~s~n" + (language) expression result got))))) + +(define (fetch-output/should-be-tested . args) + (regexp-replace (regexp + (string-append + (regexp-quote "\nThis program should be tested.") + "$")) + (apply fetch-output args) + "")) + +(define (check-top-of-repl) + (let ([drs (wait-for-drscheme-frame)]) + (set-language #t) + (with-handlers ([exn:fail? void]) + (fw:test:menu-select "Testing" "Disable tests")) + (do-execute drs) + (let* ([interactions (send drs get-interactions-text)] + [short-lang (car (last-pair (language)))] + [get-line (lambda (n) (send interactions get-text + (send interactions paragraph-start-position n) + (send interactions paragraph-end-position n)))] + [line0-expect (format "Welcome to DrScheme, version ~a [3m]." (version:version))] + [line1-expect + (if (string? short-lang) + (format "Language: ~a" short-lang) + short-lang)] + [line0-got (get-line 0)] + [line1-got (get-line 1)]) + (unless (and (string=? line0-expect line0-got) + (if (string? short-lang) + (string=? line1-expect (substring line1-got + 0 + (min (string-length line1-expect) + (string-length line1-got)))) + (regexp-match line1-expect line1-got))) + (printf "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" + line0-expect line1-expect + line0-got line1-got) + (error 'language-test.ss "failed get top of repl test"))))) + + +;; teaching-language-fraction-output +;; tests that the teaching langauges properly handle repeating decimals +(define (teaching-language-fraction-output) + (test-setting + (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions")) + "Fraction Style -- Mixed fractions" + "4/3" + "{number 4/3 \"1 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-radio-box! "Fraction Style" "Repeating decimals")) + "Fraction Style -- Repeating decimals" + "4/3" + "{number 4/3 \"1.3\" decimal}")) + +;; plt-language-fraction-output : -> void +;; tests that the PLT languages properly handle repeating decimals +(define (plt-language-fraction-output) + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f)) + "Use decimal notation for rationals -- #f" + "4/3 1/2 -1/3" + "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) + "Use decimal notation for rationals -- #t" + "4/3 1/2 -1/3" + "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}")) + +(define (generic-settings false/true?) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #t)) + "Case sensitive -- #t" + "(eq? 'g 'G)" + (if false/true? "false" "#f")) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #f)) + "Case sensitive -- #f" + "(eq? 'g 'G)" + (if false/true? "true" "#t"))) + +(define (generic-output list? quasi-quote? has-sharing?) + (let* ([drs (wait-for-drscheme-frame)] + [expression (format "(define x (list 2))~n(list x x)")] + [set-output-choice + (lambda (option show-sharing pretty?) + (set-language #f) + (fw:test:set-radio-box! "Output Style" option) + (when (and has-sharing? show-sharing) (fw:test:set-check-box! - "Insert newlines in printed values" - pretty?) - (let ([f (get-top-level-focus-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)))] - [shorten - (lambda (str) - (if ((string-length str) . <= . 45) - str - (string-append (substring str 0 45) "...")))] - [test - ;; answer must either be a string, or a procedure that accepts both zero and 1 - ;; argument. When the procedure accepts 1 arg, the argument is `got' and - ;; the result must be a boolean indicating if the result was satisfactory. - ;; if the procedure receives no arguments, it must return a descriptive string - ;; for the error message - (lambda (option show-sharing pretty? answer) - (set-output-choice option show-sharing pretty?) - (do-execute drs) - (let ([got (fetch-output drs)]) - (unless (if (procedure? answer) - (answer got) - (whitespace-string=? answer got)) - (printf "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" - (language) option show-sharing pretty? - (shorten got) - (if (procedure? answer) (answer) answer)))))]) - - (clear-definitions drs) - (type-in-definitions drs expression) - - (test "write" 'off #t "((2) (2))") + "Show sharing in values" + (if (eq? show-sharing 'on) #t #f))) + (fw:test:set-check-box! + "Insert newlines in printed values" + pretty?) + (let ([f (get-top-level-focus-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)))] + [shorten + (lambda (str) + (if ((string-length str) . <= . 45) + str + (string-append (substring str 0 45) "...")))] + [test + ;; answer must either be a string, or a procedure that accepts both zero and 1 + ;; argument. When the procedure accepts 1 arg, the argument is `got' and + ;; the result must be a boolean indicating if the result was satisfactory. + ;; if the procedure receives no arguments, it must return a descriptive string + ;; for the error message + (lambda (option show-sharing pretty? answer) + (set-output-choice option show-sharing pretty?) + (do-execute drs) + (let ([got (fetch-output/should-be-tested drs)]) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (printf "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" + (language) option show-sharing pretty? + (shorten got) + (if (procedure? answer) (answer) answer)))))]) + + (clear-definitions drs) + (type-in-definitions drs expression) + + (test "write" 'off #t "((2) (2))") + (when has-sharing? + (test "write" 'on #t "(#0=(2) #0#)")) + (when quasi-quote? + (test "Quasiquote" 'off #t "`((2) (2))") (when has-sharing? - (test "write" 'on #t "(#0=(2) #0#)")) - (when quasi-quote? - (test "Quasiquote" 'off #t "`((2) (2))") - (when has-sharing? - (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) - - (test "Constructor" 'off #t + (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) + + (test "Constructor" 'off #t + (if list? + "(list (list 2) (list 2))" + "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) + (when has-sharing? + (test "Constructor" 'on #t (if list? - "(list (list 2) (list 2))" - "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) - (when has-sharing? - (test "Constructor" 'on #t - (if list? - "(shared ((-1- (list 2))) (list -1- -1-))" - "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) - - ;; setup write / pretty-print difference - (clear-definitions drs) - (for-each fw:test:keystroke - (string->list - "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)")) - (test "Constructor" #f #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test "Constructor" #f #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])) - (test "write" #f #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test "write" #f #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])))) + "(shared ((-1- (list 2))) (list -1- -1-))" + "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) + + ;; setup write / pretty-print difference + (clear-definitions drs) + (for-each fw:test:keystroke + (string->list + "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)")) + (test "Constructor" #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "Constructor" #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])) + (test "write" #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "write" #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])))) - (define re:out-of-sync - (regexp - "WARNING: Interactions window is out of sync with the definitions window\\.")) - - (define (test-error-after-definition) - (let* ([drs (wait-for-drscheme-frame)] - [interactions-text (send drs get-interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)") - (do-execute drs) - (let ([last-para (send interactions-text last-paragraph)]) - (type-in-interactions drs "y\n") - (wait-for-computation drs) - (let ([got - (fetch-output - drs - (send interactions-text paragraph-start-position (+ last-para 1)) - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))]) - (unless (equal? got "0") - (printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) +(define re:out-of-sync + (regexp + "WARNING: Interactions window is out of sync with the definitions window\\.")) - - ;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) - ;; (union string regexp (string -> boolean)) - ;; -> void - ;; types an expression in the definitions window, executes it and tests the output - ;; types an expression in the REPL and tests the output from the REPL. - (define test-expression - (case-lambda - [(expression expected) (test-expression expression expected expected)] - [(expression defs-expected repl-expected) - (let* ([drs (wait-for-drscheme-frame)] - [interactions-text (send drs get-interactions-text)] - [definitions-text (send drs get-definitions-text)] - [handle-insertion - (lambda (item) - (cond - [(eq? item 'image) - (use-get/put-dialog - (lambda () (fw:test:menu-select "Insert" "Insert Image...")) - (simplify-path (build-path (collection-path "icons") "recycle.png")))] - [(string? item) - (type-in-definitions drs item)] - [(eq? item 'xml) - (fw:test:menu-select "Insert" "Insert XML Box") - (for-each fw:test:keystroke (string->list ""))] - [else (error 'handle-insertion "unknown thing to insert ~s" item)]))] - [check-expectation - (lambda (expected got) - (cond - [(string? expected) - (whitespace-string=? expected got)] - [(regexp? expected) - (regexp-match expected got)] - [(procedure? expected) - (expected got)]))] - [make-err-msg - (lambda (expected) - (cond - [(string? expected) - "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead~n"] - [(regexp? expected) - "FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"] - [(procedure? expected) - "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))]) - (clear-definitions drs) - (cond - [(pair? expression) (for-each handle-insertion expression)] - [else (handle-insertion expression)]) - (do-execute drs) - +(define (test-error-after-definition) + (let* ([drs (wait-for-drscheme-frame)] + [interactions-text (send drs get-interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)") + (do-execute drs) + (let ([last-para (send interactions-text last-paragraph)]) + (type-in-interactions drs "y\n") + (wait-for-computation drs) + (let ([got + (fetch-output/should-be-tested + drs + (send interactions-text paragraph-start-position (+ last-para 1)) + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))]) + (unless (equal? got "0") + (printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) + + +;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) +;; (union string regexp (string -> boolean)) +;; -> void +;; types an expression in the definitions window, executes it and tests the output +;; types an expression in the REPL and tests the output from the REPL. +(define test-expression + (case-lambda + [(expression expected) (test-expression expression expected expected)] + [(expression defs-expected repl-expected) + (let* ([drs (wait-for-drscheme-frame)] + [interactions-text (send drs get-interactions-text)] + [definitions-text (send drs get-definitions-text)] + [handle-insertion + (lambda (item) + (cond + [(eq? item 'image) + (use-get/put-dialog + (lambda () (fw:test:menu-select "Insert" "Insert Image...")) + (simplify-path (build-path (collection-path "icons") "recycle.png")))] + [(string? item) + (type-in-definitions drs item)] + [(eq? item 'xml) + (fw:test:menu-select "Insert" "Insert XML Box") + (for-each fw:test:keystroke (string->list ""))] + [else (error 'handle-insertion "unknown thing to insert ~s" item)]))] + [check-expectation + (lambda (expected got) + (cond + [(string? expected) + (whitespace-string=? expected got)] + [(regexp? expected) + (regexp-match expected got)] + [(procedure? expected) + (expected got)]))] + [make-err-msg + (lambda (expected) + (cond + [(string? expected) + "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead~n"] + [(regexp? expected) + "FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"] + [(procedure? expected) + "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))]) + (clear-definitions drs) + (cond + [(pair? expression) (for-each handle-insertion expression)] + [else (handle-insertion expression)]) + (do-execute drs) + + (let ([got + (fetch-output + drs + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))]) + (when (regexp-match re:out-of-sync got) + (error 'text-expression "got out of sync message")) + (unless (check-expectation defs-expected got) + (printf (make-err-msg defs-expected) + 'definitions (language) expression defs-expected got))) + + (let ([s (make-semaphore 0)]) + (queue-callback + (λ () + (send definitions-text select-all) + (send definitions-text copy) + (send interactions-text set-position + (send interactions-text last-position) + (send interactions-text last-position)) + (send interactions-text paste) + (semaphore-post s))) + (semaphore-wait s)) + + (let ([last-para (send interactions-text last-paragraph)]) + (type-in-interactions drs (string #\newline)) + (wait-for-computation drs) (let ([got (fetch-output drs - (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-start-position (+ last-para 1)) (send interactions-text paragraph-end-position (- (send interactions-text last-paragraph) 1)))]) (when (regexp-match re:out-of-sync got) (error 'text-expression "got out of sync message")) - (unless (check-expectation defs-expected got) - (printf (make-err-msg defs-expected) - 'definitions (language) expression defs-expected got))) - - (let ([s (make-semaphore 0)]) - (queue-callback - (λ () - (send definitions-text select-all) - (send definitions-text copy) - (send interactions-text set-position - (send interactions-text last-position) - (send interactions-text last-position)) - (send interactions-text paste) - (semaphore-post s))) - (semaphore-wait s)) - - (let ([last-para (send interactions-text last-paragraph)]) - (type-in-interactions drs (string #\newline)) - (wait-for-computation drs) - (let ([got - (fetch-output - drs - (send interactions-text paragraph-start-position (+ last-para 1)) - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))]) - (when (regexp-match re:out-of-sync got) - (error 'text-expression "got out of sync message")) - (unless (check-expectation repl-expected got) - (printf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got)))))])) - - - (define-syntax (go stx) - (syntax-case stx () - [(_ arg) - (identifier? (syntax arg)) - (syntax (begin (printf ">> starting ~a\n" (syntax-object->datum #'arg)) - (arg) - (printf ">> finished ~a\n" (syntax-object->datum #'arg))))])) - - (define (run-test) - ;; (go mred) - (go r5rs) - (go pretty-big) - (go beginner) - (go beginner/abbrev) - (go intermediate) - (go intermediate/lambda) - (go advanced))) + (unless (check-expectation repl-expected got) + (printf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got)))))])) + + +(define-syntax (go stx) + (syntax-case stx () + [(_ arg) + (identifier? (syntax arg)) + (syntax (begin (printf ">> starting ~a\n" (syntax->datum #'arg)) + (arg) + (printf ">> finished ~a\n" (syntax->datum #'arg))))])) + +(define (run-test) + (go pretty-big) + (go r5rs) + (go beginner) + (go beginner/abbrev) + (go intermediate) + (go intermediate/lambda) + (go advanced) + ) \ No newline at end of file diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index b3e15e793d..c831ec3b25 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -45,7 +45,7 @@ (regexp "first>")) (make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))" "foldl" - ". reference to an identifier before its definition: foldl") + ". . reference to an identifier before its definition: foldl") (make-test "(module m mzscheme (require (prefix mz: mzscheme)))" "mz:+" #rx"procedure:+") @@ -72,7 +72,7 @@ `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) x)) "+" - ". reference to an identifier before its definition: +") + ". . reference to an identifier before its definition: +") (make-test (format "~s" '(module m mzscheme (provide lambda))) "(lambda (x) x)" @@ -83,14 +83,14 @@ "1") (make-test (format "~s" '(module m mzscheme (define-syntax s (syntax 1)) (provide s))) "s" - "s: illegal use of syntax in: s") + ". s: illegal use of syntax in: s") (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x)) "a" - ". reference to an identifier before its definition: a") + ". . reference to an identifier before its definition: a") (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x)) "a" - ". reference to an identifier before its definition: a") + ". . reference to an identifier before its definition: a") (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x (define a 77))) "a" "77") @@ -210,7 +210,7 @@ [(regexp? (test-result test)) (regexp-match (test-result test) after-int-output)])]) (unless passed? - (printf "FAILED: ~a\n ~a\n expected: ~a\n got: ~a\n" + (printf "FAILED: ~a\n ~a\n expected: ~s\n got: ~s\n" (test-definitions test) (or (test-interactions test) 'no-interactions) (test-result test) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 9de80e1b16..2a6417acfa 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -1,1216 +1,1476 @@ +#lang scheme -(module repl-test mzscheme - (require "drscheme-test-util.ss" - mzlib/class - mzlib/file - mzlib/string - mred - framework) - - (provide run-test) - - (define-struct loc (line col offset)) - ;; loc = (make-loc number number number) - ;; all numbers in loc structs start at zero. - - (define-struct test (program - ;; : (union - ;; string - ;; 'fraction-sum - ;; (listof - ;; (union string? // typed in - ;; 'left // left arrow key - ;; (list string? string?)))) // menu item select - - raw-execute-answer ;; answer when executing - raw-load-answer ;; answer when loading +;; NOTES: +;; - (expt 3 #f) is likely to never be optimized, making the stack traces produced from it predictable - error-message ;; (or/c string? false/c) - error-srcloc ;; (or/c string? false/c) - error-mode ;; (one-of/c 'read 'syntax 'runtime 'runtime-nested) - - source-location ;; : (union 'definitions - ;; 'interactions - ;; (cons loc loc)) - ;; if cons, the car and cdr are the start and end positions resp. - ;; if 'interactions, no source location and - ;; the focus must be in the interactions window - ;; if 'definitions, no source location and - ;; the focus must be in the definitions window - - breaking-test? ;; : boolean - - ;; setup is called before the test case is run. - setup ;; : -> void - ;; teardown is called after the test case is complete. - teardown ;; : -> void - )) - - (define (to-strings . args) - (apply string-append (map (λ (x) (format "~s\n" x)) args))) - - (define (add-load-handler-context str) - (regexp - (string-append (regexp-quote "{bug09.png} {file.gif} ../../mred/private/snipfile.ss:") - "[0-9]+:[0-9]+: " - (regexp-quote str)))) - - (define test-data - (list - - ;; basic tests - (make-test "1" - "1" - "1" - #f #f #f - 'interactions - #f - void - void) - - (make-test "\"a\"" - "\"a\"" - "\"a\"" - #f #f #f - 'interactions - #f - void - void) - - (make-test "1 2" - "1\n2" - "2" - #f #f #f - 'interactions - #f - void - void) - - (make-test "\"a\" \"b\"" - "\"a\"\n\"b\"" - "\"b\"" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(" - "" "" - "read: expected a `)'" - "1:0" - 'read - (cons (make-loc 0 0 0) (make-loc 0 1 1)) - #f - void - void) - - (make-test "." - "" "" - "read: illegal use of \".\"" - "1:0" - 'read - (cons (make-loc 0 0 0) (make-loc 0 1 1)) - #f - void - void) +#| - (make-test "(lambda ())" - "" "" - "lambda: bad syntax in: (lambda ())" - "1:0" - 'syntax - (cons (make-loc 0 0 0) (make-loc 0 11 11)) - #f - void - void) - - ;; make sure only a single syntax error occurs when in nested begin situation - (make-test "(begin (lambda ()) (lambda ()))" - "" "" - "lambda: bad syntax in: (lambda ())" - "1:7" - 'syntax - (cons (make-loc 0 7 7) (make-loc 0 18 18)) - #f - void - void) - - (make-test "xx" - "" "" - "reference to undefined identifier: xx" - "1:0" - 'runtime - (cons (make-loc 0 0 0) (make-loc 0 2 2)) - #f - void - void) - (make-test "(raise 1)" - "" "" - "uncaught exception: 1" - #f - 'runtime - 'interactions - #f - void - void) - (make-test "(raise #f)" - "" "" - "uncaught exception: #f" - #f - 'runtime - 'interactions - #f - void - void) - - (make-test "(values 1 2)" - "1\n2" - "1\n2" - #f #f #f - 'interactions - #f - void - void) - (make-test "(list 1 2)" - "(1 2)" - "(1 2)" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))" - "#(struct:s 1)" - "#(struct:s 1)" - #f #f #f - 'interactions - #f - void - void) - - ;; top-level semantics test - (make-test "(define (f) (+ 1 1)) (define + -) (f)" - "0" - "0" - #f #f #f - 'interactions - #f - void - void) +This produces an ACK message - (make-test "(begin (define-struct a ()) (define-struct (b a) ()))" - "" - "" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(begin (values) 1)" - "1" - "1" - #f #f #f - 'interactions - #f - void - void) +#lang scheme +(require scheme/sandbox) +(make-evaluator '(file "/tmp/foo.ss")) - (make-test "(begin xx (printf \"hi\\n\"))" - "" "" - "reference to undefined identifier: xx" - "1:7" - 'runtime - (cons (make-loc 0 7 7) (make-loc 0 9 9)) - #f - void - void) - - (make-test (string-append - "(module m mzscheme (provide e) (define e #'1))\n" - "(module n mzscheme (require-for-syntax 'm) (provide s) (define-syntax (s stx) e))\n" - "(require 'n)\n" - "s") - "" "" - "compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" - "1:43" - 'syntax - (cons (make-loc 0 43 43) (make-loc 0 44 44)) - #f - void - void) +|# - - ;; leading comment test - (make-test "#!/bin/sh\n1" - "1" - "1" - #f #f #f - 'interactions - #f - void - void) +(require "drscheme-test-util.ss" + mred + framework) - (make-test "#!/bin/sh\nxx" - "" "" - "reference to undefined identifier: xx" - "2:0" - 'runtime - (cons (make-loc 1 0 10) (make-loc 1 2 12)) - #f - void - void) +(provide run-test) - ;; eval tests +(define-struct loc (line col offset)) +;; loc = (make-loc number number number) +;; all numbers in loc structs start at zero. - (make-test " (eval '(values 1 2))" - "1\n2" - "1\n2" - #f #f #f - 'interactions - #f - void - void) +(define-struct test (program + ;; : (union + ;; string + ;; 'fraction-sum + ;; (listof + ;; (union string? // typed in + ;; 'left // left arrow key + ;; (list string? string?)))) // menu item select + + + answer ;; : answer + ;; the answers for the various modes of the test, specifically: + ;; with debugging enabled: execute, load with different filename, load with same filename + ;; as in ordinary mzscheme: execute, load with different filename, load with same filename + + source-location ;; (or/c 'interactions 'definitions (cons number number)) + + breaking-test? ;; : boolean + + ;; setup is called before the test case is run. + setup ;; : -> void + ;; teardown is called after the test case is complete. + teardown ;; : -> void + )) - (make-test " (eval '(list 1 2))" - "(1 2)" - "(1 2)" - #f #f #f - 'interactions - #f - void - void) - - (make-test " (eval '(lambda ()))" - "" "" - "lambda: bad syntax in: (lambda ())" - "1:4" - 'runtime - (cons (make-loc 0 4 4) (make-loc 0 23 23)) - #f - void - void) - (make-test " (eval 'x)" - "" "" - "reference to undefined identifier: x" - "1:4" - 'runtime - (cons (make-loc 0 4 4) (make-loc 0 13 13)) - #f - void - void) - - (make-test "(eval (box 1))" - "#&1" - "#&1" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(eval '(box 1))" - "#&1" - "#&1" - #f #f #f - 'interactions - #f - void - void) - - ; printer setup test - (make-test "(car (void))" - "" "" - "car: expects argument of type ; given #" - "1:0" - 'runtime - (cons (make-loc 0 0 0) (make-loc 0 12 12)) - #f - void - void) - - ;; error in the middle - (make-test "1 2 ( 3 4" - "1\n2\n" "" - "read: expected a `)'" - "1:4" - 'read - (cons (make-loc 0 4 4) (make-loc 0 5 5)) - #f - void - void) - (make-test "1 2 . 3 4" - "1\n2\n" "" - "read: illegal use of \".\"" - "1:4" - 'read - (cons (make-loc 0 4 4) (make-loc 0 5 5)) - #f - void - void) - (make-test "1 2 (lambda ()) 3 4" - "1\n2\n" "" - "lambda: bad syntax in: (lambda ())" - "1:4" - 'syntax - (cons (make-loc 0 4 4) (make-loc 0 15 15)) - #f - void - void) - (make-test "1 2 x 3 4" - "1\n2\n" "" - "reference to undefined identifier: x" - "1:4" - 'runtime - (cons (make-loc 0 4 4) (make-loc 0 5 5)) - #f - void - void) - (make-test "1 2 (raise 1) 3 4" - "1\n2\n" "" - "uncaught exception: 1" - #f - 'runtime - 'interactions - #f - void - void) - (make-test "1 2 (raise #f) 3 4" - "1\n2\n" "" - "uncaught exception: #f" - #f - 'runtime - 'interactions - #f - void - void) +(define-struct answer (debug-execute debug-load-fn debug-load raw-execute raw-load-fn raw-load)) - ;; error across separate files - (make-test - "(load \"repl-test-tmp2.ss\") (define (g) (+ 1 (car 1))) (f g)" - "" "" - "car: expects argument of type ; given 1" - "1:44" - 'runtime-nested - (cons (make-loc -1 -1 44) - (make-loc -1 -1 51)) - #f - (λ () - (call-with-output-file (build-path tmp-load-directory "repl-test-tmp2.ss") - (lambda (port) - (write '(define (f t) (+ 1 (t))) - port)) - 'truncate)) - (λ () (delete-file (build-path tmp-load-directory "repl-test-tmp2.ss")))) - - ;; new namespace test - (make-test "(current-namespace (make-namespace))\nif" - "" "" - "if: bad syntax in: if" - "2:0" - 'syntax - (cons (make-loc 1 0 37) (make-loc 1 2 39)) - #f - void - void) - - (make-test "(current-namespace (make-namespace 'empty))\nif" - "" "" - "compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" - "2:0" - 'syntax - (cons (make-loc 1 0 44) (make-loc 1 0 46)) - #f - void - void) - - ;; macro tests - (make-test "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))" - "" - "" - #f #f #f - 'interactions - #f - void - void) - - ;; error escape handler test - (make-test - "(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (car))\n(lambda () (error-escape-handler old))))\n10))" - "" "" - "car: expects 1 argument, given 0\n15" - "5:19" - 'runtime - 'definitions - #f - void - void) +(define-syntax (mktest stx) + (syntax-case stx () + [(_ program (a b c d e f) di breaking-test?) + #'(make-test program (make-answer a b c d e f) di breaking-test? void void)] + [(_ program (a b c d e f) di breaking-test? setup teardown) + #'(make-test program (make-answer a b c d e f) di breaking-test? setup teardown)])) - ; fraction snip test - ;; this test depends on the state of the 'framework:fraction-snip-style preference - ;; make sure this preference is set to the default when running this test. - (make-test 'fraction-sum - #rx"{number 5/6 \"5/6\" (improper|mixed)}" - #rx"{number 5/6 \"5/6\" (improper|mixed)}" - #f #f #f - 'interactions - #f - void - void) - - ;; should produce a syntax object with a turn-down triangle. - (make-test "(write (list (syntax x)))" - "({embedded \".#\"})" - "({embedded \".#\"})" - #f #f #f - 'interactions - #f - void - void) - - ;; make sure syntax objects only go into good ports - (make-test "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)" - "10" - "10" - #f #f #f - 'interactions - #f - void - void) - - ;; make sure syntax objects don't go into bad ports - (make-test "(parameterize ([current-output-port (open-output-string)]) (write #'1))" - "" - "" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" - "#" - "#" - #f #f #f - 'interactions - #f - void - void) - - (make-test "(write-special 1)" - "1#t" - "1#t" - #f #f #f - 'interactions - #f - void - void) - - (make-test - ;; the begin/void combo is to make sure that no value printout - ;; comes and messes up the source location for the error. - "(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (car))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))" - "" "" - "car: expects 1 argument, given 0" - "6:15" - 'runtime - (cons (make-loc 0 99 99) (make-loc 0 104 104)) - #f - void - void) +(define syntax-regexp-prefix + (string-append + (regexp-quote "#" - "#" - #f #f #f - 'interactions - #f - void - void) - (make-test (to-strings - '(let ([on (current-namespace)] - [n ((current-module-name-resolver) 'mred #f #f)]) - (current-namespace (make-namespace)) - (namespace-attach-module on n)) - '(require texpict/utils) - '(disk 3)) - "{image}" - "{image}" - #f #f #f - 'interactions - #f - void - void) - - (make-test (string-append - "(require (lib \"pretty.ss\"))" - "(pretty-print-print-hook (lambda x (car)))" - "(list 1 2 3)") - "(1 2 3)" - "(1 2 3)" - #f #f #f - 'interactions - #f - void - void) - - (make-test - (string-append - "(define p (open-output-string))\n" - "(parameterize ([current-error-port p])\n" - "(dynamic-wind\n" - "void\n" - "(lambda ()\n" - "((error-display-handler)\n" - "\"x\"\n" - "(with-handlers ((void values)) (eval '(lambda ())))))\n" - "(lambda ()\n" - "(display (get-output-string p)))))\n") - "x in: (lambda ())" - "x in: (lambda ())" - #f #f #f - 'interactions - #f - void - void) - )) - ;; these tests aren't used at the moment. - #; - (define xml-tests - (list - ;; XML tests - (make-test (list "#!/bin/sh\n" - '("Insert" "Insert XML Box") - "") - "(a ())" - "(a ())" - #f #f #f - 'interactions - #f - void - void) - - (make-test - '(("Insert" "Insert XML Box") - "") - "(a ())" - "(a ())" - #f - 'interactions - #f - #f - void - void) - - (make-test - '(("Insert" "Insert XML Box") - "" - ("Insert" "Insert Scheme Box") - "1") - "(a () 1)" - "(a () 1)" - #f - 'interactions - #f - #f - void - void) - - (make-test - '(("Insert" "Insert XML Box") - "" - ("Insert" "Insert Scheme Splice Box") - "'(1)") - "(a () 1)" - "(a () 1)" - #f - 'interactions - #f - #f - void - void) - - (make-test - '(("Insert" "Insert XML Box") - "" - ("Insert" "Insert Scheme Splice Box") - "1") - "scheme-splice-box: expected a list, found: 1" - "scheme-splice-box: expected a list, found: 1" - #t - 'definitions - #f - #f - void - void))) - - (define backtrace-image-string "{bug09.png}") - (define file-image-string "{file.gif}") - - (define tmp-load-directory - (normal-case-path - (normalize-path - (collection-path "tests" "drscheme")))) - - (define (run-test) +(define test-data + (list + + ;; basic tests + (mktest "1" + ("1" + "1" + "1" + "1" + "1" + "1") + 'interactions + #f + void + void) + + (mktest "\"a\"" + + ("\"a\"" + "\"a\"" + "\"a\"" + "\"a\"" + "\"a\"" + "\"a\"") + 'interactions + #f + void + void) + + (mktest "1 2" + + ("1\n2" + "2" + "2" + "1\n2" + "2" + "2") + 'interactions + #f + void + void) + + (mktest "\"a\" \"b\"" + + ("\"a\"\n\"b\"" + "\"b\"" + "\"b\"" + "\"a\"\n\"b\"" + "\"b\"" + "\"b\"") + 'interactions + #f + void + void) + + (mktest "(" + ("{stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'" + "{stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'") + 'definitions + #f + void + void) + + (mktest "." + + ("{stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: illegal use of \".\"" + "{stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: illegal use of \".\"") + 'definitions + #f + void + void) + + (mktest "(lambda ())" + + ("{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.ss:1:0: lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: lambda: bad syntax in: (lambda ())") + 'definitions + #f + void + void) + + ;; make sure only a single syntax error occurs when in nested begin situation + (mktest "(begin (lambda ()) (lambda ()))" + + ("{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.ss:1:7: lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: lambda: bad syntax in: (lambda ())") + 'definitions + #f + void + void) + + (mktest "xx" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" + "reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") + 'definitions + #f + void + void) + (mktest "(raise 1)" + + ("uncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1") + 'interactions + #f + void + void) + (mktest "(raise #f)" + + ("uncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f") + 'interactions + #f + void + void) + + (mktest "(values 1 2)" + + ("1\n2" + "1\n2" + "1\n2" + "1\n2" + "1\n2" + "1\n2") + 'interactions + #f + void + void) + (mktest "(list 1 2)" + + ("(1 2)" + "(1 2)" + "(1 2)" + "(1 2)" + "(1 2)" + "(1 2)") + 'interactions + #f + void + void) + + (mktest "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))" + + ("#(struct:s 1)" + "#(struct:s 1)" + "#(struct:s 1)" + "#(struct:s 1)" + "#(struct:s 1)" + "#(struct:s 1)") + 'interactions + #f + void + void) + + ;; top-level semantics test + (mktest "(define (f) (+ 1 1)) (define + -) (f)" + + ("define-values: cannot change constant identifier: +" + "define-values: cannot change constant identifier: +" + "define-values: cannot change constant identifier: +" + "define-values: cannot change constant identifier: +" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: define-values: cannot change constant identifier: +" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: define-values: cannot change constant identifier: +") + 'interactions + #f + void + void) + + (mktest "(begin (define-struct a ()) (define-struct (b a) ()))" + + ("" + "" + "" + "" + "" + "") + 'interactions + #f + void + void) + + (mktest "(begin (values) 1)" + + ("1" + "1" + "1" + "1" + "1" + "1") + 'interactions + #f + void + void) + + (mktest "(begin xx (printf \"hi\\n\"))" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: reference to undefined identifier: xx" + "reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") + 'definitions + #f + void + void) + + (mktest (string-append + "(module m mzscheme (provide e) (define e #'1))\n" + "(module n mzscheme (require-for-syntax 'm) (provide s) (define-syntax (s stx) e))\n" + "(require 'n)\n" + "s") + + ("{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" + "{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" + "{stop-22x22.png} repl-test-tmp3.ss:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" + "{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" + "{stop-multi.png} {stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1") + 'definitions + #f + void + void) + + + ;; leading comment test + (mktest "#!/bin/sh\n1" + + ("1" + "1" + "1" + "1" + "1" + "1") + 'interactions + #f + void + void) + + (mktest "#!/bin/sh\nxx" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: reference to undefined identifier: xx" + "reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") + 'definitions + #f + void + void) + + ;; eval tests + + (mktest " (eval '(values 1 2))" + + ("1\n2" + "1\n2" + "1\n2" + "1\n2" + "1\n2" + "1\n2") + 'interactions + #f + void + void) + + (mktest " (eval '(list 1 2))" + + ("(1 2)" + "(1 2)" + "(1 2)" + "(1 2)" + "(1 2)" + "(1 2)") + 'interactions + #f + void + void) + + (mktest " (eval '(lambda ()))" + + ("{stop-multi.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())" + "{stop-multi.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} lambda: bad syntax in: (lambda ())") + 'interactions + #f + void + void) + + (mktest " (read (open-input-string \".\"))" + + ("{stop-multi.png} read: illegal use of \".\"" + "{stop-multi.png} read: illegal use of \".\"" + "{stop-multi.png} read: illegal use of \".\"" + "read: illegal use of \".\"" + "{stop-multi.png} read: illegal use of \".\"" + "{stop-multi.png} read: illegal use of \".\"") + 'interactions + #f + void + void) + + (mktest " (eval 'x)" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" + "reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x") + 'definitions + #f + void + void) + + (mktest "(eval (box 1))" + + ("#&1" + "#&1" + "#&1" + "#&1" + "#&1" + "#&1") + 'interactions + #f + void + void) + + (mktest "(eval '(box 1))" + + ("#&1" + "#&1" + "#&1" + "#&1" + "#&1" + "#&1") + 'interactions + #f + void + void) + + ; printer setup test + (mktest "(expt 3 (void))" + + ("{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type ; given #" + "expt: expected argument of type ; given #" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #") + 'definitions + #f + void + void) + + ;; error in the middle + (mktest "1 2 ( 3 4" + + ("1\n2\n{stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'" + "1\n2\n{stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} read: expected a `)'" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'") + 'definitions + #f + void + void) + (mktest "1 2 . 3 4" + + ("1\n2\n{stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: illegal use of \".\"" + "1\n2\n{stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} read: illegal use of \".\"" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: illegal use of \".\"") + 'definitions + #f + void + void) + (mktest "1 2 (lambda ()) 3 4" + + ("1\n2\n{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.ss:1:4: lambda: bad syntax in: (lambda ())" + "1\n2\n{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: lambda: bad syntax in: (lambda ())") + 'definitions + #f + void + void) + (mktest "1 2 x 3 4" + + ("1\n2\n{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" + "1\n2\nreference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x") + 'definitions + #f + void + void) + (mktest "1 2 (raise 1) 3 4" + + ("1\n2\nuncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1" + "1\n2\nuncaught exception: 1" + "uncaught exception: 1" + "uncaught exception: 1") + 'interactions + #f + void + void) + (mktest "1 2 (raise #f) 3 4" + + ("1\n2\nuncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f" + "1\n2\nuncaught exception: #f" + "uncaught exception: #f" + "uncaught exception: #f") + 'interactions + #f + void + void) + + (mktest "(require lang/htdp-beginner)\n(cond [1 2 3 4])" + + ("{stop-22x22.png} cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4" + "{stop-22x22.png} cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4" + "{stop-22x22.png} repl-test-tmp3.ss:2:7: cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4" + "{stop-multi.png} {stop-22x22.png} cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4" + "{stop-multi.png} {stop-22x22.png} cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:7: cond: expected a clause with one question and one answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4") + 'definitions + #f + void + void) + + ;; error across separate files + (mktest + "(load \"repl-test-tmp2.ss\") (define (g) (+ 1 (expt 3 #f))) (f g)" - (define drscheme-frame (wait-for-drscheme-frame)) + ("{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:44: expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:27: expt: expected argument of type ; given #f") + 'definitions + #f + (λ () + (call-with-output-file (build-path tmp-load-directory "repl-test-tmp2.ss") + (lambda (port) + (write '(define (f t) (+ 1 (t))) + port)) + #:exists 'truncate)) + (λ () (delete-file (build-path tmp-load-directory "repl-test-tmp2.ss")))) + + ;; new namespace test + (mktest "(current-namespace (make-namespace))\nif" + + ("{stop-22x22.png} if: bad syntax in: if" + "{stop-22x22.png} if: bad syntax in: if" + "{stop-22x22.png} repl-test-tmp3.ss:2:0: if: bad syntax in: if" + "{stop-22x22.png} if: bad syntax in: if" + "{stop-multi.png} {stop-22x22.png} if: bad syntax in: if" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: if: bad syntax in: if") + 'definitions + #f + void + void) + + (mktest "(current-namespace (make-namespace 'empty))\nif" + + ("{stop-22x22.png} compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" + "{stop-22x22.png} compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" + "{stop-22x22.png} repl-test-tmp3.ss:2:0: compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" + "{stop-22x22.png} compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" + "{stop-multi.png} {stop-22x22.png} compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (#%top-interaction . if)") + 'definitions + #f + void + void) + + ;; macro tests + (mktest "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))" + + ("" + "" + "" + "" + "" + "") + 'interactions + #f + void + void) + + ;; error escape handler test + (mktest + "(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (expt 3 #f))\n(lambda () (error-escape-handler old))))\n10))" - (define interactions-text (send drscheme-frame get-interactions-text)) - (define interactions-canvas (send drscheme-frame get-interactions-canvas)) - (define definitions-text (send drscheme-frame get-definitions-text)) - (define definitions-canvas (send drscheme-frame get-definitions-canvas)) - (define execute-button (send drscheme-frame get-execute-button)) + ("{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f\n15" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f\n15" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type ; given #f\n15" + "expt: expected argument of type ; given #f\n15" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f\n15" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f\n15") + 'definitions + #f + void + void) + + ; fraction snip test + ;; this test depends on the state of the 'framework:fraction-snip-style preference + ;; make sure this preference is set to the default when running this test. + (mktest 'fraction-sum + ("{number 5/6 \"5/6\" mixed}" + "{number 5/6 \"5/6\" mixed}" + "{number 5/6 \"5/6\" mixed}" + "{number 5/6 \"5/6\" mixed}" + "{number 5/6 \"5/6\" mixed}" + "{number 5/6 \"5/6\" mixed}") + 'interactions + #f + void + void) + + ;; should produce a syntax object with a turn-down triangle. + (let ([printout + (regexp + (string-append (regexp-quote "({embedded \".") + syntax-regexp-prefix + (regexp-quote ":1:21>\"})")))]) + (mktest "(write (list (syntax x)))" + + ("({embedded \".#\"})" + "({embedded \".#\"})" + "({embedded \".#\"})" + "({embedded \".#\"})" + "({embedded \".#\"})" + "({embedded \".#\"})") + 'interactions + #f + void + void)) + + ;; make sure syntax objects only go into good ports + (mktest "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)" + + ("10" + "10" + "10" + "10" + "10" + "10") + 'interactions + #f + void + void) + + ;; make sure syntax objects don't go into bad ports + (mktest "(parameterize ([current-output-port (open-output-string)]) (write #'1))" + + ("" + "" + "" + "" + "" + "") + 'interactions + #f + void + void) + + (mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" + + ("#" + "#" + "#" + "#" + "#" + "#") + 'interactions + #f + void + void) + + + (mktest "(write-special 1)" + + ("1#t" + "1#t" + "1#t" + "1#t" + "1#t" + "1#t") + 'interactions + #f + void + void) + + (mktest + ;; the begin/void combo is to make sure that no value printout + ;; comes and messes up the source location for the error. + "(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (expt 3 #f))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))" - (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))))) + ("{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type ; given #f" + "expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f") + 'definitions + #f + void + void) + + + ;; breaking tests + (mktest "(semaphore-wait (make-semaphore 0))" + ("{stop-multi.png} {stop-22x22.png} user break" + #rx"user break" + #rx"user break" + #rx"user break" + #rx"user break" + #rx"user break") + 'definitions + #t + void + void) + + (mktest "(let l()(l))" + (#rx"{stop-multi.png} {stop-22x22.png} user break" + #rx"user break" + #rx"user break" + #rx"user break" + #rx"user break" + #rx"user break") + 'definitions + #t + void + void) + + ;; continuation tests + (mktest "(define k (call/cc (lambda (x) x)))\n(k 17)\nk" + + ("17" + "17" + "17" + "17" + "17" + "17") + 'interactions + #f + void + void) + (mktest "(define v (vector (call/cc (lambda (x) x))))\n((vector-ref v 0) 2)\nv" + + ("#(2)" + "#(2)" + "#(2)" + "#(2)" + "#(2)" + "#(2)") + 'interactions + #f + void + void) + (mktest "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv" + + ("#(2)" + "#(2)" + "#(2)" + "#(2)" + "#(2)" + "#(2)") + 'interactions + #f + void + void) + + (mktest "(define x 1)\n((λ (x y) y) (set! x (call/cc (lambda (x) x)))\n(x 3))" + + ("{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" + "{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3" + "procedure application: expected procedure, given: 3; arguments were: 3" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3") + 'definitions + #f + void + void) + + ;; top-level & continuation interaction test + (mktest "(begin (define k (call/cc (λ (x) x)))\n(define x 'wrong))\n(set! x 'right)\n(k 1)\nx" + + ("right" + "right" + "right" + "right" + "right" + "right") + 'interactions + #f + void + void) + + (mktest (format "~s" + '(call-with-continuation-prompt + (lambda () + (eval '(begin (abort-current-continuation + (default-continuation-prompt-tag) + 1 2 3) + 10))) + (default-continuation-prompt-tag) + list)) + + ("(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)") + 'interactions + #f + void + void) + + ;; graphical lambda tests + (mktest (list "((" '("Insert" "Insert λ") "(x) x) 1)") + + ("1" + "1" + "1" + "1" + "1" + "1") + 'interactions + #f + void + void) + + (mktest (list "(" '("Insert" "Insert λ") "())") + + ("{stop-22x22.png} λ: bad syntax in: (λ ())" + "{stop-22x22.png} λ: bad syntax in: (λ ())" + "{stop-22x22.png} repl-test-tmp3.ss:1:0: λ: bad syntax in: (λ ())" + "{stop-22x22.png} λ: bad syntax in: (λ ())" + "{stop-multi.png} {stop-22x22.png} λ: bad syntax in: (λ ())" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: λ: bad syntax in: (λ ())") + 'definitions + #f + void + void) + + ;; thread tests + (mktest "(begin (thread (lambda () x)) (sleep 1/10))" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:26: reference to undefined identifier: x" + "reference to undefined identifier: x" + "reference to undefined identifier: x" + "reference to undefined identifier: x") + 'definitions + #f + void + void) + + ;; brought down from above for comparison + (mktest "xx" + + ("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" + "reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" + "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") + 'definitions + #f + void + void) + + ;; setup of the namespaces for pict printing (from slideshow) + + (mktest "(require (lib \"utils.ss\" \"texpict\"))(disk 3)" + + ("{image}" + "{image}" + "{image}" + "{image}" + "{image}" + "{image}") + 'interactions + #f + void + void) + + (mktest (to-strings + '(require texpict/utils) + '(let () + (current-namespace (make-namespace)) + (namespace-set-variable-value! 'd (disk 3))) + 'd) + + ("#" + "#" + "#" + "#" + "#" + "#") + 'interactions + #f + void + void) + (mktest (to-strings + '(let ([on (current-namespace)] + [n ((current-module-name-resolver) 'mred #f #f)]) + (current-namespace (make-namespace)) + (namespace-attach-module on n)) + '(require texpict/utils) + '(disk 3)) + + ("{image}" + "{image}" + "{image}" + "{image}" + "{image}" + "{image}") + 'interactions + #f + void + void) + + (mktest (string-append + "(require (lib \"pretty.ss\"))" + "(pretty-print-print-hook (lambda x (expt 3 #f)))" + "(list 1 2 3)") + + ("(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)" + "(1 2 3)") + 'interactions + #f + void + void) + + (mktest + (string-append + "(define p (open-output-string))\n" + "(parameterize ([current-error-port p])\n" + "(dynamic-wind\n" + "void\n" + "(lambda ()\n" + "((error-display-handler)\n" + "\"x\"\n" + "(with-handlers ((void values)) (eval '(lambda ())))))\n" + "(lambda ()\n" + "(display (get-output-string p)))))\n") - (define wait-for-execute (lambda () (wait-for-button execute-button))) - (define get-int-pos (lambda () (get-text-pos interactions-text))) - - (define tmp-load-short-filename "repl-test-tmp.ss") - (define tmp-load-filename (build-path tmp-load-directory tmp-load-short-filename)) - - (define tmp-load3-short-filename "repl-test-tmp3.ss") - (define tmp-load3-filename (build-path tmp-load-directory tmp-load3-short-filename)) + ("x in: (lambda ())" + "x in: (lambda ())" + "x in: (lambda ())" + "x in: (lambda ())" + "x in: (lambda ())" + "x in: (lambda ())") + 'interactions + #f + void + void) + + )) +;; these tests aren't used at the moment. +#; +(define xml-tests + (list + ;; XML tests + (mktest (list "#!/bin/sh\n" + '("Insert" "Insert XML Box") + "") + "(a ())" + "(a ())" + #f #f #f + 'interactions + #f + void + void) + + (mktest + '(("Insert" "Insert XML Box") + "") + "(a ())" + "(a ())" + #f + 'interactions + #f + #f + void + void) + + (mktest + '(("Insert" "Insert XML Box") + "" + ("Insert" "Insert Scheme Box") + "1") + "(a () 1)" + "(a () 1)" + #f + 'interactions + #f + #f + void + void) + + (mktest + '(("Insert" "Insert XML Box") + "" + ("Insert" "Insert Scheme Splice Box") + "'(1)") + "(a () 1)" + "(a () 1)" + #f + 'interactions + #f + #f + void + void) + + (mktest + '(("Insert" "Insert XML Box") + "" + ("Insert" "Insert Scheme Splice Box") + "1") + "scheme-splice-box: expected a list, found: 1" + "scheme-splice-box: expected a list, found: 1" + #t + 'definitions + #f + #f + void + void))) - (define short-tmp-load-filename - (let-values ([(base name dir?) (split-path tmp-load-filename)]) - (path->string name))) - - ;; setup-fraction-sum-interactions : -> void - ;; clears the definitions window, and executes `1/2' to - ;; get a fraction snip in the interactions window. - ;; Then, copies that and uses it to construct the sum - ;; of the 1/2 image and 1/3. - (define (setup-fraction-sum-interactions) +(define backtrace-image-string "{stop-multi.png}") +(define file-image-string "{stop-22x22.png}") + +(define tmp-load-directory + (normal-case-path + (normalize-path + (collection-path "tests" "drscheme")))) + +(define (run-test) + + (define drscheme-frame (wait-for-drscheme-frame)) + + (define interactions-text (send drscheme-frame get-interactions-text)) + (define interactions-canvas (send drscheme-frame get-interactions-canvas)) + (define definitions-text (send drscheme-frame get-definitions-text)) + (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))) + + (define tmp-load-short-filename "repl-test-tmp.ss") + (define tmp-load-filename (build-path tmp-load-directory tmp-load-short-filename)) + + (define tmp-load3-short-filename "repl-test-tmp3.ss") + (define tmp-load3-filename (build-path tmp-load-directory tmp-load3-short-filename)) + + (define short-tmp-load-filename + (let-values ([(base name dir?) (split-path tmp-load-filename)]) + (path->string name))) + + ;; setup-fraction-sum-interactions : -> void + ;; clears the definitions window, and executes `1/2' to + ;; get a fraction snip in the interactions window. + ;; Then, copies that and uses it to construct the sum + ;; of the 1/2 image and 1/3. + (define (setup-fraction-sum-interactions) + (clear-definitions drscheme-frame) + (type-in-definitions drscheme-frame "1/2") + (do-execute drscheme-frame) + (let ([s (make-semaphore 0)]) + (queue-callback + (lambda () + (let* ([start (send interactions-text paragraph-start-position 2)] + ;; since the fraction is supposed to be one char wide, we just + ;; select one char, so that, if the regular number prints out, + ;; this test will fail. + [end (+ start 1)]) + (send interactions-text set-position start end) + (semaphore-post s)))) + (semaphore-wait s)) + (test:menu-select "Edit" "Copy") + (clear-definitions drscheme-frame) + (type-in-definitions drscheme-frame "(+ ") + (test:menu-select "Edit" "Paste") + (type-in-definitions drscheme-frame " 1/3)")) + + ; given a filename "foo", we perform two operations on the contents + ; 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) + ;(printf "\n>> testing ~s\n" (test-program in-vector)) + (let* ([program (test-program in-vector)] + [execute-answer (make-execute-answer in-vector raw?)] + [source-location (test-source-location in-vector)] + [setup (test-setup in-vector)] + [teardown (test-teardown in-vector)] + [start-line (and (pair? source-location) + (number->string (+ 1 (loc-line (car source-location)))))] + [start-col (and (pair? source-location) + (number->string (loc-col (car source-location))))] + [start-pos (and (pair? source-location) + (number->string (+ 1 (loc-offset (car source-location)))))] + [breaking-test? (test-breaking-test? in-vector)]) + + (setup) + (clear-definitions drscheme-frame) - (type-in-definitions drscheme-frame "1/2") - (do-execute drscheme-frame) - (let ([s (make-semaphore 0)]) - (queue-callback - (lambda () - (let* ([start (send interactions-text paragraph-start-position 2)] - ;; since the fraction is supposed to be one char wide, we just - ;; select one char, so that, if the regular number prints out, - ;; this test will fail. - [end (+ start 1)]) - (send interactions-text set-position start end) - (semaphore-post s)))) - (semaphore-wait s)) - (test:menu-select "Edit" "Copy") - (clear-definitions drscheme-frame) - (type-in-definitions drscheme-frame "(+ ") - (test:menu-select "Edit" "Paste") - (type-in-definitions drscheme-frame " 1/3)")) - - (define (string/rx-append a b) - (if (regexp? b) - (regexp (string-append (regexp-quote a) (object-name b))) - (string-append a b))) - - ; given a filename "foo", we perform two operations on the contents - ; 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) - ;(printf "\n>> testing ~s\n" (test-program in-vector)) - (let* ([program (test-program in-vector)] - [execute-answer (let ([base (test-raw-execute-answer in-vector)]) - (cond - [(not (test-error-mode in-vector)) base] - [else - (string/rx-append - base - (let ([base (test-error-message in-vector)]) - (cond - [(not (test-error-srcloc in-vector)) base] - [raw? (if (eq? 'read (test-error-mode in-vector)) - (string-append backtrace-image-string " " base) - base)] - [(eq? 'syntax (test-error-mode in-vector)) base] - [(eq? 'read (test-error-mode in-vector)) base] - [else (string-append backtrace-image-string " " base)])))]))] - [make-load-answer - (lambda (src-file) - (let ([base (test-raw-load-answer in-vector)]) - (cond - [(not (test-error-mode in-vector)) base] - [else - (string/rx-append - base - (let ([base (test-error-message in-vector)] - [add-src (lambda (s) - (if src-file - (string-append file-image-string " " - src-file ":" - (test-error-srcloc in-vector) ": " - s) - s))]) - (cond - [(not (test-error-srcloc in-vector)) base] - [raw? (if (eq? 'runtime (test-error-mode in-vector)) - (add-load-handler-context base) - (string-append backtrace-image-string " " (add-src base)))] - [else (if (eq? 'syntax (test-error-mode in-vector)) - (add-src base) - (string-append backtrace-image-string " " (add-src base)))])))])))] - [source-location (test-source-location in-vector)] - [setup (test-setup in-vector)] - [teardown (test-teardown in-vector)] - [start-line (and (pair? source-location) - (number->string (+ 1 (loc-line (car source-location)))))] - [start-col (and (pair? source-location) - (number->string (loc-col (car source-location))))] - [start-pos (and (pair? source-location) - (number->string (+ 1 (loc-offset (car source-location)))))] - [breaking-test? (test-breaking-test? in-vector)]) - - (setup) - - (clear-definitions drscheme-frame) - ; load contents of test-file into the REPL, recording - ; the start and end positions of the text - - (cond - [(string? program) - (insert-string program)] - [(eq? program 'fraction-sum) - (setup-fraction-sum-interactions)] - [(list? program) - (for-each - (lambda (item) - (cond - [(string? item) (insert-string item)] - [(eq? item 'left) - (send definitions-text - set-position - (- (send definitions-text get-start-position) 1) - (- (send definitions-text get-start-position) 1))] - [(pair? item) (apply test:menu-select item)])) - program)]) - - (do-execute drscheme-frame #f) - (when breaking-test? - (test:run-one (lambda () (send (send drscheme-frame get-break-button) command)))) - (wait-for-execute) - - (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline - [received-execute - (fetch-output drscheme-frame execute-text-start execute-text-end)]) - - ; check focus and selection for execute test - (unless raw? + ; load contents of test-file into the REPL, recording + ; the start and end positions of the text + + (cond + [(string? program) + (insert-string program)] + [(eq? program 'fraction-sum) + (setup-fraction-sum-interactions)] + [(list? program) + (for-each + (lambda (item) (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) - (unless (cond - [(string? execute-answer) - (string=? execute-answer received-execute)] - [(regexp? execute-answer) - (regexp-match execute-answer received-execute)] - [else #f]) - (failure) - (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" - program - raw? - execute-answer received-execute)) - - (test:new-window interactions-canvas) - - ; save the file so that load is in sync - (test:menu-select "File" "Save Definitions") - - ; make sure that a prompt is available at end of the REPL - (unless (and (char=? #\> - (send interactions-text get-character - (- (send interactions-text last-position) 2))) - (char=? #\space - (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!) - ;; the definitions and click execute with the empty buffer - (test:new-window definitions-canvas) - (test:menu-select "Edit" "Select All") - (test:menu-select "Edit" "Delete") - (do-execute drscheme-frame #f) - (wait-for-execute) - - ;; stuff the load command into the REPL - (for-each test:keystroke - (string->list (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))]) - - (test:keystroke #\return) - - (when breaking-test? - (test:run-one (lambda () (send (send drscheme-frame get-break-button) command)))) - (wait-for-execute) - - (let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline - [received-load - (fetch-output drscheme-frame load-text-start load-text-end)]) - - ;; check load text - (next-test) - (unless (cond - [(string? load-answer) - (string=? load-answer received-load)] - [(regexp? load-answer) - (regexp-match load-answer received-load)] - [else #f]) - (failure) - (printf "FAILED load test for ~s\n expected: ~s\n got: ~s\n" - program load-answer received-load)))))]) - (load-test tmp-load-short-filename - (make-load-answer #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 tmp-load3-short-filename))) - - - (teardown) - - ; check for edit-sequence - (when (repl-in-edit-sequence?) - (printf "FAILED: repl in edit-sequence") - (escape))))) - - (define tests 0) - (define failures 0) - (define (next-test) (set! tests (+ tests 1))) - (define (failure) (set! failures (+ failures 1))) - (define (reset) (set! tests 0) (set! failures 0)) - (define (final-report) - (if (= 0 failures) - (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?) - (let ([level (list "Pretty Big (includes MrEd and Advanced Student)")]) - (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)) - - (random-seed-test) - - (test:new-window definitions-canvas) - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (let/ec escape - (for-each (run-single-test (get-int-pos) escape raw?) test-data)))) - - (define (kill-tests) - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) + [(string? item) (insert-string item)] + [(eq? item 'left) + (send definitions-text + set-position + (- (send definitions-text get-start-position) 1) + (- (send definitions-text get-start-position) 1))] + [(pair? item) (apply test:menu-select item)])) + program)]) - (test:menu-select "Scheme" "Kill") - - (let ([win (wait-for-new-frame drscheme-frame)]) - (test:button-push "OK") - (let ([drs2 (wait-for-new-frame win)]) - (unless (eq? drs2 drscheme-frame) - (error 'kill-test1 "expected original drscheme frame to come back to the front")))) - - (type-in-definitions drscheme-frame "(kill-thread (current-thread))") (do-execute drscheme-frame #f) - (let ([win (wait-for-new-frame drscheme-frame)]) - (test:button-push "OK") - (let ([drs2 (wait-for-new-frame win)]) - (unless (eq? drs2 drscheme-frame) - (error 'kill-test2 "expected original drscheme frame to come back to the front")))) - - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (type-in-definitions - drscheme-frame - "(define (f) (queue-callback f) (error 'ouch)) (f)") - (do-execute drscheme-frame #f) - (sleep 1/2) - (test:menu-select "Scheme" "Kill") - (let ([win (wait-for-new-frame drscheme-frame null 360)]) - (test:button-push "OK") - (let ([drs2 (wait-for-new-frame win)]) - (unless (eq? drs2 drscheme-frame) - (error - 'kill-test3 - "expected original drscheme frame to come back to the front")))) - (when (send (send drscheme-frame get-interactions-text) local-edit-sequence?) - (error 'kill-test3 "in edit-sequence"))) - - (define (callcc-test) - (next-test) - (clear-definitions drscheme-frame) - (type-in-definitions drscheme-frame "(define kont #f) (let/cc empty (set! kont empty))") - (do-execute drscheme-frame) + (when breaking-test? + (test:run-one (lambda () (send (send drscheme-frame get-break-button) command)))) (wait-for-execute) - (for-each test:keystroke (string->list "(kont)")) + (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline + [received-execute + (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))))))])) + + ; check text for execute test + (next-test) + (unless (cond + [(string? execute-answer) + (string=? execute-answer received-execute)] + [(regexp? execute-answer) + (regexp-match execute-answer received-execute)] + [else #f]) + (failure) + (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" + program + raw? + execute-answer received-execute)) + + (test:new-window interactions-canvas) + + ; save the file so that load is in sync + (test:menu-select "File" "Save Definitions") + + ; make sure that a prompt is available at end of the REPL + (unless (and (char=? #\> + (send interactions-text get-character + (- (send interactions-text last-position) 2))) + (char=? #\space + (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!) + ;; the definitions and click execute with the empty buffer + (test:new-window definitions-canvas) + (test:menu-select "Edit" "Select All") + (test:menu-select "Edit" "Delete") + (do-execute drscheme-frame #f) + (wait-for-execute) + + ;; stuff the load command into the REPL + (for-each test:keystroke + (string->list (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))]) + + (test:keystroke #\return) + + (when breaking-test? + (test:run-one (lambda () (send (send drscheme-frame get-break-button) command)))) + (wait-for-execute) + + (let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline + [received-load + (fetch-output drscheme-frame load-text-start load-text-end)]) + + ;; check load text + (next-test) + (unless (cond + [(string? load-answer) + (string=? load-answer received-load)] + [(regexp? load-answer) + (regexp-match load-answer received-load)] + [else #f]) + (failure) + (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)) + (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))) + + (teardown) + + ; check for edit-sequence + (when (repl-in-edit-sequence?) + (printf "FAILED: repl in edit-sequence") + (escape))))) + + (define tests 0) + (define failures 0) + (define (next-test) (set! tests (+ tests 1))) + (define (failure) (set! failures (+ failures 1))) + (define (reset) (set! tests 0) (set! failures 0)) + (define (final-report) + (if (= 0 failures) + (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?) + (let ([level (list "Pretty Big (includes MrEd and Advanced Student)")]) + (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)) + + (random-seed-test) + + (test:new-window definitions-canvas) + (clear-definitions drscheme-frame) + (do-execute drscheme-frame) + (let/ec escape + (for-each (run-single-test (get-int-pos) escape raw?) test-data)))) + + (define (kill-tests) + (clear-definitions drscheme-frame) + (do-execute drscheme-frame) + + (test:menu-select "Scheme" "Kill") + + (let ([win (wait-for-new-frame drscheme-frame)]) + (test:button-push "OK") + (let ([drs2 (wait-for-new-frame win)]) + (unless (eq? drs2 drscheme-frame) + (error 'kill-test1 "expected original drscheme frame to come back to the front")))) + + (type-in-definitions drscheme-frame "(kill-thread (current-thread))") + (do-execute drscheme-frame #f) + (let ([win (wait-for-new-frame drscheme-frame)]) + (test:button-push "OK") + (let ([drs2 (wait-for-new-frame win)]) + (unless (eq? drs2 drscheme-frame) + (error 'kill-test2 "expected original drscheme frame to come back to the front")))) + + (clear-definitions drscheme-frame) + (do-execute drscheme-frame) + (type-in-definitions + drscheme-frame + "(define (f) (queue-callback f) (error 'ouch)) (f)") + (do-execute drscheme-frame #f) + (sleep 1/2) + (test:menu-select "Scheme" "Kill") + (let ([win (wait-for-new-frame drscheme-frame null 360)]) + (test:button-push "OK") + (let ([drs2 (wait-for-new-frame win)]) + (unless (eq? drs2 drscheme-frame) + (error + 'kill-test3 + "expected original drscheme frame to come back to the front")))) + (when (send (send drscheme-frame get-interactions-text) local-edit-sequence?) + (error 'kill-test3 "in edit-sequence"))) + + (define (callcc-test) + (next-test) + (clear-definitions drscheme-frame) + (type-in-definitions drscheme-frame "(define kont #f) (let/cc empty (set! kont empty))") + (do-execute drscheme-frame) + (wait-for-execute) + + (for-each test:keystroke (string->list "(kont)")) + (test:keystroke #\return) + (wait-for-execute) + + + (for-each test:keystroke (string->list "x")) + (let ([start (+ 1 (send interactions-text last-position))]) (test:keystroke #\return) (wait-for-execute) - - (for-each test:keystroke (string->list "x")) + (let* ([end (- (get-int-pos) 1)] + [output (fetch-output drscheme-frame start end)] + [expected "reference to undefined identifier: x"]) + (unless (equal? output expected) + (failure) + (fprintf (current-error-port) "callcc-test: expected ~s, got ~s" expected output))))) + + (define (random-seed-test) + (define expression + (string->list (format "~a" '(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) + (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) + (let ([start2 (+ 1 (send interactions-text last-position))]) + (test:keystroke #\return) + (wait-for-execute) + (let ([output2 (fetch-output drscheme-frame start2 (- (get-int-pos) 1))]) + (unless (equal? output1 output2) + (failure) + (fprintf (current-error-port) + "random-seed-test: expected\n ~s\nand\n ~s\nto be the same" + output1 + output2))))))) + + (define (top-interaction-test) + (clear-definitions drscheme-frame) + (do-execute drscheme-frame) + (wait-for-execute) + (let ([ints-just-after-welcome (+ 1 (send interactions-text last-position))]) + + (type-in-definitions drscheme-frame "(define-syntax #%top-interaction (syntax-rules () [(_ . e) 'e]))\n(+ 1 2)\n") + (test:menu-select "File" "Save Definitions") + + (clear-definitions drscheme-frame) + (do-execute drscheme-frame) + (wait-for-execute) + + (for-each test:keystroke (string->list (format "(load ~s)" tmp-load-short-filename))) (let ([start (+ 1 (send interactions-text last-position))]) (test:keystroke #\return) (wait-for-execute) - (let* ([end (- (get-int-pos) 1)] [output (fetch-output drscheme-frame start end)] - [expected "reference to undefined identifier: x"]) + [expected "(+ 1 2)"]) (unless (equal? output expected) - (failure) - (fprintf (current-error-port) "callcc-test: expected ~s, got ~s" expected output))))) - - (define (random-seed-test) - (define expression - (string->list (format "~a" '(pseudo-random-generator->vector (current-pseudo-random-generator))))) - (next-test) - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (wait-for-execute) + (error 'top-interaction-test "expected.1 ~s, got ~s" expected output)) + (next-test))) - (for-each test:keystroke expression) - (let ([start1 (+ 1 (send interactions-text last-position))]) + (for-each test:keystroke (string->list "(+ 4 5)")) + (let ([start (+ 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) - (let ([start2 (+ 1 (send interactions-text last-position))]) - (test:keystroke #\return) - (wait-for-execute) - (let ([output2 (fetch-output drscheme-frame start2 (- (get-int-pos) 1))]) - (unless (equal? output1 output2) - (failure) - (fprintf (current-error-port) - "random-seed-test: expected\n ~s\nand\n ~s\nto be the same" - output1 - output2))))))) - - (define (top-interaction-test) - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (wait-for-execute) - (let ([ints-just-after-welcome (+ 1 (send interactions-text last-position))]) - - (type-in-definitions drscheme-frame "(define-syntax #%top-interaction (syntax-rules () [(_ . e) 'e]))\n(+ 1 2)\n") - (test:menu-select "File" "Save Definitions") - - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (wait-for-execute) - - (for-each test:keystroke (string->list (format "(load ~s)" tmp-load-short-filename))) - (let ([start (+ 1 (send interactions-text last-position))]) - (test:keystroke #\return) - (wait-for-execute) - (let* ([end (- (get-int-pos) 1)] - [output (fetch-output drscheme-frame start end)] - [expected "(+ 1 2)"]) - (unless (equal? output expected) - (error 'top-interaction-test "expected.1 ~s, got ~s" expected output)) - (next-test))) - - (for-each test:keystroke (string->list "(+ 4 5)")) - (let ([start (+ 1 (send interactions-text last-position))]) - (test:keystroke #\return) - (wait-for-execute) - (let* ([end (- (get-int-pos) 1)] - [output (fetch-output drscheme-frame start end)] - [expected "(+ 4 5)"]) - (unless (equal? output expected) - (error 'top-interaction-test "expected.2 ~s, got ~s" expected output)) - (next-test))))) - - (when (file-exists? tmp-load-filename) - (delete-file tmp-load-filename)) - (save-drscheme-window-as tmp-load-filename) + (let* ([end (- (get-int-pos) 1)] + [output (fetch-output drscheme-frame start end)] + [expected "(+ 4 5)"]) + (unless (equal? output expected) + (error 'top-interaction-test "expected.2 ~s, got ~s" expected output)) + (next-test))))) + + (when (file-exists? tmp-load-filename) + (delete-file tmp-load-filename)) + (save-drscheme-window-as tmp-load-filename) + + (run-test-in-language-level #f) + (run-test-in-language-level #t) + ;(kill-tests) + ;(callcc-test) + ;(top-interaction-test) + ;(final-report) + ) - (run-test-in-language-level #t) - (run-test-in-language-level #f) - (kill-tests) - (callcc-test) - (top-interaction-test) - (final-report))) + +(define (make-execute-answer test raw?) + ((if raw? answer-raw-execute answer-debug-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)) + (test-answer test))) + +(define (string/rx-append a b) + (if (regexp? b) + (regexp (string-append (regexp-quote a) (object-name b))) + (string-append a b))) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 3f0379ec65..f872c7bb40 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -18,6 +18,10 @@ . removed help-desk:help-desk from the tools interface. Use the help collection instead. + . removed drscheme:debug:show-error-and-highlight from + the tools interface. Use drscheme:debug:error-display-handler/stacktrace + instead. + ------------------------------ Version 372 ------------------------------