;;;; latch.scm


(module latch (let-once let*-once)

(import scheme chicken.base)

(import-for-syntax matchable)

(define-syntax let-once
  (er-macro-transformer
   (lambda (x r c)
     (let ((%let (r 'let))
	   (%quote (r 'quote))
	   (%tmp (r 'tmp))
	   (%eq? (r 'eq?))
	   (%if (r 'if)))
       (match (cdr x)
	 (((bindings ...) body ...)
	  (let ((tmps (map (lambda _ (gensym)) bindings)))
	    `(,%let
	      ,(map (lambda (t)
		      (list t (list %quote (vector 'latch#empty))))
		    tmps)
	      (,%let 
	       ,(map (lambda (b t)
		       `(,(car b) 
			 (,%let ((,%tmp (##sys#slot ,t 0)))
				(,%if (,%eq? (,%quote latch#empty) ,%tmp)
				      (,%let ((,%tmp ,(cadr b)))
					     (##sys#setslot ,t 0 ,%tmp)
					     ,%tmp)
				      ,%tmp))))
		     bindings tmps)
	       ,@body)))))))))

(define-syntax let*-once
  (syntax-rules ()
    ((_ () body ...) 
     (let () body ...))
    ((_ (binding1 binding2 ...) body ...)
     (let-once (binding1) 
	       (let*-once (binding2 ...)
			  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))))

)