;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Jun 21 20:59:17 2004
;;;; Contains: Aux. functions for package tests



(defmacro test-with-package-iterator (package-list-expr &rest symbol-types)
  "Build an expression that tests the with-package-iterator form."
  (let ((name (gensym))
        (cht-var (gensym))
        (pkg-list-var (gensym)))
    `(let ((,cht-var (make-hash-table))
           (,pkg-list-var ,package-list-expr)
           (fail-count 0))
         (with-package-iterator (,name ,pkg-list-var
                                       ,@(copy-list symbol-types))
           ;; For each symbol, check that name is returning appropriate
           ;; things
           (loop
             (block fail
               (multiple-value-bind (more sym access pkg)
                   (,name)
                 (unless more (return nil))
                 (setf (gethash sym ,cht-var) t)  ;; note presence of symbol
                 ;; Check that its access status is in the list,
                 ;;  that pkg is a package,
                 ;;  that the symbol is in the package,
                 ;;  and that (in the package) it has the correct access type
                 (unless (member access (quote ,(copy-list symbol-types)))
                   (unless (> fail-count +fail-count-limit+)
                     (format t "Bad access type: ~S ==> ~A~%" sym access))
                   (when (= fail-count +fail-count-limit+)
                     (format t "Further messages suppressed~%"))
                   (incf fail-count)
                   (return-from fail nil))

                 (unless (packagep pkg)
                   (unless (> fail-count +fail-count-limit+)
                     (format t "Not a package: ~S ==> ~S~%" sym pkg))
                   (when (= fail-count +fail-count-limit+)
                     (format t "Further messages suppressed~%"))
                   (incf fail-count)
                   (return-from fail nil))
                 (multiple-value-bind (sym2 access2)
                     (find-symbol (symbol-name sym) pkg)
                   (unless (or (eqt sym sym2)
                               (member sym2 (package-shadowing-symbols pkg)))
                     (unless (> fail-count +fail-count-limit+)
                       (format t "Not same symbol: ~S ~S~%" sym sym2))
                     (when (= fail-count +fail-count-limit+)
                       (format t "Further messages suppressed~%"))
                     (incf fail-count)
                     (return-from fail nil))
                   (unless  (eqt access access2)
                     (unless (> fail-count +fail-count-limit+)
                       (format t "Not same access type: ~S ~S ~S~%"
                               sym access access2))
                     (when (= fail-count +fail-count-limit+)
                       (format t "Further messages suppressed~%"))
                     (incf fail-count)
                     (return-from fail nil)))))))
         ;; now, check that each symbol in each package has
         ;; been properly found
         (loop
             for p in ,pkg-list-var do
               (block fail
                 (do-symbols (sym p)
                   (multiple-value-bind (sym2 access)
                       (find-symbol (symbol-name sym) p)
                     (unless (eqt sym sym2)
                       (unless (> fail-count +fail-count-limit+)
                         (format t "Not same symbol (2): ~S ~S~%"
                                 sym sym2))
                       (when (= fail-count +fail-count-limit+)
                         (format t "Further messages suppressed~%"))
                       (incf fail-count)
                       (return-from fail nil))
                     (unless (or (not (member access
                                              (quote ,(copy-list symbol-types))))
                                 (gethash sym ,cht-var))
                       (format t "Symbol not found: ~S~%" sym)
                       (incf fail-count)
                       (return-from fail nil))))))
         (or (zerop fail-count) fail-count))))

(defun with-package-iterator-internal (packages)
  (test-with-package-iterator packages :internal))

(defun with-package-iterator-external (packages)
  (test-with-package-iterator packages :external))

(defun with-package-iterator-inherited (packages)
  (test-with-package-iterator packages :inherited))

(defun with-package-iterator-all (packages)
  (test-with-package-iterator packages :internal :external :inherited))

(defun num-external-symbols-in-package (p)
  (let ((num 0))
    (declare (fixnum num))
    (do-external-symbols (s p num)
      (declare (ignorable s))
      (incf num))))

(defun external-symbols-in-package (p)
  (let ((symbols nil))
    (do-external-symbols (s p)
      (push s symbols))
    (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1)
                                             (symbol-name s2))))))

(defun num-symbols-in-package (p)
  (let ((num 0))
    (declare (fixnum num))
    (do-symbols (s p num)
      (declare (ignorable s))
      (incf num))))

(defun sort-symbols (sl)
  (sort (copy-list sl)
        #'(lambda (x y)
            (or
             (string< (symbol-name x)
                      (symbol-name y))
             (and (string= (symbol-name x)
                           (symbol-name y))
                  (string< (package-name (symbol-package x))
                           (package-name (symbol-package y))))))))

(defun sort-package-list (x)
  (sort (copy-list x)
        #'string<
        :key #'package-name))