home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / import-export / top-definitions.scm < prev   
Encoding:
Text File  |  1994-09-27  |  4.0 KB  |  116 lines  |  [TEXT/CCL2]
  1. ;;; File: top-definitions.scm
  2.  
  3. ;;; Description: This creates definitions for all top level (exportable)
  4. ;;;  object in a module.
  5.  
  6. (define (create-top-definitions)
  7.   (dolist (decl (module-decls *module*))
  8.     (if (interface-module? *module*)
  9.     (when (signdecl? decl)
  10.        (create-var-definitions decl (signdecl-vars decl)))
  11.     (when (valdef? decl)
  12.        (create-var-definitions
  13.         decl (collect-pattern-vars (valdef-lhs decl))))))
  14.   (dolist (algdata (module-algdatas *module*))
  15.     (create-alg-definitions algdata))
  16.   (dolist (synonym (module-synonyms *module*))
  17.     (create-syn-definitions synonym))
  18.   (dolist (class (module-classes *module*))
  19.     (create-class-definitions class))
  20.   (dolist (deriving (module-derivings *module*))
  21.     (create-deriving-definition deriving)))
  22.  
  23. ;;; ------------------------------------------------------------------------
  24. ;;; creation of definitions
  25. ;;; ------------------------------------------------------------------------
  26.  
  27. (define (create-var-definitions decl vars)
  28.   (remember-context decl
  29.     (dolist (v vars)
  30.      (let* ((var-name (var-ref-name v))
  31.         (def (create-top-definition var-name 'var)))
  32.        (setf (def-where-defined def) 
  33.          (ast-node-line-number decl))
  34.        (setf (var-ref-var v) def)
  35.        (add-new-group var-name def)))))
  36.  
  37. ;;; This also creates definitions for the constructors
  38.  
  39. (define (create-alg-definitions algdata)
  40.   (remember-context algdata
  41.     (with-slots data-decl (simple constrs) algdata
  42.       (let* ((alg-name (tycon-name simple))
  43.          (def (create-top-definition alg-name 'algdata)))
  44.     (setf (def-where-defined def) 
  45.           (ast-node-line-number algdata))
  46.     (setf (tycon-def simple) def)
  47.     (let ((constr-group
  48.            (map (lambda (constr) 
  49.              (let* ((con-ref (constr-constructor constr))
  50.                 (con-name (con-ref-name con-ref))
  51.                 (con-def (create-top-definition con-name 'con)))
  52.                 (setf (con-ref-con con-ref) con-def)
  53.             (tuple con-name con-def)))
  54.             constrs)))
  55.       (setf (algdata-constrs def) (map (function tuple-2-2) constr-group))
  56.       (setf (tycon-def-arity def) (length (tycon-args simple)))
  57.       (add-new-group alg-name def constr-group))))))
  58.  
  59. (define (create-class-definitions class-decl)
  60.   (remember-context class-decl
  61.     (with-slots class-decl (class decls) class-decl
  62.       (let* ((class-name (class-ref-name class))
  63.          (class-def (create-top-definition class-name 'class)))
  64.     (setf (def-where-defined class-def) 
  65.           (ast-node-line-number class-decl))
  66.     (setf (class-ref-class class) class-def)
  67.     (let ((method-group
  68.            (concat
  69.         (map
  70.          (lambda (decl) 
  71.           (if (is-type? 'signdecl decl)
  72.               (remember-context decl
  73.                (map (lambda (method-var)
  74.                   (let* ((var-name (var-ref-name method-var))
  75.                      (def (create-top-definition
  76.                           var-name 'method-var)))
  77.                 (setf (def-where-defined def)
  78.                       (ast-node-line-number method-var))
  79.                 (setf (method-var-class def) class-def)
  80.                 (setf (method-var-default def) '#f)
  81.                 (setf (var-ref-var method-var) def)
  82.                 (tuple var-name def)))
  83.                 (signdecl-vars decl)))
  84.               '()))
  85.         decls))))
  86.       (setf (class-method-vars class-def)
  87.         (map (function tuple-2-2) method-group))
  88.       (add-new-group class-name class-def method-group))))))
  89.  
  90. (define (create-syn-definitions synonym-decl)
  91.   (remember-context synonym-decl
  92.     (let* ((simple (synonym-decl-simple synonym-decl))
  93.        (syn-name (tycon-name simple))
  94.        (def (create-top-definition syn-name 'synonym)))
  95.       (setf (def-where-defined def) 
  96.         (ast-node-line-number synonym-decl))
  97.       (setf (tycon-def simple) def)
  98.       (setf (tycon-def-arity def) (length (tycon-args simple)))
  99.       (add-new-group syn-name def))))
  100.  
  101. (define (add-new-group name def . others)
  102.   (when (memq *module* (module-exported-modules *module*))
  103.       (export-group (cons (tuple name def)
  104.               (if (null? others)
  105.                   '()
  106.                   (car others))))))
  107.  
  108. (define (create-deriving-definition di)
  109.   (remember-context di
  110.     (let* ((simple (deriving-decl-simple di))
  111.        (di-name (add-di-prefix (tycon-name simple)))
  112.        (def (create-top-definition di-name 'di)))
  113.       (setf (tycon-def simple) def)
  114.       (add-new-group di-name def))))
  115.  
  116.