From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- import-export/import-export.scm | 209 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 209 insertions(+) create mode 100644 import-export/import-export.scm (limited to 'import-export/import-export.scm') 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-cistring (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?))))) + + + -- cgit v1.2.3