0.9.10.3: Faster function calls via constant symbols

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 26a5b3a..5fd8828 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1157,7 +1157,7 @@
                            c
                            0)))))
 
-;; Put this in a separate function.
+;;; Put this in a separate function.
 (defun test-constraint-propagation/cast (x)
   (when (the double-float (multiple-value-prog1
                               x
@@ -1168,4 +1168,65 @@
   (assert (assertoid:raises-error?
            (test-constraint-propagation/cast 1) type-error)))
 
+;;; bug #399
+(let ((result (make-array 50000 :fill-pointer 0 :adjustable t)))
+  (defun string->html (string &optional (max-length nil))
+    (when (and (numberp max-length)
+               (> max-length (array-dimension result 0)))
+      (setf result (make-array max-length :fill-pointer 0 :adjustable t)))
+    (let ((index 0)
+          (left-quote? t))
+      (labels ((add-char (it)
+                 (setf (aref result index) it)
+                 (incf index))
+               (add-string (it)
+                 (loop for ch across it do
+                       (add-char ch))))
+        (loop for char across string do
+              (cond ((char= char #\<)
+                     (add-string "&lt;"))
+                    ((char= char #\>)
+                     (add-string "&gt;"))
+                    ((char= char #\&)
+                     (add-string "&amp;"))
+                    ((char= char #\')
+                     (add-string "&#39;"))
+                    ((char= char #\newline)
+                     (add-string "<br>"))
+                    ((char= char #\")
+                     (if left-quote? (add-string "&#147;") (add-string "&#148;"))
+                     (setf left-quote? (not left-quote?)))
+                    (t
+                     (add-char char))))
+        (setf (fill-pointer result) index)
+        (coerce result 'string)))))
+
+;;; Callign thru constant symbols
+(require :sb-introspect)
+
+(declaim (inline target-fun))
+(defun target-fun (arg0 arg1)
+  (+ arg0 arg1))
+(declaim (notinline target-fun))
+
+(defun test-target-fun-called (fun res)
+  (assert (member #'target-fun
+                  (sb-introspect:find-function-callees #'caller-fun-1)))
+  (assert (equal (funcall fun) res)))
+
+(defun caller-fun-1 ()
+  (funcall 'target-fun 1 2))
+(test-target-fun-called #'caller-fun-1 3)
+
+(defun caller-fun-2 ()
+  (declare (inline target-fun))
+  (apply 'target-fun 1 '(3)))
+(test-target-fun-called #'caller-fun-2 4)
+
+(defun caller-fun-3 ()
+  (flet ((target-fun (a b)
+           (- a b)))
+    (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
+(test-target-fun-called #'caller-fun-3 (list -3 5))
+
 ;;; success