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 (sb-alien:define-alien-variable "errno" sb-alien:int)
230 (deftest alien-variable
234 ;;;; FUNCTION-INFORMATION
236 (defmacro fun-info (var &environment env)
237 (list 'quote (multiple-value-list (function-information var env))))
239 (defun my-global-fun (x) x)
241 (deftest function-info.global/no-ftype
242 (fun-info my-global-fun)
245 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
247 (defun my-global-fun-2 (x) x)
249 (deftest function-info.global/ftype
250 (fun-info my-global-fun-2)
251 (:function nil ((ftype function (cons) (values t &optional)))))
253 (defmacro my-macro (x) x)
255 (deftest function-info.macro
259 (deftest function-info.macrolet
260 (macrolet ((thingy () nil))
264 (deftest function-info.special-form
266 (:special-form nil nil))
268 (deftest function-info.notinline/local
270 (declare (notinline x))
273 (:function t ((inline . notinline))))
275 (declaim (notinline my-notinline))
276 (defun my-notinline (x) x)
278 (deftest function-info.notinline/global
279 (fun-info my-notinline)
280 (:function nil ((inline . notinline))))
282 (declaim (inline my-inline))
283 (defun my-inline (x) x)
285 (deftest function-info.inline/global
287 (:function nil ((inline . inline))))
289 (deftest function-information.known-inline
290 (locally (declare (inline identity))
292 (:function nil ((inline . inline)
293 (ftype function (t) (values t &optional)))))
295 (deftest function-information.ftype
297 (declare (ftype (sfunction (integer) integer) foo))
301 ((ftype function (integer) (values integer &optional)))))
303 ;;;;; AUGMENT-ENVIRONMENT
305 (defmacro ct (form &environment env)
306 (let ((toeval `(let ((lexenv (quote ,env)))
308 `(quote ,(eval toeval))))
311 (deftest augment-environment.variable1
312 (multiple-value-bind (kind local alist)
313 (variable-information
315 (augment-environment nil :variable (list 'x) :declare '((type integer x))))
316 (list kind local (cdr (assoc 'type alist))))
317 (:lexical t integer))
321 (deftest augment-environment.variable2
322 (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
325 (deftest augment-environment.variable3
326 (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
329 (deftest augment-environment.variable.special1
330 (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
333 (deftest augment-environment.variable.special12
334 (locally (declare (special x))
336 (variable-information
338 (identity (augment-environment lexenv :variable '(x))))))
341 (deftest augment-environment.variable.special13
342 (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
343 (e2 (augment-environment e1 :variable '(x))))
344 (identity (variable-information 'x e2)))
347 (deftest augment-environment.variable.special.mask
348 (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
349 (e2 (augment-environment e1 :variable '(x))))
351 (nth 2 (multiple-value-list
352 (variable-information 'x e2)))))
355 (deftest augment-environment.variable.ignore
356 (variable-information
358 (augment-environment nil
360 :declare '((ignore x))))
365 (deftest augment-environment.function
366 (function-information
368 (augment-environment nil
370 :declare '((ftype (sfunction (integer) integer) foo))))
373 ((ftype function (integer) (values integer &optional))))
376 (deftest augment-environment.macro
377 (macroexpand '(mac feh)
380 :macro (list (list 'mac #'(lambda (form benv)
381 (declare (ignore env))
382 `(quote ,form ,form ,form))))))
383 (quote (mac feh) (mac feh) (mac feh))
386 (deftest augment-environment.symbol-macro
390 :symbol-macro (list (list 'sym '(foo bar baz)))))
394 (deftest augment-environment.macro2
395 (eval (macroexpand '(newcond
398 (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
402 (deftest augment-environment.nest
405 (let* ((e (augment-environment lexenv :variable '(y))))
407 (variable-information 'x e)
408 (variable-information 'y e)))))
411 (deftest augment-environment.nest2
412 (symbol-macrolet ((x "x"))
414 (let* ((e (augment-environment lexenv :variable '(y))))
417 (variable-information 'y e)))))
420 (deftest augment-environment.symbol-macro-var
421 (let ((e (augment-environment
423 :symbol-macro (list (list 'sym '(foo bar baz)))
425 (list (macroexpand 'sym e)
426 (variable-information 'x e)))
432 ;;;;; DEFINE-DECLARATION
434 (defmacro third-value (form)
435 (sb-int::with-unique-names (a b c)
436 `(multiple-value-bind (,a ,b ,c) ,form
437 (declare (ignore ,a ,b))
440 (deftest define-declaration.declare
442 (define-declaration zaphod (spec env)
443 (declare (ignore env))
444 (values :declare (cons 'zaphod spec)))
445 (locally (declare (zaphod beblebrox))
446 (locally (declare (zaphod and ford))
447 (ct (declaration-information 'zaphod lexenv)))))
451 (deftest define-declaration.declare2
453 (define-declaration zaphod (spec env)
454 (declare (ignore env))
455 (values :declare (cons 'zaphod spec)))
457 (declare (zaphod beblebrox)
459 (ct (declaration-information 'zaphod lexenv))))
462 (deftest define-declaration.variable
464 (define-declaration vogon (spec env)
465 (declare (ignore env))
466 (values :variable `((,(cadr spec) vogon-key vogon-value))))
467 (locally (declare (vogon poetry))
471 (variable-information
474 (vogon-key . vogon-value))
477 (deftest define-declaration.variable.special
479 (define-declaration vogon (spec env)
480 (declare (ignore env))
481 (values :variable `((,(cadr spec) vogon-key vogon-value))))
484 (declare (special x))
488 (variable-information 'x lexenv))))))
489 (vogon-key . vogon-value))
491 (deftest define-declaration.variable.special2
493 (define-declaration vogon (spec env)
494 (declare (ignore env))
495 (values :variable `((,(cadr spec) vogon-key vogon-value))))
497 (declare (special x))
502 (variable-information 'x lexenv))))))
503 (vogon-key . vogon-value))
505 (deftest define-declaration.variable.mask
507 (define-declaration vogon (spec env)
508 (declare (ignore env))
509 (values :variable `((,(cadr spec) vogon-key vogon-value))))
516 (third (multiple-value-list (variable-information 'x lexenv))))))))
519 (deftest define-declaration.variable.macromask
521 (define-declaration vogon (spec env)
522 (declare (ignore env))
523 (values :variable `((,(cadr spec) vogon-key vogon-value))))
526 (symbol-macrolet ((x 42))
530 (third (multiple-value-list (variable-information 'x lexenv))))))))
533 (deftest define-declaration.variable.macromask2
535 (define-declaration vogon (spec env)
536 (declare (ignore env))
537 (values :variable `((,(cadr spec) vogon-key vogon-value))))
538 (symbol-macrolet ((x 42))
545 (third (multiple-value-list (variable-information 'x lexenv))))))
549 (third (multiple-value-list (variable-information 'x lexenv))))))))
550 (nil (vogon-key . vogon-value)))
552 (deftest define-declaration.variable.mask2
554 (define-declaration vogon-a (spec env)
555 (declare (ignore env))
556 (values :variable `((,(cadr spec) vogon-key a))))
557 (define-declaration vogon-b (spec env)
558 (declare (ignore env))
559 (values :variable `((,(cadr spec) vogon-key b))))
561 (declare (vogon-a x))
563 (declare (vogon-b x)))
567 (third (multiple-value-list (variable-information 'x lexenv)))))))
570 (deftest define-declaration.variable.specialmask
572 (define-declaration vogon (spec env)
573 (declare (ignore env))
574 (values :variable `((,(cadr spec) vogon-key vogon-value))))
576 (declare (vogon *foo*))
581 (third (multiple-value-list (variable-information '*foo* lexenv))))))))
582 (vogon-key . vogon-value))
586 (deftest define-declaration.function
588 (define-declaration sad (spec env)
589 (declare (ignore env))
590 (values :function `((,(cadr spec) emotional-state sad))))
591 (locally (declare (zaphod beblebrox))
592 (locally (declare (sad robot))
594 (assoc 'emotional-state
595 (third-value (function-information
598 (emotional-state . sad))
600 (deftest define-declaration.function.lexical
602 (define-declaration sad (spec env)
603 (declare (ignore env))
604 (values :function `((,(cadr spec) emotional-state sad))))
606 (locally (declare (sad robot))
608 (assoc 'emotional-state
609 (third-value (function-information
612 (emotional-state . sad))
615 (deftest define-declaration.function.lexical2
617 (define-declaration sad (spec env)
618 (declare (ignore env))
619 (values :function `((,(cadr spec) emotional-state sad))))
620 (labels ((robot nil))
621 (declare (sad robot))
623 (assoc 'emotional-state
624 (third-value (function-information
627 (emotional-state . sad))
629 (deftest define-declaration.function.mask
631 (define-declaration sad (spec env)
632 (declare (ignore env))
633 (values :function `((,(cadr spec) emotional-state sad))))
634 (labels ((robot nil))
635 (declare (sad robot))
636 (labels ((robot nil))
638 (assoc 'emotional-state
639 (third-value (function-information
645 (deftest define-declaration.function.mask2
647 (define-declaration sad (spec env)
648 (declare (ignore env))
649 (values :function `((,(cadr spec) emotional-state sad))))
651 (declare (sad robot))
652 (labels ((robot nil))
654 (assoc 'emotional-state
655 (third-value (function-information
660 (deftest define-declaration.function2
662 (define-declaration happy (spec env)
663 (declare (ignore env))
664 (values :function `((,(cadr spec) emotional-state happy))))
665 (locally (declare (zaphod beblebrox))
666 (locally (declare (sad robot))
667 (locally (declare (happy robot))
669 (assoc 'emotional-state
670 (third-value (function-information
673 (emotional-state . happy))