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

(in-package :cl-test)

(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 ~S ~S ~S ~S~%" sym p sym2 access (quote ,(copy-list symbol-types)))
		       (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))
