contrib/sb-cltl2/tests.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; The software is in the public domain and is provided with
   5 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
   6 ;;;; more information.
   7
   8 (defpackage :sb-cltl2-tests
   9   (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
  10
  11 (in-package :sb-cltl2-tests)
  12
  13 (rem-all-tests)
  14
  15 (defmacro *x*-value ()
  16   (declare (special *x*))
  17   *x*)
  18
  19 (deftest compiler-let.1
  20     (let ((*x* :outer))
  21       (compiler-let ((*x* :inner))
  22         (list *x* (*x*-value))))
  23   (:outer :inner))
  24
  25 (defvar *expansions* nil)
  26 (defmacro macroexpand-macro (arg)
  27   (push arg *expansions*)
  28   arg)
  29
  30 (deftest macroexpand-all.1
  31     (progn
  32       (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
  33       t)
  34   t)
  35
  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* #'<)))
  42   (1 2))
  43
  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)))
  49                        (foo
  50                         (macrolet ((bar (key)
  51                                      (push key *expansions*)
  52                                      key))
  53                           (foo 1))))))
  54       (remove-duplicates *expansions*))
  55   (1))
  56
  57 (defun smv (env)
  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))
  63
  64 (deftest macroexpand-all.4
  65     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
  66   (symbol-macrolet ((srlt '(nil zool))) 'zool))
  67
  68 ;;;; DECLARATION-INFORMATION
  69
  70 (defmacro dinfo (thing &environment env)
  71   `',(declaration-information thing env))
  72
  73 (macrolet ((def (x)
  74                `(macrolet ((frob (suffix answer &optional declaration)
  75                             `(deftest ,(intern (concatenate 'string
  76                                                             "DECLARATION-INFORMATION."
  77                                                             (symbol-name ',x)
  78                                                             suffix))
  79                                (locally (declare ,@(when declaration
  80                                                          (list declaration)))
  81                                  (cadr (assoc ',',x (dinfo optimize))))
  82                               ,answer)))
  83                  (frob ".DEFAULT" 1)
  84                  (frob ".0" 0 (optimize (,x 0)))
  85                  (frob ".1" 1 (optimize (,x 1)))
  86                  (frob ".2" 2 (optimize (,x 2)))
  87                  (frob ".3" 3 (optimize (,x 3)))
  88                  (frob ".IMPLICIT" 3 (optimize ,x)))))
  89   (def speed)
  90   (def safety)
  91   (def debug)
  92   (def compilation-speed)
  93   (def space))
  94
  95
  96 (deftest declaration-information.restrict-compiler-policy.1
  97     (with-compilation-unit (:policy '(optimize) :override t)
  98       (restrict-compiler-policy 'speed 3)
  99       (eval '(cadr (assoc 'speed (dinfo optimize)))))
 100   3)
 101
 102 (deftest declaration-information.restrict-compiler-policy.2
 103     (with-compilation-unit (:policy '(optimize) :override t)
 104       (restrict-compiler-policy 'speed 3)
 105       (locally (declare (optimize (speed 2)))
 106         (cadr (assoc 'speed (dinfo optimize)))))
 107   2)
 108
 109 (deftest declaration-information.restrict-compiler-policy.3
 110     (locally (declare (optimize (speed 2)))
 111       (with-compilation-unit (:policy '(optimize) :override t)
 112         (restrict-compiler-policy 'speed 3)
 113         (cadr (assoc 'speed (dinfo optimize)))))
 114   2)
 115
 116 (deftest declaration-information.muffle-conditions.default
 117   (dinfo sb-ext:muffle-conditions)
 118   nil)
 119 (deftest declaration-information.muffle-conditions.1
 120   (locally (declare (sb-ext:muffle-conditions warning))
 121     (dinfo sb-ext:muffle-conditions))
 122   warning)
 123 (deftest declaration-information.muffle-conditions.2
 124   (let ((junk (dinfo sb-ext:muffle-conditions)))
 125     (declare (sb-ext:muffle-conditions warning))
 126     (locally (declare (sb-ext:unmuffle-conditions style-warning))
 127       (let ((dinfo (dinfo sb-ext:muffle-conditions)))
 128         (not
 129          (not
 130           (and (subtypep dinfo `(or (and warning (not style-warning))
 131                                     (and ,junk (not style-warning))))
 132                (subtypep '(and warning (not style-warning)) dinfo)))))))
 133   t)
 134
 135
 136 (declaim (declaration fubar))
 137
 138 (deftest declaration-information.declaration
 139     (if (member 'fubar (declaration-information 'declaration)) 'yay)
 140   yay)
 141
 142 ;;;; VARIABLE-INFORMATION
 143
 144 (defvar *foo*)
 145
 146 (defmacro var-info (var &environment env)
 147   (list 'quote (multiple-value-list (variable-information var env))))
 148
 149 (deftest variable-info.global-special/unbound
 150     (var-info *foo*)
 151   (:special nil nil))
 152
 153 (deftest variable-info.global-special/unbound/extra-decl
 154     (locally (declare (special *foo*))
 155       (var-info *foo*))
 156   (:special nil nil))
 157
 158 (deftest variable-info.global-special/bound
 159     (let ((*foo* t))
 160       (var-info *foo*))
 161   (:special nil nil))
 162
 163 (deftest variable-info.global-special/bound/extra-decl
 164     (let ((*foo* t))
 165       (declare (special *foo*))
 166       (var-info *foo*))
 167   (:special nil nil))
 168
 169 (deftest variable-info.local-special/unbound
 170     (locally (declare (special x))
 171       (var-info x))
 172   (:special nil nil))
 173
 174 (deftest variable-info.local-special/bound
 175     (let ((x 13))
 176       (declare (special x))
 177       (var-info x))
 178   (:special nil nil))
 179
 180 (deftest variable-info.local-special/shadowed
 181     (let ((x 3))
 182       (declare (special x))
 183       x
 184       (let ((x 3))
 185         x
 186         (var-info x)))
 187   (:lexical t nil))
 188
 189 (deftest variable-info.local-special/shadows-lexical
 190     (let ((x 3))
 191       (let ((x 3))
 192         (declare (special x))
 193         (var-info x)))
 194   (:special nil nil))
 195
 196 (deftest variable-info.lexical
 197     (let ((x 8))
 198       (var-info x))
 199   (:lexical t nil))
 200
 201 (deftest variable-info.lexical.type
 202     (let ((x 42))
 203       (declare (fixnum x))
 204       (var-info x))
 205   (:lexical t ((type . fixnum))))
 206
 207 (deftest variable-info.lexical.type.2
 208     (let ((x 42))
 209       (prog1
 210           (var-info x)
 211         (locally (declare (fixnum x))
 212           (assert (plusp x)))))
 213   (:lexical t nil))
 214
 215 (deftest variable-info.lexical.type.3
 216     (let ((x 42))
 217       (locally (declare (fixnum x))
 218         (var-info x)))
 219   (:lexical t ((type . fixnum))))
 220
 221 (deftest variable-info.ignore
 222     (let ((x 8))
 223       (declare (ignore x))
 224       (var-info x))
 225   (:lexical t ((ignore . t))))
 226
 227 (deftest variable-info.symbol-macro/local
 228     (symbol-macrolet ((x 8))
 229       (var-info x))
 230   (:symbol-macro t nil))
 231
 232 (define-symbol-macro my-symbol-macro t)
 233
 234 (deftest variable-info.symbol-macro/global
 235     (var-info my-symbol-macro)
 236   (:symbol-macro nil nil))
 237
 238 (deftest variable-info.undefined
 239     (var-info #:undefined)
 240   (nil nil nil))
 241
 242 (declaim (global this-is-global))
 243 (deftest global-variable
 244     (var-info this-is-global)
 245   (:global nil nil))
 246
 247 (defglobal this-is-global-too 42)
 248 (deftest global-variable.2
 249     (var-info this-is-global-too)
 250   (:global nil ((always-bound . t))))
 251
 252 (sb-alien:define-alien-variable "errno" sb-alien:int)
 253 (deftest alien-variable
 254     (var-info errno)
 255   (:alien nil nil))
 256
 257 ;;;; FUNCTION-INFORMATION
 258
 259 (defmacro fun-info (var &environment env)
 260   (list 'quote (multiple-value-list (function-information var env))))
 261
 262 (defun my-global-fun (x) x)
 263
 264 (deftest function-info.global/no-ftype
 265     (fun-info my-global-fun)
 266   (:function nil nil))
 267
 268 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
 269
 270 (defun my-global-fun-2 (x) x)
 271
 272 (deftest function-info.global/ftype
 273     (fun-info my-global-fun-2)
 274   (:function nil ((ftype function (cons) (values t &optional)))))
 275
 276 (defmacro my-macro (x) x)
 277
 278 (deftest function-info.macro
 279     (fun-info my-macro)
 280   (:macro nil nil))
 281
 282 (deftest function-info.macrolet
 283     (macrolet ((thingy () nil))
 284       (fun-info thingy))
 285   (:macro t nil))
 286
 287 (deftest function-info.special-form
 288     (fun-info progn)
 289   (:special-form  nil nil))
 290
 291 (deftest function-info.notinline/local
 292     (flet ((x (y) y))
 293       (declare (notinline x))
 294       (x 1)
 295       (fun-info x))
 296   (:function t ((inline . notinline))))
 297
 298 (declaim (notinline my-notinline))
 299 (defun my-notinline (x) x)
 300
 301 (deftest function-info.notinline/global
 302     (fun-info my-notinline)
 303   (:function nil ((inline . notinline))))
 304
 305 (declaim (inline my-inline))
 306 (defun my-inline (x) x)
 307
 308 (deftest function-info.inline/global
 309     (fun-info my-inline)
 310   (:function nil ((inline . inline))))
 311
 312 (deftest function-information.known-inline
 313     (locally (declare (inline identity))
 314       (fun-info identity))
 315   (:function nil ((inline . inline)
 316                   (ftype function (t) (values t &optional)))))
 317
 318 (deftest function-information.ftype
 319     (flet ((foo (x) x))
 320       (declare (ftype (sfunction (integer) integer) foo))
 321       (fun-info foo))
 322   (:function
 323    t
 324    ((ftype function (integer) (values integer &optional)))))
 325
 326 ;;;;; AUGMENT-ENVIRONMENT
 327
 328 (defmacro ct (form &environment env)
 329   (let ((toeval `(let ((lexenv (quote ,env)))
 330                    ,form)))
 331     `(quote ,(eval toeval))))
 332
 333
 334 (deftest augment-environment.variable1
 335     (multiple-value-bind (kind local alist)
 336         (variable-information
 337          'x
 338          (augment-environment nil :variable (list 'x) :declare '((type integer x))))
 339       (list kind local (cdr (assoc 'type alist))))
 340   (:lexical t integer))
 341
 342 (defvar *foo*)
 343
 344 (deftest augment-environment.variable2
 345     (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
 346   :lexical)
 347
 348 (deftest augment-environment.variable3
 349     (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
 350   :lexical)
 351
 352 (deftest augment-environment.variable.special1
 353     (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
 354   :special)
 355
 356 (deftest augment-environment.variable.special12
 357     (locally (declare (special x))
 358       (ct
 359        (variable-information
 360         'x
 361         (identity (augment-environment lexenv :variable '(x))))))
 362   :lexical)
 363
 364 (deftest augment-environment.variable.special13
 365     (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
 366            (e2 (augment-environment e1  :variable '(x))))
 367       (identity (variable-information 'x e2)))
 368   :lexical)
 369
 370 (deftest augment-environment.variable.special.mask
 371     (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
 372            (e2 (augment-environment e1  :variable '(x))))
 373       (assoc 'ignore
 374              (nth 2 (multiple-value-list
 375                      (variable-information 'x e2)))))
 376   nil)
 377
 378 (deftest augment-environment.variable.ignore
 379     (variable-information
 380      'x
 381      (augment-environment nil
 382                           :variable '(x)
 383                           :declare  '((ignore x))))
 384   :lexical
 385   t
 386   ((ignore . t)))
 387
 388 (deftest augment-environment.function
 389     (function-information
 390      'foo
 391      (augment-environment nil
 392                           :function '(foo)
 393                           :declare  '((ftype (sfunction (integer) integer) foo))))
 394   :function
 395   t
 396   ((ftype function (integer) (values integer &optional))))
 397
 398
 399 (deftest augment-environment.macro
 400     (macroexpand '(mac feh)
 401                  (augment-environment
 402                   nil
 403                   :macro (list (list 'mac #'(lambda (form benv)
 404                                               (declare (ignore env))
 405                                               `(quote ,form ,form ,form))))))
 406   (quote (mac feh) (mac feh) (mac feh))
 407   t)
 408
 409 (deftest augment-environment.symbol-macro
 410     (macroexpand 'sym
 411                  (augment-environment
 412                   nil
 413                   :symbol-macro (list (list 'sym '(foo bar baz)))))
 414   (foo bar baz)
 415   t)
 416
 417 (deftest augment-environment.macro2
 418     (eval (macroexpand '(newcond
 419                          ((= 1 2) 'foo)
 420                          ((= 1 1) 'bar))
 421                        (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
 422   bar)
 423
 424
 425 (deftest augment-environment.nest
 426     (let ((x 1))
 427       (ct
 428        (let* ((e (augment-environment lexenv :variable '(y))))
 429          (list
 430           (variable-information 'x e)
 431           (variable-information 'y e)))))
 432   (:lexical :lexical))
 433
 434 (deftest augment-environment.nest2
 435     (symbol-macrolet ((x "x"))
 436       (ct
 437        (let* ((e (augment-environment lexenv :variable '(y))))
 438          (list
 439           (macroexpand 'x e)
 440           (variable-information 'y e)))))
 441   ("x" :lexical))
 442
 443 (deftest augment-environment.symbol-macro-var
 444     (let ((e (augment-environment
 445               nil
 446               :symbol-macro (list (list 'sym '(foo bar baz)))
 447               :variable '(x))))
 448       (list (macroexpand 'sym e)
 449             (variable-information 'x e)))
 450   ((foo bar baz)
 451    :lexical))
 452
 453
 454
 455 ;;;;; DEFINE-DECLARATION
 456
 457 (defmacro third-value (form)
 458   (sb-int::with-unique-names (a b c)
 459     `(multiple-value-bind (,a ,b ,c) ,form
 460        (declare (ignore ,a ,b))
 461        ,c)))
 462
 463 (deftest define-declaration.declare
 464     (progn
 465       (define-declaration zaphod (spec env)
 466         (declare (ignore env))
 467         (values :declare (cons 'zaphod spec)))
 468       (locally (declare (zaphod beblebrox))
 469          (locally (declare (zaphod and ford))
 470            (ct (declaration-information 'zaphod lexenv)))))
 471   (zaphod and ford))
 472
 473
 474 (deftest define-declaration.declare2
 475     (progn
 476       (define-declaration zaphod (spec env)
 477         (declare (ignore env))
 478         (values :declare (cons 'zaphod spec)))
 479       (locally
 480            (declare (zaphod beblebrox)
 481                     (special x))
 482          (ct (declaration-information 'zaphod lexenv))))
 483   (zaphod beblebrox))
 484
 485 (deftest define-declaration.variable
 486     (progn
 487       (define-declaration vogon (spec env)
 488         (declare (ignore env))
 489         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 490       (locally (declare (vogon poetry))
 491         (ct
 492          (assoc 'vogon-key
 493                 (third-value
 494                  (variable-information
 495                   'poetry
 496                   lexenv))))))
 497   (vogon-key . vogon-value))
 498
 499
 500 (deftest define-declaration.variable.special
 501     (progn
 502       (define-declaration vogon (spec env)
 503         (declare (ignore env))
 504         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 505       (let (x)
 506         (declare (vogon x))
 507         (declare (special x))
 508         (ct
 509          (assoc 'vogon-key
 510                 (third-value
 511                  (variable-information 'x lexenv))))))
 512   (vogon-key . vogon-value))
 513
 514 (deftest define-declaration.variable.special2
 515     (progn
 516       (define-declaration vogon (spec env)
 517         (declare (ignore env))
 518         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 519       (let (x)
 520         (declare (special x))
 521         (declare (vogon x))
 522         (ct
 523          (assoc 'vogon-key
 524                 (third-value
 525                  (variable-information 'x lexenv))))))
 526   (vogon-key . vogon-value))
 527
 528 (deftest define-declaration.variable.mask
 529     (progn
 530       (define-declaration vogon (spec env)
 531         (declare (ignore env))
 532         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 533       (let (x)
 534         (declare (vogon x))
 535         (let (x)
 536           (ct
 537            (assoc
 538             'vogon-key
 539             (third (multiple-value-list (variable-information 'x lexenv))))))))
 540   nil)
 541
 542 (deftest define-declaration.variable.macromask
 543     (progn
 544       (define-declaration vogon (spec env)
 545         (declare (ignore env))
 546         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 547       (let (x)
 548         (declare (vogon x))
 549         (symbol-macrolet ((x 42))
 550           (ct
 551            (assoc
 552             'vogon-key
 553             (third (multiple-value-list (variable-information 'x lexenv))))))))
 554   nil)
 555
 556 (deftest define-declaration.variable.macromask2
 557     (progn
 558       (define-declaration vogon (spec env)
 559         (declare (ignore env))
 560         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 561       (symbol-macrolet ((x 42))
 562         (declare (vogon x))
 563         (list
 564          (let (x)
 565            (ct
 566             (assoc
 567              'vogon-key
 568              (third (multiple-value-list (variable-information 'x lexenv))))))
 569          (ct
 570           (assoc
 571            'vogon-key
 572            (third (multiple-value-list (variable-information 'x lexenv))))))))
 573   (nil (vogon-key . vogon-value)))
 574
 575 (deftest define-declaration.variable.mask2
 576     (progn
 577       (define-declaration vogon-a (spec env)
 578         (declare (ignore env))
 579         (values :variable `((,(cadr spec) vogon-key a))))
 580       (define-declaration vogon-b (spec env)
 581         (declare (ignore env))
 582         (values :variable `((,(cadr spec) vogon-key b))))
 583       (let (x)
 584         (declare (vogon-a x))
 585         (let (x)
 586           (declare (vogon-b x)))
 587         (ct
 588          (assoc
 589           'vogon-key
 590           (third (multiple-value-list (variable-information 'x lexenv)))))))
 591   (vogon-key . a))
 592
 593 (deftest define-declaration.variable.specialmask
 594     (progn
 595       (define-declaration vogon (spec env)
 596         (declare (ignore env))
 597         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 598       (locally
 599           (declare (vogon *foo*))
 600         (let (*foo*)
 601           (ct
 602            (assoc
 603             'vogon-key
 604             (third (multiple-value-list (variable-information '*foo* lexenv))))))))
 605   (vogon-key . vogon-value))
 606
 607
 608
 609 (deftest define-declaration.function
 610     (progn
 611       (define-declaration sad (spec env)
 612         (declare (ignore env))
 613         (values :function `((,(cadr spec) emotional-state sad))))
 614       (locally (declare (zaphod beblebrox))
 615         (locally (declare (sad robot))
 616           (ct
 617            (assoc 'emotional-state
 618                   (third-value (function-information
 619                                 'robot
 620                                 lexenv)))))))
 621   (emotional-state . sad))
 622
 623 (deftest define-declaration.function.lexical
 624     (progn
 625       (define-declaration sad (spec env)
 626         (declare (ignore env))
 627         (values :function `((,(cadr spec) emotional-state sad))))
 628       (flet ((robot nil))
 629         (locally (declare (sad robot))
 630           (ct
 631            (assoc 'emotional-state
 632                   (third-value (function-information
 633                                 'robot
 634                                 lexenv)))))))
 635   (emotional-state . sad))
 636
 637
 638 (deftest define-declaration.function.lexical2
 639     (progn
 640       (define-declaration sad (spec env)
 641         (declare (ignore env))
 642         (values :function `((,(cadr spec) emotional-state sad))))
 643       (labels ((robot nil))
 644         (declare (sad robot))
 645         (ct
 646          (assoc 'emotional-state
 647                 (third-value (function-information
 648                               'robot
 649                               lexenv))))))
 650   (emotional-state . sad))
 651
 652 (deftest define-declaration.function.mask
 653     (progn
 654       (define-declaration sad (spec env)
 655         (declare (ignore env))
 656         (values :function `((,(cadr spec) emotional-state sad))))
 657       (labels ((robot nil))
 658         (declare (sad robot))
 659         (labels ((robot nil))
 660           (ct
 661            (assoc 'emotional-state
 662                   (third-value (function-information
 663                                 'robot
 664                                 lexenv)))))))
 665   nil)
 666
 667
 668 (deftest define-declaration.function.mask2
 669     (progn
 670       (define-declaration sad (spec env)
 671         (declare (ignore env))
 672         (values :function `((,(cadr spec) emotional-state sad))))
 673       (locally
 674           (declare (sad robot))
 675         (labels ((robot nil))
 676           (ct
 677            (assoc 'emotional-state
 678                   (third-value (function-information
 679                                 'robot
 680                                 lexenv)))))))
 681   nil)
 682
 683 (deftest define-declaration.function2
 684     (progn
 685       (define-declaration happy (spec env)
 686         (declare (ignore env))
 687         (values :function `((,(cadr spec) emotional-state happy))))
 688       (locally (declare (zaphod beblebrox))
 689         (locally (declare (sad robot))
 690           (locally (declare (happy robot))
 691             (ct
 692              (assoc 'emotional-state
 693                     (third-value (function-information
 694                                   'robot
 695                                   lexenv))))))))
 696   (emotional-state . happy))
 697
 698 (deftest macroexpand-all.special-binding
 699     (let ((form '(macrolet ((v (x &environment env)
 700                              (sb-cltl2:variable-information x env)))
 701                   (let* ((x :foo)
 702                          (y (v x)))
 703                     (declare (special x))
 704                     (list y (v x))))))
 705       (list (eval form)
 706             (eval (sb-cltl2:macroexpand-all form))))
 707   ((:special :special) (:special :special)))
 708
 709 (deftest macroexpand-all.symbol-macro-shadowed
 710     (let ((form '(macrolet ((v (x &environment env)
 711                              (macroexpand x env)))
 712                   (symbol-macrolet ((x :bad))
 713                     (let* ((x :good)
 714                            (y (v x)))
 715                       y)))))
 716       (list (eval form)
 717             (eval (sb-cltl2:macroexpand-all form))))
 718   (:good :good))