diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss
index a468ccae5b..aec1ae88a6 100644
--- a/collects/drscheme/private/frame.ss
+++ b/collects/drscheme/private/frame.ss
@@ -184,10 +184,16 @@
(label (string-constant keybindings-add-user-defined-keybindings))
(callback
(λ (x y)
- (let ([filename (get-file (string-constant keybindings-choose-user-defined-file)
- this)])
- (when filename
- (add-keybindings-item/update-prefs filename))))))
+ (with-handlers ([exn? (λ (x)
+ (printf "~a\n" (exn-message x)))])
+ (let ([filename (finder:get-file
+ #f
+ (string-constant keybindings-choose-user-defined-file)
+ #f
+ ""
+ this)])
+ (when filename
+ (add-keybindings-item/update-prefs filename)))))))
(new menu-item%
(parent keybindings-menu)
(label (string-constant keybindings-add-user-defined-keybindings/planet))
@@ -335,7 +341,7 @@
;; gets the name of a file from the user and
;; updates file-text-field
(define (browse)
- (let ([filename (get-file #f dialog)])
+ (let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename
(send file-text-field set-value (path->string filename)))))
diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss
index 88ea042f89..a502de3a55 100644
--- a/collects/drscheme/private/language.ss
+++ b/collects/drscheme/private/language.ss
@@ -1121,10 +1121,14 @@
;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof)))
;; type reader = type-spec-of-read-syntax (see mz manual for details)
- (define (module-based-language-front-end port reader)
- (λ ()
- (reader (object-name port) port)))
-
+ (define (module-based-language-front-end port reader)
+ (λ ()
+ (let ([s (reader (object-name port) port)])
+ (if (syntax? s)
+ (with-syntax ([s s]
+ [t (namespace-syntax-introduce (datum->syntax-object #f '#%top-interaction))])
+ (syntax (t . s)))
+ s))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index b2ec4b53b5..82db72e3ee 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -184,12 +184,6 @@ TODO
;; a port that accepts values for printing in the repl
(define current-value-port (make-parameter #f))
- ;; an error escape continuation that the user program can't
- ;; change; DrScheme sets it, we use a parameter instead of an
- ;; object field so that there's no non-weak pointer to the
- ;; continuation from DrScheme.
- (define current-error-escape-k (make-parameter void))
-
;; drscheme-error-display-handler : (string (union #f exn) -> void
;; =User=
;; the timing is a little tricky here.
@@ -1018,10 +1012,6 @@ TODO
(define/public (set-submit-predicate p)
(set! submit-predicate p))
- ;; record this on an ivar in the class so that
- ;; continuation jumps into old calls to evaluate-from-port
- ;; continue to evaluate from the correct port.
- (define get-sexp/syntax/eof #f)
(define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
(send context disable-evaluation)
(send context reset-offer-kill)
@@ -1039,59 +1029,43 @@ TODO
(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)])
- (set! get-sexp/syntax/eof
+ [dummy-value (box #f)]
+ [get-sexp/syntax/eof
(if complete-program?
(send lang front-end/complete-program port settings user-teachpack-cache)
- (send lang front-end/interaction port settings user-teachpack-cache)))
+ (send lang front-end/interaction port settings user-teachpack-cache))])
; 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.)
- ; A continuation hop might take us out of this instance of
- ; evaluation and into another one, which is fine.
- (let/ec k
- (let ([saved-error-escape-k (current-error-escape-k)]
- [cleanup? #f])
- (dynamic-wind
- (λ ()
- (set! cleanup? #f)
- (current-error-escape-k (λ ()
- (set! cleanup? #t)
- (k (void)))))
-
- (λ ()
- (let loop ()
- (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))])
- (unless (eof-object? sexp/syntax/eof)
- (call-with-break-parameterization
- user-break-parameterization
- ;; a break exn may be raised right at this point,
- ;; in which case the stack won't be in a trimmable state
- ;; so we don't complain (above) when we find an untrimmable
- ;; break exn.
- (λ ()
- (call-with-values
- (λ ()
- (with-stacktrace-name (eval-syntax sexp/syntax/eof)))
- (λ x (display-results x)))))
- (loop))))
- (set! cleanup? #t))
-
- (λ ()
- (current-error-escape-k saved-error-escape-k)
- (when cleanup?
- (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))))))))))))
+ (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)))))
+ (λ 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))
@@ -1135,39 +1109,6 @@ TODO
(cleanup-interaction)
(cleanup)))))))))
- (define/private protect-user-evaluation ; =User=, =Handler=, =No-Breaks=
- (λ (thunk cleanup)
-
- ;; We only run cleanup if thunk finishes normally or tries to
- ;; error-escape. Otherwise, it must be a continuation jump
- ;; into a different call to protect-user-evaluation.
-
- ;; `thunk' is responsible for ensuring that breaks are off when
- ;; it returns or jumps out.
-
- (set! in-evaluation? #t)
- (update-running #t)
-
- (let/ec k
- (let ([saved-error-escape-k (current-error-escape-k)]
- [cleanup? #f])
- (dynamic-wind
- (λ ()
- (set! cleanup? #f)
- (current-error-escape-k (λ ()
- (set! cleanup? #t)
- (k (void)))))
- (λ ()
- (thunk)
- ; Breaks must be off!
- (set! cleanup? #t))
- (λ ()
- (current-error-escape-k saved-error-escape-k)
- (when cleanup?
- (set! in-evaluation? #f)
- (update-running #f)
- (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)))
@@ -1238,11 +1179,6 @@ TODO
(parameterize ([current-eventspace (get-user-eventspace)])
(queue-callback
(λ ()
- (let ([drscheme-error-escape-handler
- (λ ()
- ((current-error-escape-k)))])
- (error-escape-handler drscheme-error-escape-handler))
-
(set! in-evaluation? #f)
(update-running #f)
(send context set-breakables #f #f)
@@ -1391,26 +1327,23 @@ TODO
;; 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))
- (protect-user-evaluation
- ; Run the dispatch:
+ (call-with-continuation-prompt
(λ () ; =User=, =Handler=, =No-Breaks=
(call-with-break-parameterization
user-break-parameterization
- (λ () (primitive-dispatch-handler eventspace))))
- ; Cleanup after dispatch
- (λ ()
- ;; in principle, the line below might cause
- ;; a "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)))))]
+ (λ () (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)])]
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
index 4142abefae..5af09a1e45 100644
--- a/collects/drscheme/private/unit.ss
+++ b/collects/drscheme/private/unit.ss
@@ -1051,8 +1051,6 @@ module browser threading seems wrong.
update-info
get-file-menu
file-menu:get-close-item
- file-menu:get-open-item
- file-menu:get-new-item
file-menu:get-save-item
file-menu:get-save-as-item
file-menu:get-revert-item
@@ -2191,15 +2189,11 @@ module browser threading seems wrong.
(for-each (λ (c r) (set-visible-region txt c r)) canvases regions)))))
(define (set-visible-region txt canvas region)
(let ([admin (send txt get-admin)])
- ;(printf "setting to ~s\n" region)
(send admin scroll-to
(first region)
(second region)
(third region)
- (fourth region))
- #;
- (let-values ([(x y w h _) (get-visible-region canvas)])
- (printf " set to ~s\n" (list x y w h)))))
+ (fourth region))))
(let-values ([(vi is?) (send current-tab get-visible-ints)]
[(vd ds?) (send current-tab get-visible-defs)])
(set! interactions-shown? is?)
@@ -3106,15 +3100,17 @@ module browser threading seems wrong.
(inner (void) after-percentage-change))
(super-new)))
- (define drs-name-message%
- (class name-message%
- (define/override (on-choose-directory dir)
- (let ([file (get-file (string-constant select-file)
- (send this get-top-level-window)
- dir)])
- (when file
- (handler:edit-file file))))
- (super-new)))
+ (define drs-name-message%
+ (class name-message%
+ (define/override (on-choose-directory dir)
+ (let ([file (finder:get-file dir
+ (string-constant select-file)
+ #f
+ ""
+ (send this get-top-level-window))])
+ (when file
+ (handler:edit-file file))))
+ (super-new)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
diff --git a/collects/help/doc.txt b/collects/help/doc.txt
index c0033b751c..ad40904c68 100644
--- a/collects/help/doc.txt
+++ b/collects/help/doc.txt
@@ -299,8 +299,7 @@ Help Desk looks for html documentation in two places:
2) Help Desk also looks inside each sub-directory in any
`doc' collection (Help Desk searches all doc
collections, not just the first one, unlike
- `collection-path'). For example, the MzScheme manual is
- in the directory plt/doc/mzscheme.
+ `collection-path').
The starting point for each manual must be called either:
diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss
index 391dc55312..64f635762a 100644
--- a/collects/tests/drscheme/language-test.ss
+++ b/collects/tests/drscheme/language-test.ss
@@ -1223,11 +1223,11 @@ the settings above should match r5rs
(let ([drs (wait-for-drscheme-frame)])
(fw:test:menu-select "Language" "Clear All Teachpacks"))
+ (go mred)
+ (go mzscheme)
(go beginner)
(go beginner/abbrev)
(go intermediate)
(go intermediate/lambda)
(go advanced)
- (go r5rs)
- (go mred)
- (go mzscheme)))
+ (go r5rs)))
diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss
index 440eb71930..fbe1abc9e0 100644
--- a/collects/tests/drscheme/repl-test.ss
+++ b/collects/tests/drscheme/repl-test.ss
@@ -48,7 +48,6 @@
(define test-data
(list
-#|
;; basic tests
(make-test "1"
"1"
@@ -207,14 +206,6 @@
void
void)
-#|
- ;; syntax error template
- "{bug09.gif} "
- "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: "
- ""
- "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: "
- |#
-
(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"
@@ -250,75 +241,7 @@
#f
void
void)
-
- (make-test (list "#!\n"
- '("Special" "Insert XML Box")
- "")
- "(a ())"
- "(a ())"
- "(a ())"
- "(a ())"
- 'interactions
- #f
- void
- void)
- #|
- ;; XML tests
- (make-test
- '(("Special" "Insert XML Box")
- "")
- "(a ())"
- "(a ())"
- #f
- 'interactions
- #f
- #f
- void
- void)
-
- (make-test
- '(("Special" "Insert XML Box")
- ""
- ("Special" "Insert Scheme Box")
- "1")
- "(a () 1)"
- "(a () 1)"
- #f
- 'interactions
- #f
- #f
- void
- void)
-
- (make-test
- '(("Special" "Insert XML Box")
- ""
- ("Special" "Insert Scheme Splice Box")
- "'(1)")
- "(a () 1)"
- "(a () 1)"
- #f
- 'interactions
- #f
- #f
- void
- void)
-
- (make-test
- '(("Special" "Insert XML Box")
- ""
- ("Special" "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)
-|#
;; eval tests
(make-test " (eval '(values 1 2))"
@@ -507,7 +430,7 @@
#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.
@@ -520,7 +443,7 @@
#f
void
void)
- #|
+
;; should produce a syntax object with a turn-down triangle.
(make-test "(write (list (syntax x)))"
"({embedded \".#\"})"
@@ -767,8 +690,77 @@
#f
void
void)
-|#
+
))
+ ;; these tests aren't used at the moment.
+ (define xml-tests
+ (list
+ ;; XML tests
+ (make-test (list "#!\n"
+ '("Special" "Insert XML Box")
+ "")
+ "(a ())"
+ "(a ())"
+ "(a ())"
+ "(a ())"
+ 'interactions
+ #f
+ void
+ void)
+
+ (make-test
+ '(("Special" "Insert XML Box")
+ "")
+ "(a ())"
+ "(a ())"
+ #f
+ 'interactions
+ #f
+ #f
+ void
+ void)
+
+ (make-test
+ '(("Special" "Insert XML Box")
+ ""
+ ("Special" "Insert Scheme Box")
+ "1")
+ "(a () 1)"
+ "(a () 1)"
+ #f
+ 'interactions
+ #f
+ #f
+ void
+ void)
+
+ (make-test
+ '(("Special" "Insert XML Box")
+ ""
+ ("Special" "Insert Scheme Splice Box")
+ "'(1)")
+ "(a () 1)"
+ "(a () 1)"
+ #f
+ 'interactions
+ #f
+ #f
+ void
+ void)
+
+ (make-test
+ '(("Special" "Insert XML Box")
+ ""
+ ("Special" "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.gif}")
(define file-image-string "{file.gif}")
@@ -838,6 +830,7 @@
; 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 (if raw?
(test-raw-execute-answer in-vector)
@@ -909,11 +902,13 @@
(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)))
+ (= (+ (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
- (list (+ (srcloc-position error-range) -1)
- (+ (srcloc-position error-range) -1 (srcloc-span error-range)))
+ (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))))))]))
@@ -1076,14 +1071,69 @@
[expected "{bug09.gif} reference to undefined identifier: x"])
(unless (equal? output expected)
(error 'callcc-test "expected ~s, got ~s" expected output)))))
-
+
+ (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 ~s, got ~s" expected output))))
+
+ (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 ~s, got ~s" expected output))))
+
+ (do-execute drscheme-frame)
+ (wait-for-execute)
+ (let ([start (+ 1 (send interactions-text last-position))])
+ (type-in-definitions drscheme-frame "(define-syntax #%top-interaction (syntax-rules () [(_ . e) 'e]))\n(+ 1 2)\n")
+ (do-execute drscheme-frame)
+ (wait-for-execute)
+ (let* ([end (- (get-int-pos) 1)]
+ [output (fetch-output drscheme-frame ints-just-after-welcome end)]
+ [expected "(+ 4 5)"])
+ (unless (equal? output expected)
+ (error 'top-interaction-test "expected ~s, got ~s" expected output))))
+
+ (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 ~s, got ~s" expected output))))))
(when (file-exists? tmp-load-filename)
(delete-file tmp-load-filename))
(save-drscheme-window-as tmp-load-filename)
-
+
(run-test-in-language-level #t)
(run-test-in-language-level #f)
(kill-tests)
(callcc-test)
+ (top-interaction-test)
(final-report)))