[uim-commit] r2822 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Jan 6 17:20:11 PST 2006
Author: yamaken
Date: 2006-01-06 17:20:07 -0800 (Fri, 06 Jan 2006)
New Revision: 2822
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations-srfi8.c
branches/r5rs/sigscheme/syntax.c
branches/r5rs/sigscheme/test/test-define.scm
branches/r5rs/sigscheme/test/test-exp.scm
branches/r5rs/sigscheme/test/test-srfi1.scm
branches/r5rs/sigscheme/test/test-srfi8.scm
branches/r5rs/sigscheme/test/test-syntax.scm
Log:
* sigscheme/operations-srfi8.c
- (scm_s_srfi8_receive): Fix lacking formals varidation
* sigscheme/test/test-srfi8.scm
- Add tests for the formals varidation
- Add tests for variadic_[012]
* sigscheme/syntax.c
- (scm_s_define): Fix lacking formals varidation
* sigscheme/test/test-define.scm
- Add tests for the formals varidation
* sigscheme/eval.c
- (call_closure): Replace unneeded formals check with SCM_ASSERT()
* sigscheme/test/test-exp.scm
- Add tests for the formals varidation of lambda
* sigscheme/test/test-syntax.scm
- Add tests for function calling for 'define'-created closure
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/eval.c 2006-01-07 01:20:07 UTC (rev 2822)
@@ -227,7 +227,7 @@
eval_state->env = scm_extend_environment(SCM_NULL, SCM_NULL, proc_env);
} else {
- ERR_OBJ("bad formals list", formals);
+ SCM_ASSERT(scm_false);
}
eval_state->ret_type = SCM_RETTYPE_NEED_EVAL;
Modified: branches/r5rs/sigscheme/operations-srfi8.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi8.c 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/operations-srfi8.c 2006-01-07 01:20:07 UTC (rev 2822)
@@ -70,6 +70,7 @@
scm_s_srfi8_receive(ScmObj formals, ScmObj expr, ScmObj body,
ScmEvalState *eval_state)
{
+ int formals_len, actuals_len;
ScmObj env, actuals;
DECLARE_FUNCTION("receive", syntax_variadic_tailrec_2);
@@ -79,7 +80,8 @@
* (receive <formals> <expression> <body>)
*/
- if (!(LISTP(formals) || SYMBOLP(formals)))
+ formals_len = scm_validate_formals(formals);
+ if (SCM_LISTLEN_ERRORP(formals_len))
ERR_OBJ("bad formals", formals);
/* FIXME: do we have to extend the environment first? The SRFI-8
@@ -94,11 +96,16 @@
*/
actuals = EVAL(expr, env);
- if (SCM_VALUEPACKETP(actuals))
+ if (SCM_VALUEPACKETP(actuals)) {
actuals = SCM_VALUEPACKET_VALUES(actuals);
- else
+ actuals_len = scm_finite_length(actuals);
+ } else {
actuals = LIST_1(actuals);
+ actuals_len = 1;
+ }
+ if (!scm_valid_environment_extension_lengthp(formals_len, actuals_len))
+ ERR_OBJ("unmatched number of args for multiple values", actuals);
eval_state->env = env = scm_extend_environment(formals, actuals, env);
return scm_s_begin(body, eval_state);
Modified: branches/r5rs/sigscheme/syntax.c
===================================================================
--- branches/r5rs/sigscheme/syntax.c 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/syntax.c 2006-01-07 01:20:07 UTC (rev 2822)
@@ -681,7 +681,6 @@
SCM_QUEUE_ADD(varq, var);
SCM_QUEUE_ADD(valq, val);
}
-
if (!NULLP(bindings))
ERR_OBJ("invalid bindings form", bindings);
@@ -756,6 +755,7 @@
ERR("letrec: invalid bindings form");
/* extend env by placeholder frame for subsequent lambda evaluations */
+ /* FIXME: direct env object manipulation */
frame = CONS(SCM_NULL, SCM_NULL);
eval_state->env = CONS(frame, eval_state->env);
@@ -1115,6 +1115,8 @@
#endif
ENSURE_SYMBOL(procname);
+ if (SCM_LISTLEN_ERRORP(scm_validate_formals(formals)))
+ ERR_OBJ("bad formals", formals);
define_internal(procname, MAKE_CLOSURE(CONS(formals, body), env), env);
} else {
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/test/test-define.scm 2006-01-07 01:20:07 UTC (rev 2822)
@@ -32,6 +32,8 @@
(load "./test/unittest.scm")
+(define tn test-name)
+
; invalid form
(assert-error "define invalid form #1"
(lambda ()
@@ -125,4 +127,82 @@
(assert-equal? "set dot test" '(1 2) (set-dot '()))
+(tn "define function form: boolean as an arg")
+(assert-error (tn) (lambda () (define (f . #t) #t)))
+(assert-error (tn) (lambda () (define (f #t) #t)))
+(assert-error (tn) (lambda () (define (f x #t) #t)))
+(assert-error (tn) (lambda () (define (f #t x) #t)))
+(assert-error (tn) (lambda () (define (f x . #t) #t)))
+(assert-error (tn) (lambda () (define (f #t . x) #t)))
+(assert-error (tn) (lambda () (define (f x y #t) #t)))
+(assert-error (tn) (lambda () (define (f x y . #t) #t)))
+(assert-error (tn) (lambda () (define (f x #t y) #t)))
+(assert-error (tn) (lambda () (define (f x #t . y) #t)))
+(tn "define function form: intger as an arg")
+(assert-error (tn) (lambda () (define (f . 1) #t)))
+(assert-error (tn) (lambda () (define (f 1) #t)))
+(assert-error (tn) (lambda () (define (f x 1) #t)))
+(assert-error (tn) (lambda () (define (f 1 x) #t)))
+(assert-error (tn) (lambda () (define (f x . 1) #t)))
+(assert-error (tn) (lambda () (define (f 1 . x) #t)))
+(assert-error (tn) (lambda () (define (f x y 1) #t)))
+(assert-error (tn) (lambda () (define (f x y . 1) #t)))
+(assert-error (tn) (lambda () (define (f x 1 y) #t)))
+(assert-error (tn) (lambda () (define (f x 1 . y) #t)))
+(tn "define function form: null as an arg")
+(assert-true (tn) (define (f . ()) #t))
+(assert-error (tn) (lambda () (define (f ()) #t)))
+(assert-error (tn) (lambda () (define (f x ()) #t)))
+(assert-error (tn) (lambda () (define (f () x) #t)))
+(assert-true (tn) (define (f x . ()) #t))
+(assert-error (tn) (lambda () (define (f () . x) #t)))
+(assert-error (tn) (lambda () (define (f x y ()) #t)))
+(assert-true (tn) (define (f x y . ()) #t))
+(assert-error (tn) (lambda () (define (f x () y) #t)))
+(assert-error (tn) (lambda () (define (f x () . y) #t)))
+(tn "define function form: pair as an arg")
+(assert-true (tn) (define (f . (a)) #t))
+(assert-error (tn) (lambda () (define (f (a)) #t)))
+(assert-error (tn) (lambda () (define (f x (a)) #t)))
+(assert-error (tn) (lambda () (define (f (a) x) #t)))
+(assert-true (tn) (define (f x . (a)) #t))
+(assert-error (tn) (lambda () (define (f (a) . x) #t)))
+(assert-error (tn) (lambda () (define (f x y (a)) #t)))
+(assert-true (tn) (define (f x y . (a)) #t))
+(assert-error (tn) (lambda () (define (f x (a) y) #t)))
+(assert-error (tn) (lambda () (define (f x (a) . y) #t)))
+(tn "define function form: char as an arg")
+(assert-error (tn) (lambda () (define (f . #\a) #t)))
+(assert-error (tn) (lambda () (define (f #\a) #t)))
+(assert-error (tn) (lambda () (define (f x #\a) #t)))
+(assert-error (tn) (lambda () (define (f #\a x) #t)))
+(assert-error (tn) (lambda () (define (f x . #\a) #t)))
+(assert-error (tn) (lambda () (define (f #\a . x) #t)))
+(assert-error (tn) (lambda () (define (f x y #\a) #t)))
+(assert-error (tn) (lambda () (define (f x y . #\a) #t)))
+(assert-error (tn) (lambda () (define (f x #\a y) #t)))
+(assert-error (tn) (lambda () (define (f x #\a . y) #t)))
+(tn "define function form: string as an arg")
+(assert-error (tn) (lambda () (define (f . "a") #t)))
+(assert-error (tn) (lambda () (define (f "a") #t)))
+(assert-error (tn) (lambda () (define (f x "a") #t)))
+(assert-error (tn) (lambda () (define (f "a" x) #t)))
+(assert-error (tn) (lambda () (define (f x . "a") #t)))
+(assert-error (tn) (lambda () (define (f "a" . x) #t)))
+(assert-error (tn) (lambda () (define (f x y "a") #t)))
+(assert-error (tn) (lambda () (define (f x y . "a") #t)))
+(assert-error (tn) (lambda () (define (f x "a" y) #t)))
+(assert-error (tn) (lambda () (define (f x "a" . y) #t)))
+(tn "define function form: vector as an arg")
+(assert-error (tn) (lambda () (define (f . #(a)) #t)))
+(assert-error (tn) (lambda () (define (f #(a)) #t)))
+(assert-error (tn) (lambda () (define (f x #(a)) #t)))
+(assert-error (tn) (lambda () (define (f #(a) x) #t)))
+(assert-error (tn) (lambda () (define (f x . #(a)) #t)))
+(assert-error (tn) (lambda () (define (f #(a) . x) #t)))
+(assert-error (tn) (lambda () (define (f x y #(a)) #t)))
+(assert-error (tn) (lambda () (define (f x y . #(a)) #t)))
+(assert-error (tn) (lambda () (define (f x #(a) y) #t)))
+(assert-error (tn) (lambda () (define (f x #(a) . y) #t)))
+
(total-report)
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2006-01-07 01:20:07 UTC (rev 2822)
@@ -32,6 +32,7 @@
(load "./test/unittest.scm")
+(define tn test-name)
(define tee #t)
(define ef #f)
@@ -55,6 +56,77 @@
(assert-equal? "basic lambda test10" 2 ((lambda (x y . z) y) 1 2))
(assert-equal? "basic lambda test11" '() ((lambda (x y . z) z) 1 2))
+(tn "lambda invalid formals: boolean as an arg")
+(assert-error (tn) (lambda () (lambda (#t) #t)))
+(assert-error (tn) (lambda () (lambda (x #t) #t)))
+(assert-error (tn) (lambda () (lambda (#t x) #t)))
+(assert-error (tn) (lambda () (lambda (x . #t) #t)))
+(assert-error (tn) (lambda () (lambda (#t . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y #t) #t)))
+(assert-error (tn) (lambda () (lambda (x y . #t) #t)))
+(assert-error (tn) (lambda () (lambda (x #t y) #t)))
+(assert-error (tn) (lambda () (lambda (x #t . y) #t)))
+(tn "lambda invalid formals: intger as an arg")
+(assert-error (tn) (lambda () (lambda (1) #t)))
+(assert-error (tn) (lambda () (lambda (x 1) #t)))
+(assert-error (tn) (lambda () (lambda (1 x) #t)))
+(assert-error (tn) (lambda () (lambda (x . 1) #t)))
+(assert-error (tn) (lambda () (lambda (1 . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y 1) #t)))
+(assert-error (tn) (lambda () (lambda (x y . 1) #t)))
+(assert-error (tn) (lambda () (lambda (x 1 y) #t)))
+(assert-error (tn) (lambda () (lambda (x 1 . y) #t)))
+(tn "lambda invalid formals: null as an arg")
+(assert-error (tn) (lambda () (lambda (()) #t)))
+(assert-error (tn) (lambda () (lambda (x ()) #t)))
+(assert-error (tn) (lambda () (lambda (() x) #t)))
+(assert-true (tn) (lambda (x . ()) #t))
+(assert-error (tn) (lambda () (lambda (() . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y ()) #t)))
+(assert-true (tn) (lambda (x y . ()) #t))
+(assert-error (tn) (lambda () (lambda (x () y) #t)))
+(assert-error (tn) (lambda () (lambda (x () . y) #t)))
+(tn "lambda invalid formals: pair as an arg")
+(assert-error (tn) (lambda () (lambda ((a)) #t)))
+(assert-error (tn) (lambda () (lambda (x (a)) #t)))
+(assert-error (tn) (lambda () (lambda ((a) x) #t)))
+(assert-true (tn) (lambda (x . (a)) #t))
+(assert-error (tn) (lambda () (lambda ((a) . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y (a)) #t)))
+(assert-true (tn) (lambda (x y . (a)) #t))
+(assert-error (tn) (lambda () (lambda (x (a) y) #t)))
+(assert-error (tn) (lambda () (lambda (x (a) . y) #t)))
+(tn "lambda invalid formals: char as an arg")
+(assert-error (tn) (lambda () (lambda (#\a) #t)))
+(assert-error (tn) (lambda () (lambda (x #\a) #t)))
+(assert-error (tn) (lambda () (lambda (#\a x) #t)))
+(assert-error (tn) (lambda () (lambda (x . #\a) #t)))
+(assert-error (tn) (lambda () (lambda (#\a . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y #\a) #t)))
+(assert-error (tn) (lambda () (lambda (x y . #\a) #t)))
+(assert-error (tn) (lambda () (lambda (x #\a y) #t)))
+(assert-error (tn) (lambda () (lambda (x #\a . y) #t)))
+(tn "lambda invalid formals: string as an arg")
+(assert-error (tn) (lambda () (lambda ("a") #t)))
+(assert-error (tn) (lambda () (lambda (x "a") #t)))
+(assert-error (tn) (lambda () (lambda ("a" x) #t)))
+(assert-error (tn) (lambda () (lambda (x . "a") #t)))
+(assert-error (tn) (lambda () (lambda ("a" . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y "a") #t)))
+(assert-error (tn) (lambda () (lambda (x y . "a") #t)))
+(assert-error (tn) (lambda () (lambda (x "a" y) #t)))
+(assert-error (tn) (lambda () (lambda (x "a" . y) #t)))
+(tn "lambda invalid formals: vector as an arg")
+(assert-error (tn) (lambda () (lambda (#(a)) #t)))
+(assert-error (tn) (lambda () (lambda (x #(a)) #t)))
+(assert-error (tn) (lambda () (lambda (#(a) x) #t)))
+(assert-error (tn) (lambda () (lambda (x . #(a)) #t)))
+(assert-error (tn) (lambda () (lambda (#(a) . x) #t)))
+(assert-error (tn) (lambda () (lambda (x y #(a)) #t)))
+(assert-error (tn) (lambda () (lambda (x y . #(a)) #t)))
+(assert-error (tn) (lambda () (lambda (x #(a) y) #t)))
+(assert-error (tn) (lambda () (lambda (x #(a) . y) #t)))
+
;;
;; if
;;
Modified: branches/r5rs/sigscheme/test/test-srfi1.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi1.scm 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm 2006-01-07 01:20:07 UTC (rev 2822)
@@ -1,5 +1,5 @@
;; FileName : test-srfi1.scm
-;; About : unit test for SRFI1
+;; About : unit test for SRFI-1
;;
;; Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
;;
Modified: branches/r5rs/sigscheme/test/test-srfi8.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi8.scm 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/test/test-srfi8.scm 2006-01-07 01:20:07 UTC (rev 2822)
@@ -1,4 +1,39 @@
+;; FileName : test-srfi8.scm
+;; About : unit test for SRFI-8
+;;
+;; Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
(load "./test/unittest.scm")
+
+(define tn test-name)
+
(use srfi-8)
(receive (a b c)
@@ -28,5 +63,108 @@
(assert-equal? "receive test 9" 'global c)
(assert-equal? "receive test 10" 'local var))
+(tn "receive symbol formals (variadic_0)")
+(assert-equal? (tn) '() (receive args (values) args))
+(assert-equal? (tn) '(0) (receive args 0 args))
+(assert-equal? (tn) '(0) (receive args (values 0) args))
+(assert-equal? (tn) '(0) (receive args (values 0) args))
+(assert-equal? (tn) '(0 1) (receive args (values 0 1) args))
+(assert-equal? (tn) '(0 1 2) (receive args (values 0 1 2) args))
+(tn "receive dotted formals variadic_1")
+(assert-error (tn) (lambda () (receive (x . rest) (values) (list x rest))))
+(assert-equal? (tn) '(0 ()) (receive (x . rest) 0 (list x rest)))
+(assert-equal? (tn) '(0 ()) (receive (x . rest) (values 0) (list x rest)))
+(assert-equal? (tn) '(0 ()) (receive (x . rest) (values 0) (list x rest)))
+(assert-equal? (tn) '(0 (1)) (receive (x . rest) (values 0 1) (list x rest)))
+(assert-equal? (tn) '(0 (1 2)) (receive (x . rest) (values 0 1 2)
+ (list x rest)))
+
+(tn "receive dotted formals variadic_2")
+(assert-error (tn) (lambda ()
+ (receive (x y . rest) (values) (list x y rest))))
+(assert-error (tn) (lambda ()
+ (receive (x y . rest) 0 (list x y rest))))
+(assert-error (tn) (lambda ()
+ (receive (x y . rest) (values 0) (list x y rest))))
+(assert-error (tn) (lambda ()
+ (receive (x y . rest) (values 0) (list x y rest))))
+(assert-equal? (tn) '(0 1 ())
+ (receive (x y . rest) (values 0 1) (list x y rest)))
+(assert-equal? (tn) '(0 1 (2))
+ (receive (x y . rest) (values 0 1 2) (list x y rest)))
+(assert-equal? (tn) '(0 1 (2 3))
+ (receive (x y . rest) (values 0 1 2 3) (list x y rest)))
+
+(tn "receive invalid formals: boolean as an arg")
+(assert-error (tn) (lambda () (receive (#t) #t #t)))
+(assert-error (tn) (lambda () (receive (x #t) #t #t)))
+(assert-error (tn) (lambda () (receive (#t x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . #t) #t #t)))
+(assert-error (tn) (lambda () (receive (#t . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y #t) #t #t)))
+(assert-error (tn) (lambda () (receive (x y . #t) #t #t)))
+(assert-error (tn) (lambda () (receive (x #t y) #t #t)))
+(assert-error (tn) (lambda () (receive (x #t . y) #t #t)))
+(tn "receive invalid formals: intger as an arg")
+(assert-error (tn) (lambda () (receive (1) #t #t)))
+(assert-error (tn) (lambda () (receive (x 1) #t #t)))
+(assert-error (tn) (lambda () (receive (1 x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . 1) #t #t)))
+(assert-error (tn) (lambda () (receive (1 . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y 1) #t #t)))
+(assert-error (tn) (lambda () (receive (x y . 1) #t #t)))
+(assert-error (tn) (lambda () (receive (x 1 y) #t #t)))
+(assert-error (tn) (lambda () (receive (x 1 . y) #t #t)))
+(tn "receive invalid formals: null as an arg")
+(assert-error (tn) (lambda () (receive (()) #t #t)))
+(assert-error (tn) (lambda () (receive (x ()) #t #t)))
+(assert-error (tn) (lambda () (receive (() x) #t #t)))
+(assert-true (tn) (receive (x . ()) #t x))
+(assert-error (tn) (lambda () (receive (() . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y ()) #t #t)))
+(assert-error (tn) (lambda () (receive (x y . ()) #t x)))
+(assert-error (tn) (lambda () (receive (x () y) #t #t)))
+(assert-error (tn) (lambda () (receive (x () . y) #t #t)))
+(tn "receive invalid formals: pair as an arg")
+(assert-error (tn) (lambda () (receive ((a)) #t #t)))
+(assert-error (tn) (lambda () (receive (x (a)) #t #t)))
+(assert-error (tn) (lambda () (receive ((a) x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . (a)) #t x)))
+(assert-error (tn) (lambda () (receive ((a) . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y (a)) #t #t)))
+(assert-true (tn) (lambda () (receive (x y . (a)) #t x)))
+(assert-error (tn) (lambda () (receive (x (a) y) #t #t)))
+(assert-error (tn) (lambda () (receive (x (a) . y) #t #t)))
+(tn "receive invalid formals: char as an arg")
+(assert-error (tn) (lambda () (receive (#\a) #t #t)))
+(assert-error (tn) (lambda () (receive (x #\a) #t #t)))
+(assert-error (tn) (lambda () (receive (#\a x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . #\a) #t #t)))
+(assert-error (tn) (lambda () (receive (#\a . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y #\a) #t #t)))
+(assert-error (tn) (lambda () (receive (x y . #\a) #t #t)))
+(assert-error (tn) (lambda () (receive (x #\a y) #t #t)))
+(assert-error (tn) (lambda () (receive (x #\a . y) #t #t)))
+(tn "receive invalid formals: string as an arg")
+(assert-error (tn) (lambda () (receive ("a") #t #t)))
+(assert-error (tn) (lambda () (receive (x "a") #t #t)))
+(assert-error (tn) (lambda () (receive ("a" x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . "a") #t #t)))
+(assert-error (tn) (lambda () (receive ("a" . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y "a") #t #t)))
+(assert-error (tn) (lambda () (receive (x y . "a") #t #t)))
+(assert-error (tn) (lambda () (receive (x "a" y) #t #t)))
+(assert-error (tn) (lambda () (receive (x "a" . y) #t #t)))
+(tn "receive invalid formals: vector as an arg")
+(assert-error (tn) (lambda () (receive (#(a)) #t #t)))
+(assert-error (tn) (lambda () (receive (x #(a)) #t #t)))
+(assert-error (tn) (lambda () (receive (#(a) x) #t #t)))
+(assert-error (tn) (lambda () (receive (x . #(a)) #t #t)))
+(assert-error (tn) (lambda () (receive (#(a) . x) #t #t)))
+(assert-error (tn) (lambda () (receive (x y #(a)) #t #t)))
+(assert-error (tn) (lambda () (receive (x y . #(a)) #t #t)))
+(assert-error (tn) (lambda () (receive (x #(a) y) #t #t)))
+(assert-error (tn) (lambda () (receive (x #(a) . y) #t #t)))
+
(total-report)
Modified: branches/r5rs/sigscheme/test/test-syntax.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-syntax.scm 2006-01-06 23:42:59 UTC (rev 2821)
+++ branches/r5rs/sigscheme/test/test-syntax.scm 2006-01-07 01:20:07 UTC (rev 2822)
@@ -241,6 +241,67 @@
(assert-equal? (tn) '(#t #t (#t)) (f #t #t #t))
(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling fixed_0 for define-created closure")
+(define (f) #t)
+(assert-equal? (tn) #t (f))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-error (tn) (lambda () (f #t)))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-error (tn) (lambda () (f #t #t)))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-error (tn) (lambda () (f #t #t #t)))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling variadic_0 for define-created closure")
+(define (f . args) args)
+(assert-equal? (tn) '() (f))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-equal? (tn) '(#t) (f #t))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-equal? (tn) '(#t #t) (f #t #t))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-equal? (tn) '(#t #t #t) (f #t #t #t))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling fixed_1 for define-created closure")
+(define (f x) x)
+(assert-error (tn) (lambda () (f)))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-equal? (tn) #t (f #t))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-error (tn) (lambda () (f #t #t)))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-error (tn) (lambda () (f #t #t #t)))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling variadic_1 for define-created closure")
+(define (f x . rest) (list x rest))
+(assert-error (tn) (lambda () (f)))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-equal? (tn) '(#t ()) (f #t))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-equal? (tn) '(#t (#t)) (f #t #t))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-equal? (tn) '(#t (#t #t)) (f #t #t #t))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling fixed_2 for define-created closure")
+(define (f x y) (list x y))
+(assert-error (tn) (lambda () (f)))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-error (tn) (lambda () (f #t)))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-equal? (tn) '(#t #t) (f #t #t))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-error (tn) (lambda () (f #t #t #t)))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+(tn "function calling variadic_2 for define-created closure")
+(define (f x y . rest) (list x y rest))
+(assert-error (tn) (lambda () (f)))
+(assert-error (tn) (lambda () (f . #t)))
+(assert-error (tn) (lambda () (f #t)))
+(assert-error (tn) (lambda () (f #t . #t)))
+(assert-equal? (tn) '(#t #t ()) (f #t #t))
+(assert-error (tn) (lambda () (f #t #t . #t)))
+(assert-equal? (tn) '(#t #t (#t)) (f #t #t #t))
+(assert-error (tn) (lambda () (f #t #t #t . #t)))
+
;; Although SigScheme's eval facility itself does not ensure properness of
;; syntax args, each syntax implementation must check it. These tests only
;; indicate what should be done.
More information about the uim-commit
mailing list