;;;; miscellaneous tests of package-related stuff

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(make-package "FOO")
(defvar *foo* (find-package (coerce "FOO" 'base-string)))
(rename-package "FOO" (make-array 0 :element-type nil))
(assert (eq *foo* (find-package "")))
(assert (delete-package ""))

(make-package "BAR")
(defvar *baz* (rename-package "BAR" "BAZ"))
(assert (eq *baz* (find-package "BAZ")))
(assert (delete-package *baz*))

(handler-case
    (export :foo)
  (package-error (c) (princ c))
  (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))

(make-package "FOO")
(assert (shadow #\a :foo))

(defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))

(defpackage :PACKAGE-DESIGNATOR-2
  (:import-from #.(find-package :cl) "+"))

(defpackage "EXAMPLE-INDIRECT"
  (:import-from "CL" "+"))

(defpackage "EXAMPLE-PACKAGE"
  (:shadow "CAR")
  (:shadowing-import-from "CL" "CAAR")
  (:use)
  (:import-from "CL" "CDR")
  (:import-from "EXAMPLE-INDIRECT" "+")
  (:export "CAR" "CDR" "EXAMPLE"))

(flet ((check-symbol (name expected-status expected-home-name)
         (multiple-value-bind (symbol status)
             (find-symbol name "EXAMPLE-PACKAGE")
           (let ((home (symbol-package symbol))
                 (expected-home (find-package expected-home-name)))
             (assert (eql home expected-home))
             (assert (eql status expected-status))))))
  (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  (check-symbol "CDR" :external "CL")
  (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  (check-symbol "CAAR" :internal "CL")
  (check-symbol "+" :internal "CL")
  (check-symbol "CDDR" nil "CL"))

(defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))

(assert (raises-error? (defpackage "A-NICKNAME")))

(assert (eql (find-package "A-NICKNAME")
             (find-package "TEST-ORIGINAL")))

;;;; Utilities
(defun sym (package name)
 (let ((package (or (find-package package) package)))
   (multiple-value-bind (symbol status)
       (find-symbol name package)
     (assert status
             (package name symbol status)
             "No symbol with name ~A in ~S." name package symbol status)
   (values symbol status))))

(defmacro with-name-conflict-resolution ((symbol &key restarted)
                                         form &body body)
  "Resolves potential name conflict condition arising from FORM.

The conflict is resolved in favour of SYMBOL, a form which must
evaluate to a symbol.

If RESTARTED is a symbol, it is bound for the BODY forms and set to T
if a restart was invoked."
  (check-type restarted symbol "a binding name")
  (let ((%symbol (copy-symbol 'symbol)))
    `(let (,@(when restarted `((,restarted)))
           (,%symbol ,symbol))
       (handler-bind
           ((sb-ext:name-conflict
             (lambda (condition)
               ,@(when restarted `((setf ,restarted t)))
               (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
               (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
         ,form)
       ,@body)))

(defmacro with-packages (specs &body forms)
  (let ((names (mapcar #'car specs)))
    `(unwind-protect
          (progn
            (delete-packages ',names)
            ,@(mapcar (lambda (spec)
                        `(defpackage ,@spec))
                      specs)
            ,@forms)
       (delete-packages ',names))))

(defun delete-packages (names)
  (dolist (p names)
    (ignore-errors (delete-package p))))


;;;; Tests
;;; USE-PACKAGE
(with-test (:name use-package.1)
  (with-packages (("FOO" (:export "SYM"))
                  ("BAR" (:export "SYM"))
                  ("BAZ" (:use)))
    (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
        (use-package '("FOO" "BAR") "BAZ")
      (is restartedp)
      (is (eq (sym "BAR" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name use-package.2)
  (with-packages (("FOO" (:export "SYM"))
                  ("BAZ" (:use) (:intern "SYM")))
    (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
        (use-package "FOO" "BAZ")
      (is restartedp)
      (is (eq (sym "FOO" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name use-package.2a)
  (with-packages (("FOO" (:export "SYM"))
                  ("BAZ" (:use) (:intern "SYM")))
    (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
        (use-package "FOO" "BAZ")
      (is restartedp)
      (is (equal (list (sym "BAZ" "SYM") :internal)
                 (multiple-value-list (sym "BAZ" "SYM")))))))

(with-test (:name use-package-conflict-set :fails-on :sbcl)
  (with-packages (("FOO" (:export "SYM"))
                  ("QUX" (:export "SYM"))
                  ("BAR" (:intern "SYM"))
                  ("BAZ" (:use) (:import-from "BAR" "SYM")))
    (let ((conflict-set))
      (block nil
        (handler-bind
            ((sb-ext:name-conflict
              (lambda (condition)
                (setf conflict-set (copy-list
                                    (sb-ext:name-conflict-symbols condition)))
                (return))))
          (use-package '("FOO" "QUX") "BAZ")))
      (setf conflict-set
            (sort conflict-set #'string<
                  :key (lambda (symbol)
                         (package-name (symbol-package symbol)))))
      (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
                 conflict-set)))))

;;; EXPORT
(with-test (:name export.1)
  (with-packages (("FOO" (:intern "SYM"))
                  ("BAR" (:export "SYM"))
                  ("BAZ" (:use "FOO" "BAR")))
    (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
        (export (sym "FOO" "SYM") "FOO")
      (is restartedp)
      (is (eq (sym "FOO" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name export.1a)
  (with-packages (("FOO" (:intern "SYM"))
                  ("BAR" (:export "SYM"))
                  ("BAZ" (:use "FOO" "BAR")))
    (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
        (export (sym "FOO" "SYM") "FOO")
      (is restartedp)
      (is (eq (sym "BAR" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name export.ensure-exported)
  (with-packages (("FOO" (:intern "SYM"))
                  ("BAR" (:export "SYM"))
                  ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
    (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
        (export (sym "FOO" "SYM") "FOO")
      (is restartedp)
      (is (equal (list (sym "FOO" "SYM") :external)
                 (multiple-value-list (sym "FOO" "SYM"))))
      (is (eq (sym "FOO" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name export.3.intern)
  (with-packages (("FOO" (:intern "SYM"))
                  ("BAZ" (:use "FOO") (:intern "SYM")))
    (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
        (export (sym "FOO" "SYM") "FOO")
      (is restartedp)
      (is (eq (sym "FOO" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name export.3a.intern)
  (with-packages (("FOO" (:intern "SYM"))
                  ("BAZ" (:use "FOO") (:intern "SYM")))
    (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
        (export (sym "FOO" "SYM") "FOO")
      (is restartedp)
      (is (equal (list (sym "BAZ" "SYM") :internal)
                 (multiple-value-list (sym "BAZ" "SYM")))))))

;;; IMPORT
(with-test (:name import-nil.1)
  (with-packages (("FOO" (:use) (:intern "NIL"))
                  ("BAZ" (:use) (:intern "NIL")))
    (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
        (import (list (sym "FOO" "NIL")) "BAZ")
      (is restartedp)
      (is (eq (sym "FOO" "NIL")
              (sym "BAZ" "NIL"))))))

(with-test (:name import-nil.2)
  (with-packages (("BAZ" (:use) (:intern "NIL")))
    (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
        (import '(CL:NIL) "BAZ")
      (is restartedp)
      (is (eq 'CL:NIL
              (sym "BAZ" "NIL"))))))

(with-test (:name import-single-conflict :fails-on :sbcl)
  (with-packages (("FOO" (:export "NIL"))
                  ("BAR" (:export "NIL"))
                  ("BAZ" (:use)))
    (let ((conflict-sets '()))
      (handler-bind
          ((sb-ext:name-conflict
            (lambda (condition)
              (push (copy-list (sb-ext:name-conflict-symbols condition))
                    conflict-sets)
              (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
        (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
      (is (eql 1 (length conflict-sets)))
      (is (eql 3 (length (first conflict-sets)))))))

;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
;;; multiple symbols of the same name in the package (this particular
;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
(with-test (:name import-conflict-resolution)
  (with-packages (("FOO" (:export "NIL"))
                  ("BAR" (:use)))
    (with-name-conflict-resolution ((sym "FOO" "NIL"))
      (import (list 'CL:NIL (sym "FOO" "NIL")) "BAR"))
    (do-symbols (sym "BAR")
      (assert (eq sym (sym "FOO" "NIL"))))))

;;; UNINTERN
(with-test (:name unintern.1)
  (with-packages (("FOO" (:export "SYM"))
                  ("BAR" (:export "SYM"))
                  ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
    (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
        (unintern (sym "BAZ" "SYM") "BAZ")
      (is restartedp)
      (is (eq (sym "FOO" "SYM")
              (sym "BAZ" "SYM"))))))

(with-test (:name unintern.2)
  (with-packages (("FOO" (:intern "SYM")))
    (unintern :sym "FOO")
    (assert (find-symbol "SYM" "FOO"))))

;;; WITH-PACKAGE-ITERATOR error signalling had problems
(with-test (:name with-package-itarator.error)
  (assert (eq :good
              (handler-case
                  (progn
                    (eval '(with-package-iterator (sym :cl-user :foo)
                            (sym)))
                    :bad)
                ((and simple-condition program-error) (c)
                  (assert (equal (list :foo) (simple-condition-format-arguments c)))
                  :good)))))

;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
(with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
  (let* ((p (make-package :bug-511072))
         (sem1 (sb-thread:make-semaphore))
         (sem2 (sb-thread:make-semaphore))
         (t2 (make-join-thread (lambda ()
                                 (handler-bind ((error (lambda (c)
                                                         (sb-thread:signal-semaphore sem1)
                                                         (sb-thread:wait-on-semaphore sem2)
                                                         (abort c))))
                                   (make-package :bug-511072))))))
    (sb-thread:wait-on-semaphore sem1)
    (with-timeout 10
      (assert (eq 'cons (read-from-string "CL:CONS"))))
    (sb-thread:signal-semaphore sem2)))

(with-test (:name :quick-name-conflict-resolution-import)
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
           (intern "FOO" p1)
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::dont-import-it))))
             (import (intern "FOO" p2) p1))
           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::shadowing-import-it))))
             (import (intern "FOO" p2) p1))
           (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name :quick-name-conflict-resolution-export.1)
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
           (intern "FOO" p1)
           (use-package p2 p1)
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::keep-old))))
             (export (intern "FOO" p2) p2))
           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name :quick-name-conflict-resolution-export.2)
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
           (intern "FOO" p1)
           (use-package p2 p1)
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::take-new))))
             (export (intern "FOO" p2) p2))
           (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name :quick-name-conflict-resolution-use-package.1)
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
           (intern "FOO" p1)
           (intern "BAR" p1)
           (export (intern "FOO" p2) p2)
           (export (intern "BAR" p2) p2)
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::keep-old))))
             (use-package p2 p1))
           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
           (assert (not (eq (intern "BAR" p1) (intern "BAR" p2)))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name :quick-name-conflict-resolution-use-package.2)
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
           (intern "FOO" p1)
           (intern "BAR" p1)
           (export (intern "FOO" p2) p2)
           (export (intern "BAR" p2) p2)
           (handler-bind ((name-conflict (lambda (c)
                                           (invoke-restart 'sb-impl::take-new))))
             (use-package p2 p1))
           (assert (eq (intern "FOO" p1) (intern "FOO" p2)))
           (assert (eq (intern "BAR" p1) (intern "BAR" p2))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name (:package-at-variance-restarts :shadow))
  (let (p)
    (unwind-protect
         (progn
           (setf p (eval `(defpackage :package-at-variance-restarts.1
                            (:use :cl)
                            (:shadow "CONS"))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::keep-them))))
             (eval `(defpackage :package-at-variance-restarts.1
                      (:use :cl))))
           (assert (not (eq 'cl:cons (intern "CONS" p))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::drop-them))))
             (eval `(defpackage :package-at-variance-restarts.1
                      (:use :cl))))
           (assert (eq 'cl:cons (intern "CONS" p))))
      (when p (delete-package p)))))

(with-test (:name (:package-at-variance-restarts :use))
  (let (p)
    (unwind-protect
         (progn
           (setf p (eval `(defpackage :package-at-variance-restarts.2
                            (:use :cl))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::keep-them))))
             (eval `(defpackage :package-at-variance-restarts.2
                      (:use))))
           (assert (eq 'cl:cons (intern "CONS" p)))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::drop-them))))
             (eval `(defpackage :package-at-variance-restarts.2
                      (:use))))
           (assert (not (eq 'cl:cons (intern "CONS" p)))))
      (when p (delete-package p)))))

(with-test (:name (:package-at-variance-restarts :export))
  (let (p)
    (unwind-protect
         (progn
           (setf p (eval `(defpackage :package-at-variance-restarts.4
                            (:export "FOO"))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::keep-them))))
             (eval `(defpackage :package-at-variance-restarts.4)))
           (assert (eq :external (nth-value 1 (find-symbol "FOO" p))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::drop-them))))
             (eval `(defpackage :package-at-variance-restarts.4)))
           (assert (eq :internal (nth-value 1 (find-symbol "FOO" p)))))
      (when p (delete-package p)))))

(with-test (:name (:package-at-variance-restarts :implement))
  (let (p)
    (unwind-protect
         (progn
           (setf p (eval `(defpackage :package-at-variance-restarts.5
                            (:implement :sb-int))))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::keep-them))))
             (eval `(defpackage :package-at-variance-restarts.5)))
           (assert (member p (package-implemented-by-list :sb-int)))
           (handler-bind ((sb-kernel::package-at-variance-error
                            (lambda (c)
                              (invoke-restart 'sb-impl::drop-them))))
             (eval `(defpackage :package-at-variance-restarts.5)))
           (assert (not (member p (package-implemented-by-list :sb-int)))))
      (when p (delete-package p)))))

(with-test (:name (:delete-package :implementation-package))
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
                 p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
           (add-implementation-package p2 p1)
           (assert (= 1 (length (package-implemented-by-list p1))))
           (delete-package p2)
           (assert (= 0 (length (package-implemented-by-list p1)))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))

(with-test (:name (:delete-package :implementated-package))
  (let (p1 p2)
    (unwind-protect
         (progn
           (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
                 p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
           (add-implementation-package p2 p1)
           (assert (= 1 (length (package-implements-list p2))))
           (delete-package p1)
           (assert (= 0 (length (package-implements-list p2)))))
      (when p1 (delete-package p1))
      (when p2 (delete-package p2)))))