path: root/top/symbol-table.scm

;;; 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))