From 9616bd178284a9721c0fed20dbc35ffbe0f03a83 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 11 Feb 1999 17:19:12 +0000 Subject: [PATCH] ... original commit: 3c158bf7a0846729599873a8ace7f888b6fac586 --- collects/framework/editor.ss | 10 +-- collects/framework/frame.ss | 5 +- collects/framework/keymap.ss | 10 +++ collects/framework/scheme.ss | 6 +- collects/tests/framework/main.ss | 131 ++++++++++++++++++------------- 5 files changed, 94 insertions(+), 68 deletions(-) diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index 3f2eb683..fe7a2870 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -46,8 +46,6 @@ (error 'end-edit-sequence "extra end-edit-sequence")) (super-end-edit-sequence))]) - - (rename [super-set-modified set-modified] [super-on-focus on-focus] [super-lock lock]) @@ -175,13 +173,7 @@ (let ([keymap (get-keymap)]) (keymap:set-keymap-error-handler keymap) (keymap:set-keymap-implied-shifts keymap) - (add-editor-keymap-functions keymap) - (add-text-keymap-functions keymap) - (add-pasteboard-keymap-functions keymap) - (for-each (lambda (k) - (keymap:set-keymap-error-handler k) - (keymap:set-keymap-implied-shifts k) - (send keymap chain-to-keymap k #f)) + (for-each (lambda (k) (send keymap chain-to-keymap k #f)) (get-keymaps)))))) (define file<%> (interface (-keymap<%>))) diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 2936bfab..41cd768c 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -11,6 +11,7 @@ [finder : framework:finder^] [keymap : framework:keymap^] [text : framework:text^] + [pasteboard : framework:pasteboard^] [editor : framework:editor^] [mzlib:function : mzlib:function^]) @@ -281,7 +282,7 @@ (mixin (-editor<%>) (-text<%>) args (override [get-editor<%> (lambda () text<%>)] - [get-editor% (lambda () text%)]) + [get-editor% (lambda () text:keymap%)]) (sequence (apply super-init args)))) (define -pasteboard<%> (interface (-editor<%>))) @@ -289,7 +290,7 @@ (mixin (-editor<%>) (-pasteboard<%>) args (override [get-editor<%> (lambda () pasteboard<%>)] - [get-editor% (lambda () pasteboard%)]) + [get-editor% (lambda () pasteboard:keymap%)]) (sequence (apply super-init args)))) (define searchable<%> (interface (-text<%>) diff --git a/collects/framework/keymap.ss b/collects/framework/keymap.ss index 6ff7e2ec..42358bb7 100644 --- a/collects/framework/keymap.ss +++ b/collects/framework/keymap.ss @@ -847,14 +847,24 @@ (map "c:x;c:w" "save-file-as") (map "c:x;c:f" "load-file"))))) + (define (generic-setup keymap) + (set-keymap-error-handler keymap) + (set-keymap-implied-shifts keymap) + (add-editor-keymap-functions keymap) + (add-pasteboard-keymap-functions keymap) + (add-text-keymap-functions keymap)) + (define global (make-object keymap%)) (setup-global global) + (generic-setup global) (define (get-global) global) (define file (make-object keymap%)) (setup-file file) + (generic-setup file) (define (-get-file) file) (define search (make-object keymap%)) + (generic-setup search) (setup-search search) (define (get-search) search)) diff --git a/collects/framework/scheme.ss b/collects/framework/scheme.ss index ae4d15c1..918e1bda 100644 --- a/collects/framework/scheme.ss +++ b/collects/framework/scheme.ss @@ -567,21 +567,21 @@ forward-cache))] [remove-sexp (lambda (start-pos) - (let ([end-pos (get-forward-sexp this start-pos)]) + (let ([end-pos (get-forward-sexp start-pos)]) (if end-pos (kill 0 start-pos end-pos) (bell)) #t))] [forward-sexp (lambda (start-pos) - (let ([end-pos (get-forward-sexp this start-pos)]) + (let ([end-pos (get-forward-sexp start-pos)]) (if end-pos (set-position end-pos) (bell)) #t))] [flash-forward-sexp (lambda (start-pos) - (let ([end-pos (get-forward-sexp this start-pos)]) + (let ([end-pos (get-forward-sexp start-pos)]) (if end-pos (flash-on end-pos (add1 end-pos)) (bell)) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index a351199a..79f23659 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -109,50 +109,57 @@ (define send-sexp-to-mred (lambda (sexp) - (unless (and in-port - out-port - (or (not (char-ready? in-port)) - (not (eof-object? (peek-char in-port))))) - (restart-mred)) - (printf " ~a // ~a: sending to mred:~n" section-name test-name) - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp)) - (newline) - (write sexp out-port) - (newline out-port) - (let ([answer - (with-handlers ([(lambda (x) #t) - (lambda (x) (list 'cant-read - (string-append - (exn-message x) - "; rest of string: " - (apply - string - (let loop () - (if (char-ready? in-port) - (cons (read-char in-port) - (loop)) - null))))))]) - (read in-port))]) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)))) - (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred (format "mred raised \"~a\"" (second answer)))] - [(cant-read) (error 'mred/cant-parse (second answer))] - [(normal) (eval (second answer))]))))) + (let ([show-text + (lambda (sexp) + + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp) + (newline)))]) + (unless (and in-port + out-port + (or (not (char-ready? in-port)) + (not (eof-object? (peek-char in-port))))) + (restart-mred)) + (printf " ~a // ~a: sending to mred:~n" section-name test-name) + (show-text sexp) + (write sexp out-port) + (newline out-port) + (let ([answer + (with-handlers ([(lambda (x) #t) + (lambda (x) (list 'cant-read + (string-append + (exn-message x) + "; rest of string: " + (apply + string + (let loop () + (if (char-ready? in-port) + (cons (read-char in-port) + (loop)) + null))))))]) + (read in-port))]) + (unless (or (eof-object? answer) + (and (list? answer) + (= 2 (length answer)))) + (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) + (if (eof-object? answer) + (raise (make-eof-result)) + (case (car answer) + [(error) + (error 'send-sexp-to-mred (format "mred raised \"~a\"" (second answer)))] + [(cant-read) (error 'mred/cant-parse (second answer))] + [(normal) + (printf " ~a // ~a: received from mred:~n" section-name test-name) + (show-text (second answer)) + (eval (second answer))])))))) (define test @@ -233,11 +240,26 @@ (set! only-these-tests (cons (string->symbol _only-these-tests) (or only-these-tests null)))) ("Only run test named " "test-name")]))]) - (parse-command-line "framework-test" argv command-line-flags - (lambda (collected . files) - (set! files-to-process (if (null? files) all-files files))) - `("Names of the tests; defaults to all tests")) + + (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")] + [parsed-argv (if (equal? argv (vector)) + (if (file-exists? saved-command-line-file) + (begin + (let ([result (call-with-input-file saved-command-line-file read)]) + (printf "reusing command-line arguments: ~s~n" result) + result)) + (vector)) + argv)]) + (parse-command-line "framework-test" parsed-argv command-line-flags + (lambda (collected . files) + (set! files-to-process (if (null? files) all-files files))) + `("Names of the tests; defaults to all tests")) + (call-with-output-file saved-command-line-file + (lambda (port) + (write parsed-argv port)) + 'truncate)) + (when (file-exists? preferences-file) (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) (when (file-exists? old-preferences-file) @@ -254,15 +276,16 @@ (lambda (exn) (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))]) (printf "beginning ~a test suite~n" x) + (invoke-unit/sig (eval `(unit/sig () - (import TestSuite^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - (include ,x))) + (import TestSuite^ + mzlib:function^ + mzlib:file^ + mzlib:string^ + mzlib:pretty-print^) + (include ,x))) TestSuite^ mzlib:function^ mzlib:file^