1 files changed, 121 insertions, 0 deletions
diff --git a/import-export/ie-utils.scm b/import-export/ie-utils.scm
new file mode 100644
index 0000000..20b6c1d
--- /dev/null
+++ b/import-export/ie-utils.scm
@@ -0,0 +1,121 @@
+
+;;; This file contains utilities, globals, and macros used by the
+;;; import-export system.
+
+(define *new-exports-found?* '#f)  ; used by the fixpoint iteration
+
+;;; A group is a collection of related symbols.  It is represented
+;;; by a list of (name,def) pairs.  The first element is the head
+;;; of the group; the group is entered in the export table under the
+;;; name of the head only.  Groups for vars and synonyms have only the
+;;; head.  Data types and classes have the constructors or methods in
+;;; the tail of the group.
+
+(define (group-name x)  ; name of the head
+  (tuple-2-1 (car x)))
+
+(define (group-definition x) ; definition of the head
+  (tuple-2-2 (car x)))
+
+;;; The name & entry are the head of the group.  Others is a list of
+;;; name - definition pairs.
+(define (make-group name entry . others)
+  (if (null? others)
+      (list (cons name entry))
+      (cons (cons name entry) (car others))))
+
+(define (hidden-constructors? group)
+  (null? (cdr group)))
+
+(define (strip-constructors group)
+  (list (car group)))
+
+;;; rename-group applies the current renaming  to every
+;;;  name in a group.  When uses, a renaming is marked to allow unused
+;;;  renamings to be detected.
+
+(define (rename-group g renamings)
+  (if (null? renamings)
+      g
+      (map (lambda (n-d)
+	     (let* ((def (tuple-2-2 n-d))
+		    (keep-name? (or (con? def) (var? def)))
+		    (n (tuple-2-1 n-d))
+		    (name (if keep-name? n (add-con-prefix/symbol n)))
+		    (renaming (locate-renaming name renamings)))
+	       (cond (renaming
+		      (let ((new-name
+			     (if keep-name?
+				 (renaming-to renaming)
+				 (remove-con-prefix/symbol
+				   (renaming-to renaming)))))
+			(when (and (def-prelude? def)
+				   (not (eq? (def-name def) new-name)))
+			    (signal-prelude-renaming def new-name)
+			    (setf new-name (def-name def)))
+			(setf (renaming-referenced? renaming) '#t)
+			(tuple new-name def)))
+		     (else n-d))))
+	   g)))
+
+(define (locate-renaming name renamings)
+  (if (null? renamings)
+      '#f
+      (if (eq? name (renaming-from (car renamings)))
+	  (car renamings)
+	  (locate-renaming name (cdr renamings)))))
+
+(define (gather-algdata-group name def)
+  (cons (tuple name def)
+	(gather-group (algdata-constrs def))))
+
+(define (gather-class-group name def)
+  (cons (tuple name def)
+	(gather-group (class-method-vars def))))
+
+(define (gather-group defs)
+  (if (null? defs)
+      '()
+      (let ((local-name (local-name (car defs))))
+	(if (eq? local-name '#f)
+	    '()
+	    (cons (tuple local-name (car defs))
+		  (gather-group (cdr defs)))))))
+
+;;; These deal with `hiding' lists.
+
+;;; Note: as per the new report, no need to worry about anything but the
+;;; group head and the entity name since only var, Class(..),Alg(..) allowed
+
+(define (in-hiding-list? group hiding)
+  (cond ((null? hiding)
+	 '#f)
+	((eq? (entity-name (car hiding)) (group-name group))
+	 '#t)
+	(else (in-hiding-list? group (cdr hiding)))))
+
+(define (remove-entity group hiding)
+  (cond ((eq? (entity-name (car hiding)) (group-name group))
+	 (cdr hiding))
+	(else (cons (car hiding) (remove-entity group (cdr hiding))))))
+
+;;; This moves fixity information to the local symbols.  This must be
+;;; called after local symbols are installed but before imported
+;;; symbols arrive.
+
+(define (attach-fixities)
+  (dolist (fixity-decl (module-fixities *module*))
+    (let ((fixity (fixity-decl-fixity fixity-decl)))
+      (dolist (op (fixity-decl-names fixity-decl))
+        (let ((def (resolve-toplevel-name op)))
+	  (cond ((or (eq? def '#f) (not (eq? *module-name* (def-module def))))
+		 ;;; ***This is WRONG!  Inner fixities may be found.
+		 (signal-non-local-fixity op))
+		((var? def)
+		 (setf (var-fixity def) fixity)
+		 (setf (table-entry *fixity-table* op) fixity))
+		((con? def)
+		 (setf (con-fixity def) fixity)
+		 (setf (table-entry *fixity-table* op) fixity))
+		(else (signal-fixity-not-var/con op))))))))
+