[uim-commit] r2804 - branches/r5rs/sigscheme

[yamaken at freedesktop.org]

Author: yamaken
Date: 2006-01-06 04:04:06 -0800 (Fri, 06 Jan 2006)
New Revision: 2804

Modified:
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/sigscheme.h
   branches/r5rs/sigscheme/sigschemeinternal.h
Log:
* sigscheme/sigscheme.h
  - (SCM_ERRMSG_IMPROPER_ARGS, SCM_PROPER_LISTP): New macro
* sigscheme/sigschemeinternal.h
  - (PROPER_LISTP): New macro
* sigscheme/eval.c
  - (scm_tailcall, scm_call): Add proper list assertion for args
  - (call): Add properness check for syntax args, but disabled. See
    the comment for further details
  - (map_eval): Reject improper list


Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2006-01-06 11:54:06 UTC (rev 2803)
+++ branches/r5rs/sigscheme/eval.c	2006-01-06 12:04:06 UTC (rev 2804)
@@ -100,6 +100,8 @@
 ScmObj
 scm_tailcall(ScmObj proc, ScmObj args, ScmEvalState *eval_state)
 {
+    SCM_ASSERT(PROPER_LISTP(args));
+
     eval_state->ret_type = SCM_RETTYPE_AS_IS;
     return call(proc, args, eval_state, SUPPRESS_EVAL_ARGS);
 }
@@ -113,6 +115,8 @@
     ScmEvalState state;
     ScmObj ret;
 
+    SCM_ASSERT(PROPER_LISTP(args));
+
     /* We don't need a nonempty environemnt, because this function
      * will never be called directly from Scheme code.  If PROC is a
      * closure, it'll have its own environment, if it's a syntax, it's
@@ -231,6 +235,7 @@
     ScmObj env, cont;
     ScmObj (*func)();
     enum ScmFuncTypeCode type;
+    scm_bool syntaxp;
     int mand_count, i;
     /* The +2 is for rest and env/eval_state. */
     void *argbuf[SCM_FUNCTYPE_MAND_MAX + 2];
@@ -265,11 +270,12 @@
         return reduce(func, args, env, suppress_eval);
 
     /* Suppress argument evaluation for syntaxes. */
+    syntaxp = type & SCM_FUNCTYPE_SYNTAX;
     if (suppress_eval) {
-        if (type & SCM_FUNCTYPE_SYNTAX)
+        if (syntaxp)
             ERR_OBJ("can't apply/map a syntax", proc);
     } else {
-        suppress_eval = type & SCM_FUNCTYPE_SYNTAX;
+        suppress_eval = syntaxp;
     }
 
     /* Collect mandatory arguments. */
@@ -288,6 +294,12 @@
     if (type & SCM_FUNCTYPE_VARIADIC) {
         if (!suppress_eval)
             args = map_eval(args, env);
+#if 0
+        /* Since this check is expensive, each syntax should do. Other
+         * procedures are already ensured that having proper args here. */
+        else if (syntaxp && !PROPER_LISTP(args))
+            ERR(SCM_ERRMSG_IMPROPER_ARGS, args);
+#endif
         argbuf[i++] = args;
     } else {
         ASSERT_NO_MORE_ARG(args);
@@ -417,7 +429,7 @@
 map_eval(ScmObj args, ScmObj env)
 {
     ScmQueue q;
-    ScmObj res, elm;
+    ScmObj res, elm, rest;
     DECLARE_INTERNAL_FUNCTION("(function call)");
 
     if (NULLP(args))
@@ -426,19 +438,16 @@
     res = SCM_NULL;
     SCM_QUEUE_POINT_TO(q, res);
     /* does not use POP_ARG() to increace performance */
-    for (; CONSP(args); args = CDR(args)) {
-        elm = EVAL(CAR(args), env);
+    for (rest = args; CONSP(rest); rest = CDR(rest)) {
+        elm = EVAL(CAR(rest), env);
 #if SCM_STRICT_ARGCHECK
         if (VALUEPACKETP(elm))
             ERR_OBJ("multiple values are not allowed here", elm);
 #endif
         SCM_QUEUE_ADD(q, elm);
     }
-    /* dot list */
-    if (!NULLP(args)) {
-        elm = EVAL(args, env);
-        SCM_QUEUE_SLOPPY_APPEND(q, elm);
-    }
+    if (!NULLP(rest))
+        ERR(SCM_ERRMSG_IMPROPER_ARGS, args);
 
     return res;
 }

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2006-01-06 11:54:06 UTC (rev 2803)
+++ branches/r5rs/sigscheme/sigscheme.h	2006-01-06 12:04:06 UTC (rev 2804)
@@ -57,6 +57,8 @@
 =======================================*/
 #define SCM_ERRMSG_UNHANDLED_EXCEPTION "unhandled exception"
 #define SCM_ERRMSG_MEMORY_EXHAUSTED    "memory exhausted"
+#define SCM_ERRMSG_IMPROPER_ARGS                                             \
+    "proper list required for function call but got"
 
 #ifdef __GNUC__
 #define SCM_NOINLINE __attribute__((noinline))
@@ -149,6 +151,8 @@
 #define SCM_LIST_4_P(lst) (SCM_CONSP(lst) && SCM_LIST_3_P(SCM_CDR(lst)))
 #define SCM_LIST_5_P(lst) (SCM_CONSP(lst) && SCM_LIST_4_P(SCM_CDR(lst)))
 
+#define SCM_PROPER_LISTP(obj) (0 <= scm_length(obj))
+
 #define SCM_EVAL(obj, env) (scm_eval((obj), (env)))
 
 #if SCM_GCC4_READY_GC

Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-06 11:54:06 UTC (rev 2803)
+++ branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-06 12:04:06 UTC (rev 2804)
@@ -219,6 +219,7 @@
 #define LIST_3_P       SCM_LIST_3_P
 #define LIST_4_P       SCM_LIST_4_P
 #define LIST_5_P       SCM_LIST_5_P
+#define PROPER_LISTP   SCM_PROPER_LISTP
 
 #define CDBG           SCM_CDBG
 #define DBG            SCM_DBG