test-suite/tests/exceptions.test

   1 ;;;; exceptions.test                                            -*- scheme -*-
   2 ;;;; Copyright (C) 2001 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This program is free software; you can redistribute it and/or modify
   5 ;;;; it under the terms of the GNU General Public License as published by
   6 ;;;; the Free Software Foundation; either version 2, or (at your option)
   7 ;;;; any later version.
   8 ;;;;
   9 ;;;; This program is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;;; GNU General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU General Public License
  15 ;;;; along with this software; see the file COPYING.  If not, write to
  16 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17 ;;;; Boston, MA 02111-1307 USA
  18 ;;;;
  19 ;;;; As a special exception, the Free Software Foundation gives permission
  20 ;;;; for additional uses of the text contained in its release of GUILE.
  21 ;;;;
  22 ;;;; The exception is that, if you link the GUILE library with other files
  23 ;;;; to produce an executable, this does not by itself cause the
  24 ;;;; resulting executable to be covered by the GNU General Public License.
  25 ;;;; Your use of that executable is in no way restricted on account of
  26 ;;;; linking the GUILE library code into it.
  27 ;;;;
  28 ;;;; This exception does not however invalidate any other reasons why
  29 ;;;; the executable file might be covered by the GNU General Public License.
  30 ;;;;
  31 ;;;; This exception applies only to the code released by the
  32 ;;;; Free Software Foundation under the name GUILE.  If you copy
  33 ;;;; code from other Free Software Foundation releases into a copy of
  34 ;;;; GUILE, as the General Public License permits, the exception does
  35 ;;;; not apply to the code that you add in this way.  To avoid misleading
  36 ;;;; anyone as to the status of such modified files, you must delete
  37 ;;;; this exception notice from them.
  38 ;;;;
  39 ;;;; If you write modifications of your own for GUILE, it is your choice
  40 ;;;; whether to permit this exception to apply to your modifications.
  41 ;;;; If you do not wish that, delete this exception notice.
  42
  43 ;;;; Commentary:
  44
  45 ;;; All tests should use `expect-exception' (aliased to `goad' for
  46 ;;; brevity).  Tests that fail (i.e., do NOT cause exception should be
  47 ;;; marked with a preceding line "no exception on DATE", where DATE is
  48 ;;; when you found the failure.  If guile is fixed so that the test
  49 ;;; passes, do not delete the comment, but instead append "fixed on
  50 ;;; DATE" w/ the fix date.  If the test itself changes (due to a change
  51 ;;; in the specification, for example), append "test amended on DATE"
  52 ;;; and some explanatory text.  You can delete comments (and move the
  53 ;;; test up into the clump of uncommented tests) when the dates become
  54 ;;; very old.
  55 ;;;
  56 ;;; By convention, test-prefix strings have no whitespace.  This makes
  57 ;;; change log entries more regular.
  58
  59 ;;;; Code:
  60
  61 (use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list))
  62
  63 (defmacro expect-exception (name-snippet expression)
  64   `(pass-if (with-output-to-string
  65               (lambda ()
  66                 (for-each display
  67                           (list
  68                            "`"
  69                            (let ((x (symbol->string ',name-snippet)))
  70                              (substring x 2 (string-length x)))
  71                            "' expected: "))
  72                 (write ',expression)))
  73             (catch #t
  74                    (lambda () ,expression #f) ; conniving falsehood!
  75                    (lambda args
  76                      ;; squeeze value to `#t'
  77                      (not (notany (lambda (x)
  78                                     (and (string? x)
  79                                          (string-match ,name-snippet x)))
  80                                   args))))))
  81
  82 (define goad expect-exception)
  83
  84 ;; Exception messages
  85 ;; Ideally, we would mine these out of libguile/error.[hc], etc.
  86 ;; (Someday, when guile is re-implemented in Scheme....)
  87
  88 (define exception:bad-bindings
  89   (cons 'misc-error "^bad bindings"))
  90 (define exception:bad-formals
  91   (cons 'misc-error "^bad formals"))
  92 (define exception:bad-var
  93   (cons 'misc-error "^bad variable"))
  94 (define exception:missing/extra-expr
  95   (cons 'misc-error "^missing or extra expression"))
  96
  97 (define x:unbound-var "[Uu]nbound variable")
  98 (define x:bad-var "[Bb]ad variable")
  99 (define x:bad-formals "[Bb]ad formals")
 100 (define x:bad-bindings "[Bb]ad bindings")
 101 (define x:bad-body "[Bb]ad body")
 102 (define x:bad/missing-clauses "[Bb]ad or missing clauses")
 103 (define x:missing/extra-expr "[Mm]issing or extra expression")
 104 (define x:wrong-num-args "[Ww]rong number of arguments")
 105 (define x:wrong-type-arg "[Ww]rong type argument")
 106
 107 ;; This is to encourage people to write tests.
 108
 109 (define                   x:hm "[Hh]m")                   ;-D
 110  (define                 x:bad "[Bb]ad")                 ;-D
 111   (define               x:sick "[Ss]ick")               ;-D
 112    (define             x:wrong "[Ww]rong")             ;-D
 113     (define           x:stupid "[Ss]tupid")           ;-D
 114      (define         x:strange "[Ss]trange")         ;-D
 115       (define       x:unlikely "[Uu]nlikely")       ;-D
 116        (define     x:inelegant "[Ii]nelegant")     ;-D
 117         (define   x:suboptimal "[Ss]uboptimal")   ;-D
 118          (define x:bletcherous "[Bb]letcherous") ;-D   h a t - t h e - ?!?
 119
 120 ;; Tests
 121
 122 (with-test-prefix "syntax"
 123   (with-test-prefix "lambda"
 124
 125     (goad x:bad-formals (lambda (x 1) 2))
 126     (goad x:bad-formals (lambda (1 x) 2))
 127     (goad x:bad-formals (lambda (x "a") 2))
 128     (goad x:bad-formals (lambda ("a" x) 2))
 129
 130     (expect-fail-exception "(lambda (x x) 1)"
 131       exception:bad-formals
 132       (lambda (x x) 1))
 133
 134     (expect-fail-exception "(lambda (x x x) 1)"
 135       exception:bad-formals
 136       (lambda (x x x) 1))
 137
 138     (with-test-prefix "cond-arrow-proc"
 139       (goad x:bad-formals (cond (1 => (lambda (x 1) 2))))
 140       ;; Add more (syntax lambda cond-arrow-proc) exceptions here.
 141       )
 142
 143     ;; Add more (syntax lambda) exceptions here.
 144     )
 145   ;; Below, A1,B1 different from A2,B2 because A1,B1 are "named let".
 146   (with-test-prefix "let"
 147     (goad x:bad-body (let))
 148     (goad x:bad-body (let 1))
 149     (goad x:bad-body (let ()))
 150     (goad x:bad-body (let (x)))
 151     (goad x:bad-bindings (let (x) 1))
 152     (goad x:bad-bindings (let ((x)) 3))
 153     (goad x:bad-bindings (let ((x 1) y) x))
 154     (goad x:bad-body (let x ()))        ; A1
 155     (goad x:bad-body (let x (y)))       ; B1
 156     ;; Add more (syntax let) exceptions here.
 157     )
 158   (with-test-prefix "let*"
 159     (goad x:bad-body (let*))
 160     (goad x:bad-body (let* 1))
 161     (goad x:bad-body (let* ()))
 162     (goad x:bad-body (let* (x)))
 163     (goad x:bad-bindings (let* (x) 1))
 164     (goad x:bad-bindings (let* ((x)) 3))
 165     (goad x:bad-bindings (let* ((x 1) y) x))
 166     (goad x:bad-bindings (let* x ()))   ; A2
 167     (goad x:bad-bindings (let* x (y)))  ; B2
 168     ;; Add more (syntax let*) exceptions here.
 169     )
 170   (with-test-prefix "letrec"
 171     (goad x:bad-body (letrec))
 172     (goad x:bad-body (letrec 1))
 173     (goad x:bad-body (letrec ()))
 174     (goad x:bad-body (letrec (x)))
 175     (goad x:bad-bindings (letrec (x) 1))
 176     (goad x:bad-bindings (letrec ((x)) 3))
 177     (goad x:bad-bindings (letrec ((x 1) y) x))
 178     (goad x:bad-bindings (letrec x ()))   ; A2
 179     (goad x:bad-bindings (letrec x (y)))  ; B2
 180     ;; Add more (syntax letrec) exceptions here.
 181     )
 182   (with-test-prefix "cond"
 183     (goad x:bad/missing-clauses (cond))
 184     (goad x:bad/missing-clauses (cond #t))
 185     (goad x:bad/missing-clauses (cond 1))
 186     (goad x:bad/missing-clauses (cond 1 2))
 187     (goad x:bad/missing-clauses (cond 1 2 3))
 188     (goad x:bad/missing-clauses (cond 1 2 3 4))
 189     (goad x:bad/missing-clauses (cond ()))
 190     (goad x:bad/missing-clauses (cond () 1))
 191     (goad x:bad/missing-clauses (cond (1) 1))
 192     ;; Add more (syntax cond) exceptions here.
 193     )
 194   (with-test-prefix "if"
 195     (goad x:missing/extra-expr (if))
 196     (goad x:missing/extra-expr (if 1 2 3 4))
 197     ;; Add more (syntax if) exceptions here.
 198     )
 199   (with-test-prefix "define"
 200     (goad x:missing/extra-expr (define))
 201     ;; Add more (syntax define) exceptions here.
 202     )
 203   (with-test-prefix "set!"
 204     (goad x:missing/extra-expr (set!))
 205     (goad x:missing/extra-expr (set! 1))
 206     (goad x:missing/extra-expr (set! 1 2 3))
 207     ;; Add more (syntax set!) exceptions here.
 208     )
 209   (with-test-prefix "misc"
 210     (goad x:missing/extra-expr (quote))
 211
 212     ;; R5RS says:
 213     ;; *Note:* In many dialects of Lisp, the empty combination, (),
 214     ;; is a legitimate expression.  In Scheme, combinations must
 215     ;; have at least one subexpression, so () is not a syntactically
 216     ;; valid expression.
 217     (expect-fail-exception "empty parentheses \"()\""
 218       exception:missing/extra-expr
 219       ())
 220
 221     ;; Add more (syntax misc) exceptions here.
 222     )
 223   ;; Add more (syntax) exceptions here.
 224   )
 225
 226 (with-test-prefix "bindings"
 227   (with-test-prefix "unbound"
 228     (goad x:unbound-var unlikely-to-be-bound)
 229     (goad x:unbound-var (unlikely-to-be-bound))
 230     ;; Add more (bindings unbound) exceptions here.
 231     )
 232   (with-test-prefix "immutable-modification"
 233     (goad x:bad-var (set! "some-string" #t))
 234     (goad x:bad-var (set! 1 #t))
 235     (goad x:bad-var (set! #t #f))
 236     (goad x:bad-var (set! #f #t))
 237     (goad x:bad-var (set! #\space 'the-final-frontier))
 238     (goad x:wrong-type-arg (set! (symbol->string 'safe) 1))
 239     (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs
 240     (goad x:bad-var (set! "abc" 1))
 241     (goad x:wrong-type-arg (set! '145932 1))
 242     (goad x:bad-var (set! 145932 1))
 243     (goad x:wrong-type-arg (set! '#t 1))
 244     (goad x:wrong-type-arg (set! '#f 1))
 245
 246     ;; Add more (bindings immutable-modification) exceptions here.
 247     )
 248   (with-test-prefix "let"
 249     (goad x:bad-var (let ((1 2)) 3))
 250     (goad x:unbound-var (let ((x 1) (y x)) y))
 251
 252     (expect-fail-exception "(let ((x 1) (x 2)) x)"
 253       exception:bad-bindings
 254       (let ((x 1) (x 2)) x))
 255
 256     ;; Add more (bindings let) exceptions here.
 257     )
 258   (with-test-prefix "let*"
 259     (goad x:bad-var (let* ((1 2)) 3))
 260
 261     (expect-fail-exception "(let* ((x 1) (x 2)) x)"
 262       exception:bad-bindings
 263       (let* ((x 1) (x 2)) x))
 264
 265     ;; Add more (bindings let*) exceptions here.
 266     )
 267   (with-test-prefix "letrec"
 268     (goad x:bad-var (letrec ((1 2)) 3))
 269     (goad x:unbound-var (letrec ((x 1) (y x)) y))
 270
 271     (expect-fail-exception "(letrec ((x 1) (x 2)) x)"
 272       exception:bad-bindings
 273       (letrec ((x 1) (x 2)) x))
 274
 275     ;; Add more (bindings letrec) exceptions here.
 276     )
 277   ;; Add more (bindings) exceptions here.
 278   )
 279
 280 (with-test-prefix "application"
 281   (goad x:wrong-type-arg (+ 1 #f))
 282   (goad x:wrong-type-arg (+ "1" 2))
 283   (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3)))
 284   ;; Add more (application) exceptions here.
 285   )
 286
 287 ;; Local variables:
 288 ;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
 289 ;; End:
 290
 291 ;;; exceptions.test ends here