+;;;; tests for compiler output
+(let* ((*error-output* (make-broadcast-stream))
+ (output (with-output-to-string (*standard-output*)
+ (compile-file "compiler-output-test.lisp"
+ :print nil :verbose nil))))
+ (print output)
+ (assert (zerop (length output))))
+
+;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
+
+(define-condition optimization-error (error) ())
+
+(labels ((compile-lambda (type sense)
+ (handler-bind ((compiler-note (lambda (_)
+ (declare (ignore _))
+ (error 'optimization-error))))
+ (values
+ (compile
+ nil
+ `(lambda ()
+ (declare
+ ,@(when type '((ftype (function () (integer 0 10)) bug-305)))
+ (,sense bug-305)
+ (optimize speed))
+ (1+ (bug-305))))
+ nil)))
+ (expect-error (sense)
+ (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense))
+ (assert (not f))
+ (assert (typep e 'optimization-error))))
+ (expect-pass (sense)
+ (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense))
+ (assert f)
+ (assert (not e)))))
+ (expect-error 'inline)
+ (expect-error 'notinline)
+ (expect-pass 'inline)
+ (expect-pass 'notinline))
+
+;;; bug 211e: bogus style warning from duplicated keyword argument to
+;;; a local function.
+(handler-bind ((style-warning #'error))
+ (let ((f (compile nil '(lambda ()
+ (flet ((foo (&key y) (list y)))
+ (list (foo :y 1 :y 2)))))))
+ (assert (equal '((1)) (funcall f)))))
+
+;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM).
+(handler-bind ((compiler-note #'error))
+ (let ((f1 (compile nil '(lambda (x1 y1)
+ (declare (type (or symbol fixnum) x1)
+ (optimize speed))
+ (eql x1 y1))))
+ (f2 (compile nil '(lambda (x2 y2)
+ (declare (type (or symbol fixnum) y2)
+ (optimize speed))
+ (eql x2 y2)))))
+ (let ((fix (random most-positive-fixnum))
+ (sym (gensym))
+ (e-count 0))
+ (assert (funcall f1 fix fix))
+ (assert (funcall f2 fix fix))
+ (assert (funcall f1 sym sym))
+ (assert (funcall f2 sym sym))
+ (handler-bind ((type-error (lambda (c)
+ (incf e-count)
+ (continue c))))
+ (flet ((test (f x y)
+ (with-simple-restart (continue "continue with next test")
+ (funcall f x y)
+ (error "fell through with (~S ~S ~S)" f x y))))
+ (test f1 "oops" 42)
+ (test f1 (1+ most-positive-fixnum) 42)
+ (test f2 42 "oops")
+ (test f2 42 (1+ most-positive-fixnum))))
+ (assert (= e-count 4)))))
+
+;;; bug #389 (Rick Taube sbcl-devel)
+(defun bes-jn (unn ux)
+ (let ((nn unn) (x ux))
+ (let* ((n (floor (abs nn)))
+ (besn
+ (if (= n 0)
+ (bes-j0 x)
+ (if (= n 1)
+ (bes-j1 x)
+ (if (zerop x)
+ 0.0
+ (let ((iacc 40)
+ (ans 0.0)
+ (bigno 1.0e+10)
+ (bigni 1.0e-10))
+ (if (> (abs x) n)
+ (do ((tox (/ 2.0 (abs x)))
+ (bjm (bes-j0 (abs x)))
+ (bj (bes-j1 (abs x)))
+ (j 1 (+ j 1))
+ (bjp 0.0))
+ ((= j n) (setf ans bj))
+ (setf bjp (- (* j tox bj) bjm))
+ (setf bjm bj)
+ (setf bj bjp))
+ (let ((tox (/ 2.0 (abs x)))
+ (m
+ (* 2
+ (floor
+ (/ (+ n (sqrt (* iacc n)))
+ 2))))
+ (jsum 0.0)
+ (bjm 0.0)
+ (sum 0.0)
+ (bjp 0.0)
+ (bj 1.0))
+ (do ((j m (- j 1)))
+ ((= j 0))
+ (setf bjm (- (* j tox bj) bjp))
+ (setf bjp bj)
+ (setf bj bjm)
+ (when (> (abs bj) bigno)
+ (setf bj (* bj bigni))
+ (setf bjp (* bjp bigni))
+ (setf ans (* ans bigni))
+ (setf sum (* sum bigni)))
+ (if (not (= 0 jsum)) (incf sum bj))
+ (setf jsum (- 1 jsum))
+ (if (= j n) (setf ans bjp)))
+ (setf sum (- (* 2.0 sum) bj))
+ (setf ans (/ ans sum))))
+ (if (and (minusp x) (oddp n))
+ (- ans)
+ ans)))))))
+ (if (and (minusp nn) (oddp nn)) (- besn) besn))))
+