tests/dynamic-extent.impure.lisp

   1 ;;;; tests that dynamic-extent functionality works.
   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 (setq sb-c::*check-consistency* t)
  15
  16 (defmacro defun-with-dx (name arglist &body body)
  17   `(locally
  18      (declare (optimize sb-c::stack-allocate-dynamic-extent))
  19      (defun ,name ,arglist
  20        ,@body)))
  21
  22 (declaim (notinline opaque-identity))
  23 (defun opaque-identity (x)
  24   x)
  25
  26 ;;; &REST lists
  27 (defun-with-dx dxlength (&rest rest)
  28   (declare (dynamic-extent rest))
  29   (length rest))
  30
  31 (assert (= (dxlength 1 2 3) 3))
  32 (assert (= (dxlength t t t t t t) 6))
  33 (assert (= (dxlength) 0))
  34
  35 (defun callee (list)
  36   (destructuring-bind (a b c d e f &rest g) list
  37     (+ a b c d e f (length g))))
  38
  39 (defun-with-dx dxcaller (&rest rest)
  40   (declare (dynamic-extent rest))
  41   (callee rest))
  42
  43 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
  44
  45 ;;; %NIP-VALUES
  46 (defun-with-dx test-nip-values ()
  47   (flet ((bar (x &rest y)
  48            (declare (dynamic-extent y))
  49            (if (> x 0)
  50                (values x (length y))
  51                (values (car y)))))
  52     (multiple-value-call #'values
  53       (bar 1 2 3 4 5 6)
  54       (bar -1 'a 'b))))
  55
  56 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
  57
  58 ;;; LET-variable substitution
  59 (defun-with-dx test-let-var-subst1 (x)
  60   (let ((y (list x (1- x))))
  61     (opaque-identity :foo)
  62     (let ((z (the list y)))
  63       (declare (dynamic-extent z))
  64       (length z))))
  65 (assert (eql (test-let-var-subst1 17) 2))
  66
  67 (defun-with-dx test-let-var-subst2 (x)
  68   (let ((y (list x (1- x))))
  69     (declare (dynamic-extent y))
  70     (opaque-identity :foo)
  71     (let ((z (the list y)))
  72       (length z))))
  73 (assert (eql (test-let-var-subst2 17) 2))
  74
  75 ;;; DX propagation through LET-return.
  76 (defun-with-dx test-lvar-subst (x)
  77   (let ((y (list x (1- x))))
  78     (declare (dynamic-extent y))
  79     (second (let ((z (the list y)))
  80               (opaque-identity :foo)
  81               z))))
  82 (assert (eql (test-lvar-subst 11) 10))
  83
  84 ;;; this code is incorrect, but the compiler should not fail
  85 (defun-with-dx test-let-var-subst-incorrect (x)
  86   (let ((y (list x (1- x))))
  87     (opaque-identity :foo)
  88     (let ((z (the list y)))
  89       (declare (dynamic-extent z))
  90       (opaque-identity :bar)
  91       z)))
  92 \f
  93 (defmacro assert-no-consing (form &optional times)
  94   `(%assert-no-consing (lambda () ,form ,times)))
  95 (defun %assert-no-consing (thunk &optional times)
  96   (let ((before (get-bytes-consed))
  97         (times (or times 10000)))
  98     (declare (type (integer 1 *) times))
  99     (dotimes (i times)
 100       (funcall thunk))
 101     (assert (< (- (get-bytes-consed) before) times))))
 102
 103 #+x86
 104 (progn
 105   (assert-no-consing (dxlength 1 2 3))
 106   (assert-no-consing (dxlength t t t t t t))
 107   (assert-no-consing (dxlength))
 108   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 109   (assert-no-consing (test-nip-values))
 110   (assert-no-consing (test-let-var-subst1 17))
 111   (assert-no-consing (test-let-var-subst2 17))
 112   (assert-no-consing (test-lvar-subst 11))
 113   )
 114
 115 \f
 116 ;;; Bugs found by Paul F. Dietz
 117 (assert
 118  (eq
 119   (funcall
 120    (compile
 121     nil
 122     '(lambda (a b)
 123       (declare (optimize (speed 2) (space 0) (safety 0)
 124                 (debug 1) (compilation-speed 3)))
 125       (let* ((v5 (cons b b)))
 126         (declare (dynamic-extent v5))
 127         a)))
 128    'x 'y)
 129   'x))
 130
 131 \f
 132 ;;; other bugs
 133
 134 ;;; bug reported by Svein Ove Aas
 135 (defun svein-2005-ii-07 (x y)
 136   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 137   (let ((args (list* y 1 2 x)))
 138     (declare (dynamic-extent args))
 139     (apply #'aref args)))
 140 (assert (eql
 141          (svein-2005-ii-07
 142           '(0)
 143           #3A(((1 1 1) (1 1 1) (1 1 1))
 144               ((1 1 1) (1 1 1) (4 1 1))
 145               ((1 1 1) (1 1 1) (1 1 1))))
 146          4))
 147
 148 \f
 149 (sb-ext:quit :unix-status 104)