;;; 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))))))