adapted repl to new prompt stuff, fixed minor other things along the way
svn: r5179
This commit is contained in:
Robby Findler
parent
8baf2c76b2
commit
3e679de9a5
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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)])]
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 ())"
|
||||
"(a ())"
|
||||
'interactions
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
#|
|
||||
;; XML tests
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>")
|
||||
"(a ())"
|
||||
"(a ())"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("Special" "Insert Scheme Box")
|
||||
"1")
|
||||
"(a () 1)"
|
||||
"(a () 1)"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("Special" "Insert Scheme Splice Box")
|
||||
"'(1)")
|
||||
"(a () 1)"
|
||||
"(a () 1)"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("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 \".#<syntax:1:21>\"})"
|
||||
|
|
@ -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 ())"
|
||||
"(a ())"
|
||||
'interactions
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>")
|
||||
"(a ())"
|
||||
"(a ())"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("Special" "Insert Scheme Box")
|
||||
"1")
|
||||
"(a () 1)"
|
||||
"(a () 1)"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("Special" "Insert Scheme Splice Box")
|
||||
"'(1)")
|
||||
"(a () 1)"
|
||||
"(a () 1)"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
"<a>"
|
||||
("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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user