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

Trunk merging, check it and see

Browse Source 
svn: r11726
This commit is contained in:
Stevie Strickland 2008-09-13 16:06:35 +00:00
commit e5539b1766
8 changed files with 66 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/framework/private/comment-box.ss
View File

@ -32,12 +32,6 @@
(define bm (make-object bitmap% semicolon-bitmap-path))
(define (editor-keymap-mixin %)
(class %
(define/override (get-keymaps)
(cons (keymap:get-file) (super get-keymaps)))
(super-instantiate ())))
(define scheme+copy-self% #f)
(define (get-scheme+copy-self%)
(unless scheme+copy-self%
@ -48,7 +42,9 @@
(let ([ed (new scheme+copy-self%)])
(copy-self-to ed)
ed))
(super-new))))
(super-new)
(inherit set-max-undo-history)
(set-max-undo-history 'forever))))
scheme+copy-self%)
(define -snip%

6
collects/framework/private/frame.ss
View File

@ -1933,6 +1933,12 @@
(λ (text evt)
(send (send text get-top-level-window) search 'forward)))
(send search/replace-keymap map-function "c:return" "insert-return")
(send search/replace-keymap map-function "a:return" "insert-return")
(send search/replace-keymap add-function "insert-return"
(λ (text evt)
(send text insert "\n")))
(send search/replace-keymap map-function "esc" "hide-search")
(send search/replace-keymap add-function "hide-search"
(λ (text evt)

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "12sep2008")
#lang scheme/base (provide stamp) (define stamp "13sep2008")

1
collects/scheme/private/contract.ss
View File

@ -23,7 +23,6 @@ improve method arity mismatch contract violation error messages?
(for-syntax syntax/define)
scheme/promise
scheme/stxparam
scheme/stxparam-exptime
mzlib/etc)
(require "contract-arrow.ss"

8
collects/stepper/xml-tool.ss
View File

@ -203,7 +203,9 @@
(let ([t (new scheme-box-text%)])
(copy-self-to t)
t))
(super-new))))
(super-new)
(inherit set-max-undo-history)
(set-max-undo-history 'forever))))
scheme-box-text%)
(define (add-file-keymap-mixin %)
@ -311,7 +313,9 @@
(let ([t (new xml-text%)])
(copy-self-to t)
t))
(super-new))))
(super-new)
(inherit set-max-undo-history)
(set-max-undo-history 'forever))))
xml-text%)))
;; matching-xml : (is-a?/c text) -> void

35
collects/test-engine/scheme-tests.ss
View File

@ -166,12 +166,8 @@
(send (send test-info get-info) check-failed
(check->message result) (check-fail-src result)
(and (incorrect-error? result) (incorrect-error-exn result)))
(list 'check-error-failed
(if (expected-error? result)
(expected-error-message result)
(incorrect-error-message result))
error))
(list 'check-error-succeeded error error))))
#f)
#t)))
(define (error-check pred? actual fmt)
@ -201,31 +197,10 @@
(list (maker src test-val expect range) test-val #f)])))])
(cond [(check-fail? result)
(send (send test-info get-info) check-failed (check->message result) (check-fail-src result) exn?)
(render-for-stepper/fail result expect range kind)]
[else
;; I'd like to pass the actual, but I don't have it.
(render-for-stepper/pass result-val expect range kind)])))
#f]
[else
#t])))
;; render-for-stepper/fail : test-fail? any/c any/c symbol? -> any/c
;; arrange the fail-result as a value that will look tolerable
;; in the stepper's list of completed expressions
(define (render-for-stepper/fail check-fail expected range kind)
(let ([displayed-result (cond [(unexpected-error? check-fail) 'error]
;; I really want actual here, but I'm using test because the thing is
;; created backward, afaict.
[(unequal? check-fail) (unequal-test check-fail)]
[(outofrange? check-fail) (outofrange-test check-fail)])])
(case kind
[(check-expect) (list 'check-expect-failed displayed-result expected)]
[(check-within) (list 'check-within-failed displayed-result expected range)]
[else (error 'render-for-stepper/fail "internal error 2008052801")])))
;; render-for-stepper/pass : any/c any/c any/c symbol? -> any/c
(define (render-for-stepper/pass actual expected range kind)
(case kind
[(check-expect) (list 'check-expect-passed actual expected)]
[(check-within) (list 'check-within-passed actual expected range)]
[else (error 'render-for-stepper/pass "internal error 2008052802")]))
(define (check->message fail)
(cond

45
collects/tests/stepper/through-tests.ss
View File

@ -101,7 +101,7 @@
(for-each (lambda (fn) (apply fn args)) level-fns)))
(define test-mz-sequence
(lang-level-test-sequence 'scheme/base fake-mz-render-settings #t #f))
(lang-level-test-sequence 'mzscheme fake-mz-render-settings #t #f))
(define test-beginner-sequence
(lang-level-test-sequence `(lib "htdp-beginner.ss" "lang")
fake-beginner-render-settings #f #t))
@ -1354,19 +1354,14 @@
; (custodian-shutdown-all new-custodian))
))
(t1 check-expect
(test-bwla-to-int/lam
"(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4)(+ 4 5)"
`((before-after ((hilite (+ 4 5)))
((hilite 9)))
(before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9))))
(9 (check-expect (+ 3 4) (hilite 17))))
(before-after (9 (check-expect (hilite (+ 3 4)) 17))
(9 (check-expect (hilite 7) 17)))
(before-after (9 (list 'check-expect-failed 7 17) (check-expect (hilite (+ 1 1)) 2))
(9 (list 'check-expect-failed 7 17) (check-expect (hilite 2) 2)))
(before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4))
(9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4))))))
(t check-expect test-bwla-to-int/lam
(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4) (+ 4 5)
:: {(+ 4 5)} -> {9}
:: 9 (check-expect (+ 3 4) {(+ 8 9)}) -> 9 (check-expect (+ 3 4) {17})
:: 9 (check-expect {(+ 3 4)} 17) -> 9 (check-expect {7} 17)
:: 9 false (check-expect {(+ 1 1)} 2) -> 9 false (check-expect {2} 2)
:: 9 false true (check-expect {(+ 2 2)} 4) -> 9 false true (check-expect {4} 4))
(t1 check-within
(test-bwla-to-int/lam
@ -1379,8 +1374,8 @@
(9 (check-within (+ 3 4) 18 (hilite 100))))
(before-after (9 (check-within (hilite (+ 3 4)) 18 100))
(9 (check-within (hilite 7) 18 100)))
(before-after (9 (list 'check-within-passed 7 18 100) (check-expect (hilite (+ 1 1)) 2))
(9 (list 'check-within-passed 7 18 100) (check-expect (hilite 2) 2))))))
(before-after (9 true (check-expect (hilite (+ 1 1)) 2))
(9 true (check-expect (hilite 2) 2))))))
(t1 check-within-bad
@ -1392,8 +1387,8 @@
(9 (check-within (+ 3 4) (hilite 18) 0.01)))
(before-after (9 (check-within (hilite (+ 3 4)) 18 0.01))
(9 (check-within (hilite 7) 18 0.01)))
(before-after (9 (list 'check-within-failed 7 18 0.01) (check-expect (hilite (+ 1 1)) 2))
(9 (list 'check-within-failed 7 18 0.01) (check-expect (hilite 2) 2))))))
(before-after (9 false (check-expect (hilite (+ 1 1)) 2))
(9 false (check-expect (hilite 2) 2))))))
(let ([errmsg "rest: expected argument of type <non-empty list>; given ()"])
(t1 check-error
@ -1405,8 +1400,8 @@
(9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg))))
(before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg))
(9 (check-error (+ (hilite 7) (rest empty)) ,errmsg)))
(before-after (9 (list 'check-error-passed ,errmsg ,errmsg) (check-expect (hilite (+ 3 1)) 4))
(9 (list 'check-error-passed ,errmsg ,errmsg) (check-expect (hilite 4) 4)))))))
(before-after (9 true (check-expect (hilite (+ 3 1)) 4))
(9 true (check-expect (hilite 4) 4)))))))
(t1 check-error-bad
(test-bwla-to-int/lam
@ -1417,8 +1412,8 @@
(9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus"))))
(before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus"))
(9 (check-error (+ (hilite 7) (rest empty)) "bogus")))
(before-after (9 (list 'check-error-failed "rest: expected argument of type <non-empty list>; given ()" "bogus") (check-expect (hilite (+ 3 1)) 4))
(9 (list 'check-error-failed "rest: expected argument of type <non-empty list>; given ()" "bogus") (check-expect (hilite 4) 4))))))
(before-after (9 false (check-expect (hilite (+ 3 1)) 4))
(9 false (check-expect (hilite 4) 4))))))
; uses set-render-settings!
;(reconstruct:set-render-settings! fake-beginner-render-settings)
@ -1693,4 +1688,8 @@
#;[store-steps #f]
#;[show-all-steps #t])
#;(run-tests '(check-expect check-within check-within-bad check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error))
(run-all-tests)))
(run-tests '(check-expect check-within check-error check-error-bad))
#;(run-all-tests)))

31
collects/xml/text-snipclass.ss
View File

@ -15,12 +15,25 @@
((null? acc) (cons (car s) (chunk-string (cdr s) null)))
(else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null))))))
(define icon
(let* ((x (make-object bitmap% 10 10))
(y (make-object bitmap-dc% x)))
(send y set-font (make-object font% 24 'default 'normal 'normal ))
(send y draw-text "\"" 0 0)
x))
(define get-icon
(let ([icon #f])
(λ ()
(unless icon
(let ()
(define str "“”")
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1)))
(define font (send the-font-list find-or-create-font 24 'default 'normal 'normal))
(define-values (w h _1 _2) (send bdc get-text-extent str font))
(define bmp (make-object bitmap% (floor (inexact->exact w)) (floor (inexact->exact h))))
(send bdc set-bitmap bmp)
(send bdc set-smoothing 'aligned)
(send bdc set-font font)
(send bdc clear)
(send bdc draw-text str 0 0)
(send bdc set-bitmap #f)
(set! icon bmp)))
icon)))
;; marshall: writable -> string
(define (marshall s)
@ -46,13 +59,15 @@
(define text-box%
(class* decorated-editor-snip% (readable-snip<%>)
(define/override (make-editor) (new text:keymap%))
(define/override (make-editor) (let ([e (new text:keymap%)])
(send e set-max-undo-history 'forever)
e))
(define/override (make-snip) (make-object text-box%))
(inherit get-editor get-admin)
(define/override (get-corner-bitmap)
icon)
(get-icon))
(define/override (get-menu)
(let ([menu (new popup-menu%)])