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 ;;;; Code:
  57
  58 (use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list))
  59
  60 (defmacro expect-exception (name-snippet expression)
  61   `(pass-if (with-output-to-string
  62               (lambda ()
  63                 (for-each display
  64                           (list
  65                            "`"
  66                            (let ((x (symbol->string ',name-snippet)))
  67                              (substring x 2 (string-length x)))
  68                            "' expected but not thrown: "))
  69                 (write ',expression)))
  70             (catch #t
  71                    (lambda () ,expression #f) ; conniving falsehood!
  72                    (lambda args
  73                      ;; squeeze value to `#t'
  74                      (not (notany (lambda (x)
  75                                     (and (string? x)
  76                                          (string-match ,name-snippet x)))
  77                                   args))))))
  78
  79 (define goad expect-exception)
  80
  81 ;; Exception messages
  82 ;; Ideally, we would mine these out of libguile/error.[hc], etc.
  83 ;; (Someday, when guile is re-implemented in Scheme....)
  84
  85 (define x:unbound-var "[Uu]nbound variable")
  86 (define x:bad-var "[Bb]ad variable")
  87 (define x:bad-formals "[Bb]ad formals")
  88 (define x:bad-bindings "[Bb]ad bindings")
  89 (define x:bad-body "[Bb]ad body")
  90 (define x:bad/missing-clauses "[Bb]ad or missing clauses")
  91 (define x:missing/extra-expr "[Mm]issing or extra expression")
  92 (define x:wrong-num-args "[Ww]rong number of arguments")
  93 (define x:wrong-type-arg "[Ww]rong type argument")
  94
  95 ;; This is to encourage people to write tests.
  96
  97 (define                   x:hm "[Hh]m")                   ;-D
  98  (define                 x:bad "[Bb]ad")                 ;-D
  99   (define               x:sick "[Ss]ick")               ;-D
 100    (define             x:wrong "[Ww]rong")             ;-D
 101     (define           x:stupid "[Ss]tupid")           ;-D
 102      (define         x:strange "[Ss]trange")         ;-D
 103       (define       x:unlikely "[Uu]nlikely")       ;-D
 104        (define     x:inelegant "[Ii]nelegant")     ;-D
 105         (define   x:suboptimal "[Ss]uboptimal")   ;-D
 106          (define x:bletcherous "[Bb]letcherous") ;-D   h a t - t h e - ?!?
 107
 108 ;; Tests
 109
 110 (with-test-prefix "syntax"
 111   (with-test-prefix "let"
 112     (goad x:bad-body (let))
 113     (goad x:bad-body (let 1))
 114     (goad x:bad-body (let ()))
 115     (goad x:bad-body (let (x)))
 116     (goad x:bad-bindings (let (x) 1))   ; maybe these should go under bindings?
 117     (goad x:bad-bindings (let ((x)) 3))
 118     (goad x:bad-bindings (let ((x 1) y) x))
 119     (goad x:bad-body (let x ()))
 120     (goad x:bad-body (let x (y)))
 121
 122     ;; no exception on 2001-02-22
 123     (goad x:bad-bindings (let ((x 1) (x 2)) x))
 124
 125     ;; Add more (syntax let) exceptions here.
 126     )
 127   (with-test-prefix "cond"
 128     (goad x:bad/missing-clauses (cond))
 129     (goad x:bad/missing-clauses (cond #t))
 130     (goad x:bad/missing-clauses (cond 1))
 131     (goad x:bad/missing-clauses (cond 1 2))
 132     (goad x:bad/missing-clauses (cond 1 2 3))
 133     (goad x:bad/missing-clauses (cond 1 2 3 4))
 134     (goad x:bad/missing-clauses (cond ()))
 135     (goad x:bad/missing-clauses (cond () 1))
 136     (goad x:bad/missing-clauses (cond (1) 1))
 137     ;; Add more (syntax cond) exceptions here.
 138     )
 139   (with-test-prefix "if"
 140     (goad x:missing/extra-expr (if))
 141     (goad x:missing/extra-expr (if 1 2 3 4))
 142     ;; Add more (syntax if) exceptions here.
 143     )
 144   (with-test-prefix "define"
 145     (goad x:missing/extra-expr (define))
 146     ;; Add more (syntax define) exceptions here.
 147     )
 148   ;; Add more (syntax) exceptions here.
 149   )
 150
 151 (with-test-prefix "bindings"
 152   (goad x:unbound-var unlikely-to-be-bound)
 153   (goad x:bad-var (set! "some-string" #t))
 154   (goad x:bad-var (set! 1 #t))
 155   (goad x:bad-var (set! #t #f))
 156   (goad x:bad-var (set! #f #t))
 157   (goad x:bad-var (set! #\space 'the-final-frontier))
 158   (goad x:wrong-type-arg (set! (symbol->string 'safe) 1))
 159   (goad x:wrong-type-arg (set! '"abc" 1))      ; from r5rs
 160   (goad x:bad-var (set! "abc" 1))
 161   (goad x:wrong-type-arg (set! '145932 1))
 162   (goad x:bad-var (set! 145932 1))
 163   (goad x:wrong-type-arg (set! '#t 1))
 164   (goad x:wrong-type-arg (set! '#f 1))
 165   (goad x:bad-body (let))
 166   (goad x:bad-var (let ((1 2)) 3))
 167
 168   ;; no exception on 2001-02-22
 169   (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space))
 170   ;; no exception on 2001-02-22
 171   (goad x:bad-var (string-set! "abc" 1 #\space))
 172
 173   ;; Add more (bindings) exceptions here.
 174   )
 175
 176 (with-test-prefix "lambda"
 177
 178   (goad x:bad-formals (lambda (x 1) 2))
 179   (goad x:bad-formals (lambda (1 x) 2))
 180   (goad x:bad-formals (lambda (x "a") 2))
 181   (goad x:bad-formals (lambda ("a" x) 2))
 182   (goad x:bad-formals (lambda (x x) 1))
 183   (goad x:bad-formals (lambda (x x x) 1))
 184
 185   (with-test-prefix "cond-arrow-proc"
 186     (goad x:bad-formals (cond (1 => (lambda (x 1) 2))))
 187     ;; Add more (lambda cond-arrow-proc) exceptions here.
 188     )
 189
 190   ;; Add more (lambda) exceptions here.
 191   )
 192
 193 (with-test-prefix "application"
 194   (goad x:wrong-type-arg (+ 1 #f))
 195   (goad x:wrong-type-arg (+ "1" 2))
 196   (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3)))
 197   ;; Add more (application) exceptions here.
 198   )
 199
 200 ;;; exceptions.test ends here