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