1 ;;;; miscellaneous tests of package-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "compiler-test-util.lisp")
21 (when (> (sb-kernel:symbol-package-id s
) 100) (incf n
)))
24 (defun set-bad-package (x)
25 (declare (optimize (safety 0)))
28 ;; When interpreting, the error occurs in SET-BAD-PACKAGE,
29 ;; not at the INTERN call.
30 (with-test (:name
:set-bad-package
:skipped-on
:interpreter
)
31 (set-bad-package :cl-user
)
32 (assert-error (intern "FRED") type-error
))
34 ;;; Expect an error about the nickname not being a string designator,
35 ;;; not about the nickname being taken by another package.
36 (with-test (:name
:nickname-is-string-designator
)
37 (let ((errmsg (handler-case (make-package "X" :nicknames
(list (find-package "CL")))
38 (error (c) (princ-to-string c
)))))
39 (assert (search "does not designate a string" errmsg
))))
41 (with-test (:name
:packages-sanely-nicknamed
)
42 (dolist (p (list-all-packages))
43 (let* ((nicks (package-nicknames p
))
44 (check (remove-duplicates nicks
:test
'string
=)))
45 (assert (= (length check
) (length nicks
))))))
48 (defvar *foo
* (find-package (coerce "FOO" 'base-string
)))
49 (rename-package "FOO" (make-array 0 :element-type
'character
))
50 (assert (eq *foo
* (find-package "")))
51 (assert (delete-package ""))
54 (defvar *baz
* (rename-package "BAR" "BAZ"))
55 (assert (eq *baz
* (find-package "BAZ")))
56 (assert (delete-package *baz
*))
60 (package-error (c) (princ c
))
61 (:no-error
(&rest args
) (error "(EXPORT :FOO) returned ~S" args
)))
64 (assert (shadow #\a :foo
))
66 (defpackage :PACKAGE-DESIGNATOR-1
(:use
#.
(find-package :cl
)))
68 (defpackage :PACKAGE-DESIGNATOR-2
69 (:import-from
#.
(find-package :cl
) "+"))
71 (defpackage "EXAMPLE-INDIRECT"
72 (:import-from
"CL" "+"))
74 (defpackage "EXAMPLE-PACKAGE"
76 (:shadowing-import-from
"CL" "CAAR")
78 (:import-from
"CL" "CDR")
79 (:import-from
"EXAMPLE-INDIRECT" "+")
80 (:export
"CAR" "CDR" "EXAMPLE"))
82 (flet ((check-symbol (name expected-status expected-home-name
)
83 (multiple-value-bind (symbol status
)
84 (find-symbol name
"EXAMPLE-PACKAGE")
85 (let ((home (symbol-package symbol
))
86 (expected-home (find-package expected-home-name
)))
87 (assert (eql home expected-home
))
88 (assert (eql status expected-status
))))))
89 (check-symbol "CAR" :external
"EXAMPLE-PACKAGE")
90 (check-symbol "CDR" :external
"CL")
91 (check-symbol "EXAMPLE" :external
"EXAMPLE-PACKAGE")
92 (check-symbol "CAAR" :internal
"CL")
93 (check-symbol "+" :internal
"CL")
94 (check-symbol "CDDR" nil
"CL"))
96 (defpackage "TEST-ORIGINAL" (:nicknames
"A-NICKNAME"))
98 (assert-error (defpackage "A-NICKNAME"))
100 (assert (eql (find-package "A-NICKNAME")
101 (find-package "TEST-ORIGINAL")))
104 (defun sym (package name
)
105 (let ((package (or (find-package package
) package
)))
106 (multiple-value-bind (symbol status
)
107 (find-symbol name package
)
109 (package name symbol status
)
110 "No symbol with name ~A in ~S." name package symbol status
)
111 (values symbol status
))))
113 (defmacro with-name-conflict-resolution
((symbol &key restarted
)
115 "Resolves potential name conflict condition arising from FORM.
117 The conflict is resolved in favour of SYMBOL, a form which must
118 evaluate to a symbol.
120 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
121 if a restart was invoked."
122 (check-type restarted symbol
"a binding name")
123 (let ((%symbol
(copy-symbol 'symbol
)))
124 `(let (,@(when restarted
`((,restarted
)))
127 ((sb-ext:name-conflict
129 ,@(when restarted
`((setf ,restarted t
)))
130 (assert (member ,%symbol
(sb-ext:name-conflict-symbols condition
)))
131 (invoke-restart 'sb-ext
:resolve-conflict
,%symbol
))))
135 (defmacro with-packages
(specs &body forms
)
136 (let ((names (mapcar #'car specs
)))
139 (delete-packages ',names
)
140 ,@(mapcar (lambda (spec)
141 `(defpackage ,@spec
))
144 (delete-packages ',names
))))
146 (defun delete-packages (names)
148 (ignore-errors (delete-package p
))))
153 (with-test (:name
:use-keyword-nope
)
154 (assert-error (use-package "KEYWORD"))
155 (assert-error (use-package "CL-USER" "KEYWORD")))
157 (with-test (:name
:use-package
.1)
158 (with-packages (("FOO" (:export
"SYM"))
159 ("BAR" (:export
"SYM"))
161 (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp
)
162 (use-package '("FOO" "BAR") "BAZ")
164 (is (eq (sym "BAR" "SYM")
165 (sym "BAZ" "SYM"))))))
167 (with-test (:name
:use-package
.2)
168 (with-packages (("FOO" (:export
"SYM"))
169 ("BAZ" (:use
) (:intern
"SYM")))
170 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
171 (use-package "FOO" "BAZ")
173 (is (eq (sym "FOO" "SYM")
174 (sym "BAZ" "SYM"))))))
176 (with-test (:name
:use-package
.2a
)
177 (with-packages (("FOO" (:export
"SYM"))
178 ("BAZ" (:use
) (:intern
"SYM")))
179 (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp
)
180 (use-package "FOO" "BAZ")
182 (is (equal (list (sym "BAZ" "SYM") :internal
)
183 (multiple-value-list (sym "BAZ" "SYM")))))))
185 (with-test (:name
:use-package-conflict-set
:fails-on
:sbcl
)
186 (with-packages (("FOO" (:export
"SYM"))
187 ("QUX" (:export
"SYM"))
188 ("BAR" (:intern
"SYM"))
189 ("BAZ" (:use
) (:import-from
"BAR" "SYM")))
190 (let ((conflict-set))
193 ((sb-ext:name-conflict
195 (setf conflict-set
(copy-list
196 (sb-ext:name-conflict-symbols condition
)))
198 (use-package '("FOO" "QUX") "BAZ")))
200 (sort conflict-set
#'string
<
201 :key
(lambda (symbol)
202 (package-name (symbol-package symbol
)))))
203 (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
207 (with-test (:name
:export
.1)
208 (with-packages (("FOO" (:intern
"SYM"))
209 ("BAR" (:export
"SYM"))
210 ("BAZ" (:use
"FOO" "BAR")))
211 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
212 (export (sym "FOO" "SYM") "FOO")
214 (is (eq (sym "FOO" "SYM")
215 (sym "BAZ" "SYM"))))))
217 (with-test (:name
:export
.1a
)
218 (with-packages (("FOO" (:intern
"SYM"))
219 ("BAR" (:export
"SYM"))
220 ("BAZ" (:use
"FOO" "BAR")))
221 (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp
)
222 (export (sym "FOO" "SYM") "FOO")
224 (is (eq (sym "BAR" "SYM")
225 (sym "BAZ" "SYM"))))))
227 (with-test (:name
:export.ensure-exported
)
228 (with-packages (("FOO" (:intern
"SYM"))
229 ("BAR" (:export
"SYM"))
230 ("BAZ" (:use
"FOO" "BAR") (:IMPORT-FROM
"BAR" "SYM")))
231 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
232 (export (sym "FOO" "SYM") "FOO")
234 (is (equal (list (sym "FOO" "SYM") :external
)
235 (multiple-value-list (sym "FOO" "SYM"))))
236 (is (eq (sym "FOO" "SYM")
237 (sym "BAZ" "SYM"))))))
239 (with-test (:name
:export
.3.intern
)
240 (with-packages (("FOO" (:intern
"SYM"))
241 ("BAZ" (:use
"FOO") (:intern
"SYM")))
242 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
243 (export (sym "FOO" "SYM") "FOO")
245 (is (eq (sym "FOO" "SYM")
246 (sym "BAZ" "SYM"))))))
248 (with-test (:name
:export
.3a.intern
)
249 (with-packages (("FOO" (:intern
"SYM"))
250 ("BAZ" (:use
"FOO") (:intern
"SYM")))
251 (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp
)
252 (export (sym "FOO" "SYM") "FOO")
254 (is (equal (list (sym "BAZ" "SYM") :internal
)
255 (multiple-value-list (sym "BAZ" "SYM")))))))
258 (with-test (:name
:import-nil
.1)
259 (with-packages (("FOO" (:use
) (:intern
"NIL"))
260 ("BAZ" (:use
) (:intern
"NIL")))
261 (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp
)
262 (import (list (sym "FOO" "NIL")) "BAZ")
264 (is (eq (sym "FOO" "NIL")
265 (sym "BAZ" "NIL"))))))
267 (with-test (:name
:import-nil
.2)
268 (with-packages (("BAZ" (:use
) (:intern
"NIL")))
269 (with-name-conflict-resolution ('CL
:NIL
:restarted restartedp
)
270 (import '(CL:NIL
) "BAZ")
273 (sym "BAZ" "NIL"))))))
275 (with-test (:name
:import-single-conflict
:fails-on
:sbcl
)
276 (with-packages (("FOO" (:export
"NIL"))
277 ("BAR" (:export
"NIL"))
279 (let ((conflict-sets '()))
281 ((sb-ext:name-conflict
283 (push (copy-list (sb-ext:name-conflict-symbols condition
))
285 (invoke-restart 'sb-ext
:resolve-conflict
'CL
:NIL
))))
286 (import (list 'CL
:NIL
(sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
287 (is (eql 1 (length conflict-sets
)))
288 (is (eql 3 (length (first conflict-sets
)))))))
290 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
291 ;;; multiple symbols of the same name in the package (this particular
292 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
293 (with-test (:name
:import-conflict-resolution
)
294 (with-packages (("FOO" (:export
"NIL"))
296 (with-name-conflict-resolution ((sym "FOO" "NIL"))
297 (import (list 'CL
:NIL
(sym "FOO" "NIL")) "BAR"))
298 (do-symbols (sym "BAR")
299 (assert (eq sym
(sym "FOO" "NIL"))))))
302 (with-test (:name
:unintern
.1)
303 (with-packages (("FOO" (:export
"SYM"))
304 ("BAR" (:export
"SYM"))
305 ("BAZ" (:use
"FOO" "BAR") (:shadow
"SYM")))
306 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
307 (unintern (sym "BAZ" "SYM") "BAZ")
309 (is (eq (sym "FOO" "SYM")
310 (sym "BAZ" "SYM"))))))
312 (with-test (:name
:unintern
.2)
313 (with-packages (("FOO" (:intern
"SYM")))
314 (unintern :sym
"FOO")
315 (assert (find-symbol "SYM" "FOO"))))
317 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
318 (with-test (:name
:with-package-iterator.error
)
322 (eval '(with-package-iterator (sym :cl-user
:foo
)
325 ((and simple-condition program-error
) (c)
326 (assert (equal (list :foo
) (simple-condition-format-arguments c
)))
329 ;; X3J13 writeup HASH-TABLE-PACKAGE-GENERATORS says
330 ;; "An argument of NIL is treated as an empty list of packages."
331 ;; This used to fail with "NIL does not name a package"
332 (with-test (:name
:with-package-iterator-nil-list
)
333 (with-package-iterator (iter '() :internal
)
334 (assert (null (iter)))))
336 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
337 (with-test (:name
:bug-511072
:skipped-on
(not :sb-thread
))
338 (let* ((p (make-package :bug-511072
))
339 (sem1 (sb-thread:make-semaphore
))
340 (sem2 (sb-thread:make-semaphore
))
341 (t2 (make-join-thread (lambda ()
342 (handler-bind ((error (lambda (c)
343 (sb-thread:signal-semaphore sem1
)
344 (sb-thread:wait-on-semaphore sem2
)
346 (make-package :bug-511072
))))))
347 (declare (ignore p t2
))
348 (sb-thread:wait-on-semaphore sem1
)
350 (assert (eq 'cons
(read-from-string "CL:CONS"))))
351 (sb-thread:signal-semaphore sem2
)))
353 (defmacro handling
((condition restart-name
) form
)
354 `(handler-bind ((,condition
(lambda (c)
356 (invoke-restart ',restart-name
))))
360 (with-test (:name
:quick-name-conflict-resolution-import
)
364 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
365 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
367 (handling (name-conflict sb-impl
::dont-import-it
)
368 (import (intern "FOO" p2
) p1
))
369 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
))))
370 (handling (name-conflict sb-impl
::shadowing-import-it
)
371 (import (intern "FOO" p2
) p1
))
372 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
))))
373 (when p1
(delete-package p1
))
374 (when p2
(delete-package p2
)))))
376 (with-test (:name
:quick-name-conflict-resolution-export
.1)
380 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
381 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
384 (handling (name-conflict sb-impl
::keep-old
)
385 (export (intern "FOO" p2
) p2
))
386 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
)))))
387 (when p1
(delete-package p1
))
388 (when p2
(delete-package p2
)))))
390 (with-test (:name
:quick-name-conflict-resolution-export
.2)
394 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
395 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
398 (handling (name-conflict sb-impl
::take-new
)
399 (export (intern "FOO" p2
) p2
))
400 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
))))
401 (when p1
(delete-package p1
))
402 (when p2
(delete-package p2
)))))
404 (with-test (:name
:quick-name-conflict-resolution-use-package
.1)
408 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
409 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
412 (export (intern "FOO" p2
) p2
)
413 (export (intern "BAR" p2
) p2
)
414 (handling (name-conflict sb-impl
::keep-old
)
416 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
))))
417 (assert (not (eq (intern "BAR" p1
) (intern "BAR" p2
)))))
418 (when p1
(delete-package p1
))
419 (when p2
(delete-package p2
)))))
421 (with-test (:name
:quick-name-conflict-resolution-use-package
.2)
425 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
426 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
429 (export (intern "FOO" p2
) p2
)
430 (export (intern "BAR" p2
) p2
)
431 (handling (name-conflict sb-impl
::take-new
)
433 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
)))
434 (assert (eq (intern "BAR" p1
) (intern "BAR" p2
))))
435 (when p1
(delete-package p1
))
436 (when p2
(delete-package p2
)))))
438 (with-test (:name
(:package-at-variance-restarts
:shadow
))
440 (*on-package-variance
* '(:error t
)))
443 (setf p
(eval `(defpackage :package-at-variance-restarts
.1
446 (handling (sb-kernel::package-at-variance-error sb-impl
::keep-them
)
447 (eval `(defpackage :package-at-variance-restarts
.1
449 (assert (not (eq 'cl
:cons
(intern "CONS" p
))))
450 (handling (sb-kernel::package-at-variance-error sb-impl
::drop-them
)
451 (eval `(defpackage :package-at-variance-restarts
.1
453 (assert (eq 'cl
:cons
(intern "CONS" p
))))
454 (when p
(delete-package p
)))))
456 (with-test (:name
(:package-at-variance-restarts
:use
))
458 (*on-package-variance
* '(:error t
)))
461 (setf p
(eval `(defpackage :package-at-variance-restarts
.2
463 (handling (sb-kernel::package-at-variance-error sb-impl
::keep-them
)
464 (eval `(defpackage :package-at-variance-restarts
.2
466 (assert (eq 'cl
:cons
(intern "CONS" p
)))
467 (handling (sb-kernel::package-at-variance-error sb-impl
::drop-them
)
468 (eval `(defpackage :package-at-variance-restarts
.2
470 (assert (not (eq 'cl
:cons
(intern "CONS" p
)))))
471 (when p
(delete-package p
)))))
473 (with-test (:name
(:package-at-variance-restarts
:export
))
475 (*on-package-variance
* '(:error t
)))
478 (setf p
(eval `(defpackage :package-at-variance-restarts
.4
480 (handling (sb-kernel::package-at-variance-error sb-impl
::keep-them
)
481 (eval `(defpackage :package-at-variance-restarts
.4)))
482 (assert (eq :external
(nth-value 1 (find-symbol "FOO" p
))))
483 (handling (sb-kernel::package-at-variance-error sb-impl
::drop-them
)
484 (eval `(defpackage :package-at-variance-restarts
.4)))
485 (assert (eq :internal
(nth-value 1 (find-symbol "FOO" p
)))))
486 (when p
(delete-package p
)))))
488 (with-test (:name
(:package-at-variance-restarts
:implement
))
490 (*on-package-variance
* '(:error t
)))
493 (setf p
(eval `(defpackage :package-at-variance-restarts
.5
494 (:implement
:sb-int
))))
495 (handling (sb-kernel::package-at-variance-error sb-impl
::keep-them
)
496 (eval `(defpackage :package-at-variance-restarts
.5)))
497 (assert (member p
(package-implemented-by-list :sb-int
)))
498 (handling (sb-kernel::package-at-variance-error sb-impl
::drop-them
)
499 (eval `(defpackage :package-at-variance-restarts
.5)))
500 (assert (not (member p
(package-implemented-by-list :sb-int
)))))
501 (when p
(delete-package p
)))))
503 (with-test (:name
(:delete-package
:implementation-package
))
507 (setf p1
(make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
508 p2
(make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
509 (add-implementation-package p2 p1
)
510 (assert (= 1 (length (package-implemented-by-list p1
))))
512 (assert (= 0 (length (package-implemented-by-list p1
)))))
513 (when p1
(delete-package p1
))
514 (when p2
(delete-package p2
)))))
516 (with-test (:name
(:delete-package
:implementated-package
))
520 (setf p1
(make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
521 p2
(make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
522 (add-implementation-package p2 p1
)
523 (assert (= 1 (length (package-implements-list p2
))))
525 (assert (= 0 (length (package-implements-list p2
)))))
526 (when p1
(delete-package p1
))
527 (when p2
(delete-package p2
)))))
529 (with-test (:name
:package-local-nicknames
)
531 (without-package-locks
532 (when (find-package :package-local-nicknames-test-1
)
533 (delete-package :package-local-nicknames-test-1
))
534 (when (find-package :package-local-nicknames-test-2
)
535 (delete-package :package-local-nicknames-test-2
)))
536 (eval `(defpackage :package-local-nicknames-test-1
537 (:local-nicknames
(:l
:cl
) (:sb
:sb-ext
))))
538 (eval `(defpackage :package-local-nicknames-test-2
541 (let ((alist (package-local-nicknames :package-local-nicknames-test-1
)))
542 (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist
:test
'string
=)))
543 (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist
:test
'string
=)))
544 (assert (eql 2 (length alist
))))
546 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
547 (let ((cons0 (read-from-string "L:CONS"))
548 (exit0 (read-from-string "SB:EXIT"))
549 (cons1 (find-symbol "CONS" :l
))
550 (exit1 (find-symbol "EXIT" :sb
))
551 (cl (find-package :l
))
552 (sb (find-package :sb
)))
553 (assert (eq 'cons cons0
))
554 (assert (eq 'cons cons1
))
555 (assert (equal "L:CONS" (prin1-to-string cons0
)))
556 (assert (eq 'sb-ext
:exit exit0
))
557 (assert (eq 'sb-ext
:exit exit1
))
558 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
559 (assert (eq cl
(find-package :common-lisp
)))
560 (assert (eq sb
(find-package :sb-ext
)))))
561 ;; Can't add same name twice for different global names.
564 (add-package-local-nickname :l
:package-local-nicknames-test-2
565 :package-local-nicknames-test-1
)
568 ;; But same name twice is OK.
569 (add-package-local-nickname :l
:cl
:package-local-nicknames-test-1
)
571 (assert (remove-package-local-nickname :l
:package-local-nicknames-test-1
))
572 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
573 (let ((exit0 (read-from-string "SB:EXIT"))
574 (exit1 (find-symbol "EXIT" :sb
))
575 (sb (find-package :sb
)))
576 (assert (eq 'sb-ext
:exit exit0
))
577 (assert (eq 'sb-ext
:exit exit1
))
578 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
579 (assert (eq sb
(find-package :sb-ext
)))
580 (assert (not (find-package :l
)))))
581 ;; Adding back as another package.
582 (assert (eq (find-package :package-local-nicknames-test-1
)
583 (add-package-local-nickname :l
:package-local-nicknames-test-2
584 :package-local-nicknames-test-1
)))
585 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
586 (let ((cons0 (read-from-string "L:CONS"))
587 (exit0 (read-from-string "SB:EXIT"))
588 (cons1 (find-symbol "CONS" :l
))
589 (exit1 (find-symbol "EXIT" :sb
))
590 (cl (find-package :l
))
591 (sb (find-package :sb
)))
592 (assert (eq cons0 cons1
))
593 (assert (not (eq 'cons cons0
)))
594 (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2
)
596 (assert (equal "L:CONS" (prin1-to-string cons0
)))
597 (assert (eq 'sb-ext
:exit exit0
))
598 (assert (eq 'sb-ext
:exit exit1
))
599 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
600 (assert (eq cl
(find-package :package-local-nicknames-test-2
)))
601 (assert (eq sb
(find-package :sb-ext
)))))
602 ;; Interaction with package locks.
603 (lock-package :package-local-nicknames-test-1
)
604 (assert (eq :package-oopsie
606 (add-package-local-nickname :c
:sb-c
:package-local-nicknames-test-1
)
607 (package-lock-violation ()
609 (assert (eq :package-oopsie
611 (remove-package-local-nickname :l
:package-local-nicknames-test-1
)
612 (package-lock-violation ()
614 (unlock-package :package-local-nicknames-test-1
)
615 (add-package-local-nickname :c
:sb-c
:package-local-nicknames-test-1
)
616 (remove-package-local-nickname :l
:package-local-nicknames-test-1
))
618 (defmacro with-tmp-packages
(bindings &body body
)
619 `(let ,(mapcar #'car bindings
)
622 (setf ,@(apply #'append bindings
))
624 ,@(mapcar (lambda (p)
625 `(when ,p
(delete-package ,p
)))
626 (mapcar #'car bindings
)))))
628 (with-test (:name
(:delete-package
:locally-nicknames-others
))
629 (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
630 (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
631 (add-package-local-nickname :foo p2 p1
)
632 (assert (equal (list p1
) (package-locally-nicknamed-by-list p2
)))
634 (assert (not (package-locally-nicknamed-by-list p2
)))))
636 (with-test (:name
(:delete-package
:locally-nicknamed-by-others
))
637 (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
638 (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
639 (add-package-local-nickname :foo p2 p1
)
640 (assert (package-local-nicknames p1
))
642 (assert (not (package-local-nicknames p1
)))))
644 (with-test (:name
:own-name-as-local-nickname
)
645 (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
646 (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
649 (add-package-local-nickname :own-name-as-nickname1 p2 p1
)
652 (handler-bind ((error #'continue
))
653 (add-package-local-nickname :own-name-as-nickname1 p2 p1
))
654 (assert (eq (intern "FOO" p2
)
655 (let ((*package
* p1
))
656 (intern "FOO" :own-name-as-nickname1
))))))
658 (with-test (:name
:own-nickname-as-local-nickname
)
659 (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
660 :nicknames
'("OWN-NICKNAME")))
661 (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
664 (add-package-local-nickname :own-nickname p2 p1
)
667 (handler-bind ((error #'continue
))
668 (add-package-local-nickname :own-nickname p2 p1
))
669 (assert (eq (intern "FOO" p2
)
670 (let ((*package
* p1
))
671 (intern "FOO" :own-nickname
))))))
673 (defun random-package-name (min max
)
674 (let* ((s (make-string (+ min
(random (- max min
))))))
675 (dotimes (i (length s
) s
)
676 (setf (char s i
) (code-char (+ (char-code #\A
) (random 26)))))))
678 ;;; Hammer on the somewhat intricate structure that maintains the bidirection mapping
679 ;;; between PLNs and packages, and PLN ID to package.
680 (with-test (:name
:pln-data-structure-bashing
)
681 (with-tmp-packages ((referencing-pkg (make-package "FOO")))
684 (let ((package (make-package (random-package-name 10 12)))
685 (local-nick (random-package-name 3 6)))
686 (push (cons local-nick package
) plns
)
687 (add-package-local-nickname local-nick package referencing-pkg
)))
689 ;; Test all 3 directions of the mapping
691 ;; local nickname to package
692 (assert (eq (sb-impl::pkgnick-search-by-name
(car entry
) referencing-pkg
)
694 ;; numeric id to package
695 (let ((id (sb-int:info-gethash
(car entry
) (car sb-impl
::*package-nickname-ids
*))))
696 (assert (eq (sb-impl::pkgnick-search-by-id id referencing-pkg
)
698 ;; package to local nickname
699 (assert (string= (sb-impl::package-local-nickname
(cdr entry
)
702 ;; Delete a random package that has a local nickname
703 (let ((entry (nth (random (length plns
)) plns
)))
704 (delete-package (cdr entry
))
705 ;; Deletion removes from local nicknames on attempted lookup
706 (assert (not (sb-impl::find-package-using-package
(car entry
) referencing-pkg
)))
707 (setq plns
(delete entry plns
))
708 (assert (= (length (car (sb-impl::package-%local-nicknames referencing-pkg
)))
709 (* 2 (length plns
)))))
710 (when plns
(go iterate
)))))
712 (defun intern-in-fixed-pkg-designator (x) (intern x
"PWELN"))
713 (compile 'intern-in-fixed-pkg-designator
)
715 (with-test (:name
:cached-find-package
)
717 ((p1 (make-package "PKG-WITH-EXCEEDINGLY-LONG-NAME"))
718 (p2 (make-package "PKG-WHICH-EVERYONE-LOVES-NOW" :nicknames
'("PWELN")))
719 (p3 (defpackage "USERPKG"
720 (:local-nicknames
("PWELN" "PKG-WITH-EXCEEDINGLY-LONG-NAME")
721 ("FOOCL" "COMMON-LISP")))))
722 (let ((s (intern-in-fixed-pkg-designator "A")))
723 (assert (eq (symbol-package s
) p2
))) ; global PWELN package
724 (let ((s (let ((*package
* p3
))
725 (intern-in-fixed-pkg-designator "A"))))
726 (assert (eq (symbol-package s
) p1
))) ; local PWELN package
727 (delete-package p1
) ; will lazily delete "inbound" nicknames
728 (let ((s (let ((*package
* p3
))
729 (intern-in-fixed-pkg-designator "A"))))
730 (assert (eq (symbol-package s
) p2
))))) ; global PWELN package
732 (with-test (:name
:delete-package-restart
)
736 ((sb-kernel:simple-package-error
740 (delete-package (gensym)))))
742 (assert (not result
))))
744 ;; WITH-PACKAGE-ITERATOR isn't well-exercised by tests (though LOOP uses it)
745 ;; so here's a basic correctness test with some complications involving
746 ;; shadowing symbols.
747 (make-package "FOOFORMAT" :use
'("CL"))
748 (export 'fooformat
::format-error
'fooformat
)
749 (export 'fooformat
::%compiler-walk-format-string
'fooformat
)
750 (make-package "P1" :use
'("FOOFORMAT"))
752 (export 'p1
::foo
'p1
)
753 (shadow "FORMAT-ERROR" 'p1
)
754 (make-package "A" :use
'("FOOFORMAT" "P1" "P2"))
755 (shadow '("PROG2" "FOO") 'a
)
757 (export 'p2
::(foo bar baz
) 'p2
)
758 (export 'a
::goodfun
'a
)
760 (with-test (:name
:with-package-iterator
)
761 (let ((tests '((:internal
) (:external
) (:inherited
)
762 (:internal
:inherited
)
763 (:internal
:external
)
764 (:external
:inherited
)
765 (:internal
:external
:inherited
)))
767 '(;; symbols visible in A
768 (a::prog2
:internal
"A")
769 (a::foo
:internal
"A")
770 (a:goodfun
:external
"A")
771 (p2:bar
:inherited
"A")
772 (p2:baz
:inherited
"A")
773 (fooformat:%compiler-walk-format-string
:inherited
"A")
774 (fooformat:format-error
:inherited
"A")
776 (p1:foo
:external
"P1")
777 (p1::format-error
:internal
"P1")
778 (fooformat:%compiler-walk-format-string
:inherited
"P1")
780 (p2::blah
:internal
"P2")
781 (p2:foo
:external
"P2")
782 (p2:bar
:external
"P2")
783 (p2:baz
:external
"P2"))))
784 ;; Compile a new function to test each combination of
785 ;; accessibility-kind since the macro doesn't eval them.
786 (dolist (access tests
)
787 ; (print `(testing ,access))
791 (with-package-iterator (iter '(p1 a p2
) ,@access
)
794 (multiple-value-bind (foundp sym access pkg
) (iter)
796 (push (list sym access
(package-name pkg
)) res
)
799 (let ((answer (funcall f
))
800 (expect (remove-if-not (lambda (x) (member (second x
) access
))
802 ;; exactly as many results as expected
803 (assert (equal (length answer
) (length expect
)))
804 ;; each result is right
805 (assert (equal (length (intersection answer expect
:test
#'equal
))
806 (length expect
))))))))
808 ;; Assert that changes in size of a symbo-hashset's symbol vector
809 ;; do not cause WITH-PACKAGE-ITERATOR to crash. The vector shouldn't grow,
810 ;; because it is not permitted to INTERN new symbols, but it can shrink
811 ;; because it is expressly permitted to UNINTERN the current symbol.
812 ;; (In fact we allow INTERN, but that's beside the point)
813 (with-test (:name
:with-package-iterator-and-mutation
)
814 (flet ((table-size (pkg)
815 (length (sb-impl::symtbl-cells
816 (sb-impl::package-internal-symbols pkg
)))))
817 (let* ((p (make-package (string (gensym))))
818 (initial-table-size (table-size p
))
820 '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m")))
823 (let ((grown-table-size (table-size p
)))
824 (assert (> grown-table-size initial-table-size
))
826 (with-package-iterator (iter p
:internal
)
827 (loop (multiple-value-bind (foundp sym
) (iter)
833 (assert (= n
(length strings
)))
834 ;; while we're at it, assert that calling the iterator
835 ;; a couple more times returns nothing.
837 (assert (not (iter))))))
838 (let ((shrunk-table-size (table-size p
)))
839 (assert (< shrunk-table-size grown-table-size
)))))))
841 (with-test (:name
:symbol-externalp
)
842 (with-package-iterator (iter (list-all-packages) :internal
:external
)
844 (multiple-value-bind (foundp sym access pkg
) (iter)
845 (unless foundp
(return))
846 (when (eq access
:external
)
847 (assert (sb-impl::symbol-externalp sym pkg
)))))))
850 (with-test (:name
:do-symbols-block-scope
)
853 (do-symbols (s (or (find-package "FROB") (return nil
)))
857 (with-test (:name
:export-inaccessible-lookalike
)
860 (export (intern "A" "E2") 'e2
)
861 (multiple-value-bind (answer condition
)
862 (ignore-errors (export (intern "A" "E1") 'e2
))
863 (assert (and (not answer
)
864 (and (typep condition
'sb-kernel
:simple-package-error
)
865 (search "not accessible"
866 (simple-condition-format-control condition
)))))))
868 ;; Concurrent FIND-SYMBOL was adversely affected by package rehash.
869 ;; It's slightly difficult to show that this is fixed, because this
870 ;; test only sometimes failed prior to the fix. Now it never fails though.
871 (with-test (:name
:concurrent-find-symbol
:skipped-on
(not :sb-thread
))
872 (let ((pkg (make-package (gensym)))
877 (let ((s (string (gensym "FRED"))))
881 (push (sb-thread:make-thread
885 (dotimes (i 10 n-missing
)
887 (unless (find-symbol name pkg
)
888 (incf n-missing
)))))))
891 ;; Interning new symbols can't cause the pre-determined
892 ;; 50 names to transiently disappear.
893 (let ((s (make-string 3))
894 (alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345"))
895 (dotimes (i (expt 32 3))
896 (setf (char s
0) (char alphabet
(ldb (byte 5 10) i
))
897 (char s
1) (char alphabet
(ldb (byte 5 5) i
))
898 (char s
2) (char alphabet
(ldb (byte 5 0) i
)))
900 (let ((tot-missing 0))
901 (dolist (thread threads
(assert (zerop tot-missing
)))
902 (incf tot-missing
(sb-thread:join-thread thread
))))))
904 (with-test (:name
:defpackage-multiple-nicknames
)
905 (let* ((name1 (string (gensym)))
906 (name2 (string (gensym)))
907 (names (package-nicknames
908 (eval `(defpackage ,(gensym)
910 (:nicknames
,name2
))))))
916 (list name2 name1
))))))
918 (with-test (:name
(defpackage :local-nicknames
:lock
))
919 (destructuring-bind (name1 name2 name3
)
920 (loop :repeat
3 :collect
(string (gensym)))
921 (let ((package1 (eval `(defpackage ,name1
)))
922 (package2 (eval `(defpackage ,name2
923 (:local-nicknames
(,name3
,name1
))
925 (assert (equal (package-local-nicknames package2
) `((,name3 .
,package1
))))
926 (assert (package-locked-p package2
)))))
928 (with-test (:name
:locally-nicknamed-by-dedup
)
930 ((p1 (make-package "LONGNAME.SAMPLE.FRED"))
931 (p2 (defpackage "BAZ"
932 (:local-nicknames
(:fred
"LONGNAME.SAMPLE.FRED")
933 (:f
"LONGNAME.SAMPLE.FRED")))))
934 (assert (equal (package-locally-nicknamed-by-list "LONGNAME.SAMPLE.FRED")
935 (list (find-package "BAZ"))))))
937 ;;; Now a possibly useless test on an essentially useless function.
938 ;;; But we may as well get it right - assert that GENTEMP returns
939 ;;; a symbol that definitely did not exist in the specified package
940 ;;; even if multiple threads are calling it simultaneously.
942 ;;; We'll create about 25000 symbols, and mark the ones that were returned
943 ;;; by GENTEMP. Because *GENTEMP-COUNTER* isn't synchronized, but INTERN is,
944 ;;; returning an indicator of whether it created a symbol, it's simple enough
945 ;;; to make GENTEMP not accidentally return a symbol created by someone else.
947 ;;; Use array of fixnums because there're no atomic ops on array of word.
948 ;;; This is either 58000 useful bits or 126000 bits depending on word size.
949 (defglobal *scoreboard
* (make-array 2000 :initial-element
0))
950 (defglobal *testpkg
* (make-package "A-NICE-PACKAGE"))
952 (defun hammer-on-gentemp (package n-iter
)
954 (let ((index (parse-integer (string (gentemp "T" package
)) :start
1)))
955 ;; Mark this index in the scoreboard, failing if already set.
956 (multiple-value-bind (elt-index bit-index
)
957 (floor index sb-vm
:n-positive-fixnum-bits
)
958 (let ((old (svref *scoreboard
* elt-index
)))
960 (when (logbitp bit-index old
) (return-from hammer-on-gentemp
:fail
))
962 (cas (svref *scoreboard
* elt-index
)
963 old
(logior old
(ash 1 bit-index
)))))
964 (if (eq old actual-old
) (return))
965 (setq old actual-old
))))))))
967 ;; This test would consistently fail when GENTEMP first called FIND-SYMBOL
968 ;; and then INTERN when FIND-SYMBOL said that it found no symbol.
969 (with-test (:name
(gentemp :threadsafety
) :skipped-on
(not :sb-thread
))
973 (dotimes (i n-threads
)
974 (push (sb-thread:make-thread
#'hammer-on-gentemp
975 :arguments
(list *testpkg
* n-iter
))
977 (let ((results (mapcar #'sb-thread
:join-thread threads
)))
978 (assert (not (find :fail results
))))))
980 ;;; This test is a bit weak in that prior to the fix for what it tests,
981 ;;; it didn't fail often enough to convincingly show that there was a problem.
982 ;;; Nonetheless it did sometimes fail, and now should never fail.
983 (with-test (:name
:concurrent-intern-bad-published-symbol-package
984 ;; No point in wasting time on concurrency bugs otherwise
985 :skipped-on
(not :sb-thread
))
986 ;; Confirm that the compiler does not know that KEYWORDICATE
987 ;; returns a KEYWORD (so the answer isn't constant-folded)
988 (assert (sb-kernel:type
= (sb-int:info
:function
:type
'sb-int
:keywordicate
)
989 (sb-kernel:find-classoid
'function
)))
990 (let ((sema (sb-thread:make-semaphore
))
992 (dotimes (i 10) ; number of trials
994 (dotimes (i n-threads
)
995 (push (make-join-thread
997 (sb-thread:wait-on-semaphore sema
)
998 (keywordp (sb-int:keywordicate
"BLUB"))))
1000 (sb-thread:signal-semaphore sema n-threads
)
1002 (dolist (thread threads
)
1003 (when (sb-thread:join-thread thread
) (incf count
)))
1004 (unintern (sb-int:keywordicate
"BLUB") "KEYWORD")
1005 (assert (= count n-threads
)))))))
1007 (with-test (:name
:name-conflict-non-pretty-message
)
1008 (make-package "SILLYPACKAGE1")
1009 (export (intern "ASILLYSYM" 'sillypackage1
) 'sillypackage1
)
1010 (make-package "SILLYPACKAGE2")
1011 (export (intern "ASILLYSYM" 'sillypackage2
) 'sillypackage2
)
1012 (use-package 'sillypackage1
)
1013 (handler-case (use-package 'sillypackage2
)
1014 (name-conflict (c) ; No silly string in the result
1015 (assert (not (search "symbols:SILLY"
1016 (write-to-string c
:pretty nil
:escape nil
)))))
1017 (condition () (error "Should not get here"))
1018 (:no-error
(c) (declare (ignore c
)) (error "Should not get here"))))
1020 ;; git revision f7d1550c0e16262f28213c9e3c048f42e3f0b476 broke find-all-symbols
1021 (with-test (:name
:find-all-symbols
)
1022 (find-all-symbols "FIXNUM"))
1024 (defun foo-intern (x) (intern x
"PKG-A"))
1025 (compile 'foo-intern
)
1026 ;;; Basic smoke test of compiler transform of INTERN
1027 (with-test (:name
:cached-find-package
)
1028 (assert-error (foo-intern "X"))
1029 (make-package "PKG-A")
1030 (locally (declare (notinline intern find-symbol
))
1031 (assert (eq (foo-intern "X") (find-symbol "X" "PKG-A")))
1032 (delete-package "PKG-A")
1033 (make-package "PKG-B" :nicknames
'("PKG-A"))
1034 (assert (eq (foo-intern "X") (find-symbol "X" "PKG-B")))))
1036 ;;; The concept behind the intricate storage representation of local nicknames
1037 ;;; was that adding a nickname does not create a strong reference to the
1038 ;;; nicknamed package, but nonetheless avoids having to do a FIND-PACKAGE
1039 ;;; on its actual name. This is efficient, but it is complicated because
1040 ;;; it involves weak objects. Here is a test which asserts that.
1041 ;;; [It probably would have been fine to penalize DELETE-PACKAGE by forcing
1042 ;;; it to scan all other packages for local nicknames of the deleted one,
1043 ;;; but I guess I didn't want to do that. But I wonder if it might be possible
1044 ;;; to reduce the complexity now that we have package IDs.]
1045 (defvar *the-weak-ptr
*) ; to determine that the test worked
1046 (defun prepare-nickname-weakness-test ()
1047 (setq *the-weak-ptr
* (make-weak-pointer (make-package "SOMEPACKAGE")))
1048 (make-package "MYPKG" :use
'("CL"))
1049 (add-package-local-nickname "SP" "SOMEPACKAGE" "MYPKG")
1050 (intern "ZOOK" "SOMEPACKAGE")
1051 (let ((*package
* (find-package "MYPKG")))
1052 (assert (eq (find-symbol "ZOOK" "SP")
1053 (find-symbol "ZOOK" "SOMEPACKAGE")))))
1055 (with-test (:name
:local-nicknames-like-weak-pointers
)
1056 (prepare-nickname-weakness-test)
1057 ;; Check that SP is a local nickname
1058 (assert (let ((*package
* (find-package "MYPKG"))) (find-symbol "ZOOK" "SP")))
1059 ;;; But not a global name of any package
1060 (assert-error (find-symbol "ZOOK" "SP"))
1061 (delete-package "SOMEPACKAGE")
1062 ;; Assert that the local nickname vector has not yet removed the
1063 ;; deleted package. DELETE-PACKAGE does not scan all packages to adjust
1064 ;; their local nicknames. (There's no "locally nicknamed by" accessor so it
1065 ;; definitely would need to visit all packages which I didn't like.
1066 ;; It wouldn't be the worst thing, but I opted not to store a reverse lookup)
1067 ;; Rather interestingly, this operation overwrites a words of the control stack
1068 ;; that might otherwise randomly contain the very package that got deleted.
1069 (assert (= (sb-int:weak-vector-len
1070 (cdr (sb-impl::package-%local-nicknames
(find-package "MYPKG"))))
1072 (sb-sys:scrub-control-stack
)
1074 ;; Asserting that the weak pointer gets splatted _before_ doing the next FIND-SYMBOL
1075 ;; confirms that the nickname representation did not store a strong reference
1076 ;; to #<SOMEPACKAGE>. Package-local nicknames are necessarily purged of any deleted
1077 ;; packages just-in-time, so the assertion would not demonstrate anything if run
1078 ;; _after_ calling FIND-SYMBOL. I don't know why this fails on #+win32, SEARCH-ROOTS
1079 ;; did not return a path, so there must also be a deficiency in that.
1080 #-win32
(assert (not (weak-pointer-value *the-weak-ptr
*)))
1081 (assert-error (let ((*package
* (find-package "MYPKG")))
1082 ;; the nickname magically went away!
1083 (find-symbol "ZOOK" "SP"))))
1085 ;;; This is probably, strictly speaking, non-conforming code according
1086 ;;; to ANSI 3.2.4.4 under item 1 for symbol, taking package "same"ness
1088 (with-test (:name
:defpackage-rename-package-redefpackage
)
1090 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
1091 (when (find-package "DEFPACKAGE4")
1092 (rename-package "DEFPACKAGE4" "DEFPACKAGE4")))
1093 (defpackage "DEFPACKAGE4"
1095 (in-package "DEFPACKAGE4")
1096 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1099 (assert (eq (nth-value 1 (find-symbol "F" "DEFPACKAGE4"))
1102 (with-test (:name
:defpackage-rename-package
)
1103 (delete-package "BAR")
1105 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
1107 ((find-package "FOO")
1108 (rename-package "FOO"
1110 ((not (find-package "BAR"))
1111 (make-package "BAR" :use
'("CL")))))
1115 (defun stable-union (bar) bar
))
1116 :before-load
(lambda ()
1117 (delete-package "BAR")
1118 (defpackage foo
(:use
:cl
)))
1120 (assert (find-symbol "STABLE-UNION" "BAR"))
1121 (delete-package "BAR"))
1123 (with-test (:name
:defpackage-rename-package-symbol-conflict
)
1124 (with-scratch-file (fasl2 "fasl")
1125 (compile-file "package-test-2.lisp" :output-file fasl2
)
1126 (delete-package "BAR")
1127 (with-scratch-file (fasl1 "fasl")
1128 (compile-file "package-test-1.lisp" :output-file fasl1
)
1130 (assert (eq (symbol-package (find-symbol "BAZ" "BAR"))
1131 (find-package "BAR")))
1132 (assert (eq (funcall (find-symbol "BAZ" "BAR"))
1134 (delete-package "BAR"))
1136 (with-test (:name
:defpackage-rename-package-preserve-externals
)
1137 (with-scratch-file (fasl4 "fasl")
1138 (compile-file "package-test-4.lisp" :output-file fasl4
)
1139 (delete-package "FOO-NEW")
1140 (with-scratch-file (fasl3 "fasl")
1141 (compile-file "package-test-3.lisp" :output-file fasl3
)
1143 (assert (eq (nth-value 1 (find-symbol "BAR" "FOO-NEW"))
1145 (delete-package "FOO-NEW"))
1147 (with-test (:name
:defpackage-delete-package-redefpackage-fasloader
)
1148 (with-scratch-file (fasl5 "fasl")
1149 (compile-file "package-test-5.lisp" :output-file fasl5
)
1151 (if (find-package "BAR-DRRFL") (delete-package "BAR-DRRFL"))
1152 (with-scratch-file (fasl6 "fasl")
1153 (compile-file "package-test-6.lisp" :output-file fasl6
)
1156 (delete-package "BAR-DRRFL")))
1158 ;;; We were not creating fasls correctly when a file defining a
1159 ;;; package was compiled twice, since we were relying on the compile
1160 ;;; time effect of that happening to change the behavior of what code
1161 ;;; to put in the same component.
1162 (with-test (:name
:make-package-compile-twice
)
1163 (with-scratch-file (fasl7 "fasl")
1164 (compile-file "package-test-7.lisp" :output-file fasl7
)
1165 (compile-file "package-test-7.lisp" :output-file fasl7
)
1166 (delete-package "COMPILE-TWICE")
1168 (delete-package "COMPILE-TWICE")))