Changeset 27358 in project


Ignore:
Timestamp:
09/01/12 23:01:57 (7 years ago)
Author:
felix winkelmann
Message:

latch: added snap (not active yet)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/latch/trunk/latch.scm

    r18748 r27358  
    4242                          body ...)))))
    4343
     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
    4466)
Note: See TracChangeset for help on using the changeset viewer.