;;; copy-flic.scm -- general copy functions for flic structures
;;;
;;; author :  Sandra Loosemore
;;; date   :  23 Feb 1993
;;;
;;;


;;; The var-renamings argument is an a-list.  It's used to map local vars
;;; in the input expression to new, gensymed vars.

(define-flic-walker copy-flic (object var-renamings))

(define (copy-flic-list objects var-renamings)
  (let ((result  '()))
    (dolist (o objects)
      (push (copy-flic o var-renamings) result))
    (nreverse result)))


(define (copy-flic-top object)
  (copy-flic object '()))


(define-copy-flic flic-lambda (object var-renamings)
  (let ((new-vars  (map (lambda (v)
			  (let ((new  (copy-temp-var (def-name v))))
			    (push (cons v new) var-renamings)
			    (when (var-force-strict? v)
			      (setf (var-force-strict? new) '#t))
			    (init-flic-var new '#f '#f)))
			(flic-lambda-vars object))))
    (make-flic-lambda
      new-vars
      (copy-flic (flic-lambda-body object) var-renamings))))


;;; Hack to avoid concatenating multiple gensym suffixes.

(define (copy-temp-var sym)
  (if (gensym? sym)
      (let* ((string  (symbol->string sym))
	     (n       (string-length string))
	     (root    (find-string-prefix string 0 n)))
	(create-temp-var root))
      (create-temp-var sym)))

(define (find-string-prefix string i n)
  (declare (type string string) (type fixnum i n))
  (cond ((eqv? i n)
	 string)
	((char-numeric? (string-ref string i))
	 (substring string 0 i))
	(else
	 (find-string-prefix string (+ i 1) n))))


(define-copy-flic flic-let (object var-renamings)
  (let ((new-vars  (map (lambda (v)
			  (let ((new  (copy-temp-var (def-name v))))
			    (when (var-force-inline? v)
			      (setf (var-force-inline? new) '#t))
			    (push (cons v new) var-renamings)
			    new))
			(flic-let-bindings object))))
    (for-each
      (lambda (new old)
	(init-flic-var new (copy-flic (var-value old) var-renamings) '#f))
      new-vars
      (flic-let-bindings object))
    (make-flic-let
      new-vars
      (copy-flic (flic-let-body object) var-renamings)
      (flic-let-recursive? object))))

(define-copy-flic flic-app (object var-renamings)
  (make-flic-app
    (copy-flic (flic-app-fn object) var-renamings)
    (copy-flic-list (flic-app-args object) var-renamings)
    (flic-app-saturated? object)))

(define-copy-flic flic-ref (object var-renamings)
  (let* ((var   (flic-ref-var object))
	 (entry (assq var var-renamings)))
    (if entry
	(make-flic-ref (cdr entry))
	(make-flic-ref var))))   ; don't share structure


(define-copy-flic flic-const (object var-renamings)
  (declare (ignore var-renamings))
  (make-flic-const (flic-const-value object)))  ; don't share structure

(define-copy-flic flic-pack (object var-renamings)
  (declare (ignore var-renamings))
  (make-flic-pack (flic-pack-con object)))      ; don't share structure


;;; Don't have to gensym new block names; these constructs always
;;; happen in pairs.

(define-copy-flic flic-case-block (object var-renamings)
  (make-flic-case-block
    (flic-case-block-block-name object)
    (copy-flic-list (flic-case-block-exps object) var-renamings)))

(define-copy-flic flic-return-from (object var-renamings)
  (make-flic-return-from
    (flic-return-from-block-name object)
    (copy-flic (flic-return-from-exp object) var-renamings)))

(define-copy-flic flic-and (object var-renamings)
  (make-flic-and
    (copy-flic-list (flic-and-exps object) var-renamings)))

(define-copy-flic flic-if (object var-renamings)
  (make-flic-if
    (copy-flic (flic-if-test-exp object) var-renamings)
    (copy-flic (flic-if-then-exp object) var-renamings)
    (copy-flic (flic-if-else-exp object) var-renamings)))

(define-copy-flic flic-sel (object var-renamings)
  (make-flic-sel
    (flic-sel-con object)
    (flic-sel-i object)
    (copy-flic (flic-sel-exp object) var-renamings)))

(define-copy-flic flic-is-constructor (object var-renamings)
  (make-flic-is-constructor
    (flic-is-constructor-con object)
    (copy-flic (flic-is-constructor-exp object) var-renamings)))

(define-copy-flic flic-con-number (object var-renamings)
  (make-flic-con-number
    (flic-con-number-type object)
    (copy-flic (flic-con-number-exp object) var-renamings)))

(define-copy-flic flic-void (object var-renamings)
  (declare (ignore object var-renamings))
  (make-flic-void))   ; don't share structure