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

...

Browse Source 
original commit: 3c158bf7a0846729599873a8ace7f888b6fac586
This commit is contained in:
Robby Findler 1999-02-11 17:19:12 +00:00
parent 4a3e69442a
commit 9616bd1782
5 changed files with 94 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/framework/editor.ss
View File

@ -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<%>)))

5
collects/framework/frame.ss
View File

@ -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<%>)

10
collects/framework/keymap.ss
View File

@ -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))

6
collects/framework/scheme.ss
View File

@ -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))

131
collects/tests/framework/main.ss
View File

@ -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>" "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^