[uim-commit] r2832 - in branches/r5rs/sigscheme: . test
jun0 at freedesktop.org
jun0 at freedesktop.org
Fri Jan 6 23:51:05 PST 2006
Author: jun0
Date: 2006-01-06 23:51:02 -0800 (Fri, 06 Jan 2006)
New Revision: 2832
Modified:
branches/r5rs/sigscheme/env.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/io.c
branches/r5rs/sigscheme/operations-nonstd.c
branches/r5rs/sigscheme/operations-siod.c
branches/r5rs/sigscheme/operations-srfi2.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigschemeinternal.h
branches/r5rs/sigscheme/storage-continuation.c
branches/r5rs/sigscheme/syntax.c
branches/r5rs/sigscheme/test/test-exp.scm
Log:
Addition of FOR_EACH() and simplification of POP_ARG().
* sigscheme/sigschemeinternal.h
- (POP_ARG): rename to SAFE_POP().
- (POP, SAFE_POP, FOR_EACH_WHILE, FOR_EACH, FOR_EACH_PAIR): new macros.
* sigscheme/operations-srfi2.c
- (scm_s_srfi2_and_letstar): follow change in sigschemeinternal.h.
* sigscheme/io.c
- (prepare_port): ditto.
* sigscheme/storage-continuation.c
- (enter_dynamic_extent): ditto.
* sigscheme/operations.c
- (prepare_radix, scm_p_append, scm_p_append, scm_p_make_string, scm_p_list2vector, map_single_arg): ditto.
* sigscheme/operations-nonstd.c
- (scm_p_symbol_boundp): ditto.
* sigscheme/env.c
- (scm_validate_formals): ditto.
* sigscheme/operations-siod.c
- (scm_p_verbose): ditto.
* sigscheme/syntax.c
- (scm_s_if, scm_s_and, scm_s_or, scm_s_let, scm_s_begin, scm_s_do): ditto.
* sigscheme/eval.c
- (reduce, map_eval): ditto.
* sigscheme/test/test-exp.scm
- add new test.
Modified: branches/r5rs/sigscheme/env.c
===================================================================
--- branches/r5rs/sigscheme/env.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/env.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -271,14 +271,13 @@
scm_validate_formals(ScmObj formals)
{
#if SCM_STRICT_ARGCHECK
- ScmObj var;
int len;
DECLARE_INTERNAL_FUNCTION("scm_validate_formals");
/* This loop goes infinite if the formals is circular. SigSchme expects
* that user codes are sane here. */
- for (len = 0; var = POP_ARG(formals), VALIDP(var); len++) {
- if (!SYMBOLP(var))
+ for (len = 0; formals = CDR(formals); len++) {
+ if (!SYMBOLP(CAR(formals)))
return SCM_LISTLEN_ENCODE_ERROR(len);
}
if (NULLP(formals))
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/eval.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -144,20 +144,24 @@
enum ScmReductionState state;
DECLARE_INTERNAL_FUNCTION("(reduction)");
- state = SCM_REDUCE_0;
- if (NO_MORE_ARG(args))
+ if (!CONSP(args)) {
+ state = SCM_REDUCE_0;
return (*func)(SCM_INVALID, SCM_INVALID, &state);
+ }
state = SCM_REDUCE_1;
- left = POP_ARG(args);
+ left = POP(args);
if (!suppress_eval)
left = EVAL(left, env);
- if (NO_MORE_ARG(args))
+
+ if (!CONSP(args)) {
+ state = SCM_REDUCE_1;
return (*func)(left, left, &state);
+ }
- /* Reduce upto all but the last argument. */
+ /* Reduce upto the penult. */
state = SCM_REDUCE_PARTWAY;
- while (right = POP_ARG(args), !NO_MORE_ARG(args)) {
+ FOR_EACH_WHILE (right, args, CONSP(CDR(args))) {
if (!suppress_eval)
right = EVAL(right, env);
left = (*func)(left, right, &state);
@@ -167,6 +171,7 @@
/* Make the last call. */
state = SCM_REDUCE_LAST;
+ right = CAR(args);
if (!suppress_eval)
right = EVAL(right, env);
return (*func)(left, right, &state);
@@ -445,9 +450,10 @@
/* More than one argument given. */
args = LIST_1(arg0);
q = REF_CDR(args);
- while (arg = POP_ARG(rest), !NO_MORE_ARG(rest))
+ FOR_EACH_WHILE (arg, rest, CONSP(CDR(rest)))
SCM_QUEUE_ADD(q, arg);
/* The last one is spliced. */
+ arg = POP(rest);
SCM_QUEUE_SLOPPY_APPEND(q, arg);
last = arg;
}
@@ -473,8 +479,10 @@
res = SCM_NULL;
SCM_QUEUE_POINT_TO(q, res);
- /* does not use POP_ARG() to increace performance */
- for (len = 0, rest = args; CONSP(rest); len++, rest = CDR(rest)) {
+
+ len = 0;
+ FOR_EACH_PAIR (rest, args) {
+ len++;
elm = EVAL(CAR(rest), env);
#if SCM_STRICT_ARGCHECK
if (VALUEPACKETP(elm))
Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/io.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -118,10 +118,12 @@
ScmObj port;
DECLARE_INTERNAL_FUNCTION("prepare_port");
- port = POP_ARG(args);
- if (!VALIDP(port))
+ if (CONSP(args)) {
+ port = POP(args);
+ ENSURE_PORT(port);
+ } else {
port = default_port;
- ENSURE_PORT(port);
+ }
ASSERT_NO_MORE_ARG(args);
return port;
Modified: branches/r5rs/sigscheme/operations-nonstd.c
===================================================================
--- branches/r5rs/sigscheme/operations-nonstd.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/operations-nonstd.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -93,11 +93,12 @@
ENSURE_SYMBOL(sym);
- env = POP_ARG(rest);
- if (VALIDP(env))
+ if (CONSP(env)) {
+ env = POP(rest);
ENSURE_ENV(env);
- else
+ } else {
env = SCM_INTERACTION_ENV;
+ }
ref = scm_lookup_environment(sym, env);
return MAKE_BOOL(ref != SCM_INVALID_REF || SCM_SYMBOL_BOUNDP(sym));
Modified: branches/r5rs/sigscheme/operations-siod.c
===================================================================
--- branches/r5rs/sigscheme/operations-siod.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/operations-siod.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -202,7 +202,8 @@
ScmObj level;
DECLARE_FUNCTION("verbose", procedure_variadic_0);
- if (level = POP_ARG(args), VALIDP(level)) {
+ if (CONSP(args)) {
+ level = POP(args);
ENSURE_INT(level);
scm_set_verbose_level(SCM_INT_VALUE(level));
Modified: branches/r5rs/sigscheme/operations-srfi2.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi2.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/operations-srfi2.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -84,7 +84,7 @@
| <bound-variable>
========================================================================*/
if (CONSP(claws)) {
- while (claw = POP_ARG(claws), VALIDP(claw)) {
+ FOR_EACH (claw, claws) {
if (CONSP(claw)) {
if (NULLP(CDR(claw))) {
/* (<expression>) */
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/operations.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -556,7 +556,8 @@
/* dirty hack to replace internal function name */
SCM_MANGLE(name) = funcname;
- if (radix = POP_ARG(args), VALIDP(radix)) {
+ if (CONSP(args)) {
+ radix = POP(args);
ASSERT_NO_MORE_ARG(args);
ENSURE_INT(radix);
r = SCM_INT_VALUE(radix);
@@ -897,7 +898,7 @@
scm_p_append(ScmObj args)
{
ScmQueue q;
- ScmObj elm_lst, res;
+ ScmObj elm_lst, res, tmp;
DECLARE_FUNCTION("append", procedure_variadic_0);
if (NULLP(args))
@@ -906,13 +907,14 @@
res = SCM_NULL;
SCM_QUEUE_POINT_TO(q, res);
/* duplicate and merge all but the last argument */
- while (elm_lst = POP_ARG(args), !NO_MORE_ARG(args)) {
- for (; CONSP(elm_lst); elm_lst = CDR(elm_lst))
- SCM_QUEUE_ADD(q, CAR(elm_lst));
+ FOR_EACH_WHILE (elm_lst, args, CONSP(CDR(args))) {
+ FOR_EACH (tmp, elm_lst)
+ SCM_QUEUE_ADD(q, tmp);
ENSURE_PROPER_LIST_TERMINATION(elm_lst, args);
}
+ tmp = POP(args);
/* append the last argument */
- SCM_QUEUE_SLOPPY_APPEND(q, elm_lst);
+ SCM_QUEUE_SLOPPY_APPEND(q, tmp);
return res;
}
@@ -1263,7 +1265,7 @@
if (NO_MORE_ARG(args)) {
filler_val = ' ';
} else {
- filler = POP_ARG(args);
+ filler = POP(args);
ASSERT_NO_MORE_ARG(args);
ENSURE_CHAR(filler);
filler_val = SCM_CHAR_VALUE(filler);
@@ -1710,7 +1712,7 @@
vec = scm_malloc(sizeof(ScmObj) * len);
for (i = 0; i < len; i++)
- vec[i] = POP_ARG(lst);
+ vec[i] = POP(lst);
return MAKE_VECTOR(vec, len);
}
@@ -1768,8 +1770,7 @@
res = SCM_NULL;
SCM_QUEUE_POINT_TO(q, res);
- while (!NO_MORE_ARG(lst)) {
- elm = POP_ARG(lst);
+ FOR_EACH (elm, lst) {
elm = scm_call(proc, LIST_1(elm));
SCM_QUEUE_ADD(q, elm);
}
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2006-01-07 07:51:02 UTC (rev 2832)
@@ -295,20 +295,28 @@
#define ASSERT_PROPER_ARG_LIST(args)
#endif /* not SCM_STRICT_ARGCHECK */
-/* Destructively retreives the first element of an argument list. If
- * ARGS doesn't contain enough arguments, return SCM_INVALID. */
-#define POP_ARG(args) \
- (CONSP(args) \
- ? (SCM_MANGLE(tmp) = CAR(args), (args) = CDR(args), SCM_MANGLE(tmp)) \
- : SCM_INVALID)
+/* Destructively retreives the first element of a list. */
+#define POP(_lst) \
+ (SCM_MANGLE(tmp) = CAR(_lst), (_lst) = CDR(_lst), SCM_MANGLE(tmp))
-/* Like POP_ARG(), but signals an error if no argument is
- available. */
+/* POP() with safety check. */
+#define SAFE_POP(_lst) \
+ (CONSP((_lst)) ? POP((_lst)) : SCM_INVALID)
+
+/* Like POP(), but signals an error if no argument is available. */
#define MUST_POP_ARG(args) \
(CONSP(args) \
? (SCM_MANGLE(tmp) = CAR(args), (args) = CDR(args), SCM_MANGLE(tmp)) \
: (ERR("missing argument(s)"), NULL))
+#define FOR_EACH_WHILE(_kar, _lst, _cond) \
+ while ((_cond) && ((_kar) = POP((_lst)), 1))
+
+#define FOR_EACH(_kar, _lst) FOR_EACH_WHILE((_kar), (_lst), CONSP(_lst))
+
+#define FOR_EACH_PAIR(_subls, _lst) \
+ for ((_subls) = (_lst); CONSP((_subls)); (_subls) = CDR(_subls))
+
#define ENSURE_TYPE(pred, typename, obj) \
(pred(obj) || (ERR_OBJ(typename " required but got", (obj)), 1))
Modified: branches/r5rs/sigscheme/storage-continuation.c
===================================================================
--- branches/r5rs/sigscheme/storage-continuation.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/storage-continuation.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -168,9 +168,8 @@
retpath = CONS(frame, retpath);
}
- while (frame = POP_ARG(retpath), VALIDP(frame)) {
+ FOR_EACH (frame, retpath)
scm_call(DYNEXT_FRAME_BEFORE(frame), SCM_NULL);
- }
}
/* exit to a dynamic extent of another continuation (dest) */
Modified: branches/r5rs/sigscheme/syntax.c
===================================================================
--- branches/r5rs/sigscheme/syntax.c 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/syntax.c 2006-01-07 07:51:02 UTC (rev 2832)
@@ -394,16 +394,14 @@
if (test = EVAL(test, env), NFALSEP(test)) {
#if SCM_STRICT_ARGCHECK
- POP_ARG(rest);
+ SAFE_POP(rest);
ASSERT_NO_MORE_ARG(rest);
#endif
return conseq;
} else {
- /* does not use POP_ARG() for efficiency since 'if' syntax is
- frequently used */
alt = (CONSP(rest)) ? CAR(rest) : SCM_UNDEF;
#if SCM_STRICT_ARGCHECK
- POP_ARG(rest);
+ SAFE_POP(rest);
ASSERT_NO_MORE_ARG(rest);
#endif
return alt;
@@ -480,7 +478,7 @@
ERR("cond: syntax error: at least one clause required");
/* looping in each clause */
- while (clause = POP_ARG(args), VALIDP(clause)) {
+ FOR_EACH (clause, args) {
if (!CONSP(clause))
ERR_OBJ("bad clause", clause);
@@ -583,7 +581,7 @@
if (NO_MORE_ARG(args))
return SCM_TRUE;
- while (expr = POP_ARG(args), !NO_MORE_ARG(args)) {
+ FOR_EACH_WHILE (expr, args, CONSP(CDR(args))) {
val = EVAL(expr, eval_state->env);
if (FALSEP(val)) {
ASSERT_PROPER_ARG_LIST(args);
@@ -591,6 +589,8 @@
return SCM_FALSE;
}
}
+ expr = POP(args);
+ ASSERT_NO_MORE_ARG(args);
return expr;
}
@@ -604,7 +604,7 @@
if (NO_MORE_ARG(args))
return SCM_FALSE;
- while (expr = POP_ARG(args), !NO_MORE_ARG(args)) {
+ FOR_EACH (expr, args) {
val = EVAL(expr, eval_state->env);
if (!FALSEP(val)) {
ASSERT_PROPER_ARG_LIST(args);
@@ -658,7 +658,7 @@
if (!CONSP(args))
ERR("let: invalid form");
- bindings = POP_ARG(args);
+ bindings = POP(args);
/* named let */
if (SYMBOLP(bindings)) {
@@ -666,15 +666,14 @@
if (!CONSP(args))
ERR("let: invalid named let form");
- bindings = POP_ARG(args);
+ bindings = POP(args);
}
body = args;
SCM_QUEUE_POINT_TO(varq, formals);
SCM_QUEUE_POINT_TO(valq, actuals);
- for (; CONSP(bindings); bindings = CDR(bindings)) {
- binding = CAR(bindings);
+ FOR_EACH (binding, bindings) {
#if SCM_COMPAT_SIOD_BUGS
/* temporary solution. the inefficiency is not a problem */
if (LIST_1_P(binding))
@@ -812,9 +811,13 @@
if (NO_MORE_ARG(args))
return SCM_UNDEF;
- while (expr = POP_ARG(args), !NO_MORE_ARG(args))
+ FOR_EACH_WHILE(expr, args, CONSP(CDR(args)))
EVAL(expr, eval_state->env);
+ expr = POP(args);
+
+ ASSERT_NO_MORE_ARG(args);
+
/* Return tail expression. */
return expr;
}
@@ -846,16 +849,15 @@
ScmObj steps = SCM_NULL;
ScmObj test = SCM_FALSE;
ScmObj expression = SCM_FALSE;
- ScmObj tmp_steps = SCM_FALSE;
ScmObj tmp_vars = SCM_FALSE;
+ ScmObj tmp;
ScmRef obj;
DECLARE_FUNCTION("do", syntax_variadic_tailrec_2);
/* construct Environment and steps */
- for (; !NULLP(bindings); bindings = CDR(bindings)) {
- binding = CAR(bindings);
+ FOR_EACH (binding, bindings) {
if (NULLP(binding))
- ERR("invalid bindings");
+ ERR("invalid binding");
var = MUST_POP_ARG(binding);
ENSURE_SYMBOL(var);
@@ -869,7 +871,7 @@
if (NO_MORE_ARG(binding))
steps = CONS(var, steps);
else
- steps = CONS(POP_ARG(binding), steps);
+ steps = CONS(POP(binding), steps);
ASSERT_NO_MORE_ARG(binding);
}
@@ -896,12 +898,8 @@
* results to the "vals" variable and set it in hand.
*/
vals = SCM_NULL;
- for (tmp_steps = steps;
- !NULLP(tmp_steps);
- tmp_steps = CDR(tmp_steps))
- {
- vals = CONS(EVAL(CAR(tmp_steps), env), vals);
- }
+ FOR_EACH_PAIR (tmp, steps)
+ vals = CONS(EVAL(CAR(tmp), env), vals);
vals = scm_p_reverse(vals);
/* set it */
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2006-01-07 06:19:05 UTC (rev 2831)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2006-01-07 07:51:02 UTC (rev 2832)
@@ -483,6 +483,7 @@
(assert-equal? "and test 2" #f (and (= 2 2) (< 2 1)))
(assert-equal? "and test 3" '(f g) (and 1 2 'c '(f g)))
(assert-equal? "and test 4" #t (and))
+(assert-equal? "and test 5" #f (and #t #f))
;;
;; or
More information about the uim-commit
mailing list