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 (defmacro dinfo (thing &environment env)
  69   `',(declaration-information thing env))
  70
  71 (macrolet ((def (x)
  72                `(macrolet ((frob (suffix answer &optional declaration)
  73                             `(deftest ,(intern (concatenate 'string
  74                                                             "DECLARATION-INFORMATION."
  75                                                             (symbol-name ',x)
  76                                                             suffix))
  77                                (locally (declare ,@(when declaration
  78                                                          (list declaration)))
  79                                  (cadr (assoc ',',x (dinfo optimize))))
  80                               ,answer)))
  81                  (frob ".DEFAULT" 1)
  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)))))
  87   (def speed)
  88   (def safety)
  89   (def debug)
  90   (def compilation-speed)
  91   (def space))
  92
  93 (deftest declaration-information.muffle-conditions.default
  94   (dinfo sb-ext:muffle-conditions)
  95   nil)
  96 (deftest declaration-information.muffle-conditions.1
  97   (locally (declare (sb-ext:muffle-conditions warning))
  98     (dinfo sb-ext:muffle-conditions))
  99   warning)
 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)))
 105         (not
 106          (not
 107           (and (subtypep dinfo `(or (and warning (not style-warning))
 108                                     (and ,junk (not style-warning))))
 109                (subtypep '(and warning (not style-warning)) dinfo)))))))
 110   t)
 111
 112
 113 (declaim (declaration fubar))
 114
 115 (deftest declaration-information.declaration
 116     (if (member 'fubar (declaration-information 'declaration)) 'yay)
 117   yay)
 118
 119 ;;;; VARIABLE-INFORMATION
 120
 121 (defvar *foo*)
 122
 123 (defmacro var-info (var &environment env)
 124   (list 'quote (multiple-value-list (variable-information var env))))
 125
 126 (deftest variable-info.global-special/unbound
 127     (var-info *foo*)
 128   (:special nil nil))
 129
 130 (deftest variable-info.global-special/unbound/extra-decl
 131     (locally (declare (special *foo*))
 132       (var-info *foo*))
 133   (:special nil nil))
 134
 135 (deftest variable-info.global-special/bound
 136     (let ((*foo* t))
 137       (var-info *foo*))
 138   (:special nil nil))
 139
 140 (deftest variable-info.global-special/bound/extra-decl
 141     (let ((*foo* t))
 142       (declare (special *foo*))
 143       (var-info *foo*))
 144   (:special nil nil))
 145
 146 (deftest variable-info.local-special/unbound
 147     (locally (declare (special x))
 148       (var-info x))
 149   (:special nil nil))
 150
 151 (deftest variable-info.local-special/bound
 152     (let ((x 13))
 153       (declare (special x))
 154       (var-info x))
 155   (:special nil nil))
 156
 157 (deftest variable-info.local-special/shadowed
 158     (let ((x 3))
 159       (declare (special x))
 160       x
 161       (let ((x 3))
 162         x
 163         (var-info x)))
 164   (:lexical t nil))
 165
 166 (deftest variable-info.local-special/shadows-lexical
 167     (let ((x 3))
 168       (let ((x 3))
 169         (declare (special x))
 170         (var-info x)))
 171   (:special nil nil))
 172
 173 (deftest variable-info.lexical
 174     (let ((x 8))
 175       (var-info x))
 176   (:lexical t nil))
 177
 178 (deftest variable-info.lexical.type
 179     (let ((x 42))
 180       (declare (fixnum x))
 181       (var-info x))
 182   (:lexical t ((type . fixnum))))
 183
 184 (deftest variable-info.lexical.type.2
 185     (let ((x 42))
 186       (prog1
 187           (var-info x)
 188         (locally (declare (fixnum x))
 189           (assert (plusp x)))))
 190   (:lexical t nil))
 191
 192 (deftest variable-info.lexical.type.3
 193     (let ((x 42))
 194       (locally (declare (fixnum x))
 195         (var-info x)))
 196   (:lexical t ((type . fixnum))))
 197
 198 (deftest variable-info.ignore
 199     (let ((x 8))
 200       (declare (ignore x))
 201       (var-info x))
 202   (:lexical t ((ignore . t))))
 203
 204 (deftest variable-info.symbol-macro/local
 205     (symbol-macrolet ((x 8))
 206       (var-info x))
 207   (:symbol-macro t nil))
 208
 209 (define-symbol-macro my-symbol-macro t)
 210
 211 (deftest variable-info.symbol-macro/global
 212     (var-info my-symbol-macro)
 213   (:symbol-macro nil nil))
 214
 215 (deftest variable-info.undefined
 216     (var-info #:undefined)
 217   (nil nil nil))
 218
 219 (declaim (global this-is-global))
 220 (deftest global-variable
 221     (var-info this-is-global)
 222   (:global nil nil))
 223
 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))))
 228
 229 (sb-alien:define-alien-variable "errno" sb-alien:int)
 230 (deftest alien-variable
 231     (var-info errno)
 232   (:alien nil nil))
 233
 234 ;;;; FUNCTION-INFORMATION
 235
 236 (defmacro fun-info (var &environment env)
 237   (list 'quote (multiple-value-list (function-information var env))))
 238
 239 (defun my-global-fun (x) x)
 240
 241 (deftest function-info.global/no-ftype
 242     (fun-info my-global-fun)
 243   (:function nil nil))
 244
 245 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
 246
 247 (defun my-global-fun-2 (x) x)
 248
 249 (deftest function-info.global/ftype
 250     (fun-info my-global-fun-2)
 251   (:function nil ((ftype function (cons) (values t &optional)))))
 252
 253 (defmacro my-macro (x) x)
 254
 255 (deftest function-info.macro
 256     (fun-info my-macro)
 257   (:macro nil nil))
 258
 259 (deftest function-info.macrolet
 260     (macrolet ((thingy () nil))
 261       (fun-info thingy))
 262   (:macro t nil))
 263
 264 (deftest function-info.special-form
 265     (fun-info progn)
 266   (:special-form  nil nil))
 267
 268 (deftest function-info.notinline/local
 269     (flet ((x (y) y))
 270       (declare (notinline x))
 271       (x 1)
 272       (fun-info x))
 273   (:function t ((inline . notinline))))
 274
 275 (declaim (notinline my-notinline))
 276 (defun my-notinline (x) x)
 277
 278 (deftest function-info.notinline/global
 279     (fun-info my-notinline)
 280   (:function nil ((inline . notinline))))
 281
 282 (declaim (inline my-inline))
 283 (defun my-inline (x) x)
 284
 285 (deftest function-info.inline/global
 286     (fun-info my-inline)
 287   (:function nil ((inline . inline))))
 288
 289 (deftest function-information.known-inline
 290     (locally (declare (inline identity))
 291       (fun-info identity))
 292   (:function nil ((inline . inline)
 293                   (ftype function (t) (values t &optional)))))
 294
 295 (deftest function-information.ftype
 296     (flet ((foo (x) x))
 297       (declare (ftype (sfunction (integer) integer) foo))
 298       (fun-info foo))
 299   (:function
 300    t
 301    ((ftype function (integer) (values integer &optional)))))
 302
 303 ;;;;; AUGMENT-ENVIRONMENT
 304
 305 (defmacro ct (form &environment env)
 306   (let ((toeval `(let ((lexenv (quote ,env)))
 307                    ,form)))
 308     `(quote ,(eval toeval))))
 309
 310
 311 (deftest augment-environment.variable1
 312     (multiple-value-bind (kind local alist)
 313         (variable-information
 314          'x
 315          (augment-environment nil :variable (list 'x) :declare '((type integer x))))
 316       (list kind local (cdr (assoc 'type alist))))
 317   (:lexical t integer))
 318
 319 (defvar *foo*)
 320
 321 (deftest augment-environment.variable2
 322     (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
 323   :lexical)
 324
 325 (deftest augment-environment.variable3
 326     (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
 327   :lexical)
 328
 329 (deftest augment-environment.variable.special1
 330     (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
 331   :special)
 332
 333 (deftest augment-environment.variable.special12
 334     (locally (declare (special x))
 335       (ct
 336        (variable-information
 337         'x
 338         (identity (augment-environment lexenv :variable '(x))))))
 339   :lexical)
 340
 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)))
 345   :lexical)
 346
 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))))
 350       (assoc 'ignore
 351              (nth 2 (multiple-value-list
 352                      (variable-information 'x e2)))))
 353   nil)
 354
 355 (deftest augment-environment.variable.ignore
 356     (variable-information
 357      'x
 358      (augment-environment nil
 359                           :variable '(x)
 360                           :declare  '((ignore x))))
 361   :lexical
 362   t
 363   ((ignore . t)))
 364
 365 (deftest augment-environment.function
 366     (function-information
 367      'foo
 368      (augment-environment nil
 369                           :function '(foo)
 370                           :declare  '((ftype (sfunction (integer) integer) foo))))
 371   :function
 372   t
 373   ((ftype function (integer) (values integer &optional))))
 374
 375
 376 (deftest augment-environment.macro
 377     (macroexpand '(mac feh)
 378                  (augment-environment
 379                   nil
 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))
 384   t)
 385
 386 (deftest augment-environment.symbol-macro
 387     (macroexpand 'sym
 388                  (augment-environment
 389                   nil
 390                   :symbol-macro (list (list 'sym '(foo bar baz)))))
 391   (foo bar baz)
 392   t)
 393
 394 (deftest augment-environment.macro2
 395     (eval (macroexpand '(newcond
 396                          ((= 1 2) 'foo)
 397                          ((= 1 1) 'bar))
 398                        (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
 399   bar)
 400
 401
 402 (deftest augment-environment.nest
 403     (let ((x 1))
 404       (ct
 405        (let* ((e (augment-environment lexenv :variable '(y))))
 406          (list
 407           (variable-information 'x e)
 408           (variable-information 'y e)))))
 409   (:lexical :lexical))
 410
 411 (deftest augment-environment.nest2
 412     (symbol-macrolet ((x "x"))
 413       (ct
 414        (let* ((e (augment-environment lexenv :variable '(y))))
 415          (list
 416           (macroexpand 'x e)
 417           (variable-information 'y e)))))
 418   ("x" :lexical))
 419
 420 (deftest augment-environment.symbol-macro-var
 421     (let ((e (augment-environment
 422               nil
 423               :symbol-macro (list (list 'sym '(foo bar baz)))
 424               :variable '(x))))
 425       (list (macroexpand 'sym e)
 426             (variable-information 'x e)))
 427   ((foo bar baz)
 428    :lexical))
 429
 430
 431
 432 ;;;;; DEFINE-DECLARATION
 433
 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))
 438        ,c)))
 439
 440 (deftest define-declaration.declare
 441     (progn
 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)))))
 448   (zaphod and ford))
 449
 450
 451 (deftest define-declaration.declare2
 452     (progn
 453       (define-declaration zaphod (spec env)
 454         (declare (ignore env))
 455         (values :declare (cons 'zaphod spec)))
 456       (locally
 457            (declare (zaphod beblebrox)
 458                     (special x))
 459          (ct (declaration-information 'zaphod lexenv))))
 460   (zaphod beblebrox))
 461
 462 (deftest define-declaration.variable
 463     (progn
 464       (define-declaration vogon (spec env)
 465         (declare (ignore env))
 466         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 467       (locally (declare (vogon poetry))
 468         (ct
 469          (assoc 'vogon-key
 470                 (third-value
 471                  (variable-information
 472                   'poetry
 473                   lexenv))))))
 474   (vogon-key . vogon-value))
 475
 476
 477 (deftest define-declaration.variable.special
 478     (progn
 479       (define-declaration vogon (spec env)
 480         (declare (ignore env))
 481         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 482       (let (x)
 483         (declare (vogon x))
 484         (declare (special x))
 485         (ct
 486          (assoc 'vogon-key
 487                 (third-value
 488                  (variable-information 'x lexenv))))))
 489   (vogon-key . vogon-value))
 490
 491 (deftest define-declaration.variable.special2
 492     (progn
 493       (define-declaration vogon (spec env)
 494         (declare (ignore env))
 495         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 496       (let (x)
 497         (declare (special x))
 498         (declare (vogon x))
 499         (ct
 500          (assoc 'vogon-key
 501                 (third-value
 502                  (variable-information 'x lexenv))))))
 503   (vogon-key . vogon-value))
 504
 505 (deftest define-declaration.variable.mask
 506     (progn
 507       (define-declaration vogon (spec env)
 508         (declare (ignore env))
 509         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 510       (let (x)
 511         (declare (vogon x))
 512         (let (x)
 513           (ct
 514            (assoc
 515             'vogon-key
 516             (third (multiple-value-list (variable-information 'x lexenv))))))))
 517   nil)
 518
 519 (deftest define-declaration.variable.macromask
 520     (progn
 521       (define-declaration vogon (spec env)
 522         (declare (ignore env))
 523         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 524       (let (x)
 525         (declare (vogon x))
 526         (symbol-macrolet ((x 42))
 527           (ct
 528            (assoc
 529             'vogon-key
 530             (third (multiple-value-list (variable-information 'x lexenv))))))))
 531   nil)
 532
 533 (deftest define-declaration.variable.macromask2
 534     (progn
 535       (define-declaration vogon (spec env)
 536         (declare (ignore env))
 537         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 538       (symbol-macrolet ((x 42))
 539         (declare (vogon x))
 540         (list
 541          (let (x)
 542            (ct
 543             (assoc
 544              'vogon-key
 545              (third (multiple-value-list (variable-information 'x lexenv))))))
 546          (ct
 547           (assoc
 548            'vogon-key
 549            (third (multiple-value-list (variable-information 'x lexenv))))))))
 550   (nil (vogon-key . vogon-value)))
 551
 552 (deftest define-declaration.variable.mask2
 553     (progn
 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))))
 560       (let (x)
 561         (declare (vogon-a x))
 562         (let (x)
 563           (declare (vogon-b x)))
 564         (ct
 565          (assoc
 566           'vogon-key
 567           (third (multiple-value-list (variable-information 'x lexenv)))))))
 568   (vogon-key . a))
 569
 570 (deftest define-declaration.variable.specialmask
 571     (progn
 572       (define-declaration vogon (spec env)
 573         (declare (ignore env))
 574         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 575       (locally
 576           (declare (vogon *foo*))
 577         (let (*foo*)
 578           (ct
 579            (assoc
 580             'vogon-key
 581             (third (multiple-value-list (variable-information '*foo* lexenv))))))))
 582   (vogon-key . vogon-value))
 583
 584
 585
 586 (deftest define-declaration.function
 587     (progn
 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))
 593           (ct
 594            (assoc 'emotional-state
 595                   (third-value (function-information
 596                                 'robot
 597                                 lexenv)))))))
 598   (emotional-state . sad))
 599
 600 (deftest define-declaration.function.lexical
 601     (progn
 602       (define-declaration sad (spec env)
 603         (declare (ignore env))
 604         (values :function `((,(cadr spec) emotional-state sad))))
 605       (flet ((robot nil))
 606         (locally (declare (sad robot))
 607           (ct
 608            (assoc 'emotional-state
 609                   (third-value (function-information
 610                                 'robot
 611                                 lexenv)))))))
 612   (emotional-state . sad))
 613
 614
 615 (deftest define-declaration.function.lexical2
 616     (progn
 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))
 622         (ct
 623          (assoc 'emotional-state
 624                 (third-value (function-information
 625                               'robot
 626                               lexenv))))))
 627   (emotional-state . sad))
 628
 629 (deftest define-declaration.function.mask
 630     (progn
 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))
 637           (ct
 638            (assoc 'emotional-state
 639                   (third-value (function-information
 640                                 'robot
 641                                 lexenv)))))))
 642   nil)
 643
 644
 645 (deftest define-declaration.function.mask2
 646     (progn
 647       (define-declaration sad (spec env)
 648         (declare (ignore env))
 649         (values :function `((,(cadr spec) emotional-state sad))))
 650       (locally
 651           (declare (sad robot))
 652         (labels ((robot nil))
 653           (ct
 654            (assoc 'emotional-state
 655                   (third-value (function-information
 656                                 'robot
 657                                 lexenv)))))))
 658   nil)
 659
 660 (deftest define-declaration.function2
 661     (progn
 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))
 668             (ct
 669              (assoc 'emotional-state
 670                     (third-value (function-information
 671                                   'robot
 672                                   lexenv))))))))
 673   (emotional-state . happy))