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

sync to trunk

Browse Source 
svn: r14964
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-23 23:05:16 +00:00
commit ec3f69f7ba
15 changed files with 76 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/drscheme/syncheck.ss
View File

@ -241,6 +241,8 @@ If the namespace does not, they are colored the unbound color.
;; string))))))
(define arrow-vectors #f)
;; cleanup-texts : (or/c #f (listof text))
(define cleanup-texts #f)
;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))]
;; this is a private field
@ -385,6 +387,7 @@ If the namespace does not, they are colored the unbound color.
(set! tacked-hash-table (make-hasheq))
(set! arrow-vectors (make-hasheq))
(set! bindings-table (make-hash))
(set! cleanup-texts '())
(let ([f (get-top-level-window)])
(when f
(send f open-status-line 'drscheme:check-syntax:mouse-over))))
@ -405,48 +408,69 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(when cleanup-texts
(for-each (λ (text) (send text thaw-colorer))
cleanup-texts))
(set! cleanup-texts #f)
(when any-tacked?
(invalidate-bitmap-cache))
(update-docs-background #f)
(let ([f (get-top-level-window)])
(when f
(send f close-status-line 'drscheme:check-syntax:mouse-over))))))
;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void
(define/public (syncheck:add-to-cleanup-texts txt)
(cond
[cleanup-texts
(unless (memq txt cleanup-texts)
(send txt freeze-colorer)
(set! cleanup-texts (cons txt cleanup-texts)))
#t]
[else #f]))
(define/public (syncheck:add-menu text start-pos end-pos key make-menu)
(when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t)))
(when arrow-vectors
(when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t))))
(define/public (syncheck:add-background-color text color start fin key)
(when (is-a? text text:basic<%>)
(add-to-range/key text start fin (make-colored-region color text start fin) key #f)))
(when arrow-vectors
(when (is-a? text text:basic<%>)
(add-to-range/key text start fin (make-colored-region color text start fin) key #f))))
;; syncheck:add-arrow : symbol text number number text number number boolean -> void
;; pre: start-editor, end-editor are embedded in `this' (or are `this')
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)
(let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f))))
(when arrow-vectors
(let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))))
;; syncheck:add-tail-arrow : text number text number -> void
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos)
(let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
(add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f)))
(when arrow-vectors
(let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
(add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))))
;; syncheck:add-jump-to-definition : text start end id filename -> void
(define/public (syncheck:add-jump-to-definition text start end id filename)
(add-to-range/key text start end (make-def-link id filename) #f #f))
(when arrow-vectors
(add-to-range/key text start end (make-def-link id filename) #f #f)))
;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
(add-to-range/key text pos-left pos-right str #f #f))
(when arrow-vectors
(add-to-range/key text pos-left pos-right str #f #f)))
;; add-to-range/key : text number number any any boolean -> void
;; adds `key' to the range `start' - `end' in the editor
@ -981,17 +1005,12 @@ If the namespace does not, they are colored the unbound color.
(when (is-current-tab?)
(send (get-frame) hide-error-report)))
(define cleanup-texts '())
(define/public (syncheck:clear-highlighting)
(let* ([definitions (get-defs)]
[locked? (send definitions is-locked?)])
(send definitions begin-edit-sequence #f)
(send definitions lock #f)
(send definitions syncheck:clear-arrows)
(for-each (λ (text)
(send text thaw-colorer))
cleanup-texts)
(set! cleanup-texts '())
(send definitions lock locked?)
(send definitions end-edit-sequence)))
@ -1004,12 +1023,6 @@ If the namespace does not, they are colored the unbound color.
(send (get-defs) syncheck:clear-arrows)
(inner (void) on-close))
;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void
(define/public (syncheck:add-to-cleanup-texts txt)
(unless (memq txt cleanup-texts)
(send txt freeze-colorer)
(set! cleanup-texts (cons txt cleanup-texts))))
(super-new)))
(define unit-frame-mixin
@ -2416,8 +2429,8 @@ If the namespace does not, they are colored the unbound color.
(let ([style (send (send source get-style-list)
find-named-style
style-name)])
(add-to-cleanup-texts source)
(send source change-style style start finish #f)))
(when (add-to-cleanup-texts source)
(send source change-style style start finish #f))))
;; hash-table[syntax -o> (listof syntax)] -> void
(define (add-tail-ht-links tail-ht)
@ -2488,10 +2501,9 @@ If the namespace does not, they are colored the unbound color.
;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void
(define (add-to-cleanup-texts ed)
(let ([ed (find-outermost-editor ed)])
(when (is-a? ed drscheme:unit:definitions-text<%>)
(let ([tab (send ed get-tab)])
(send tab syncheck:add-to-cleanup-texts ed)))))
(let ([outermost (find-outermost-editor ed)])
(and (is-a? outermost drscheme:unit:definitions-text<%>)
(send outermost syncheck:add-to-cleanup-texts ed))))
(define (find-outermost-editor ed)
(let loop ([ed ed])

2
collects/redex/private/stepper.ss
View File

@ -647,8 +647,8 @@ todo:
(move-to dot-snip (* n dot-spacing) y) ;; also do the move to
(loop (cdr nodes) (+ y dot-spacing)))])))
(loop (+ n 1)))))))
(send this set-flip-labels? #f)
(super-new)
(send this set-flip-labels? #f)
(inherit set-draw-arrow-heads?)
(set-draw-arrow-heads? #f)))

3
collects/scheme/match/compiler.ss
View File

@ -8,8 +8,7 @@
"reorder.ss"
scheme/struct-info
scheme/stxparam
scheme/nest
(only-in srfi/1 delete-duplicates))
scheme/nest)
(provide compile*)

3
collects/scheme/match/parse-helper.ss
View File

@ -5,8 +5,7 @@
syntax/stx
scheme/struct-info
"patterns.ss"
"compiler.ss"
(only-in srfi/1 delete-duplicates))
"compiler.ss")
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
match-expander-transform trans-match parse-struct

3
collects/scheme/match/parse-legacy.ss
View File

@ -7,8 +7,7 @@
"patterns.ss"
"compiler.ss"
"parse-helper.ss"
"parse-quasi.ss"
(only-in srfi/1 delete-duplicates))
"parse-quasi.ss")
(provide parse/legacy/cert)

3
collects/scheme/match/parse-quasi.ss
View File

@ -6,8 +6,7 @@
scheme/struct-info
"patterns.ss"
"compiler.ss"
"parse-helper.ss"
(only-in srfi/1 delete-duplicates))
"parse-helper.ss")
(provide parse-quasi)

1
collects/scheme/match/parse.ss
View File

@ -7,7 +7,6 @@
"compiler.ss"
"parse-helper.ss"
"parse-quasi.ss"
(only-in srfi/1 delete-duplicates)
(for-template (only-in "runtime.ss" matchable?)
scheme/base))

13
collects/scheme/match/reorder.ss
View File

@ -2,7 +2,6 @@
(require "patterns.ss"
scheme/list
(only-in srfi/1/list take-while)
(for-syntax scheme/base))
(provide reorder-columns)
@ -52,16 +51,20 @@
(define (or-all? ps l)
(ormap (lambda (p) (andmap p l)) ps))
(define (count-while pred l)
(let loop ([l l] [r 0])
(if (or (null? l) (not (pred (car l)))) r (loop (cdr l) (add1 r)))))
(define (score col)
(define n (length col))
(define c (car col))
(define preds (list Var? Pair? Null?))
(cond [(or-all? preds col) (add1 n)]
[(andmap CPat? col) n]
[(Var? c) (length (take-while Var? col))]
[(Pair? c) (length (take-while Pair? col))]
[(Vector? c) (length (take-while Vector? col))]
[(Box? c) (length (take-while Box? col))]
[(Var? c) (count-while Var? col)]
[(Pair? c) (count-while Pair? col)]
[(Vector? c) (count-while Vector? col)]
[(Box? c) (count-while Box? col)]
[else 0]))
(define (reorder-by ps scores*)

4
collects/scribblings/reference/file-ports.scrbl
View File

@ -53,7 +53,7 @@ cases, the port is buffered by default.
The port produced by @scheme[open-input-file] should be explicitly
closed, either though @scheme[close-input-port] or indirectly via
@scheme[custodian-shutdown-all], to release the OS-level file
handle. The input port will not closed automatically if it is
handle. The input port will not be closed automatically if it is
otherwise available for garbage collection (see
@secref["gc-model"]); a @tech{will} could be associated input port
to close it more automatically (see @secref["willexecutor"]).
@ -134,7 +134,7 @@ terminal, in which case is it line buffered bu default.
The port produced by @scheme[open-output-port] should be explicitly
closed, either though @scheme[close-output-port] or indirectly via
@scheme[custodian-shutdown-all], to release the OS-level file
handle. The output port will not closed automatically if it is
handle. The output port will not be closed automatically if it is
otherwise available for garbage collection (see
@secref["gc-model"]); a @tech{will} could be associated input port
to close it more automatically (see @secref["willexecutor"]).

3
collects/scribblings/reference/pairs.scrbl
View File

@ -517,7 +517,8 @@ Returns the last pair of a (possibly improper) list.}
Returns a newly constructed list of length @scheme[k], holding
@scheme[v] in all positions.
@mz-examples[(make-list 7 'foo)]}
@mz-examples[#:eval list-eval
(make-list 7 'foo)]}
@defproc[(take [lst any/c] [pos exact-nonnegative-integer?]) list?]{
Returns a fresh list whose elements are the first @scheme[pos] elements of

3
collects/setup/unixstyle-install.ss
View File

@ -179,7 +179,8 @@
(regexp-replace* #rx"[\"`'$\\]" (dir: 'bin) "\\\\&"))
(write-bytes buf (current-output-port) (cdadr m))))))
(let ([magic (with-input-from-file file (lambda () (read-bytes 10)))])
(cond [(regexp-match #rx#"^\177ELF" magic)
(cond [(or (regexp-match #rx#"^\177ELF" magic)
(regexp-match #rx#"^\316\372\355\376" magic))
(let ([temp (format "~a-temp-for-install"
(regexp-replace* #rx"/" file "_"))])
(with-handlers ([exn? (lambda (e) (delete-file temp) (raise e))])

8
collects/srfi/1/cons.ss
View File

@ -34,7 +34,8 @@
#lang scheme/base
(require srfi/optional "selector.ss" (only-in scheme/list make-list))
(require srfi/optional "selector.ss"
(only-in scheme/list [make-list make-list*]))
(provide xcons
make-list
@ -50,10 +51,7 @@
;; Make a list of length LEN.
;; reprovided from mzscheme
;; (define (make-list len [elt #f])
;; (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
;; (for/list ([i (in-range len)]) elt))
(define (make-list len [elt #f]) (make-list* len elt))
;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.

4
collects/test-engine/test-engine.scm
View File

@ -87,11 +87,11 @@
[else (format "All ~a" count)])
(if (= count 1) "" "s"))))
(define (display-untested-summary port)
(define/public (display-untested-summary port)
(unless (test-silence)
(fprintf port "This program should be tested.~n")))
(define (display-disabled-summary port)
(define/public (display-disabled-summary port)
(fprintf port "Tests disabled.\n"))
(define/public (next-line) (printf "~a" "\n\t"))

4
collects/test-engine/test-info.scm
View File

@ -98,9 +98,9 @@
(formatter (unequal-test fail))
(formatter (unequal-actual fail)))]
[(outofrange? fail)
(print "Actual value ~F is not within ~v of expected value ~F."
(print "Actual value ~F is not within ~a of expected value ~F."
(formatter (outofrange-test fail))
(format (outofrange-range fail))
(formatter (outofrange-range fail))
(formatter (outofrange-actual fail)))]
[(incorrect-error? fail)
(print "check-error encountered the following error instead of the expected ~a~n :: ~a"

4
src/mred/mred.cxx
View File

@ -3152,9 +3152,11 @@ wxFrame *MrEdApp::OnInit(void)
# endif
#endif
#ifdef OS_X
#ifdef wx_mac
# ifdef OS_X
/* Hack to make sure it's referenced, so that xform doesn't throw it away. */
wx_in_terminal = wx_in_terminal;
# endif
#endif
mred_run_from_cmd_line(argc, argv, setup_basic_env);