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

Last change on this file since 27358 was 27358, checked in by felix winkelmann, 8 years ago

latch: added snap (not active yet)

File size: 1.6 KB
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;;XXX
45#;(define (snap from to)
46  (##sys#check-procedure from 'snap)
47  (##sys#check-procedure to 'snap)
48  (let ((fromsize (##sys#size from))
49        (tosize (##sys#size to))
50        (psize (fxmax fromsize tosize)))
51    (define (copy src dest n)
52      (do ((i 0 (fx+ i 1)))
53          ((fx>= i n))
54        (##sys#setslot dest i (##sys#slot src i))))
55    (letrec ((proc
56              (lambda args
57                (let ((from from))      ; copy may overwrite closure-slot of free "from" variable!
58                  (copy to proc tosize) ; does optimizer interfere?
59                  (apply from args)))))
60      (set! psize (fxmax psize (##sys#size proc)))
61      (let ((v (make-vector psize)))
62        (copy proc v (##sys#size proc))
63        (##core#inline "C_vector_to_closure" v)
64        v))))
65
66)
Note: See TracBrowser for help on using the repository browser.