test-suite/tests/procprop.test

   1 ;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
   2 ;;;; Ludovic Courtès <ludo@gnu.org>
   3 ;;;;
   4 ;;;;    Copyright (C) 2009, 2010, 2011, 2012, 2013 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-procpop)
  21   :use-module (test-suite lib))
  22
  23 \f
  24 (with-test-prefix "procedure-name"
  25   (pass-if "simple subr"
  26     (eq? 'display (procedure-name display)))
  27
  28   (pass-if "gsubr"
  29     (eq? 'hashq-ref (procedure-name hashq-ref)))
  30
  31   (pass-if "from eval"
  32     (eq? 'foobar (procedure-name
  33                   (eval '(begin (define (foobar) #t) foobar)
  34                         (current-module))))))
  35
  36 \f
  37 (with-test-prefix "procedure-arity"
  38   (pass-if "simple subr"
  39     (equal? (procedure-minimum-arity display)
  40             '(1 1 #f)))
  41
  42   (pass-if "gsubr"
  43     (equal? (procedure-minimum-arity hashq-ref)
  44             '(2 1 #f)))
  45
  46   (pass-if "port-closed?"
  47     (equal? (procedure-minimum-arity port-closed?)
  48             '(1 0 #f)))
  49
  50   (pass-if "apply"
  51     (equal? (procedure-minimum-arity apply)
  52             '(2 0 #t)))
  53
  54   (pass-if "cons*"
  55     (equal? (procedure-minimum-arity cons*)
  56             '(1 0 #t)))
  57
  58   (pass-if "list"
  59     (equal? (procedure-minimum-arity list)
  60             '(0 0 #t)))
  61
  62   (pass-if "fixed, eval"
  63     (equal? (procedure-minimum-arity (eval '(lambda (a b) #t)
  64                                            (current-module)))
  65             '(2 0 #f)))
  66
  67   (pass-if "rest, eval"
  68     (equal? (procedure-minimum-arity (eval '(lambda (a b . c) #t)
  69                                            (current-module)))
  70             '(2 0 #t)))
  71
  72   (pass-if "opt, eval"
  73     (equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
  74                                            (current-module)))
  75             '(2 1 #f))))