Name: Anonymous 2011-01-23 9:31
How can a mere human comprehend a code snippet like this? Scheme might look neat and clever in small chunks, but it's just unsuitable for something bigger, something real. When it grows it starts to mutate in a horrible and unpredictable way that strongly obstructs readability and turns code into a challenge which questions the very ability of the reader to stay sane.
Code is taken from somewhere in the guts of Racket.
Code is taken from somewhere in the guts of Racket.
(define (make-eventspace* th)
(let ([done-sema (make-semaphore 1)]
[done-set? #t]
[frames (make-hasheq)])
(let ([e
(make-eventspace th
(let ([count 0])
(let ([lo (mcons #f #f)]
[refresh (mcons #f #f)]
[med (mcons #f #f)]
[hi (mcons #f #f)]
[timer (box '())]
[timer-counter 0]
[newly-posted-sema (make-semaphore)])
(let* ([check-done
(lambda ()
(if (or (positive? count)
(positive? (hash-count frames))
(not (null? (unbox timer))))
(when done-set?
(hash-set! active-eventspaces th #t)
(set! done-set? #f)
(semaphore-try-wait? done-sema))
(unless done-set?
(hash-remove! active-eventspaces th)
(set! done-set? #t)
(semaphore-post done-sema))))]
[enqueue (lambda (v q)
(set! count (add1 count))
(check-done)
(let ([p (mcons v #f)])
(if (mcdr q)
(set-mcdr! (mcdr q) p)
(set-mcar! q p))
(set-mcdr! q p)))]
[first (lambda (q)
(and (mcar q)
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(set! count (sub1 count))
(check-done)
(let ([result (mcar (mcar q))])
(set-mcar! q (mcdr (mcar q)))
(unless (mcar q)
(set-mcdr! q #f))
(end-atomic)
result)))))]
[remove-timer
(lambda (v timer)
(set-box! timer (rbtree-remove
timed-compare
v
(unbox timer)))
(check-done))])
(case-lambda
[(v)
;; Enqueue
(start-atomic)
(let ([val (cdr v)])
(case (car v)
[(lo) (enqueue val lo)]
[(refresh) (enqueue val refresh)]
[(med) (enqueue val med)]
[(hi) (enqueue val hi)]
[(timer-add)
(set! timer-counter (add1 timer-counter))
(set-timed-id! val timer-counter)
(set-box! timer
(rbtree-insert
timed-compare
val
(unbox timer)))
(check-done)]
[(timer-remove) (remove-timer val timer)]
[(frame-add) (hash-set! frames val #t) (check-done)]
[(frame-remove) (hash-remove! frames val) (check-done)]))
(semaphore-post newly-posted-sema)
(set! newly-posted-sema (make-semaphore))
(check-done)
(end-atomic)]
[()
;; Dequeue as evt
(start-atomic)
(let ([timer-first-ready
(lambda (timer)
(let ([rb (unbox timer)])
(and (not (null? rb))
(let* ([v (rbtree-min (unbox timer))]
[evt (timed-alarm-evt v)])
(and (sync/timeout 0 evt)
;; It's ready
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(remove-timer v timer)
(end-atomic)
(timed-val v))))))))]
[timer-first-wait
(lambda (timer)
(let ([rb (unbox timer)])
(and (not (null? rb))
(wrap-evt
(timed-alarm-evt (rbtree-min (unbox timer)))
(lambda (_) #f)))))])
(let ([e (choice-evt
(wrap-evt (semaphore-peek-evt newly-posted-sema)
(lambda (_) #f))
(or (first hi)
(timer-first-ready timer)
(first refresh)
(first med)
(first lo)
(timer-first-wait timer)
;; nothing else ready...
never-evt))])
(end-atomic)
e))]
[(_1 _2)
;; Dequeue only refresh event
(start-atomic)
(begin0
(or (first refresh) never-evt)
(end-atomic))]))))
frames
(semaphore-peek-evt done-sema)
#f
done-sema
0
(make-hash)
0)]
[cb-box (box #f)])
(parameterize ([current-cb-box cb-box])
(scheme_add_managed (current-custodian)
e
shutdown-eventspace!
cb-box ; retain callback until it's called
0))
e)))