test-package-local-nicknames.script 6.18 KB
Newer Older
1
2
3
4
;;; -*- mode:common-lisp; -*-

(in-package :asdf-test)

5
6
7
(unless (uiop:featurep :package-local-nicknames)
  (leave-test "This lisp implementation does not support package local nicknames" 0))

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
;;; these tests for DEFINE-PACKAGE support of package-local-nicknames were adapted from
;;; the trivial-package-local-nicknames system, to test UIOP's support for package local
;;; nicknames

(progn
  (defparameter +test-data+
    #+sbcl      '(:sb-ext    :sb :exit)
    #+ccl       '(:ccl       :cc :quit)
    #+ecl       '(:ext       :ex :exit)
    #+abcl      '(:ext       :ex :quit)
    #+clasp     '(:core      :ex :quit)
    #+lispworks '(:lispworks :ex :quit)
    #+allegro   '(:excl      :ex :exit))

  (defparameter +pkg-name+ (first +test-data+))
  (defparameter +nn-name+ (second +test-data+))
  (defparameter +sym-name+ (third +test-data+))

  (defparameter +pkg-sname+ (string +pkg-name+))
  (defparameter +nn-sname+ (string +nn-name+))
  (defparameter +sym-sname+ (string +sym-name+))
  (defparameter +sym-fullname+ (concatenate 'string +pkg-sname+ ":" +sym-sname+))
  (defparameter +sym-fullnickname+ (concatenate 'string +nn-sname+ ":" +sym-sname+))
31
  (defparameter +sym+ (or (uiop:find-symbol* +sym-sname+ +pkg-name+)
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
                          (error "Symbol not found while loading tests: check +SYM+ binding."))))

(defun reset-test-packages ()
  (#+sbcl sb-ext:without-package-locks
   #-sbcl progn
   (when (find-package :package-local-nicknames-test-1)
     (delete-package :package-local-nicknames-test-1))
   (when (find-package :package-local-nicknames-test-2)
     (delete-package :package-local-nicknames-test-2)))
  (let ((form1 `(uiop/package:define-package :package-local-nicknames-test-1 (:use)
                  (:local-nicknames (:l :cl) (,+nn-name+ ,+pkg-name+)))))
    (eval form1))
  (let ((form2 `(uiop/package:define-package :package-local-nicknames-test-2 (:use)
                     (:export "CONS"))))
    (eval form2)))

(defmacro define-test (name &rest body)
  `(progn
     (DBG ,(symbol-name name))
     ,@body))

53
54
55
56
57
58
(defun case-lisp-string (str)
  "Downcase string, if necessary for Allegro modern mode."
  (if (eq (readtable-case *readtable*) :preserve)
      (string-downcase str)
      str))

59
60
(define-test test-package-local-nicknames-introspection
  (reset-test-packages)
61
  (dolist (p '(:keyword :common-lisp :common-lisp-user
62
63
64
               :package-local-nicknames-test-1
               :package-local-nicknames-test-2))
    (let ((*package* (find-package p)))
65
      (let ((alist (uiop/package*:package-local-nicknames :package-local-nicknames-test-1)))
66
67
        (assert (equal (cons (case-lisp-string "L") (find-package :cl))
                       (assoc (case-lisp-string "L") alist :test 'string=)))
68
69
70
71
72
73
74
        (assert (equal (cons +nn-sname+ (find-package +pkg-sname+))
                       (assoc +nn-sname+ alist :test 'string=)))
        (assert (eql 2 (length alist)))))))

(define-test test-package-local-nicknames-symbol-equality
  (reset-test-packages)
  (let ((*package* (find-package :package-local-nicknames-test-1)))
75
76
77
    (let ((cons0 (read-from-string (case-lisp-string "L:CONS")))
          (cons1 (uiop:find-symbol* '#:cons :l))
          (cons1s (uiop:find-symbol* '#:cons (if (eq (readtable-case *readtable*) :preserve) #\l #\L)))
78
          (exit0 (read-from-string +sym-fullname+))
79
          (exit1 (uiop:find-symbol* +sym-sname+ +nn-name+)))
80
81
82
83
84
85
86
87
88
89
      (assert (eq 'cons cons0))
      (assert (eq 'cons cons1))
      (assert (eq 'cons cons1s))
      (assert (eq +sym+ exit0))
      (assert (eq +sym+ exit1)))))

(define-test test-package-local-nicknames-package-equality
  (reset-test-packages)
  (let ((*package* (find-package :package-local-nicknames-test-1)))
    (let ((cl (find-package :l))
90
          (cls (find-package (if (eq (readtable-case *readtable*) :preserve) #\l #\L)))
91
92
93
94
95
96
97
          (sb (find-package +nn-name+)))
      (assert (eq cl (find-package :common-lisp)))
      (assert (eq cls (find-package :common-lisp)))
      (assert (eq sb (find-package +pkg-name+))))))

(define-test test-package-local-nicknames-nickname-removal
  (reset-test-packages)
98
99
100
  (assert (= 2 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
  (assert (uiop/package*:remove-package-local-nickname :l :package-local-nicknames-test-1))
  (assert (= 1 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
101
102
103
104
105
106
  (let ((*package* (find-package :package-local-nicknames-test-1)))
    (assert (not (find-package :l)))))

(define-test test-package-local-nicknames-nickname-removal-char
  #+ignore (declare (optimize (debug 3) (speed 0)))
  (reset-test-packages)
107
108
  (assert (= 2 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
  (assert (uiop/package*:remove-package-local-nickname (if (eq (readtable-case *readtable*) :preserve) #\l #\L)
109
                                                      :package-local-nicknames-test-1))
110
  (assert (= 1 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
111
112
113
114
115
116
  (let ((*package* (find-package :package-local-nicknames-test-1)))
    (assert (not (find-package :l)))))


(define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality
  (reset-test-packages)
117
  (assert (uiop/package*:remove-package-local-nickname :l :package-local-nicknames-test-1))
118
  (assert (eq (find-package :package-local-nicknames-test-1)
119
              (uiop/package*:add-package-local-nickname :l :package-local-nicknames-test-2
120
121
122
123
124
125
                                          :package-local-nicknames-test-1)))
  (let ((*package* (find-package :package-local-nicknames-test-1)))
    (let ((cl (find-package :l))
          (sb (find-package +nn-name+)))
      (assert (eq cl (find-package :package-local-nicknames-test-2)))
      (assert (eq sb (find-package +pkg-name+))))))
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141


(define-test test-package-local-nicknames-nickname-removal-by-define-package
  (reset-test-packages)
  (uiop:define-package #:foo
    (:local-nicknames (#:u #:uiop)))
  (assert
   (eq (find-package :uiop)
       (let ((*package* (find-package '#:foo)))
         (find-package '#:u))))
  (uiop:define-package #:foo
    (:local-nicknames (#:u #:asdf)))
  (assert
   (eq (find-package :asdf)
       (let ((*package* (find-package '#:foo)))
         (find-package '#:u)))))