1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; The software is in the public domain and is provided with
5 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
8 (defpackage :sb-cltl2-tests
9 (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
11 (in-package :sb-cltl2-tests)
15 (defmacro *x*-value ()
16 (declare (special *x*))
19 (deftest compiler-let.1
21 (compiler-let ((*x* :inner))
22 (list *x* (*x*-value))))
25 (defvar *expansions* nil)
26 (defmacro macroexpand-macro (arg)
27 (push arg *expansions*)
30 (deftest macroexpand-all.1
32 (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
36 (deftest macroexpand-all.2
37 (let ((*expansions* nil))
38 (macroexpand-all '(list (macroexpand-macro 1)
39 (let (macroexpand-macro :no)
40 (macroexpand-macro 2))))
41 (remove-duplicates (sort *expansions* #'<)))
44 (deftest macroexpand-all.3
45 (let ((*expansions* nil))
46 (compile nil '(lambda ()
47 (macrolet ((foo (key &environment env)
48 (macroexpand-all `(bar ,key) env)))
51 (push key *expansions*)
54 (remove-duplicates *expansions*))
58 (multiple-value-bind (expansion macro-p)
59 (macroexpand 'srlt env)
60 (when macro-p (eval expansion))))
61 (defmacro testr (&environment env)
62 `',(getf (smv env) nil))
64 (deftest macroexpand-all.4
65 (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
66 (symbol-macrolet ((srlt '(nil zool))) 'zool))
68 (defmacro dinfo (thing &environment env)
69 `',(declaration-information thing env))
72 `(macrolet ((frob (suffix answer &optional declaration)
73 `(deftest ,(intern (concatenate 'string
74 "DECLARATION-INFORMATION."
77 (locally (declare ,@(when declaration
79 (cadr (assoc ',',x (dinfo optimize))))
82 (frob ".0" 0 (optimize (,x 0)))
83 (frob ".1" 1 (optimize (,x 1)))
84 (frob ".2" 2 (optimize (,x 2)))
85 (frob ".3" 3 (optimize (,x 3)))
86 (frob ".IMPLICIT" 3 (optimize ,x)))))
90 (def compilation-speed)
93 (deftest declaration-information.muffle-conditions.default
94 (dinfo sb-ext:muffle-conditions)
96 (deftest declaration-information.muffle-conditions.1
97 (locally (declare (sb-ext:muffle-conditions warning))
98 (dinfo sb-ext:muffle-conditions))
100 (deftest declaration-information.muffle-conditions.2
101 (let ((junk (dinfo sb-ext:muffle-conditions)))
102 (declare (sb-ext:muffle-conditions warning))
103 (locally (declare (sb-ext:unmuffle-conditions style-warning))
104 (let ((dinfo (dinfo sb-ext:muffle-conditions)))
107 (and (subtypep dinfo `(or (and warning (not style-warning))
108 (and ,junk (not style-warning))))
109 (subtypep '(and warning (not style-warning)) dinfo)))))))
113 (declaim (declaration fubar))
115 (deftest declaration-information.declaration
116 (if (member 'fubar (declaration-information 'declaration)) 'yay)
119 ;;;; VARIABLE-INFORMATION
123 (defmacro var-info (var &environment env)
124 (list 'quote (multiple-value-list (variable-information var env))))
126 (deftest variable-info.global-special/unbound
130 (deftest variable-info.global-special/unbound/extra-decl
131 (locally (declare (special *foo*))
135 (deftest variable-info.global-special/bound
140 (deftest variable-info.global-special/bound/extra-decl
142 (declare (special *foo*))
146 (deftest variable-info.local-special/unbound
147 (locally (declare (special x))
151 (deftest variable-info.local-special/bound
153 (declare (special x))
157 (deftest variable-info.local-special/shadowed
159 (declare (special x))
166 (deftest variable-info.local-special/shadows-lexical
169 (declare (special x))
173 (deftest variable-info.lexical
178 (deftest variable-info.lexical.type
182 (:lexical t ((type . fixnum))))
184 (deftest variable-info.lexical.type.2
188 (locally (declare (fixnum x))
189 (assert (plusp x)))))
192 (deftest variable-info.lexical.type.3
194 (locally (declare (fixnum x))
196 (:lexical t ((type . fixnum))))
198 (deftest variable-info.ignore
202 (:lexical t ((ignore . t))))
204 (deftest variable-info.symbol-macro/local
205 (symbol-macrolet ((x 8))
207 (:symbol-macro t nil))
209 (define-symbol-macro my-symbol-macro t)
211 (deftest variable-info.symbol-macro/global
212 (var-info my-symbol-macro)
213 (:symbol-macro nil nil))
215 (deftest variable-info.undefined
216 (var-info #:undefined)
219 (declaim (global this-is-global))
220 (deftest global-variable
221 (var-info this-is-global)
224 (defglobal this-is-global-too 42)
225 (deftest global-variable.2
226 (var-info this-is-global-too)
227 (:global nil ((always-bound . t))))
229 ;;;; FUNCTION-INFORMATION
231 (defmacro fun-info (var &environment env)
232 (list 'quote (multiple-value-list (function-information var env))))
234 (defun my-global-fun (x) x)
236 (deftest function-info.global/no-ftype
237 (fun-info my-global-fun)
240 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
242 (defun my-global-fun-2 (x) x)
244 (deftest function-info.global/ftype
245 (fun-info my-global-fun-2)
246 (:function nil ((ftype function (cons) (values t &optional)))))
248 (defmacro my-macro (x) x)
250 (deftest function-info.macro
254 (deftest function-info.macrolet
255 (macrolet ((thingy () nil))
259 (deftest function-info.special-form
261 (:special-form nil nil))
263 (deftest function-info.notinline/local
265 (declare (notinline x))
268 (:function t ((inline . notinline))))
270 (declaim (notinline my-notinline))
271 (defun my-notinline (x) x)
273 (deftest function-info.notinline/global
274 (fun-info my-notinline)
275 (:function nil ((inline . notinline))))
277 (declaim (inline my-inline))
278 (defun my-inline (x) x)
280 (deftest function-info.inline/global
282 (:function nil ((inline . inline))))
284 (deftest function-information.known-inline
285 (locally (declare (inline identity))
287 (:function nil ((inline . inline)
288 (ftype function (t) (values t &optional)))))
290 (deftest function-information.ftype
292 (declare (ftype (sfunction (integer) integer) foo))
296 ((ftype function (integer) (values integer &optional)))))
298 ;;;;; AUGMENT-ENVIRONMENT
300 (defmacro ct (form &environment env)
301 (let ((toeval `(let ((lexenv (quote ,env)))
303 `(quote ,(eval toeval))))
306 (deftest augment-environment.variable1
307 (multiple-value-bind (kind local alist)
308 (variable-information
310 (augment-environment nil :variable (list 'x) :declare '((type integer x))))
311 (list kind local (cdr (assoc 'type alist))))
312 (:lexical t integer))
316 (deftest augment-environment.variable2
317 (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
320 (deftest augment-environment.variable3
321 (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
324 (deftest augment-environment.variable.special1
325 (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
328 (deftest augment-environment.variable.special12
329 (locally (declare (special x))
331 (variable-information
333 (identity (augment-environment lexenv :variable '(x))))))
336 (deftest augment-environment.variable.special13
337 (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
338 (e2 (augment-environment e1 :variable '(x))))
339 (identity (variable-information 'x e2)))
342 (deftest augment-environment.variable.special.mask
343 (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
344 (e2 (augment-environment e1 :variable '(x))))
346 (nth 2 (multiple-value-list
347 (variable-information 'x e2)))))
350 (deftest augment-environment.variable.ignore
351 (variable-information
353 (augment-environment nil
355 :declare '((ignore x))))
360 (deftest augment-environment.function
361 (function-information
363 (augment-environment nil
365 :declare '((ftype (sfunction (integer) integer) foo))))
368 ((ftype function (integer) (values integer &optional))))
371 (deftest augment-environment.macro
372 (macroexpand '(mac feh)
375 :macro (list (list 'mac #'(lambda (form benv)
376 (declare (ignore env))
377 `(quote ,form ,form ,form))))))
378 (quote (mac feh) (mac feh) (mac feh))
381 (deftest augment-environment.symbol-macro
385 :symbol-macro (list (list 'sym '(foo bar baz)))))
389 (deftest augment-environment.macro2
390 (eval (macroexpand '(newcond
393 (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
397 (deftest augment-environment.nest
400 (let* ((e (augment-environment lexenv :variable '(y))))
402 (variable-information 'x e)
403 (variable-information 'y e)))))
406 (deftest augment-environment.nest2
407 (symbol-macrolet ((x "x"))
409 (let* ((e (augment-environment lexenv :variable '(y))))
412 (variable-information 'y e)))))
415 (deftest augment-environment.symbol-macro-var
416 (let ((e (augment-environment
418 :symbol-macro (list (list 'sym '(foo bar baz)))
420 (list (macroexpand 'sym e)
421 (variable-information 'x e)))
427 ;;;;; DEFINE-DECLARATION
429 (defmacro third-value (form)
430 (sb-int::with-unique-names (a b c)
431 `(multiple-value-bind (,a ,b ,c) ,form
432 (declare (ignore ,a ,b))
435 (deftest define-declaration.declare
437 (define-declaration zaphod (spec env)
438 (declare (ignore env))
439 (values :declare (cons 'zaphod spec)))
440 (locally (declare (zaphod beblebrox))
441 (locally (declare (zaphod and ford))
442 (ct (declaration-information 'zaphod lexenv)))))
446 (deftest define-declaration.declare2
448 (define-declaration zaphod (spec env)
449 (declare (ignore env))
450 (values :declare (cons 'zaphod spec)))
452 (declare (zaphod beblebrox)
454 (ct (declaration-information 'zaphod lexenv))))
457 (deftest define-declaration.variable
459 (define-declaration vogon (spec env)
460 (declare (ignore env))
461 (values :variable `((,(cadr spec) vogon-key vogon-value))))
462 (locally (declare (vogon poetry))
466 (variable-information
469 (vogon-key . vogon-value))
472 (deftest define-declaration.variable.special
474 (define-declaration vogon (spec env)
475 (declare (ignore env))
476 (values :variable `((,(cadr spec) vogon-key vogon-value))))
479 (declare (special x))
483 (variable-information 'x lexenv))))))
484 (vogon-key . vogon-value))
486 (deftest define-declaration.variable.special2
488 (define-declaration vogon (spec env)
489 (declare (ignore env))
490 (values :variable `((,(cadr spec) vogon-key vogon-value))))
492 (declare (special x))
497 (variable-information 'x lexenv))))))
498 (vogon-key . vogon-value))
500 (deftest define-declaration.variable.mask
502 (define-declaration vogon (spec env)
503 (declare (ignore env))
504 (values :variable `((,(cadr spec) vogon-key vogon-value))))
511 (third (multiple-value-list (variable-information 'x lexenv))))))))
514 (deftest define-declaration.variable.macromask
516 (define-declaration vogon (spec env)
517 (declare (ignore env))
518 (values :variable `((,(cadr spec) vogon-key vogon-value))))
521 (symbol-macrolet ((x 42))
525 (third (multiple-value-list (variable-information 'x lexenv))))))))
528 (deftest define-declaration.variable.macromask2
530 (define-declaration vogon (spec env)
531 (declare (ignore env))
532 (values :variable `((,(cadr spec) vogon-key vogon-value))))
533 (symbol-macrolet ((x 42))
540 (third (multiple-value-list (variable-information 'x lexenv))))))
544 (third (multiple-value-list (variable-information 'x lexenv))))))))
545 (nil (vogon-key . vogon-value)))
547 (deftest define-declaration.variable.mask2
549 (define-declaration vogon-a (spec env)
550 (declare (ignore env))
551 (values :variable `((,(cadr spec) vogon-key a))))
552 (define-declaration vogon-b (spec env)
553 (declare (ignore env))
554 (values :variable `((,(cadr spec) vogon-key b))))
556 (declare (vogon-a x))
558 (declare (vogon-b x)))
562 (third (multiple-value-list (variable-information 'x lexenv)))))))
565 (deftest define-declaration.variable.specialmask
567 (define-declaration vogon (spec env)
568 (declare (ignore env))
569 (values :variable `((,(cadr spec) vogon-key vogon-value))))
571 (declare (vogon *foo*))
576 (third (multiple-value-list (variable-information '*foo* lexenv))))))))
577 (vogon-key . vogon-value))
581 (deftest define-declaration.function
583 (define-declaration sad (spec env)
584 (declare (ignore env))
585 (values :function `((,(cadr spec) emotional-state sad))))
586 (locally (declare (zaphod beblebrox))
587 (locally (declare (sad robot))
589 (assoc 'emotional-state
590 (third-value (function-information
593 (emotional-state . sad))
595 (deftest define-declaration.function.lexical
597 (define-declaration sad (spec env)
598 (declare (ignore env))
599 (values :function `((,(cadr spec) emotional-state sad))))
601 (locally (declare (sad robot))
603 (assoc 'emotional-state
604 (third-value (function-information
607 (emotional-state . sad))
610 (deftest define-declaration.function.lexical2
612 (define-declaration sad (spec env)
613 (declare (ignore env))
614 (values :function `((,(cadr spec) emotional-state sad))))
615 (labels ((robot nil))
616 (declare (sad robot))
618 (assoc 'emotional-state
619 (third-value (function-information
622 (emotional-state . sad))
624 (deftest define-declaration.function.mask
626 (define-declaration sad (spec env)
627 (declare (ignore env))
628 (values :function `((,(cadr spec) emotional-state sad))))
629 (labels ((robot nil))
630 (declare (sad robot))
631 (labels ((robot nil))
633 (assoc 'emotional-state
634 (third-value (function-information
640 (deftest define-declaration.function.mask2
642 (define-declaration sad (spec env)
643 (declare (ignore env))
644 (values :function `((,(cadr spec) emotional-state sad))))
646 (declare (sad robot))
647 (labels ((robot nil))
649 (assoc 'emotional-state
650 (third-value (function-information
655 (deftest define-declaration.function2
657 (define-declaration happy (spec env)
658 (declare (ignore env))
659 (values :function `((,(cadr spec) emotional-state happy))))
660 (locally (declare (zaphod beblebrox))
661 (locally (declare (sad robot))
662 (locally (declare (happy robot))
664 (assoc 'emotional-state
665 (third-value (function-information
668 (emotional-state . happy))