diff options
Diffstat (limited to 'import-export')
| -rw-r--r-- | import-export/README | 15 | ||||
| -rw-r--r-- | import-export/ie-errors.scm | 154 | ||||
| -rw-r--r-- | import-export/ie-utils.scm | 121 | ||||
| -rw-r--r-- | import-export/ie.scm | 16 | ||||
| -rw-r--r-- | import-export/import-export.scm | 209 | ||||
| -rw-r--r-- | import-export/init-modules.scm | 142 | ||||
| -rw-r--r-- | import-export/locate-entity.scm | 126 | ||||
| -rw-r--r-- | import-export/top-definitions.scm | 98 |
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)))))) + + + |