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.

---
 import-export/init-modules.scm | 142 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 142 insertions(+)
 create mode 100644 import-export/init-modules.scm

(limited to 'import-export/init-modules.scm')

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