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-all
insert-return
box-comment-out-selection
comment-out-selection
uncomment-selection
get-forward-sexp
@ -576,7 +577,8 @@
(set! in-highlight-parens? #f))))
(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
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
remove-parens-forward)
@ -834,7 +836,28 @@
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)]
[end-pos (get-end-position)])
(begin-edit-sequence)
@ -1184,6 +1207,8 @@
(lambda (x) (send x insert-return)))
(add-edit-function "comment-out"
(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"
(lambda (x) (send x uncomment-selection))))

88
collects/framework/test.ss
View File

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