0.7.7.5:
[sbcl.git] / tests / clos.test.sh
1 #!/bin/sh
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 # Check that compiling and loading the file $1 generates an error
15 # at load time; also that just loading it directly (into the
16 # interpreter) generates an error.
17 expect_load_error ()
18 {
19     # Test compiling and loading.
20     $SBCL <<EOF
21         (compile-file "$1")
22         ;;; But loading the file should fail.
23         (multiple-value-bind (value0 value1) (ignore-errors (load *))
24             (assert (null value0))
25             (format t "VALUE1=~S (~A)~%" value1 value1)
26             (assert (typep value1 'error)))
27         (sb-ext:quit :unix-status 52)
28 EOF
29     if [ $? != 52 ]; then
30         echo compile-and-load $1 test failed: $?
31         exit 1
32     fi
33
34     # Test loading into the interpreter.
35     $SBCL <<EOF
36         (multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
37             (assert (null value0))
38             (format t "VALUE1=~S (~A)~%" value1 value1)
39             (assert (typep value1 'error)))
40         (sb-ext:quit :unix-status 52)
41 EOF
42     if [ $? != 52 ]; then
43         echo load-into-interpreter $1 test failed: $?
44         exit 1
45     fi
46 }
47
48 # Test that a file compiles cleanly, with no ERRORs, WARNINGs or
49 # STYLE-WARNINGs.
50 #
51 # Maybe this wants to be in a compiler.test.sh script?  This function
52 # was originally written to test APD's patch for slot readers and
53 # writers not being known to the compiler. -- CSR, 2002-08-14
54 expect_clean_compile () 
55 {
56     $SBCL <<EOF
57         (multiple-value-bind (pathname warnings-p failure-p)
58             (compile-file "$1")
59           (declare (ignore pathname))
60           (assert (not warnings-p))
61           (assert (not failure-p))
62           (sb-ext:quit :unix-status 52))
63 EOF
64     if [ $? != 52 ]; then
65         echo clean-compile $1 test failed: $?
66         exit 1
67     fi
68 }
69
70 base_tmpfilename="clos-test-$$-tmp"
71 tmpfilename="$base_tmpfilename.lisp"
72 compiled_tmpfilename="$base_tmpfilename.fasl"
73
74 # This should fail, but didn't until sbcl-0.6.12.7, with Martin
75 # Atzmueller's port of Pierre Mai's fixes.
76 cat > $tmpfilename <<EOF
77     (in-package :cl-user)
78     ;; This definition has too many qualifiers, so loading the
79     ;; DEFMETHOD should fail.
80     (defmethod zut progn :around ((x integer)) (print "integer"))
81 EOF
82 expect_load_error $tmpfilename
83
84 # Even before sbcl-0.6.12.7, this would fail as it should. Let's
85 # make sure that it still does.
86 cat > $tmpfilename <<EOF
87     (in-package :cl-user)
88     (defgeneric zut (x) (:method-combination progn))
89     ;; This definition is missing the PROGN qualifier, and so the
90     ;; DEFMETHOD should fail.
91     (defmethod zut ((x integer)) (print "integer"))
92 EOF
93 expect_load_error $tmpfilename
94
95 # Even before sbcl-0.6.12.7, this would fail as it should, but Martin
96 # Atzmueller's port of Pierre Mai's fixes caused it to generate more
97 # correct text in the error message. We can't check that in a regression
98 # test until AI gets a mite stronger, but at least we can check that
99 # the problem is still detected.
100 cat > $tmpfilename <<EOF
101     (in-package :cl-user)
102     (defgeneric zut (x) (:method-combination progn))
103     ;; This definition has too many qualifiers, so loading the
104     ;; DEFMETHOD should fail.
105     (defmethod zut progn :around ((x integer)) (print "integer"))
106 EOF
107 expect_load_error $tmpfilename
108
109 # Until sbcl-0.7.6.21, PCL signalled spurious STYLE-WARNINGs on
110 # compilation of this form; the report (bug #191a.) and a patch
111 # suppressing these were provided by Alexey Dejenka in quick
112 # succession.
113 cat > $tmpfilename <<EOF
114     (in-package :cl-user)
115     (defclass another-class-with-slots () 
116       (a-new-slot-name))
117     (defun foo (x)
118       (values (setf (slot-value x 'a-new-slot-name) 2)
119               (slot-value x 'a-new-slot-name)))
120 EOF
121 expect_clean_compile $tmpfilename
122
123 rm $tmpfilename
124 rm $compiled_tmpfilename
125
126 # success 
127 exit 104