Import to github.

8 files changed, 881 insertions, 0 deletions

diff --git a/import-export/README b/import-export/README
new file mode 100644
index 0000000..4bd3bc4
--- /dev/null
+++ b/import-export/README
@@ -0,0 +1,15 @@
+This is the import / export phase.  This process is accomplished as follows:
+
+a) Local definitions are created in each module.  These are entered into the
+   local symbol table.
+b) Imports to non-local modules are completely resolved.
+c) Local import/export is performed via a fixpoint:
+    1) Export: definitions added in the previous round are filtered by the
+       export list and placed in a fresh export list.
+    2) Each module imports from the fresh export list of the other modules.
+       Any import not already present is placed on a new fresh export list.
+   When no fresh exports are generated, the iteration is complete.
+d) Missing exports and imports are checked for.
+
+
+
diff --git a/import-export/ie-errors.scm b/import-export/ie-errors.scm
new file mode 100644
index 0000000..16180f5
--- /dev/null
+++ b/import-export/ie-errors.scm
@@ -0,0 +1,154 @@
+;;; Error checks & calls for the import-export code
+
+;;; this is called at the end of import-export to look for
+;;;  a) exported entities that were never found
+;;;  b) imported entities that were never found
+;;;  c) renamed entities that were never found
+;;;  d) hidden entities that were never found
+
+(define (check-missing-names)
+  (dolist (export (module-exports *module*))
+    (remember-context export
+      (signal-missing-export export)))
+  (dolist (import-decl (module-imports *module*))
+    (remember-context import-decl
+      (with-slots import-decl (mode specs renamings) import-decl
+        ;; *** I'm confused.  Aren't these errors already detected
+	;; *** by import-all-entities and import-named-entities?
+	;; jcp: no - a final check is needed after all symbols have moved.
+        (cond ((eq? mode 'all)
+	       (dolist (entity specs)
+		 (signal-unused-hiding
+		   (entity-name entity)
+		   (import-decl-module-name import-decl))))
+	      (else
+	       (dolist (entity specs)
+		 (signal-entity-not-found
+		   (entity-name entity)
+		   (import-decl-module-name import-decl)))))
+	(find-unused-renamings renamings import-decl)))))
+
+(define (find-unused-renamings renamings import-decl)
+  (dolist (r renamings)
+    (when (not (renaming-referenced? r))
+      (remember-context r
+	(signal-unused-renaming (renaming-from r)
+				(import-decl-module-name import-decl))))))
+
+(define (check-duplicates l entity)
+  (when (not (null? (find-duplicates l)))
+    (signal-duplicate-names-in-entity entity)))
+
+;;; There are a ton of possible errors in import-export.  All error
+;;; calls are found here:
+
+(define (signal-missing-export export)
+  (recoverable-error 'missing-export
+    "Module ~A exports ~A, but provides no definition for it."
+    *module-name* export))
+
+(define (signal-unused-renaming name module-name)
+  (recoverable-error 'unused-renaming
+    "The name ~a is included in the renaming list of an import declaration,~%~
+     but is not among the entities being imported from module ~a."
+    name module-name))
+
+(define (signal-unused-hiding name module-name)
+  (recoverable-error 'unused-hiding
+    "The name ~a is included in the hiding list of an import declaration,~%~
+     but is not among the entities exported from module ~a."
+    name module-name))
+
+(define (signal-multiple-name-conflict name old-local-name def)
+  (recoverable-error 'multiple-name-conflict
+    "In module ~A, the symbol ~A from module ~A is known as both ~A and ~A."
+    *module-name* (def-name def) (def-module def) name old-local-name))
+
+
+(define (signal-undefined-module-import name)
+  (fatal-error 'undefined-module-import
+	       "Cannot find module ~A, imported by module ~A."
+	       name *module-name*))
+
+
+(define (signal-undefined-module-export name)		
+  (fatal-error 'undefined-module-export
+	       "Cannot find module ~A, exported by module ~A."
+	       name *module-name*))
+
+
+(define (signal-self-import name)
+  (fatal-error 'self-import
+	       "Module ~A cannot import itself."
+	       name))
+
+(define (signal-missing-prelude)
+  (fatal-error 'missing-prelude "Can't find module Prelude."))
+
+(define (signal-missing-prelude-core)
+  (fatal-error 'missing-prelude "Can't find module PreludeCore."))
+
+(define (signal-export-not-imported name)
+  (recoverable-error 'export-not-imported
+    "Module ~A is exported from ~A,~%~
+     but is not also imported into that module."
+    name *module-name*))
+
+(define (signal-entity-not-found name module-name)
+  (fatal-error 'entity-not-found
+    "The entity ~a is not exported from module ~a." name module-name))
+
+(define (signal-synonym-needs-dots name module-name)
+  (declare (ignore module-name))
+  (fatal-error 'synonym-needs-dots
+    "The entity ~a is a type synonym; to name it in an import or export~%~
+     list, you must use `~a(..)' as the entity."
+    name name))
+
+(define (signal-wrong-definition expected name module-name)
+  (fatal-error 'wrong-definition
+    "The entity ~a does not name a ~a in module ~a."
+    name expected module-name))
+
+(define (signal-abstract-type name module-name)
+  (fatal-error 'abstract-type
+    "The entity ~a names an abstract type in module ~a;~%~
+     you cannot import or export its constructors."
+    name module-name))
+
+(define (signal-extra-constituent entity name what)
+  (fatal-error 'extra-constituent
+    "The entity specification ~a includes the ~a name ~a,~%~
+     which is not present in its definition."
+    entity what name))
+
+(define (signal-missing-constituent entity name what)
+  (fatal-error 'missing-constituent
+    "The entity specification ~a does not include the ~a name ~a,~%~
+     which is part of its definition."
+    entity what name))
+
+(define (signal-duplicate-names-in-entity entity)
+  (fatal-error 'duplicate-names-in-entity
+    "The entity specification ~a includes duplicate names."
+    entity))
+
+(define (signal-export-method-var name)
+  (fatal-error 'export-method-var
+    "You can't export the method ~a like an ordinary variable."
+    name))
+
+(define (signal-prelude-renaming def name)
+  (recoverable-error 'cant-rename-core
+     "Names in PreludeCore cannot be renamed: ~a was renamed to ~a"
+     (def-name def) name))
+
+(define (signal-non-local-fixity op)
+  (recoverable-error 'fixity-must-be-local
+     "The fixity for ~A will be ignored since it is not defined in this module"
+     op))
+
+(define (signal-fixity-not-var/con op)
+  (recoverable-error 'fixity-requires-var-or-con
+     "The fixity for ~A will be ignored since it is not a value or constructor"
+     op))
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))))))))
+
diff --git a/import-export/ie.scm b/import-export/ie.scm
new file mode 100644
index 0000000..9cd6de9
--- /dev/null
+++ b/import-export/ie.scm
@@ -0,0 +1,16 @@
+(define-compilation-unit ie
+  (source-filename "$Y2/import-export/")
+  (require global)
+  (unit ie-utils
+    (source-filename "ie-utils"))
+  (unit import-export
+    (source-filename "import-export"))
+  (unit init-modules
+    (source-filename "init-modules"))
+  (unit top-definitions
+    (source-filename "top-definitions"))
+  (unit locate-entity
+    (source-filename "locate-entity"))
+  (unit ie-errors
+    (source-filename "ie-errors")))
+
diff --git a/import-export/import-export.scm b/import-export/import-export.scm
new file mode 100644
index 0000000..25fdfcf
--- /dev/null
+++ b/import-export/import-export.scm
@@ -0,0 +1,209 @@
+;;; This is the main driver for the import / export routine
+
+(define (import-export modules)
+  (walk-modules modules
+        (lambda () (add-module-to-symbol-table *module*)))
+  (walk-modules modules
+      (lambda () (init-module-structure)))
+  (import-export/fixpoint modules '#t)
+  (walk-modules modules (lambda () (check-missing-names)))
+  (when (memq 'import (dynamic *printers*))
+    (show-export-tables modules))
+ modules)
+
+(define (import-export/interface modules)
+  (walk-modules modules
+        (lambda () (add-module-to-symbol-table *module*)))
+  (walk-modules modules
+      (lambda () (init-module-structure)))
+  (walk-modules modules
+      (lambda () (create-top-definitions)
+	         (attach-fixities))))
+
+(define (import-export/fixpoint modules initial-cycle?)
+  (setf *new-exports-found?* '#f)
+  (walk-modules modules
+   (lambda ()
+     (setf (module-fresh-exports *module*) '())
+     (when initial-cycle?
+       (create-top-definitions)
+       (attach-fixities)
+       (import-non-local))
+     (locally-import)
+     (locally-export)))
+  (when *new-exports-found?*
+      (import-export/fixpoint modules '#f)))
+
+;;; This does the non-local importing from previously defined modules
+
+(define (import-non-local)
+  (setf (module-imports *module*)
+	(process-non-local-imports (module-imports *module*))))
+
+(define (process-non-local-imports imports)
+  (if (null? imports)
+      '()
+      (let* ((import (car imports)))
+        (with-slots import-decl (module mode specs renamings) import
+	  (cond ((eq? *unit* (module-unit module))
+		 (cons import (process-non-local-imports (cdr imports))))
+		((eq? mode 'all)
+		 (import-all-entities module specs renamings import)
+		 (process-non-local-imports (cdr imports)))
+		(else
+		 (import-named-entities module specs renamings import)
+		 (process-non-local-imports (cdr imports))))))))
+
+(define (import-all-entities module hiding renamings import-decl)
+  (table-for-each
+   (lambda (name group)
+     (declare (ignore name))
+     (cond ((in-hiding-list? group hiding)
+	    (setf hiding (remove-entity group hiding)))
+	   (else
+	    (import-group (rename-group group renamings) module))))
+   (module-export-table module))
+  (when (not (null? hiding))
+    (remember-context import-decl
+      (dolist (h hiding)
+	(signal-unused-hiding (entity-name h) (module-name module)))))
+  (find-unused-renamings renamings import-decl))
+
+(define (import-named-entities mod specs renamings import-decl)
+  (dolist (entity specs)
+    (let ((group (locate-entity/export-table entity mod '#t)))
+      (when (not (eq? group 'error))
+	(setf group (rename-group group renamings))
+	(import-group group mod))))
+  (find-unused-renamings renamings import-decl))
+
+;;; This takes a module and processes the import declarations, moving as
+;;; many entities from the freshly exported components of other modules into
+;;; the current module.
+
+(define (locally-import)
+  (dolist (import (module-imports *module*))
+    (with-slots import-decl (module mode specs renamings) import
+      (if (eq? mode 'all)
+	  (import-fresh-entities import module specs renamings)
+	  (setf (import-decl-specs import)
+		(import-entities specs module renamings))))))
+
+(define (import-fresh-entities import module hiding renamings)
+  (dolist (group (module-fresh-exports module))
+    (cond ((in-hiding-list? group hiding)
+	    (setf hiding (remove-entity group hiding)))
+	   (else
+	    (import-group (rename-group group renamings) module))))
+  (setf (import-decl-specs import) hiding))
+
+(define (import-entities entities module renamings)
+  (if (null? entities)
+      '()
+      (let ((group (locate-entity/export-table (car entities) module '#f)))
+	(cond ((eq? group 'not-found)
+	       (cons (car entities)
+		     (import-entities (cdr entities) module renamings)))
+	      ((eq? group 'error)
+	       (import-entities (cdr entities) module renamings))
+	      (else
+	       (setf group (rename-group group renamings))
+	       (import-group group module)
+	       (import-entities (cdr entities) module renamings))))))
+
+;;; This imports a group into *module*.  module is the place the group is
+;;; taken from.
+
+(define (import-group group module)
+  (when (memq module (module-exported-modules *module*))
+    (export-group group))
+  (dolist (n-d group)
+    (insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d))))
+
+;;; This takes as yet unresolved exports and moves them to the export table.
+
+(define (locally-export)
+  (setf (module-exports *module*)
+	(export-entities (module-exports *module*))))
+
+(define (export-entities entities)
+  (if (null? entities)
+      '()
+      (let* ((entity (car entities))
+	     (group (locate-entity entity)))
+	(cond ((eq? group 'error)
+	       (export-entities (cdr entities)))
+	      ((eq? group 'not-found)
+	       (cons entity (export-entities (cdr entities))))
+	      (else
+	       (export-group group)
+	       (export-entities (cdr entities)))))))
+
+
+;;; This moves a group into the export table.  If this export is new,
+;;; a flag is set.
+
+(define (export-group group)
+  (let* ((export-table (module-export-table *module*))
+	 (old-group (table-entry export-table (group-name group))))
+    (when (or (eq? old-group '#f)
+	      (and (hidden-constructors? old-group)
+		   (not (hidden-constructors? group))))
+      (setf (table-entry export-table (group-name group)) group)
+      (dolist (n-d group)
+        (setf (def-exported? (tuple-2-2 n-d)) '#t))
+      (push group (module-fresh-exports *module*))
+      (setf *new-exports-found?* '#t))))
+
+(define (show-export-tables modules)
+  (walk-modules modules
+    (lambda ()
+      (format '#t "~%Exports from module ~A~%" *module-name*)
+      (let ((exports '()))
+	(table-for-each (lambda (key val)
+			  (push (cons key val) exports))
+			(module-export-table *module*))
+	(setf exports (sort-list exports
+				 (lambda (x y)
+				   (string-ci<? (symbol->string (car x))
+						(symbol->string (car y))))))
+	(dolist (e exports)
+          (print-exported-group (car e) (group-definition (cdr e))
+				(cdr (cdr e))))))))
+
+(define (print-exported-group name def extras)
+  (if (eq? (def-module def) *module-name*)
+      (format '#t " ")
+      (format '#t "*"))
+  (cond ((synonym? def)
+	 (format '#t "type  "))
+	((algdata? def)
+	 (format '#t "data  "))
+	((class? def)
+	 (format '#t "class "))
+	(else
+	 (format '#t "      ")))
+  (format '#t "~A" name)
+  (when (not (eq? name (def-name def)))
+     (format '#t "[~A]" (def-name def)))
+  (when extras
+     (format '#t " (")
+     (print-exported-group-1 extras (algdata? def)))
+  (format '#t "~%"))
+
+(define (print-exported-group-1 extras alg?)
+  (let* ((name (tuple-2-1 (car extras)))
+	 (ns (symbol->string name))
+	 (def (tuple-2-2 (car extras))))
+    (format '#t "~A" (if alg? (remove-con-prefix ns) ns))
+    (when (not (eq? name (def-name def)))
+      (let ((name1 (symbol->string (def-name def))))
+	  (format '#t "[~A]" (if alg? (remove-con-prefix name1) name1))))
+    (if (null? (cdr extras))
+	(format '#t ")")
+	(begin
+	  (format '#t ",")
+	  (print-exported-group-1 (cdr extras) alg?)))))
+
+
+
diff --git a/import-export/init-modules.scm b/import-export/init-modules.scm
new file mode 100644
index 0000000..5198c0c
--- /dev/null
+++ b/import-export/init-modules.scm
@@ -0,0 +1,142 @@
+;;; This initializes the module ast structures.
+
+;;; This requires that the module table be created and updated with new
+;;; modules first.  *unit* must also be defined.
+
+;;; Things initialized there:
+;;;  all tables in the module structure
+;;;  the module slot of all import declarations and entity-modules
+;;;  The import Prelude is added when necessary
+;;;  Empty export lists are explicated
+
+(define (init-module-structure)
+  (when (not (eq? (module-type *module*) 'extension))
+    ;; If this is an extension, the incremental compiler has already
+    ;; filled in the compilation unit.
+    (setf (module-unit *module*) *unit*))
+  ;;; This processes the annotations.  Annotations used at the top
+  ;;; level of the module:
+  ;;;   {-#PRELUDE#-} : this contains definitions in the Haskell prelude
+  (setf (module-prelude? *module*) '#f)
+  (setf (module-interface-codefile *module*) '())
+  (dolist (a (module-annotations *module*))
+    (when (annotation-value? a)
+      (let ((name (annotation-value-name a)))
+	(cond ((eq? name '|Prelude|)
+	       (setf (module-prelude? *module*) '#t))))))
+  (cond ((eq? (module-type *module*) 'interface)
+	 (setf (module-exported-modules *module*) (list *module*))
+	 (process-interface-imports *module*))
+	((eq? (module-type *module*) 'standard)
+	 (init-standard-module))))
+
+(define (init-standard-module)
+   (let ((seen-prelude? '#f))
+    (dolist (import (module-imports *module*))
+      (let* ((name (import-decl-module-name import))
+	     (imported-mod (locate-module name)))
+	(when (eq? name '|Prelude|)
+	   (setf seen-prelude? '#t))
+	(if (eq? imported-mod '#f)
+	    (signal-undefined-module-import name)
+	    (setf (import-decl-module import) imported-mod))
+	(when (eq? name *module-name*)
+	  (signal-self-import name))))
+    (when (null? (module-exports *module*))
+	(setf (module-exports *module*)
+	      (list (make entity-module (name *module-name*)
+			                (module *module*)))))
+    (when (not seen-prelude?)
+      (let ((prelude (locate-module '|Prelude|)))
+	(cond ((eq? prelude '#f)
+	       (signal-missing-prelude))
+	      ((module-prelude? *module*)
+	       (setf (module-uses-standard-prelude? *module*) '#f)
+	       (add-imported-module prelude))
+	      (else
+	       (setf (module-uses-standard-prelude? *module*) '#t)
+	       (let ((fix-table (module-fixity-table *module*)))
+		 (table-for-each (lambda (k v)
+				   (setf (table-entry fix-table k) v))
+				 *prelude-fixity-table*))))))
+    (let ((prelude-core (locate-module '|PreludeCore|)))
+       (if (eq? prelude-core '#f)
+	   (signal-missing-prelude-core)
+	   (when (module-prelude? *module*)
+		 (add-imported-module prelude-core))))
+    (setf (module-exports *module*)
+	  (filter-complete-module-exports (module-exports *module*))))
+    )
+
+
+(define (add-imported-module module)
+  (setf (module-imports *module*)
+	(cons (make import-decl
+		    (module-name (module-name module))
+		    (module module)
+		    (mode 'all)
+		    (specs '())
+		    (renamings '()))
+	      (module-imports *module*))))
+
+(define (filter-complete-module-exports exports)
+  (if (null? exports)
+      '()
+      (let ((export (car exports))
+	    (others (filter-complete-module-exports (cdr exports))))
+	(if (is-type? 'entity-module export)
+	    (let* ((name (entity-name export))
+		   (exported-mod (locate-module name)))
+	      (when (eq? exported-mod '#f)
+		(signal-undefined-module-export name))
+	      (push exported-mod (module-exported-modules *module*))
+	      (when (not (memq name
+			   (cons *module-name*
+				 (map
+				   (lambda (import)
+				     (import-decl-module-name import))
+				   (module-imports *module*)))))
+		(signal-export-not-imported name))
+	      others)
+	    (cons export others)))))
+
+(define (process-interface-imports module)
+  (let ((imports '()))
+    (dolist (i (module-imports module))
+      (let ((module (import-decl-module-name i))
+	    (renamings (import-decl-renamings i)))
+	(dolist (s (import-decl-specs i))
+          (let* ((n (entity-name s))
+		 (n1 (do-interface-rename n renamings)))
+	    (when (assq n1 imports)
+               (signal-multiple-imports n1))
+	    (push (tuple n1 (tuple module n)) imports)
+	    (cond ((entity-class? s)
+		   (dolist (m (entity-class-methods s))
+                     (let ((m1 (do-interface-rename m renamings)))
+		       (when (assq m1 imports)
+                          (signal-multiple-imports m1))
+		       (push (tuple m1 (tuple module m)) imports))))
+		  ((entity-datatype? s)
+		   (dolist (m (entity-datatype-constructors s))
+                     (let ((m1 (do-interface-rename m renamings)))
+		       (when (assq m1 imports)
+                          (signal-multiple-imports m1))
+		       (push (tuple m1 (tuple module m)) imports)))))))))
+    (setf (module-interface-imports module) imports)))
+
+(define (signal-multiple-imports name)
+  (phase-error 'multuple-interface-import
+    "Interface file has more than one definition of ~A~%" name))
+
+(define (do-interface-rename name renamings)
+  (if (has-con-prefix? (symbol->string name))
+      (let* ((n1 (remove-con-prefix/symbol name))
+	     (res (locate-renaming n1 renamings)))
+	(if (eq? res '#f)
+	    name
+	    (add-con-prefix/symbol (renaming-to res))))
+      (let ((res (locate-renaming name renamings)))
+	(if (eq? res '#f)
+	    name
+	    (renaming-to res)))))
diff --git a/import-export/locate-entity.scm b/import-export/locate-entity.scm
new file mode 100644
index 0000000..a001b62
--- /dev/null
+++ b/import-export/locate-entity.scm
@@ -0,0 +1,126 @@
+;;; This file deals with entities in import / export lists
+
+;;; This resolves an entity with the export table of a
+;;; module.  It returns either a group, the symbol 'error, or the symbol
+;;; 'not-found.  When force-error? is true, signal an error when
+;;; the module is not found & return 'error.
+
+(define (locate-entity/export-table entity mod force-error?)
+  (let* ((name (entity-name entity))
+	 (group (table-entry (module-export-table mod) name)))
+    (if (eq? group '#f)
+	(if (not force-error?)
+	    'not-found
+	    (signal-entity-not-found name (module-name mod)))
+	(let ((def (group-definition group)))
+	  (cond ((is-type? 'entity-var entity)
+		 group)
+		((is-type? 'entity-con entity)
+		 (cond ((algdata? def)
+			(strip-constructors group))
+		       ((synonym? def)
+			(signal-synonym-needs-dots name (module-name mod)))
+		       (else
+			(signal-wrong-definition
+			  "type constructor" name (module-name mod)))))
+		((is-type? 'entity-abbreviated entity)
+		 (cond ((algdata? def)
+			(cond ((hidden-constructors? group)
+			       (if force-error?
+				   (signal-abstract-type
+				     name (module-name mod))
+				   'not-found))
+			      (else
+			       group)))
+		       ((or (class? def) (synonym? def))
+			group)
+		       (else
+			(signal-wrong-definition
+			  "class or datatype" name (module-name mod)))))
+		((is-type? 'entity-class entity)
+		 (if (class? def)
+		     (match-constituents group (entity-class-methods entity)
+					 entity "method")
+		     (signal-wrong-definition "class" name (module-name mod))))
+		((is-type? 'entity-datatype entity)
+		 (if (algdata? def)
+		     (match-constituents group
+					 (entity-datatype-constructors entity)
+					 entity "constructor")
+		     (signal-wrong-definition
+		       "data type" name (module-name mod))))
+		(else
+		 (error "Bad entity ~s." entity))
+		)))))
+
+(define (match-constituents group names entity what)
+  (check-duplicates names entity)
+  (dolist (n-d (cdr group))
+    (when (not (memq (tuple-2-1 n-d) names))
+      (signal-extra-constituent entity (tuple-2-1 n-d) what)))
+  (dolist (name names)
+    (when (not (assq name (cdr group)))
+      (signal-missing-constituent entity name what)))
+  group)
+
+
+;;; The following routine locates an entity in the current module.
+;;; It may return 'error, 'not-found, or a group.
+
+(define (locate-entity entity)
+  (let* ((name (entity-name entity))
+	 (def (resolve-toplevel-name name)))
+    (cond ((eq? def '#f)
+	   'not-found)
+	  ((is-type? 'entity-var entity)
+	   (if (method-var? def)
+	       (signal-export-method-var name)
+	       (make-group name def)))
+	  ((is-type? 'entity-con entity)
+	   (cond ((algdata? def)
+		  (make-group name def))
+		 ((synonym? def)
+		  (signal-synonym-needs-dots name *module-name*))
+		 (else
+		  (signal-wrong-definition
+		    "type constructor" name *module-name*))))
+	  ((is-type? 'entity-abbreviated entity)
+	   (cond ((algdata? def)
+		  (require-complete-algdata
+		   (gather-algdata-group name def)))
+		 ((synonym? def)
+		  (make-group name def))
+		 ((class? def)
+		  (gather-class-group name def))
+		 (else
+		  (signal-wrong-definition
+		    "type constructor or class" name *module-name*))))
+	  ((is-type? 'entity-class entity)
+	   (if (class? def)
+	       (match-group-names
+		 (gather-class-group name def)
+		 (entity-class-methods entity)
+		 entity
+		 "method")
+	       (signal-wrong-definition "class" name *module-name*)))
+	  ((is-type? 'entity-datatype entity)
+	   (if (algdata? def)
+	       (match-group-names
+		 (require-complete-algdata (gather-algdata-group name def))
+		 (entity-datatype-constructors entity)
+		 entity "constructor")
+	       (signal-wrong-definition "data type" name *module-name*)))
+	  (else
+	   (error "Bad entity ~s." entity)))))
+
+(define (require-complete-algdata group)
+  (if (hidden-constructors? group)
+      'not-found
+      group))
+
+(define (match-group-names group names entity what)
+  (when (not (eq? group 'not-found))
+    (match-constituents group names entity what))
+  group)
+
+
diff --git a/import-export/top-definitions.scm b/import-export/top-definitions.scm
new file mode 100644
index 0000000..07722dd
--- /dev/null
+++ b/import-export/top-definitions.scm
@@ -0,0 +1,98 @@
+;;; File: top-definitions.scm
+
+;;; Description: This creates definitions for all top level (exportable)
+;;;  object in a module.
+
+(define (create-top-definitions)
+  (dolist (decl (module-decls *module*))
+    (if (eq? (module-type *module*) 'interface)
+	(when (signdecl? decl)
+	   (create-var-definitions decl (signdecl-vars decl)))
+	(when (valdef? decl)
+	   (create-var-definitions
+	    decl (collect-pattern-vars (valdef-lhs decl))))))
+  (dolist (algdata (module-algdatas *module*))
+    (create-alg-definitions algdata))
+  (dolist (synonym (module-synonyms *module*))
+    (create-syn-definitions synonym))
+  (dolist (class (module-classes *module*))
+    (create-class-definitions class)))
+
+;;; ------------------------------------------------------------------------
+;;; creation of definitions
+;;; ------------------------------------------------------------------------
+
+(define (create-var-definitions decl vars)
+  (remember-context decl
+    (dolist (v vars)
+     (let* ((var-name (var-ref-name v))
+	    (def (create-top-definition var-name 'var)))
+       (setf (var-ref-var v) def)
+       (push def (module-vars *module*))
+       (add-new-group var-name def)))))
+
+;;; This also creates definitions for the constructors
+
+(define (create-alg-definitions algdata)
+  (remember-context algdata
+    (with-slots data-decl (simple constrs) algdata
+      (let* ((alg-name (tycon-name simple))
+	     (def (create-top-definition alg-name 'algdata)))
+	(setf (tycon-def simple) def)
+	(let ((constr-group
+	       (map (lambda (constr) 
+		     (let* ((con-ref (constr-constructor constr))
+			    (con-name (con-ref-name con-ref))
+			    (con-def (create-top-definition con-name 'con)))
+		        (setf (con-ref-con con-ref) con-def)
+			(tuple con-name con-def)))
+		    constrs)))
+	  (setf (algdata-constrs def) (map (function tuple-2-2) constr-group))
+	  (setf (tycon-def-arity def) (length (tycon-args simple)))
+	  (add-new-group alg-name def constr-group))))))
+
+(define (create-class-definitions class-decl)
+  (remember-context class-decl
+    (with-slots class-decl (class decls) class-decl
+      (let* ((class-name (class-ref-name class))
+	     (class-def (create-top-definition class-name 'class)))
+	(setf (class-ref-class class) class-def)
+	(let ((method-group
+	       (concat
+		(map
+		 (lambda (decl) 
+		  (if (is-type? 'signdecl decl)
+		      (remember-context decl
+		       (map (lambda (method-var)
+			      (let* ((var-name (var-ref-name method-var))
+				     (def (create-top-definition
+					      var-name 'method-var)))
+				(setf (method-var-class def) class-def)
+				(setf (method-var-default def) '#f)
+				(setf (var-ref-var method-var) def)
+				(tuple var-name def)))
+			    (signdecl-vars decl)))
+		      '()))
+		decls))))
+	  (setf (class-method-vars class-def)
+		(map (function tuple-2-2) method-group))
+	  (add-new-group class-name class-def method-group))))))
+
+(define (create-syn-definitions synonym-decl)
+  (remember-context synonym-decl
+    (let* ((simple (synonym-decl-simple synonym-decl))
+	   (syn-name (tycon-name simple))
+	   (def (create-top-definition syn-name 'synonym)))
+      (setf (tycon-def simple) def)
+      (setf (tycon-def-arity def) (length (tycon-args simple)))
+      (add-new-group syn-name def))))
+
+(define (add-new-group name def . others)
+  (when (memq *module* (module-exported-modules *module*))
+      (export-group (cons (tuple name def)
+			  (if (null? others)
+			      '()
+			      (car others))))))
+
+
+