0.pre7.14:
[sbcl.git] / tests / compiler.pure.lisp
1 ;;;; various compiler tests without side-effects
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 (cl:in-package :cl-user)
15
16 ;;; Exercise a compiler bug (by crashing the compiler).
17 ;;;
18 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
19 ;;; (2000-09-06 on cmucl-imp).
20 ;;;
21 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
22 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
23 (funcall (compile nil
24                   '(lambda ()
25                      (labels ((fun1 ()
26                                 (fun2))
27                               (fun2 ()
28                                 (when nil
29                                   (tagbody
30                                    tag
31                                    (fun2)
32                                    (go tag)))
33                                 (when nil
34                                   (tagbody
35                                    tag
36                                    (fun1)
37                                    (go tag)))))
38
39                        (fun1)
40                        nil))))
41
42 ;;; Exercise a compiler bug (by crashing the compiler).
43 ;;;
44 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on 
45 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
46 (funcall (compile nil
47                   '(lambda (x)
48                      (or (integerp x)
49                          (block used-by-some-y?
50                            (flet ((frob (stk)
51                                     (dolist (y stk)
52                                       (unless (rejected? y)
53                                         (return-from used-by-some-y? t)))))
54                              (declare (inline frob))
55                              (frob (rstk x))
56                              (frob (mrstk x)))
57                            nil))))
58          13)