home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / symbol-table.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  11.8 KB  |  240 lines  |  [TEXT/CCL2]
  1. ;;; These routines deal with the global symbol table.  The symbol table
  2. ;;; is represented in two stages: a module table which maps module names
  3. ;;; onto module structures and local tables within each module which
  4. ;;; map names (symbols) to definitions.
  5.  
  6. ;;; create-definition makes a new definition object 
  7.  
  8. (define (create-definition module name type)
  9.   (cond ((module-prelude? module)
  10.      (let ((def (table-entry *core-symbols* name)))
  11.        (cond ((eq? def '#f)
  12.           (create-definition/non-core module name type))
  13.          (else
  14.           (setf (def-unit def) *unit*)
  15.           (setf (def-module def) (module-name module))
  16.           ;; *** Should any other properties be reinitialized here?
  17.           (cond ((or (eq? type 'var) (eq? type 'method-var))
  18.              (setf (var-fixity def) '#f)
  19.              (setf (var-signature def) '#f))
  20.             ((eq? type 'con)
  21.              (setf (con-fixity def) '#f)))
  22.           (when (eq? (module-type *module*) 'interface)
  23.             (add-interface-definition (def-module def) def))
  24.           def))))
  25.     (else (create-definition/non-core module name type))))
  26.  
  27. (define (create-definition/non-core module name type)
  28.   (let ((mname  (module-name module)))
  29.     (when (eq? (module-type *module*) 'interface)
  30.        (mlet (((mod name1) (rename-interface-symbol name)))
  31.          (setf mname mod)
  32.      (setf name name1)))
  33.     (let ((res (create-definition/inner mname name type)))
  34.       (when (eq? (module-type *module*) 'interface)
  35.      (add-interface-definition mname res))
  36.       res)))
  37.  
  38. (define (create-definition/inner mname name type)
  39.     (cond ((eq? type 'var)
  40.        (make var (name name) (module mname) (unit *unit*)))
  41.       ((eq? type 'con)
  42.        (make con (name name) (module mname) (unit *unit*)))
  43.       ((eq? type 'synonym)
  44.        (make synonym (name name) (module mname) (unit *unit*)))
  45.       ((eq? type 'algdata)
  46.        (make algdata (name name) (module mname) (unit *unit*)))
  47.       ((eq? type 'class)
  48.        (make class (name name) (module mname) (unit *unit*)))
  49.       ((eq? type 'method-var)
  50.        (make method-var (name name) (module mname) (unit *unit*)))
  51.       ((eq? type 'di)
  52.        (make deriving (name name) (module mname) (unit *unit*)))
  53.       (else
  54.        (error "Bad type argument ~s." type))))
  55.  
  56. (define (create-top-definition name type)
  57.   (let ((def (create-definition *module* name type)))
  58.     (insert-top-definition name def)
  59.     def))
  60.  
  61. ;;; Interfaces have a special table which resolves imports in the
  62. ;;; interface.  Given a name in an interface module this returns the
  63. ;;; corresponding full name: a (module,original-name) pair.  Symbols not
  64. ;;; imported are assumed to be defined in the interface.
  65.  
  66. (define (rename-interface-symbol name)
  67.   (let ((res (assq name (module-interface-imports *module*))))
  68.     (if (eq? res '#f)
  69.     (values *module-name* name)
  70.     (values (tuple-2-1 (tuple-2-2 res))
  71.         (tuple-2-2 (tuple-2-2 res))))))
  72.  
  73. ;;; This creates a locally defined var node.
  74.  
  75. (define (create-local-definition name)
  76.   (let ((var     (make var (name name) (module *module-name*) (unit *unit*))))
  77.     (setf (var-fixity var) (table-entry *fixity-table* name))
  78.     var))
  79.  
  80. ;;; This maintains a list of definitions referenced in an interface, sorted by
  81. ;;; module (2 level alist).
  82.  
  83. (define (add-interface-definition module def)
  84.  (when (not (def-core? def))
  85.   (setf (def-interface? def) '#t)
  86.   (let ((alist (assq module (module-interface-definitions *module*))))
  87.     (if alist
  88.     (setf (cdr alist) (cons def (cdr alist)))
  89.     (setf (module-interface-definitions *module*)
  90.           (cons (tuple module (list def))
  91.             (module-interface-definitions *module*)))))))
  92.  
  93. ;;; This function creates a new variable. 
  94. ;;; The "root" may be either a symbol or a string.
  95. ;;; *unit* defines the home module of the variable.
  96.  
  97. ;;; *** Maybe it would be possible to hack this so that it doesn't
  98. ;;; *** create any symbol at all until the name is demanded by something,
  99. ;;; *** but that seems like a rather sweeping change.
  100.  
  101. (define (create-temp-var root)
  102.   (let* ((name   (gensym (if (symbol? root) (symbol->string root) root)))
  103.      (module  *unit*))
  104.     (make var (name name) (module module) (unit *unit*))))
  105.  
  106.  
  107. ;;; The following routines install top level definitions into the symbol
  108. ;;; table.
  109.  
  110. (predefine (signal-multiple-name-conflict name old-local-name def))
  111.     ; in import-export/ie-errors.scm
  112.  
  113. (define (insert-top-definition name def)
  114.   (let ((old-definition (resolve-toplevel-name name)))
  115.     (cond ((eq? old-definition '#f)
  116.        (when (not (def-core? def))
  117.            (setf (table-entry *symbol-table* name) def))
  118.        (when (and (var? def) (not (eq? (var-fixity def) '#f)))
  119.              (setf (table-entry *fixity-table* name)
  120.            (var-fixity def)))
  121.        (when (and (con? def) (not (eq? (con-fixity def) '#f)))
  122.              (setf (table-entry *fixity-table* name)
  123.            (con-fixity def)))
  124.        (when (not (def-core? def))
  125.          (if (eq? (local-name def) '#f)
  126.         (setf (table-entry *inverted-symbol-table* def) name)
  127.         (signal-multiple-name-conflict name (local-name def) def))))
  128.       ((eq? old-definition def)
  129.        'OK)
  130.       ((def-core? old-definition)
  131.        (signal-core-redefinition name def))
  132.       ((and (module-uses-standard-prelude? *module*)
  133.         (table-entry *prelude-symbol-table* name))
  134.        (if (eq? (def-module def) *module-name*)
  135.            (signal-prelude-redefinition name def)
  136.            (signal-prelude-reimport name (def-module def) def)))
  137.       ((eq? (def-module def) *module-name*)
  138.        (signal-multiple-definition-in-module
  139.         name *module-name* old-definition def))
  140.       ((eq? (def-module old-definition) *module-name*)
  141.        (signal-redefinition-by-imported-symbol
  142.         name *module-name* def old-definition))
  143.       (else
  144.        (signal-multiple-import name *module-name* def old-definition)))))
  145.  
  146. ;;; Gets the fixity of a name.
  147.  
  148. (define (get-local-fixity name)
  149.   (table-entry *fixity-table* name))
  150.  
  151. ;;; These routines support general scoping issues.  Only vars have local
  152. ;;; definitions - all other names are resolved from the global symbol table.
  153.  
  154. ;;; This is used when the name must be in the top symbols.
  155.  
  156. (define (fetch-top-def name type)
  157.   (let ((def (resolve-toplevel-name name)))
  158.     (cond ((eq? def '#f)
  159.        (cond ((interface-module? *module*)
  160.           (mlet (((mod name1) (rename-interface-symbol name)))
  161.             (if (eq? mod *module-name*)
  162.             (undefined-topsym name type)
  163.             (if (and (module-prelude? *module*)
  164.                  (table-entry *core-symbols* name1))
  165.                 (let ((def (table-entry *core-symbols* name1)))
  166.                   (insert-top-definition name1 def)
  167.                   def)
  168.                 (create-interface-type name mod name1 type)))))
  169.          (else
  170.           (undefined-topsym name type))))
  171.       (else def))))
  172.  
  173. (define (undefined-topsym name type)
  174.   (signal-undefined-symbol name type)
  175.   *undefined-def*)
  176.  
  177. ;;; Interfaces may contain references to unknown type system objects.
  178. ;;; In this case, dummy objects must be created.
  179.  
  180. (define (create-interface-type local-name mod name type)
  181.   (let ((new-def (create-definition/inner mod name type)))
  182.     (insert-top-definition local-name new-def)
  183.     (push new-def (module-unresolved-symbols *module*))
  184.     new-def))
  185.  
  186. (define (resolve-toplevel-name name)
  187.  (forward-def
  188.   (let ((pc (table-entry *prelude-core-symbols* name)))
  189.     (cond ((not (eq? pc '#f))
  190.        pc)
  191.       ((module-uses-standard-prelude? *module*)
  192.        (let ((res (table-entry *prelude-symbol-table* name)))
  193.          (if (eq? res '#f)
  194.          (resolve-toplevel-name-1 name)
  195.          res)))
  196.       (else
  197.        (resolve-toplevel-name-1 name))))))
  198.  
  199. (define (resolve-toplevel-name-1 name)
  200.   (cond ((eq? (module-inherited-env *module*) '#f)
  201.      (table-entry *symbol-table* name))
  202.     (else
  203.      (let ((res (search-inherited-tables
  204.              name (module-inherited-env *module*))))
  205.        (if (eq? res '#f)
  206.            (table-entry *symbol-table* name)
  207.            res)))))
  208.  
  209. (define (search-inherited-tables name mod)
  210.   (if (eq? mod '#f)
  211.       '#f
  212.       (let ((res (table-entry (module-symbol-table mod) name)))
  213.     (if (eq? res '#f)
  214.         (search-inherited-tables name (module-inherited-env mod))
  215.         res))))
  216.  
  217. (define (forward-def def)
  218.   (and def (or (def-forward-to def) def)))
  219.  
  220. ;;; Con-ref's are special in that the naming convention (;Name) ensures
  221. ;;; that if a def is found it must be a con.
  222.  
  223. (define (resolve-con con-ref)
  224.   (when (eq? (con-ref-con con-ref) *undefined-def*)
  225.     (remember-context con-ref
  226.       (let ((def (fetch-top-def (con-ref-name con-ref) 'con)))
  227.     (setf (con-ref-con con-ref) def)))))
  228.  
  229. (define (resolve-class class-ref)
  230.   (when (eq? (class-ref-class class-ref) *undefined-def*)
  231.     (remember-context class-ref
  232.       (let ((def (fetch-top-def (class-ref-name class-ref) 'class)))
  233.     (when (and (not (eq? def *undefined-def*)) (not (class? def)))
  234.       (signal-class-name-required def (class-ref-name class-ref)))
  235.     (setf (class-ref-class class-ref) def)))))
  236.  
  237. (define (resolve-tycon tycon)
  238.   (when (eq? (tycon-def tycon) *undefined-def*)
  239.     (remember-context tycon
  240.       (l