1 files changed, 412 insertions, 0 deletions
diff --git a/top/symbol-table.scm b/top/symbol-table.scm
new file mode 100644
index 0000000..499bfb8
--- /dev/null
+++ b/top/symbol-table.scm
@@ -0,0 +1,412 @@
+;;; These routines deal with the global symbol table.  The symbol table
+;;; is represented in two stages: a module table which maps module names
+;;; onto module structures and local tables within each module which
+;;; map names (symbols) to definitions.
+
+;;; The following functions deal with the module table (*modules*):
+
+;;;  (initialize-module-table) - this clears out all modules from the
+;;;      symbol table.  Every compilation should start with this.
+;;;  (add-module-to-module-table module) - this takes a module ast,
+;;;      either from a .exp file or previous compilation with the same
+;;;      incarnation of the compiler and adds it to the set of `known'
+;;;      modules.  Incomplete module ast's in the process of compilation
+;;;      are also added to this table.
+
+
+(define (initialize-module-table)
+  (setf *modules* (make-table)))
+
+(define (add-module-to-symbol-table module)
+  (let* ((name (module-name module))
+	 (old-module (table-entry *modules* name)))
+    (when (not (eq? old-module '#f))
+      (if (eq? *unit* (module-unit old-module))
+	  (signal-module-double-definition name)
+	  (signal-module-already-defined name)))
+    (setf (table-entry *modules* name) module)))
+
+(define (remove-module-from-symbol-table module)
+  (let ((name (module-name module)))
+    (setf (table-entry *modules* name) '#f)))
+
+(define (locate-module name)
+  (table-entry *modules* name))
+
+;;;  (walk-modules fn mod-list) - this calls fn for each module in the
+;;;      mod-list.  It also binds the global variable *module* to the
+;;;      current module, *symbol-table* to the local symbol
+;;;      table.  The fixity table is also placed in a global.
+
+(define (walk-modules mods fn)
+  (dolist (mod mods)
+    (dynamic-let ((*module* mod)
+		  (*module-name* (module-name mod))
+		  (*symbol-table* (module-symbol-table mod))
+		  (*fixity-table* (module-fixity-table mod))
+		  (*inverted-symbol-table* (module-inverted-symbol-table mod)))
+       (funcall fn))))
+
+;;; create-definition makes a new definition object 
+
+(define (create-definition module name type)
+  (cond ((module-prelude? module)
+	 (let ((def (table-entry *core-symbols* name)))
+	   (cond ((eq? def '#f)
+		  (create-definition/non-core module name type))
+		 (else
+		  (setf (def-unit def) *unit*)
+		  (setf (def-module def) (module-name module))
+		  ;; *** Should any other properties be reinitialized here?
+		  (cond ((or (eq? type 'var) (eq? type 'method-var))
+			 (setf (var-fixity def) '#f)
+			 (setf (var-signature def) '#f))
+			((eq? type 'con)
+			 (setf (con-fixity def) '#f)))
+		  def))))
+	(else (create-definition/non-core module name type))))
+
+;(define (create-definition/non-core module name type)
+;  (create-definition/new module name type)
+;      (let* ((interface (module-interface-module module))
+;	     (old-def (table-entry (module-symbol-table interface) name)))
+;	(if (eq? old-def '#f)
+;	    (create-definition/new module name type)
+;	    (cond ((eq? type 'var)
+;		   (unless (var? old-def)	
+;		       (def-conflict module name type old-def))
+;		   (setf (var-interface-type old-def) (var-type old-def)))
+;		  ((eq? type 'con)
+;		   (unless (con? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'synonym)
+;		   (unless (synonym? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'algdata)
+;		   (unless (algdata? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'class)
+;		   (unless (class? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'method-var)
+;		   (unless (method-var? old-def)
+;		      (def-conflict module name type old-def)))))
+;	(setf (def-unit old-def) *unit*)
+;	old-def)))
+;
+;(define (def-conflict module name type def)
+;  (phase-error 'interface-conflict
+;    "The ~A ~A in module ~A was defined as a ~A in an interface."
+;    (cond ((var? def) "variable")
+;	  ((class? def) "class")
+;	  ((algdata? def) "data type")
+;	  ((synonym? def) "synonym")
+;	  ((con? def) "constructor")
+;	  (else "widgit"))
+;    name (module-name module) type))    
+
+(define (create-definition/non-core module name type)
+  (let ((mname  (module-name module)))
+    (when (eq? (module-type *module*) 'interface)
+       (mlet (((mod name1) (rename-interface-symbol name)))
+         (setf mname mod)
+	 (setf name name1)))
+    (create-definition/inner mname name type)))
+
+(define (create-definition/inner mname name type)
+    (cond ((eq? type 'var)
+	   (make var (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'con)
+	   (make con (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'synonym)
+	   (make synonym (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'algdata)
+	   (make algdata (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'class)
+	   (make class (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'method-var)
+	   (make method-var (name name) (module mname) (unit *unit*)))
+	  (else
+	   (error "Bad type argument ~s." type))))
+
+
+(define (create-top-definition name type)
+  (let ((def (create-definition *module* name type)))
+    (insert-top-definition name def)
+    def))
+
+;;; Interfaces have a special table which resolves imports in the
+;;; interface.  Given a name in an interface module this returns the
+;;; corresponding full name: a (module,original-name) pair.  Symbols not
+;;; imported are assumed to be defined in the interface.
+
+(define (rename-interface-symbol name)
+  (let ((res (assq name (module-interface-imports *module*))))
+    (if (eq? res '#f)
+	(values *module-name* name)
+	(values (tuple-2-1 (tuple-2-2 res))
+		(tuple-2-2 (tuple-2-2 res))))))
+
+;;; This creates a locally defined var node.
+
+(define (create-local-definition name)
+  (let ((var     (make var (name name) (module *module-name*) (unit *unit*))))
+    (setf (var-fixity var) (table-entry *fixity-table* name))
+    var))
+
+
+;;; This function creates a new variable. 
+;;; The "root" may be either a symbol or a string.
+;;; *unit* defines the home module of the variable.
+
+;;; *** Maybe it would be possible to hack this so that it doesn't
+;;; *** create any symbol at all until the name is demanded by something,
+;;; *** but that seems like a rather sweeping change.
+
+(define (create-temp-var root)
+  (let* ((name   (gensym (if (symbol? root) (symbol->string root) root)))
+	 (module  *unit*))
+    (make var (name name) (module module) (unit *unit*))))
+
+
+;;; The following routines install top level definitions into the symbol
+;;; table.
+
+(predefine (signal-multiple-name-conflict name old-local-name def))
+    ; in import-export/ie-errors.scm
+
+(define (insert-top-definition name def)
+  (let ((old-definition (resolve-toplevel-name name)))
+    (cond ((eq? old-definition '#f)
+	   (when (not (def-prelude? def))
+	       (setf (table-entry *symbol-table* name) def))
+	   (when (and (var? def) (not (eq? (var-fixity def) '#f)))
+             (setf (table-entry *fixity-table* name)
+		   (var-fixity def)))
+	   (when (and (con? def) (not (eq? (con-fixity def) '#f)))
+             (setf (table-entry *fixity-table* name)
+		   (con-fixity def)))
+	   (when (not (def-prelude? def))
+ 	    (if (eq? (local-name def) '#f)
+		(setf (table-entry *inverted-symbol-table* def) name)
+		(signal-multiple-name-conflict name (local-name def) def))))
+	  ((eq? old-definition def)
+	   'OK)
+	  ((def-prelude? old-definition)
+	   (signal-core-redefinition name))
+	  ((and (module-uses-standard-prelude? *module*)
+		(table-entry *prelude-symbol-table* name))
+	   (if (eq? (def-module def) *module-name*)
+	       (signal-prelude-redefinition name)
+	       (signal-prelude-reimport name (def-module def))))
+	  ((eq? (def-module def) *module-name*)
+	   (signal-multiple-definition-in-module name *module-name*))
+	  ((eq? (def-module old-definition) *module-name*)
+	   (signal-redefinition-by-imported-symbol name *module-name*))
+	  (else
+	   (signal-multiple-import name *module-name*)))))
+
+;;; Gets the fixity of a name.
+
+(define (get-local-fixity name)
+  (table-entry *fixity-table* name))
+
+;;; These routines support general scoping issues.  Only vars have local
+;;; definitions - all other names are resolved from the global symbol table.
+
+;;; This is used when the name must be in the top symbols.
+
+(define (fetch-top-def name type)
+  (let ((def (resolve-toplevel-name name)))
+    (cond ((eq? def '#f)
+	   (cond ((eq? (module-type *module*) 'interface)
+		  (mlet (((mod name1) (rename-interface-symbol name)))
+		    (if (eq? mod *module-name*)
+			(undefined-topsym name)
+			(let ((new-def (create-definition/inner
+					mod name1 type)))
+			  (insert-top-definition name1 new-def)
+			  (cond ((algdata? new-def)
+				 (setf (algdata-n-constr new-def) 0)
+				 (setf (algdata-constrs new-def) '())
+				 (setf (algdata-context new-def) '())
+				 (setf (algdata-tyvars new-def) '())
+				 (setf (algdata-classes new-def) '#f)
+				 (setf (algdata-enum? new-def) '#f)
+				 (setf (algdata-tuple? new-def) '#f)
+				 (setf (algdata-real-tuple? new-def) '#f)
+				 (setf (algdata-deriving new-def) '()))
+				((class? new-def)
+				 (setf (class-method-vars new-def) '())
+				 (setf (class-super new-def) '())
+				 (setf (class-super* new-def) '())
+				 (setf (class-tyvar new-def) '|a|)
+				 (setf (class-instances new-def) '())
+				 (setf (class-kind new-def) 'other)
+				 (setf (class-n-methods new-def) 0)
+				 (setf (class-dict-size new-def) 0)
+				 (setf (class-selectors new-def) '()))) 
+			  new-def))))
+		 (else
+		  (undefined-topsym name))))
+	  (else def))))
+
+(define (undefined-topsym name)
+  (signal-undefined-symbol name)
+  *undefined-def*)
+
+
+(define (resolve-toplevel-name name)
+  (let ((pc (table-entry *prelude-core-symbols* name)))
+    (cond ((not (eq? pc '#f))
+	   pc)
+	  ((module-uses-standard-prelude? *module*)
+	   (let ((res (table-entry *prelude-symbol-table* name)))
+	     (if (eq? res '#f)
+		 (resolve-toplevel-name-1 name)
+		 res)))
+	  (else
+	   (resolve-toplevel-name-1 name)))))
+
+(define (resolve-toplevel-name-1 name)
+  (cond ((eq? (module-inherited-env *module*) '#f)
+	 (table-entry *symbol-table* name))
+	(else
+	 (let ((res (search-inherited-tables
+		     name (module-inherited-env *module*))))
+	   (if (eq? res '#f)
+	       (table-entry *symbol-table* name)
+	       res)))))
+
+(define (search-inherited-tables name mod)
+  (if (eq? mod '#f)
+      '#f
+      (let ((res (table-entry (module-symbol-table mod) name)))
+	(if (eq? res '#f)
+	    (search-inherited-tables name (module-inherited-env mod))
+	    res))))
+
+;;; Con-ref's are special in that the naming convention (;Name) ensures
+;;; that if a def is found it must be a con.
+
+(define (resolve-con con-ref)
+  (when (eq? (con-ref-con con-ref) *undefined-def*)
+    (remember-context con-ref
+      (let ((def (fetch-top-def (con-ref-name con-ref) 'con)))
+	(setf (con-ref-con con-ref) def)))))
+
+(define (resolve-class class-ref)
+  (when (eq? (class-ref-class class-ref) *undefined-def*)
+    (remember-context class-ref
+      (let ((def (fetch-top-def (class-ref-name class-ref) 'class)))
+	(when (not (class? def))
+	  (signal-class-name-required def (class-ref-name class-ref)))
+	(setf (class-ref-class class-ref) def)))))
+
+
+(define (resolve-tycon tycon)
+  (when (eq? (tycon-def tycon) *undefined-def*)
+    (remember-context tycon
+      (let ((def (fetch-top-def (tycon-name tycon) 'algdata)))
+	(when (class? def)
+	  (signal-tycon-name-required (tycon-name tycon)))
+	(setf (tycon-def tycon) def)))))
+
+
+;;; This should be used after the local environment has been searched.
+;;; Other routines dealing with variable scoping are elsewhere.
+
+(define (resolve-var var-ref)
+  (when (eq? (var-ref-var var-ref) *undefined-def*)
+    (remember-context var-ref
+      (let ((def (fetch-top-def (var-ref-name var-ref) 'var)))
+	(setf (var-ref-var var-ref) def)))))
+
+
+;;; *** The inverted-symbol-table is the only table in the whole
+;;; *** system that is not keyed off of symbols.  If this is a problem,
+;;; *** things that use it could probably be rewritten to do something
+;;; *** else, like store an a-list on the def itself.
+
+;;; This does not need to consult the inherited-env flag because when this
+;;; is used in extensions only new symbols get inserted.
+
+(define (local-name def)
+  (cond ((def-prelude? def)
+	 (def-name def))
+	((module-uses-standard-prelude? *module*)
+	 (let ((res (table-entry *prelude-inverted-symbol-table* def)))
+	   (if (eq? res '#f)
+	    (table-entry *inverted-symbol-table* def)
+	    res)))
+	(else
+	 (table-entry *inverted-symbol-table* def))))
+    
+(define (print-name x)
+  (let ((res (local-name x)))
+    (if (eq? res '#f)
+	(def-name x)
+	res)))
+
+
+;;; Error signalling routines.
+
+(define (signal-module-double-definition name)
+  (fatal-error 'module-double-definition
+    "Module ~s is defined more than once."
+    name))
+
+(define (signal-module-already-defined name)
+  (fatal-error 'module-already-defined
+    "Module ~a is defined more than once in the current unit."
+    name))
+
+(define (signal-multiple-definition-in-module name modname)
+ (if (eq? (module-type *module*) 'extension)
+     (phase-error 'cant-redefine-in-extension
+        "An extension for module ~A cannot redefine the symbol ~A"
+	modname name)
+     (phase-error 'multiple-definition-in-module
+        "There is more than one definition for the name ~a in module ~a."
+	name modname)))
+
+(define (signal-redefinition-by-imported-symbol name modname)
+  (phase-error 'redefinition-by-imported-symbol
+    "The name ~a is defined in module ~a, and cannot be imported."
+    name modname))
+
+(define (signal-core-redefinition name)
+  (phase-error 'prelude-redefinition
+    "The name ~a is defined in the prelude core and cannot be redefined."
+    name))
+
+(define (signal-prelude-redefinition name)
+  (phase-error 'prelude-redefinition
+    "The name ~a is defined in the prelude.~%You must hide it if you wish to use this name."
+    name))
+
+(define (signal-prelude-reimport name modname)
+  (phase-error 'prelude-redefinition
+    "The name ~a is both imported from ~A and defined in the prelude.~%"
+    name modname))
+
+(define (signal-multiple-import name modname)
+  (phase-error 'multiple-import
+    "The name ~a is imported into module ~a multiple times."
+    name modname))
+
+(define (signal-undefined-symbol name)
+  (phase-error 'undefined-symbol
+    "The name ~A is undefined."
+    name))
+
+(define (signal-class-name-required name def)
+  (phase-error 'class-name-required
+    "The name ~A defines a ~A, but a class name is required."
+    name
+    (if (synonym? def) "synonym" "data type")))
+
+(define (signal-tycon-name-required name)
+  (phase-error 'tycon-required
+    "The name ~A defines a class, but a type constructor name is required."
+    name))