[uim-commit] r1243 - in branches/r5rs: sigscheme sigscheme/test uim
kzk at freedesktop.org
kzk at freedesktop.org
Sun Aug 21 02:56:54 EST 2005
Author: kzk
Date: 2005-08-20 09:56:51 -0700 (Sat, 20 Aug 2005)
New Revision: 1243
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/bigloo-bchar.scm
branches/r5rs/sigscheme/test/test-define.scm
branches/r5rs/uim/uim-compat-scm.c
Log:
* more appropriate support for dot list argument
This is for getting slib's "fold" working
* simplify "symbol-value"
* sigscheme/test/test-define.scm
- add testcase for assignment for dot list arg
* sigscheme/test/bigloo-bchar.scm
- comment out some testcase not supported now
* sigscheme/eval.c
- (extend_environment): change to create new value for dot list
arg
- (lookup_frame): doesn't create new cons cell, because it cannot
handle "assignment".
- (ScmExp_set): set new env
- (ScmOp_symbol_value): change args
* sigscheme/sigscheme.c
- (SigScm_Initialize): export "symbol-value" as FUNCTYPE_1
* sigscheme/sigscheme.h
- (ScmOp_symbol_value): change args
* uim/uim-compat-scm.c
- (uim_scm_symbol_value): change args of ScmOp_symbol_value
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/sigscheme/eval.c 2005-08-20 16:56:51 UTC (rev 1243)
@@ -95,8 +95,26 @@
static ScmObj extend_environment(ScmObj vars, ScmObj vals, ScmObj env)
{
- ScmObj frame = SCM_NIL;
+ ScmObj frame = SCM_NIL;
+ ScmObj tmp_vars = vars;
+ ScmObj tmp_vals = vals;
+ /* handle dot list */
+ while (1) {
+ if (SCM_NULLP(tmp_vars) || !SCM_CONSP(tmp_vars))
+ break;
+
+ /* dot list appears */
+ if (!SCM_NULLP(SCM_CDR(tmp_vars)) && !SCM_CONSP(SCM_CDR(tmp_vars))) {
+ /* create new value */
+ SCM_SETCDR(tmp_vals, Scm_NewCons(SCM_CDR(tmp_vals),
+ SCM_NIL));
+ }
+
+ tmp_vars = SCM_CDR(tmp_vars);
+ tmp_vals = SCM_CDR(tmp_vals);
+ }
+
/* create new frame */
frame = Scm_NewCons(vars, vals);
@@ -185,17 +203,24 @@
vars = SCM_CAR(frame);
vals = SCM_CDR(frame);
- for (; !SCM_NULLP(vars); vars = SCM_CDR(vars), vals = SCM_CDR(vals)) {
- /* handle dot list */
- if (SCM_CONSP(vars)) {
- if (SCM_EQ(SCM_CAR(vars), var))
- return vals;
- } else {
- if (SCM_EQ(vars, var))
- return Scm_NewCons(vals, SCM_NIL);
- else
- return SCM_NIL;
- }
+ while (1) {
+ if (SCM_NULLP(vars))
+ break;
+
+ if (!SCM_CONSP(vars)) {
+ /* handle dot list */
+ if (SCM_EQ(vars, var))
+ return vals;
+
+ break;
+ } else {
+ /* normal binding */
+ if (SCM_EQ(SCM_CAR(vars), var))
+ return vals;
+ }
+
+ vars = SCM_CDR(vars);
+ vals = SCM_CDR(vals);
}
return SCM_NIL;
@@ -1016,6 +1041,9 @@
SCM_SETCAR(tmp, ret);
}
+ /* set new env */
+ *envp = env;
+
return ret;
}
@@ -1667,14 +1695,12 @@
return SCM_FALSE;
}
-ScmObj ScmOp_symbol_value(ScmObj arg, ScmObj env)
+ScmObj ScmOp_symbol_value(ScmObj var)
{
- ScmObj var = SCM_CAR(arg);
-
if (!SCM_SYMBOLP(var))
SigScm_ErrorObj("symbol-value : require symbol but got ", var);
- return symbol_value(var, env);
+ return symbol_value(var, SCM_NIL);
}
ScmObj ScmOp_set_symbol_value(ScmObj var, ScmObj val)
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-20 16:56:51 UTC (rev 1243)
@@ -136,7 +136,7 @@
Scm_RegisterFunc1("null-environment" , ScmOp_null_environment);
/* SIOD compatible functions */
Scm_RegisterFunc1("symbol-bound?" , ScmOp_symbol_boundp);
- Scm_RegisterFuncL("symbol-value" , ScmOp_symbol_value);
+ Scm_RegisterFunc1("symbol-value" , ScmOp_symbol_value);
Scm_RegisterFunc2("set-symbol-value!" , ScmOp_set_symbol_value);
Scm_RegisterFunc2("bit-and" , ScmOp_bit_and);
Scm_RegisterFunc2("bit-or" , ScmOp_bit_or);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-20 16:56:51 UTC (rev 1243)
@@ -181,7 +181,7 @@
ScmObj ScmOp_null_environment(ScmObj version);
/* SIOD compatible functions */
ScmObj ScmOp_symbol_boundp(ScmObj obj);
-ScmObj ScmOp_symbol_value(ScmObj var, ScmObj env);
+ScmObj ScmOp_symbol_value(ScmObj var);
ScmObj ScmOp_set_symbol_value(ScmObj var, ScmObj val);
ScmObj ScmOp_bit_and(ScmObj obj1, ScmObj obj2);
ScmObj ScmOp_bit_or(ScmObj obj1, ScmObj obj2);
Modified: branches/r5rs/sigscheme/test/bigloo-bchar.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-bchar.scm 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/sigscheme/test/bigloo-bchar.scm 2005-08-20 16:56:51 UTC (rev 1243)
@@ -40,9 +40,9 @@
(test "char-upper-case?" (char-upper-case? #\a) #f)
(test "char-lower-case?" (char-lower-case? #\A) #f)
(test "char-lower-case?" (char-lower-case? #\a) #t)
- (test "char->integer" (char->integer #\0) 48)
+; (test "char->integer" (char->integer #\0) 48)
; (test "char->integer" (char->integer #a200) 200)
- (test "integer->char" (integer->char 48) #\0)
+; (test "integer->char" (integer->char 48) #\0)
(test "char-upcase" (char-upcase #\a) #\A)
(test "char-upcase" (char-upcase #\A) #\A)
(test "char-downcase" (char-downcase #\a) #\a)
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/sigscheme/test/test-define.scm 2005-08-20 16:56:51 UTC (rev 1243)
@@ -1,4 +1,3 @@
-
(load "./test/unittest.scm")
; basic define
@@ -68,3 +67,11 @@
(assert-eq? "internal define2" 17 (idefine0 0))
(total-report)
+
+
+; set!
+(define (set-dot a . b)
+ (set! b '(1 2))
+ b)
+
+(assert-equal? "set dot test" '(1 2) (set-dot '()))
Modified: branches/r5rs/uim/uim-compat-scm.c
===================================================================
--- branches/r5rs/uim/uim-compat-scm.c 2005-08-20 09:18:36 UTC (rev 1242)
+++ branches/r5rs/uim/uim-compat-scm.c 2005-08-20 16:56:51 UTC (rev 1243)
@@ -155,9 +155,7 @@
uim_lisp
uim_scm_symbol_value(const char *symbol_str)
{
- return (uim_lisp)ScmOp_symbol_value(Scm_NewCons(Scm_Intern(symbol_str),
- SigScm_nil),
- SigScm_nil);
+ return (uim_lisp)ScmOp_symbol_value(Scm_Intern(symbol_str));
}
uim_lisp
More information about the uim-commit
mailing list