[uim-commit] r1273 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Mon Aug 22 15:56:10 EST 2005
Author: kzk
Date: 2005-08-21 22:56:08 -0700 (Sun, 21 Aug 2005)
New Revision: 1273
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/debug.c
branches/r5rs/sigscheme/encoding.c
branches/r5rs/sigscheme/error.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/io.c
branches/r5rs/sigscheme/main.c
branches/r5rs/sigscheme/operations-srfi1.c
branches/r5rs/sigscheme/operations-srfi8.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/read.c
branches/r5rs/sigscheme/sigschemetype.h
branches/r5rs/sigscheme/test/test-vector.scm
Log:
* change indentation style
- untabify
- change "switch" indentation
- use "(pred) ? VAL1 : VAL2;" style
* sigscheme/operations-srfi1.c
* sigscheme/io.c
* sigscheme/read.c
* sigscheme/operations-srfi8.c
* sigscheme/sigschemetype.h
* sigscheme/operations.c
* sigscheme/main.c
* sigscheme/encoding.c
* sigscheme/debug.c
* sigscheme/eval.c
* sigscheme/error.c
* sigscheme/datas.c
- untabify
- change "switch" indentation
- use "(pred) ? VAL1 : VAL2;" style
* sigscheme/test/test-vector.scm
- use assert-equal? instead of assert-eq?
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/datas.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -108,10 +108,10 @@
#define NAMEHASH_SIZE 1024
#define SCM_NEW_OBJ_INTERNAL(VALNAME) \
- if (EQ(scm_freelist, SCM_NIL)) \
- gc_mark_and_sweep(); \
- VALNAME = scm_freelist; \
- scm_freelist = SCM_FREECELL_CDR(scm_freelist); \
+ if (EQ(scm_freelist, SCM_NIL)) \
+ gc_mark_and_sweep(); \
+ VALNAME = scm_freelist; \
+ scm_freelist = SCM_FREECELL_CDR(scm_freelist); \
#define SCM_UNMARKER 0
#define SCM_INITIAL_MARKER (SCM_UNMARKER + 1)
@@ -217,19 +217,19 @@
/* fill with zero and construct free_list */
for (i = 0; i < num_heap; i++) {
/* Initialize Heap */
- heap = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
+ heap = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
(*heaps)[i] = heap;
/* link in order */
for (cell=heap; cell-heap < HEAP_SIZE; cell++) {
- SCM_SETFREECELL(cell);
- SCM_DO_UNMARK(cell);
- SCM_SETFREECELL_CDR(cell, cell+1);
+ SCM_SETFREECELL(cell);
+ SCM_DO_UNMARK(cell);
+ SCM_SETFREECELL_CDR(cell, cell+1);
}
- SCM_SETFREECELL_CDR(cell-1, (*freelist));
- /* and freelist is head of the heap */
- (*freelist) = (*heaps)[i];
+ SCM_SETFREECELL_CDR(cell-1, (*freelist));
+ /* and freelist is head of the heap */
+ (*freelist) = (*heaps)[i];
}
}
@@ -255,9 +255,9 @@
/* link in order */
for (cell=heap; cell-heap < HEAP_SIZE; cell++) {
- SCM_SETFREECELL(cell);
- SCM_DO_UNMARK(cell);
- SCM_SETFREECELL_CDR(cell, cell+1);
+ SCM_SETFREECELL(cell);
+ SCM_DO_UNMARK(cell);
+ SCM_SETFREECELL_CDR(cell, cell+1);
}
SCM_SETFREECELL_CDR(cell-1, *freelist);
@@ -270,32 +270,32 @@
int j = 0;
for (i = 0; i < scm_heap_num; i++) {
- for (j = 0; j < SCM_HEAP_SIZE; j++) {
- sweep_obj(&scm_heaps[i][j]);
- }
- free(scm_heaps[i]);
+ for (j = 0; j < SCM_HEAP_SIZE; j++) {
+ sweep_obj(&scm_heaps[i][j]);
+ }
+ free(scm_heaps[i]);
}
free(scm_heaps);
}
static void gc_preprocess(void)
{
- ++scm_cur_marker; /* make everything unmarked */
+ ++scm_cur_marker; /* make everything unmarked */
if (scm_cur_marker == SCM_UNMARKER) {
- /* We've been running long enough to do
- * (1 << (sizeof(int)*8)) - 1 GCs, yay! */
- int i = 0;
- long j = 0;
+ /* We've been running long enough to do
+ * (1 << (sizeof(int)*8)) - 1 GCs, yay! */
+ int i = 0;
+ long j = 0;
- scm_cur_marker = SCM_INITIAL_MARKER;
+ scm_cur_marker = SCM_INITIAL_MARKER;
- /* unmark everything */
- for (i = 0; i < scm_heap_num; i++) {
- for (j = 0; j < SCM_HEAP_SIZE; j++) {
- SCM_DO_UNMARK(&scm_heaps[i][j]);
- }
- }
+ /* unmark everything */
+ for (i = 0; i < scm_heap_num; i++) {
+ for (j = 0; j < SCM_HEAP_SIZE; j++) {
+ SCM_DO_UNMARK(&scm_heaps[i][j]);
+ }
+ }
}
}
@@ -336,29 +336,29 @@
/* mark recursively */
switch (SCM_GETTYPE(obj)) {
- case ScmCons:
- mark_obj(SCM_CAR(obj));
- obj = SCM_CDR(obj);
- goto mark_loop;
- break;
- case ScmSymbol:
- mark_obj(SCM_SYMBOL_VCELL(obj));
- break;
- case ScmClosure:
- mark_obj(SCM_CLOSURE_EXP(obj));
- obj = SCM_CLOSURE_ENV(obj);
- goto mark_loop;
- break;
- case ScmValuePacket:
- obj = SCM_VALUEPACKET_VALUES(obj);
- goto mark_loop;
- case ScmVector:
- for (i = 0; i < SCM_VECTOR_LEN(obj); i++) {
- mark_obj(SCM_VECTOR_VEC(obj)[i]);
- }
- break;
- default:
- break;
+ case ScmCons:
+ mark_obj(SCM_CAR(obj));
+ obj = SCM_CDR(obj);
+ goto mark_loop;
+ break;
+ case ScmSymbol:
+ mark_obj(SCM_SYMBOL_VCELL(obj));
+ break;
+ case ScmClosure:
+ mark_obj(SCM_CLOSURE_EXP(obj));
+ obj = SCM_CLOSURE_ENV(obj);
+ goto mark_loop;
+ break;
+ case ScmValuePacket:
+ obj = SCM_VALUEPACKET_VALUES(obj);
+ goto mark_loop;
+ case ScmVector:
+ for (i = 0; i < SCM_VECTOR_LEN(obj); i++) {
+ mark_obj(SCM_VECTOR_VEC(obj)[i]);
+ }
+ break;
+ default:
+ break;
}
}
@@ -381,9 +381,9 @@
gc_protected_obj *item = protected_obj_list;
gc_protected_obj *tmp = NULL;
while (item) {
- tmp = item;
- item = item->next_obj;
- free(tmp);
+ tmp = item;
+ item = item->next_obj;
+ free(tmp);
}
}
@@ -393,11 +393,11 @@
int i = 0;
ScmObj head = SCM_NIL;
for (i = 0; i < scm_heap_num; i++) {
- if ((head = scm_heaps[i])
- && (head <= obj)
- && (obj < head + SCM_HEAP_SIZE)
- && ((((char*)obj - (char*)head) % sizeof(ScmObjInternal)) == 0))
- return 1;
+ if ((head = scm_heaps[i])
+ && (head <= obj)
+ && (obj < head + SCM_HEAP_SIZE)
+ && ((((char*)obj - (char*)head) % sizeof(ScmObjInternal)) == 0))
+ return 1;
}
return 0;
@@ -418,7 +418,7 @@
/* mark stack */
for (i = 0; i < n; i++) {
- obj = start[i];
+ obj = start[i];
if (is_pointer_to_heap(obj)) {
mark_obj(obj);
@@ -467,7 +467,7 @@
setjmp(save_regs_buf);
gc_mark_locations((ScmObj*)save_regs_buf,
- (ScmObj*)(((char*)save_regs_buf) + sizeof(save_regs_buf)));
+ (ScmObj*)(((char*)save_regs_buf) + sizeof(save_regs_buf)));
gc_mark_protected_obj();
gc_mark_locations(stack_start_pointer, &obj);
@@ -478,45 +478,50 @@
{
/* if the type has the pointer to free, then free it! */
switch (SCM_GETTYPE(obj)) {
- case ScmInt:
- case ScmCons:
- case ScmFunc:
- case ScmClosure:
- case ScmFreeCell:
- case ScmEtc:
- break;
- case ScmChar:
- if (SCM_CHAR_CH(obj)) free(SCM_CHAR_CH(obj));
- break;
- case ScmString:
- if (SCM_STRING_STR(obj)) free(SCM_STRING_STR(obj));
+ case ScmInt:
+ case ScmCons:
+ case ScmFunc:
+ case ScmClosure:
+ case ScmFreeCell:
+ case ScmEtc:
+ break;
+ case ScmChar:
+ if (SCM_CHAR_CH(obj)) free(SCM_CHAR_CH(obj));
+ break;
+ case ScmString:
+ if (SCM_STRING_STR(obj)) free(SCM_STRING_STR(obj));
+ break;
+ case ScmVector:
+ if (SCM_VECTOR_VEC(obj)) free(SCM_VECTOR_VEC(obj));
+ break;
+ case ScmSymbol:
+ if (SCM_SYMBOL_NAME(obj)) free(SCM_SYMBOL_NAME(obj));
+ break;
+ case ScmPort:
+ {
+ switch (SCM_PORTINFO_PORTTYPE(obj)) {
+ case PORT_FILE:
+ if (SCM_PORTINFO_FILENAME(obj))
+ free(SCM_PORTINFO_FILENAME(obj));
break;
- case ScmVector:
- if (SCM_VECTOR_VEC(obj)) free(SCM_VECTOR_VEC(obj));
- break;
- case ScmSymbol:
- if (SCM_SYMBOL_NAME(obj)) free(SCM_SYMBOL_NAME(obj));
- break;
- case ScmPort:
- switch (SCM_PORTINFO_PORTTYPE(obj)) {
- case PORT_FILE:
- if (SCM_PORTINFO_FILENAME(obj)) free(SCM_PORTINFO_FILENAME(obj));
- break;
- case PORT_STRING:
- if (SCM_PORTINFO_STR(obj)) free(SCM_PORTINFO_STR(obj));
- break;
- default:
- break;
- }
-
- if (SCM_PORT_PORTINFO(obj)) free(SCM_PORT_PORTINFO(obj));
- break;
- case ScmContinuation:
- if (SCM_CONTINUATION_CONTINFO(obj)) free(SCM_CONTINUATION_CONTINFO(obj));
- break;
- default:
- break;
+ case PORT_STRING:
+ if (SCM_PORTINFO_STR(obj))
+ free(SCM_PORTINFO_STR(obj));
+ break;
+ default:
+ break;
+ }
+
+ if (SCM_PORT_PORTINFO(obj))
+ free(SCM_PORT_PORTINFO(obj));
+ break;
}
+ case ScmContinuation:
+ if (SCM_CONTINUATION_CONTINFO(obj)) free(SCM_CONTINUATION_CONTINFO(obj));
+ break;
+ default:
+ break;
+ }
}
static void gc_sweep(void)
@@ -529,25 +534,25 @@
ScmObj scm_new_freelist = SCM_NIL;
/* iterate heaps */
for (i = 0; i < scm_heap_num; i++) {
- corrected_obj_num = 0;
-
- /* iterate in heap */
- for (j = 0; j < SCM_HEAP_SIZE; j++) {
- obj = &scm_heaps[i][j];
- sigassert (!SCM_MARK_CORRUPT (obj));
- if (!SCM_IS_MARKED(obj)) {
- sweep_obj(obj);
+ corrected_obj_num = 0;
+
+ /* iterate in heap */
+ for (j = 0; j < SCM_HEAP_SIZE; j++) {
+ obj = &scm_heaps[i][j];
+ sigassert (!SCM_MARK_CORRUPT (obj));
+ if (!SCM_IS_MARKED(obj)) {
+ sweep_obj(obj);
- SCM_SETFREECELL(obj);
- SCM_SETFREECELL_CAR(obj, SCM_NIL);
- SCM_SETFREECELL_CDR(obj, scm_new_freelist);
- scm_new_freelist = obj;
- corrected_obj_num++;
- }
- }
-
+ SCM_SETFREECELL(obj);
+ SCM_SETFREECELL_CAR(obj, SCM_NIL);
+ SCM_SETFREECELL_CDR(obj, scm_new_freelist);
+ scm_new_freelist = obj;
+ corrected_obj_num++;
+ }
+ }
+
#if DEBUG_GC
- printf("scm[%d] sweeped = %d\n", i, corrected_obj_num);
+ printf("scm[%d] sweeped = %d\n", i, corrected_obj_num);
#endif
}
scm_freelist = scm_new_freelist;
@@ -556,13 +561,13 @@
void SigScm_gc_protect_stack(ScmObj *stack_start)
{
if (!stack_start_pointer)
- stack_start_pointer = stack_start;
+ stack_start_pointer = stack_start;
}
void SigScm_gc_unprotect_stack(ScmObj *stack_start)
{
if (stack_start_pointer == stack_start)
- stack_start_pointer = NULL;
+ stack_start_pointer = NULL;
}
/*===========================================================================
@@ -609,8 +614,8 @@
/* check length */
if (SigScm_default_encoding_strlen(ch) != 1) {
- printf("ch = [%s], len = %d\n", ch, SigScm_default_encoding_strlen(ch));
- SigScm_Error("invalid character\n");
+ printf("ch = [%s], len = %d\n", ch, SigScm_default_encoding_strlen(ch));
+ SigScm_Error("invalid character\n");
}
SCM_NEW_OBJ_INTERNAL(obj);
@@ -814,7 +819,7 @@
int c;
char *cname = (char *)name;
while ((c = *cname++)) {
- hash = ((hash * 17) ^ c) % NAMEHASH_SIZE;
+ hash = ((hash * 17) ^ c) % NAMEHASH_SIZE;
}
return hash;
}
@@ -852,7 +857,7 @@
int Scm_GetInt(ScmObj num)
{
if (EQ(ScmOp_numberp(num), SCM_FALSE))
- SigScm_ErrorObj("Scm_GetInt : number required but got ", num);
+ SigScm_ErrorObj("Scm_GetInt : number required but got ", num);
return SCM_INT_VALUE(num);
}
@@ -861,14 +866,14 @@
{
char *ret = NULL;
switch (SCM_GETTYPE(str)) {
- case ScmString:
- ret = SCM_STRING_STR(str);
- break;
- case ScmSymbol:
- ret = SCM_SYMBOL_NAME(str);
- break;
- default:
- SigScm_Error("Scm_GetString : cannot get string of not string nor symbol\n");
+ case ScmString:
+ ret = SCM_STRING_STR(str);
+ break;
+ case ScmSymbol:
+ ret = SCM_SYMBOL_NAME(str);
+ break;
+ default:
+ SigScm_Error("Scm_GetString : cannot get string of not string nor symbol\n");
}
return ret;
@@ -878,7 +883,7 @@
void* Scm_GetCPointer(ScmObj c_ptr)
{
if (!SCM_C_POINTERP(c_ptr))
- SigScm_ErrorObj("Scm_GetCPointer : c_ptr required but got ", c_ptr);
+ SigScm_ErrorObj("Scm_GetCPointer : c_ptr required but got ", c_ptr);
return SCM_C_POINTER_DATA(c_ptr);
}
@@ -886,7 +891,7 @@
C_FUNC Scm_GetCFuncPointer(ScmObj c_funcptr)
{
if (!SCM_C_FUNCPOINTERP(c_funcptr))
- SigScm_ErrorObj("Scm_GetCFuncPointer : c_funcptr required but got ", c_funcptr);
+ SigScm_ErrorObj("Scm_GetCFuncPointer : c_funcptr required but got ", c_funcptr);
return SCM_C_FUNCPOINTER_FUNC(c_funcptr);
}
Modified: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/debug.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -83,9 +83,9 @@
FILE *f = NULL;
if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
- f = SCM_PORTINFO_FILE(port);
- print_ScmObj_internal(f, obj, AS_WRITE);
- return;
+ f = SCM_PORTINFO_FILE(port);
+ print_ScmObj_internal(f, obj, AS_WRITE);
+ return;
}
SigScm_Error("SigScm_WriteToPort : support write only for file port.");
@@ -96,9 +96,9 @@
FILE *f = NULL;
if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
- f = SCM_PORTINFO_FILE(port);
- print_ScmObj_internal(f, obj, AS_DISPLAY);
- return;
+ f = SCM_PORTINFO_FILE(port);
+ print_ScmObj_internal(f, obj, AS_DISPLAY);
+ return;
}
SigScm_Error("SigScm_DisplayToPort : support display only for file port.");
@@ -107,82 +107,84 @@
static void print_ScmObj_internal(FILE *f, ScmObj obj, enum OutputType otype)
{
switch (SCM_GETTYPE(obj)) {
- case ScmInt:
- fprintf(f, "%d", SCM_INT_VALUE(obj));
- break;
- case ScmCons:
- print_list(f, obj, otype);
- break;
- case ScmSymbol:
- fprintf(f, "%s", SCM_SYMBOL_NAME(obj));
- break;
- case ScmChar:
- print_char(f, obj, otype);
- break;
- case ScmString:
- print_string(f, obj, otype);
- break;
- case ScmFunc:
- fprintf(f, "#<subr>");
- break;
- case ScmClosure:
- fprintf(f, "#<closure:");
- print_ScmObj_internal(f, SCM_CLOSURE_EXP(obj), otype);
- fprintf(f, ">");
- break;
- case ScmVector:
- print_vector(f, obj, otype);
- break;
- case ScmPort:
- print_port(f, obj, otype);
- break;
- case ScmContinuation:
- fprintf(f, "#<subr continuation>");
- break;
- case ScmValuePacket:
- fputs("#<values ", f);
- print_list(f, SCM_VALUEPACKET_VALUES(obj), otype);
- putc('>', f);
- break;
- case ScmEtc:
- print_etc(f, obj, otype);
- break;
- case ScmCPointer:
- fprintf(f, "#<c_pointer %p>", SCM_C_POINTER_DATA(obj));
- break;
- case ScmCFuncPointer:
- fprintf(f, "#<c_func_pointer %p>", (void*)SCM_C_FUNCPOINTER_FUNC(obj));
- break;
- case ScmFreeCell:
- SigScm_Error("You cannot print ScmFreeCell, may be GC bug.\n");
- break;
- }
+ case ScmInt:
+ fprintf(f, "%d", SCM_INT_VALUE(obj));
+ break;
+ case ScmCons:
+ print_list(f, obj, otype);
+ break;
+ case ScmSymbol:
+ fprintf(f, "%s", SCM_SYMBOL_NAME(obj));
+ break;
+ case ScmChar:
+ print_char(f, obj, otype);
+ break;
+ case ScmString:
+ print_string(f, obj, otype);
+ break;
+ case ScmFunc:
+ fprintf(f, "#<subr>");
+ break;
+ case ScmClosure:
+ fprintf(f, "#<closure:");
+ print_ScmObj_internal(f, SCM_CLOSURE_EXP(obj), otype);
+ fprintf(f, ">");
+ break;
+ case ScmVector:
+ print_vector(f, obj, otype);
+ break;
+ case ScmPort:
+ print_port(f, obj, otype);
+ break;
+ case ScmContinuation:
+ fprintf(f, "#<subr continuation>");
+ break;
+ case ScmValuePacket:
+ fputs("#<values ", f);
+ print_list(f, SCM_VALUEPACKET_VALUES(obj), otype);
+ putc('>', f);
+ break;
+ case ScmEtc:
+ print_etc(f, obj, otype);
+ break;
+ case ScmFreeCell:
+ SigScm_Error("You cannot print ScmFreeCell, may be GC bug.\n");
+ break;
+
+ case ScmCPointer:
+ fprintf(f, "#<c_pointer %p>", SCM_C_POINTER_DATA(obj));
+ break;
+ case ScmCFuncPointer:
+ fprintf(f, "#<c_func_pointer %p>", (void*)SCM_C_FUNCPOINTER_FUNC(obj));
+ break;
+ }
}
static void print_char(FILE *f, ScmObj obj, enum OutputType otype)
{
switch (otype) {
- case AS_WRITE:
- /*
- * in write, character objects are written using the #\ notation.
- */
- if (strcmp(SCM_CHAR_CH(obj), " ") == 0) {
- fprintf(f, "#\\space");
- } else if(strcmp(SCM_CHAR_CH(obj), "\n") == 0) {
- fprintf(f, "#\\newline");
- } else {
- fprintf(f, "#\\%s", SCM_CHAR_CH(obj));
- }
- break;
- case AS_DISPLAY:
- /*
- * in display, character objects appear in the reqpresentation as
- * if writen by write-char instead of by write.
- */
- fprintf(f, "%s", SCM_CHAR_CH(obj));
- break;
- default:
- SigScm_Error("print_char : unknown output type\n");
+ case AS_WRITE:
+ /*
+ * in write, character objects are written using the #\ notation.
+ */
+ if (strcmp(SCM_CHAR_CH(obj), " ") == 0) {
+ fprintf(f, "#\\space");
+ } else if(strcmp(SCM_CHAR_CH(obj), "\n") == 0) {
+ fprintf(f, "#\\newline");
+ } else {
+ fprintf(f, "#\\%s", SCM_CHAR_CH(obj));
+ }
+ break;
+ case AS_DISPLAY:
+ /*
+ * in display, character objects appear in the reqpresentation as
+ * if writen by write-char instead of by write.
+ */
+ fprintf(f, "%s", SCM_CHAR_CH(obj));
+ break;
+ default:
+ SigScm_Error("print_char : unknown output type\n");
+ break;
}
}
@@ -194,32 +196,33 @@
char c = 0;
switch (otype) {
- case AS_WRITE:
- /*
- * in write, strings that appear in the written representation are
- * enclosed in doublequotes, and within those strings backslash and
- * doublequote characters are escaped by backslashes.
- */
- fprintf(f, "\""); /* first doublequote */
- for (i = 0; i < size; i++) {
- c = str[i];
- switch (c) {
- case '\"': fprintf(f, "\\\""); break;
- case '\n': fprintf(f, "\\n"); break;
- case '\r': fprintf(f, "\\r"); break;
- case '\f': fprintf(f, "\\f"); break;
- case '\t': fprintf(f, "\\t"); break;
- default:
- fprintf(f, "%c", str[i]); break;
- }
- }
- fprintf(f, "\""); /* last doublequote */
- break;
- case AS_DISPLAY:
- fprintf(f, "%s", SCM_STRING_STR(obj));
- break;
- default:
- SigScm_Error("print_string : unknown output type\n");
+ case AS_WRITE:
+ /*
+ * in write, strings that appear in the written representation are
+ * enclosed in doublequotes, and within those strings backslash and
+ * doublequote characters are escaped by backslashes.
+ */
+ fprintf(f, "\""); /* first doublequote */
+ for (i = 0; i < size; i++) {
+ c = str[i];
+ switch (c) {
+ case '\"': fprintf(f, "\\\""); break;
+ case '\n': fprintf(f, "\\n"); break;
+ case '\r': fprintf(f, "\\r"); break;
+ case '\f': fprintf(f, "\\f"); break;
+ case '\t': fprintf(f, "\\t"); break;
+ default:
+ fprintf(f, "%c", str[i]); break;
+ }
+ }
+ fprintf(f, "\""); /* last doublequote */
+ break;
+ case AS_DISPLAY:
+ fprintf(f, "%s", SCM_STRING_STR(obj));
+ break;
+ default:
+ SigScm_Error("print_string : unknown output type\n");
+ break;
}
}
@@ -239,28 +242,28 @@
/* print car */
print_ScmObj_internal(f, car, otype);
if (!SCM_NULLP(cdr))
- fprintf(f, " ");
+ fprintf(f, " ");
/* print else for-each */
for (tmp = cdr; ; tmp = SCM_CDR(tmp)) {
- if (SCM_CONSP(tmp)) {
- print_ScmObj_internal(f, SCM_CAR(tmp), otype);
- if (SCM_NULLP(SCM_CDR(tmp))) {
- fprintf(f, ")");
- return;
- } else {
- if (!SCM_NULLP(SCM_CDR(tmp)))
- fprintf(f, " ");
- }
- } else {
- if (!SCM_NULLP(tmp)) {
- fprintf(f, ". ");
- print_ScmObj_internal(f, tmp, otype);
- }
+ if (SCM_CONSP(tmp)) {
+ print_ScmObj_internal(f, SCM_CAR(tmp), otype);
+ if (SCM_NULLP(SCM_CDR(tmp))) {
+ fprintf(f, ")");
+ return;
+ } else {
+ if (!SCM_NULLP(SCM_CDR(tmp)))
+ fprintf(f, " ");
+ }
+ } else {
+ if (!SCM_NULLP(tmp)) {
+ fprintf(f, ". ");
+ print_ScmObj_internal(f, tmp, otype);
+ }
- fprintf(f, ")");
- return;
- }
+ fprintf(f, ")");
+ return;
+ }
}
}
@@ -275,10 +278,10 @@
/* print each element */
for (i = 0; i < c_len; i++) {
- print_ScmObj_internal(f, v[i], otype);
+ print_ScmObj_internal(f, v[i], otype);
- if (i != c_len - 1)
- fprintf(f, " ");
+ if (i != c_len - 1)
+ fprintf(f, " ");
}
fprintf(f, ")");
@@ -289,47 +292,44 @@
fprintf(f, "#<");
/* input or output */
- if (SCM_PORT_PORTDIRECTION(port) == PORT_INPUT) {
- fprintf(f, "i");
- } else {
- fprintf(f, "o");
- }
+ if (SCM_PORT_PORTDIRECTION(port) == PORT_INPUT)
+ fprintf(f, "i");
+ else
+ fprintf(f, "o");
fprintf(f, "port ");
/* file or string */
- if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
- fprintf(f, "file %s", SCM_PORTINFO_FILENAME(port));
- } else if (SCM_PORTINFO_PORTTYPE(port) == PORT_STRING) {
- fprintf(f, "string %s", SCM_PORTINFO_STR(port));
- }
+ if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE)
+ fprintf(f, "file %s", SCM_PORTINFO_FILENAME(port));
+ else if (SCM_PORTINFO_PORTTYPE(port) == PORT_STRING)
+ fprintf(f, "string %s", SCM_PORTINFO_STR(port));
fprintf(f, ">");
}
static void print_etc(FILE *f, ScmObj obj, enum OutputType otype)
{
- if (EQ(obj, SCM_NIL)) {
- fprintf(f, "()");
- } else if (EQ(obj, SCM_TRUE)) {
- fprintf(f, "#t");
- } else if (EQ(obj, SCM_FALSE)) {
- fprintf(f, "#f");
- } else if (EQ(obj, SCM_EOF)) {
- fprintf(f, "#<eof>");
- } else if (EQ(obj, SCM_QUOTE)) {
- fprintf(f, "#<quote>");
- } else if (EQ(obj, SCM_QUASIQUOTE)) {
- fprintf(f, "#<quasiquote>");
- } else if (EQ(obj, SCM_UNQUOTE)) {
- fprintf(f, "#<unquote>");
- } else if (EQ(obj, SCM_UNQUOTE_SPLICING)) {
- fprintf(f, "#<unquote_splicing>");
- } else if (EQ(obj, SCM_UNBOUND)) {
- fprintf(f, "#<unbound>");
- } else if (EQ(obj, SCM_UNSPECIFIED)) {
- fprintf(f, "#<unspecified>");
- } else if (EQ(obj, SCM_UNDEF)) {
- fprintf(f, "#<undef>");
- }
+ if (EQ(obj, SCM_NIL))
+ fprintf(f, "()");
+ else if (EQ(obj, SCM_TRUE))
+ fprintf(f, "#t");
+ else if (EQ(obj, SCM_FALSE))
+ fprintf(f, "#f");
+ else if (EQ(obj, SCM_EOF))
+ fprintf(f, "#<eof>");
+ else if (EQ(obj, SCM_QUOTE))
+ fprintf(f, "#<quote>");
+ else if (EQ(obj, SCM_QUASIQUOTE))
+ fprintf(f, "#<quasiquote>");
+ else if (EQ(obj, SCM_UNQUOTE))
+ fprintf(f, "#<unquote>");
+ else if (EQ(obj, SCM_UNQUOTE_SPLICING))
+ fprintf(f, "#<unquote_splicing>");
+ else if (EQ(obj, SCM_UNBOUND))
+ fprintf(f, "#<unbound>");
+ else if (EQ(obj, SCM_UNSPECIFIED))
+ fprintf(f, "#<unspecified>");
+ else if (EQ(obj, SCM_UNDEF))
+ fprintf(f, "#<undef>");
}
Modified: branches/r5rs/sigscheme/encoding.c
===================================================================
--- branches/r5rs/sigscheme/encoding.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/encoding.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -88,13 +88,13 @@
int len = 0;
const unsigned char *cur = (const unsigned char *)str;
while (*cur) {
- if (*cur > 127) {
- /* 2 bytes */
- cur++;
- }
+ if (*cur > 127) {
+ /* 2 bytes */
+ cur++;
+ }
- cur++;
- len++;
+ cur++;
+ len++;
}
return len;
@@ -105,16 +105,16 @@
int len = 0;
const unsigned char *cur = (const unsigned char *)str;
while (*cur) {
- if (len == k)
- return (const char *)cur;
+ if (len == k)
+ return (const char *)cur;
- if (*cur > 127) {
- /* 2 bytes */
- cur++;
- }
+ if (*cur > 127) {
+ /* 2 bytes */
+ cur++;
+ }
- cur++;
- len++;
+ cur++;
+ len++;
}
return (const char*)cur;
@@ -125,20 +125,20 @@
int len = 0;
const unsigned char *cur = (const unsigned char *)str;
while (*cur) {
- if (*cur > 127) {
- /* 2 bytes */
- cur++;
- }
+ if (*cur > 127) {
+ /* 2 bytes */
+ cur++;
+ }
- cur++;
- len++;
+ cur++;
+ len++;
- if (len == k + 1)
- return (const char *)cur;
+ if (len == k + 1)
+ return (const char *)cur;
}
if (len == k + 1)
- return (const char *)cur;
+ return (const char *)cur;
SigScm_Error("eucjp_str_startpos : unreachable point\n");
return NULL;
Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/error.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -116,8 +116,8 @@
/* show each frame's obj */
for (f = trace_root; f; f = f->prev) {
- SigScm_WriteToPort(current_error_port, f->obj);
-
- fprintf(SCM_PORTINFO_FILE(current_error_port), "\n");
+ SigScm_WriteToPort(current_error_port, f->obj);
+
+ fprintf(SCM_PORTINFO_FILE(current_error_port), "\n");
}
}
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/eval.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -60,7 +60,7 @@
/*=======================================
File Local Macro Declarations
=======================================*/
-#define SCM_INVALID NULL /* TODO: make a more appropriate choice */
+#define SCM_INVALID NULL /* TODO: make a more appropriate choice */
#define IS_LIST_LEN_1(args) (SCM_CONSP(args) && SCM_NULLP(SCM_CDR(args)))
/* for the quasiquote family */
@@ -101,20 +101,20 @@
/* handle dot list */
while (1) {
- if (SCM_NULLP(tmp_vars) || !SCM_CONSP(tmp_vars))
- break;
+ 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));
- }
+ /* 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);
+ tmp_vars = SCM_CDR(tmp_vars);
+ tmp_vals = SCM_CDR(tmp_vals);
}
-
+
/* create new frame */
frame = Scm_NewCons(vars, vals);
@@ -204,23 +204,23 @@
vals = SCM_CDR(frame);
while (1) {
- if (SCM_NULLP(vars))
- break;
+ if (SCM_NULLP(vars))
+ break;
- if (!SCM_CONSP(vars)) {
- /* handle dot list */
- if (SCM_EQ(vars, var))
- return vals;
+ 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;
- }
+ break;
+ } else {
+ /* normal binding */
+ if (SCM_EQ(SCM_CAR(vars), var))
+ return vals;
+ }
- vars = SCM_CDR(vars);
- vals = SCM_CDR(vals);
+ vars = SCM_CDR(vars);
+ vals = SCM_CDR(vals);
}
return SCM_NIL;
@@ -244,258 +244,260 @@
eval_loop:
switch (SCM_GETTYPE(obj)) {
+ case ScmSymbol:
+ {
+ ret = symbol_value(obj, env);
+ goto eval_done;
+ }
+
+ /*====================================================================
+ Evaluating Expression
+ ====================================================================*/
+ case ScmCons:
+ {
+ /*============================================================
+ Evaluating CAR
+ ============================================================*/
+ tmp = SCM_CAR(obj);
+ switch (SCM_GETTYPE(tmp)) {
+ case ScmFunc:
+ break;
+ case ScmClosure:
+ break;
case ScmSymbol:
- {
- ret = symbol_value(obj, env);
- goto eval_done;
- }
-
- /*====================================================================
- Evaluating Expression
- ====================================================================*/
+ tmp = symbol_value(tmp, env);
+ break;
case ScmCons:
+ tmp = ScmOp_eval(tmp, env);
+ break;
+ case ScmEtc:
+ /* QUOTE case */
+ break;
+ default:
+ SigScm_ErrorObj("eval : invalid operation ", obj);
+ break;
+ }
+ /*============================================================
+ Evaluating the rest of the List by the type of CAR
+ ============================================================*/
+ switch (SCM_GETTYPE(tmp)) {
+ case ScmFunc:
+ {
+ /*
+ * Description of FUNCTYPE handling.
+ *
+ * - FUNCTYPE_L
+ * - evaluate all the args and pass it to func
+ *
+ * - FUNCTYPE_R
+ * - not evaluate all the arguments
+ *
+ * - FUNCTYPE_2N
+ * - call the function with each 2 objs
+ *
+ * - FUNCTYPE_0
+ * - FUNCTYPE_1
+ * - FUNCTYPE_2
+ * - FUNCTYPE_3
+ * - FUNCTYPE_4
+ * - FUNCTYPE_5
+ * - call the function with 0-5 arguments
+ */
+ switch (SCM_FUNC_NUMARG(tmp)) {
+ case FUNCTYPE_L:
{
- /*============================================================
- Evaluating CAR
- ============================================================*/
- tmp = SCM_CAR(obj);
- switch (SCM_GETTYPE(tmp)) {
- case ScmFunc:
- break;
- case ScmClosure:
- break;
- case ScmSymbol:
- tmp = symbol_value(tmp, env);
- break;
- case ScmCons:
- tmp = ScmOp_eval(tmp, env);
- break;
- case ScmEtc:
- /* QUOTE case */
- break;
- default:
- SigScm_ErrorObj("eval : invalid operation ", obj);
- break;
- }
- /*============================================================
- Evaluating the rest of the List by the type of CAR
- ============================================================*/
- switch (SCM_GETTYPE(tmp)) {
- case ScmFunc:
- /*
- * Description of FUNCTYPE handling.
- *
- * - FUNCTYPE_L
- * - evaluate all the args and pass it to func
- *
- * - FUNCTYPE_R
- * - not evaluate all the arguments
- *
- * - FUNCTYPE_2N
- * - call the function with each 2 objs
- *
- * - FUNCTYPE_0
- * - FUNCTYPE_1
- * - FUNCTYPE_2
- * - FUNCTYPE_3
- * - FUNCTYPE_4
- * - FUNCTYPE_5
- * - call the function with 0-5 arguments
- */
- switch (SCM_FUNC_NUMARG(tmp)) {
- case FUNCTYPE_L:
- {
- ret = SCM_FUNC_EXEC_SUBRL(tmp,
- map_eval(SCM_CDR(obj), env),
- env);
- goto eval_done;
- }
- case FUNCTYPE_R:
- {
- obj = SCM_FUNC_EXEC_SUBRR(tmp,
- SCM_CDR(obj),
- &env,
- &tail_flag);
+ ret = SCM_FUNC_EXEC_SUBRL(tmp,
+ map_eval(SCM_CDR(obj), env),
+ env);
+ goto eval_done;
+ }
+ case FUNCTYPE_R:
+ {
+ obj = SCM_FUNC_EXEC_SUBRR(tmp,
+ SCM_CDR(obj),
+ &env,
+ &tail_flag);
- /*
- * The core point of tail-recursion
- *
- * if tail_flag == 1, SCM_FUNC_EXEC_SUBRR returns raw S-expression.
- * So we need to evaluate it! This is for not to consume stack,
- * that is, tail-recursion optimization.
- */
- if (tail_flag == 1)
- goto eval_loop;
+ /*
+ * The core point of tail-recursion
+ *
+ * if tail_flag == 1, SCM_FUNC_EXEC_SUBRR returns raw S-expression.
+ * So we need to evaluate it! This is for not to consume stack,
+ * that is, tail-recursion optimization.
+ */
+ if (tail_flag == 1)
+ goto eval_loop;
- ret = obj;
- goto eval_done;
- }
- case FUNCTYPE_2N:
- {
- obj = SCM_CDR(obj);
+ ret = obj;
+ goto eval_done;
+ }
+ case FUNCTYPE_2N:
+ {
+ obj = SCM_CDR(obj);
- /* check 1st arg */
- if (SCM_NULLP(obj)) {
- ret = SCM_FUNC_EXEC_SUBR2N(tmp, SCM_NIL, SCM_NIL);
- goto eval_done;
- }
+ /* check 1st arg */
+ if (SCM_NULLP(obj)) {
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp, SCM_NIL, SCM_NIL);
+ goto eval_done;
+ }
- /* eval 1st arg */
- ret = ScmOp_eval(SCM_CAR(obj), env);
+ /* eval 1st arg */
+ ret = ScmOp_eval(SCM_CAR(obj), env);
- /* check 2nd arg */
- if (SCM_NULLP(SCM_CDR(obj))) {
- ret = SCM_FUNC_EXEC_SUBR2N(tmp, ret, SCM_NIL);
- goto eval_done;
- }
+ /* check 2nd arg */
+ if (SCM_NULLP(SCM_CDR(obj))) {
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp, ret, SCM_NIL);
+ goto eval_done;
+ }
- /* call proc with each 2 objs */
- for (obj = SCM_CDR(obj); !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
- ret = SCM_FUNC_EXEC_SUBR2N(tmp,
- ret,
- ScmOp_eval(SCM_CAR(obj), env));
- }
- goto eval_done;
- }
- case FUNCTYPE_0:
- {
- ret = SCM_FUNC_EXEC_SUBR0(tmp);
- goto eval_done;
- }
- case FUNCTYPE_1:
- {
- ret = SCM_FUNC_EXEC_SUBR1(tmp, ScmOp_eval(SCM_CAR(SCM_CDR(obj)),env));
- goto eval_done;
- }
- case FUNCTYPE_2:
- {
- obj = SCM_CDR(obj);
- arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
- ret = SCM_FUNC_EXEC_SUBR2(tmp,
- arg,
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 2nd arg */
- goto eval_done;
- }
- case FUNCTYPE_3:
- {
- obj = SCM_CDR(obj);
- arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
- obj = SCM_CDR(obj);
- ret = SCM_FUNC_EXEC_SUBR3(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 3rd arg */
- goto eval_done;
- }
- case FUNCTYPE_4:
- {
- obj = SCM_CDR(obj);
- arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
- obj = SCM_CDR(obj);
- ret = SCM_FUNC_EXEC_SUBR4(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env)); /* 4th arg */
- goto eval_done;
- }
- case FUNCTYPE_5:
- {
- obj = SCM_CDR(obj);
- arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
- obj = SCM_CDR(obj);
- ret = SCM_FUNC_EXEC_SUBR5(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env), /* 4th arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))), env)); /* 5th arg */
- goto eval_done;
- }
- }
- break;
- case ScmClosure:
- {
- /*
- * Description of the ScmClosure handling
- *
- * (lambda <formals> <body>)
- *
- * <formals> should have 3 forms.
- *
- * (1) : <variable>
- * (2) : (<variable1> <variable2> ...)
- * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
- */
- arg = SCM_CAR(SCM_CLOSURE_EXP(tmp)); /* arg is <formals> */
-
- if (SCM_SYMBOLP(arg)) {
- /* (1) : <variable> */
- env = extend_environment(Scm_NewCons(arg, SCM_NIL),
- Scm_NewCons(map_eval(SCM_CDR(obj), env),
- SCM_NIL),
- SCM_CLOSURE_ENV(tmp));
- } else if (SCM_CONSP(arg)) {
- /*
- * (2) : (<variable1> <variable2> ...)
- * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
- *
- * - dot list is handled in lookup_frame().
- */
- env = extend_environment(arg,
- map_eval(SCM_CDR(obj), env),
- SCM_CLOSURE_ENV(tmp));
- } else if (SCM_NULLP(arg)) {
- /*
- * (2') : <variable> is '()
- */
- env = extend_environment(SCM_NIL,
- SCM_NIL,
- SCM_CLOSURE_ENV(tmp));
- } else {
- SigScm_ErrorObj("lambda : bad syntax with ", arg);
- }
-
- /*
- * Notice
- *
- * The return obj of ScmExp_begin is the raw S-expression.
- * So we need to re-evaluate this!.
- */
- obj = ScmExp_begin(SCM_CDR(SCM_CLOSURE_EXP(tmp)), &env, &tail_flag);
- goto eval_loop;
- }
- case ScmContinuation:
- {
- /*
- * Description of ScmContinuation handling
- *
- * (1) eval 1st arg
- * (2) store it to global variable "continuation_thrown_obj"
- * (3) then longjmp
- *
- * PROBLEM : setjmp/longjmp is stack based operation, so we
- * cannot jump from the bottom of the stack to the top of
- * the stack. Is there any efficient way to implement first
- * class continuation? (TODO).
- */
- obj = SCM_CAR(SCM_CDR(obj));
- continuation_thrown_obj = ScmOp_eval(obj, env);
- longjmp(SCM_CONTINUATION_JMPENV(tmp), 1);
- }
- break;
- case ScmEtc:
- SigScm_ErrorObj("invalid application: ", obj);
- default:
- /* What? */
- SigScm_ErrorObj("eval : What type of function? ", arg);
+ /* call proc with each 2 objs */
+ for (obj = SCM_CDR(obj); !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp,
+ ret,
+ ScmOp_eval(SCM_CAR(obj), env));
}
-
+ goto eval_done;
}
+ case FUNCTYPE_0:
+ {
+ ret = SCM_FUNC_EXEC_SUBR0(tmp);
+ goto eval_done;
+ }
+ case FUNCTYPE_1:
+ {
+ ret = SCM_FUNC_EXEC_SUBR1(tmp, ScmOp_eval(SCM_CAR(SCM_CDR(obj)),env));
+ goto eval_done;
+ }
+ case FUNCTYPE_2:
+ {
+ obj = SCM_CDR(obj);
+ arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+ ret = SCM_FUNC_EXEC_SUBR2(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 2nd arg */
+ goto eval_done;
+ }
+ case FUNCTYPE_3:
+ {
+ obj = SCM_CDR(obj);
+ arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+ obj = SCM_CDR(obj);
+ ret = SCM_FUNC_EXEC_SUBR3(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 3rd arg */
+ goto eval_done;
+ }
+ case FUNCTYPE_4:
+ {
+ obj = SCM_CDR(obj);
+ arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+ obj = SCM_CDR(obj);
+ ret = SCM_FUNC_EXEC_SUBR4(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env)); /* 4th arg */
+ goto eval_done;
+ }
+ case FUNCTYPE_5:
+ {
+ obj = SCM_CDR(obj);
+ arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+ obj = SCM_CDR(obj);
+ ret = SCM_FUNC_EXEC_SUBR5(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env), /* 4th arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))), env)); /* 5th arg */
+ goto eval_done;
+ }
+ default:
+ SigScm_Error("eval : unknown functype\n");
+ }
+ }
+ case ScmClosure:
+ {
+ /*
+ * Description of the ScmClosure handling
+ *
+ * (lambda <formals> <body>)
+ *
+ * <formals> should have 3 forms.
+ *
+ * (1) : <variable>
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ */
+ arg = SCM_CAR(SCM_CLOSURE_EXP(tmp)); /* arg is <formals> */
+
+ if (SCM_SYMBOLP(arg)) {
+ /* (1) : <variable> */
+ env = extend_environment(Scm_NewCons(arg, SCM_NIL),
+ Scm_NewCons(map_eval(SCM_CDR(obj), env),
+ SCM_NIL),
+ SCM_CLOSURE_ENV(tmp));
+ } else if (SCM_CONSP(arg)) {
+ /*
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ *
+ * - dot list is handled in lookup_frame().
+ */
+ env = extend_environment(arg,
+ map_eval(SCM_CDR(obj), env),
+ SCM_CLOSURE_ENV(tmp));
+ } else if (SCM_NULLP(arg)) {
+ /*
+ * (2') : <variable> is '()
+ */
+ env = extend_environment(SCM_NIL,
+ SCM_NIL,
+ SCM_CLOSURE_ENV(tmp));
+ } else {
+ SigScm_ErrorObj("lambda : bad syntax with ", arg);
+ }
+
+ /*
+ * Notice
+ *
+ * The return obj of ScmExp_begin is the raw S-expression.
+ * So we need to re-evaluate this!.
+ */
+ obj = ScmExp_begin(SCM_CDR(SCM_CLOSURE_EXP(tmp)), &env, &tail_flag);
+ goto eval_loop;
+ }
+ case ScmContinuation:
+ {
+ /*
+ * Description of ScmContinuation handling
+ *
+ * (1) eval 1st arg
+ * (2) store it to global variable "continuation_thrown_obj"
+ * (3) then longjmp
+ *
+ * PROBLEM : setjmp/longjmp is stack based operation, so we
+ * cannot jump from the bottom of the stack to the top of
+ * the stack. Is there any efficient way to implement first
+ * class continuation? (TODO).
+ */
+ obj = SCM_CAR(SCM_CDR(obj));
+ continuation_thrown_obj = ScmOp_eval(obj, env);
+ longjmp(SCM_CONTINUATION_JMPENV(tmp), 1);
+ }
+ break;
+ case ScmEtc:
+ SigScm_ErrorObj("invalid application: ", obj);
default:
- ret = obj;
- goto eval_done;
+ /* What? */
+ SigScm_ErrorObj("eval : What type of function? ", arg);
+ }
}
+ default:
+ ret = obj;
+ goto eval_done;
+ }
eval_done:
trace_root = frame.prev;
@@ -512,7 +514,7 @@
if CHECK_2_ARGS(args)
SigScm_Error("apply : Wrong number of arguments\n");
if (!SCM_NULLP(SCM_CDR(SCM_CDR(args))))
- SigScm_Error("apply : Doesn't support multiarg apply\n");
+ SigScm_Error("apply : Doesn't support multiarg apply\n");
/* 1st elem of list is proc */
proc = SCM_CAR(args);
@@ -522,139 +524,139 @@
/* apply proc */
switch (SCM_GETTYPE(proc)) {
- case ScmFunc:
- switch (SCM_FUNC_NUMARG(proc)) {
- case FUNCTYPE_L:
- {
- return SCM_FUNC_EXEC_SUBRL(proc,
- obj,
- env);
- }
- case FUNCTYPE_2N:
- {
- args = obj;
-
- /* check 1st arg */
- if (SCM_NULLP(args))
- return SCM_FUNC_EXEC_SUBR2N(proc, SCM_NIL, SCM_NIL);
-
- /* eval 1st arg */
- obj = SCM_CAR(args);
-
- /* check 2nd arg */
- if (SCM_NULLP(SCM_CDR(args)))
- return SCM_FUNC_EXEC_SUBR2N(proc, obj, SCM_NIL);
-
- /* call proc with each 2 objs */
- for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
- obj = SCM_FUNC_EXEC_SUBR2N(proc,
- obj,
- SCM_CAR(args));
- }
- return obj;
- }
- case FUNCTYPE_0:
- {
- return SCM_FUNC_EXEC_SUBR0(proc);
- }
- case FUNCTYPE_1:
- {
- return SCM_FUNC_EXEC_SUBR1(proc,
- SCM_CAR(obj));
- }
- case FUNCTYPE_2:
- {
- return SCM_FUNC_EXEC_SUBR2(proc,
- SCM_CAR(obj),
- SCM_CAR(SCM_CDR(obj)));
- }
- case FUNCTYPE_3:
- {
- return SCM_FUNC_EXEC_SUBR3(proc,
- SCM_CAR(obj),
- SCM_CAR(SCM_CDR(obj)),
- SCM_CAR(SCM_CDR(SCM_CDR(obj))));
- }
- case FUNCTYPE_4:
- {
- return SCM_FUNC_EXEC_SUBR4(proc,
- SCM_CAR(obj),
- SCM_CAR(SCM_CDR(obj)),
- SCM_CAR(SCM_CDR(SCM_CDR(obj))),
- SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))));
- }
- case FUNCTYPE_5:
- {
- return SCM_FUNC_EXEC_SUBR5(proc,
- SCM_CAR(obj),
- SCM_CAR(SCM_CDR(obj)),
- SCM_CAR(SCM_CDR(SCM_CDR(obj))),
- SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))),
- SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(obj))))));
- }
- default:
- SigScm_ErrorObj("apply : invalid application ", proc);
+ case ScmFunc:
+ {
+ switch (SCM_FUNC_NUMARG(proc)) {
+ case FUNCTYPE_L:
+ {
+ return SCM_FUNC_EXEC_SUBRL(proc,
+ obj,
+ env);
+ }
+ case FUNCTYPE_2N:
+ {
+ args = obj;
+
+ /* check 1st arg */
+ if (SCM_NULLP(args))
+ return SCM_FUNC_EXEC_SUBR2N(proc, SCM_NIL, SCM_NIL);
+
+ /* eval 1st arg */
+ obj = SCM_CAR(args);
+
+ /* check 2nd arg */
+ if (SCM_NULLP(SCM_CDR(args)))
+ return SCM_FUNC_EXEC_SUBR2N(proc, obj, SCM_NIL);
+
+ /* call proc with each 2 objs */
+ for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+ obj = SCM_FUNC_EXEC_SUBR2N(proc,
+ obj,
+ SCM_CAR(args));
}
- break;
- case ScmClosure:
- {
- /*
- * Description of the ScmClosure handling
- *
- * (lambda <formals> <body>)
- *
- * <formals> should have 3 forms.
- *
- * (1) : <variable>
- * (2) : (<variable1> <variable2> ...)
- * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
- */
- args = SCM_CAR(SCM_CLOSURE_EXP(proc)); /* arg is <formals> */
+ return obj;
+ }
+ case FUNCTYPE_0:
+ {
+ return SCM_FUNC_EXEC_SUBR0(proc);
+ }
+ case FUNCTYPE_1:
+ {
+ return SCM_FUNC_EXEC_SUBR1(proc,
+ SCM_CAR(obj));
+ }
+ case FUNCTYPE_2:
+ {
+ return SCM_FUNC_EXEC_SUBR2(proc,
+ SCM_CAR(obj),
+ SCM_CAR(SCM_CDR(obj)));
+ }
+ case FUNCTYPE_3:
+ {
+ return SCM_FUNC_EXEC_SUBR3(proc,
+ SCM_CAR(obj),
+ SCM_CAR(SCM_CDR(obj)),
+ SCM_CAR(SCM_CDR(SCM_CDR(obj))));
+ }
+ case FUNCTYPE_4:
+ {
+ return SCM_FUNC_EXEC_SUBR4(proc,
+ SCM_CAR(obj),
+ SCM_CAR(SCM_CDR(obj)),
+ SCM_CAR(SCM_CDR(SCM_CDR(obj))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))));
+ }
+ case FUNCTYPE_5:
+ {
+ return SCM_FUNC_EXEC_SUBR5(proc,
+ SCM_CAR(obj),
+ SCM_CAR(SCM_CDR(obj)),
+ SCM_CAR(SCM_CDR(SCM_CDR(obj))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))),
+ SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(obj))))));
+ }
+ default:
+ SigScm_ErrorObj("apply : invalid application ", proc);
+ }
+ }
+ case ScmClosure:
+ {
+ /*
+ * Description of the ScmClosure handling
+ *
+ * (lambda <formals> <body>)
+ *
+ * <formals> should have 3 forms.
+ *
+ * (1) : <variable>
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ */
+ args = SCM_CAR(SCM_CLOSURE_EXP(proc)); /* arg is <formals> */
- if (SCM_SYMBOLP(args)) {
- /* (1) : <variable> */
- env = extend_environment(Scm_NewCons(args, SCM_NIL),
- Scm_NewCons(obj, SCM_NIL),
- SCM_CLOSURE_ENV(proc));
- } else if (SCM_CONSP(args)) {
- /*
- * (2) : (<variable1> <variable2> ...)
- * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
- *
- * - dot list is handled in lookup_frame().
- */
- env = extend_environment(args,
- obj,
- SCM_CLOSURE_ENV(proc));
- } else if (SCM_NULLP(args)) {
- /*
- * (2') : <variable> is '()
- */
- env = extend_environment(SCM_NIL,
- SCM_NIL,
- SCM_CLOSURE_ENV(proc));
- } else {
- SigScm_ErrorObj("lambda : bad syntax with ", args);
- }
+ if (SCM_SYMBOLP(args)) {
+ /* (1) : <variable> */
+ env = extend_environment(Scm_NewCons(args, SCM_NIL),
+ Scm_NewCons(obj, SCM_NIL),
+ SCM_CLOSURE_ENV(proc));
+ } else if (SCM_CONSP(args)) {
+ /*
+ * (2) : (<variable1> <variable2> ...)
+ * (3) : (<variable1> <variable2> ... <variable n-1> . <variable n>)
+ *
+ * - dot list is handled in lookup_frame().
+ */
+ env = extend_environment(args,
+ obj,
+ SCM_CLOSURE_ENV(proc));
+ } else if (SCM_NULLP(args)) {
+ /*
+ * (2') : <variable> is '()
+ */
+ env = extend_environment(SCM_NIL,
+ SCM_NIL,
+ SCM_CLOSURE_ENV(proc));
+ } else {
+ SigScm_ErrorObj("lambda : bad syntax with ", args);
+ }
- /*
- * Notice
- *
- * The return obj of ScmExp_begin is the raw S-expression.
- * So we need to re-evaluate this!.
- */
- obj = ScmExp_begin(SCM_CDR(SCM_CLOSURE_EXP(proc)), &env, &tail_flag);
- return ScmOp_eval(obj, env);
- }
- default:
- SigScm_ErrorObj("apply : invalid application ", args);
+ /*
+ * Notice
+ *
+ * The return obj of ScmExp_begin is the raw S-expression.
+ * So we need to re-evaluate this!.
+ */
+ obj = ScmExp_begin(SCM_CDR(SCM_CLOSURE_EXP(proc)), &env, &tail_flag);
+ return ScmOp_eval(obj, env);
}
+ default:
+ SigScm_ErrorObj("apply : invalid application ", args);
+ }
/* never reaches here */
return SCM_NIL;
}
-
static ScmObj symbol_value(ScmObj var, ScmObj env)
{
ScmObj val = SCM_NIL;
@@ -712,11 +714,11 @@
/**
* The big bad full-implementation of quasiquote.
- *
+ *
* @param qexpr The expression given to quasiquote.
* @param env The effective environment.
* @param nest Nesting level of quasiquote. This function is recursive.
- *
+ *
* @return If qexpr or any of its subexpressions was evaluated, then
* (do-unquotes qexpr) is returned. Otherwise, the return
* value will test true for QQUOTE_IS_VERBATIM().
@@ -738,101 +740,100 @@
#define qquote_copy_delayed() (QQUOTE_IS_VERBATIM(ret_list))
#define qquote_force_copy_upto(end) \
do { \
- ScmObj src = qexpr; \
- ret_tail = &ret_list; \
- while (!EQ(src, end)) { \
- *ret_tail = Scm_NewCons(SCM_CAR(src), SCM_NIL); \
- ret_tail = &SCM_CDR(*ret_tail); \
- src = SCM_CDR(src); \
- } \
+ ScmObj src = qexpr; \
+ ret_tail = &ret_list; \
+ while (!EQ(src, end)) { \
+ *ret_tail = Scm_NewCons(SCM_CAR(src), SCM_NIL); \
+ ret_tail = &SCM_CDR(*ret_tail); \
+ src = SCM_CDR(src); \
+ } \
} while (0)
QQUOTE_SET_VERBATIM(ret_list); /* default return value */
if (SCM_CONSP(qexpr)) {
- car = SCM_CAR(qexpr);
- args = SCM_CDR(qexpr);
+ car = SCM_CAR(qexpr);
+ args = SCM_CDR(qexpr);
- if (EQ(car, SCM_UNQUOTE_SPLICING)) {
- if (!IS_LIST_LEN_1(args))
- SigScm_ErrorObj("syntax error: ", qexpr);
- if (--nest == 0)
- return ScmOp_eval(SCM_CAR(args), env);
- }
- else if (EQ(car, SCM_QUASIQUOTE)) {
- if (!IS_LIST_LEN_1(args))
- SigScm_ErrorObj("syntax error: ", qexpr);
- if (++nest <= 0)
- SigScm_Error("quasiquote: nesting too deep (circular list?)");
- }
+ if (EQ(car, SCM_UNQUOTE_SPLICING)) {
+ if (!IS_LIST_LEN_1(args))
+ SigScm_ErrorObj("syntax error: ", qexpr);
+ if (--nest == 0)
+ return ScmOp_eval(SCM_CAR(args), env);
+ } else if (EQ(car, SCM_QUASIQUOTE)) {
+ if (!IS_LIST_LEN_1(args))
+ SigScm_ErrorObj("syntax error: ", qexpr);
+ if (++nest <= 0)
+ SigScm_Error("quasiquote: nesting too deep (circular list?)");
+ }
}
for (ls = qexpr; SCM_CONSP(ls); ls = SCM_CDR(ls)) {
- obj = SCM_CAR(ls);
- splice_flag = 0;
+ obj = SCM_CAR(ls);
+ splice_flag = 0;
- if (SCM_CONSP(obj)) {
- result = qquote_internal(obj, env, nest);
+ if (SCM_CONSP(obj)) {
+ result = qquote_internal(obj, env, nest);
- if (EQ(SCM_CAR(obj), SCM_UNQUOTE_SPLICING) && nest == 1) {
- /* , at x */
- splice_flag = 1;
- }
- } else if (SCM_VECTORP(obj)) {
- /* #(x) */
- result = qquote_vector(obj, env, nest);
- } else if (EQ(obj, SCM_UNQUOTE) && IS_LIST_LEN_1(SCM_CDR(ls))) {
- /* we're at the comma in (x . ,y) or qexpr was ,z */
- if (--nest == 0) {
- result = ScmOp_eval(SCM_CADR(ls), env);
- goto append_last_item;
- }
- QQUOTE_SET_VERBATIM(result);
- } else {
- /* atom */
- QQUOTE_SET_VERBATIM(result);
- }
+ if (EQ(SCM_CAR(obj), SCM_UNQUOTE_SPLICING) && nest == 1) {
+ /* , at x */
+ splice_flag = 1;
+ }
+ } else if (SCM_VECTORP(obj)) {
+ /* #(x) */
+ result = qquote_vector(obj, env, nest);
+ } else if (EQ(obj, SCM_UNQUOTE) && IS_LIST_LEN_1(SCM_CDR(ls))) {
+ /* we're at the comma in (x . ,y) or qexpr was ,z */
+ if (--nest == 0) {
+ result = ScmOp_eval(SCM_CADR(ls), env);
+ goto append_last_item;
+ }
+ QQUOTE_SET_VERBATIM(result);
+ } else {
+ /* atom */
+ QQUOTE_SET_VERBATIM(result);
+ }
- if (QQUOTE_IS_VERBATIM(result)) {
- if (!qquote_copy_delayed()) {
- *ret_tail = Scm_NewCons(obj, SCM_NIL);
- ret_tail = &SCM_CDR(*ret_tail);
- }
- } else {
- if (qquote_copy_delayed())
- qquote_force_copy_upto(ls);
+ if (QQUOTE_IS_VERBATIM(result)) {
+ if (!qquote_copy_delayed()) {
+ *ret_tail = Scm_NewCons(obj, SCM_NIL);
+ ret_tail = &SCM_CDR(*ret_tail);
+ }
+ } else {
+ if (qquote_copy_delayed())
+ qquote_force_copy_upto(ls);
- if (splice_flag) {
- *ret_tail = result;
- /* find the new tail (which may be the current pos) */
- while (SCM_CONSP(*ret_tail))
- ret_tail = &SCM_CDR(*ret_tail);
- if (!SCM_NULLP(*ret_tail))
- SigScm_ErrorObj("unquote-splicing: bad list: ",
- result);
- } else {
- *ret_tail = Scm_NewCons(result, SCM_NIL);
- ret_tail = &SCM_CDR(*ret_tail);
- }
- }
+ if (splice_flag) {
+ *ret_tail = result;
+ /* find the new tail (which may be the current pos) */
+ while (SCM_CONSP(*ret_tail))
+ ret_tail = &SCM_CDR(*ret_tail);
+ if (!SCM_NULLP(*ret_tail))
+ SigScm_ErrorObj("unquote-splicing: bad list: ",
+ result);
+ } else {
+ *ret_tail = Scm_NewCons(result, SCM_NIL);
+ ret_tail = &SCM_CDR(*ret_tail);
+ }
+ }
} /* foreach ls in qexpr */
/* Handle the leftover of an improper list; if qexpr is a proper
- * list, all the following will be a no-op. */
+ * list, all the following will be a no-op. */
if (SCM_VECTORP(ls))
- result = qquote_vector(ls, env, nest);
+ result = qquote_vector(ls, env, nest);
else
- QQUOTE_SET_VERBATIM(result);
+ QQUOTE_SET_VERBATIM(result);
append_last_item:
if (QQUOTE_IS_VERBATIM(result)) {
- if (!qquote_copy_delayed())
- *ret_tail = ls;
+ if (!qquote_copy_delayed())
+ *ret_tail = ls;
} else {
- if (qquote_copy_delayed())
- qquote_force_copy_upto(ls);
- *ret_tail = result;
+ if (qquote_copy_delayed())
+ qquote_force_copy_upto(ls);
+ *ret_tail = result;
}
return ret_list;
@@ -868,78 +869,78 @@
(SCM_CONSP(o) && EQ(SCM_CAR(o), SCM_UNQUOTE_SPLICING))
#define qquote_force_copy_upto(n) \
do { \
- int k; \
- copy_buf = (ScmObj*)malloc((len + growth) * sizeof(ScmObj)); \
- memcpy(copy_buf, SCM_VECTOR_VEC(src), n*sizeof(ScmObj)); \
- /* wrap it now, or a cont invocation can leak it */ \
- ret = Scm_NewVector(copy_buf, len + growth); \
- /* fill with something the garbage collector recognizes */ \
- for (k=n; k < len + growth; k++) \
- copy_buf[k] = SCM_NIL; \
+ int k; \
+ copy_buf = (ScmObj*)malloc((len + growth) * sizeof(ScmObj)); \
+ memcpy(copy_buf, SCM_VECTOR_VEC(src), n*sizeof(ScmObj)); \
+ /* wrap it now, or a cont invocation can leak it */ \
+ ret = Scm_NewVector(copy_buf, len + growth); \
+ /* fill with something the garbage collector recognizes */ \
+ for (k=n; k < len + growth; k++) \
+ copy_buf[k] = SCM_NIL; \
} while(0)
QQUOTE_SET_VERBATIM(ret);
copy_buf = NULL;
if (nest == 1) {
- /* Evaluate all the splices first, in reverse order, and store
- * them in a list ((ls . index) (ls . index)...). */
- for (i = len - 1; i >= 0; i--) {
- expr = SCM_VECTOR_CREF(src, i);
- if (qquote_is_spliced(expr)) {
- if (!IS_LIST_LEN_1(SCM_CDR(expr)))
- SigScm_ErrorObj("syntax error: ", expr);
+ /* Evaluate all the splices first, in reverse order, and store
+ * them in a list ((ls . index) (ls . index)...). */
+ for (i = len - 1; i >= 0; i--) {
+ expr = SCM_VECTOR_CREF(src, i);
+ if (qquote_is_spliced(expr)) {
+ if (!IS_LIST_LEN_1(SCM_CDR(expr)))
+ SigScm_ErrorObj("syntax error: ", expr);
- result = ScmOp_eval(SCM_CADR(expr), env);
+ result = ScmOp_eval(SCM_CADR(expr), env);
- splice_len = ScmOp_length(result);
- if (SCM_INT_VALUE(splice_len) < 0)
- SigScm_Error("unquote-splicing: bad list");
+ splice_len = ScmOp_length(result);
+ if (SCM_INT_VALUE(splice_len) < 0)
+ SigScm_Error("unquote-splicing: bad list");
- growth += SCM_INT_VALUE(splice_len) - 1;
- splices = Scm_NewCons(Scm_NewCons(result, Scm_NewInt(i)),
- splices);
- }
- }
- if (!SCM_NULLP(splices)) {
- next_splice_index = SCM_INT_VALUE(SCM_CDAR(splices));
- qquote_force_copy_upto(0);
- }
+ growth += SCM_INT_VALUE(splice_len) - 1;
+ splices = Scm_NewCons(Scm_NewCons(result, Scm_NewInt(i)),
+ splices);
+ }
+ }
+ if (!SCM_NULLP(splices)) {
+ next_splice_index = SCM_INT_VALUE(SCM_CDAR(splices));
+ qquote_force_copy_upto(0);
+ }
}
for (i = j = 0; i < len; i++) {
- /* j will be the index for copy_buf */
- if (i == next_splice_index) {
- /* spliced */
- for (expr=SCM_CAAR(splices); !SCM_NULLP(expr); expr=SCM_CDR(expr))
- copy_buf[j++] = SCM_CAR(expr);
- splices = SCM_CDR(splices);
+ /* j will be the index for copy_buf */
+ if (i == next_splice_index) {
+ /* spliced */
+ for (expr=SCM_CAAR(splices); !SCM_NULLP(expr); expr=SCM_CDR(expr))
+ copy_buf[j++] = SCM_CAR(expr);
+ splices = SCM_CDR(splices);
- if (SCM_NULLP(splices))
- next_splice_index = -1;
- else
- next_splice_index = SCM_INT_VALUE(SCM_CDAR(splices));
- /* continue; */
- } else {
- expr = SCM_VECTOR_CREF(src, i);
- if (SCM_CONSP(expr))
- result = qquote_internal(expr, env, nest);
- else if (SCM_VECTORP(expr))
- result = qquote_vector(expr, env, nest);
- else
- QQUOTE_SET_VERBATIM(result);
+ if (SCM_NULLP(splices))
+ next_splice_index = -1;
+ else
+ next_splice_index = SCM_INT_VALUE(SCM_CDAR(splices));
+ /* continue; */
+ } else {
+ expr = SCM_VECTOR_CREF(src, i);
+ if (SCM_CONSP(expr))
+ result = qquote_internal(expr, env, nest);
+ else if (SCM_VECTORP(expr))
+ result = qquote_vector(expr, env, nest);
+ else
+ QQUOTE_SET_VERBATIM(result);
- if (!QQUOTE_IS_VERBATIM(result)) {
- if (qquote_copy_delayed())
- qquote_force_copy_upto(i);
+ if (!QQUOTE_IS_VERBATIM(result)) {
+ if (qquote_copy_delayed())
+ qquote_force_copy_upto(i);
- copy_buf[j] = result;
- } else if (!qquote_copy_delayed()) {
- copy_buf[j] = expr;
- }
+ copy_buf[j] = result;
+ } else if (!qquote_copy_delayed()) {
+ copy_buf[j] = expr;
+ }
- j++;
- }
+ j++;
+ }
}
return ret;
@@ -956,7 +957,7 @@
ScmObj ScmOp_quote(ScmObj obj, ScmObj *envp, int *tail_flag)
{
if (!SCM_CONSP(obj) || !SCM_NULLP(SCM_CDR(obj)))
- SigScm_ErrorObj("quote: bad argument list: ", obj);
+ SigScm_ErrorObj("quote: bad argument list: ", obj);
*tail_flag = 0;
return SCM_CAR(obj);
}
@@ -991,7 +992,7 @@
/* sanity check */
if (SCM_NULLP(exp) || SCM_NULLP(SCM_CDR(exp)))
- SigScm_Error("if : syntax error\n");
+ SigScm_ErrorObj("if : syntax error : ", exp);
/* eval predicates */
pred = ScmOp_eval(SCM_CAR(exp), env);
@@ -1105,13 +1106,13 @@
proc = ScmOp_eval(SCM_CAR(SCM_CDR(exps)), env);
if (EQ(ScmOp_procedurep(proc), SCM_FALSE))
SigScm_ErrorObj("cond : the value of exp after => must be the procedure but got ", proc);
-
+
return ScmOp_apply(Scm_NewCons(proc,
Scm_NewCons(Scm_NewCons(test, SCM_NIL),
SCM_NIL)),
env);
}
-
+
return ScmExp_begin(exps, &env, tail_flag);
}
}
@@ -1255,8 +1256,8 @@
if (SCM_CONSP(bindings) || SCM_NULLP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
- if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
- SigScm_ErrorObj("let : invalid binding form : ", binding);
+ if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
+ SigScm_ErrorObj("let : invalid binding form : ", binding);
vars = Scm_NewCons(SCM_CAR(binding), vars);
vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), vals);
@@ -1328,9 +1329,9 @@
if (SCM_CONSP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
- if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
- SigScm_ErrorObj("let* : invalid binding form : ", binding);
-
+ if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
+ SigScm_ErrorObj("let* : invalid binding form : ", binding);
+
vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), SCM_NIL);
@@ -1388,8 +1389,8 @@
if (SCM_CONSP(bindings) || SCM_NULLP(bindings)) {
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
- if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
- SigScm_ErrorObj("letrec : invalid binding form : ", binding);
+ if (SCM_NULLP(binding) || SCM_NULLP(SCM_CDR(binding)))
+ SigScm_ErrorObj("letrec : invalid binding form : ", binding);
var = SCM_CAR(binding);
val = SCM_CAR(SCM_CDR(binding));
@@ -1416,7 +1417,7 @@
for (; !SCM_NULLP(vals); vals = SCM_CDR(vals)) {
SCM_SETCAR(vals, ScmOp_eval(SCM_CAR(vals), env));
}
-
+
/* evaluate body */
return ScmExp_begin(body, &env, tail_flag);
}
@@ -1436,7 +1437,7 @@
{
ScmObj env = *envp;
ScmObj exp = SCM_NIL;
-
+
/* set tail_flag */
(*tail_flag) = 1;
@@ -1453,14 +1454,14 @@
/* return last expression's result */
if (EQ(SCM_CDR(arg), SCM_NIL)) {
/* doesn't evaluate exp now for tail-recursion. */
- return exp;
+ return exp;
}
/* evaluate exp */
ScmOp_eval(exp, env);
/* set new env */
- *envp = env;
+ *envp = env;
}
/* set tail_flag */
@@ -1509,7 +1510,7 @@
/* append <step> to steps */
step = SCM_CDR(SCM_CDR(binding));
if (SCM_NULLP(step))
- steps = Scm_NewCons(SCM_CAR(binding), steps);
+ steps = Scm_NewCons(SCM_CAR(binding), steps);
else
steps = Scm_NewCons(SCM_CAR(step), steps);
}
@@ -1584,20 +1585,20 @@
{
ScmObj ret;
if (!IS_LIST_LEN_1(obj))
- SigScm_ErrorObj("quasiquote: bad argument list: ", obj);
+ SigScm_ErrorObj("quasiquote: bad argument list: ", obj);
obj = SCM_CAR(obj);
ret = qquote_internal(obj, *envp, 1);
*tail_flag = 0;
if (QQUOTE_IS_VERBATIM(ret))
- return obj;
+ return obj;
return ret;
}
ScmObj ScmOp_unquote(ScmObj obj, ScmObj *envp, int *tail_flag)
{
if (!SCM_CONSP(obj) || !SCM_NULLP(SCM_CDR(obj)))
- SigScm_ErrorObj("unquote: bad argument list: ", obj);
+ SigScm_ErrorObj("unquote: bad argument list: ", obj);
SigScm_Error("unquote outside quasiquote");
return SCM_NIL;
}
@@ -1605,7 +1606,7 @@
ScmObj ScmOp_unquote_splicing(ScmObj obj, ScmObj *envp, int *tail_flag)
{
if (!SCM_CONSP(obj) || !SCM_NULLP(SCM_CDR(obj)))
- SigScm_ErrorObj("unquote-splicing: bad argument list: ", obj);
+ SigScm_ErrorObj("unquote-splicing: bad argument list: ", obj);
SigScm_Error("unquote-splicing outside quasiquote");
return SCM_NIL;
}
@@ -1708,7 +1709,7 @@
ScmObj ScmOp_symbol_value(ScmObj var)
{
if (!SCM_SYMBOLP(var))
- SigScm_ErrorObj("symbol-value : require symbol but got ", var);
+ SigScm_ErrorObj("symbol-value : require symbol but got ", var);
return symbol_value(var, SCM_NIL);
}
@@ -1717,7 +1718,7 @@
{
/* sanity check */
if (!SCM_SYMBOLP(var))
- SigScm_ErrorObj("set-symbol-value! : require symbol but got ", var);
+ SigScm_ErrorObj("set-symbol-value! : require symbol but got ", var);
return SCM_SYMBOL_VCELL(var);
}
@@ -1725,9 +1726,9 @@
ScmObj ScmOp_bit_and(ScmObj obj1, ScmObj obj2)
{
if (!SCM_INTP(obj1))
- SigScm_ErrorObj("bit-and : number required but got ", obj1);
+ SigScm_ErrorObj("bit-and : number required but got ", obj1);
if (!SCM_INTP(obj2))
- SigScm_ErrorObj("bit-and : number required but got ", obj2);
+ SigScm_ErrorObj("bit-and : number required but got ", obj2);
return Scm_NewInt(SCM_INT_VALUE(obj1) & SCM_INT_VALUE(obj2));
}
@@ -1735,9 +1736,9 @@
ScmObj ScmOp_bit_or(ScmObj obj1, ScmObj obj2)
{
if (!SCM_INTP(obj1))
- SigScm_ErrorObj("bit-or : number required but got ", obj1);
+ SigScm_ErrorObj("bit-or : number required but got ", obj1);
if (!SCM_INTP(obj2))
- SigScm_ErrorObj("bit-or : number required but got ", obj2);
+ SigScm_ErrorObj("bit-or : number required but got ", obj2);
return Scm_NewInt(SCM_INT_VALUE(obj1) | SCM_INT_VALUE(obj2));
}
@@ -1745,9 +1746,9 @@
ScmObj ScmOp_bit_xor(ScmObj obj1, ScmObj obj2)
{
if (!SCM_INTP(obj1))
- SigScm_ErrorObj("bit-xor : number required but got ", obj1);
+ SigScm_ErrorObj("bit-xor : number required but got ", obj1);
if (!SCM_INTP(obj2))
- SigScm_ErrorObj("bit-xor : number required but got ", obj2);
+ SigScm_ErrorObj("bit-xor : number required but got ", obj2);
return Scm_NewInt(SCM_INT_VALUE(obj1) ^ SCM_INT_VALUE(obj2));
}
@@ -1755,7 +1756,7 @@
ScmObj ScmOp_bit_not(ScmObj obj)
{
if (!SCM_INTP(obj))
- SigScm_ErrorObj("bit-not : number required but got ", obj);
+ SigScm_ErrorObj("bit-not : number required but got ", obj);
return Scm_NewInt(~SCM_INT_VALUE(obj));
}
@@ -1768,7 +1769,7 @@
ScmObj ScmOp_closure_code(ScmObj closure)
{
if (!SCM_CLOSUREP(closure))
- SigScm_ErrorObj("%%closure-code : closure required but got ", closure);
+ SigScm_ErrorObj("%%closure-code : closure required but got ", closure);
return SCM_CLOSURE_EXP(closure);
}
Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/io.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -461,7 +461,7 @@
feature.
*/
if (!filepath)
- return SCM_FALSE;
+ return SCM_FALSE;
/* open port */
port = ScmOp_open_input_file(Scm_NewStringCopying(filepath));
@@ -494,31 +494,31 @@
/* construct filepath */
if (lib_path) {
- /* try absolute path */
- if (file_existsp(c_filename))
- return c_filename;
+ /* try absolute path */
+ if (file_existsp(c_filename))
+ return c_filename;
- /* use lib_path */
+ /* use lib_path */
filepath = (char*)malloc(strlen(lib_path) + strlen(c_filename) + 2);
strcpy(filepath, lib_path);
strcat(filepath, "/");
strcat(filepath, c_filename);
- if (file_existsp(filepath)) {
- free(c_filename);
- return filepath;
- }
+ if (file_existsp(filepath)) {
+ free(c_filename);
+ return filepath;
+ }
}
/* clear */
if (filepath)
- free(filepath);
+ free(filepath);
/* fallback */
filepath = (char*)malloc(strlen(c_filename) + 1);
strcpy(filepath, c_filename);
if (file_existsp(filepath)) {
- free(c_filename);
- return filepath;
+ free(c_filename);
+ return filepath;
}
free(c_filename);
@@ -605,7 +605,7 @@
SigScm_ErrorObj("file-exists? : string requred but got ", filepath);
if (file_existsp(SCM_STRING_STR(filepath)))
- return SCM_TRUE;
+ return SCM_TRUE;
return SCM_FALSE;
}
Modified: branches/r5rs/sigscheme/main.c
===================================================================
--- branches/r5rs/sigscheme/main.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/main.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -72,12 +72,12 @@
printf("sscm> ");
for( s_exp = SigScm_Read(stdin_port);
- !EQ(s_exp, SCM_EOF);
- s_exp = SigScm_Read(stdin_port))
+ !EQ(s_exp, SCM_EOF);
+ s_exp = SigScm_Read(stdin_port))
{
- result = ScmOp_eval(s_exp, SCM_NIL);
- SigScm_DisplayToPort(stdout_port, result);
- printf("\nsscm> ");
+ result = ScmOp_eval(s_exp, SCM_NIL);
+ SigScm_DisplayToPort(stdout_port, result);
+ printf("\nsscm> ");
}
ScmOp_close_input_port(stdin_port);
@@ -98,7 +98,7 @@
if (argc < 2) {
repl();
- /* SigScm_Error("usage : sscm <filename>\n"); */
+ /* SigScm_Error("usage : sscm <filename>\n"); */
} else {
SigScm_load(filename);
}
@@ -106,4 +106,3 @@
SigScm_Finalize();
return 0;
}
-
Modified: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/operations-srfi1.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -58,13 +58,13 @@
static ScmObj list_gettailcons(ScmObj head)
{
if (SCM_NULLP(head))
- return SCM_NIL;
+ return SCM_NIL;
if (SCM_NULLP(SCM_CDR(head)))
- return head;
+ return head;
for (; !SCM_NULLP(head); head = SCM_CDR(head)) {
- if (SCM_NULLP(SCM_CDR(head)))
- return head;
+ if (SCM_NULLP(SCM_CDR(head)))
+ return head;
}
SigScm_Error("list_gettailcons : cannot get tailcons?\n");
@@ -88,15 +88,15 @@
ScmObj prev_tail = obj;
if (SCM_NULLP(SCM_CDR(obj)))
- return SCM_CAR(obj);
+ return SCM_CAR(obj);
for (tail_cons = SCM_CDR(obj); !SCM_NULLP(tail_cons); tail_cons = SCM_CDR(tail_cons)) {
- /* check tail cons cell */
- if (SCM_NULLP(SCM_CDR(tail_cons))) {
- SCM_SETCDR(prev_tail, SCM_CAR(tail_cons));
- }
+ /* check tail cons cell */
+ if (SCM_NULLP(SCM_CDR(tail_cons))) {
+ SCM_SETCDR(prev_tail, SCM_CAR(tail_cons));
+ }
- prev_tail = tail_cons;
+ prev_tail = tail_cons;
}
return obj;
@@ -111,23 +111,23 @@
/* sanity check */
if CHECK_1_ARG(args)
- SigScm_Error("make-llist : require at least 1 arg\n");
+ SigScm_Error("make-llist : require at least 1 arg\n");
if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
- SigScm_ErrorObj("make-list : number required but got ", SCM_CAR(args));
+ SigScm_ErrorObj("make-list : number required but got ", SCM_CAR(args));
/* get n */
n = SCM_INT_VALUE(SCM_CAR(args));
/* get filler if available */
if (!SCM_NULLP(SCM_CDR(args)))
- fill = SCM_CAR(SCM_CDR(args));
+ fill = SCM_CAR(SCM_CDR(args));
/* then create list */
for (i = n; 0 < i; i--) {
- if (!SCM_NULLP(fill))
- head = Scm_NewCons(fill, head);
- else
- head = Scm_NewCons(Scm_NewInt(i), head);
+ if (!SCM_NULLP(fill))
+ head = Scm_NewCons(fill, head);
+ else
+ head = Scm_NewCons(Scm_NewInt(i), head);
}
return head;
@@ -144,27 +144,27 @@
/* sanity check */
if (EQ(ScmOp_numberp(scm_n), SCM_FALSE))
- SigScm_ErrorObj("list-tabulate : number required but got ", scm_n);
+ SigScm_ErrorObj("list-tabulate : number required but got ", scm_n);
/* get n */
n = SCM_INT_VALUE(scm_n);
/* get init_proc if available */
if (!SCM_NULLP(SCM_CDR(args)))
- proc = SCM_CAR(SCM_CDR(args));
+ proc = SCM_CAR(SCM_CDR(args));
/* then create list */
for (i = n; 0 < i; i--) {
- num = Scm_NewInt(i - 1);
+ num = Scm_NewInt(i - 1);
- if (!SCM_NULLP(proc)) {
- /* evaluate (proc num) */
- num = ScmOp_eval(Scm_NewCons(proc,
- Scm_NewCons(num, SCM_NIL)),
- env);
- }
+ if (!SCM_NULLP(proc)) {
+ /* evaluate (proc num) */
+ num = ScmOp_eval(Scm_NewCons(proc,
+ Scm_NewCons(num, SCM_NIL)),
+ env);
+ }
- head = Scm_NewCons(num, head);
+ head = Scm_NewCons(num, head);
}
return head;
@@ -177,24 +177,24 @@
ScmObj obj = SCM_NIL;
if (EQ(ScmOp_listp(list), SCM_FALSE))
- SigScm_ErrorObj("list-copy : list required but got ", list);
+ SigScm_ErrorObj("list-copy : list required but got ", list);
for (; !SCM_NULLP(list); list = SCM_CDR(list)) {
- obj = SCM_CAR(list);
+ obj = SCM_CAR(list);
- /* further copy */
- if (SCM_CONSP(obj))
- obj = ScmOp_SRFI_1_list_copy(obj);
+ /* further copy */
+ if (SCM_CONSP(obj))
+ obj = ScmOp_SRFI_1_list_copy(obj);
- /* then create new cons */
- obj = Scm_NewCons(obj, SCM_NIL);
- if (!SCM_NULLP(tail)) {
- SCM_SETCDR(tail, obj);
- tail = obj;
- } else {
- head = obj;
- tail = head;
- }
+ /* then create new cons */
+ obj = Scm_NewCons(obj, SCM_NIL);
+ if (!SCM_NULLP(tail)) {
+ SCM_SETCDR(tail, obj);
+ tail = obj;
+ } else {
+ head = obj;
+ tail = head;
+ }
}
return head;
@@ -205,7 +205,7 @@
ScmObj tailcons = SCM_NIL;
if (EQ(ScmOp_listp(list), SCM_FALSE))
- SigScm_ErrorObj("circular-list : list required but got ", list);
+ SigScm_ErrorObj("circular-list : list required but got ", list);
tailcons = list_gettailcons(list);
SCM_SETCDR(tailcons, list);
@@ -226,33 +226,33 @@
/* sanity check */
if CHECK_1_ARG(args)
- SigScm_Error("iota : required at least 1 arg\n");
+ SigScm_Error("iota : required at least 1 arg\n");
/* get params */
scm_count = SCM_CAR(args);
if (!SCM_NULLP(SCM_CDR(args)))
- scm_start = SCM_CAR(SCM_CDR(args));
+ scm_start = SCM_CAR(SCM_CDR(args));
if (!SCM_NULLP(scm_start) && !SCM_NULLP(SCM_CDR(SCM_CDR(args))))
- scm_step = SCM_CAR(SCM_CDR(SCM_CDR(args)));
+ scm_step = SCM_CAR(SCM_CDR(SCM_CDR(args)));
/* param type check */
if (EQ(ScmOp_numberp(scm_count), SCM_FALSE))
- SigScm_ErrorObj("iota : number required but got ", scm_count);
+ SigScm_ErrorObj("iota : number required but got ", scm_count);
if (!SCM_NULLP(scm_start) && EQ(ScmOp_numberp(scm_start), SCM_FALSE))
- SigScm_ErrorObj("iota : number required but got ", scm_start);
+ SigScm_ErrorObj("iota : number required but got ", scm_start);
if (!SCM_NULLP(scm_step) && EQ(ScmOp_numberp(scm_step), SCM_FALSE))
- SigScm_ErrorObj("iota : number required but got ", scm_step);
+ SigScm_ErrorObj("iota : number required but got ", scm_step);
/* now create list */
count = SCM_INT_VALUE(scm_count);
start = SCM_NULLP(scm_start) ? 0 : SCM_INT_VALUE(scm_start);
step = SCM_NULLP(scm_step) ? 1 : SCM_INT_VALUE(scm_step);
for (i = count - 1; 0 <= i; i--) {
- head = Scm_NewCons(Scm_NewInt(start + i*step), head);
+ head = Scm_NewCons(Scm_NewInt(start + i*step), head);
}
return head;
Modified: branches/r5rs/sigscheme/operations-srfi8.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi8.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/operations-srfi8.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -77,7 +77,7 @@
/* sanity check */
if (CHECK_3_ARGS(args))
- SigScm_ErrorObj("receive: bad argument list: ", args);
+ SigScm_ErrorObj("receive: bad argument list: ", args);
/* set tail_flag */
(*tail_flag) = 1;
@@ -91,9 +91,9 @@
actuals = ScmOp_eval(expr, env);
if (SCM_VALUEPACKETP(actuals))
- actuals = SCM_VALUEPACKET_VALUES(actuals);
+ actuals = SCM_VALUEPACKET_VALUES(actuals);
else
- actuals = Scm_NewCons(actuals, SCM_NIL);
+ actuals = Scm_NewCons(actuals, SCM_NIL);
closure = Scm_NewClosure(Scm_NewCons(formals, body), env);
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/operations.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -84,37 +84,33 @@
/* same type */
switch (type) {
- case ScmInt:
- /* both numbers, are numerically equal */
- if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2)))
- {
- return SCM_TRUE;
- }
- break;
- case ScmChar:
- /* chars and are the same character according to the char=? */
- if (EQ(ScmOp_char_equal(obj1, obj2), SCM_TRUE))
- {
- return SCM_TRUE;
- }
- break;
- case ScmSymbol: /* equivalent symbols must already be true on eq? */
- case ScmCons:
- case ScmVector:
- case ScmString:
- case ScmFunc:
- case ScmClosure:
- case ScmPort:
- case ScmContinuation:
- case ScmEtc:
- break;
- case ScmFreeCell:
- SigScm_Error("eqv? : cannnot compare freecell, gc broken?\n");
- break;
- case ScmCPointer:
- case ScmCFuncPointer:
- case ScmValuePacket:
- break;
+ case ScmInt:
+ /* both numbers, are numerically equal */
+ if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2))) return SCM_TRUE;
+ break;
+ case ScmChar:
+ /* chars and are the same character according to the char=? */
+ if (EQ(ScmOp_char_equal(obj1, obj2), SCM_TRUE)) return SCM_TRUE;
+ break;
+ case ScmSymbol: /* equivalent symbols must already be true on eq? */
+ case ScmCons:
+ case ScmVector:
+ case ScmString:
+ case ScmFunc:
+ case ScmClosure:
+ case ScmPort:
+ case ScmContinuation:
+ case ScmValuePacket:
+ break;
+ case ScmEtc:
+ break;
+ case ScmFreeCell:
+ SigScm_Error("eqv? : cannnot compare freecell, gc broken?\n");
+ break;
+
+ case ScmCPointer:
+ case ScmCFuncPointer:
+ break;
}
return SCM_FALSE;
@@ -141,97 +137,79 @@
/* same type */
switch (type) {
- case ScmInt:
- /* both numbers, are numerically equal */
- if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2)))
- {
- return SCM_TRUE;
- }
- break;
- case ScmChar:
- /* chars and are the same character according to the char=? */
- if (EQ(ScmOp_char_equal(obj1, obj2), SCM_TRUE))
- {
- return SCM_TRUE;
- }
- break;
- case ScmCons:
- for (; !SCM_NULLP(obj1); obj1 = SCM_CDR(obj1), obj2 = SCM_CDR(obj2))
- {
- /* check contents */
- if (EQ(ScmOp_equalp(SCM_CAR(obj1), SCM_CAR(obj2)), SCM_FALSE))
- {
- return SCM_FALSE;
- }
+ case ScmInt:
+ /* both numbers, are numerically equal */
+ if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2))) return SCM_TRUE;
+ break;
- /* check next cdr's type */
- if (SCM_GETTYPE(SCM_CDR(obj1)) != SCM_GETTYPE(SCM_CDR(obj2)))
- {
- return SCM_FALSE;
- }
+ case ScmChar:
+ /* chars and are the same character according to the char=? */
+ if (EQ(ScmOp_char_equal(obj1, obj2), SCM_TRUE)) return SCM_TRUE;
+ break;
- /* check dot pair */
- if (!SCM_CONSP(SCM_CDR(obj1)))
- {
- if(EQ(ScmOp_equalp(SCM_CDR(obj1), SCM_CDR(obj2)), SCM_FALSE))
- return SCM_FALSE;
- else
- return SCM_TRUE;
- }
- }
- return SCM_TRUE;
- case ScmVector:
- /* check len */
- if (SCM_VECTOR_LEN(obj1) != SCM_VECTOR_LEN(obj2))
- {
- return SCM_FALSE;
- }
- /* check contents */
- for (i = 0; i < SCM_VECTOR_LEN(obj1); i++)
- {
- if (EQ(ScmOp_equalp(SCM_VECTOR_CREF(obj1, i), SCM_VECTOR_CREF(obj2, i)), SCM_FALSE))
- return SCM_FALSE;
- }
- return SCM_TRUE;
- case ScmString:
- /* check string data */
- if (strcmp(SCM_STRING_STR(obj1), SCM_STRING_STR(obj2)) == 0)
- {
- return SCM_TRUE;
- }
- break;
- case ScmFunc:
- case ScmClosure:
- case ScmPort:
- case ScmContinuation:
- {
- return SCM_UNSPECIFIED;
+ case ScmCons:
+ for (; !SCM_NULLP(obj1); obj1 = SCM_CDR(obj1), obj2 = SCM_CDR(obj2)) {
+ /* check contents */
+ if (EQ(ScmOp_equalp(SCM_CAR(obj1), SCM_CAR(obj2)), SCM_FALSE))
+ return SCM_FALSE;
+
+ /* check next cdr's type */
+ if (SCM_GETTYPE(SCM_CDR(obj1)) != SCM_GETTYPE(SCM_CDR(obj2)))
+ return SCM_FALSE;
+
+ /* check dot pair */
+ if (!SCM_CONSP(SCM_CDR(obj1))) {
+ if(EQ(ScmOp_equalp(SCM_CDR(obj1), SCM_CDR(obj2)), SCM_FALSE))
+ return SCM_FALSE;
+ else
+ return SCM_TRUE;
}
- break;
- case ScmSymbol: /* equivalent symbols must already be true on eq? */
- case ScmEtc:
- break;
- case ScmFreeCell:
- SigScm_Error("equal? : cannnot compare freecell, gc broken?\n");
- break;
- case ScmCPointer:
- if (SCM_C_POINTER_DATA(obj1) == SCM_C_POINTER_DATA(obj2))
- {
- return SCM_TRUE;
- }
- break;
- case ScmCFuncPointer:
- if (SCM_C_FUNCPOINTER_FUNC(obj1) == SCM_C_FUNCPOINTER_FUNC(obj2))
- {
- return SCM_TRUE;
- }
- break;
- case ScmValuePacket:
- if (EQ(SCM_VALUEPACKET_VALUES(obj1), SCM_VALUEPACKET_VALUES(obj2)))
- {
- return SCM_TRUE;
- }
- break;
+ }
+ return SCM_TRUE;
+
+ case ScmVector:
+ /* check len */
+ if (SCM_VECTOR_LEN(obj1) != SCM_VECTOR_LEN(obj2))
+ return SCM_FALSE;
+
+ /* check contents */
+ for (i = 0; i < SCM_VECTOR_LEN(obj1); i++) {
+ if (EQ(ScmOp_equalp(SCM_VECTOR_CREF(obj1, i), SCM_VECTOR_CREF(obj2, i)), SCM_FALSE))
+ return SCM_FALSE;
+ }
+ return SCM_TRUE;
+
+ case ScmString:
+ /* check string data */
+ if (strcmp(SCM_STRING_STR(obj1), SCM_STRING_STR(obj2)) == 0)
+ return SCM_TRUE;
+ break;
+
+ case ScmSymbol: /* equivalent symbols must already be true on eq? */
+ break;
+ case ScmFunc:
+ case ScmClosure:
+ case ScmPort:
+ case ScmContinuation:
+ return SCM_UNSPECIFIED;
+ case ScmValuePacket:
+ if (EQ(SCM_VALUEPACKET_VALUES(obj1), SCM_VALUEPACKET_VALUES(obj2)))
+ return SCM_TRUE;
+ break;
+ case ScmEtc:
+ break;
+ case ScmFreeCell:
+ SigScm_Error("equal? : cannnot compare freecell, gc broken?\n");
+ break;
+
+ case ScmCPointer:
+ if (SCM_C_POINTER_DATA(obj1) == SCM_C_POINTER_DATA(obj2))
+ return SCM_TRUE;
+ break;
+ case ScmCFuncPointer:
+ if (SCM_C_FUNCPOINTER_FUNC(obj1) == SCM_C_FUNCPOINTER_FUNC(obj2))
+ return SCM_TRUE;
+ break;
}
return SCM_FALSE;
@@ -252,10 +230,10 @@
ScmObj operand;
for (ls = args; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
- operand = SCM_CAR(ls);
- if (!SCM_INTP(operand))
- SigScm_ErrorObj("+ : integer required but got ", operand);
- result += SCM_INT_VALUE(operand);
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("+ : integer required but got ", operand);
+ result += SCM_INT_VALUE(operand);
}
return Scm_NewInt(result);
@@ -268,10 +246,10 @@
ScmObj ls;
for (ls=args; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
- operand = SCM_CAR(ls);
- if (!SCM_INTP(operand))
- SigScm_ErrorObj("* : integer required but got ", operand);
- result *= SCM_INT_VALUE(operand);
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("* : integer required but got ", operand);
+ result *= SCM_INT_VALUE(operand);
}
return Scm_NewInt(result);
@@ -285,20 +263,20 @@
ls = args;
if (SCM_NULLP(ls))
- SigScm_Error("- : at least 1 argument required");
+ SigScm_Error("- : at least 1 argument required");
result = SCM_INT_VALUE(SCM_CAR(ls));
ls = SCM_CDR(ls);
/* single arg */
if (SCM_NULLP(ls))
- return Scm_NewInt(-result);
+ return Scm_NewInt(-result);
for (; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
- operand = SCM_CAR(ls);
- if (!SCM_INTP(operand))
- SigScm_ErrorObj("- : integer required but got ", operand);
- result -= SCM_INT_VALUE(operand);
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("- : integer required but got ", operand);
+ result -= SCM_INT_VALUE(operand);
}
return Scm_NewInt(result);
@@ -311,23 +289,23 @@
ScmObj ls;
if (SCM_NULLP(args))
- SigScm_Error("/ : at least 1 argument required");
+ SigScm_Error("/ : at least 1 argument required");
result = SCM_INT_VALUE(SCM_CAR(args));
ls = SCM_CDR(args);
/* single arg */
if (SCM_NULLP(ls))
- return Scm_NewInt(1 / result);
+ return Scm_NewInt(1 / result);
for (; !SCM_NULLP(ls); ls = SCM_CDR(ls)) {
- operand = SCM_CAR(ls);
- if (!SCM_INTP(operand))
- SigScm_ErrorObj("/ : integer required but got ", operand);
+ operand = SCM_CAR(ls);
+ if (!SCM_INTP(operand))
+ SigScm_ErrorObj("/ : integer required but got ", operand);
- if (SCM_INT_VALUE(operand) == 0)
- SigScm_ErrorObj("/ : division by zero ", args);
- result /= SCM_INT_VALUE(operand);
+ if (SCM_INT_VALUE(operand) == 0)
+ SigScm_ErrorObj("/ : division by zero ", args);
+ result /= SCM_INT_VALUE(operand);
}
return Scm_NewInt(result);
@@ -510,10 +488,7 @@
if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
SigScm_ErrorObj("zero? : number required but got ", scm_num);
- if (SCM_INT_VALUE(scm_num) == 0)
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (SCM_INT_VALUE(scm_num) == 0) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_positivep(ScmObj scm_num)
@@ -521,10 +496,7 @@
if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
SigScm_ErrorObj("positive? : number required but got", scm_num);
- if (SCM_INT_VALUE(scm_num) > 0)
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (SCM_INT_VALUE(scm_num) > 0) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_negativep(ScmObj scm_num)
@@ -532,10 +504,7 @@
if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
SigScm_ErrorObj("negative? : number required but got ", scm_num);
- if (SCM_INT_VALUE(scm_num) < 0)
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (SCM_INT_VALUE(scm_num) < 0) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_oddp(ScmObj scm_num)
@@ -562,7 +531,7 @@
ScmObj maxobj = SCM_NIL;
if (SCM_NULLP(args))
- SigScm_Error("max : at least 1 number required\n");
+ SigScm_Error("max : at least 1 number required\n");
for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
car = SCM_CAR(args);
@@ -572,8 +541,8 @@
car_val = SCM_INT_VALUE(car);
if (max < car_val) {
max = car_val;
- maxobj = car;
- }
+ maxobj = car;
+ }
}
return Scm_NewInt(max);
@@ -587,7 +556,7 @@
ScmObj minobj = SCM_NIL;
if (SCM_NULLP(args))
- SigScm_Error("min : at least 1 number required\n");
+ SigScm_Error("min : at least 1 number required\n");
for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
car = SCM_CAR(args);
@@ -597,8 +566,8 @@
car_val = SCM_INT_VALUE(car);
if (car_val < min) {
min = car_val;
- minobj = car;
- }
+ minobj = car;
+ }
}
return minobj;
@@ -613,10 +582,8 @@
SigScm_ErrorObj("abs : number required but got ", scm_num);
num = SCM_INT_VALUE(scm_num);
- if (0 < num)
- return scm_num;
- return Scm_NewInt(-num);
+ return (num < 0) ? Scm_NewInt(-num) : scm_num;
}
ScmObj ScmOp_quotient(ScmObj scm_n1, ScmObj scm_n2)
@@ -706,16 +673,16 @@
else {
#ifdef SCM_STRICT_ARGCHECK
if (!SCM_NULLP(SCM_CDDR(args)))
- SigScm_ErrorObj("number->string: too many arguments: ", args);
+ SigScm_ErrorObj("number->string: too many arguments: ", args);
#endif
radix = SCM_CADR(args);
if (!SCM_INTP(radix))
- SigScm_ErrorObj("number->string: integer required but got ", radix);
+ SigScm_ErrorObj("number->string: integer required but got ", radix);
r = SCM_INT_VALUE(radix);
if (!(2 <= r && r <= 16))
- SigScm_ErrorObj("number->string: invalid or unsupported radix: ",
- radix);
+ SigScm_ErrorObj("number->string: invalid or unsupported radix: ",
+ radix);
}
/* no signs for nondecimals */
@@ -729,9 +696,9 @@
do
{
if (n % r > 9)
- *--p = 'A' + n % r - 10;
+ *--p = 'A' + n % r - 10;
else
- *--p = '0' + n % r;
+ *--p = '0' + n % r;
}
while (n /= r);
if (r == 10 && SCM_INT_VALUE (number) < 0)
@@ -748,13 +715,13 @@
size_t len = 0;
if (!SCM_STRINGP(string))
- SigScm_ErrorObj("string->number : string required but got ", string);
+ SigScm_ErrorObj("string->number : string required but got ", string);
str = SCM_STRING_STR(string);
len = strlen(str);
for (p = str; p < str + len; p++) {
- if (isdigit(*p) == 0)
- return SCM_FALSE;
+ if (isdigit(*p) == 0)
+ return SCM_FALSE;
}
return Scm_NewInt((int)atoi(SCM_STRING_STR(string)));
@@ -768,18 +735,12 @@
==============================================================================*/
ScmObj ScmOp_not(ScmObj obj)
{
- if (EQ(obj, SCM_FALSE))
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (EQ(obj, SCM_FALSE)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_booleanp(ScmObj obj)
{
- if (EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE))
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE)) ? SCM_TRUE : SCM_FALSE;
}
/*==============================================================================
@@ -799,7 +760,7 @@
SigScm_Error("car : empty list\n");
#endif
if (SCM_NULLP(obj))
- return SCM_NIL;
+ return SCM_NIL;
if (!SCM_CONSP(obj))
SigScm_ErrorObj("car : list required but got ", obj);
@@ -821,7 +782,7 @@
SigScm_Error("cdr : empty list\n");
#endif
if (SCM_NULLP(obj))
- return SCM_NIL;
+ return SCM_NIL;
if (!SCM_CONSP(obj))
SigScm_ErrorObj("cdr : list required but got ", obj);
@@ -831,10 +792,7 @@
ScmObj ScmOp_pairp(ScmObj obj)
{
- if (SCM_CONSP(obj))
- return SCM_TRUE;
- else
- return SCM_FALSE;
+ return (SCM_CONSP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_cons(ScmObj car, ScmObj cdr)
@@ -982,10 +940,7 @@
ScmObj ScmOp_nullp(ScmObj obj)
{
- if (SCM_NULLP(obj))
- return SCM_TRUE;
-
- return SCM_FALSE;
+ return (SCM_NULLP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_listp(ScmObj obj)
@@ -993,15 +948,13 @@
int len = 0;
if (SCM_NULLP(obj))
- return SCM_TRUE;
+ return SCM_TRUE;
if (!SCM_CONSP(obj))
- return SCM_FALSE;
+ return SCM_FALSE;
len = ScmOp_c_length(obj);
- if (len == -1)
- return SCM_FALSE;
- return SCM_TRUE;
+ return (len != -1) ? SCM_TRUE : SCM_FALSE;
}
/*
@@ -1017,17 +970,17 @@
for (;;) {
if (SCM_NULLP(obj)) break;
if (!SCM_CONSP(obj)) return -1;
- if (len != 0 && obj == slow) return -1; /* circular */
+ if (len != 0 && obj == slow) return -1; /* circular */
- obj = SCM_CDR(obj);
- len++;
+ obj = SCM_CDR(obj);
+ len++;
if (SCM_NULLP(obj)) break;
if (!SCM_CONSP(obj)) return -1;
- if (obj == slow) return -1; /* circular */
+ if (obj == slow) return -1; /* circular */
- obj = SCM_CDR(obj);
- slow = SCM_CDR(slow);
- len++;
+ obj = SCM_CDR(obj);
+ slow = SCM_CDR(slow);
+ len++;
}
return len;
@@ -1047,18 +1000,18 @@
ScmObj obj = SCM_NIL;
if (SCM_NULLP(args))
- return SCM_NIL;
+ return SCM_NIL;
/* duplicate and merge all but the last argument */
for (; !SCM_NULLP(SCM_CDR(args)); args = SCM_CDR(args)) {
- for (ls = SCM_CAR(args); SCM_CONSP(ls); ls = SCM_CDR(ls)) {
- obj = SCM_CAR(ls);
- *ret_tail = Scm_NewCons(obj, SCM_NIL);
- ret_tail = &SCM_CDR(*ret_tail);
- }
- if (!SCM_NULLP(ls))
- SigScm_ErrorObj("append: proper list required but got: ",
- SCM_CAR(args));
+ for (ls = SCM_CAR(args); SCM_CONSP(ls); ls = SCM_CDR(ls)) {
+ obj = SCM_CAR(ls);
+ *ret_tail = Scm_NewCons(obj, SCM_NIL);
+ ret_tail = &SCM_CDR(*ret_tail);
+ }
+ if (!SCM_NULLP(ls))
+ SigScm_ErrorObj("append: proper list required but got: ",
+ SCM_CAR(args));
}
/* append the last argument */
@@ -1075,7 +1028,7 @@
ret_list = Scm_NewCons(SCM_CAR(list), ret_list);
if (!SCM_NULLP(list))
- SigScm_ErrorObj("reverse: got improper list: ", list);
+ SigScm_ErrorObj("reverse: got improper list: ", list);
return ret_list;
}
@@ -1083,9 +1036,9 @@
static ScmObj ScmOp_listtail_internal(ScmObj list, int k)
{
while (k--) {
- if (!SCM_CONSP(list))
- return SCM_INVALID;
- list = SCM_CDR(list);
+ if (!SCM_CONSP(list))
+ return SCM_INVALID;
+ list = SCM_CDR(list);
}
return list;
@@ -1101,8 +1054,8 @@
ret = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
if (EQ(ret, SCM_INVALID))
- SigScm_ErrorObj("list-tail: out of range or bad list, arglist is: ",
- Scm_NewCons(list, scm_k));
+ SigScm_ErrorObj("list-tail: out of range or bad list, arglist is: ",
+ Scm_NewCons(list, scm_k));
return ret;
}
@@ -1116,7 +1069,7 @@
list_tail = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
if (EQ(list_tail, SCM_INVALID))
SigScm_ErrorObj("list-ref : out of range or bad list, arglist is: ",
- Scm_NewCons(list, scm_k));
+ Scm_NewCons(list, scm_k));
return SCM_CAR(list_tail);
}
@@ -1169,12 +1122,12 @@
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- car = SCM_CAR(tmpobj);
+ car = SCM_CAR(tmpobj);
#if SCM_STRICT_R5RS
- if (!SCM_CONSP(tmpobj))
- SigScm_ErrorObj("assq: invalid alist: ", alist);
- if (EQ(SCM_CAR(tmpobj), obj))
- return tmpobj;
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assq: invalid alist: ", alist);
+ if (EQ(SCM_CAR(tmpobj), obj))
+ return tmpobj;
#else
if (SCM_CONSP(tmpobj) && EQ(SCM_CAR(tmpobj), obj))
return tmpobj;
@@ -1192,12 +1145,12 @@
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- car = SCM_CAR(tmpobj);
+ car = SCM_CAR(tmpobj);
#if SCM_STRICT_R5RS
- if (!SCM_CONSP(tmpobj))
- SigScm_ErrorObj("assv: invalid alist: ", alist);
- if (EQ(ScmOp_eqvp(car, obj), SCM_TRUE))
- return tmpobj;
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assv: invalid alist: ", alist);
+ if (EQ(ScmOp_eqvp(car, obj), SCM_TRUE))
+ return tmpobj;
#else
if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqvp(car, obj), SCM_TRUE))
return tmpobj;
@@ -1215,12 +1168,12 @@
for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
tmpobj = SCM_CAR(tmplist);
- car = SCM_CAR(tmpobj);
+ car = SCM_CAR(tmpobj);
#if SCM_STRICT_R5RS
- if (!SCM_CONSP(tmpobj))
- SigScm_ErrorObj("assoc: invalid alist: ", alist);
- if (EQ(ScmOp_equalp(car, obj), SCM_TRUE))
- return tmpobj;
+ if (!SCM_CONSP(tmpobj))
+ SigScm_ErrorObj("assoc: invalid alist: ", alist);
+ if (EQ(ScmOp_equalp(car, obj), SCM_TRUE))
+ return tmpobj;
#else
if (SCM_CONSP(tmpobj) && EQ(ScmOp_equalp(car, obj), SCM_TRUE))
return tmpobj;
@@ -1236,10 +1189,7 @@
==============================================================================*/
ScmObj ScmOp_symbolp(ScmObj obj)
{
- if (SCM_SYMBOLP(obj))
- return SCM_TRUE;
-
- return SCM_FALSE;
+ return (SCM_SYMBOLP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_symbol_to_string(ScmObj obj)
@@ -1263,10 +1213,7 @@
==============================================================================*/
ScmObj ScmOp_charp(ScmObj obj)
{
- if (SCM_CHARP(obj))
- return SCM_TRUE;
-
- return SCM_FALSE;
+ return (SCM_CHARP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_char_equal(ScmObj ch1, ScmObj ch2)
@@ -1365,11 +1312,11 @@
ScmObj ScmOp_char_upcase(ScmObj obj)
{
if (!SCM_CHARP(obj))
- SigScm_ErrorObj("char-upcase : char required but got ", obj);
+ SigScm_ErrorObj("char-upcase : char required but got ", obj);
/* check multibyte */
if (strlen(SCM_CHAR_CH(obj)) != 1)
- return obj;
+ return obj;
/* to upcase */
SCM_CHAR_CH(obj)[0] = toupper(SCM_CHAR_CH(obj)[0]);
@@ -1380,11 +1327,11 @@
ScmObj ScmOp_char_downcase(ScmObj obj)
{
if (!SCM_CHARP(obj))
- SigScm_ErrorObj("char-upcase : char required but got ", obj);
+ SigScm_ErrorObj("char-upcase : char required but got ", obj);
/* check multibyte */
if (strlen(SCM_CHAR_CH(obj)) != 1)
- return obj;
+ return obj;
/* to upcase */
SCM_CHAR_CH(obj)[0] = tolower(SCM_CHAR_CH(obj)[0]);
@@ -1397,10 +1344,7 @@
==============================================================================*/
ScmObj ScmOp_stringp(ScmObj obj)
{
- if (SCM_STRINGP(obj))
- return SCM_TRUE;
-
- return SCM_FALSE;
+ return (SCM_STRINGP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_make_string(ScmObj arg, ScmObj env)
@@ -1422,18 +1366,18 @@
/* get length */
len = SCM_INT_VALUE(SCM_CAR(arg));
if (len == 0)
- return Scm_NewStringCopying("");
+ return Scm_NewStringCopying("");
/* specify filler */
if (argc == 1) {
- /* specify length only, so fill string with space(' ') */
+ /* specify length only, so fill string with space(' ') */
tmp = (char*)malloc(sizeof(char) * (1 + 1));
- tmp[0] = ' ';
- tmp[1] = '\0';
- ch = Scm_NewChar(tmp);
+ tmp[0] = ' ';
+ tmp[1] = '\0';
+ ch = Scm_NewChar(tmp);
} else {
- /* also specify filler char */
- ch = SCM_CAR(SCM_CDR(arg));
+ /* also specify filler char */
+ ch = SCM_CAR(SCM_CDR(arg));
}
/* make string */
@@ -1562,7 +1506,7 @@
/* sanity check */
if (c_start_index == c_end_index)
- return Scm_NewStringCopying("");
+ return Scm_NewStringCopying("");
/* get str */
string_str = SCM_STRING_STR(str);
@@ -1588,7 +1532,7 @@
/* sanity check */
if (SCM_NULLP(arg))
- return Scm_NewStringCopying("");
+ return Scm_NewStringCopying("");
/* count total size of the new string */
for (strings = arg; !SCM_NULLP(strings); strings = SCM_CDR(strings)) {
@@ -1667,7 +1611,7 @@
SigScm_ErrorObj("list->string : list required but got ", list);
if (SCM_NULLP(list))
- return Scm_NewStringCopying("");
+ return Scm_NewStringCopying("");
/* count total size of the string */
for (chars = list; !SCM_NULLP(chars); chars = SCM_CDR(chars)) {
@@ -1735,10 +1679,7 @@
==============================================================================*/
ScmObj ScmOp_vectorp(ScmObj obj)
{
- if (SCM_VECTORP(obj))
- return SCM_TRUE;
-
- return SCM_FALSE;
+ return (SCM_VECTORP(obj)) ? SCM_TRUE : SCM_FALSE;
}
ScmObj ScmOp_make_vector(ScmObj arg, ScmObj env )
@@ -1988,15 +1929,15 @@
ScmObj cont = SCM_NIL;
if (!SCM_CLOSUREP(proc))
- SigScm_ErrorObj("call-with-current-continuation : closure required but got ", proc);
+ SigScm_ErrorObj("call-with-current-continuation : closure required but got ", proc);
cont = Scm_NewContinuation();
/* setjmp and check result */
jmpret = setjmp(SCM_CONTINUATION_JMPENV(cont));
if (jmpret) {
- /* return by calling longjmp */
- return continuation_thrown_obj;
+ /* return by calling longjmp */
+ return continuation_thrown_obj;
}
/* execute (proc cont) */
@@ -2010,7 +1951,7 @@
/* Values with one arg must return something that fits an ordinary
* continuation. */
if (SCM_CONSP(argl) && SCM_NULLP(SCM_CDR(argl)))
- return SCM_CAR(argl);
+ return SCM_CAR(argl);
/* Otherwise, we'll return the values in a packet. */
return Scm_NewValuePacket(argl);
@@ -2023,18 +1964,18 @@
/* This should go away when we reorganize function types. */
if (CHECK_2_ARGS(argl))
- SigScm_ErrorObj("call-with-values: too few arguments: ", argl);
+ SigScm_ErrorObj("call-with-values: too few arguments: ", argl);
/* make the list (producer) and evaluate it */
cons_wrapper = Scm_NewCons(SCM_CAR(argl), SCM_NIL);
vals = ScmOp_eval(cons_wrapper, *envp);
if (!SCM_VALUEPACKETP(vals)) {
- /* got back a single value */
- vals = Scm_NewCons(vals, SCM_NIL);
+ /* got back a single value */
+ vals = Scm_NewCons(vals, SCM_NIL);
} else {
- /* extract */
- vals = SCM_VALUEPACKET_VALUES(vals);
+ /* extract */
+ vals = SCM_VALUEPACKET_VALUES(vals);
}
*tail_flag = 1;
Modified: branches/r5rs/sigscheme/read.c
===================================================================
--- branches/r5rs/sigscheme/read.c 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/read.c 2005-08-22 05:56:08 UTC (rev 1273)
@@ -51,26 +51,26 @@
/*=======================================
File Local Macro Declarations
=======================================*/
-#define SCM_PORT_GETC(port, c) \
- do { \
- if (SCM_PORTINFO_UNGOTTENCHAR(port)) { \
- c = SCM_PORTINFO_UNGOTTENCHAR(port); \
- SCM_PORTINFO_UNGOTTENCHAR(port) = 0; \
- } else { \
- switch (SCM_PORTINFO_PORTTYPE(port)) { \
- case PORT_FILE: \
- c = getc(SCM_PORTINFO_FILE(port)); \
- break; \
- case PORT_STRING: \
- c = (*SCM_PORTINFO_STR_CURRENT(port)); \
- SCM_PORTINFO_STR_CURRENT(port)++; \
- break; \
- } \
- SCM_PORTINFO_UNGOTTENCHAR(port) = 0; \
- } \
+#define SCM_PORT_GETC(port, c) \
+ do { \
+ if (SCM_PORTINFO_UNGOTTENCHAR(port)) { \
+ c = SCM_PORTINFO_UNGOTTENCHAR(port); \
+ SCM_PORTINFO_UNGOTTENCHAR(port) = 0; \
+ } else { \
+ switch (SCM_PORTINFO_PORTTYPE(port)) { \
+ case PORT_FILE: \
+ c = getc(SCM_PORTINFO_FILE(port)); \
+ break; \
+ case PORT_STRING: \
+ c = (*SCM_PORTINFO_STR_CURRENT(port)); \
+ SCM_PORTINFO_STR_CURRENT(port)++; \
+ break; \
+ } \
+ SCM_PORTINFO_UNGOTTENCHAR(port) = 0; \
+ } \
} while (0);
-#define SCM_PORT_UNGETC(port,c ) \
+#define SCM_PORT_UNGETC(port,c ) \
SCM_PORTINFO_UNGOTTENCHAR(port) = c;
/*=======================================
@@ -119,26 +119,26 @@
{
int c = 0;
while (1) {
- SCM_PORT_GETC(port, c);
+ SCM_PORT_GETC(port, c);
if (c == EOF) {
return c;
} else if(c == ';') {
while (1) {
- SCM_PORT_GETC(port, c);
+ SCM_PORT_GETC(port, c);
if (c == '\n') {
- if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
- SCM_PORTINFO_LINE(port)++;
- }
- break;
- }
+ if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
+ SCM_PORTINFO_LINE(port)++;
+ }
+ break;
+ }
if (c == EOF ) return c;
}
continue;
} else if(c == '\n') {
- if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
- SCM_PORTINFO_LINE(port)++;
- }
- continue;
+ if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE) {
+ SCM_PORTINFO_LINE(port)++;
+ }
+ continue;
} else if(isspace(c)) {
continue;
}
@@ -164,63 +164,63 @@
#endif
switch (c) {
- case '(':
- return read_list(port, ')');
- case '\"':
- return read_string(port);
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- SCM_PORT_UNGETC(port, c);
- return read_number_or_symbol(port);
- case '+': case '-':
- SCM_PORT_UNGETC(port, c);
- return read_number_or_symbol(port);
- case '\'':
- return read_quote(port, SCM_QUOTE);
- case '`':
- return read_quote(port, SCM_QUASIQUOTE);
- case ',':
- {
- SCM_PORT_GETC(port, c1);
- if (c1 == EOF) {
- SigScm_Error("EOF in unquote\n");
- } else if (c1 == '@') {
- return read_quote(port, SCM_UNQUOTE_SPLICING);
- } else {
- SCM_PORT_UNGETC(port, c1);
- return read_quote(port, SCM_UNQUOTE);
- }
- }
- case '#':
- {
- SCM_PORT_GETC(port, c1);
- switch (c1) {
- case 't': case 'T':
- return SCM_TRUE;
- case 'f': case 'F':
- return SCM_FALSE;
- case '(':
- return ScmOp_list_to_vector(read_list(port, ')'));
- case '\\':
- return read_char(port);
- case EOF:
- SigScm_Error("end in #\n");
- default:
- SigScm_Error("Unsupported # : %c\n", c1);
- }
+ case '(':
+ return read_list(port, ')');
+ case '\"':
+ return read_string(port);
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ SCM_PORT_UNGETC(port, c);
+ return read_number_or_symbol(port);
+ case '+': case '-':
+ SCM_PORT_UNGETC(port, c);
+ return read_number_or_symbol(port);
+ case '\'':
+ return read_quote(port, SCM_QUOTE);
+ case '`':
+ return read_quote(port, SCM_QUASIQUOTE);
+ case ',':
+ {
+ SCM_PORT_GETC(port, c1);
+ if (c1 == EOF) {
+ SigScm_Error("EOF in unquote\n");
+ } else if (c1 == '@') {
+ return read_quote(port, SCM_UNQUOTE_SPLICING);
+ } else {
+ SCM_PORT_UNGETC(port, c1);
+ return read_quote(port, SCM_UNQUOTE);
}
- break;
+ }
+ case '#':
+ {
+ SCM_PORT_GETC(port, c1);
+ switch (c1) {
+ case 't': case 'T':
+ return SCM_TRUE;
+ case 'f': case 'F':
+ return SCM_FALSE;
+ case '(':
+ return ScmOp_list_to_vector(read_list(port, ')'));
+ case '\\':
+ return read_char(port);
+ case EOF:
+ SigScm_Error("end in #\n");
+ default:
+ SigScm_Error("Unsupported # : %c\n", c1);
+ }
+ }
+ break;
- /* Error sequence */
- case ')':
- SigScm_Error("invalid close parenthesis\n");
- break;
- case EOF:
- return SCM_EOF;
+ /* Error sequence */
+ case ')':
+ SigScm_Error("invalid close parenthesis\n");
+ break;
+ case EOF:
+ return SCM_EOF;
- default:
- SCM_PORT_UNGETC(port, c);
- return read_symbol(port);
+ default:
+ SCM_PORT_UNGETC(port, c);
+ return read_symbol(port);
}
}
}
@@ -249,45 +249,45 @@
#endif
if (c == EOF) {
- if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE)
- SigScm_Error("EOF inside list. (starting from line %d)\n", line + 1);
- else
- SigScm_Error("EOF inside list.\n");
+ if (SCM_PORTINFO_PORTTYPE(port) == PORT_FILE)
+ SigScm_Error("EOF inside list. (starting from line %d)\n", line + 1);
+ else
+ SigScm_Error("EOF inside list.\n");
} else if (c == closeParen) {
return list_head;
} else if (c == '.') {
- c2 = 0;
- SCM_PORT_GETC(port, c2);
+ 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) || c2 == '(' || c2 == '"' || c2 == ';') {
cdr = read_sexpression(port);
if (SCM_NULLP(list_tail))
SigScm_Error(".(dot) at the start of the list.\n");
- c = skip_comment_and_space(port);
- if (c != ')')
- SigScm_Error("bad dot syntax\n");
+ c = skip_comment_and_space(port);
+ if (c != ')')
+ SigScm_Error("bad dot syntax\n");
SCM_SETCDR(list_tail, cdr);
- return list_head;
+ 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_word(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);
+ /*
+ * 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_word(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);
@@ -316,14 +316,14 @@
/* check special sequence "space" and "newline" */
if (strcmp(ch, "space") == 0) {
- ch[0] = ' ';
- ch[1] = '\0';
+ ch[0] = ' ';
+ ch[1] = '\0';
} else if (strcmp(ch, "Space") == 0) {
- ch[0] = ' ';
- ch[1] = '\0';
+ ch[0] = ' ';
+ ch[1] = '\0';
} else if (strcmp(ch, "newline") == 0) {
- ch[0] = '\n';
- ch[1] = '\0';
+ ch[0] = '\n';
+ ch[1] = '\0';
}
return Scm_NewChar(ch);
@@ -340,51 +340,51 @@
#endif
while (1) {
- SCM_PORT_GETC(port, c);
+ SCM_PORT_GETC(port, c);
#if DEBUG_PARSER
printf("read_string c = %c\n", c);
#endif
switch (c) {
- case EOF:
- SigScm_Error("EOF in the string\n");
- break;
- case '\"':
- {
- stringbuf[stringlen] = '\0';
- return Scm_NewStringCopying(stringbuf);
+ case EOF:
+ SigScm_Error("EOF in the string\n");
+ break;
+ case '\"':
+ {
+ stringbuf[stringlen] = '\0';
+ return Scm_NewStringCopying(stringbuf);
+ }
+ case '\\':
+ {
+ /*
+ * (R5RS) 6.3.5 String
+ * A double quote can be written inside a string only by
+ * escaping it with a backslash (\).
+ */
+ SCM_PORT_GETC(port, c);
+ switch (c) {
+ case '\"': stringbuf[stringlen] = c; break;
+ case 'n': stringbuf[stringlen] = '\n'; break;
+ case 'r': stringbuf[stringlen] = '\r'; break;
+ case 'f': stringbuf[stringlen] = '\f'; break;
+ case 't': stringbuf[stringlen] = '\t'; break;
+ default:
+ stringbuf[stringlen] = '\\';
+ stringbuf[++stringlen] = c;
+ break;
}
- case '\\':
- {
- /*
- * (R5RS) 6.3.5 String
- * A double quote can be written inside a string only by
- * escaping it with a backslash (\).
- */
- SCM_PORT_GETC(port, c);
- switch (c) {
- case '\"': stringbuf[stringlen] = c; break;
- case 'n': stringbuf[stringlen] = '\n'; break;
- case 'r': stringbuf[stringlen] = '\r'; break;
- case 'f': stringbuf[stringlen] = '\f'; break;
- case 't': stringbuf[stringlen] = '\t'; break;
- default:
- stringbuf[stringlen] = '\\';
- stringbuf[++stringlen] = c;
- break;
- }
- stringlen++;
+ stringlen++;
#if DEBUG_PARSER
- printf("read_string following \\ : c = %c\n", c);
+ printf("read_string following \\ : c = %c\n", c);
#endif
- }
- break;
- default:
- stringbuf[stringlen] = c;
- stringlen++;
- break;
+ }
+ break;
+ default:
+ stringbuf[stringlen] = c;
+ stringlen++;
+ break;
}
}
}
@@ -419,39 +419,39 @@
str_len = strlen(str);
if (strlen(str) == 1
- && (strcmp(str, "+") == 0 || strcmp(str, "-") == 0))
+ && (strcmp(str, "+") == 0 || strcmp(str, "-") == 0))
{
#if DEBUG_PARSER
- printf("determined as symbol : %s\n", str);
+ printf("determined as symbol : %s\n", str);
#endif
- obj = Scm_Intern(str);
- free(str);
- return obj;
+ obj = Scm_Intern(str);
+ free(str);
+ return obj;
}
/* check whether each char is the digit */
for (i = 0; i < str_len; i++) {
- if (i == 0 && (str[i] == '+' || str[i] == '-'))
- continue;
+ if (i == 0 && (str[i] == '+' || str[i] == '-'))
+ continue;
- if (!isdigit(str[i])) {
- is_str = 1;
- break;
- }
+ if (!isdigit(str[i])) {
+ is_str = 1;
+ break;
+ }
}
/* if symbol, then intern it. if number, return new int obj */
if (is_str) {
#if DEBUG_PARSER
- printf("determined as symbol : %s\n", str);
+ printf("determined as symbol : %s\n", str);
#endif
- obj = Scm_Intern(str);
+ obj = Scm_Intern(str);
} else {
#if DEBUG_PARSER
- printf("determined as num : %s\n", str);
+ printf("determined as num : %s\n", str);
#endif
- obj = Scm_NewInt((int)atof(str));
+ obj = Scm_NewInt((int)atof(str));
}
free(str);
@@ -467,31 +467,29 @@
char *dst = NULL;
while (1) {
- SCM_PORT_GETC(port, c);
+ SCM_PORT_GETC(port, c);
#if DEBUG_PARSER
- printf("c = %c\n", c);
+ printf("c = %c\n", c);
#endif
switch (c) {
-
- case EOF: /*
- * don't became an error for handling c-eval.
- * Scm_eval_c_string("some-symbol");
- */
- case ' ':
- case '(': case ')': case ';':
- case '\n': case '\t': case '\"': case '\'':
- SCM_PORT_UNGETC(port, c);
- stringbuf[stringlen] = '\0';
- dst = (char *)malloc(strlen(stringbuf) + 1);
- strcpy(dst, stringbuf);
- return dst;
-
- default:
- stringbuf[stringlen] = (char)c;
- stringlen++;
- break;
+ case EOF: /*
+ * don't became an error for handling c-eval.
+ * Scm_eval_c_string("some-symbol");
+ */
+ case ' ':
+ case '(': case ')': case ';':
+ case '\n': case '\t': case '\"': case '\'':
+ SCM_PORT_UNGETC(port, c);
+ stringbuf[stringlen] = '\0';
+ dst = (char *)malloc(strlen(stringbuf) + 1);
+ strcpy(dst, stringbuf);
+ return dst;
+ default:
+ stringbuf[stringlen] = (char)c;
+ stringlen++;
+ break;
}
}
}
@@ -504,36 +502,36 @@
char *dst = NULL;
while (1) {
- SCM_PORT_GETC(port, c);
+ SCM_PORT_GETC(port, c);
#if DEBUG_PARSER
- printf("c = %c\n", c);
+ printf("c = %c\n", c);
#endif
switch (c) {
- case EOF:
- SigScm_Error("EOF in the char sequence.\n");
- break;
+ case EOF:
+ SigScm_Error("EOF in the char sequence.\n");
+ break;
- /* pass through first char */
- case ' ': case '\"': case '\'':
- case '(': case ')': case ';':
- if (stringlen == 0) {
- stringbuf[stringlen] = (char)c;
- stringlen++;
- break;
- }
- case '\n': case '\t':
- SCM_PORT_UNGETC(port, c);
- stringbuf[stringlen] = '\0';
- dst = (char *)malloc(strlen(stringbuf) + 1);
- strcpy(dst, stringbuf);
- return dst;
-
- default:
+ case ' ': case '\"': case '\'':
+ case '(': case ')': case ';':
+ /* pass through first char */
+ if (stringlen == 0) {
stringbuf[stringlen] = (char)c;
stringlen++;
break;
+ }
+ case '\n': case '\t':
+ SCM_PORT_UNGETC(port, c);
+ stringbuf[stringlen] = '\0';
+ dst = (char *)malloc(strlen(stringbuf) + 1);
+ strcpy(dst, stringbuf);
+ return dst;
+
+ default:
+ stringbuf[stringlen] = (char)c;
+ stringlen++;
+ break;
}
}
}
@@ -542,4 +540,3 @@
{
return Scm_NewCons(quoter, Scm_NewCons(read_sexpression(port), SCM_NIL));
}
-
Modified: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/sigschemetype.h 2005-08-22 05:56:08 UTC (rev 1273)
@@ -59,12 +59,12 @@
ScmVector = 7,
ScmPort = 8,
ScmContinuation = 9,
- ScmFreeCell = 10,
- ScmEtc = 11,
+ ScmEtc = 10,
+ ScmValuePacket = 11,
+ ScmFreeCell = 12,
ScmCPointer = 20,
- ScmCFuncPointer = 21,
- ScmValuePacket = 22
+ ScmCFuncPointer = 21
};
/* Function Type by argnuments */
@@ -204,9 +204,9 @@
ScmContInfo *cont_info;
} continuation;
- struct ScmValuePacket {
- ScmObj values;
- } value_pack;
+ struct ScmValuePacket {
+ ScmObj values;
+ } value_pack;
struct ScmEtc {
int type;
Modified: branches/r5rs/sigscheme/test/test-vector.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-vector.scm 2005-08-21 22:12:25 UTC (rev 1272)
+++ branches/r5rs/sigscheme/test/test-vector.scm 2005-08-22 05:56:08 UTC (rev 1273)
@@ -4,8 +4,8 @@
(assert "vector test" (equal? '#(a b c d) vec))
(assert "vector? test" (vector? vec))
-(assert-eq? "vector-length test" 4 (vector-length vec))
-(assert-eq? "vector-ref test" 'd (vector-ref vec 3))
+(assert-equal? "vector-length test" 4 (vector-length vec))
+(assert-equal? "vector-ref test" 'd (vector-ref vec 3))
(assert "vector-set! test" (equal? '#(1 a "aiue" #t) (begin
(define tmpvec (vector 1 'a "aiue" #f))
(vector-set! tmpvec 3 #t)
More information about the uim-commit
mailing list