[uim-commit] r1704 - in branches/r5rs/sigscheme: . test

[yamaken at freedesktop.org]

Author: yamaken
Date: 2005-09-30 10:32:49 -0700 (Fri, 30 Sep 2005)
New Revision: 1704

Modified:
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/sigschemeinternal.h
   branches/r5rs/sigscheme/sigschemetype.h
   branches/r5rs/sigscheme/test/test-exp.scm
Log:
* sigscheme/sigschemetype.h
  - (SCM_SYNTAXP): New macro
* sigscheme/sigschemeinternal.h
  - (SYNTAXP): New macro
* sigscheme/operations.c
  - (ScmOp_procedurep): Fix invalid test for syntax and cotinuation
* sigscheme/test/test-exp.scm
  - Add tests for 'procedure?'


Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2005-09-30 17:02:59 UTC (rev 1703)
+++ branches/r5rs/sigscheme/operations.c	2005-09-30 17:32:49 UTC (rev 1704)
@@ -1649,7 +1649,8 @@
 =======================================*/
 ScmObj ScmOp_procedurep(ScmObj obj)
 {
-    return (FUNCP(obj) || CLOSUREP(obj)) ? SCM_TRUE : SCM_FALSE;
+    return ((FUNCP(obj) && !SYNTAXP(obj))
+            || CLOSUREP(obj) || CONTINUATIONP(obj)) ? SCM_TRUE : SCM_FALSE;
 }
 
 ScmObj ScmOp_map(ScmObj proc, ScmObj args)

Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h	2005-09-30 17:02:59 UTC (rev 1703)
+++ branches/r5rs/sigscheme/sigschemeinternal.h	2005-09-30 17:32:49 UTC (rev 1704)
@@ -136,6 +136,7 @@
 #define CHARP          SCM_CHARP
 #define STRINGP        SCM_STRINGP
 #define FUNCP          SCM_FUNCP
+#define SYNTAXP        SCM_SYNTAXP
 #define CLOSUREP       SCM_CLOSUREP
 #define VECTORP        SCM_VECTORP
 #define PORTP          SCM_PORTP

Modified: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h	2005-09-30 17:02:59 UTC (rev 1703)
+++ branches/r5rs/sigscheme/sigschemetype.h	2005-09-30 17:32:49 UTC (rev 1704)
@@ -341,6 +341,8 @@
 #define SCM_FUNC_SET_TYPECODE(a, type) (SCM_FUNC_TYPECODE(a) = (type))
 #define SCM_FUNC_CFUNC(a)   (SCM_AS_FUNC(a)->obj.func.func)
 #define SCM_FUNC_SET_CFUNC(a, func)     (SCM_FUNC_CFUNC(a) = (ScmFuncType)(func))
+#define SCM_SYNTAXP(a) (SCM_FUNCP(a)                                         \
+                        && (SCM_FUNC_TYPECODE(a) & SCM_FUNCTYPE_SYNTAX))
 
 #define SCM_CLOSUREP(a) (SCM_TYPE(a) == ScmClosure)
 #define SCM_ENTYPE_CLOSURE(a) (SCM_ENTYPE((a), ScmClosure))

Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm	2005-09-30 17:02:59 UTC (rev 1703)
+++ branches/r5rs/sigscheme/test/test-exp.scm	2005-09-30 17:32:49 UTC (rev 1704)
@@ -209,6 +209,14 @@
 (assert-equal? "do test4" '(c b a) (nreverse '(a b c)))
 (assert-equal? "do test5" '((5 6) (3 4) (1 2)) (nreverse '((1 2) (3 4) (5 6))))
 
+(assert-true  "procedure? #1" (procedure? even?))
+(assert-true  "procedure? #2" (procedure? (lambda (x) x)))
+(assert-true  "procedure? #3" (procedure? (call-with-current-continuation
+                                           (lambda (c)
+                                             c))))
+(assert-false "procedure? #4" (procedure? if))
+(assert-false "procedure? #5" (procedure? quote))
+
 ;; from R5RS
 (assert-equal? "call-with-values #1"
                5