home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / import-export / import-export.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  10.1 KB  |  297 lines  |  [TEXT/CCL2]
  1. ;;; This is the main driver for the import / export routine
  2.  
  3. (define (import-export modules)
  4.   (add-modules-to-program modules)
  5.   (walk-modules modules
  6.       (lambda () (init-module-structure)))
  7.   (import-export/fixpoint modules '#t)
  8.   (walk-modules modules (lambda () (check-missing-names)))
  9.   (when (memq 'import (dynamic *printers*))
  10.     (show-export-tables modules))
  11.   (walk-modules (get-all-interfaces)
  12.       (lambda () (attach-external-definitions modules)))
  13.   (walk-modules (get-all-interfaces)
  14.      (lambda () (forward-dangling-references)))
  15.   modules)
  16.  
  17. (define (import-export/interface modules)
  18.   (add-modules-to-program modules)
  19.   (walk-modules modules
  20.       (lambda () (init-module-structure)))
  21.   (walk-modules modules
  22.       (lambda () (create-top-definitions)
  23.              (attach-fixities))))
  24.  
  25. (define (import-export/fixpoint modules initial-cycle?)
  26.   (setf *new-exports-found?* '#f)
  27.   (walk-modules modules
  28.    (lambda ()
  29.      (setf (module-fresh-exports *module*) '())
  30.      (when initial-cycle?
  31.        (create-top-definitions)
  32.        (attach-fixities)
  33.        (import-non-local))
  34.      (locally-import)
  35.      (locally-export)))
  36.   (when *new-exports-found?*
  37.       (import-export/fixpoint modules '#f)))
  38.  
  39. ;;; This does the non-local importing from previously defined modules
  40.  
  41. (define (import-non-local)
  42.   (setf (module-imports *module*)
  43.     (process-non-local-imports (module-imports *module*))))
  44.  
  45. (define (process-non-local-imports imports)
  46.   (if (null? imports)
  47.       '()
  48.       (let* ((import (car imports)))
  49.         (with-slots import-decl (module mode specs renamings) import
  50.       (cond ((eq? *unit* (module-unit module))
  51.          (cons import (process-non-local-imports (cdr imports))))
  52.         ((eq? mode 'all)
  53.          (import-all-entities module specs renamings import)
  54.          (process-non-local-imports (cdr imports)))
  55.         (else
  56.          (import-named-entities module specs renamings import)
  57.          (process-non-local-imports (cdr imports))))))))
  58.  
  59. (define (import-all-entities module hiding renamings import-decl)
  60.   (table-for-each
  61.    (lambda (name group)
  62.      (declare (ignore name))
  63.      (cond ((in-hiding-list? group hiding)
  64.         (setf hiding (remove-entity group hiding)))
  65.        (else
  66.         (import-group (rename-group group renamings) module))))
  67.    (module-export-table module))
  68.   (when (not (null? hiding))
  69.     (remember-context import-decl
  70.       (dolist (h hiding)
  71.     (signal-unused-hiding (entity-name h) (module-name module)))))
  72.   (find-unused-renamings renamings import-decl))
  73.  
  74. (define (import-named-entities mod specs renamings import-decl)
  75.   (dolist (entity specs)
  76.     (let ((group (locate-entity/export-table entity mod '#t)))
  77.       (when (not (eq? group 'error))
  78.     (setf group (rename-group group renamings))
  79.     (import-group group mod))))
  80.   (find-unused-renamings renamings import-decl))
  81.  
  82. ;;; This takes a module and processes the import declarations, moving as
  83. ;;; many entities from the freshly exported components of other modules into
  84. ;;; the current module.
  85.  
  86. (define (locally-import)
  87.   (dolist (import (module-imports *module*))
  88.     (with-slots import-decl (module mode specs renamings) import
  89.       (if (eq? mode 'all)
  90.       (import-fresh-entities import module specs renamings)
  91.       (setf (import-decl-specs import)
  92.         (import-entities specs module renamings))))))
  93.  
  94. (define (import-fresh-entities import module hiding renamings)
  95.   (dolist (group (module-fresh-exports module))
  96.     (cond ((in-hiding-list? group hiding)
  97.         (setf hiding (remove-entity group hiding)))
  98.        (else
  99.         (import-group (rename-group group renamings) module))))
  100.   (setf (import-decl-specs import) hiding))
  101.  
  102. (define (import-entities entities module renamings)
  103.   (if (null? entities)
  104.       '()
  105.       (let ((group (locate-entity/export-table (car entities) module '#f)))
  106.     (cond ((eq? group 'not-found)
  107.            (cons (car entities)
  108.              (import-entities (cdr entities) module renamings)))
  109.           ((eq? group 'error)
  110.            (import-entities (cdr entities) module renamings))
  111.           (else
  112.            (setf group (rename-group group renamings))
  113.            (import-group group module)
  114.            (import-entities (cdr entities) module renamings))))))
  115.  
  116. ;;; This imports a group into *module*.  module is the place the group is
  117. ;;; taken from.
  118.  
  119. (define (import-group group module)
  120.   (when (memq module (module-exported-modules *module*))
  121.     (export-group group))
  122.   (dolist (n-d group)
  123.     (insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d))))
  124.  
  125. ;;; This takes as yet unresolved exports and moves them to the export table.
  126.  
  127. (define (locally-export)
  128.   (setf (module-exports *module*)
  129.     (export-entities (module-exports *module*))))
  130.  
  131. (define (export-entities entities)
  132.   (if (null? entities)
  133.       '()
  134.       (let* ((entity (car entities))
  135.          (group (locate-entity entity)))
  136.     (cond ((eq? group 'error)
  137.            (export-entities (cdr entities)))
  138.           ((eq? group 'not-found)
  139.            (cons entity (export-entities (cdr entities))))
  140.           (else
  141.            (export-group group)
  142.            (export-entities (cdr entities)))))))
  143.  
  144.  
  145. ;;; This moves a group into the export table.  If this export is new,
  146. ;;; a flag is set.
  147.  
  148. (define (export-group group)
  149.   (let* ((export-table (module-export-table *module*))
  150.      (old-group (table-entry export-table (group-name group))))
  151.     (when (or (eq? old-group '#f)
  152.           (and (hidden-constructors? old-group)
  153.            (not (hidden-constructors? group))))
  154.       (setf (table-entry export-table (group-name group)) group)
  155.       (dolist (n-d group)
  156.         (setf (def-exported? (tuple-2-2 n-d)) '#t))
  157.       (push group (module-fresh-exports *module*))
  158.       (setf *new-exports-found?* '#t))))
  159.  
  160. (define (show-export-tables modules)
  161.   (walk-modules modules
  162.     (lambda ()
  163.       (format '#t "~%Exports from module ~A~%" *module-name*)
  164.       (let ((exports '()))
  165.     (table-for-each (lambda (key val)
  166.               (push (cons key val) exports))
  167.             (module-export-table *module*))
  168.     (setf exports (sort-list exports
  169.                  (lambda (x y)
  170.                    (string-ci<? (symbol->string (car x))
  171.                         (symbol->string (car y))))))
  172.     (dolist (e exports)
  173.           (print-exported-group (car e) (group-definition (cdr e))
  174.                 (cdr (cdr e))))))))
  175.  
  176. (define (print-exported-group name def extras)
  177.   (if (eq? (def-module def) *module-name*)
  178.       (format '#t " ")
  179.       (format '#t "*"))
  180.   (cond ((synonym? def)
  181.      (format '#t "type  "))
  182.     ((algdata? def)
  183.      (format '#t "data  "))
  184.     ((class? def)
  185.      (format '#t "class "))
  186.     (else
  187.      (format '#t "      ")))
  188.   (format '#t "~A" name)
  189.   (when (not (eq? name (def-name def)))
  190.      (format '#t "[~A]" (def-name def)))
  191.   (when extras
  192.      (format '#t " (")
  193.      (print-exported-group-1 extras (algdata? def)))
  194.   (format '#t "~%"))
  195.  
  196. (define (print-exported-group-1 extras alg?)
  197.   (let* ((name (tuple-2-1 (car extras)))
  198.      (ns (symbol->string name))
  199.      (def (tuple-2-2 (car extras))))
  200.     (format '#t "~A" (if alg? (remove-con-prefix ns) ns))
  201.     (when (not (eq? name (def-name def)))
  202.       (let ((name1 (symbol->string (def-name def))))
  203.       (format '#t "[~A]" (if alg? (remove-con-prefix name1) name1))))
  204.     (if (null? (cdr extras))
  205.     (format '#t ")")
  206.     (begin
  207.       (format '#t ",")
  208.       (print-exported-group-1 (cdr extras) alg?)))))
  209.  
  210.  
  211.  
  212. ;;; This is for interfaces used by the program.  This walks over all known
  213. ;;; interfaces and distributes their definitions to the appropriate module.
  214. ;;; The forward-to field of every def in the interfaces is initialized here.
  215.  
  216. (define (attach-external-definitions mods)
  217.    ;; The interface-definitions slot contains an alist of module-name and
  218.    ;; defs located in that module.
  219.    (dolist (alist (module-interface-definitions *module*))
  220.      (let* ((mod (car alist))
  221.         (defs (cdr alist))
  222.         (mod-ast (locate-module mod)))
  223.        (cond ((not mod-ast)
  224.           ;; The module is totally unknown - create a dummy module
  225.           ;; to hold definitions from it.
  226.           (let ((dummy-module (make module
  227.                     (name mod)
  228.                     (type 'psuedo-interface)
  229.                     (symbol-table (make-table)))))
  230.         (let ((st (module-symbol-table dummy-module)))
  231.           (dolist (def defs)
  232.             (setf (table-entry st (def-name def)) def)))
  233.         (add-modules-to-environment (list dummy-module))))
  234.          ((eq? (module-type mod-ast) 'standard)
  235.           ;; The module is defined as an implementation.  In this case,
  236.           ;; the defs are forwarded to local symbols.
  237.           (let ((st (module-symbol-table mod-ast))
  238.             (compiled-now? (memq mod-ast mods)))
  239.         (dolist (def defs)
  240.           (let ((new-def (table-entry st (def-name def))))
  241.             (cond (new-def
  242.             ;; This needs more error checking - we might forward
  243.             ;; a class to a type or some such!
  244.                (setf (def-forward-to def) new-def)
  245.                (unless compiled-now?
  246.                    (check-interface def new-def)))
  247.               (else
  248.                ;; The interface said it was here but NO!
  249.                (missing-interface-symbol-error def)))))))
  250.          ((eq? (module-type mod-ast) 'interface)
  251.           (if (eq? mod-ast *module*)
  252.           (dolist (def defs)
  253.                 (setf (def-forward-to def) '#f)) ; clean out old forwarding
  254.           (let ((st (module-symbol-table mod-ast)))
  255.             (dolist (def defs)
  256.               (let ((new-def (table-entry st (def-name def))))
  257.             (cond (new-def
  258.                    (check-interface def new-def))
  259.                   (else
  260.                    ;; The interface said it was here but NO!
  261.                    (missing-interface-symbol-error def))))))))
  262.          (else
  263.           ;; Must be a dummy interface
  264.           (let ((st (module-symbol-table mod-ast)))
  265.         (dolist (def defs)
  266.           (setf (def-forward-to def) '#f)
  267.           (let ((new-def (table-entry st (def-name def))))
  268.             (cond (new-def
  269.                 (check-interface/dummy def new-def)
  270.                 (when (def-more-specific? def new-def)
  271.                    (setf (table-entry (module-symbol-table mod-ast)
  272.                           (def-name def))
  273.                      def)))
  274.               (else
  275.                ;; The interface said it was here but NO!
  276.                (missing-interface-symbol-error def)))))))))))
  277.  
  278.  
  279. (define (forward-dangling-references)
  280.   (dolist (def (module-unresolved-symbols *module*))
  281.     (let ((mod (locate-module (def-module def))))
  282.       (if mod
  283.       (let ((def1 (table-entry (module-symbol-table mod) (def-name def))))
  284.         (if def1
  285.         (begin
  286.           (check-interface/dangling def def1)
  287.           (setf (def-forward-to def) (forward-def def1)))
  288.         (missing-interface-symbol-error def)))
  289.       (missing-interface-symbol-error def)))))
  290.  
  291. (define (missing-interface-symbol-error def)
  292.   (phase-error/objs 'missing-interface-symbol (list def)
  293.     "Interface ~A requires a definition of ~A which is not present"
  294.       *module-name* (get-object-name def)))
  295.  
  296.  
  297.