diff options
Diffstat (limited to 'flic/copy-flic.scm')
| -rw-r--r-- | flic/copy-flic.scm | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/flic/copy-flic.scm b/flic/copy-flic.scm new file mode 100644 index 0000000..373fbd4 --- /dev/null +++ b/flic/copy-flic.scm @@ -0,0 +1,146 @@ +;;; 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 + + + + + + |