home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / flic / copy-flic.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.6 KB  |  129 lines  |  [TEXT/CCL2]
  1. ct)
  2.   (copy-flic object '()))
  3.  
  4.  
  5. (define-copy-flic flic-lambda (object var-renamings)
  6.   (let ((new-vars  (map (lambda (v)
  7.               (let ((new  (copy-temp-var (def-name v))))
  8.                 (push (cons v new) var-renamings)
  9.                 (when (var-force-strict? v)
  10.                   (setf (var-force-strict? new) '#t))
  11.                 (init-flic-var new '#f '#f)))
  12.             (flic-lambda-vars object))))
  13.     (make-flic-lambda
  14.       new-vars
  15.       (copy-flic (flic-lambda-body object) var-renamings))))
  16.  
  17.  
  18. ;;; Hack to avoid concatenating multiple gensym suffixes.
  19.  
  20. (define (copy-temp-var sym)
  21.   (if (gensym? sym)
  22.       (let* ((string  (symbol->string sym))
  23.          (n       (string-length string))
  24.          (root    (find-string-prefix string 0 n)))
  25.     (create-temp-var root))
  26.       (create-temp-var sym)))
  27.  
  28. (define (find-string-prefix string i n)
  29.   (declare (type string string) (type fixnum i n))
  30.   (cond ((eqv? i n)
  31.      string)
  32.     ((char-numeric? (string-ref string i))
  33.      (substring string 0 i))
  34.     (else
  35.      (find-string-prefix string (+ i 1) n))))
  36.  
  37.  
  38. (define-copy-flic flic-let (object var-renamings)
  39.   (let ((new-vars  (map (lambda (v)
  40.               (let ((new  (copy-temp-var (def-name v))))
  41.                 (when (var-inline? v)
  42.                   (setf (var-inline? new) '#t))
  43.                 (when (var-always-inline? v)
  44.                   (setf (var-always-inline? new) '#t))
  45.                 (push (cons v new) var-renamings)
  46.                 new))
  47.             (flic-let-bindings object))))
  48.     (for-each
  49.       (lambda (new old)
  50.     (init-flic-var new (copy-flic (var-value old) var-renamings) '#f))
  51.       new-vars
  52.       (flic-let-bindings object))
  53.     (make-flic-let
  54.       new-vars
  55.       (copy-flic (flic-let-body object) var-renamings)
  56.       (flic-let-recursive? object))))
  57.  
  58. (define-copy-flic flic-app (object var-renamings)
  59.   (make-flic-app
  60.     (copy-flic (flic-app-fn object) var-renamings)
  61.     (copy-flic-list (flic-app-args object) var-renamings)
  62.     (flic-app-saturated? object)))
  63.  
  64. (define-copy-flic flic-ref (object var-renamings)
  65.   (let* ((var   (flic-ref-var object))
  66.      (entry (assq var var-renamings)))
  67.     (if entry
  68.     (make-flic-ref (cdr entry))
  69.     (make-flic-ref var))))   ; don't share structure
  70.  
  71.  
  72. (define-copy-flic flic-const (object var-renamings)
  73.   (declare (ignore var-renamings))
  74.   (make-flic-const (flic-const-value object)))  ; don't share structure
  75.  
  76. (define-copy-flic flic-pack (object var-renamings)
  77.   (declare (ignore var-renamings))
  78.   (make-flic-pack (flic-pack-con object)))      ; don't share structure
  79.  
  80.  
  81. ;;; Don't have to gensym new block names; these constructs always
  82. ;;; happen in pairs.
  83.  
  84. (define-copy-flic flic-case-block (object var-renamings)
  85.   (make-flic-case-block
  86.     (flic-case-block-block-name object)
  87.     (copy-flic-list (flic-case-block-exps object) var-renamings)))
  88.  
  89. (define-copy-flic flic-return-from (object var-renamings)
  90.   (make-flic-return-from
  91.     (flic-return-from-block-name object)
  92.     (copy-flic (flic-return-from-exp object) var-renamings)))
  93.  
  94. (define-copy-flic flic-and (object var-renamings)
  95.   (make-flic-and
  96.     (copy-flic-list (flic-and-exps object) var-renamings)))
  97.  
  98. (define-copy-flic flic-if (object var-renamings)
  99.   (make-flic-if
  100.     (copy-flic (flic-if-test-exp object) var-renamings)
  101.     (copy-flic (flic-if-then-exp object) var-renamings)
  102.     (copy-flic (flic-if-else-exp object) var-renamings)))
  103.  
  104. (define-copy-flic flic-sel (object var-renamings)
  105.   (make-flic-sel
  106.     (flic-sel-con object)
  107.     (flic-sel-i object)
  108.     (copy-flic (flic-sel-exp object) var-renamings)))
  109.  
  110. (define-copy-flic flic-is-constructor (object var-renamings)
  111.   (make-flic-is-constructor
  112.     (flic-is-constructor-con object)
  113.     (copy-flic (flic-is-constructor-exp object) var-renamings)))
  114.  
  115. (define-copy-flic flic-con-number (object var-renamings)
  116.   (make-flic-con-number
  117.     (flic-con-number-type object)
  118.     (copy-flic (flic-con-number-exp object) var-renamings)))
  119.  
  120. (define-copy-flic flic-void (object var-renamings)
  121.   (declare (ignore object var-renamings))
  122.   (make-flic-void))   ; don't share structure
  123.   
  124.  
  125. (define-copy-flic flic-update (object var-renamings)
  126.   (make-flic-update
  127.     (flic-update-con object)
  128.     (map (lambda (x) (cons (car x) (copy-flic (cdr x) var-renamings)))
  129.      (flic-upda