diff --git a/collects/frtime/demos/spreadsheet/spread.ss b/collects/frtime/demos/spreadsheet/spread.ss index b9f21d4b44..182b260903 100644 --- a/collects/frtime/demos/spreadsheet/spread.ss +++ b/collects/frtime/demos/spreadsheet/spread.ss @@ -2,17 +2,20 @@ (require (lib "class.ss") (all-except (lib "mred.ss" "mred") send-event) + (rename mzscheme mz:define-struct define-struct) "preprocessor2.ss" (lifted "ss-funcs.ss" inflate-data) "quotes.ss" (as-is:unchecked (lib "match.ss") match-lambda) + (as-is:unchecked (lib "frp-core.ss" "frtime") signal-value + proc->signal) (lib "framework.ss" "framework") (as-is:unchecked (lib "string.ss") expr->string) (as-is:unchecked (lib "etc.ss") build-vector) (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? eof-object? + exn? open-input-file open-output-file read write hash-table-map file-exists? delete-file open-input-string eof flush-output close-output-port dynamic-require)) @@ -44,7 +47,7 @@ (set-cell! raise-exceptions #t) - (define-struct ss-loc (row col)) + (mz:define-struct ss-loc (row col)) (define (ss-format val) (if (or (and (signal? val) @@ -142,7 +145,7 @@ cols (lambda (_) (make-hash-table)))) - (define-struct ss-cell (expr value updater)) + (mz:define-struct ss-cell (expr value updater)) (define (ss-get-cell-text row col) (cond @@ -212,7 +215,7 @@ (eval `(let ([row ,row] [col ,col]) ,processed-expr)))) - (synchronize) + ;(synchronize) (send canvas draw-cell row col)) (send canvas focus))) diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index d0e1a8f475..7b5b9397f4 100644 --- a/collects/frtime/lang-ext.ss +++ b/collects/frtime/lang-ext.ss @@ -250,9 +250,12 @@ (define-syntax snapshot/sync (syntax-rules () [(_ (id ...) expr ...) - (let-values ([(id ...) (sync/read id ...)]) + (let-values ([(id ...) (value-now/sync id ...)]) expr ...)])) + (define (synchronize) + (snapshot/sync () (void))) + (define-syntax snapshot (syntax-rules () [(_ (id ...) expr ...) @@ -702,6 +705,7 @@ hold for-each-e! snapshot/sync + synchronize snapshot snapshot-e snapshot/apply @@ -736,7 +740,7 @@ value-now/sync frtime-version signal-count - + signal? ) ) diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index 4c508d5180..bb1622d546 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/collects/frtime/mzscheme-core.ss @@ -141,7 +141,10 @@ (lambda (_) (loop (unbox (signal:switching-current v)))) (signal:switching-trigger v))] - [(signal? v) (printf "access to ~a in ~a~n" acc (value-now/no-copy v)) (lift #t acc v)] + [(signal? v) #;(printf "access to ~a in ~a~n" acc + (value-now/no-copy v)) + (lift #t acc v)] + [(undefined? v) undefined] [else (acc v)])))) (define frp:car @@ -252,7 +255,7 @@ ; FORBIDS MUTATION (define (frp:make-struct-field-mutator acc i sym) - (lambda (s) + (lambda (s _) (error "MUTATION NOT ALLOWED IN FrTime STRUCTURES"))) (define-syntax (frp:define-struct stx) @@ -280,11 +283,23 @@ [(_ s (field ...)) #'(frp:define-struct (s #f) (field ...) (current-inspector))])) + (define (find pred lst) + (cond + [(empty? lst) #f] + [(pred (first lst)) (first lst)] + [else (find pred (rest lst))])) + - - - - + (define (ensure-no-signal-args val name) + (if (procedure? val) + (lambda args + (cond + [(find signal? args) + => + (lambda (v) + (raise-type-error name "non-signal" + (format "#" (signal-value v))))] + [else (apply val args)])))) ;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss index 398146ae1c..35d8156724 100644 --- a/collects/frtime/mzscheme-utils.ss +++ b/collects/frtime/mzscheme-utils.ss @@ -306,7 +306,7 @@ seconds->date expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks exn:fail? - list->vector make-vector vector-set!) + list->vector make-vector) (rename eq? mzscheme:eq?) make-exn:fail current-inspector make-inspector