3b630af6f9
moved internal modules to schemeunit/private moved tests to tests/schemeunig added schemeunit/gui drscheme: fixed bug in show-backtrace-window svn: r18243
49 lines
1.2 KiB
Scheme
49 lines
1.2 KiB
Scheme
#lang scheme/base
|
|
(require scheme/contract)
|
|
|
|
;; Add a new kind of promise instead?
|
|
|
|
;; FIXME: handle exceptions like promises?
|
|
|
|
(define (make-cache* thunk)
|
|
(make-cache thunk #f))
|
|
|
|
(define (cache-ref cb)
|
|
(let ([result (cache-result cb)])
|
|
(if result
|
|
(apply values result)
|
|
(call-with-values (cache-thunk cb)
|
|
(lambda result
|
|
(set-cache-result! cb result)
|
|
(apply values result))))))
|
|
|
|
(define (cache-invalidate! cb)
|
|
(set-cache-result! cb #f))
|
|
|
|
(define (cache-printer cb port write?)
|
|
(let ([result (cache-result cb)])
|
|
(if result
|
|
(fprintf port
|
|
(if write? "#<cache!~s>" "#<cache!~a>")
|
|
(if (and (pair? result) (null? (cdr result)))
|
|
(car result)
|
|
(cons 'values result)))
|
|
(fprintf port "#<cache>"))))
|
|
|
|
(define-struct cache (thunk [result #:mutable])
|
|
#:property prop:custom-write cache-printer)
|
|
|
|
(define-syntax-rule (cache* expr)
|
|
(make-cache* (lambda () expr)))
|
|
|
|
(provide (rename-out [cache* cache]))
|
|
(provide/contract
|
|
[rename make-cache* make-cache
|
|
(-> (-> any) cache?)]
|
|
[cache?
|
|
(-> any/c boolean?)]
|
|
[cache-ref
|
|
(-> cache? any)]
|
|
[cache-invalidate!
|
|
(-> cache? any)])
|