Author: kzk
Date: Thu Aug 11 21:31:01 2005
New Revision: 1187
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/read.c
branches/r5rs/sigscheme/test/test-r4rs.scm
Log:
* bug fixes
* sigscheme/read.c
- (read_list): handle the symbol which starts with dot('.').
This code is originally proposed from Jun Inoue <[EMAIL PROTECTED]>
* sigscheme/eval.c
- (eval_unquote): handle () correctly
- (ScmExp_case): don't evaluate datums
- (ScmExp_let, ScmExp_let_star, ScmExp_letrec)
: handle when bindings is null list.
Modified: branches/r5rs/sigscheme/eval.c
==============================================================================
--- branches/r5rs/sigscheme/eval.c (original)
+++ branches/r5rs/sigscheme/eval.c Thu Aug 11 21:31:01 2005
@@ -687,6 +687,12 @@
/* handle SCM_UNQUOTE_SPLICING(,@) */
if (EQ(SCM_CAR(obj), SCM_UNQUOTE_SPLICING)) {
obj = ScmOp_eval(SCM_CDR(obj), env);
+
+ if (SCM_NULLP(obj)) {
+ SCM_SETCDR(prev, SCM_CDR(SCM_CDR(prev)));
+ continue;
+ }
+
if (!SCM_CONSP(obj))
SigScm_Error("invalid unquote-splicing (,@)\n");
@@ -912,7 +918,7 @@
/* evaluate datums and compare to key by eqv? */
for (; !SCM_NULLP(datums); datums = SCM_CDR(datums)) {
- if (EQ(ScmOp_eqvp(ScmOp_eval(SCM_CAR(datums), env), key),
SCM_TRUE)) {
+ if (EQ(ScmOp_eqvp(SCM_CAR(datums), key), SCM_TRUE)) {
return ScmExp_begin(exps, &env, tail_flag);
}
}
@@ -1023,7 +1029,7 @@
(<variable2> <init2>)
...)
========================================================================*/
- if (SCM_CONSP(bindings)) {
+ if (SCM_CONSP(bindings) || SCM_NULLP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
vars = Scm_NewCons(SCM_CAR(binding), vars);
@@ -1037,6 +1043,8 @@
return ScmExp_begin(body, &env, tail_flag);
}
+ return ScmExp_begin(body, &env, tail_flag);
+
named_let:
/*========================================================================
(let <variable> <bindings> <body>)
@@ -1091,7 +1099,7 @@
(<variable2> <init2>)
...)
========================================================================*/
- if (SCM_CONSP(bindings)) {
+ if (SCM_CONSP(bindings) || SCM_NULLP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
@@ -1115,18 +1123,18 @@
ScmObj ScmExp_letrec(ScmObj arg, ScmObj *envp, int *tail_flag)
{
- ScmObj env = *envp;
- ScmObj bindings = SCM_NIL;
- ScmObj body = SCM_NIL;
- ScmObj vars = SCM_NIL;
- ScmObj vals = SCM_NIL;
- ScmObj binding = SCM_NIL;
- ScmObj var = SCM_NIL;
- ScmObj val = SCM_NIL;
- ScmObj frame = SCM_NIL;
+ ScmObj env = *envp;
+ ScmObj bindings = SCM_NIL;
+ ScmObj body = SCM_NIL;
+ ScmObj vars = SCM_NIL;
+ ScmObj vals = SCM_NIL;
+ ScmObj binding = SCM_NIL;
+ ScmObj var = SCM_NIL;
+ ScmObj val = SCM_NIL;
+ ScmObj frame = SCM_NIL;
/* sanity check */
- if CHECK_2_ARGS(arg)
+ if (SCM_NULLP(arg) || SCM_NULLP(SCM_CDR(arg)))
SigScm_Error("letrec : syntax error\n");
/* get bindings and body */
@@ -1139,7 +1147,7 @@
(<variable2> <init2>)
...)
========================================================================*/
- if (SCM_CONSP(bindings)) {
+ if (SCM_CONSP(bindings) || SCM_NULLP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
var = SCM_CAR(binding);
Modified: branches/r5rs/sigscheme/read.c
==============================================================================
--- branches/r5rs/sigscheme/read.c (original)
+++ branches/r5rs/sigscheme/read.c Thu Aug 11 21:31:01 2005
@@ -228,9 +228,13 @@
{
ScmObj list_head = SCM_NIL;
ScmObj list_tail = SCM_NIL;
- ScmObj item = SCM_NIL;
- int line = SCM_PORTINFO_LINE(port);
- int c = 0;
+ ScmObj item = SCM_NIL;
+ ScmObj cdr = SCM_NIL;
+ int line = SCM_PORTINFO_LINE(port);
+ int c = 0;
+ int c2 = 0;
+ char *token = NULL;
+ char *dotsym = NULL;
#if DEBUG_PARSER
printf("read_list\n");
@@ -251,13 +255,14 @@
} else if (c == closeParen) {
return list_head;
} else if (c == '.') {
- int c2 = 0;
+ c2 = 0;
SCM_PORT_GETC(port, c2);
+
#if DEBUG_PARSER
- printf("read_list process_dot c2 = [%c]\n", c2);
+ printf("read_list process_dot c2 = [%c]\n", c2);
#endif
- if (isspace(c2)) {
- ScmObj cdr = read_sexpression(port);
+ if (isspace(c2) || c2 == '(' || c2 == '"' || c2 == ';') {
+ cdr = read_sexpression(port);
if (SCM_NULLP(list_tail))
SigScm_Error(".(dot) at the start of the list.\n");
@@ -268,6 +273,20 @@
SCM_SETCDR(list_tail, cdr);
return list_head;
}
+
+ /*
+ * This dirty hack here picks up the current token as a
+ * symbol beginning with the dot (that's how Guile and
+ * Gauche behave).
+ */
+ SCM_PORT_UNGETC(port, c2);
+ token = read_char_sequence(port);
+ dotsym = (char*)malloc(sizeof(char) * (strlen(token) + 1 + 1));
+ memmove (dotsym + 1, token, strlen(token)+1);
+ dotsym[0] = '.';
+ item = Scm_Intern(dotsym);
+ free(dotsym);
+ free(token);
} else {
SCM_PORT_UNGETC(port, c);
item = read_sexpression(port);
Modified: branches/r5rs/sigscheme/test/test-r4rs.scm
==============================================================================
--- branches/r5rs/sigscheme/test/test-r4rs.scm (original)
+++ branches/r5rs/sigscheme/test/test-r4rs.scm Thu Aug 11 21:31:01 2005
@@ -171,7 +171,6 @@
(odd?
(lambda (n) (if (zero? n) #f (even? (- n 1))))))
(even? 88)))
-(print "fefefe")
(define x 34)
(test 5 'let (let ((x 3)) (define x 5) x))
(test 34 'let x)
