Changeset 27358 in project

Timestamp:

09/01/12 23:01:57 (9 years ago)

Author:

felix winkelmann

Message:

latch: added snap (not active yet)

File:

• release/4/latch/trunk/latch.scm (modified) (1 diff)

release/4/latch/trunk/latch.scm

@@ -42 +42 @@
                           body ...)))))
 
+;;XXX
+#;(define (snap from to)
+  (##sys#check-procedure from 'snap)
+  (##sys#check-procedure to 'snap)
+  (let ((fromsize (##sys#size from))
+        (tosize (##sys#size to))
+        (psize (fxmax fromsize tosize)))
+    (define (copy src dest n)
+      (do ((i 0 (fx+ i 1)))
+          ((fx>= i n))
+        (##sys#setslot dest i (##sys#slot src i))))
+    (letrec ((proc 
+              (lambda args
+                (let ((from from))      ; copy may overwrite closure-slot of free "from" variable!
+                  (copy to proc tosize) ; does optimizer interfere?
+                  (apply from args)))))
+      (set! psize (fxmax psize (##sys#size proc)))
+      (let ((v (make-vector psize)))
+        (copy proc v (##sys#size proc))
+        (##core#inline "C_vector_to_closure" v)
+        v))))
+
 )