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