tests/fopcompiler.impure-cload.lisp

   1 ;;;; tests of the fop compiler
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  14 (in-package "CL-USER")
  15
  16 ;; Can't use normal ASSERT, since it is not fopcompilable...
  17 (defun assert* (value)
  18   (unless value
  19     (error "assert failed")))
  20
  21 ;;; Test that the forms that are supposed to be fopcompilable are, and
  22 ;;; the ones that aren't aren't. The body might contain further tests to
  23 ;;; ensure that the fopcompiled code works as intended.
  24 (defmacro fopcompile-test (fopcompilable-p &body body)
  25   (assert (eql (sb-c::fopcompilable-p `(progn ,@body))
  26                fopcompilable-p))
  27   `(progn ,@body))
  28
  29 (fopcompile-test t
  30  (let ((a 1))
  31    (assert* (eql a 1))))
  32
  33 (fopcompile-test t
  34  (let ((a 3))
  35    (let ((a 4))
  36      (assert* (eql a 4)))))
  37
  38 (fopcompile-test t
  39  (let* ((a 5))
  40    (let* ((a 6))
  41      (assert* (eql a 6)))))
  42
  43 (fopcompile-test nil
  44  (let ((a 7))
  45    (assert* (eql (funcall (lambda () a)) 7))))
  46
  47 (fopcompile-test nil
  48   (let* ((a 8))
  49     (assert* (eql (funcall (lambda () a)) 8))))
  50
  51 (fopcompile-test t
  52   (let ((a 8)
  53         (b (lambda () 1)))
  54     nil))
  55
  56 (fopcompile-test t
  57   (let* ((a (lambda () 1)))
  58     nil))
  59
  60 (fopcompile-test nil
  61   (let* ((a 8)
  62          (b (lambda () 1)))
  63     nil))
  64
  65 (fopcompile-test nil
  66   (let* ((a 9)
  67          (b (funcall (lambda () a))))
  68     (assert* (eql b 9))))
  69
  70 (fopcompile-test t
  71   (let ((a 10))
  72     (let ((a 11)
  73           (b a))
  74       (assert* (eql b 10)))))
  75
  76 (fopcompile-test t
  77   (let ((a 12))
  78     (let* ((a 13)
  79            (b a))
  80       (assert* (eql b 13)))))
  81
  82 (setf (symbol-value 'fopcompile-test-foo) 1)
  83 (assert* (eql fopcompile-test-foo 1))
  84
  85 ;;; Ensure that we're passing sensible environments to macros during
  86 ;;; fopcompilation. Reported by Samium Gromoff.
  87
  88 (defmacro bar (vars &environment env)
  89   (assert (equal vars
  90                  (mapcar #'car (sb-c::lexenv-vars env)))))
  91
  92 (symbol-macrolet ((foo 1))
  93   (let* ((x (bar (foo)))
  94          (y (bar (x foo))))
  95     (bar (y x foo))))
  96
  97 ;;; Some tests involving compiler-macros.
  98
  99 (defvar *cmacro-result* nil)
 100
 101 (defun baz (x) (declare (ignore x)))
 102
 103 ;; functional foo - a function with a compiler-macro
 104 (defun ffoo (x) (push `(regular-ffoo ,x) *cmacro-result*))
 105 (define-compiler-macro ffoo (x)
 106   `(push `(cmacro-ffoo ,,x) *cmacro-result*))
 107
 108 ;; macro foo - a macro with a compiler-macro
 109 (defmacro mfoo (x) `(push `(regular-mfoo ,,x) *cmacro-result*))
 110 (define-compiler-macro mfoo (x)
 111   `(push `(cmacro-mfoo ,,x) *cmacro-result*))
 112
 113 (defun get-s () (declare (special s)) s)
 114
 115 ;; Verify some assumptions that the tests will test what was intended.
 116 (eval-when (:compile-toplevel)
 117   (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv)))
 118     (assert (sb-c::fopcompilable-p '(baz (ffoo 3))))
 119     (assert (sb-c::fopcompilable-p '(baz (mfoo 3))))
 120     ;; The special binding of S makes these forms not fopcompilable.
 121     (assert (not (sb-c::fopcompilable-p
 122                   '(ffoo (let ((s 3)) (declare (special s)) (get-s))))))
 123     (assert (not (sb-c::fopcompilable-p
 124                   '(mfoo (let ((s 3)) (declare (special s)) (get-s))))))))
 125
 126 ;; fopcompilable toplevel form should execute the compiler macro
 127 (ffoo 1)
 128 (mfoo 1)
 129 ;; fopcompilable form expands embedded compiler-macro
 130 (baz (ffoo 2))
 131 (baz (mfoo 2))
 132 ;; not-fopcompilable toplevel form should execute the compiler macro.
 133 ;; This was ok if the toplevel call was a function with a compiler-macro,
 134 ;; but was not working for a toplevel macro having a compiler-macro.
 135 (ffoo (let ((s 3)) (declare (special s)) (get-s)))
 136 (mfoo (let ((s 3)) (declare (special s)) (get-s)))
 137
 138 (with-test (:name :compiler-macros-at-toplevel)
 139   ;; Now assert about the macroexpansions that happened.
 140   (assert (equal *cmacro-result*
 141                  '((CMACRO-MFOO 3) (CMACRO-FFOO 3)
 142                    (CMACRO-MFOO 2) (CMACRO-FFOO 2)
 143                    (CMACRO-MFOO 1) (CMACRO-FFOO 1)))))