minor changes + fixes to demos:

svn: r818

collects/frtime/demos/analog-clock.ss

@@ -31,7 +31,8 @@
    (clicks-in-clock
     . -=> .
     (snapshot (mouse-pos clock-center)
-              (posn- mouse-pos clock-center)))))
+              (posn- mouse-pos clock-center)))
+   #;(make-posn 0 0)))
 
 ;; Define follow-mouse which is true when the center of the clock
 ;; should be at the mouse cursor; false when it is at the last 
@@ -47,9 +48,9 @@
   (rec p
     (inf-delay
      (until (make-posn 200 200)
-            (let ([p1 (posn- mouse-pos offset)])
+            (let ([p1 0])
               (if follow-mouse?
-                  p1
+                  (posn- mouse-pos offset)
                   p))))))
 
 ;; Define the length of the hands in terms of the radius of the clock.

collects/frtime/demos/spreadsheet/spread.ss

@@ -12,7 +12,7 @@
            (lib "framework.ss" "framework")
            (as-is:unchecked (lib "string.ss") expr->string)
            (as-is:unchecked (lib "etc.ss") build-vector)
-           (lifted mzscheme regexp-match)
+           ;(lifted mzscheme regexp-match)
            (as-is:unchecked mzscheme make-hash-table hash-table-put! hash-table-get
                             hash-table-remove! let*-values vector-set! make-string
                             exn?
@@ -346,10 +346,10 @@
        
        [scrollbar-updater
         (list
-         (lift #t (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
+         (lift-strict (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~)
-         (lift #t (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
+         (lift-strict (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~)
-         (lift #t (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
+         (lift-strict (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~)
-         (lift #t (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
+         (lift-strict (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))]
        
        [scroller ((merge-e (changes h-scroll-pos~)
                            (changes v-scroll-pos~)) . -=> . (refresh))]
@@ -409,7 +409,7 @@
        [focuser ((key-events . =#> . (lambda (ev) (eq? #\return (send ev get-key-code))))
                  . -=> . (send text-field focus))]
        
-       [text-field-switcher (lift #t (lambda (row col)
+       [text-field-switcher (lift-strict (lambda (row col)
                                        (unless (or (negative? row)
                                                    (negative? col))
                                          (send text-field set-value (ss-get-cell-text row col))))

collects/frtime/frp-core.ss

@@ -142,6 +142,17 @@
   ; update the given signal at the given time
   (define-struct alarm (time signal))  
   
+  (define extra-cont-marks (make-parameter #f))
+
+  (define (effective-continuation-marks)
+    (if (extra-cont-marks)
+        (begin
+          #;(thread (lambda () (raise (make-exn:fail
+                                     "extra marks present!" (extra-cont-marks)))))
+          (compose-continuation-mark-sets
+           (extra-cont-marks)
+           (current-continuation-marks)))
+        (current-continuation-marks)))
   
   ;; Simple Structure Combinators
   
@@ -162,7 +173,7 @@
       (apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps)))
   
   (define (build-signal ctor thunk producers)
-    (let ([ccm (current-continuation-marks)])
+    (let ([ccm (effective-continuation-marks)])
       (do-in-manager
        (let* ([custs (current-custs)]
               [cust-sigs (map ft-cust-signal custs)]
@@ -172,7 +183,8 @@
                                                (map safe-signal-depth cust-sigs))))
                     ccm
                     (parameterize ([current-exception-handler
-                                    (lambda (exn) (exn-handler exn))])
+                                    (lambda (exn) (exn-handler exn))]
+                                   [extra-cont-marks ccm])
                       (current-parameterization))
                     (append cust-sigs producers))])
          ;(printf "~a custodians~n" (length custs))
@@ -187,7 +199,7 @@
          sig))))
   
   (define (proc->signal:switching thunk current-box trigger . producers)
-    (let ([ccm (current-continuation-marks)])
+    (let ([ccm (effective-continuation-marks)])
       (do-in-manager
        (let* ([custs (current-custs)]
               [cust-sigs (map ft-cust-signal custs)]
@@ -197,7 +209,8 @@
                                                (map safe-signal-depth cust-sigs))))
                     ccm
                     (parameterize ([current-exception-handler
-                                    (lambda (exn) (exn-handler exn))])
+                                    (lambda (exn) (exn-handler exn))]
+                                   [extra-cont-marks ccm])
                       (current-parameterization))
                     (append cust-sigs producers)
                     current-box
@@ -221,6 +234,7 @@
   
   ;; mutate! : compound num -> (any -> ())
   (define (procs->signal:compound ctor mutate! . args)
+    (let ([ccm (effective-continuation-marks)])
       (do-in-manager
        (let* ([custs (current-custs)]
               [cust-sigs (map ft-cust-signal custs)]
@@ -254,9 +268,10 @@
                               val)))
                       (add1 (apply max 0 (append (map safe-signal-depth args)
                                                  (map safe-signal-depth cust-sigs))))
-                  (current-continuation-marks)
+                      ccm
                       (parameterize ([current-exception-handler
-                                    (lambda (exn) (exn-handler exn))])
+                                      (lambda (exn) (exn-handler exn))]
+                                     [extra-cont-marks ccm])
                         (current-parameterization))
                       (append cust-sigs args)
                       (apply ctor args)
@@ -271,7 +286,7 @@
                    custs)
          (iq-enqueue sig)
          ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
-       sig)))
+         sig))))
   
   
   
@@ -597,6 +612,8 @@
   
   (define (super-lift fun bhvr)
     (if (behavior? bhvr)
+        (parameterize ([extra-cont-marks
+                        (effective-continuation-marks)])
           (do-in-manager
            (let* ([cust (make-ft-cust (void) empty)]
                   [custs (cons cust (current-custs))]
@@ -622,7 +639,7 @@
                             (lambda () custodian-signal (value-now/no-copy (unbox current)))
                             current custodian-signal undefined bhvr custodian-signal)])
                (set-ft-cust-signal! cust custodian-signal)
-             rtn)))
+               rtn))))
         (fun bhvr)))
   
   
@@ -725,11 +742,14 @@
                           (lambda (exn)
                             (when (and cur-beh
                                        #;(not (undefined? (signal-value cur-beh))))
-                              #;(when (empty? (continuation-mark-set->list
+                              ;(when (empty? (continuation-mark-set->list
-                                             (exn-continuation-marks exn) 'frtime))
+                               ;              (exn-continuation-marks exn) 'frtime))
-                                (set! exn (make-exn:fail (exn-message exn)
+                                (set! exn (make-exn:fail
+                                           (exn-message exn)
+                                           (compose-continuation-mark-sets
                                             (signal-continuation-marks
-                                                          cur-beh))))
+                                             cur-beh)
+                                            (exn-continuation-marks exn))));)
                               ;(raise exn)
                               (iq-enqueue (list exceptions (list exn cur-beh)))
                               (when (behavior? cur-beh)

collects/frtime/lang-ext.ss

@@ -526,6 +526,92 @@
                        out)])
           (apply proc->signal thunk args)))))
   
+  (define current-emit (make-parameter #f))
+  (define current-select (make-parameter #f))
+  (define (emit ev)
+    (cond
+      [(current-emit) => (lambda (f) (f ev))]
+      [else (error 'emit "outside of general-event-processor")]))
+  (define (select-proc . clauses)
+    (cond
+      [(current-select) => (lambda (f) (apply f clauses))]
+      [else (error 'select "outside of general-event-processor")]))
+  
+  (define-syntax (select stx)
+    (syntax-case stx ()
+      [(select clause ...)
+       (with-syntax ([((e k) ...)
+                      (map (lambda (c)
+                             (syntax-case c (=>)
+                               [(e => k) #'(e k)]
+                               [(e exp0 exp1 ...) #'(e (lambda (_) exp0 exp1 ...))]))
+                           (syntax-e #'(clause ...)))])
+         #'(select-proc (list e k) ...))]))
+  
+  (define (flush . strs)
+    (select-proc (map (lambda (str) (list str void)) strs)))
+  
+  (define (general-event-processor2 proc)
+    (do-in-manager
+     (let* ([out (econs undefined undefined)]
+            [emit (lambda (val)
+                    (set-erest! out (econs val undefined))
+                    (set! out (erest out))
+                    val)]
+            [streams (make-hash-table 'weak)]
+            [extracted (make-hash-table 'weak)]
+            [top-esc #f]
+            [rtn (proc->signal void)]
+            [select (lambda e/k-list
+                      (let/ec esc
+                        (let loop ()
+                          (for-each (lambda (e/k)
+                                      (let* ([e (first e/k)]
+                                             [x (hash-table-get
+                                                 extracted e
+                                                 (lambda () empty))])
+                                        (when (cons? x)
+                                          (hash-table-put!
+                                           extracted e (rest x))
+                                          (esc ((second e/k) (first x))))))
+                                    e/k-list)
+                          (for-each (lambda (e/k)
+                                      (let* ([e (first e/k)])
+                                        (hash-table-get
+                                         streams e
+                                         (lambda ()
+                                           (register rtn e)
+                                           (hash-table-put!
+                                            streams e
+                                            (signal-value e))))))
+                                    e/k-list)
+                          (let/cc k
+                            (set! proc (lambda () (k (void))))
+                            (top-esc (void)))
+                          (loop))))])
+       (let ([thunk (lambda ()
+                      (hash-table-for-each
+                       streams
+                       (lambda (k v)
+                         ;; inefficient! appends each new event individually
+                         (let loop ([str v])
+                           (when (and (econs? str)
+                                      (not (undefined? (erest str))))
+                             (hash-table-put!
+                              extracted k
+                              (append (hash-table-get extracted k (lambda () empty))
+                                      (list (efirst (erest str)))))
+                             (loop (erest str))))
+                         (hash-table-put! streams k (signal-value k))))
+                      (let/cc k
+                        (set! top-esc k)
+                        (parameterize ([current-emit emit]
+                                       [current-select select])
+                          (proc)))
+                      out)])
+         (set-signal-thunk! rtn thunk)
+         (iq-enqueue rtn)
+         rtn))))
   
   (define (event-processor proc . args)
     (let* ([out (econs undefined undefined)]
@@ -546,7 +632,27 @@
                     out)])
       (apply proc->signal thunk args)))
   
+  ;; split : event[a] (a -> b) -> (b -> event[a])
+  (define (split ev fn)
+    (let* ([ht (make-hash-table 'weak)]
+           [sig (map-e (lambda (e)
+                         (let/ec k
+                           (send-event
+                            (hash-table-get ht (fn e) (lambda () (k (void))))
+                            e)))
+                       ev)])                             
+      (lambda (x)
+        sig
+        (hash-table-get
+         ht x (lambda ()
+                (let ([rtn (event-receiver)])
+                  (hash-table-put! ht x rtn)
+                  rtn))))))
   
+  (define-syntax event-select
+    (syntax-rules ()
+      [(_ [ev k] ...)
+       ()]))
   
     ;;;;;;;;;;;;;;;;;;;;;;
   ;; Command Lambda 
@@ -678,6 +784,9 @@
            nothing
            nothing?
            general-event-processor
+           general-event-processor2
+           emit
+           select
            event-processor
            switch
            merge-e
@@ -719,6 +828,7 @@
            mk-command-lambda
            until
            event-loop
+           split
            
            ;; from frp-core
            event-receiver