tests/packages.impure.lisp

   1 ;;;; miscellaneous tests of package-related stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (make-package "FOO")
  15 (defvar *foo* (find-package (coerce "FOO" 'base-string)))
  16 (rename-package "FOO" (make-array 0 :element-type nil))
  17 (assert (eq *foo* (find-package "")))
  18 (assert (delete-package ""))
  19
  20 (handler-case
  21     (export :foo)
  22   (package-error (c) (princ c))
  23   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
  24
  25 (make-package "FOO")
  26 (assert (shadow #\a :foo))
  27
  28 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
  29
  30 (defpackage :PACKAGE-DESIGNATOR-2
  31   (:import-from #.(find-package :cl) "+"))
  32
  33 (defpackage "EXAMPLE-INDIRECT"
  34   (:import-from "CL" "+"))
  35
  36 (defpackage "EXAMPLE-PACKAGE"
  37   (:shadow "CAR")
  38   (:shadowing-import-from "CL" "CAAR")
  39   (:use)
  40   (:import-from "CL" "CDR")
  41   (:import-from "EXAMPLE-INDIRECT" "+")
  42   (:export "CAR" "CDR" "EXAMPLE"))
  43
  44 (flet ((check-symbol (name expected-status expected-home-name)
  45          (multiple-value-bind (symbol status)
  46              (find-symbol name "EXAMPLE-PACKAGE")
  47            (let ((home (symbol-package symbol))
  48                  (expected-home (find-package expected-home-name)))
  49              (assert (eql home expected-home))
  50              (assert (eql status expected-status))))))
  51   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  52   (check-symbol "CDR" :external "CL")
  53   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  54   (check-symbol "CAAR" :internal "CL")
  55   (check-symbol "+" :internal "CL")
  56   (check-symbol "CDDR" nil "CL"))
  57
  58 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
  59
  60 (assert (raises-error? (defpackage "A-NICKNAME")))
  61
  62 (assert (eql (find-package "A-NICKNAME")
  63              (find-package "TEST-ORIGINAL")))
  64