[uim-commit] r3021 - in branches/r5rs/sigscheme: . src
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Jan 29 12:37:45 PST 2006
Author: yamaken
Date: 2006-01-29 12:37:42 -0800 (Sun, 29 Jan 2006)
New Revision: 3021
Added:
branches/r5rs/sigscheme/src/list.c
Modified:
branches/r5rs/sigscheme/TODO
branches/r5rs/sigscheme/src/Makefile.am
branches/r5rs/sigscheme/src/operations.c
branches/r5rs/sigscheme/src/sigscheme.h
branches/r5rs/sigscheme/src/sigschemeinternal.h
Log:
* sigscheme/src/sigschemeinternal.h
- (EQVP, EQUALP): Moved from operations.c
* sigscheme/src/list.c
- New file copied from operations.c
- (scm_p_symbolp, scm_p_symbol2string, scm_p_string2symbol,
scm_p_procedurep, scm_p_map, scm_p_for_each, scm_p_force,
scm_p_call_with_current_continuation, scm_p_values,
scm_p_call_with_values, scm_p_dynamic_wind): Moved from operations.c
* sigscheme/src/operations.c
- (EQVP, EQUALP): Move to list.c
- (scm_p_symbolp, scm_p_symbol2string, scm_p_string2symbol,
scm_p_procedurep, scm_p_map, scm_p_for_each, scm_p_force,
scm_p_call_with_current_continuation, scm_p_values,
scm_p_call_with_values, scm_p_dynamic_wind): Move to list.c
* sigscheme/src/sigscheme.h
- Move prototype section
* sigscheme/src/Makefile.am
- (R5RS_PROC_SRCS, libsscm_la_SOURCES): Add list.c
* sigscheme/TODO
- Update
Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/TODO 2006-01-29 20:37:42 UTC (rev 3021)
@@ -38,7 +38,7 @@
* [uim] link libsscm into libuim statically
* Clear license, copyright and changes information
- - scm_length() in operations.c
+ - scm_length() in list.c
- "Shiro Kawai" part of read.c
- slib.scm
- test/{gauche*,bigloo*}.scm
Modified: branches/r5rs/sigscheme/src/Makefile.am
===================================================================
--- branches/r5rs/sigscheme/src/Makefile.am 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/src/Makefile.am 2006-01-29 20:37:42 UTC (rev 3021)
@@ -23,7 +23,7 @@
./script/functable-header.txt \
./script/functable-footer.txt
-R5RS_PROC_SRCS = sigscheme.c operations.c eval.c number.c string.c \
+R5RS_PROC_SRCS = sigscheme.c operations.c eval.c list.c number.c string.c \
vector.c io.c
sigschemefunctable.c: $(FUNC_TABLES)
@@ -66,7 +66,7 @@
storage-symbol.c \
storage-continuation.c \
encoding.c error.c \
- env.c eval.c syntax.c number.c string.c vector.c io.c \
+ env.c eval.c syntax.c list.c number.c string.c vector.c io.c \
basecport.c fileport.c \
operations.c \
read.c sigscheme.c sigschemefunctable.c \
Copied: branches/r5rs/sigscheme/src/list.c (from rev 3020, branches/r5rs/sigscheme/src/operations.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations.c 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/src/list.c 2006-01-29 20:37:42 UTC (rev 3021)
@@ -0,0 +1,460 @@
+/*===========================================================================
+ * FileName : list.c
+ * About : R5SR pairs and lists
+ *
+ * Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of authors nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+ * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+ * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+ * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+ * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+===========================================================================*/
+
+#include "config.h"
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+static ScmObj list_tail(ScmObj lst, scm_int_t k);
+
+/*=======================================
+ Function Implementations
+=======================================*/
+/*===========================================================================
+ R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
+===========================================================================*/
+ScmObj
+scm_p_car(ScmObj obj)
+{
+ DECLARE_FUNCTION("car", procedure_fixed_1);
+#if SCM_COMPAT_SIOD_BUGS
+ if (NULLP(obj))
+ return SCM_NULL;
+#endif
+
+ ENSURE_CONS(obj);
+
+ return CAR(obj);
+}
+
+ScmObj
+scm_p_cdr(ScmObj obj)
+{
+ DECLARE_FUNCTION("cdr", procedure_fixed_1);
+#if SCM_COMPAT_SIOD_BUGS
+ if (NULLP(obj))
+ return SCM_NULL;
+#endif
+
+ ENSURE_CONS(obj);
+
+ return CDR(obj);
+}
+
+ScmObj
+scm_p_pairp(ScmObj obj)
+{
+ DECLARE_FUNCTION("pair?", procedure_fixed_1);
+
+ return MAKE_BOOL(CONSP(obj));
+}
+
+ScmObj
+scm_p_cons(ScmObj car, ScmObj cdr)
+{
+ DECLARE_FUNCTION("cons", procedure_fixed_2);
+
+ return CONS(car, cdr);
+}
+
+ScmObj
+scm_p_set_card(ScmObj pair, ScmObj car)
+{
+ DECLARE_FUNCTION("set-car!", procedure_fixed_2);
+
+ ENSURE_CONS(pair);
+ ENSURE_MUTABLE_CONS(pair);
+
+ SET_CAR(pair, car);
+
+#if SCM_COMPAT_SIOD
+ return car;
+#else
+ return SCM_UNDEF;
+#endif
+}
+
+ScmObj
+scm_p_set_cdrd(ScmObj pair, ScmObj cdr)
+{
+ DECLARE_FUNCTION("set-cdr!", procedure_fixed_2);
+
+ ENSURE_CONS(pair);
+ ENSURE_MUTABLE_CONS(pair);
+
+ SET_CDR(pair, cdr);
+
+#if SCM_COMPAT_SIOD
+ return cdr;
+#else
+ return SCM_UNDEF;
+#endif
+}
+
+ScmObj
+scm_p_caar(ScmObj lst)
+{
+ DECLARE_FUNCTION("caar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car(lst) );
+}
+
+ScmObj
+scm_p_cadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cadr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr(lst) );
+}
+
+ScmObj
+scm_p_cdar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car(lst) );
+}
+
+ScmObj
+scm_p_cddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cddr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr(lst) );
+}
+
+ScmObj
+scm_p_caddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("caddr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_cdr(lst) ));
+}
+
+ScmObj
+scm_p_cdddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdddr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) ));
+}
+
+ScmObj
+scm_p_list(ScmObj args)
+{
+ DECLARE_FUNCTION("list", procedure_variadic_0);
+
+ return args;
+}
+
+ScmObj
+scm_p_nullp(ScmObj obj)
+{
+ DECLARE_FUNCTION("null?", procedure_fixed_1);
+
+ return MAKE_BOOL(NULLP(obj));
+}
+
+ScmObj
+scm_p_listp(ScmObj obj)
+{
+ DECLARE_FUNCTION("list?", procedure_fixed_1);
+
+ /* fast path */
+ if (NULLP(obj))
+ return SCM_TRUE;
+ if (!CONSP(obj))
+ return SCM_FALSE;
+
+ return MAKE_BOOL(PROPER_LISTP(obj));
+}
+
+#define TERMINATOR_LEN 1
+
+/* scm_length() for non-circular list */
+scm_int_t
+scm_finite_length(ScmObj lst)
+{
+ scm_int_t len;
+
+ for (len = 0; CONSP(lst); lst = CDR(lst))
+ len++;
+
+ if (NULLP(lst))
+ return len;
+ else
+ return SCM_LISTLEN_ENCODE_DOTTED(len + TERMINATOR_LEN);
+}
+
+/*
+ * Notice
+ *
+ * This function is ported from Gauche, by Shiro Kawai(shiro at acm.org)
+ */
+/* FIXME: Insert its copyright and license into this file properly */
+/*
+ * ChangeLog:
+ *
+ * 2006-01-05 YamaKen Return dot list length and circular indication.
+ *
+ */
+/* Returns -1 as one length improper list for non-list obj. */
+scm_int_t
+scm_length(ScmObj lst)
+{
+ ScmObj slow;
+ scm_int_t proper_len;
+
+ for (proper_len = 0, slow = lst;;) {
+ if (NULLP(lst)) break;
+ if (!CONSP(lst))
+ return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
+ if (proper_len != 0 && lst == slow)
+ return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
+
+ lst = CDR(lst);
+ proper_len++;
+ if (NULLP(lst)) break;
+ if (!CONSP(lst))
+ return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
+ if (lst == slow)
+ return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
+
+ lst = CDR(lst);
+ slow = CDR(slow);
+ proper_len++;
+ }
+
+ return proper_len;
+}
+
+#undef TERMINATOR_LEN
+
+ScmObj
+scm_p_length(ScmObj obj)
+{
+ scm_int_t len;
+ DECLARE_FUNCTION("length", procedure_fixed_1);
+
+ len = scm_length(obj);
+ if (!SCM_LISTLEN_PROPERP(len))
+ ERR_OBJ("proper list required but got", obj);
+
+ return MAKE_INT(len);
+}
+
+ScmObj
+scm_p_append(ScmObj args)
+{
+ ScmQueue q;
+ ScmObj lst, elm, res;
+ DECLARE_FUNCTION("append", procedure_variadic_0);
+
+ if (NULLP(args))
+ return SCM_NULL;
+
+ res = SCM_NULL;
+ SCM_QUEUE_POINT_TO(q, res);
+ /* duplicate and merge all but the last argument */
+ FOR_EACH_BUTLAST (lst, args) {
+ FOR_EACH (elm, lst)
+ SCM_QUEUE_ADD(q, elm);
+ ENSURE_PROPER_LIST_TERMINATION(lst, args);
+ }
+ /* append the last argument */
+ SCM_QUEUE_SLOPPY_APPEND(q, lst);
+
+ return res;
+}
+
+ScmObj
+scm_p_reverse(ScmObj lst)
+{
+ ScmObj ret, elm;
+ DECLARE_FUNCTION("reverse", procedure_fixed_1);
+
+ ret = SCM_NULL;
+ FOR_EACH (elm, lst)
+ ret = CONS(elm, ret);
+
+ return ret;
+}
+
+static ScmObj
+list_tail(ScmObj lst, scm_int_t k)
+{
+ while (k--) {
+ if (!CONSP(lst))
+ return SCM_INVALID;
+ lst = CDR(lst);
+ }
+
+ return lst;
+}
+
+ScmObj
+scm_p_list_tail(ScmObj lst, ScmObj k)
+{
+ ScmObj ret;
+ DECLARE_FUNCTION("list-tail", procedure_fixed_2);
+
+ ENSURE_INT(k);
+
+ ret = list_tail(lst, SCM_INT_VALUE(k));
+ if (!VALIDP(ret))
+ ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
+
+ return ret;
+}
+
+ScmObj
+scm_p_list_ref(ScmObj lst, ScmObj k)
+{
+ ScmObj tail;
+ DECLARE_FUNCTION("list-ref", procedure_fixed_2);
+
+ ENSURE_INT(k);
+
+ tail = list_tail(lst, SCM_INT_VALUE(k));
+ if (!VALIDP(tail) || NULLP(tail))
+ ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
+
+ return CAR(tail);
+}
+
+#define MEMBER_BODY(obj, lst, cmp) \
+ do { \
+ for (; CONSP(lst); lst = CDR(lst)) \
+ if (cmp(obj, CAR(lst))) \
+ return lst; \
+ CHECK_PROPER_LIST_TERMINATION(lst, lst); \
+ return SCM_FALSE; \
+ } while (/* CONSTCOND */ 0)
+
+ScmObj
+scm_p_memq(ScmObj obj, ScmObj lst)
+{
+ DECLARE_FUNCTION("memq", procedure_fixed_2);
+
+ MEMBER_BODY(obj, lst, EQ);
+}
+
+ScmObj
+scm_p_memv(ScmObj obj, ScmObj lst)
+{
+ DECLARE_FUNCTION("memv", procedure_fixed_2);
+
+#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
+ MEMBER_BODY(obj, lst, EQ);
+#else
+ MEMBER_BODY(obj, lst, EQVP);
+#endif
+}
+
+ScmObj
+scm_p_member(ScmObj obj, ScmObj lst)
+{
+ DECLARE_FUNCTION("member", procedure_fixed_2);
+
+ MEMBER_BODY(obj, lst, EQUALP);
+}
+
+#undef MEMBER_BODY
+
+#define ASSOC_BODY(obj, alist, cmp) \
+ do { \
+ ScmObj pair, key; \
+ \
+ FOR_EACH (pair, alist) { \
+ ENSURE_CONS(pair); \
+ key = CAR(pair); \
+ if (cmp(key, obj)) \
+ return pair; \
+ } \
+ CHECK_PROPER_LIST_TERMINATION(alist, alist); \
+ return SCM_FALSE; \
+ } while (/* CONSTCOND */ 0)
+
+ScmObj
+scm_p_assq(ScmObj obj, ScmObj alist)
+{
+ DECLARE_FUNCTION("assq", procedure_fixed_2);
+
+ ASSOC_BODY(obj, alist, EQ);
+}
+
+ScmObj
+scm_p_assv(ScmObj obj, ScmObj alist)
+{
+ DECLARE_FUNCTION("assv", procedure_fixed_2);
+
+#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
+ ASSOC_BODY(obj, alist, EQ);
+#else
+ ASSOC_BODY(obj, alist, EQVP);
+#endif
+}
+
+ScmObj
+scm_p_assoc(ScmObj obj, ScmObj alist)
+{
+ DECLARE_FUNCTION("assoc", procedure_fixed_2);
+
+ ASSOC_BODY(obj, alist, EQUALP);
+}
+
+#undef ASSOC_BODY
Modified: branches/r5rs/sigscheme/src/operations.c
===================================================================
--- branches/r5rs/sigscheme/src/operations.c 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/src/operations.c 2006-01-29 20:37:42 UTC (rev 3021)
@@ -40,7 +40,6 @@
/*=======================================
System Include
=======================================*/
-#include <stdlib.h>
/*=======================================
Local Include
@@ -55,8 +54,6 @@
/*=======================================
File Local Macro Declarations
=======================================*/
-#define EQVP(a, b) (NFALSEP(scm_p_eqvp((a), (b))))
-#define EQUALP(a, b) (NFALSEP(scm_p_equalp((a), (b))))
/*=======================================
Variable Declarations
@@ -65,7 +62,6 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj list_tail(ScmObj lst, scm_int_t k);
static ScmObj map_single_arg(ScmObj proc, ScmObj args);
static ScmObj map_multiple_args(ScmObj proc, ScmObj args);
@@ -223,401 +219,6 @@
}
/*===========================================================================
- R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
-===========================================================================*/
-ScmObj
-scm_p_car(ScmObj obj)
-{
- DECLARE_FUNCTION("car", procedure_fixed_1);
-#if SCM_COMPAT_SIOD_BUGS
- if (NULLP(obj))
- return SCM_NULL;
-#endif
-
- ENSURE_CONS(obj);
-
- return CAR(obj);
-}
-
-ScmObj
-scm_p_cdr(ScmObj obj)
-{
- DECLARE_FUNCTION("cdr", procedure_fixed_1);
-#if SCM_COMPAT_SIOD_BUGS
- if (NULLP(obj))
- return SCM_NULL;
-#endif
-
- ENSURE_CONS(obj);
-
- return CDR(obj);
-}
-
-ScmObj
-scm_p_pairp(ScmObj obj)
-{
- DECLARE_FUNCTION("pair?", procedure_fixed_1);
-
- return MAKE_BOOL(CONSP(obj));
-}
-
-ScmObj
-scm_p_cons(ScmObj car, ScmObj cdr)
-{
- DECLARE_FUNCTION("cons", procedure_fixed_2);
-
- return CONS(car, cdr);
-}
-
-ScmObj
-scm_p_set_card(ScmObj pair, ScmObj car)
-{
- DECLARE_FUNCTION("set-car!", procedure_fixed_2);
-
- ENSURE_CONS(pair);
- ENSURE_MUTABLE_CONS(pair);
-
- SET_CAR(pair, car);
-
-#if SCM_COMPAT_SIOD
- return car;
-#else
- return SCM_UNDEF;
-#endif
-}
-
-ScmObj
-scm_p_set_cdrd(ScmObj pair, ScmObj cdr)
-{
- DECLARE_FUNCTION("set-cdr!", procedure_fixed_2);
-
- ENSURE_CONS(pair);
- ENSURE_MUTABLE_CONS(pair);
-
- SET_CDR(pair, cdr);
-
-#if SCM_COMPAT_SIOD
- return cdr;
-#else
- return SCM_UNDEF;
-#endif
-}
-
-ScmObj
-scm_p_caar(ScmObj lst)
-{
- DECLARE_FUNCTION("caar", procedure_fixed_1);
-
- return scm_p_car( scm_p_car(lst) );
-}
-
-ScmObj
-scm_p_cadr(ScmObj lst)
-{
- DECLARE_FUNCTION("cadr", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr(lst) );
-}
-
-ScmObj
-scm_p_cdar(ScmObj lst)
-{
- DECLARE_FUNCTION("cdar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car(lst) );
-}
-
-ScmObj
-scm_p_cddr(ScmObj lst)
-{
- DECLARE_FUNCTION("cddr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr(lst) );
-}
-
-ScmObj
-scm_p_caddr(ScmObj lst)
-{
- DECLARE_FUNCTION("caddr", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_cdr(lst) ));
-}
-
-ScmObj
-scm_p_cdddr(ScmObj lst)
-{
- DECLARE_FUNCTION("cdddr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) ));
-}
-
-ScmObj
-scm_p_list(ScmObj args)
-{
- DECLARE_FUNCTION("list", procedure_variadic_0);
-
- return args;
-}
-
-ScmObj
-scm_p_nullp(ScmObj obj)
-{
- DECLARE_FUNCTION("null?", procedure_fixed_1);
-
- return MAKE_BOOL(NULLP(obj));
-}
-
-ScmObj
-scm_p_listp(ScmObj obj)
-{
- DECLARE_FUNCTION("list?", procedure_fixed_1);
-
- /* fast path */
- if (NULLP(obj))
- return SCM_TRUE;
- if (!CONSP(obj))
- return SCM_FALSE;
-
- return MAKE_BOOL(PROPER_LISTP(obj));
-}
-
-#define TERMINATOR_LEN 1
-
-/* scm_length() for non-circular list */
-scm_int_t
-scm_finite_length(ScmObj lst)
-{
- scm_int_t len;
-
- for (len = 0; CONSP(lst); lst = CDR(lst))
- len++;
-
- if (NULLP(lst))
- return len;
- else
- return SCM_LISTLEN_ENCODE_DOTTED(len + TERMINATOR_LEN);
-}
-
-/*
- * Notice
- *
- * This function is ported from Gauche, by Shiro Kawai(shiro at acm.org)
- */
-/* FIXME: Insert its copyright and license into this file properly */
-/*
- * ChangeLog:
- *
- * 2006-01-05 YamaKen Return dot list length and circular indication.
- *
- */
-/* Returns -1 as one length improper list for non-list obj. */
-scm_int_t
-scm_length(ScmObj lst)
-{
- ScmObj slow;
- scm_int_t proper_len;
-
- for (proper_len = 0, slow = lst;;) {
- if (NULLP(lst)) break;
- if (!CONSP(lst))
- return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
- if (proper_len != 0 && lst == slow)
- return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
-
- lst = CDR(lst);
- proper_len++;
- if (NULLP(lst)) break;
- if (!CONSP(lst))
- return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
- if (lst == slow)
- return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
-
- lst = CDR(lst);
- slow = CDR(slow);
- proper_len++;
- }
-
- return proper_len;
-}
-
-#undef TERMINATOR_LEN
-
-ScmObj
-scm_p_length(ScmObj obj)
-{
- scm_int_t len;
- DECLARE_FUNCTION("length", procedure_fixed_1);
-
- len = scm_length(obj);
- if (!SCM_LISTLEN_PROPERP(len))
- ERR_OBJ("proper list required but got", obj);
-
- return MAKE_INT(len);
-}
-
-ScmObj
-scm_p_append(ScmObj args)
-{
- ScmQueue q;
- ScmObj lst, elm, res;
- DECLARE_FUNCTION("append", procedure_variadic_0);
-
- if (NULLP(args))
- return SCM_NULL;
-
- res = SCM_NULL;
- SCM_QUEUE_POINT_TO(q, res);
- /* duplicate and merge all but the last argument */
- FOR_EACH_BUTLAST (lst, args) {
- FOR_EACH (elm, lst)
- SCM_QUEUE_ADD(q, elm);
- ENSURE_PROPER_LIST_TERMINATION(lst, args);
- }
- /* append the last argument */
- SCM_QUEUE_SLOPPY_APPEND(q, lst);
-
- return res;
-}
-
-ScmObj
-scm_p_reverse(ScmObj lst)
-{
- ScmObj ret, elm;
- DECLARE_FUNCTION("reverse", procedure_fixed_1);
-
- ret = SCM_NULL;
- FOR_EACH (elm, lst)
- ret = CONS(elm, ret);
-
- return ret;
-}
-
-static ScmObj
-list_tail(ScmObj lst, scm_int_t k)
-{
- while (k--) {
- if (!CONSP(lst))
- return SCM_INVALID;
- lst = CDR(lst);
- }
-
- return lst;
-}
-
-ScmObj
-scm_p_list_tail(ScmObj lst, ScmObj k)
-{
- ScmObj ret;
- DECLARE_FUNCTION("list-tail", procedure_fixed_2);
-
- ENSURE_INT(k);
-
- ret = list_tail(lst, SCM_INT_VALUE(k));
- if (!VALIDP(ret))
- ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
-
- return ret;
-}
-
-ScmObj
-scm_p_list_ref(ScmObj lst, ScmObj k)
-{
- ScmObj tail;
- DECLARE_FUNCTION("list-ref", procedure_fixed_2);
-
- ENSURE_INT(k);
-
- tail = list_tail(lst, SCM_INT_VALUE(k));
- if (!VALIDP(tail) || NULLP(tail))
- ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
-
- return CAR(tail);
-}
-
-#define MEMBER_BODY(obj, lst, cmp) \
- do { \
- for (; CONSP(lst); lst = CDR(lst)) \
- if (cmp(obj, CAR(lst))) \
- return lst; \
- CHECK_PROPER_LIST_TERMINATION(lst, lst); \
- return SCM_FALSE; \
- } while (/* CONSTCOND */ 0)
-
-ScmObj
-scm_p_memq(ScmObj obj, ScmObj lst)
-{
- DECLARE_FUNCTION("memq", procedure_fixed_2);
-
- MEMBER_BODY(obj, lst, EQ);
-}
-
-ScmObj
-scm_p_memv(ScmObj obj, ScmObj lst)
-{
- DECLARE_FUNCTION("memv", procedure_fixed_2);
-
-#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
- MEMBER_BODY(obj, lst, EQ);
-#else
- MEMBER_BODY(obj, lst, EQVP);
-#endif
-}
-
-ScmObj
-scm_p_member(ScmObj obj, ScmObj lst)
-{
- DECLARE_FUNCTION("member", procedure_fixed_2);
-
- MEMBER_BODY(obj, lst, EQUALP);
-}
-
-#undef MEMBER_BODY
-
-#define ASSOC_BODY(obj, alist, cmp) \
- do { \
- ScmObj pair, key; \
- \
- FOR_EACH (pair, alist) { \
- ENSURE_CONS(pair); \
- key = CAR(pair); \
- if (cmp(key, obj)) \
- return pair; \
- } \
- CHECK_PROPER_LIST_TERMINATION(alist, alist); \
- return SCM_FALSE; \
- } while (/* CONSTCOND */ 0)
-
-ScmObj
-scm_p_assq(ScmObj obj, ScmObj alist)
-{
- DECLARE_FUNCTION("assq", procedure_fixed_2);
-
- ASSOC_BODY(obj, alist, EQ);
-}
-
-ScmObj
-scm_p_assv(ScmObj obj, ScmObj alist)
-{
- DECLARE_FUNCTION("assv", procedure_fixed_2);
-
-#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
- ASSOC_BODY(obj, alist, EQ);
-#else
- ASSOC_BODY(obj, alist, EQVP);
-#endif
-}
-
-ScmObj
-scm_p_assoc(ScmObj obj, ScmObj alist)
-{
- DECLARE_FUNCTION("assoc", procedure_fixed_2);
-
- ASSOC_BODY(obj, alist, EQUALP);
-}
-
-#undef ASSOC_BODY
-
-/*===========================================================================
R5RS : 6.3 Other data types : 6.3.3 Symbols
===========================================================================*/
ScmObj
Modified: branches/r5rs/sigscheme/src/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/src/sigscheme.h 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/src/sigscheme.h 2006-01-29 20:37:42 UTC (rev 3021)
@@ -1163,6 +1163,21 @@
ScmObj scm_p_equalp(ScmObj obj1, ScmObj obj2);
ScmObj scm_p_not(ScmObj obj);
ScmObj scm_p_booleanp(ScmObj obj);
+ScmObj scm_p_symbolp(ScmObj obj);
+ScmObj scm_p_symbol2string(ScmObj sym);
+ScmObj scm_p_string2symbol(ScmObj str);
+ScmObj scm_p_procedurep(ScmObj obj);
+ScmObj scm_p_map(ScmObj proc, ScmObj args);
+ScmObj scm_p_for_each(ScmObj proc, ScmObj args);
+ScmObj scm_p_force(ScmObj closure);
+ScmObj scm_p_call_with_current_continuation(ScmObj proc,
+ ScmEvalState *eval_state);
+ScmObj scm_p_values(ScmObj args);
+ScmObj scm_p_call_with_values(ScmObj producer, ScmObj consumer,
+ ScmEvalState *eval_state);
+ScmObj scm_p_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after);
+
+/* list.c */
ScmObj scm_p_car(ScmObj obj);
ScmObj scm_p_cdr(ScmObj obj);
ScmObj scm_p_pairp(ScmObj obj);
@@ -1189,19 +1204,6 @@
ScmObj scm_p_assq(ScmObj obj, ScmObj alist);
ScmObj scm_p_assv(ScmObj obj, ScmObj alist);
ScmObj scm_p_assoc(ScmObj obj, ScmObj alist);
-ScmObj scm_p_symbolp(ScmObj obj);
-ScmObj scm_p_symbol2string(ScmObj sym);
-ScmObj scm_p_string2symbol(ScmObj str);
-ScmObj scm_p_procedurep(ScmObj obj);
-ScmObj scm_p_map(ScmObj proc, ScmObj args);
-ScmObj scm_p_for_each(ScmObj proc, ScmObj args);
-ScmObj scm_p_force(ScmObj closure);
-ScmObj scm_p_call_with_current_continuation(ScmObj proc,
- ScmEvalState *eval_state);
-ScmObj scm_p_values(ScmObj args);
-ScmObj scm_p_call_with_values(ScmObj producer, ScmObj consumer,
- ScmEvalState *eval_state);
-ScmObj scm_p_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after);
/* number.c */
ScmObj scm_p_add(ScmObj left, ScmObj right, enum ScmReductionState *state);
Modified: branches/r5rs/sigscheme/src/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-29 20:08:36 UTC (rev 3020)
+++ branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-29 20:37:42 UTC (rev 3021)
@@ -380,6 +380,8 @@
/* error handlings */
#define SCM_ERR_HEADER "Error: "
+#define EQVP(a, b) (NFALSEP(scm_p_eqvp((a), (b))))
+#define EQUALP(a, b) (NFALSEP(scm_p_equalp((a), (b))))
#define STRING_EQUALP(str1, str2) \
(EQ((str1), (str2)) \
|| (SCM_STRING_LEN(str1) == SCM_STRING_LEN(str2) /* rough rejection */ \
More information about the uim-commit
mailing list