source: project/release/4/latch/trunk/latch.scm @ 18748

Last change on this file since 18748 was 18748, checked in by felix winkelmann, 10 years ago

added latch

File size: 935 bytes
Line 
1;;;; latch.scm
2
3
4(module latch (let-once let*-once)
5 
6(import scheme chicken)
7
8(import-for-syntax matchable)
9
10(define-syntax (let-once x r c)
11  (let ((%let (r 'let))
12        (%quote (r 'quote))
13        (%tmp (r 'tmp))
14        (%eq? (r 'eq?))
15        (%if (r 'if)))
16    (match (cdr x)
17      (((bindings ...) body ...)
18       (let ((tmps (map (lambda _ (gensym)) bindings)))
19         `(,%let
20           ,(map (lambda (t)
21                   (list t (list %quote (vector '#%novalue))))
22                 tmps)
23           (,%let 
24            ,(map (lambda (b t)
25                    `(,(car b) 
26                      (,%let ((,%tmp (##sys#slot ,t 0)))
27                             (,%if (,%eq? (,%quote #%novalue) ,%tmp)
28                                   (,%let ((,%tmp ,(cadr b)))
29                                          (##sys#setslot ,t 0 ,%tmp)
30                                          ,%tmp)
31                                   ,%tmp))))
32                  bindings tmps)
33            ,@body)))))))
34
35(define-syntax let*-once
36  (syntax-rules ()
37    ((_ () body ...) 
38     (let () body ...))
39    ((_ (binding1 binding2 ...) body ...)
40     (let-once (binding1) 
41               (let*-once (binding2 ...)
42                          body ...)))))
43
44)
Note: See TracBrowser for help on using the repository browser.