test-suite/tests/procprop.test

   1 ;;;; procprop.test --- Procedure properties               -*- Scheme -*-
   2 ;;;; Ludovic Courtès <ludo@gnu.org>
   3 ;;;;
   4 ;;;;    Copyright (C) 2009 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program 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
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-procpop)
  22   :use-module (test-suite lib))
  23
  24 \f
  25 (with-test-prefix "procedure-name"
  26   (pass-if "simple subr"
  27     (eq? 'display (procedure-name display)))
  28
  29   (pass-if "gsubr"
  30     (eq? 'hashq-ref (procedure-name hashq-ref))))
  31
  32 \f
  33 (with-test-prefix "procedure-arity"
  34   (pass-if "simple subr"
  35     (equal? (procedure-property display 'arity)
  36             '(1 1 #f)))
  37
  38   (pass-if "gsubr"
  39     (equal? (procedure-property hashq-ref 'arity)
  40             '(2 1 #f)))
  41
  42   (pass-if "port-closed?"
  43     (equal? (procedure-property port-closed? 'arity)
  44             '(1 0 #f)))
  45
  46   (pass-if "apply"
  47     (equal? (if ((@ (system vm program) program?) apply)
  48                 (throw 'unresolved)
  49                 (procedure-property apply 'arity))
  50             '(1 0 #t)))
  51
  52   (pass-if "cons*"
  53     (equal? (procedure-property cons* 'arity)
  54             '(1 0 #t)))
  55
  56   (pass-if "list"
  57     (equal? (procedure-property list 'arity)
  58             '(0 0 #t))))
  59
  60
  61 ;;; Local Variables:
  62 ;;; coding: latin-1
  63 ;;; End: