From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 flic/copy-flic.scm | 146 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 146 insertions(+)
 create mode 100644 flic/copy-flic.scm

(limited to 'flic/copy-flic.scm')

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
+  
+
+	
+     
+
+    
-- 
cgit v1.2.3