;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:04:19 1998
;;;; Contains: Tests of UNEXPORT


(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unexport

(deftest unexport.1
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
           (r (export (intern "X" p) p))
           (i 0) x y)
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (progn (setf x (incf i)) sym1)
                 (progn (setf y (incf i)) p))
       (multiple-value-bind*
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt r t)
             (eql i 2) (eql x 1) (eql y 2)
             (eqt sym1 sym2)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
  t)

(deftest unexport.2
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
           (r (export (intern "X" p) p)))
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (list sym1) "X")
       (multiple-value-bind*
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt sym1 sym2)
             (eqt r t)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
  t)

(deftest unexport.3
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
           (r1 (export (intern "X" p) p))
           (r2 (export (intern "Y" p) p)))
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (multiple-value-bind*
        (sym1a access1a)
        (find-symbol "Y" p)
        (unexport (list sym1 sym1a) '#:|X|)
        (multiple-value-bind*
         (sym2 access2)
         (find-symbol "X" p)
         (multiple-value-bind*
          (sym2a access2a)
          (find-symbol "Y" p)
          (and (eqt sym1 sym2)
               (eqt sym1a sym2a)
               (eqt r1 t)
               (eqt r2 t)
               (eqt access1 :external)
               (eqt access2 :internal)
               (eqt access1a :external)
               (eqt access2a :internal)
               (equal (symbol-name sym1) "X")
               (equal (symbol-name sym1a) "Y")
               t)))))))
  t)

(deftest unexport.4
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
           (r (export (intern "X" p) p)))
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (list sym1) #\X)
       (multiple-value-bind*
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt sym1 sym2)
             (eqt r t)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
  t)

;; Check that it signals a package error when unexporting
;;  an inaccessible symbol

(deftest unexport.5
  (signals-error
   (progn
     (when (find-package "X") (delete-package "X"))
     (unexport 'a (make-package "X" :use nil))
     nil)
   package-error)
  t)

;; Check that internal symbols are left alone

(deftest unexport.6
  (progn
    (when (find-package "X") (delete-package "X"))
    (let ((p (make-package "X" :use nil)))
      (let* ((sym (intern "FOO" p))
             (r (unexport sym p)))
        (multiple-value-bind*
         (sym2 access)
         (find-symbol "FOO" p)
         (and (eqt r t)
              (eqt access :internal)
              (eqt sym sym2)
              (equal (symbol-name sym) "FOO")
              t)))))
  t)

;;; Specialized sequence tests

(defmacro def-unexport-test (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (safely-delete-package name)
       (let* ((p (make-package name :use nil))
              (r (export (intern "X" p) p)))
         (multiple-value-bind*
          (sym1 access1)
          (find-symbol "X" p)
          (unexport (list sym1) name)
          (multiple-value-bind*
           (sym2 access2)
           (find-symbol "X" p)
           (and (eqt sym1 sym2)
                (eqt r t)
                (eqt access1 :external)
                (eqt access2 :internal)
                (equal (symbol-name sym1) "X")
                t)))))
     t))

(def-unexport-test unexport.7
  (make-array 5 :initial-contents "TEST1" :element-type 'base-char))

(def-unexport-test unexport.8
  (make-array 10 :initial-contents "TEST1ABCDE"
              :fill-pointer 5 :element-type 'base-char))

(def-unexport-test unexport.9
  (make-array 10 :initial-contents "TEST1ABCDE"
              :fill-pointer 5 :element-type 'character))

(def-unexport-test unexport.10
  (make-array 5 :initial-contents "TEST1"
              :adjustable t :element-type 'base-char))

(def-unexport-test unexport.11
  (make-array 5 :initial-contents "TEST1"
              :adjustable t :element-type 'character))

(def-unexport-test unexport.12
  (let* ((etype 'base-char)
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
    (make-array 5 :element-type etype
                :displaced-to name0
                :displaced-index-offset 5)))

(def-unexport-test unexport.13
  (let* ((etype 'character)
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
    (make-array 5 :element-type etype
                :displaced-to name0
                :displaced-index-offset 5)))

;;; Error tests

(deftest unexport.error.1
  (signals-error (unexport) program-error)
  t)

(deftest unexport.error.2
  (signals-error (unexport 'xyz "CL-TEST" nil) program-error)
  t)