test-suite/tests/optargs.test

   1 ;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
   2 ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
   3 ;;;;
   4 ;;;;    Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-optargs)
  21   #:use-module (test-suite lib)
  22   #:use-module (system base compile)
  23   #:use-module (ice-9 optargs))
  24
  25 (define exception:unrecognized-keyword
  26   '(keyword-argument-error . "Unrecognized keyword"))
  27
  28 (define exception:extraneous-arguments
  29   ;; Message depends on whether we use the interpreter or VM, and on the
  30   ;; evenness of the number of extra arguments (!).
  31   ;'(keyword-argument-error . ".*")
  32   '(#t . ".*"))
  33
  34 (define-syntax c&e
  35   (syntax-rules (pass-if pass-if-exception)
  36     ((_ (pass-if test-name exp))
  37      (begin (pass-if (string-append test-name " (eval)")
  38                      (primitive-eval 'exp))
  39             (pass-if (string-append test-name " (compile)")
  40                      (compile 'exp #:to 'value #:env (current-module)))))
  41     ((_ (pass-if-exception test-name exc exp))
  42      (begin (pass-if-exception (string-append test-name " (eval)")
  43                                exc (primitive-eval 'exp))
  44             (pass-if-exception (string-append test-name " (compile)")
  45                                exc (compile 'exp #:to 'value
  46                                             #:env (current-module)))))))
  47
  48 (define-syntax with-test-prefix/c&e
  49   (syntax-rules ()
  50     ((_ section-name exp ...)
  51      (with-test-prefix section-name (c&e exp) ...))))
  52
  53 (with-test-prefix/c&e "optional argument processing"
  54   (pass-if "local defines work with optional arguments"
  55     (eval '(begin
  56              (define* (test-1 #:optional (x 0))
  57                (define d 1)                     ; local define
  58                #t)
  59              (false-if-exception (test-1)))
  60           (interaction-environment))))
  61
  62 ;;;
  63 ;;; let-keywords
  64 ;;;
  65
  66 (with-test-prefix/c&e "let-keywords"
  67
  68   ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
  69   ;; which caused apparently internal defines to "leak" out into the
  70   ;; encompasing environment
  71   (pass-if-exception "empty bindings internal defines leaking out"
  72       exception:unbound-var
  73     (let ((rest '()))
  74       (let-keywords rest #f ()
  75         (define localvar #f)
  76         #f)
  77       localvar))
  78
  79   (pass-if "one key"
  80     (let-keywords '(#:foo 123) #f (foo)
  81       (= foo 123))))
  82
  83 ;;;
  84 ;;; let-keywords*
  85 ;;;
  86
  87 (with-test-prefix/c&e "let-keywords*"
  88
  89   ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
  90   ;; which caused apparently internal defines to "leak" out into the
  91   ;; encompasing environment
  92   (pass-if-exception "empty bindings internal defines leaking out"
  93       exception:unbound-var
  94     (let ((rest '()))
  95       (let-keywords* rest #f ()
  96         (define localvar #f)
  97         #f)
  98       localvar))
  99
 100   (pass-if "one key"
 101     (let-keywords* '(#:foo 123) #f (foo)
 102       (= foo 123))))
 103
 104 ;;;
 105 ;;; let-optional
 106 ;;;
 107
 108 (with-test-prefix/c&e "let-optional"
 109
 110   ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
 111   ;; which caused apparently internal defines to "leak" out into the
 112   ;; encompasing environment
 113   (pass-if-exception "empty bindings internal defines leaking out"
 114       exception:unbound-var
 115     (let ((rest '()))
 116       (let-optional rest ()
 117         (define localvar #f)
 118         #f)
 119       localvar))
 120
 121   (pass-if "one var"
 122     (let ((rest '(123)))
 123       (let-optional rest ((foo 999))
 124         (= foo 123)))))
 125
 126 ;;;
 127 ;;; let-optional*
 128 ;;;
 129
 130 (with-test-prefix/c&e "let-optional*"
 131
 132   ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
 133   ;; which caused apparently internal defines to "leak" out into the
 134   ;; encompasing environment
 135   (pass-if-exception "empty bindings internal defines leaking out"
 136       exception:unbound-var
 137     (let ((rest '()))
 138       (let-optional* rest ()
 139         (define localvar #f)
 140         #f)
 141       localvar))
 142
 143   (pass-if "one var"
 144     (let ((rest '(123)))
 145       (let-optional* rest ((foo 999))
 146         (= foo 123)))))
 147
 148 (define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r)
 149   (list a b c d e f g h i r))
 150
 151 ;; So we could use lots more tests here, but the fact that lambda* is in
 152 ;; the compiler, and the compiler compiles itself, using the evaluator
 153 ;; (when bootstrapping) and compiled code (when doing a partial rebuild)
 154 ;; makes me a bit complacent.
 155 (with-test-prefix/c&e "define*"
 156   (pass-if "the whole enchilada"
 157     (equal? (foo 1 2)
 158             '(1 2 #f 1 #f #f #f 1 () ())))
 159
 160   (pass-if-exception "extraneous arguments"
 161     exception:extraneous-arguments
 162     (let ((f (lambda* (#:key x) x)))
 163       (f 1 2 #:x 'x)))
 164
 165   (pass-if-exception "unrecognized keyword"
 166     exception:unrecognized-keyword
 167     (let ((f (lambda* (#:key x) x)))
 168       (f #:y 'not-recognized)))
 169
 170   (pass-if "rest given before keywords"
 171     ;; Passing the rest argument before the keyword arguments should not
 172     ;; prevent keyword argument binding.
 173     (let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
 174       (equal? (f 1 2 3 #:x 'x #:z 'z)
 175               '(x #f z (1 2 3 #:x x #:z z))))))
 176
 177 (with-test-prefix/c&e "lambda* inits"
 178   (pass-if "can bind lexicals within inits"
 179     (begin
 180       (define qux
 181         (lambda* (#:optional a #:key (b (or a 13) #:a))
 182           b))
 183       #t))
 184   (pass-if "testing qux"
 185     (and (equal? (qux) 13)
 186          (equal? (qux 1) 1)
 187          (equal? (qux #:a 2) 2))))
 188
 189 (with-test-prefix/c&e "defmacro*"
 190   (pass-if "definition"
 191     (begin
 192       (defmacro* transmogrify (a #:optional (b 10))
 193         `(,a ,b))
 194       #t))
 195
 196   (pass-if "explicit arg"
 197     (equal? (transmogrify quote 5)
 198             5))
 199
 200   (pass-if "default arg"
 201     (equal? (transmogrify quote)
 202             10)))