/[gcl]/gcl/ansi-tests/beyond-ansi/errors-eval-compile.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/beyond-ansi/errors-eval-compile.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sat May 28 20:38:46 2005 UTC revision 1.2 by pfdietz, Sun May 29 16:40:47 2005 UTC
# Line 5  Line 5 
5    
6  (in-package :ba-test)  (in-package :ba-test)
7    
 ;;; Tests of COMPILE  
   
8  (declaim (notinline compile-fails?))  (declaim (notinline compile-fails?))
9    
10    ;;; Utility functions
11    
12  (defun compile-fails? (&rest args)  (defun compile-fails? (&rest args)
13    (cl:handler-case    (cl:handler-case
14     (let ((vals (multiple-value-list (apply #'compile args))))     (let ((vals (multiple-value-list (apply #'compile args))))
# Line 26  Line 27 
27             (symbolp (cadr x))             (symbolp (cadr x))
28             (null (cddr x)))))             (null (cddr x)))))
29    
30    (defun symbol-or-function-p (x)
31      (or (symbolp x)
32          (and (consp x)
33               (eql (car x) 'function)
34               (consp (cdr x))
35               (null (cddr x))
36               (function-name-p (cadr x)))))
37    
38    ;;; Tests of COMPILE
39    
40  (deftest compile.1  (deftest compile.1
41    (loop for x in *mini-universe*    (loop for x in *mini-universe*
42          unless (or (function-name-p x)          unless (or (function-name-p x)
# Line 192  Line 203 
203    
204  (deftest ignore.1  (deftest ignore.1
205    (loop for x in *mini-universe*    (loop for x in *mini-universe*
206          unless (or (symbolp x)          unless (or (symbol-or-function-p x)
                    (and (consp x)  
                         (eql (car x) 'function)  
                         (consp (cdr x))  
                         (symbolp (cadr x))  
                         (null (cddr x)))  
207                     (eval `(signals-error (locally (declare (ignore ,x)) nil)                     (eval `(signals-error (locally (declare (ignore ,x)) nil)
208                                           error)))                                           error)))
209          collect x)          collect x)
# Line 211  Line 217 
217    
218  (deftest ignorable.1  (deftest ignorable.1
219    (loop for x in *mini-universe*    (loop for x in *mini-universe*
220          unless (or (symbolp x)          unless (or (symbol-or-function-p x)
221                     (and (consp x)                     (eval `(signals-error
222                          (eql (car x) 'function)                             (locally (declare (ignorable ,x)) nil)
223                          (consp (cdr x))                             error)))
                         (symbolp (cadr x))  
                         (null (cddr x)))  
                    (eval `(signals-error (locally (declare (ignorable ,x)) nil)  
                                          error)))  
224          collect x)          collect x)
225    nil)    nil)
226    
# Line 230  Line 232 
232    
233  (deftest dynamic-extent.1  (deftest dynamic-extent.1
234    (loop for x in *mini-universe*    (loop for x in *mini-universe*
235          unless (or (symbolp x)          unless (or (symbol-or-function-p x)
236                     (and (consp x)                     (eval `(signals-error
237                          (eql (car x) 'function)                             (locally (declare (dynamic-extent ,x)) nil)
238                          (consp (cdr x))                             error)))
                         (symbolp (cadr x))  
                         (null (cddr x)))  
                    (eval `(signals-error (locally (declare (dynamic-extent ,x)) nil)  
                                          error)))  
239          collect x)          collect x)
240    nil)    nil)
241    
242  (deftest dynamic-extent.2  (deftest dynamic-extent.2
243    (signals-error (locally (declare (dynamic-extent . foo)) nil) error)    (signals-error (locally (declare (dynamic-extent . foo)) nil) error)
   t)  
244      t)
245    
246    ;;; TYPE declarations
247    ;;; Test that violation of the type declarations is detected, and
248    ;;; leads to an error in safe code.
249    
250    (deftest type.1
251      (loop for x in *mini-universe*
252            for tp = (type-of x)
253            for lambda-form = `(lambda (y) (declare (optimize safety)
254                                                    (type (not ,tp) y)) y)
255            for fn = (progn (print lambda-form)
256                            (eval `(function ,lambda-form)))
257            unless (eval `(signals-error (funcall ',fn ',x) error))
258            collect x)
259      nil)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26