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

adapted repl to new prompt stuff, fixed minor other things along the way

Browse Source 
svn: r5179
This commit is contained in:
Robby Findler 2006-12-24 20:55:33 +00:00
parent 8baf2c76b2
commit 3e679de9a5
7 changed files with 208 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/drscheme/private/frame.ss
View File

@ -184,10 +184,16 @@
(label (string-constant keybindings-add-user-defined-keybindings)) (label (string-constant keybindings-add-user-defined-keybindings))
(callback (callback
(λ (x y) (λ (x y)
(let ([filename (get-file (string-constant keybindings-choose-user-defined-file) (with-handlers ([exn? (λ (x)
this)]) (printf "~a\n" (exn-message x)))])
(when filename (let ([filename (finder:get-file
(add-keybindings-item/update-prefs filename)))))) #f
(string-constant keybindings-choose-user-defined-file)
#f
""
this)])
(when filename
(add-keybindings-item/update-prefs filename)))))))
(new menu-item% (new menu-item%
(parent keybindings-menu) (parent keybindings-menu)
(label (string-constant keybindings-add-user-defined-keybindings/planet)) (label (string-constant keybindings-add-user-defined-keybindings/planet))
@ -335,7 +341,7 @@
;; gets the name of a file from the user and ;; gets the name of a file from the user and
;; updates file-text-field ;; updates file-text-field
(define (browse) (define (browse)
(let ([filename (get-file #f dialog)]) (let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename (when filename
(send file-text-field set-value (path->string filename))))) (send file-text-field set-value (path->string filename)))))

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

@ -1121,10 +1121,14 @@
;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof))) ;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof)))
;; type reader = type-spec-of-read-syntax (see mz manual for details) ;; type reader = type-spec-of-read-syntax (see mz manual for details)
(define (module-based-language-front-end port reader) (define (module-based-language-front-end port reader)
(λ () (λ ()
(reader (object-name port) port))) (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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

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

@ -184,12 +184,6 @@ TODO
;; a port that accepts values for printing in the repl ;; a port that accepts values for printing in the repl
(define current-value-port (make-parameter #f)) (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 ;; drscheme-error-display-handler : (string (union #f exn) -> void
;; =User= ;; =User=
;; the timing is a little tricky here. ;; the timing is a little tricky here.
@ -1018,10 +1012,6 @@ TODO
(define/public (set-submit-predicate p) (define/public (set-submit-predicate p)
(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= (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
(send context disable-evaluation) (send context disable-evaluation)
(send context reset-offer-kill) (send context reset-offer-kill)
@ -1039,59 +1029,43 @@ TODO
(let* ([settings (current-language-settings)] (let* ([settings (current-language-settings)]
[lang (drscheme:language-configuration:language-settings-language settings)] [lang (drscheme:language-configuration:language-settings-language settings)]
[settings (drscheme:language-configuration:language-settings-settings settings)] [settings (drscheme:language-configuration:language-settings-settings settings)]
[dummy-value (box #f)]) [dummy-value (box #f)]
(set! get-sexp/syntax/eof [get-sexp/syntax/eof
(if complete-program? (if complete-program?
(send lang front-end/complete-program port settings user-teachpack-cache) (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 ; Evaluate the user's expression. We're careful to turn on
; breaks as we go in and turn them off as we go out. ; breaks as we go in and turn them off as we go out.
; (Actually, we adjust breaks however the user wanted it.) ; (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 (call-with-continuation-prompt
(let ([saved-error-escape-k (current-error-escape-k)] (λ ()
[cleanup? #f]) (call-with-break-parameterization
(dynamic-wind user-break-parameterization
(λ () (λ ()
(set! cleanup? #f) (let loop ()
(current-error-escape-k (λ () (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))])
(set! cleanup? #t) (unless (eof-object? sexp/syntax/eof)
(k (void))))) (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)
(let loop () (update-running #f)
(let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))]) (cleanup)
(unless (eof-object? sexp/syntax/eof) (flush-output (get-value-port))
(call-with-break-parameterization (queue-system-callback/sync
user-break-parameterization (get-user-thread)
;; a break exn may be raised right at this point, (λ () ; =Kernel=, =Handler=
;; in which case the stack won't be in a trimmable state (after-many-evals)
;; so we don't complain (above) when we find an untrimmable (cleanup-interaction)
;; break exn. (insert-prompt)))))))
(λ ()
(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))))))))))))
(define/pubment (after-many-evals) (inner (void) after-many-evals)) (define/pubment (after-many-evals) (inner (void) after-many-evals))
@ -1135,39 +1109,6 @@ TODO
(cleanup-interaction) (cleanup-interaction)
(cleanup))))))))) (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= (define/public (run-in-evaluation-thread thunk) ; =Kernel=
(semaphore-wait eval-thread-state-sema) (semaphore-wait eval-thread-state-sema)
(set! eval-thread-thunks (append eval-thread-thunks (list thunk))) (set! eval-thread-thunks (append eval-thread-thunks (list thunk)))
@ -1238,11 +1179,6 @@ TODO
(parameterize ([current-eventspace (get-user-eventspace)]) (parameterize ([current-eventspace (get-user-eventspace)])
(queue-callback (queue-callback
(λ () (λ ()
(let ([drscheme-error-escape-handler
(λ ()
((current-error-escape-k)))])
(error-escape-handler drscheme-error-escape-handler))
(set! in-evaluation? #f) (set! in-evaluation? #f)
(update-running #f) (update-running #f)
(send context set-breakables #f #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 ;; at this point, we must not be in a nested dispatch, so we can
;; just disable breaks and rely on call-with-break-parameterization ;; just disable breaks and rely on call-with-break-parameterization
;; to restore them to the user's setting. ;; to restore them to the user's setting.
(call-with-break-parameterization (call-with-break-parameterization
no-breaks-break-parameterization no-breaks-break-parameterization
(λ () (λ ()
; =No-Breaks= ; =No-Breaks=
(send context reset-offer-kill) (send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian)) (send context set-breakables (get-user-thread) (get-user-custodian))
(protect-user-evaluation (call-with-continuation-prompt
; Run the dispatch:
(λ () ; =User=, =Handler=, =No-Breaks= (λ () ; =User=, =Handler=, =No-Breaks=
(call-with-break-parameterization (call-with-break-parameterization
user-break-parameterization user-break-parameterization
(λ () (primitive-dispatch-handler eventspace)))) (λ () (primitive-dispatch-handler eventspace)))))
; Cleanup after dispatch
(λ () ;; in principle, the line below might cause
;; in principle, the line below might cause ;; "race conditions" in the GUI. That is, there might
;; a "race conditions" in the GUI. That is, there might ;; be many little events that the user won't quite
;; be many little events that the user won't quite ;; be able to break.
;; be able to break. (send context set-breakables #f #f)))]
(send context set-breakables #f #f)))))]
[else [else
; Nested dispatch; don't adjust interface ; Nested dispatch; don't adjust interface
(primitive-dispatch-handler eventspace)])] (primitive-dispatch-handler eventspace)])]

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

@ -1051,8 +1051,6 @@ module browser threading seems wrong.
update-info update-info
get-file-menu get-file-menu
file-menu:get-close-item file-menu:get-close-item
file-menu:get-open-item
file-menu:get-new-item
file-menu:get-save-item file-menu:get-save-item
file-menu:get-save-as-item file-menu:get-save-as-item
file-menu:get-revert-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))))) (for-each (λ (c r) (set-visible-region txt c r)) canvases regions)))))
(define (set-visible-region txt canvas region) (define (set-visible-region txt canvas region)
(let ([admin (send txt get-admin)]) (let ([admin (send txt get-admin)])
;(printf "setting to ~s\n" region)
(send admin scroll-to (send admin scroll-to
(first region) (first region)
(second region) (second region)
(third region) (third region)
(fourth region)) (fourth region))))
#;
(let-values ([(x y w h _) (get-visible-region canvas)])
(printf " set to ~s\n" (list x y w h)))))
(let-values ([(vi is?) (send current-tab get-visible-ints)] (let-values ([(vi is?) (send current-tab get-visible-ints)]
[(vd ds?) (send current-tab get-visible-defs)]) [(vd ds?) (send current-tab get-visible-defs)])
(set! interactions-shown? is?) (set! interactions-shown? is?)
@ -3106,15 +3100,17 @@ module browser threading seems wrong.
(inner (void) after-percentage-change)) (inner (void) after-percentage-change))
(super-new))) (super-new)))
(define drs-name-message% (define drs-name-message%
(class name-message% (class name-message%
(define/override (on-choose-directory dir) (define/override (on-choose-directory dir)
(let ([file (get-file (string-constant select-file) (let ([file (finder:get-file dir
(send this get-top-level-window) (string-constant select-file)
dir)]) #f
(when file ""
(handler:edit-file file)))) (send this get-top-level-window))])
(super-new))) (when file
(handler:edit-file file))))
(super-new)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

3
collects/help/doc.txt
View File

@ -299,8 +299,7 @@ Help Desk looks for html documentation in two places:
2) Help Desk also looks inside each sub-directory in any 2) Help Desk also looks inside each sub-directory in any
`doc' collection (Help Desk searches all doc `doc' collection (Help Desk searches all doc
collections, not just the first one, unlike collections, not just the first one, unlike
`collection-path'). For example, the MzScheme manual is `collection-path').
in the directory plt/doc/mzscheme.
The starting point for each manual must be called either: The starting point for each manual must be called either:

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

@ -1223,11 +1223,11 @@ the settings above should match r5rs
(let ([drs (wait-for-drscheme-frame)]) (let ([drs (wait-for-drscheme-frame)])
(fw:test:menu-select "Language" "Clear All Teachpacks")) (fw:test:menu-select "Language" "Clear All Teachpacks"))
(go mred)
(go mzscheme)
(go beginner) (go beginner)
(go beginner/abbrev) (go beginner/abbrev)
(go intermediate) (go intermediate)
(go intermediate/lambda) (go intermediate/lambda)
(go advanced) (go advanced)
(go r5rs) (go r5rs)))
(go mred)
(go mzscheme)))

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

@ -48,7 +48,6 @@
(define test-data (define test-data
(list (list
#|
;; basic tests ;; basic tests
(make-test "1" (make-test "1"
"1" "1"
@ -207,14 +206,6 @@
void void
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 (make-test (string-append
"(module m mzscheme (provide e) (define e #'1))\n" "(module m mzscheme (provide e) (define e #'1))\n"
"(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n" "(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n"
@ -251,74 +242,6 @@
void void
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 ;; eval tests
(make-test " (eval '(values 1 2))" (make-test " (eval '(values 1 2))"
@ -507,7 +430,7 @@
#f #f
void void
void) void)
|#
; fraction snip test ; fraction snip test
;; this test depends on the state of the 'framework:fraction-snip-style preference ;; 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 sure this preference is set to the default when running this test.
@ -520,7 +443,7 @@
#f #f
void void
void) void)
#|
;; should produce a syntax object with a turn-down triangle. ;; should produce a syntax object with a turn-down triangle.
(make-test "(write (list (syntax x)))" (make-test "(write (list (syntax x)))"
"({embedded \".#<syntax:1:21>\"})" "({embedded \".#<syntax:1:21>\"})"
@ -767,8 +690,77 @@
#f #f
void void
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 backtrace-image-string "{bug09.gif}")
(define file-image-string "{file.gif}") (define file-image-string "{file.gif}")
@ -838,6 +830,7 @@
; directly, and second, we use the load command. We compare the ; directly, and second, we use the load command. We compare the
; the results of these operations against expected results. ; the results of these operations against expected results.
(define ((run-single-test execute-text-start escape raw?) in-vector) (define ((run-single-test execute-text-start escape raw?) in-vector)
(printf "\n>> testing ~s\n" (test-program in-vector))
(let* ([program (test-program in-vector)] (let* ([program (test-program in-vector)]
[execute-answer (if raw? [execute-answer (if raw?
(test-raw-execute-answer in-vector) (test-raw-execute-answer in-vector)
@ -909,11 +902,13 @@
(car error-ranges))]) (car error-ranges))])
(unless (and error-range (unless (and error-range
(= (+ (srcloc-position error-range) -1) (loc-offset start)) (= (+ (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" (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
program program
(list (+ (srcloc-position error-range) -1) (and error-range
(+ (srcloc-position error-range) -1 (srcloc-span error-range))) (list (+ (srcloc-position error-range) -1)
(+ (srcloc-position error-range) -1 (srcloc-span error-range))))
(list (loc-offset start) (list (loc-offset start)
(loc-offset finish))))))])) (loc-offset finish))))))]))
@ -1077,6 +1072,60 @@
(unless (equal? output expected) (unless (equal? output expected)
(error 'callcc-test "expected ~s, got ~s" expected output))))) (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) (when (file-exists? tmp-load-filename)
(delete-file tmp-load-filename)) (delete-file tmp-load-filename))
@ -1086,4 +1135,5 @@
(run-test-in-language-level #f) (run-test-in-language-level #f)
(kill-tests) (kill-tests)
(callcc-test) (callcc-test)
(top-interaction-test)
(final-report))) (final-report)))