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

..

Browse Source 
original commit: cbff647c7599255653e99c8777ca6266652c9eee
This commit is contained in:
Robby Findler 2002-08-01 04:43:38 +00:00
parent e4cb2634e5
commit b2b08a90cd
2 changed files with 81 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/framework/private/scheme.ss
View File

@ -266,6 +266,7 @@
tabify-selection tabify-selection
tabify-all tabify-all
insert-return insert-return
box-comment-out-selection
comment-out-selection comment-out-selection
uncomment-selection uncomment-selection
get-forward-sexp get-forward-sexp
@ -576,7 +577,8 @@
(set! in-highlight-parens? #f)))) (set! in-highlight-parens? #f))))
(public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
tabify-all insert-return calc-last-para comment-out-selection uncomment-selection tabify-all insert-return calc-last-para
box-comment-out-selection comment-out-selection uncomment-selection
get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
remove-parens-forward) remove-parens-forward)
@ -834,7 +836,28 @@
last-para))) last-para)))
last-para))) last-para)))
(define comment-out-selection (define comment-out-selection
(opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)])
(begin-edit-sequence)
(let ([first-pos-is-first-para-pos?
(= (paragraph-start-position (position-paragraph start-pos))
start-pos)])
(let* ([first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(if (<= curr-para last-para)
(let ([first-on-para (paragraph-start-position curr-para)])
(insert #\; first-on-para)
(para-loop (add1 curr-para))))))
(when first-pos-is-first-para-pos?
(set-position
(paragraph-start-position (position-paragraph (get-start-position)))
(get-end-position))))
(end-edit-sequence)
#t))
(define box-comment-out-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(begin-edit-sequence) (begin-edit-sequence)
@ -1184,6 +1207,8 @@
(lambda (x) (send x insert-return))) (lambda (x) (send x insert-return)))
(add-edit-function "comment-out" (add-edit-function "comment-out"
(lambda (x) (send x comment-out-selection))) (lambda (x) (send x comment-out-selection)))
(add-edit-function "box-comment-out"
(lambda (x) (send x box-comment-out-selection)))
(add-edit-function "uncomment" (add-edit-function "uncomment"
(lambda (x) (send x uncomment-selection)))) (lambda (x) (send x uncomment-selection))))

88
collects/framework/test.ss
View File

@ -243,16 +243,11 @@
;; on the real event queue. ;; on the real event queue.
;; ;;
(define timer-callback%
(class timer%
(init-field thunk)
(define/override (notify) (thunk))
(super-instantiate ())))
(define install-timer (define install-timer
(lambda (msec thunk) (lambda (msec thunk)
(let ([timer (make-object timer-callback% thunk)]) (let ([timer (instantiate timer% ()
(send timer start msec #t)))) [notify-callback (lambda () (thunk))])])
(send timer start msec #t))))
;; ;;
;; Simple accounting of actions and errors. ;; Simple accounting of actions and errors.
@ -339,7 +334,7 @@
;; Note: never more than one timer (of ours) on real event queue. ;; Note: never more than one timer (of ours) on real event queue.
;; ;;
(define run-one '(define run-one
(let ([yield-semaphore (make-semaphore 0)] (let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)]) [thread-semaphore (make-semaphore 0)])
(thread (thread
@ -350,35 +345,60 @@
(semaphore-post yield-semaphore) (semaphore-post yield-semaphore)
(loop)))) (loop))))
(lambda (thunk) (lambda (thunk)
(let ([sem (make-semaphore 0)]) (let ([sem (make-semaphore 0)])
(letrec (letrec ([start
([start (lambda () ;; eventspace main thread
(lambda ()
;; guarantee (probably) that some events are handled
;; guarantee (probably) that some events are handled (semaphore-post thread-semaphore)
(semaphore-post thread-semaphore) (yield yield-semaphore)
(yield yield-semaphore)
(install-timer (run-interval) return)
(install-timer (run-interval) return) (unless (is-exn?)
(unless (is-exn?) (begin-action)
(begin-action) (parameterize ([current-exception-handler
(pass-errors-out thunk) (lambda (exn)
(end-action)))] (end-action-with-error exn)
((error-escape-handler)))])
[pass-errors-out (thunk))
(lambda (thunk) (end-action)))]
(parameterize ([current-exception-handler
(lambda (exn) [return (lambda () (semaphore-post sem))])
(end-action-with-error exn)
((error-escape-handler)))])
(thunk)))]
[return (lambda () (semaphore-post sem))])
(install-timer 0 start) (install-timer 0 start)
(semaphore-wait sem) (semaphore-wait sem)
(reraise-error)))))) (reraise-error))))))
(define run-one
(let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)])
(thread
(rec loop
(lambda ()
(semaphore-wait thread-semaphore)
(sleep)
(semaphore-post yield-semaphore)
(loop))))
(lambda (thunk)
(let ([done (make-semaphore 0)])
(queue-callback
(lambda ()
;; guarantee (probably) that some events are handled
(semaphore-post thread-semaphore)
(yield yield-semaphore)
(queue-callback (lambda () (semaphore-post done)))
(unless (is-exn?)
(begin-action)
(parameterize ([current-exception-handler
(lambda (exn)
(end-action-with-error exn)
((error-escape-handler)))])
(thunk))
(end-action))))
(semaphore-wait done)))))
(define current-get-eventspaces (define current-get-eventspaces
(make-parameter (lambda () (list (current-eventspace))))) (make-parameter (lambda () (list (current-eventspace)))))