mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 22:50:27 +02:00
1dcf33280d
* test-suite/tests/procprop.test ("procedure-arity"): Procedure-property
'arity on "apply" will fail if "apply" is a program. I suggest that
procedure-property is actually the wrong interface for this; if we even
want to preseve the old arity forms, we should have an accessor for
arity directly that the VM can implement. But in the meantime throw
this nasty error while we decide.
63 lines
1.9 KiB
Scheme
63 lines
1.9 KiB
Scheme
;;;; procprop.test --- Procedure properties -*- Scheme -*-
|
||
;;;; Ludovic Courtès <ludo@gnu.org>
|
||
;;;;
|
||
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This program is free software; you can redistribute it and/or modify
|
||
;;;; it under the terms of the GNU General Public License as published by
|
||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||
;;;; any later version.
|
||
;;;;
|
||
;;;; This program is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;;; GNU General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU General Public License
|
||
;;;; along with this software; see the file COPYING. If not, write to
|
||
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||
;;;; Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-procpop)
|
||
:use-module (test-suite lib))
|
||
|
||
|
||
(with-test-prefix "procedure-name"
|
||
(pass-if "simple subr"
|
||
(eq? 'display (procedure-name display)))
|
||
|
||
(pass-if "gsubr"
|
||
(eq? 'hashq-ref (procedure-name hashq-ref))))
|
||
|
||
|
||
(with-test-prefix "procedure-arity"
|
||
(pass-if "simple subr"
|
||
(equal? (procedure-property display 'arity)
|
||
'(1 1 #f)))
|
||
|
||
(pass-if "gsubr"
|
||
(equal? (procedure-property hashq-ref 'arity)
|
||
'(2 1 #f)))
|
||
|
||
(pass-if "port-closed?"
|
||
(equal? (procedure-property port-closed? 'arity)
|
||
'(1 0 #f)))
|
||
|
||
(pass-if "apply"
|
||
(equal? (if ((@ (system vm program) program?) apply)
|
||
(throw 'unresolved)
|
||
(procedure-property apply 'arity))
|
||
'(1 0 #t)))
|
||
|
||
(pass-if "cons*"
|
||
(equal? (procedure-property cons* 'arity)
|
||
'(1 0 #t)))
|
||
|
||
(pass-if "list"
|
||
(equal? (procedure-property list 'arity)
|
||
'(0 0 #t))))
|
||
|
||
|
||
;;; Local Variables:
|
||
;;; coding: latin-1
|
||
;;; End:
|