[uim-commit] r3029 - branches/r5rs/sigscheme/src
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Jan 29 17:18:39 PST 2006
Author: yamaken
Date: 2006-01-29 17:18:35 -0800 (Sun, 29 Jan 2006)
New Revision: 3029
Added:
branches/r5rs/sigscheme/src/module-nonstd.c
branches/r5rs/sigscheme/src/module-r5rs-deepcadrs.c
branches/r5rs/sigscheme/src/module-siod.c
branches/r5rs/sigscheme/src/module-srfi1.c
branches/r5rs/sigscheme/src/module-srfi2.c
branches/r5rs/sigscheme/src/module-srfi23.c
branches/r5rs/sigscheme/src/module-srfi34.c
branches/r5rs/sigscheme/src/module-srfi38.c
branches/r5rs/sigscheme/src/module-srfi6.c
branches/r5rs/sigscheme/src/module-srfi60.c
branches/r5rs/sigscheme/src/module-srfi8.c
Removed:
branches/r5rs/sigscheme/src/operations-nonstd.c
branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c
branches/r5rs/sigscheme/src/operations-siod.c
branches/r5rs/sigscheme/src/operations-srfi1.c
branches/r5rs/sigscheme/src/operations-srfi2.c
branches/r5rs/sigscheme/src/operations-srfi23.c
branches/r5rs/sigscheme/src/operations-srfi34.c
branches/r5rs/sigscheme/src/operations-srfi38.c
branches/r5rs/sigscheme/src/operations-srfi6.c
branches/r5rs/sigscheme/src/operations-srfi60.c
branches/r5rs/sigscheme/src/operations-srfi8.c
Modified:
branches/r5rs/sigscheme/src/Makefile.am
branches/r5rs/sigscheme/src/procedure.c
branches/r5rs/sigscheme/src/sigscheme.h
Log:
* operations-nonstd.c
* operations-r5rs-deepcadrs.c
* operations-siod.c
* operations-srfi1.c
* operations-srfi2.c
* operations-srfi6.c
* operations-srfi8.c
* operations-srfi23.c
* operations-srfi34.c
* operations-srfi38.c
* operations-srfi60.c
- Rename to module-*.c
* module-nonstd.c
* module-r5rs-deepcadrs.c
* module-siod.c
* module-srfi1.c
* module-srfi2.c
* module-srfi6.c
* module-srfi8.c
* module-srfi23.c
* module-srfi34.c
* module-srfi38.c
* module-srfi60.c
- Renamed from operations-*.c
* sigscheme/src/Makefile.am
* sigscheme/src/procedure.c
* sigscheme/src/sigscheme.h
- Follow the renamings
Modified: branches/r5rs/sigscheme/src/Makefile.am
===================================================================
--- branches/r5rs/sigscheme/src/Makefile.am 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/Makefile.am 2006-01-30 01:18:35 UTC (rev 3029)
@@ -33,29 +33,29 @@
sigschemefunctable-r5rs-procedure.c: $(R5RS_PROC_SRCS) $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_r5rs_procedure_func_info_table" \
$(R5RS_PROC_SRCS) > $@
-sigschemefunctable-r5rs-deepcadrs.c: operations-r5rs-deepcadrs.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-r5rs-deepcadrs.c: module-r5rs-deepcadrs.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_r5rs_deepcadrs_func_info_table" $< > $@
sigschemefunctable-error.c: error.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_error_func_info_table" $< > $@
-sigschemefunctable-nonstd.c: operations-nonstd.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-nonstd.c: module-nonstd.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_nonstd_func_info_table" $< > $@
-sigschemefunctable-srfi1.c: operations-srfi1.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi1.c: module-srfi1.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi1_func_info_table" $< > $@
-sigschemefunctable-srfi2.c: operations-srfi2.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi2.c: module-srfi2.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi2_func_info_table" $< > $@
-sigschemefunctable-srfi6.c: operations-srfi6.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi6.c: module-srfi6.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi6_func_info_table" $< > $@
-sigschemefunctable-srfi8.c: operations-srfi8.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi8.c: module-srfi8.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi8_func_info_table" $< > $@
-sigschemefunctable-srfi23.c: operations-srfi23.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi23.c: module-srfi23.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi23_func_info_table" $< > $@
-sigschemefunctable-srfi34.c: operations-srfi34.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi34.c: module-srfi34.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi34_func_info_table" $< > $@
-sigschemefunctable-srfi38.c: operations-srfi38.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi38.c: module-srfi38.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi38_func_info_table" $< > $@
-sigschemefunctable-srfi60.c: operations-srfi60.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-srfi60.c: module-srfi60.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_srfi60_func_info_table" $< > $@
-sigschemefunctable-siod.c: operations-siod.c $(BUILD_FUNCTBL_SOURCES)
+sigschemefunctable-siod.c: module-siod.c $(BUILD_FUNCTBL_SOURCES)
$(BUILD_FUNCTBL) "scm_siod_func_info_table" $< > $@
EXTRA_DIST = $(FUNC_TABLES) $(BUILD_FUNCTBL_SOURCES) \
Copied: branches/r5rs/sigscheme/src/module-nonstd.c (from rev 3021, branches/r5rs/sigscheme/src/operations-nonstd.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-nonstd.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-nonstd.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,264 @@
+/*===========================================================================
+ * FileName : module-nonstd.c
+ * About : SigScheme-specific non standard operations
+ *
+ * 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.
+===========================================================================*/
+
+/*=======================================
+ System Include
+=======================================*/
+#include <stddef.h>
+#include <stdio.h>
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Macro Definitions
+=======================================*/
+
+/*=======================================
+ File Local Type Definitions
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+/* io.c */
+extern const char *scm_lib_path;
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+static void scm_require_internal(const char *filename);
+static ScmObj make_loaded_str(const char *filename);
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_nonstd_features(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_nonstd_func_info_table);
+
+ scm_define_alias("call/cc", "call-with-current-continuation");
+}
+
+/*
+ * TODO:
+ * - describe compatibility with de facto standard of other Scheme
+ * implementations (accept env as optional arg, etc)
+ *
+ * NOTE: Gauche 0.8.6 has deprecated symbol-bound? and is going to replace the
+ * procedure with global-variable-bound?.
+ */
+/* The implementation is fully compatible with SIOD */
+ScmObj
+scm_p_symbol_boundp(ScmObj sym, ScmObj rest)
+{
+ ScmObj env;
+ ScmRef ref;
+ DECLARE_FUNCTION("symbol-bound?", procedure_variadic_1);
+
+ ENSURE_SYMBOL(sym);
+
+ if (NULLP(rest)) {
+ env = SCM_INTERACTION_ENV;
+ } else {
+ env = POP(rest);
+ ASSERT_NO_MORE_ARG(rest);
+ ENSURE_VALID_ENV(env);
+ }
+ ref = scm_lookup_environment(sym, env);
+
+ return MAKE_BOOL(ref != SCM_INVALID_REF || SCM_SYMBOL_BOUNDP(sym));
+}
+
+/* SIOD compatible */
+ScmObj
+scm_p_load_path(void)
+{
+ DECLARE_FUNCTION("load-path", procedure_fixed_0);
+
+ return CONST_STRING(scm_lib_path);
+}
+
+void
+scm_require(const char *filename)
+{
+#if !SCM_GCC4_READY_GC
+ ScmObj stack_start;
+#endif
+
+#if SCM_GCC4_READY_GC
+ SCM_GC_PROTECTED_CALL_VOID(scm_require_internal, (filename));
+#else
+ scm_gc_protect_stack(&stack_start);
+
+ scm_require_internal(filename);
+
+ scm_gc_unprotect_stack(&stack_start);
+#endif
+}
+
+static void
+scm_require_internal(const char *filename)
+{
+ ScmObj loaded_str;
+
+ loaded_str = make_loaded_str(filename);
+ if (!scm_providedp(loaded_str)) {
+ scm_load(filename);
+ scm_provide(loaded_str);
+ }
+}
+
+ScmObj
+scm_p_require(ScmObj filename)
+{
+#if SCM_COMPAT_SIOD
+ ScmObj loaded_str, retsym;
+#endif
+ DECLARE_FUNCTION("require", procedure_fixed_1);
+
+ ENSURE_STRING(filename);
+
+ scm_require_internal(SCM_STRING_STR(filename));
+
+#if SCM_COMPAT_SIOD
+ loaded_str = make_loaded_str(SCM_STRING_STR(filename));
+ retsym = scm_intern(SCM_STRING_STR(loaded_str));
+ SCM_SYMBOL_SET_VCELL(retsym, SCM_TRUE);
+
+ return retsym;
+#else
+ return SCM_TRUE;
+#endif
+}
+
+static ScmObj
+make_loaded_str(const char *filename)
+{
+ char *loaded_str;
+ size_t size;
+
+ size = strlen(filename) + sizeof("*-loaded*");
+ loaded_str = scm_malloc(size);
+ snprintf(loaded_str, size, "*%s-loaded*", filename);
+
+ return MAKE_IMMUTABLE_STRING(loaded_str, STRLEN_UNKNOWN);
+}
+
+/*
+ * TODO: replace original specification with a SRFI standard or other de facto
+ * standard
+ */
+ScmObj
+scm_p_provide(ScmObj feature)
+{
+ DECLARE_FUNCTION("provide", procedure_fixed_1);
+
+ ENSURE_STRING(feature);
+
+ scm_provide(feature);
+
+ return SCM_TRUE;
+}
+
+/*
+ * TODO: replace original specification with a SRFI standard or other de facto
+ * standard
+ */
+ScmObj
+scm_p_providedp(ScmObj feature)
+{
+ DECLARE_FUNCTION("provided?", procedure_fixed_1);
+
+ ENSURE_STRING(feature);
+
+ return MAKE_BOOL(scm_providedp(feature));
+}
+
+/*
+ * TODO: describe compatibility with de facto standard of other Scheme
+ * implementations
+ */
+ScmObj
+scm_p_file_existsp(ScmObj filepath)
+{
+ FILE *f;
+ DECLARE_FUNCTION("file-exists?", procedure_fixed_1);
+
+ ENSURE_STRING(filepath);
+
+ f = fopen(SCM_STRING_STR(filepath), "r");
+ if (!f)
+ return SCM_FALSE;
+ fclose(f);
+
+ return SCM_TRUE;
+}
+
+/* TODO: remove to ensure security */
+ScmObj
+scm_p_delete_file(ScmObj filepath)
+{
+ DECLARE_FUNCTION("delete-file", procedure_fixed_1);
+
+ ENSURE_STRING(filepath);
+
+ if (remove(SCM_STRING_STR(filepath)) == -1)
+ ERR_OBJ("delete failed. file = ", filepath);
+
+ return SCM_TRUE;
+}
+
+/* to avoid being typo of length+, this procedure did not name as length++ */
+/* FIXME: replace with a SRFI or de facto standard equivalent if exist */
+ScmObj
+scm_p_lengthstar(ScmObj lst)
+{
+ scm_int_t len;
+ DECLARE_FUNCTION("length*", procedure_fixed_1);
+
+ len = scm_length(lst);
+ if (!SCM_LISTLEN_PROPERP(len)) { /* make fast path for proper list */
+ if (SCM_LISTLEN_DOTTEDP(len))
+ len = -SCM_LISTLEN_DOTTED(len);
+ else if (SCM_LISTLEN_CIRCULARP(len))
+ return SCM_FALSE;
+ }
+
+ return MAKE_INT(len);
+}
Copied: branches/r5rs/sigscheme/src/module-r5rs-deepcadrs.c (from rev 3021, branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-r5rs-deepcadrs.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,238 @@
+/*===========================================================================
+ * FileName : module-r5rs-deepcadrs.c
+ * About : Deep c[ad]+r operations of R5RS
+ *
+ * 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.
+===========================================================================*/
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Macro Definitions
+=======================================*/
+
+/*=======================================
+ File Local Type Definitions
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+ScmObj
+scm_p_caaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("caaar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_car(lst) ));
+}
+
+ScmObj
+scm_p_caadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("caadr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_cdr(lst) ));
+}
+
+ScmObj
+scm_p_cadar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cadar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_car(lst) ));
+}
+
+ScmObj
+scm_p_cdaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdaar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_car(lst) ));
+}
+
+ScmObj
+scm_p_cdadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdadr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_cdr(lst) ));
+}
+
+ScmObj
+scm_p_cddar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cddar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_car(lst) ));
+}
+
+ScmObj
+scm_p_caaaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("caaaar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_car( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_caaadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("caaadr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_car( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_caadar(ScmObj lst)
+{
+ DECLARE_FUNCTION("caadar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_cdr( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_caaddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("caaddr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_car( scm_p_cdr( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_cadaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cadaar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_car( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cadadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cadadr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_car( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_caddar(ScmObj lst)
+{
+ DECLARE_FUNCTION("caddar", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_cdr( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cadddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cadddr", procedure_fixed_1);
+
+ return scm_p_car( scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_cdaaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdaaar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_car( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cdaadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdaadr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_car( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_cdadar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdadar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_cdr( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cdaddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdaddr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_car( scm_p_cdr( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_cddaar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cddaar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_car( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cddadr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cddadr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_car( scm_p_cdr(lst) )));
+}
+
+ScmObj
+scm_p_cdddar(ScmObj lst)
+{
+ DECLARE_FUNCTION("cdddar", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_cdr( scm_p_car(lst) )));
+}
+
+ScmObj
+scm_p_cddddr(ScmObj lst)
+{
+ DECLARE_FUNCTION("cddddr", procedure_fixed_1);
+
+ return scm_p_cdr( scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) )));
+}
Copied: branches/r5rs/sigscheme/src/module-siod.c (from rev 3021, branches/r5rs/sigscheme/src/operations-siod.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-siod.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-siod.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,284 @@
+/*===========================================================================
+ * FileName : module-siod.c
+ * About : SIOD compatible procedures
+ *
+ * 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.
+===========================================================================*/
+/*=======================================
+ System Include
+=======================================*/
+#include <stddef.h>
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+#include "nullport.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+/*
+ * SIOD's verbose-level compatible debug message printing control:
+ * Search 'siod_verbose_level' in slib.c to know further detail.
+ *
+ * Don't change the verbose level 2 for SCM_DBG_BACKTRACE. This is used to
+ * suppress backtrace when run by the testing framework of uim.
+ * -- YamaKen 2005-11-05
+ *
+ * Extra control:
+ * v0: suppress all printing even if normal 'write' or 'display'
+ * v1: print each result of repl
+ * v2: print the "> " prompt
+ */
+#define SCM_DBG_SIOD_V0 SCM_DBG_NONE
+#define SCM_DBG_SIOD_V1 SCM_DBG_ERRMSG
+#define SCM_DBG_SIOD_V2 (SCM_DBG_SIOD_V1 | SCM_DBG_BACKTRACE)
+#define SCM_DBG_SIOD_V3 (SCM_DBG_SIOD_V2 | SCM_DBG_FILE)
+#define SCM_DBG_SIOD_V4 (SCM_DBG_SIOD_V3 | SCM_DBG_GC)
+#define SCM_DBG_SIOD_V5 (SCM_DBG_SIOD_V4 | SCM_DBG_READ)
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+static const int sscm_debug_mask_tbl[] = {
+ SCM_DBG_SIOD_V0,
+ SCM_DBG_SIOD_V1,
+ SCM_DBG_SIOD_V2,
+ SCM_DBG_SIOD_V3,
+ SCM_DBG_SIOD_V4,
+ SCM_DBG_SIOD_V5
+};
+static long sscm_verbose_level = -1;
+
+static ScmObj null_port;
+static ScmObj saved_output_port;
+static ScmObj saved_error_port;
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_siod(void)
+{
+ ScmCharPort *cport;
+ SCM_REGISTER_FUNC_TABLE(scm_siod_func_info_table);
+
+ scm_use("srfi-60");
+ scm_define_alias("bit-and", "logand");
+ scm_define_alias("bit-or", "logior");
+ scm_define_alias("bit-xor", "logxor");
+ scm_define_alias("bit-not", "lognot");
+
+ scm_gc_protect_with_init(&null_port, SCM_FALSE);
+ scm_gc_protect_with_init(&saved_output_port, SCM_FALSE);
+ scm_gc_protect_with_init(&saved_error_port, SCM_FALSE);
+
+ scm_nullport_init();
+ cport = scm_make_char_port(ScmNullPort_new());
+ null_port = MAKE_PORT(cport, SCM_PORTFLAG_INPUT | SCM_PORTFLAG_OUTPUT);
+
+ scm_set_verbose_level(2);
+}
+
+/*
+ * TODO:
+ * - replace with a portable proc such as (eval 'sym (interaction-environment))
+ * - make the portable proc interface similar to a de facto standard of other
+ * Scheme implementations if existing
+ */
+ScmObj
+scm_p_symbol_value(ScmObj var)
+{
+ DECLARE_FUNCTION("symbol-value", procedure_fixed_1);
+
+ ENSURE_SYMBOL(var);
+
+ return scm_symbol_value(var, SCM_NULL);
+}
+
+/*
+ * TODO:
+ * - replace with a portable proc such as (eval '(set! sym val)
+ * (interaction-environment))
+ * - make the portable proc interface similar to a de facto standard of other
+ * Scheme implementations if existing
+ */
+ScmObj
+scm_p_set_symbol_valued(ScmObj var, ScmObj val)
+{
+ DECLARE_FUNCTION("set-symbol-value!", procedure_fixed_2);
+
+ ENSURE_SYMBOL(var);
+
+ SCM_SYMBOL_SET_VCELL(var, val);
+
+ return val;
+}
+
+ScmObj
+scm_p_siod_equal(ScmObj obj1, ScmObj obj2)
+{
+ DECLARE_FUNCTION("=", procedure_fixed_2);
+
+ if (EQ(obj1, obj2))
+ return SCM_TRUE;
+ else if (!INTP(obj1) || !INTP(obj2))
+ return SCM_FALSE;
+ else if (SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2))
+ return SCM_TRUE;
+
+ return SCM_FALSE;
+}
+
+ScmObj
+scm_p_the_environment(ScmEvalState *eval_state)
+{
+ DECLARE_FUNCTION("the-environment", procedure_fixed_tailrec_0);
+
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+
+ return eval_state->env;
+}
+
+ScmObj
+scm_p_closure_code(ScmObj closure)
+{
+ ScmObj exp, body, sym_begin;
+ DECLARE_FUNCTION("%%closure-code", procedure_fixed_1);
+
+ ENSURE_CLOSURE(closure);
+
+ exp = SCM_CLOSURE_EXP(closure);
+ if (NULLP(CDDR(exp))) {
+ body = CADR(exp);
+ } else {
+ sym_begin = scm_intern("begin");
+ body = CONS(sym_begin, CDR(exp));
+ }
+
+ return CONS(CAR(exp), body);
+}
+
+ScmObj
+scm_p_verbose(ScmObj args)
+{
+ ScmObj level;
+ DECLARE_FUNCTION("verbose", procedure_variadic_0);
+
+ if (!NULLP(args)) {
+ level = POP(args);
+ ASSERT_NO_MORE_ARG(args);
+ ENSURE_INT(level);
+
+ scm_set_verbose_level(SCM_INT_VALUE(level));
+ }
+
+ return MAKE_INT(sscm_verbose_level);
+}
+
+ScmObj
+scm_p_eof_val(void)
+{
+ DECLARE_FUNCTION("eof-val", procedure_fixed_0);
+
+ return SCM_EOF;
+}
+
+ScmObj
+scm_s_undefine(ScmObj var, ScmObj env)
+{
+ ScmRef val;
+ DECLARE_FUNCTION("undefine", syntax_fixed_1);
+
+ ENSURE_SYMBOL(var);
+
+ val = scm_lookup_environment(var, env);
+ if (val != SCM_INVALID_REF)
+ SET(val, SCM_UNBOUND);
+ else
+ SCM_SYMBOL_SET_VCELL(var, SCM_UNBOUND);
+
+ return SCM_FALSE;
+}
+
+long
+scm_get_verbose_level(void)
+{
+ return sscm_verbose_level;
+}
+
+void
+scm_set_verbose_level(long level)
+{
+ if (level < 0)
+ ERR("scm_set_verbose_level: positive value required but got: %d",
+ (int)level);
+
+ if (sscm_verbose_level == level)
+ return;
+
+ sscm_verbose_level = level;
+
+ if (level > 5)
+ level = 5;
+ scm_set_debug_categories(sscm_debug_mask_tbl[level]);
+
+ if (level >= 2)
+ scm_set_debug_categories(scm_debug_categories()
+ | scm_predefined_debug_categories());
+
+ if (level == 0) {
+ if (!EQ(scm_err, null_port))
+ saved_error_port = scm_err;
+ if (!EQ(scm_out, null_port))
+ saved_output_port = scm_out;
+
+ scm_err = null_port;
+ scm_out = null_port;
+ } else {
+ if (EQ(scm_err, null_port))
+ scm_err = saved_error_port;
+ if (EQ(scm_out, null_port))
+ scm_out = saved_output_port;
+ }
+}
+
+/* FIXME: link conditionally with autoconf */
+#include "nullport.c"
Copied: branches/r5rs/sigscheme/src/module-srfi1.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi1.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi1.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi1.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,637 @@
+/*===========================================================================
+ * FileName : module-srfi1.c
+ * About : SRFI-1 List Library
+ *
+ * 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.
+===========================================================================*/
+
+/*
+ * Do not use this implementation for production code.
+ *
+ * This SRFI-1 implementation is still broken, and not using the SigScheme's
+ * safe and simple coding elements.
+ */
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2);
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi1(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi1_func_info_table);
+}
+
+/*===========================================================================
+ SRFI1 : The procedures : Constructors
+===========================================================================*/
+ScmObj
+scm_p_srfi1_xcons(ScmObj a, ScmObj b)
+{
+ DECLARE_FUNCTION("xcons", procedure_fixed_2);
+ return CONS(b, a);
+}
+
+ScmObj
+scm_p_srfi1_consstar(ScmObj args)
+{
+ ScmObj tail_cons = SCM_FALSE;
+ ScmObj prev_last = args;
+ DECLARE_FUNCTION("cons*", procedure_variadic_0);
+
+ if (NULLP(CDR(args)))
+ return CAR(args);
+
+ for (tail_cons = CDR(args); !NULLP(tail_cons); tail_cons = CDR(tail_cons)) {
+ /* check tail cons cell */
+ if (NULLP(CDR(tail_cons))) {
+ SET_CDR(prev_last, CAR(tail_cons));
+ }
+
+ prev_last = tail_cons;
+ }
+
+ return args;
+}
+
+ScmObj
+scm_p_srfi1_make_list(ScmObj length, ScmObj args)
+{
+ ScmObj filler;
+ ScmObj head = SCM_NULL;
+ scm_int_t len = 0;
+ scm_int_t i = 0;
+ DECLARE_FUNCTION("make-list", procedure_variadic_1);
+
+ ENSURE_INT(length);
+
+ len = SCM_INT_VALUE(length);
+
+ /* get filler if available */
+ if (!NULLP(args))
+ filler = CAR(args);
+ else
+ filler = SCM_FALSE;
+
+ /* then create list */
+ for (i = len; 0 < i; i--) {
+ head = CONS(filler, head);
+ }
+
+ return head;
+}
+
+ScmObj
+scm_p_srfi1_list_tabulate(ScmObj scm_n, ScmObj args)
+{
+ ScmObj proc = SCM_FALSE;
+ ScmObj head = SCM_NULL;
+ ScmObj num = SCM_FALSE;
+ scm_int_t n = 0;
+ scm_int_t i = 0;
+ DECLARE_FUNCTION("list-tabulate", procedure_variadic_1);
+
+ ENSURE_INT(scm_n);
+
+ /* get n */
+ n = SCM_INT_VALUE(scm_n);
+
+ /* get init_proc if available */
+ if (!NULLP(args))
+ proc = CAR(args);
+
+ /* then create list */
+ for (i = n; 0 < i; i--) {
+ num = MAKE_INT(i - 1);
+
+ if (!NULLP(proc))
+ num = scm_call(proc, LIST_1(num));
+
+ head = CONS(num, head);
+ }
+
+ return head;
+}
+
+/* FIXME: SRFI-1 list-copy is a shallow copy */
+ScmObj
+scm_p_srfi1_list_copy(ScmObj lst)
+{
+ /* broken */
+#if 0
+ ScmObj head = SCM_NULL;
+ ScmObj tail = SCM_FALSE;
+ ScmObj obj = SCM_FALSE;
+ DECLARE_FUNCTION("list-copy", procedure_fixed_1);
+
+ if (FALSEP(scm_p_listp(lst)))
+ ERR_OBJ("list required but got", lst);
+
+ for (; !NULLP(lst); lst = CDR(lst)) {
+ obj = CAR(lst);
+
+ /* further copy */
+ if (CONSP(obj))
+ obj = scm_p_srfi1_list_copy(obj);
+
+ /* then create new cons */
+ obj = CONS(obj, SCM_NULL);
+ if (!FALSEP(tail)) {
+ SET_CDR(tail, obj);
+ tail = obj;
+ } else {
+ head = obj;
+ tail = head;
+ }
+ }
+
+ return head;
+#endif
+ ERR("list-copy: bug: broken implementation");
+}
+
+ScmObj
+scm_p_srfi1_circular_list(ScmObj args)
+{
+ DECLARE_FUNCTION("circular-list", procedure_variadic_0);
+
+ SET_CDR(scm_p_srfi1_last_pair(args), args);
+ return args;
+}
+
+ScmObj
+scm_p_srfi1_iota(ScmObj scm_count, ScmObj args)
+{
+ ScmObj scm_start = SCM_FALSE;
+ ScmObj scm_step = SCM_FALSE;
+ ScmObj head = SCM_NULL;
+ scm_int_t count = 0;
+ scm_int_t start = 0;
+ scm_int_t step = 0;
+ scm_int_t i = 0;
+ DECLARE_FUNCTION("iota", procedure_variadic_1);
+
+ /* get params */
+ if (!NULLP(args))
+ scm_start = CAR(args);
+
+ if (!FALSEP(scm_start) && !NULLP(CDR(args)))
+ scm_step = CAR(CDR(args));
+
+ /* param type check */
+ ENSURE_INT(scm_count);
+ if (!FALSEP(scm_start))
+ ENSURE_INT(scm_start);
+ if (!FALSEP(scm_step))
+ ENSURE_INT(scm_step);
+
+ /* now create list */
+ count = SCM_INT_VALUE(scm_count);
+ start = FALSEP(scm_start) ? 0 : SCM_INT_VALUE(scm_start);
+ step = FALSEP(scm_step) ? 1 : SCM_INT_VALUE(scm_step);
+
+ for (i = count - 1; 0 <= i; i--) {
+ head = CONS(MAKE_INT(start + i * step), head);
+ }
+
+ return head;
+}
+
+/*===========================================================================
+ SRFI1 : The procedures : Predicates
+===========================================================================*/
+ScmObj
+scm_p_srfi1_proper_listp(ScmObj obj)
+{
+ DECLARE_FUNCTION("proper-list?", procedure_fixed_1);
+
+ return MAKE_BOOL(PROPER_LISTP(obj));
+}
+
+ScmObj
+scm_p_srfi1_circular_listp(ScmObj obj)
+{
+ DECLARE_FUNCTION("circular-list?", procedure_fixed_1);
+
+ return MAKE_BOOL(CIRCULAR_LISTP(obj));
+}
+
+ScmObj
+scm_p_srfi1_dotted_listp(ScmObj obj)
+{
+ DECLARE_FUNCTION("dotted-list?", procedure_fixed_1);
+
+ return MAKE_BOOL(DOTTED_LISTP(obj));
+}
+
+ScmObj
+scm_p_srfi1_not_pairp(ScmObj obj)
+{
+ DECLARE_FUNCTION("not-pair?", procedure_fixed_1);
+
+ return MAKE_BOOL(!CONSP(obj));
+}
+
+ScmObj
+scm_p_srfi1_null_listp(ScmObj lst)
+{
+ scm_int_t len;
+ DECLARE_FUNCTION("null-list?", procedure_fixed_1);
+
+ len = scm_length(lst);
+ if (!SCM_LISTLEN_PROPERP(len) && !SCM_LISTLEN_CIRCULARP(len))
+ ERR_OBJ("proper or circular list required but got", lst);
+
+ return MAKE_BOOL(NULLP(lst));
+}
+
+ScmObj
+scm_p_srfi1_listequal(ScmObj eqproc, ScmObj args)
+{
+ ScmObj first_lst = SCM_FALSE;
+ DECLARE_FUNCTION("list=", procedure_variadic_1);
+
+ if (NULLP(args))
+ return SCM_TRUE;
+
+ first_lst = CAR(args);
+ args = CDR(args);
+
+ if (NULLP(args))
+ return SCM_TRUE;
+
+ for (; !NULLP(args); args = CDR(args)) {
+ if (FALSEP(compare_list(eqproc, first_lst, CAR(args))))
+ return SCM_FALSE;
+ }
+
+ return SCM_TRUE;
+}
+
+static ScmObj
+compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2)
+{
+#define CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, obj1, obj2) \
+ (scm_call(eqproc, \
+ LIST_2(obj1, obj2)))
+
+ ScmObj ret_cmp = SCM_FALSE;
+
+ for (; !NULLP(lst1); lst1 = CDR(lst1), lst2 = CDR(lst2)) {
+ /* check contents */
+ ret_cmp = CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CAR(lst1), CAR(lst2));
+ if (FALSEP(ret_cmp))
+ return SCM_FALSE;
+
+ /* check next cdr's type */
+ if (SCM_TYPE(CDR(lst1)) != SCM_TYPE(CDR(lst2)))
+ return SCM_FALSE;
+
+ /* check dot pair */
+ if (!CONSP(CDR(lst1))) {
+ return CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CDR(lst1), CDR(lst2));
+ }
+ }
+ return SCM_TRUE;
+}
+
+ScmObj
+scm_p_srfi1_first(ScmObj lst)
+{
+ DECLARE_FUNCTION("first", procedure_fixed_1);
+ return scm_p_car(lst);
+}
+
+ScmObj
+scm_p_srfi1_second(ScmObj lst)
+{
+ DECLARE_FUNCTION("second", procedure_fixed_1);
+ return scm_p_cadr(lst);
+}
+
+ScmObj
+scm_p_srfi1_third(ScmObj lst)
+{
+ DECLARE_FUNCTION("third", procedure_fixed_1);
+ return scm_p_caddr(lst);
+}
+
+ScmObj
+scm_p_srfi1_fourth(ScmObj lst)
+{
+ DECLARE_FUNCTION("fourth", procedure_fixed_1);
+ return scm_p_cadddr(lst);
+}
+
+ScmObj
+scm_p_srfi1_fifth(ScmObj lst)
+{
+ DECLARE_FUNCTION("fifth", procedure_fixed_1);
+ return scm_p_car(scm_p_cddddr(lst));
+}
+
+ScmObj
+scm_p_srfi1_sixth(ScmObj lst)
+{
+ DECLARE_FUNCTION("sixth", procedure_fixed_1);
+ return scm_p_cadr(scm_p_cddddr(lst));
+}
+
+ScmObj
+scm_p_srfi1_seventh(ScmObj lst)
+{
+ DECLARE_FUNCTION("seventh", procedure_fixed_1);
+ return scm_p_caddr(scm_p_cddddr(lst));
+}
+
+ScmObj
+scm_p_srfi1_eighth(ScmObj lst)
+{
+ DECLARE_FUNCTION("eighth", procedure_fixed_1);
+ return scm_p_cadddr(scm_p_cddddr(lst));
+}
+
+ScmObj
+scm_p_srfi1_ninth(ScmObj lst)
+{
+ DECLARE_FUNCTION("ninth", procedure_fixed_1);
+ return scm_p_car(scm_p_cddddr(scm_p_cddddr(lst)));
+}
+
+ScmObj
+scm_p_srfi1_tenth(ScmObj lst)
+{
+ DECLARE_FUNCTION("tenth", procedure_fixed_1);
+ return scm_p_cadr(scm_p_cddddr(scm_p_cddddr(lst)));
+}
+
+ScmObj
+scm_p_srfi1_carpluscdr(ScmObj lst)
+{
+ DECLARE_FUNCTION("car+cdr", procedure_fixed_1);
+ return scm_p_values(LIST_2(CAR(lst), CDR(lst)));
+}
+
+ScmObj
+scm_p_srfi1_take(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ ScmObj ret = SCM_FALSE;
+ ScmObj ret_tail = SCM_FALSE;
+ scm_int_t idx = 0;
+ scm_int_t i;
+ DECLARE_FUNCTION("take", procedure_fixed_2);
+
+ ENSURE_INT(scm_idx);
+
+ idx = SCM_INT_VALUE(scm_idx);
+ for (i = 0; i < idx; i++) {
+ if (SCM_NULLP(tmp))
+ ERR_OBJ("illegal index is specified for", lst);
+
+ if (i != 0) {
+ SET_CDR(ret_tail, CONS(CAR(tmp), SCM_NULL));
+ ret_tail = CDR(ret_tail);
+ } else {
+ ret = CONS(CAR(tmp), SCM_NULL);
+ ret_tail = ret;
+ }
+
+ tmp = CDR(tmp);
+ }
+
+ return ret;
+}
+
+ScmObj
+scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj ret = lst;
+ scm_int_t idx = 0;
+ scm_int_t i;
+ DECLARE_FUNCTION("drop", procedure_fixed_2);
+
+ ENSURE_INT(scm_idx);
+
+ idx = SCM_INT_VALUE(scm_idx);
+ for (i = 0; i < idx; i++) {
+ if (!CONSP(ret))
+ ERR_OBJ("illegal index is specified for", lst);
+
+ ret = CDR(ret);
+ }
+
+ return ret;
+}
+
+ScmObj
+scm_p_srfi1_take_right(ScmObj lst, ScmObj scm_elem)
+{
+ ScmObj tmp = lst;
+ scm_int_t len = 0;
+ DECLARE_FUNCTION("take-right", procedure_fixed_2);
+
+ ENSURE_INT(scm_elem);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_elem);
+
+ return scm_p_srfi1_drop(lst, MAKE_INT(len));
+}
+
+ScmObj
+scm_p_srfi1_drop_right(ScmObj lst, ScmObj scm_elem)
+{
+ ScmObj tmp = lst;
+ scm_int_t len = 0;
+ DECLARE_FUNCTION("drop-right", procedure_fixed_2);
+
+ ENSURE_INT(scm_elem);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_elem);
+
+ return scm_p_srfi1_take(lst, MAKE_INT(len));
+}
+
+ScmObj
+scm_p_srfi1_taked(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ scm_int_t idx = 0;
+ scm_int_t i;
+ DECLARE_FUNCTION("take!", procedure_fixed_2);
+
+ ENSURE_INT(scm_idx);
+
+ idx = SCM_INT_VALUE(scm_idx);
+
+ for (i = 0; i < idx - 1; i++) {
+ tmp = CDR(tmp);
+ }
+
+ ENSURE_MUTABLE_CONS(tmp);
+ SET_CDR(tmp, SCM_NULL);
+
+ return lst;
+}
+
+ScmObj
+scm_p_srfi1_drop_rightd(ScmObj lst, ScmObj scm_idx)
+{
+ ScmObj tmp = lst;
+ scm_int_t len = 0;
+ scm_int_t i;
+ DECLARE_FUNCTION("drop-right!", procedure_fixed_2);
+
+ ENSURE_INT(scm_idx);
+
+ for (; CONSP(tmp); tmp = CDR(tmp))
+ len++;
+
+ len -= SCM_INT_VALUE(scm_idx);
+
+ tmp = lst;
+ for (i = 0; i < len - 1; i++) {
+ tmp = CDR(tmp);
+ }
+
+ ENSURE_MUTABLE_CONS(tmp);
+ SET_CDR(tmp, SCM_NULL);
+
+ return lst;
+}
+
+ScmObj
+scm_p_srfi1_split_at(ScmObj lst, ScmObj idx)
+{
+ DECLARE_FUNCTION("split-at", procedure_fixed_2);
+
+ return scm_p_values(LIST_2(scm_p_srfi1_take(lst, idx),
+ scm_p_srfi1_drop(lst, idx)));
+}
+
+ScmObj
+scm_p_srfi1_split_atd(ScmObj lst, ScmObj idx)
+{
+ ScmObj drop = scm_p_srfi1_drop(lst, idx);
+ DECLARE_FUNCTION("split-at!", procedure_fixed_2);
+
+ return scm_p_values(LIST_2(scm_p_srfi1_taked(lst, idx),
+ drop));
+}
+
+ScmObj
+scm_p_srfi1_last(ScmObj lst)
+{
+ DECLARE_FUNCTION("last", procedure_fixed_1);
+
+ /* sanity check */
+ if (NULLP(lst))
+ ERR_OBJ("non-empty, proper list is required but got", lst);
+
+ return CAR(scm_p_srfi1_last_pair(lst));
+}
+
+ScmObj
+scm_p_srfi1_last_pair(ScmObj lst)
+{
+ DECLARE_FUNCTION("last-pair", procedure_fixed_1);
+
+ /* sanity check */
+ if (NULLP(lst))
+ ERR_OBJ("non-empty, proper list is required but got", lst);
+
+ for (; CONSP(CDR(lst)); lst = CDR(lst))
+ ;
+
+ return lst;
+}
+
+/*===========================================================================
+ SRFI1 : The procedures : Miscellaneous
+===========================================================================*/
+ScmObj
+scm_p_srfi1_lengthplus(ScmObj lst)
+{
+ scm_int_t len;
+ DECLARE_FUNCTION("length+", procedure_fixed_1);
+
+ len = scm_length(lst);
+ /* although SRFI-1 does not specify the behavior for dotted list
+ * explicitly, the description indicates that dotted list is treated as
+ * same as R5RS 'length' procedure. So produce an error here. */
+ if (SCM_LISTLEN_DOTTEDP(len))
+ ERR_OBJ("proper or circular list required but got", lst);
+
+ return (SCM_LISTLEN_PROPERP(len)) ? MAKE_INT(len) : SCM_FALSE;
+}
+
+ScmObj
+scm_p_srfi1_concatenate(ScmObj args)
+{
+ ScmObj lsts_of_lst = CAR(args);
+ DECLARE_FUNCTION("concatenate", procedure_variadic_0);
+
+#if SCM_STRICT_ARGCHECK
+ if (!NULLP(CDR(args)))
+ ERR_OBJ("superfluous arguments", args);
+#endif
+
+ return scm_p_append(lsts_of_lst);
+}
Copied: branches/r5rs/sigscheme/src/module-srfi2.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi2.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi2.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi2.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,131 @@
+/*===========================================================================
+ * FileName : module-srfi2.c
+ * About : SRFI-2 AND-LET*: an AND with local bindings, a guarded LET*
+ * special form
+ *
+ * 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.
+===========================================================================*/
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi2(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi2_func_info_table);
+}
+
+ScmObj
+scm_s_srfi2_and_letstar(ScmObj claws, ScmObj body, ScmEvalState *eval_state)
+{
+ ScmObj env, claw, var, val, exp;
+ DECLARE_FUNCTION("and-let*", syntax_variadic_tailrec_1);
+
+ env = eval_state->env;
+
+ /*=======================================================================
+ (and-let* <claws> <body>)
+
+ <claws> ::= '() | (cons <claw> <claws>)
+ <claw> ::= (<variable> <expression>) | (<expression>)
+ | <bound-variable>
+ =======================================================================*/
+ if (CONSP(claws)) {
+ FOR_EACH (claw, claws) {
+ if (CONSP(claw)) {
+ if (NULLP(CDR(claw))) {
+ /* (<expression>) */
+ exp = CAR(claw);
+ val = EVAL(exp, env);
+ } else if (SYMBOLP(CAR(claw))) {
+ /* (<variable> <expression>) */
+ if (!LIST_2_P(claw))
+ goto err;
+ var = CAR(claw);
+ exp = CADR(claw);
+ val = EVAL(exp, env);
+ env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
+ } else {
+ goto err;
+ }
+ } else if (SYMBOLP(claw)) {
+ /* <bound-variable> */
+ val = EVAL(claw, env);
+ } else {
+ goto err;
+ }
+ if (FALSEP(val)) {
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+ return SCM_FALSE;
+ }
+ }
+ if (!NULLP(claws))
+ goto err;
+ } else if (NULLP(claws)) {
+ env = scm_extend_environment(SCM_NULL, SCM_NULL, env);
+ } else {
+ goto err;
+ }
+
+ eval_state->env = env;
+
+ return scm_s_body(body, eval_state);
+
+ err:
+ ERR_OBJ("invalid claws form", claws);
+ /* NOTREACHED */
+ return SCM_FALSE;
+}
Copied: branches/r5rs/sigscheme/src/module-srfi23.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi23.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi23.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi23.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,103 @@
+/*===========================================================================
+ * FileName : module-srfi23.c
+ * About : SRFI-23 Error reporting mechanism
+ *
+ * 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.
+===========================================================================*/
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi23(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi23_func_info_table);
+}
+
+/*===========================================================================
+ SRFI23 : Error reporting mechanism
+===========================================================================*/
+/*
+ * This code implements the '4.' of following Specification defined in SRFI-34.
+ *
+ * 1. Display <reason> and <arg1>... on the screen and terminate the Scheme
+ * program. (This might be suitable for a Scheme system implemented as a
+ * batch compiler.)
+ * 2. Display <reason> and <arg1>... on the screen and go back to the
+ * read-evaluate-print loop. (This might be suitable for an interactive
+ * implementation).
+ * 4. Package <reason> and <arg1>... up into an error object and pass this
+ * error object to an exception handler. The default exception handler then
+ * might do something as described in points 1 to 3.
+ */
+ScmObj
+scm_p_srfi23_error(ScmObj reason, ScmObj args)
+{
+ ScmObj err_obj;
+ DECLARE_FUNCTION("error", procedure_variadic_1);
+
+#if 0
+ /*
+ * Although SRFI-23 specified that "The argument <reason> should be a
+ * string", we should not force it. Displayable is sufficient.
+ */
+ ENSURE_STRING(reason);
+#endif
+
+ err_obj = scm_make_error_obj(reason, args);
+ scm_raise_error(err_obj);
+ /* NOTREACHED */
+ return SCM_UNDEF;
+}
Copied: branches/r5rs/sigscheme/src/module-srfi34.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi34.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi34.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi34.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,398 @@
+/*===========================================================================
+ * FileName : module-srfi34.c
+ * About : SRFI-34 Exception Handling for Programs
+ *
+ * Copyright (C) 2005-2006 YamaKen <yamaken AT bp.iij4u.or.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.
+===========================================================================*/
+
+/*
+ * This file implements C-version of the reference implementation written in
+ * the SRFI-34 specification. All parts are written in C since:
+ *
+ * - SigScheme doesn't have a hygienic-macros feature (yet)
+ *
+ * - To avoid namespace pollution (with-exception-handlers, guard-aux, etc),
+ * since SigScheme doesn't have a module or namespace feature (yet)
+ */
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Macro Definitions
+=======================================*/
+#define USE_WITH_SIGSCHEME_FATAL_ERROR 1
+
+#define ERRMSG_UNHANDLED_EXCEPTION "unhandled exception"
+#define ERRMSG_HANDLER_RETURNED "handler returned"
+#define ERRMSG_FALLBACK_EXHAUSTED "fallback handler exhausted"
+
+#define DECLARE_PRIVATE_FUNCTION(func_name, type) \
+ DECLARE_INTERNAL_FUNCTION(func_name)
+
+/*=======================================
+ File Local Type Definitions
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+static ScmObj current_exception_handlers;
+
+/* error messages */
+static ScmObj errmsg_unhandled_exception, errmsg_handler_returned;
+static ScmObj errmsg_fallback_exhausted;
+
+/* symbols */
+static ScmObj sym_error, sym_raise;
+static ScmObj sym_lex_env, sym_cond_catch, sym_body;
+static ScmObj sym_condition, sym_guard_k, sym_handler_k;
+
+/* procedures and syntaxes */
+static ScmObj syn_apply, proc_values;
+static ScmObj syn_set_cur_handlers, proc_fallback_handler;
+static ScmObj proc_with_exception_handlers;
+static ScmObj syn_guard_internal, syn_guard_handler, syn_guard_handler_body;
+static ScmObj syn_guard_body;
+
+static ScmObj *const global_var_list[] = {
+ ¤t_exception_handlers,
+ &errmsg_unhandled_exception, &errmsg_handler_returned,
+ &errmsg_fallback_exhausted,
+ &sym_error, &sym_raise,
+ &sym_lex_env, &sym_cond_catch, &sym_body,
+ &sym_condition, &sym_guard_k, &sym_handler_k,
+ &syn_apply, &proc_values,
+ &syn_set_cur_handlers, &proc_fallback_handler,
+ &proc_with_exception_handlers,
+ &syn_guard_internal, &syn_guard_handler, &syn_guard_handler_body,
+ &syn_guard_body,
+ NULL
+};
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+static ScmObj set_cur_handlers(ScmObj handlers, ScmObj env);
+static ScmObj with_exception_handlers(ScmObj new_handlers, ScmObj thunk);
+static ScmObj guard_internal(ScmObj q_guard_k, ScmObj env);
+static ScmObj guard_handler(ScmObj q_condition, ScmEvalState *eval_state);
+static ScmObj delay(ScmObj evaled_obj, ScmObj env);
+static ScmObj guard_handler_body(ScmObj q_handler_k, ScmObj env);
+static ScmObj guard_body(ScmEvalState *eval_state);
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi34(void)
+{
+ ScmObj *const *var;
+
+ scm_use("srfi-23");
+
+ /* protect global variables */
+ for (var = &global_var_list[0]; *var; var++)
+ scm_gc_protect_with_init(*var, SCM_FALSE);
+
+ errmsg_unhandled_exception = CONST_STRING(ERRMSG_UNHANDLED_EXCEPTION);
+ errmsg_handler_returned = CONST_STRING(ERRMSG_HANDLER_RETURNED);
+ errmsg_fallback_exhausted = CONST_STRING(ERRMSG_FALLBACK_EXHAUSTED);
+
+ sym_error = scm_intern("error");
+ sym_raise = scm_intern("raise");
+
+ sym_lex_env = scm_intern("lex-env");
+ sym_cond_catch = scm_intern("cond-catch");
+ sym_body = scm_intern("body");
+ sym_condition = scm_intern("condition");
+ sym_guard_k = scm_intern("guard-k");
+ sym_handler_k = scm_intern("handler-k");
+
+ /* prepare procedures and syntaxes */
+ syn_apply = scm_symbol_value(scm_intern("apply"), SCM_INTERACTION_ENV);
+ proc_values = scm_symbol_value(scm_intern("values"), SCM_INTERACTION_ENV);
+ /* FIXME: make registration type-safe */
+ syn_set_cur_handlers
+ = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &set_cur_handlers);
+ proc_with_exception_handlers
+ = MAKE_FUNC(SCM_PROCEDURE_FIXED | 2, &with_exception_handlers);
+ syn_guard_internal
+ = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &guard_internal);
+ syn_guard_handler
+ = MAKE_FUNC(SCM_SYNTAX_FIXED_TAIL_REC | 1, &guard_handler);
+ syn_guard_handler_body
+ = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &guard_handler_body);
+ syn_guard_body
+ = MAKE_FUNC(SCM_SYNTAX_FIXED_TAIL_REC | 0, &guard_body);
+
+#if USE_WITH_SIGSCHEME_FATAL_ERROR
+ proc_fallback_handler
+ = scm_s_lambda(LIST_1(sym_condition),
+ LIST_1(LIST_4(scm_intern("if"),
+ LIST_2(scm_intern("%%error-object?"),
+ sym_condition),
+ LIST_2(scm_intern("%%fatal-error"),
+ sym_condition),
+ LIST_3(sym_error,
+ errmsg_unhandled_exception,
+ sym_condition))),
+ SCM_INTERACTION_ENV);
+#else /* USE_WITH_SIGSCHEME_FATAL_ERROR */
+ /*
+ * The 'error' procedure should not be invoked directly by
+ * scm_p_srfi23_error(), to allow dynamic redifinition, and keep SRFI-23
+ * implementation abstract.
+ */
+ proc_fallback_handler
+ = scm_s_lambda(LIST_1(sym_condition),
+ LIST_1(LIST_3(sym_error,
+ errmsg_unhandled_exception,
+ sym_condition)),
+ SCM_INTERACTION_ENV);
+#endif /* USE_WITH_SIGSCHEME_FATAL_ERROR */
+
+ SCM_REGISTER_FUNC_TABLE(scm_srfi34_func_info_table);
+
+ current_exception_handlers = LIST_1(proc_fallback_handler);
+}
+
+static ScmObj
+set_cur_handlers(ScmObj handlers, ScmObj env)
+{
+ DECLARE_PRIVATE_FUNCTION("with_exception_handlers", syntax_fixed_1);
+
+ current_exception_handlers = handlers;
+ return SCM_UNDEF;
+}
+
+static ScmObj
+with_exception_handlers(ScmObj new_handlers, ScmObj thunk)
+{
+ ScmObj prev_handlers, before, after;
+ DECLARE_PRIVATE_FUNCTION("with_exception_handlers", procedure_fixed_2);
+
+ prev_handlers = current_exception_handlers;
+ before = scm_s_lambda(SCM_NULL,
+ LIST_1(LIST_2(syn_set_cur_handlers, new_handlers)),
+ SCM_INTERACTION_ENV);
+ after = scm_s_lambda(SCM_NULL,
+ LIST_1(LIST_2(syn_set_cur_handlers, prev_handlers)),
+ SCM_INTERACTION_ENV);
+ return scm_dynamic_wind(before, thunk, after);
+}
+
+/* with-exception-handler */
+
+ScmObj
+scm_p_srfi34_with_exception_handler(ScmObj handler, ScmObj thunk)
+{
+ ScmObj handlers;
+ DECLARE_FUNCTION("with-exception-handler", procedure_fixed_2);
+
+ ENSURE_PROCEDURE(handler);
+ ENSURE_PROCEDURE(thunk);
+
+ handlers = CONS(handler, current_exception_handlers);
+ return with_exception_handlers(handlers, thunk);
+}
+
+/* raise */
+
+ScmObj
+scm_p_srfi34_raise(ScmObj obj)
+{
+ ScmObj handler, rest_handlers, thunk, err_obj;
+ DECLARE_FUNCTION("raise", procedure_fixed_1);
+
+ if (NULLP(current_exception_handlers)) {
+ if (ERROBJP(obj))
+ err_obj = obj;
+ else
+ err_obj
+ = scm_make_error_obj(errmsg_fallback_exhausted, LIST_1(obj));
+ scm_p_fatal_error(err_obj);
+ /* NOTREACHED */
+ }
+
+ handler = CAR(current_exception_handlers);
+ rest_handlers = CDR(current_exception_handlers);
+ obj = LIST_2(SYM_QUOTE, obj);
+ thunk = scm_s_lambda(SCM_NULL,
+ LIST_2(LIST_2(handler, obj),
+ LIST_3(sym_error,
+ errmsg_handler_returned, obj)),
+ SCM_INTERACTION_ENV);
+ return with_exception_handlers(rest_handlers, thunk);
+}
+
+/* guard */
+
+ScmObj
+scm_s_srfi34_guard(ScmObj cond_catch, ScmObj body, ScmEvalState *eval_state)
+{
+ ScmObj lex_env, proc_guard_int, ret;
+ DECLARE_FUNCTION("guard", syntax_variadic_tailrec_1);
+
+ ENSURE_CONS(cond_catch);
+ ENSURE_CONS(body);
+
+ lex_env = eval_state->env;
+ eval_state->env
+ = scm_extend_environment(LIST_3(sym_lex_env, sym_cond_catch, sym_body),
+ LIST_3(lex_env, cond_catch, body),
+ lex_env);
+ proc_guard_int = scm_s_lambda(LIST_1(sym_guard_k),
+ LIST_1(LIST_2(syn_guard_internal, sym_guard_k)),
+ eval_state->env);
+
+ ret = scm_call_with_current_continuation(proc_guard_int, eval_state);
+ eval_state->env = lex_env;
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+ return scm_call(ret, SCM_NULL);
+}
+
+static ScmObj
+guard_internal(ScmObj q_guard_k, ScmObj env)
+{
+ ScmObj handler, body;
+ DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_1);
+
+ handler = scm_s_lambda(LIST_1(sym_condition),
+ LIST_1(LIST_2(syn_guard_handler, sym_condition)),
+ env);
+ body = scm_s_lambda(SCM_NULL,
+ LIST_1(LIST_1(syn_guard_body)),
+ env);
+
+ return scm_p_srfi34_with_exception_handler(handler, body);
+}
+
+static ScmObj
+guard_handler(ScmObj q_condition, ScmEvalState *eval_state)
+{
+ ScmObj handler_body, ret;
+ DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_tailrec_1);
+
+ handler_body
+ = scm_s_lambda(LIST_1(sym_handler_k),
+ LIST_1(LIST_2(syn_guard_handler_body, sym_handler_k)),
+ eval_state->env);
+ ret = scm_call_with_current_continuation(handler_body, eval_state);
+ if (eval_state->ret_type == SCM_VALTYPE_NEED_EVAL) {
+ ret = EVAL(ret, eval_state->env);
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+ }
+ return scm_call(ret, SCM_NULL);
+}
+
+/* assumes that scm_s_delay() returns a closure */
+static ScmObj
+delay(ScmObj evaled_obj, ScmObj env)
+{
+ ScmObj vals;
+
+ if (VALUEPACKETP(evaled_obj)) {
+ vals = SCM_VALUEPACKET_VALUES(evaled_obj);
+ return scm_s_delay(LIST_3(syn_apply,
+ proc_values, LIST_2(SYM_QUOTE, vals)),
+ env);
+ } else {
+ return scm_s_delay(LIST_2(SYM_QUOTE, evaled_obj), env);
+ }
+}
+
+/* assumes that scm_s_delay() returns a closure */
+static ScmObj
+guard_handler_body(ScmObj q_handler_k, ScmObj env)
+{
+ ScmEvalState eval_state;
+ ScmObj lex_env, cond_env, condition, cond_catch, guard_k, handler_k;
+ ScmObj sym_var, clauses, caught, reraise;
+ DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_1);
+
+ lex_env = scm_symbol_value(sym_lex_env, env);
+ condition = scm_symbol_value(sym_condition, env);
+ cond_catch = scm_symbol_value(sym_cond_catch, env);
+ guard_k = scm_symbol_value(sym_guard_k, env);
+ handler_k = EVAL(q_handler_k, env);
+
+ /* eval cond-catch block */
+ sym_var = CAR(cond_catch);
+ clauses = CDR(cond_catch);
+ ENSURE_SYMBOL(sym_var);
+ cond_env = scm_extend_environment(LIST_1(sym_var),
+ LIST_1(condition),
+ lex_env);
+ SCM_EVAL_STATE_INIT1(eval_state, cond_env);
+ caught = scm_s_cond_internal(clauses, SCM_INVALID, &eval_state);
+
+ if (VALIDP(caught)) {
+ if (eval_state.ret_type == SCM_VALTYPE_NEED_EVAL)
+ caught = EVAL(caught, cond_env);
+ scm_call_continuation(guard_k, delay(caught, cond_env));
+ } else {
+ reraise = scm_s_delay(LIST_2(sym_raise, LIST_2(SYM_QUOTE, condition)),
+ cond_env);
+ scm_call_continuation(handler_k, reraise);
+ }
+ /* NOTREACHED */
+ return SCM_UNDEF;
+}
+
+static ScmObj
+guard_body(ScmEvalState *eval_state)
+{
+ ScmEvalState lex_eval_state;
+ ScmObj lex_env, guard_k, body, result;
+ DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_tailrec_0);
+
+ lex_env = scm_symbol_value(sym_lex_env, eval_state->env);
+ guard_k = scm_symbol_value(sym_guard_k, eval_state->env);
+ body = scm_symbol_value(sym_body, eval_state->env);
+
+ /* evaluate the body */
+ SCM_EVAL_STATE_INIT1(lex_eval_state, lex_env);
+ result = scm_s_body(body, &lex_eval_state);
+ if (lex_eval_state.ret_type == SCM_VALTYPE_NEED_EVAL)
+ result = EVAL(result, lex_env);
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+
+ scm_call_continuation(guard_k, delay(result, lex_env));
+ /* NOTREACHED */
+ return SCM_UNDEF;
+}
Copied: branches/r5rs/sigscheme/src/module-srfi38.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi38.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi38.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi38.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,88 @@
+/*===========================================================================
+ * FileName : module-srfi38.c
+ * About : SRFI-38 External Representation for Data With Shared Structure
+ *
+ * Copyright (C) 2005-2006 Jun Inoue
+ *
+ * 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.
+===========================================================================*/
+
+/* Only write/ss is provided currently. */
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi38(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi38_func_info_table);
+
+ /* SRFI-38 allows providing (read/ss) and (write/ss) */
+ scm_define_alias("write/ss", "write-with-shared-structure");
+
+ scm_writess_func = scm_write_to_port_with_shared_structure;
+}
+
+/*===========================================================================
+ SRFI38 : External Representation for Data With Shared Structure
+===========================================================================*/
+ScmObj
+scm_p_srfi38_write_with_shared_structure(ScmObj obj, ScmObj args)
+{
+ ScmObj port;
+ DECLARE_FUNCTION("write-with-shared-structure", procedure_variadic_1);
+
+ port = scm_prepare_port(args, scm_out);
+ scm_write_to_port_with_shared_structure(port, obj);
+ return SCM_UNDEF;
+}
Copied: branches/r5rs/sigscheme/src/module-srfi6.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi6.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi6.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi6.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,144 @@
+/*===========================================================================
+ * FileName : module-srfi6.c
+ * About : SRFI-6 Basic String Ports
+ *
+ * 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.
+===========================================================================*/
+
+/*=======================================
+ System Include
+=======================================*/
+#include <stdlib.h>
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+#include "baseport.h"
+#include "strport.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+static void istrport_finalize(char **str, scm_bool ownership, void **opaque);
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi6(void)
+{
+ scm_strport_init();
+
+ SCM_REGISTER_FUNC_TABLE(scm_srfi6_func_info_table);
+}
+
+static void
+istrport_finalize(char **str, scm_bool ownership, void **opaque)
+{
+ scm_gc_unprotect((ScmObj *)opaque);
+}
+
+ScmObj
+scm_p_srfi6_open_input_string(ScmObj str)
+{
+ ScmObj *hold_str;
+ ScmBytePort *bport;
+ ScmCharPort *cport;
+ DECLARE_FUNCTION("open-input-string", procedure_fixed_1);
+
+ ENSURE_STRING(str);
+
+ bport = ScmInputStrPort_new_const(SCM_STRING_STR(str), istrport_finalize);
+ hold_str = (ScmObj *)ScmInputStrPort_ref_opaque(bport);
+ scm_gc_protect_with_init(hold_str, str);
+ cport = scm_make_char_port(bport);
+ return MAKE_PORT(cport, SCM_PORTFLAG_INPUT);
+}
+
+ScmObj
+scm_p_srfi6_open_output_string(void)
+{
+ ScmBytePort *bport;
+ ScmCharPort *cport;
+ DECLARE_FUNCTION("open-output-string", procedure_fixed_0);
+
+ bport = ScmOutputStrPort_new(NULL);
+ cport = scm_make_char_port(bport);
+ return MAKE_PORT(cport, SCM_PORTFLAG_OUTPUT);
+}
+
+ScmObj
+scm_p_srfi6_get_output_string(ScmObj port)
+{
+ ScmBaseCharPort *cport;
+ const char *str;
+ char *new_str;
+ scm_int_t mb_len;
+#if SCM_USE_NULL_CAPABLE_STRING
+ size_t size;
+#endif
+ DECLARE_FUNCTION("get-output-string", procedure_fixed_1);
+
+ ENSURE_PORT(port);
+
+ SCM_ENSURE_LIVE_PORT(port);
+ cport = SCM_CHARPORT_DYNAMIC_CAST(ScmBaseCharPort, SCM_PORT_IMPL(port));
+
+ str = ScmOutputStrPort_str(cport->bport);
+ /* FIXME: incorrect length for null-capable string */
+ mb_len = scm_mb_bare_c_strlen(scm_port_codec(port), str);
+#if SCM_USE_NULL_CAPABLE_STRING
+ size = ScmOutputStrPort_c_strlen(cport->bport) + sizeof("");
+ new_str = scm_malloc(size);
+ memcpy(new_str, str, size);
+#else
+ new_str = scm_strdup(str);
+#endif
+
+ return MAKE_STRING(new_str, mb_len);
+}
+
+
+/* FIXME: link conditionally with autoconf */
+#include "strport.c"
Copied: branches/r5rs/sigscheme/src/module-srfi60.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi60.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi60.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi60.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,158 @@
+/*===========================================================================
+ * FileName : module-srfi60.c
+ * About : SRFI-60 Integers as Bits
+ *
+ * Copyright (C) 2005-2006 YamaKen
+ *
+ * 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.
+===========================================================================*/
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+#define BITWISE_OPERATION_BODY(op, left, right) \
+ do { \
+ scm_int_t result; \
+ \
+ result = 0; \
+ switch (*state) { \
+ case SCM_REDUCE_0: \
+ break; \
+ case SCM_REDUCE_1: \
+ ENSURE_INT(right); \
+ return right; \
+ case SCM_REDUCE_PARTWAY: \
+ case SCM_REDUCE_LAST: \
+ ENSURE_INT(left); \
+ ENSURE_INT(right); \
+ result = (SCM_INT_VALUE(left) op SCM_INT_VALUE(right)); \
+ break; \
+ default: \
+ SCM_ASSERT(scm_false); \
+ } \
+ return MAKE_INT(result); \
+ } while (/* CONSTCOND */ 0)
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi60(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi60_func_info_table);
+
+ scm_define_alias("bitwise-and", "logand");
+ scm_define_alias("bitwise-ior", "logior");
+ scm_define_alias("bitwise-xor", "logxor");
+ scm_define_alias("bitwise-not", "lognot");
+ scm_define_alias("bitwise-merge", "bitwise-if");
+ scm_define_alias("any-bits-set?", "logtest");
+}
+
+/* Bitwise Operations */
+ScmObj
+scm_p_srfi60_logand(ScmObj left, ScmObj right, enum ScmReductionState *state)
+{
+ DECLARE_FUNCTION("logand", reduction_operator);
+
+ BITWISE_OPERATION_BODY(&, left, right);
+}
+
+ScmObj
+scm_p_srfi60_logior(ScmObj left, ScmObj right, enum ScmReductionState *state)
+{
+ DECLARE_FUNCTION("logior", reduction_operator);
+
+ BITWISE_OPERATION_BODY(|, left, right);
+}
+
+ScmObj
+scm_p_srfi60_logxor(ScmObj left, ScmObj right, enum ScmReductionState *state)
+{
+ DECLARE_FUNCTION("logxor", reduction_operator);
+
+ BITWISE_OPERATION_BODY(^, left, right);
+}
+
+ScmObj
+scm_p_srfi60_lognot(ScmObj n)
+{
+ DECLARE_FUNCTION("lognot", procedure_fixed_1);
+
+ ENSURE_INT(n);
+
+ return MAKE_INT(~SCM_INT_VALUE(n));
+}
+
+ScmObj
+scm_p_srfi60_bitwise_if(ScmObj mask, ScmObj n0, ScmObj n1)
+{
+ scm_int_t result, c_mask;
+ DECLARE_FUNCTION("bitwise-if", procedure_fixed_3);
+
+ ENSURE_INT(mask);
+ ENSURE_INT(n0);
+ ENSURE_INT(n1);
+
+ c_mask = SCM_INT_VALUE(mask);
+ result = (c_mask & SCM_INT_VALUE(n0)) | (~c_mask & SCM_INT_VALUE(n1));
+
+ return MAKE_INT(result);
+}
+
+ScmObj
+scm_p_srfi60_logtest(ScmObj j, ScmObj k)
+{
+ DECLARE_FUNCTION("logtest", procedure_fixed_2);
+
+ ENSURE_INT(j);
+ ENSURE_INT(k);
+
+ return MAKE_BOOL(SCM_INT_VALUE(j) & SCM_INT_VALUE(k));
+}
Copied: branches/r5rs/sigscheme/src/module-srfi8.c (from rev 3021, branches/r5rs/sigscheme/src/operations-srfi8.c)
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi8.c 2006-01-29 20:37:42 UTC (rev 3021)
+++ branches/r5rs/sigscheme/src/module-srfi8.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -0,0 +1,112 @@
+/*===========================================================================
+ * FileName : module-srfi8.c
+ * About : SRFI-8 receive: Binding to multiple values
+ *
+ * Copyright (C) 2005-2006 Jun Inoue
+ *
+ * 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.
+===========================================================================*/
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+void
+scm_initialize_srfi8(void)
+{
+ SCM_REGISTER_FUNC_TABLE(scm_srfi8_func_info_table);
+}
+
+ScmObj
+scm_s_srfi8_receive(ScmObj formals, ScmObj expr, ScmObj body,
+ ScmEvalState *eval_state)
+{
+ scm_int_t formals_len, actuals_len;
+ ScmObj env, actuals;
+ DECLARE_FUNCTION("receive", syntax_variadic_tailrec_2);
+
+ env = eval_state->env;
+
+ /*
+ * (receive <formals> <expression> <body>)
+ */
+
+ formals_len = scm_validate_formals(formals);
+ if (SCM_LISTLEN_ERRORP(formals_len))
+ ERR_OBJ("bad formals", formals);
+
+ /* FIXME: do we have to extend the environment first? The SRFI-8
+ * document contradicts itself on this part. */
+ /*
+ * In my recognition, the description in SRFI-8 "The environment in which
+ * the receive-expression is evaluated is extended by binding <variable1>,
+ * ..." does not mean that the environment is extended for the evaluation
+ * of the receive-expression. Probably it only specifies which environment
+ * will be extended after the evaluation. So current implementation is
+ * correct, I think. -- YamaKen 2006-01-05
+ */
+ actuals = EVAL(expr, env);
+
+ if (SCM_VALUEPACKETP(actuals)) {
+ actuals = SCM_VALUEPACKET_VALUES(actuals);
+ actuals_len = scm_finite_length(actuals);
+ } else {
+ actuals = LIST_1(actuals);
+ actuals_len = 1;
+ }
+
+ if (!scm_valid_environment_extension_lengthp(formals_len, actuals_len))
+ ERR_OBJ("unmatched number of args for multiple values", actuals);
+ eval_state->env = env = scm_extend_environment(formals, actuals, env);
+
+ return scm_s_body(body, eval_state);
+}
Deleted: branches/r5rs/sigscheme/src/operations-nonstd.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-nonstd.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-nonstd.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,264 +0,0 @@
-/*===========================================================================
- * FileName : operations-nonstd.c
- * About : SigScheme specific non standard operations
- *
- * 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.
-===========================================================================*/
-
-/*=======================================
- System Include
-=======================================*/
-#include <stddef.h>
-#include <stdio.h>
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Macro Definitions
-=======================================*/
-
-/*=======================================
- File Local Type Definitions
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-/* io.c */
-extern const char *scm_lib_path;
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-static void scm_require_internal(const char *filename);
-static ScmObj make_loaded_str(const char *filename);
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_nonstd_features(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_nonstd_func_info_table);
-
- scm_define_alias("call/cc", "call-with-current-continuation");
-}
-
-/*
- * TODO:
- * - describe compatibility with de facto standard of other Scheme
- * implementations (accept env as optional arg, etc)
- *
- * NOTE: Gauche 0.8.6 has deprecated symbol-bound? and is going to replace the
- * procedure with global-variable-bound?.
- */
-/* The implementation is fully compatible with SIOD */
-ScmObj
-scm_p_symbol_boundp(ScmObj sym, ScmObj rest)
-{
- ScmObj env;
- ScmRef ref;
- DECLARE_FUNCTION("symbol-bound?", procedure_variadic_1);
-
- ENSURE_SYMBOL(sym);
-
- if (NULLP(rest)) {
- env = SCM_INTERACTION_ENV;
- } else {
- env = POP(rest);
- ASSERT_NO_MORE_ARG(rest);
- ENSURE_VALID_ENV(env);
- }
- ref = scm_lookup_environment(sym, env);
-
- return MAKE_BOOL(ref != SCM_INVALID_REF || SCM_SYMBOL_BOUNDP(sym));
-}
-
-/* SIOD compatible */
-ScmObj
-scm_p_load_path(void)
-{
- DECLARE_FUNCTION("load-path", procedure_fixed_0);
-
- return CONST_STRING(scm_lib_path);
-}
-
-void
-scm_require(const char *filename)
-{
-#if !SCM_GCC4_READY_GC
- ScmObj stack_start;
-#endif
-
-#if SCM_GCC4_READY_GC
- SCM_GC_PROTECTED_CALL_VOID(scm_require_internal, (filename));
-#else
- scm_gc_protect_stack(&stack_start);
-
- scm_require_internal(filename);
-
- scm_gc_unprotect_stack(&stack_start);
-#endif
-}
-
-static void
-scm_require_internal(const char *filename)
-{
- ScmObj loaded_str;
-
- loaded_str = make_loaded_str(filename);
- if (!scm_providedp(loaded_str)) {
- scm_load(filename);
- scm_provide(loaded_str);
- }
-}
-
-ScmObj
-scm_p_require(ScmObj filename)
-{
-#if SCM_COMPAT_SIOD
- ScmObj loaded_str, retsym;
-#endif
- DECLARE_FUNCTION("require", procedure_fixed_1);
-
- ENSURE_STRING(filename);
-
- scm_require_internal(SCM_STRING_STR(filename));
-
-#if SCM_COMPAT_SIOD
- loaded_str = make_loaded_str(SCM_STRING_STR(filename));
- retsym = scm_intern(SCM_STRING_STR(loaded_str));
- SCM_SYMBOL_SET_VCELL(retsym, SCM_TRUE);
-
- return retsym;
-#else
- return SCM_TRUE;
-#endif
-}
-
-static ScmObj
-make_loaded_str(const char *filename)
-{
- char *loaded_str;
- size_t size;
-
- size = strlen(filename) + sizeof("*-loaded*");
- loaded_str = scm_malloc(size);
- snprintf(loaded_str, size, "*%s-loaded*", filename);
-
- return MAKE_IMMUTABLE_STRING(loaded_str, STRLEN_UNKNOWN);
-}
-
-/*
- * TODO: replace original specification with a SRFI standard or other de facto
- * standard
- */
-ScmObj
-scm_p_provide(ScmObj feature)
-{
- DECLARE_FUNCTION("provide", procedure_fixed_1);
-
- ENSURE_STRING(feature);
-
- scm_provide(feature);
-
- return SCM_TRUE;
-}
-
-/*
- * TODO: replace original specification with a SRFI standard or other de facto
- * standard
- */
-ScmObj
-scm_p_providedp(ScmObj feature)
-{
- DECLARE_FUNCTION("provided?", procedure_fixed_1);
-
- ENSURE_STRING(feature);
-
- return MAKE_BOOL(scm_providedp(feature));
-}
-
-/*
- * TODO: describe compatibility with de facto standard of other Scheme
- * implementations
- */
-ScmObj
-scm_p_file_existsp(ScmObj filepath)
-{
- FILE *f;
- DECLARE_FUNCTION("file-exists?", procedure_fixed_1);
-
- ENSURE_STRING(filepath);
-
- f = fopen(SCM_STRING_STR(filepath), "r");
- if (!f)
- return SCM_FALSE;
- fclose(f);
-
- return SCM_TRUE;
-}
-
-/* TODO: remove to ensure security */
-ScmObj
-scm_p_delete_file(ScmObj filepath)
-{
- DECLARE_FUNCTION("delete-file", procedure_fixed_1);
-
- ENSURE_STRING(filepath);
-
- if (remove(SCM_STRING_STR(filepath)) == -1)
- ERR_OBJ("delete failed. file = ", filepath);
-
- return SCM_TRUE;
-}
-
-/* to avoid being typo of length+, this procedure did not name as length++ */
-/* FIXME: replace with a SRFI or de facto standard equivalent if exist */
-ScmObj
-scm_p_lengthstar(ScmObj lst)
-{
- scm_int_t len;
- DECLARE_FUNCTION("length*", procedure_fixed_1);
-
- len = scm_length(lst);
- if (!SCM_LISTLEN_PROPERP(len)) { /* make fast path for proper list */
- if (SCM_LISTLEN_DOTTEDP(len))
- len = -SCM_LISTLEN_DOTTED(len);
- else if (SCM_LISTLEN_CIRCULARP(len))
- return SCM_FALSE;
- }
-
- return MAKE_INT(len);
-}
Deleted: branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-r5rs-deepcadrs.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,238 +0,0 @@
-/*===========================================================================
- * FileName : operations-r5rs-deepcadrs.c
- * About : Deep c[ad]+r operations
- *
- * 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.
-===========================================================================*/
-
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Macro Definitions
-=======================================*/
-
-/*=======================================
- File Local Type Definitions
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-ScmObj
-scm_p_caaar(ScmObj lst)
-{
- DECLARE_FUNCTION("caaar", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_car(lst) ));
-}
-
-ScmObj
-scm_p_caadr(ScmObj lst)
-{
- DECLARE_FUNCTION("caadr", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_cdr(lst) ));
-}
-
-ScmObj
-scm_p_cadar(ScmObj lst)
-{
- DECLARE_FUNCTION("cadar", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_car(lst) ));
-}
-
-ScmObj
-scm_p_cdaar(ScmObj lst)
-{
- DECLARE_FUNCTION("cdaar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_car(lst) ));
-}
-
-ScmObj
-scm_p_cdadr(ScmObj lst)
-{
- DECLARE_FUNCTION("cdadr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_cdr(lst) ));
-}
-
-ScmObj
-scm_p_cddar(ScmObj lst)
-{
- DECLARE_FUNCTION("cddar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_car(lst) ));
-}
-
-ScmObj
-scm_p_caaaar(ScmObj lst)
-{
- DECLARE_FUNCTION("caaaar", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_car( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_caaadr(ScmObj lst)
-{
- DECLARE_FUNCTION("caaadr", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_car( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_caadar(ScmObj lst)
-{
- DECLARE_FUNCTION("caadar", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_cdr( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_caaddr(ScmObj lst)
-{
- DECLARE_FUNCTION("caaddr", procedure_fixed_1);
-
- return scm_p_car( scm_p_car( scm_p_cdr( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_cadaar(ScmObj lst)
-{
- DECLARE_FUNCTION("cadaar", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_car( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cadadr(ScmObj lst)
-{
- DECLARE_FUNCTION("cadadr", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_car( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_caddar(ScmObj lst)
-{
- DECLARE_FUNCTION("caddar", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_cdr( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cadddr(ScmObj lst)
-{
- DECLARE_FUNCTION("cadddr", procedure_fixed_1);
-
- return scm_p_car( scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_cdaaar(ScmObj lst)
-{
- DECLARE_FUNCTION("cdaaar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_car( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cdaadr(ScmObj lst)
-{
- DECLARE_FUNCTION("cdaadr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_car( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_cdadar(ScmObj lst)
-{
- DECLARE_FUNCTION("cdadar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_cdr( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cdaddr(ScmObj lst)
-{
- DECLARE_FUNCTION("cdaddr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_car( scm_p_cdr( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_cddaar(ScmObj lst)
-{
- DECLARE_FUNCTION("cddaar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_car( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cddadr(ScmObj lst)
-{
- DECLARE_FUNCTION("cddadr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_car( scm_p_cdr(lst) )));
-}
-
-ScmObj
-scm_p_cdddar(ScmObj lst)
-{
- DECLARE_FUNCTION("cdddar", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_cdr( scm_p_car(lst) )));
-}
-
-ScmObj
-scm_p_cddddr(ScmObj lst)
-{
- DECLARE_FUNCTION("cddddr", procedure_fixed_1);
-
- return scm_p_cdr( scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) )));
-}
Deleted: branches/r5rs/sigscheme/src/operations-siod.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-siod.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-siod.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,284 +0,0 @@
-/*===========================================================================
- * FileName : operations-siod.c
- * About : SIOD compatible procedures
- *
- * 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.
-===========================================================================*/
-/*=======================================
- System Include
-=======================================*/
-#include <stddef.h>
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-#include "nullport.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-/*
- * SIOD's verbose-level compatible debug message printing control:
- * Search 'siod_verbose_level' in slib.c to know further detail.
- *
- * Don't change the verbose level 2 for SCM_DBG_BACKTRACE. This is used to
- * suppress backtrace when run by the testing framework of uim.
- * -- YamaKen 2005-11-05
- *
- * Extra control:
- * v0: suppress all printing even if normal 'write' or 'display'
- * v1: print each result of repl
- * v2: print the "> " prompt
- */
-#define SCM_DBG_SIOD_V0 SCM_DBG_NONE
-#define SCM_DBG_SIOD_V1 SCM_DBG_ERRMSG
-#define SCM_DBG_SIOD_V2 (SCM_DBG_SIOD_V1 | SCM_DBG_BACKTRACE)
-#define SCM_DBG_SIOD_V3 (SCM_DBG_SIOD_V2 | SCM_DBG_FILE)
-#define SCM_DBG_SIOD_V4 (SCM_DBG_SIOD_V3 | SCM_DBG_GC)
-#define SCM_DBG_SIOD_V5 (SCM_DBG_SIOD_V4 | SCM_DBG_READ)
-
-/*=======================================
- Variable Declarations
-=======================================*/
-static const int sscm_debug_mask_tbl[] = {
- SCM_DBG_SIOD_V0,
- SCM_DBG_SIOD_V1,
- SCM_DBG_SIOD_V2,
- SCM_DBG_SIOD_V3,
- SCM_DBG_SIOD_V4,
- SCM_DBG_SIOD_V5
-};
-static long sscm_verbose_level = -1;
-
-static ScmObj null_port;
-static ScmObj saved_output_port;
-static ScmObj saved_error_port;
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_siod(void)
-{
- ScmCharPort *cport;
- SCM_REGISTER_FUNC_TABLE(scm_siod_func_info_table);
-
- scm_use("srfi-60");
- scm_define_alias("bit-and", "logand");
- scm_define_alias("bit-or", "logior");
- scm_define_alias("bit-xor", "logxor");
- scm_define_alias("bit-not", "lognot");
-
- scm_gc_protect_with_init(&null_port, SCM_FALSE);
- scm_gc_protect_with_init(&saved_output_port, SCM_FALSE);
- scm_gc_protect_with_init(&saved_error_port, SCM_FALSE);
-
- scm_nullport_init();
- cport = scm_make_char_port(ScmNullPort_new());
- null_port = MAKE_PORT(cport, SCM_PORTFLAG_INPUT | SCM_PORTFLAG_OUTPUT);
-
- scm_set_verbose_level(2);
-}
-
-/*
- * TODO:
- * - replace with a portable proc such as (eval 'sym (interaction-environment))
- * - make the portable proc interface similar to a de facto standard of other
- * Scheme implementations if existing
- */
-ScmObj
-scm_p_symbol_value(ScmObj var)
-{
- DECLARE_FUNCTION("symbol-value", procedure_fixed_1);
-
- ENSURE_SYMBOL(var);
-
- return scm_symbol_value(var, SCM_NULL);
-}
-
-/*
- * TODO:
- * - replace with a portable proc such as (eval '(set! sym val)
- * (interaction-environment))
- * - make the portable proc interface similar to a de facto standard of other
- * Scheme implementations if existing
- */
-ScmObj
-scm_p_set_symbol_valued(ScmObj var, ScmObj val)
-{
- DECLARE_FUNCTION("set-symbol-value!", procedure_fixed_2);
-
- ENSURE_SYMBOL(var);
-
- SCM_SYMBOL_SET_VCELL(var, val);
-
- return val;
-}
-
-ScmObj
-scm_p_siod_equal(ScmObj obj1, ScmObj obj2)
-{
- DECLARE_FUNCTION("=", procedure_fixed_2);
-
- if (EQ(obj1, obj2))
- return SCM_TRUE;
- else if (!INTP(obj1) || !INTP(obj2))
- return SCM_FALSE;
- else if (SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2))
- return SCM_TRUE;
-
- return SCM_FALSE;
-}
-
-ScmObj
-scm_p_the_environment(ScmEvalState *eval_state)
-{
- DECLARE_FUNCTION("the-environment", procedure_fixed_tailrec_0);
-
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
-
- return eval_state->env;
-}
-
-ScmObj
-scm_p_closure_code(ScmObj closure)
-{
- ScmObj exp, body, sym_begin;
- DECLARE_FUNCTION("%%closure-code", procedure_fixed_1);
-
- ENSURE_CLOSURE(closure);
-
- exp = SCM_CLOSURE_EXP(closure);
- if (NULLP(CDDR(exp))) {
- body = CADR(exp);
- } else {
- sym_begin = scm_intern("begin");
- body = CONS(sym_begin, CDR(exp));
- }
-
- return CONS(CAR(exp), body);
-}
-
-ScmObj
-scm_p_verbose(ScmObj args)
-{
- ScmObj level;
- DECLARE_FUNCTION("verbose", procedure_variadic_0);
-
- if (!NULLP(args)) {
- level = POP(args);
- ASSERT_NO_MORE_ARG(args);
- ENSURE_INT(level);
-
- scm_set_verbose_level(SCM_INT_VALUE(level));
- }
-
- return MAKE_INT(sscm_verbose_level);
-}
-
-ScmObj
-scm_p_eof_val(void)
-{
- DECLARE_FUNCTION("eof-val", procedure_fixed_0);
-
- return SCM_EOF;
-}
-
-ScmObj
-scm_s_undefine(ScmObj var, ScmObj env)
-{
- ScmRef val;
- DECLARE_FUNCTION("undefine", syntax_fixed_1);
-
- ENSURE_SYMBOL(var);
-
- val = scm_lookup_environment(var, env);
- if (val != SCM_INVALID_REF)
- SET(val, SCM_UNBOUND);
- else
- SCM_SYMBOL_SET_VCELL(var, SCM_UNBOUND);
-
- return SCM_FALSE;
-}
-
-long
-scm_get_verbose_level(void)
-{
- return sscm_verbose_level;
-}
-
-void
-scm_set_verbose_level(long level)
-{
- if (level < 0)
- ERR("scm_set_verbose_level: positive value required but got: %d",
- (int)level);
-
- if (sscm_verbose_level == level)
- return;
-
- sscm_verbose_level = level;
-
- if (level > 5)
- level = 5;
- scm_set_debug_categories(sscm_debug_mask_tbl[level]);
-
- if (level >= 2)
- scm_set_debug_categories(scm_debug_categories()
- | scm_predefined_debug_categories());
-
- if (level == 0) {
- if (!EQ(scm_err, null_port))
- saved_error_port = scm_err;
- if (!EQ(scm_out, null_port))
- saved_output_port = scm_out;
-
- scm_err = null_port;
- scm_out = null_port;
- } else {
- if (EQ(scm_err, null_port))
- scm_err = saved_error_port;
- if (EQ(scm_out, null_port))
- scm_out = saved_output_port;
- }
-}
-
-/* FIXME: link conditionally with autoconf */
-#include "nullport.c"
Deleted: branches/r5rs/sigscheme/src/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi1.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi1.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,637 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi1.c
- * About : srfi1 procedures
- *
- * 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.
-===========================================================================*/
-
-/*
- * Do not use this implementation for production code.
- *
- * This SRFI-1 implementation is still broken, and not using the SigScheme's
- * safe and simple coding elements.
- */
-
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2);
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi1(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi1_func_info_table);
-}
-
-/*===========================================================================
- SRFI1 : The procedures : Constructors
-===========================================================================*/
-ScmObj
-scm_p_srfi1_xcons(ScmObj a, ScmObj b)
-{
- DECLARE_FUNCTION("xcons", procedure_fixed_2);
- return CONS(b, a);
-}
-
-ScmObj
-scm_p_srfi1_consstar(ScmObj args)
-{
- ScmObj tail_cons = SCM_FALSE;
- ScmObj prev_last = args;
- DECLARE_FUNCTION("cons*", procedure_variadic_0);
-
- if (NULLP(CDR(args)))
- return CAR(args);
-
- for (tail_cons = CDR(args); !NULLP(tail_cons); tail_cons = CDR(tail_cons)) {
- /* check tail cons cell */
- if (NULLP(CDR(tail_cons))) {
- SET_CDR(prev_last, CAR(tail_cons));
- }
-
- prev_last = tail_cons;
- }
-
- return args;
-}
-
-ScmObj
-scm_p_srfi1_make_list(ScmObj length, ScmObj args)
-{
- ScmObj filler;
- ScmObj head = SCM_NULL;
- scm_int_t len = 0;
- scm_int_t i = 0;
- DECLARE_FUNCTION("make-list", procedure_variadic_1);
-
- ENSURE_INT(length);
-
- len = SCM_INT_VALUE(length);
-
- /* get filler if available */
- if (!NULLP(args))
- filler = CAR(args);
- else
- filler = SCM_FALSE;
-
- /* then create list */
- for (i = len; 0 < i; i--) {
- head = CONS(filler, head);
- }
-
- return head;
-}
-
-ScmObj
-scm_p_srfi1_list_tabulate(ScmObj scm_n, ScmObj args)
-{
- ScmObj proc = SCM_FALSE;
- ScmObj head = SCM_NULL;
- ScmObj num = SCM_FALSE;
- scm_int_t n = 0;
- scm_int_t i = 0;
- DECLARE_FUNCTION("list-tabulate", procedure_variadic_1);
-
- ENSURE_INT(scm_n);
-
- /* get n */
- n = SCM_INT_VALUE(scm_n);
-
- /* get init_proc if available */
- if (!NULLP(args))
- proc = CAR(args);
-
- /* then create list */
- for (i = n; 0 < i; i--) {
- num = MAKE_INT(i - 1);
-
- if (!NULLP(proc))
- num = scm_call(proc, LIST_1(num));
-
- head = CONS(num, head);
- }
-
- return head;
-}
-
-/* FIXME: SRFI-1 list-copy is a shallow copy */
-ScmObj
-scm_p_srfi1_list_copy(ScmObj lst)
-{
- /* broken */
-#if 0
- ScmObj head = SCM_NULL;
- ScmObj tail = SCM_FALSE;
- ScmObj obj = SCM_FALSE;
- DECLARE_FUNCTION("list-copy", procedure_fixed_1);
-
- if (FALSEP(scm_p_listp(lst)))
- ERR_OBJ("list required but got", lst);
-
- for (; !NULLP(lst); lst = CDR(lst)) {
- obj = CAR(lst);
-
- /* further copy */
- if (CONSP(obj))
- obj = scm_p_srfi1_list_copy(obj);
-
- /* then create new cons */
- obj = CONS(obj, SCM_NULL);
- if (!FALSEP(tail)) {
- SET_CDR(tail, obj);
- tail = obj;
- } else {
- head = obj;
- tail = head;
- }
- }
-
- return head;
-#endif
- ERR("list-copy: bug: broken implementation");
-}
-
-ScmObj
-scm_p_srfi1_circular_list(ScmObj args)
-{
- DECLARE_FUNCTION("circular-list", procedure_variadic_0);
-
- SET_CDR(scm_p_srfi1_last_pair(args), args);
- return args;
-}
-
-ScmObj
-scm_p_srfi1_iota(ScmObj scm_count, ScmObj args)
-{
- ScmObj scm_start = SCM_FALSE;
- ScmObj scm_step = SCM_FALSE;
- ScmObj head = SCM_NULL;
- scm_int_t count = 0;
- scm_int_t start = 0;
- scm_int_t step = 0;
- scm_int_t i = 0;
- DECLARE_FUNCTION("iota", procedure_variadic_1);
-
- /* get params */
- if (!NULLP(args))
- scm_start = CAR(args);
-
- if (!FALSEP(scm_start) && !NULLP(CDR(args)))
- scm_step = CAR(CDR(args));
-
- /* param type check */
- ENSURE_INT(scm_count);
- if (!FALSEP(scm_start))
- ENSURE_INT(scm_start);
- if (!FALSEP(scm_step))
- ENSURE_INT(scm_step);
-
- /* now create list */
- count = SCM_INT_VALUE(scm_count);
- start = FALSEP(scm_start) ? 0 : SCM_INT_VALUE(scm_start);
- step = FALSEP(scm_step) ? 1 : SCM_INT_VALUE(scm_step);
-
- for (i = count - 1; 0 <= i; i--) {
- head = CONS(MAKE_INT(start + i * step), head);
- }
-
- return head;
-}
-
-/*===========================================================================
- SRFI1 : The procedures : Predicates
-===========================================================================*/
-ScmObj
-scm_p_srfi1_proper_listp(ScmObj obj)
-{
- DECLARE_FUNCTION("proper-list?", procedure_fixed_1);
-
- return MAKE_BOOL(PROPER_LISTP(obj));
-}
-
-ScmObj
-scm_p_srfi1_circular_listp(ScmObj obj)
-{
- DECLARE_FUNCTION("circular-list?", procedure_fixed_1);
-
- return MAKE_BOOL(CIRCULAR_LISTP(obj));
-}
-
-ScmObj
-scm_p_srfi1_dotted_listp(ScmObj obj)
-{
- DECLARE_FUNCTION("dotted-list?", procedure_fixed_1);
-
- return MAKE_BOOL(DOTTED_LISTP(obj));
-}
-
-ScmObj
-scm_p_srfi1_not_pairp(ScmObj obj)
-{
- DECLARE_FUNCTION("not-pair?", procedure_fixed_1);
-
- return MAKE_BOOL(!CONSP(obj));
-}
-
-ScmObj
-scm_p_srfi1_null_listp(ScmObj lst)
-{
- scm_int_t len;
- DECLARE_FUNCTION("null-list?", procedure_fixed_1);
-
- len = scm_length(lst);
- if (!SCM_LISTLEN_PROPERP(len) && !SCM_LISTLEN_CIRCULARP(len))
- ERR_OBJ("proper or circular list required but got", lst);
-
- return MAKE_BOOL(NULLP(lst));
-}
-
-ScmObj
-scm_p_srfi1_listequal(ScmObj eqproc, ScmObj args)
-{
- ScmObj first_lst = SCM_FALSE;
- DECLARE_FUNCTION("list=", procedure_variadic_1);
-
- if (NULLP(args))
- return SCM_TRUE;
-
- first_lst = CAR(args);
- args = CDR(args);
-
- if (NULLP(args))
- return SCM_TRUE;
-
- for (; !NULLP(args); args = CDR(args)) {
- if (FALSEP(compare_list(eqproc, first_lst, CAR(args))))
- return SCM_FALSE;
- }
-
- return SCM_TRUE;
-}
-
-static ScmObj
-compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2)
-{
-#define CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, obj1, obj2) \
- (scm_call(eqproc, \
- LIST_2(obj1, obj2)))
-
- ScmObj ret_cmp = SCM_FALSE;
-
- for (; !NULLP(lst1); lst1 = CDR(lst1), lst2 = CDR(lst2)) {
- /* check contents */
- ret_cmp = CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CAR(lst1), CAR(lst2));
- if (FALSEP(ret_cmp))
- return SCM_FALSE;
-
- /* check next cdr's type */
- if (SCM_TYPE(CDR(lst1)) != SCM_TYPE(CDR(lst2)))
- return SCM_FALSE;
-
- /* check dot pair */
- if (!CONSP(CDR(lst1))) {
- return CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CDR(lst1), CDR(lst2));
- }
- }
- return SCM_TRUE;
-}
-
-ScmObj
-scm_p_srfi1_first(ScmObj lst)
-{
- DECLARE_FUNCTION("first", procedure_fixed_1);
- return scm_p_car(lst);
-}
-
-ScmObj
-scm_p_srfi1_second(ScmObj lst)
-{
- DECLARE_FUNCTION("second", procedure_fixed_1);
- return scm_p_cadr(lst);
-}
-
-ScmObj
-scm_p_srfi1_third(ScmObj lst)
-{
- DECLARE_FUNCTION("third", procedure_fixed_1);
- return scm_p_caddr(lst);
-}
-
-ScmObj
-scm_p_srfi1_fourth(ScmObj lst)
-{
- DECLARE_FUNCTION("fourth", procedure_fixed_1);
- return scm_p_cadddr(lst);
-}
-
-ScmObj
-scm_p_srfi1_fifth(ScmObj lst)
-{
- DECLARE_FUNCTION("fifth", procedure_fixed_1);
- return scm_p_car(scm_p_cddddr(lst));
-}
-
-ScmObj
-scm_p_srfi1_sixth(ScmObj lst)
-{
- DECLARE_FUNCTION("sixth", procedure_fixed_1);
- return scm_p_cadr(scm_p_cddddr(lst));
-}
-
-ScmObj
-scm_p_srfi1_seventh(ScmObj lst)
-{
- DECLARE_FUNCTION("seventh", procedure_fixed_1);
- return scm_p_caddr(scm_p_cddddr(lst));
-}
-
-ScmObj
-scm_p_srfi1_eighth(ScmObj lst)
-{
- DECLARE_FUNCTION("eighth", procedure_fixed_1);
- return scm_p_cadddr(scm_p_cddddr(lst));
-}
-
-ScmObj
-scm_p_srfi1_ninth(ScmObj lst)
-{
- DECLARE_FUNCTION("ninth", procedure_fixed_1);
- return scm_p_car(scm_p_cddddr(scm_p_cddddr(lst)));
-}
-
-ScmObj
-scm_p_srfi1_tenth(ScmObj lst)
-{
- DECLARE_FUNCTION("tenth", procedure_fixed_1);
- return scm_p_cadr(scm_p_cddddr(scm_p_cddddr(lst)));
-}
-
-ScmObj
-scm_p_srfi1_carpluscdr(ScmObj lst)
-{
- DECLARE_FUNCTION("car+cdr", procedure_fixed_1);
- return scm_p_values(LIST_2(CAR(lst), CDR(lst)));
-}
-
-ScmObj
-scm_p_srfi1_take(ScmObj lst, ScmObj scm_idx)
-{
- ScmObj tmp = lst;
- ScmObj ret = SCM_FALSE;
- ScmObj ret_tail = SCM_FALSE;
- scm_int_t idx = 0;
- scm_int_t i;
- DECLARE_FUNCTION("take", procedure_fixed_2);
-
- ENSURE_INT(scm_idx);
-
- idx = SCM_INT_VALUE(scm_idx);
- for (i = 0; i < idx; i++) {
- if (SCM_NULLP(tmp))
- ERR_OBJ("illegal index is specified for", lst);
-
- if (i != 0) {
- SET_CDR(ret_tail, CONS(CAR(tmp), SCM_NULL));
- ret_tail = CDR(ret_tail);
- } else {
- ret = CONS(CAR(tmp), SCM_NULL);
- ret_tail = ret;
- }
-
- tmp = CDR(tmp);
- }
-
- return ret;
-}
-
-ScmObj
-scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx)
-{
- ScmObj ret = lst;
- scm_int_t idx = 0;
- scm_int_t i;
- DECLARE_FUNCTION("drop", procedure_fixed_2);
-
- ENSURE_INT(scm_idx);
-
- idx = SCM_INT_VALUE(scm_idx);
- for (i = 0; i < idx; i++) {
- if (!CONSP(ret))
- ERR_OBJ("illegal index is specified for", lst);
-
- ret = CDR(ret);
- }
-
- return ret;
-}
-
-ScmObj
-scm_p_srfi1_take_right(ScmObj lst, ScmObj scm_elem)
-{
- ScmObj tmp = lst;
- scm_int_t len = 0;
- DECLARE_FUNCTION("take-right", procedure_fixed_2);
-
- ENSURE_INT(scm_elem);
-
- for (; CONSP(tmp); tmp = CDR(tmp))
- len++;
-
- len -= SCM_INT_VALUE(scm_elem);
-
- return scm_p_srfi1_drop(lst, MAKE_INT(len));
-}
-
-ScmObj
-scm_p_srfi1_drop_right(ScmObj lst, ScmObj scm_elem)
-{
- ScmObj tmp = lst;
- scm_int_t len = 0;
- DECLARE_FUNCTION("drop-right", procedure_fixed_2);
-
- ENSURE_INT(scm_elem);
-
- for (; CONSP(tmp); tmp = CDR(tmp))
- len++;
-
- len -= SCM_INT_VALUE(scm_elem);
-
- return scm_p_srfi1_take(lst, MAKE_INT(len));
-}
-
-ScmObj
-scm_p_srfi1_taked(ScmObj lst, ScmObj scm_idx)
-{
- ScmObj tmp = lst;
- scm_int_t idx = 0;
- scm_int_t i;
- DECLARE_FUNCTION("take!", procedure_fixed_2);
-
- ENSURE_INT(scm_idx);
-
- idx = SCM_INT_VALUE(scm_idx);
-
- for (i = 0; i < idx - 1; i++) {
- tmp = CDR(tmp);
- }
-
- ENSURE_MUTABLE_CONS(tmp);
- SET_CDR(tmp, SCM_NULL);
-
- return lst;
-}
-
-ScmObj
-scm_p_srfi1_drop_rightd(ScmObj lst, ScmObj scm_idx)
-{
- ScmObj tmp = lst;
- scm_int_t len = 0;
- scm_int_t i;
- DECLARE_FUNCTION("drop-right!", procedure_fixed_2);
-
- ENSURE_INT(scm_idx);
-
- for (; CONSP(tmp); tmp = CDR(tmp))
- len++;
-
- len -= SCM_INT_VALUE(scm_idx);
-
- tmp = lst;
- for (i = 0; i < len - 1; i++) {
- tmp = CDR(tmp);
- }
-
- ENSURE_MUTABLE_CONS(tmp);
- SET_CDR(tmp, SCM_NULL);
-
- return lst;
-}
-
-ScmObj
-scm_p_srfi1_split_at(ScmObj lst, ScmObj idx)
-{
- DECLARE_FUNCTION("split-at", procedure_fixed_2);
-
- return scm_p_values(LIST_2(scm_p_srfi1_take(lst, idx),
- scm_p_srfi1_drop(lst, idx)));
-}
-
-ScmObj
-scm_p_srfi1_split_atd(ScmObj lst, ScmObj idx)
-{
- ScmObj drop = scm_p_srfi1_drop(lst, idx);
- DECLARE_FUNCTION("split-at!", procedure_fixed_2);
-
- return scm_p_values(LIST_2(scm_p_srfi1_taked(lst, idx),
- drop));
-}
-
-ScmObj
-scm_p_srfi1_last(ScmObj lst)
-{
- DECLARE_FUNCTION("last", procedure_fixed_1);
-
- /* sanity check */
- if (NULLP(lst))
- ERR_OBJ("non-empty, proper list is required but got", lst);
-
- return CAR(scm_p_srfi1_last_pair(lst));
-}
-
-ScmObj
-scm_p_srfi1_last_pair(ScmObj lst)
-{
- DECLARE_FUNCTION("last-pair", procedure_fixed_1);
-
- /* sanity check */
- if (NULLP(lst))
- ERR_OBJ("non-empty, proper list is required but got", lst);
-
- for (; CONSP(CDR(lst)); lst = CDR(lst))
- ;
-
- return lst;
-}
-
-/*===========================================================================
- SRFI1 : The procedures : Miscellaneous
-===========================================================================*/
-ScmObj
-scm_p_srfi1_lengthplus(ScmObj lst)
-{
- scm_int_t len;
- DECLARE_FUNCTION("length+", procedure_fixed_1);
-
- len = scm_length(lst);
- /* although SRFI-1 does not specify the behavior for dotted list
- * explicitly, the description indicates that dotted list is treated as
- * same as R5RS 'length' procedure. So produce an error here. */
- if (SCM_LISTLEN_DOTTEDP(len))
- ERR_OBJ("proper or circular list required but got", lst);
-
- return (SCM_LISTLEN_PROPERP(len)) ? MAKE_INT(len) : SCM_FALSE;
-}
-
-ScmObj
-scm_p_srfi1_concatenate(ScmObj args)
-{
- ScmObj lsts_of_lst = CAR(args);
- DECLARE_FUNCTION("concatenate", procedure_variadic_0);
-
-#if SCM_STRICT_ARGCHECK
- if (!NULLP(CDR(args)))
- ERR_OBJ("superfluous arguments", args);
-#endif
-
- return scm_p_append(lsts_of_lst);
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi2.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi2.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi2.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,131 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi2.c
- * About : SRFI-2 AND-LET*: an AND with local bindings, a guarded LET*
- * special form
- *
- * 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.
-===========================================================================*/
-
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi2(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi2_func_info_table);
-}
-
-ScmObj
-scm_s_srfi2_and_letstar(ScmObj claws, ScmObj body, ScmEvalState *eval_state)
-{
- ScmObj env, claw, var, val, exp;
- DECLARE_FUNCTION("and-let*", syntax_variadic_tailrec_1);
-
- env = eval_state->env;
-
- /*=======================================================================
- (and-let* <claws> <body>)
-
- <claws> ::= '() | (cons <claw> <claws>)
- <claw> ::= (<variable> <expression>) | (<expression>)
- | <bound-variable>
- =======================================================================*/
- if (CONSP(claws)) {
- FOR_EACH (claw, claws) {
- if (CONSP(claw)) {
- if (NULLP(CDR(claw))) {
- /* (<expression>) */
- exp = CAR(claw);
- val = EVAL(exp, env);
- } else if (SYMBOLP(CAR(claw))) {
- /* (<variable> <expression>) */
- if (!LIST_2_P(claw))
- goto err;
- var = CAR(claw);
- exp = CADR(claw);
- val = EVAL(exp, env);
- env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
- } else {
- goto err;
- }
- } else if (SYMBOLP(claw)) {
- /* <bound-variable> */
- val = EVAL(claw, env);
- } else {
- goto err;
- }
- if (FALSEP(val)) {
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
- return SCM_FALSE;
- }
- }
- if (!NULLP(claws))
- goto err;
- } else if (NULLP(claws)) {
- env = scm_extend_environment(SCM_NULL, SCM_NULL, env);
- } else {
- goto err;
- }
-
- eval_state->env = env;
-
- return scm_s_body(body, eval_state);
-
- err:
- ERR_OBJ("invalid claws form", claws);
- /* NOTREACHED */
- return SCM_FALSE;
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi23.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi23.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi23.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,103 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi23.c
- * About : SRFI-23 Error reporting mechanism
- *
- * 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.
-===========================================================================*/
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi23(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi23_func_info_table);
-}
-
-/*===========================================================================
- SRFI23 : Error reporting mechanism
-===========================================================================*/
-/*
- * This code implements the '4.' of following Specification defined in SRFI-34.
- *
- * 1. Display <reason> and <arg1>... on the screen and terminate the Scheme
- * program. (This might be suitable for a Scheme system implemented as a
- * batch compiler.)
- * 2. Display <reason> and <arg1>... on the screen and go back to the
- * read-evaluate-print loop. (This might be suitable for an interactive
- * implementation).
- * 4. Package <reason> and <arg1>... up into an error object and pass this
- * error object to an exception handler. The default exception handler then
- * might do something as described in points 1 to 3.
- */
-ScmObj
-scm_p_srfi23_error(ScmObj reason, ScmObj args)
-{
- ScmObj err_obj;
- DECLARE_FUNCTION("error", procedure_variadic_1);
-
-#if 0
- /*
- * Although SRFI-23 specified that "The argument <reason> should be a
- * string", we should not force it. Displayable is sufficient.
- */
- ENSURE_STRING(reason);
-#endif
-
- err_obj = scm_make_error_obj(reason, args);
- scm_raise_error(err_obj);
- /* NOTREACHED */
- return SCM_UNDEF;
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi34.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi34.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,398 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi34.c
- * About : SRFI-34 Exception Handling for Programs
- *
- * Copyright (C) 2005-2006 YamaKen <yamaken AT bp.iij4u.or.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.
-===========================================================================*/
-
-/*
- * This file implements C-version of the reference implementation written in
- * the SRFI-34 specification. All parts are written in C since:
- *
- * - SigScheme doesn't have a hygienic-macros feature (yet)
- *
- * - To avoid namespace pollution (with-exception-handlers, guard-aux, etc),
- * since SigScheme doesn't have a module or namespace feature (yet)
- */
-
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Macro Definitions
-=======================================*/
-#define USE_WITH_SIGSCHEME_FATAL_ERROR 1
-
-#define ERRMSG_UNHANDLED_EXCEPTION "unhandled exception"
-#define ERRMSG_HANDLER_RETURNED "handler returned"
-#define ERRMSG_FALLBACK_EXHAUSTED "fallback handler exhausted"
-
-#define DECLARE_PRIVATE_FUNCTION(func_name, type) \
- DECLARE_INTERNAL_FUNCTION(func_name)
-
-/*=======================================
- File Local Type Definitions
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-static ScmObj current_exception_handlers;
-
-/* error messages */
-static ScmObj errmsg_unhandled_exception, errmsg_handler_returned;
-static ScmObj errmsg_fallback_exhausted;
-
-/* symbols */
-static ScmObj sym_error, sym_raise;
-static ScmObj sym_lex_env, sym_cond_catch, sym_body;
-static ScmObj sym_condition, sym_guard_k, sym_handler_k;
-
-/* procedures and syntaxes */
-static ScmObj syn_apply, proc_values;
-static ScmObj syn_set_cur_handlers, proc_fallback_handler;
-static ScmObj proc_with_exception_handlers;
-static ScmObj syn_guard_internal, syn_guard_handler, syn_guard_handler_body;
-static ScmObj syn_guard_body;
-
-static ScmObj *const global_var_list[] = {
- ¤t_exception_handlers,
- &errmsg_unhandled_exception, &errmsg_handler_returned,
- &errmsg_fallback_exhausted,
- &sym_error, &sym_raise,
- &sym_lex_env, &sym_cond_catch, &sym_body,
- &sym_condition, &sym_guard_k, &sym_handler_k,
- &syn_apply, &proc_values,
- &syn_set_cur_handlers, &proc_fallback_handler,
- &proc_with_exception_handlers,
- &syn_guard_internal, &syn_guard_handler, &syn_guard_handler_body,
- &syn_guard_body,
- NULL
-};
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-static ScmObj set_cur_handlers(ScmObj handlers, ScmObj env);
-static ScmObj with_exception_handlers(ScmObj new_handlers, ScmObj thunk);
-static ScmObj guard_internal(ScmObj q_guard_k, ScmObj env);
-static ScmObj guard_handler(ScmObj q_condition, ScmEvalState *eval_state);
-static ScmObj delay(ScmObj evaled_obj, ScmObj env);
-static ScmObj guard_handler_body(ScmObj q_handler_k, ScmObj env);
-static ScmObj guard_body(ScmEvalState *eval_state);
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi34(void)
-{
- ScmObj *const *var;
-
- scm_use("srfi-23");
-
- /* protect global variables */
- for (var = &global_var_list[0]; *var; var++)
- scm_gc_protect_with_init(*var, SCM_FALSE);
-
- errmsg_unhandled_exception = CONST_STRING(ERRMSG_UNHANDLED_EXCEPTION);
- errmsg_handler_returned = CONST_STRING(ERRMSG_HANDLER_RETURNED);
- errmsg_fallback_exhausted = CONST_STRING(ERRMSG_FALLBACK_EXHAUSTED);
-
- sym_error = scm_intern("error");
- sym_raise = scm_intern("raise");
-
- sym_lex_env = scm_intern("lex-env");
- sym_cond_catch = scm_intern("cond-catch");
- sym_body = scm_intern("body");
- sym_condition = scm_intern("condition");
- sym_guard_k = scm_intern("guard-k");
- sym_handler_k = scm_intern("handler-k");
-
- /* prepare procedures and syntaxes */
- syn_apply = scm_symbol_value(scm_intern("apply"), SCM_INTERACTION_ENV);
- proc_values = scm_symbol_value(scm_intern("values"), SCM_INTERACTION_ENV);
- /* FIXME: make registration type-safe */
- syn_set_cur_handlers
- = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &set_cur_handlers);
- proc_with_exception_handlers
- = MAKE_FUNC(SCM_PROCEDURE_FIXED | 2, &with_exception_handlers);
- syn_guard_internal
- = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &guard_internal);
- syn_guard_handler
- = MAKE_FUNC(SCM_SYNTAX_FIXED_TAIL_REC | 1, &guard_handler);
- syn_guard_handler_body
- = MAKE_FUNC(SCM_SYNTAX_FIXED | 1, &guard_handler_body);
- syn_guard_body
- = MAKE_FUNC(SCM_SYNTAX_FIXED_TAIL_REC | 0, &guard_body);
-
-#if USE_WITH_SIGSCHEME_FATAL_ERROR
- proc_fallback_handler
- = scm_s_lambda(LIST_1(sym_condition),
- LIST_1(LIST_4(scm_intern("if"),
- LIST_2(scm_intern("%%error-object?"),
- sym_condition),
- LIST_2(scm_intern("%%fatal-error"),
- sym_condition),
- LIST_3(sym_error,
- errmsg_unhandled_exception,
- sym_condition))),
- SCM_INTERACTION_ENV);
-#else /* USE_WITH_SIGSCHEME_FATAL_ERROR */
- /*
- * The 'error' procedure should not be invoked directly by
- * scm_p_srfi23_error(), to allow dynamic redifinition, and keep SRFI-23
- * implementation abstract.
- */
- proc_fallback_handler
- = scm_s_lambda(LIST_1(sym_condition),
- LIST_1(LIST_3(sym_error,
- errmsg_unhandled_exception,
- sym_condition)),
- SCM_INTERACTION_ENV);
-#endif /* USE_WITH_SIGSCHEME_FATAL_ERROR */
-
- SCM_REGISTER_FUNC_TABLE(scm_srfi34_func_info_table);
-
- current_exception_handlers = LIST_1(proc_fallback_handler);
-}
-
-static ScmObj
-set_cur_handlers(ScmObj handlers, ScmObj env)
-{
- DECLARE_PRIVATE_FUNCTION("with_exception_handlers", syntax_fixed_1);
-
- current_exception_handlers = handlers;
- return SCM_UNDEF;
-}
-
-static ScmObj
-with_exception_handlers(ScmObj new_handlers, ScmObj thunk)
-{
- ScmObj prev_handlers, before, after;
- DECLARE_PRIVATE_FUNCTION("with_exception_handlers", procedure_fixed_2);
-
- prev_handlers = current_exception_handlers;
- before = scm_s_lambda(SCM_NULL,
- LIST_1(LIST_2(syn_set_cur_handlers, new_handlers)),
- SCM_INTERACTION_ENV);
- after = scm_s_lambda(SCM_NULL,
- LIST_1(LIST_2(syn_set_cur_handlers, prev_handlers)),
- SCM_INTERACTION_ENV);
- return scm_dynamic_wind(before, thunk, after);
-}
-
-/* with-exception-handler */
-
-ScmObj
-scm_p_srfi34_with_exception_handler(ScmObj handler, ScmObj thunk)
-{
- ScmObj handlers;
- DECLARE_FUNCTION("with-exception-handler", procedure_fixed_2);
-
- ENSURE_PROCEDURE(handler);
- ENSURE_PROCEDURE(thunk);
-
- handlers = CONS(handler, current_exception_handlers);
- return with_exception_handlers(handlers, thunk);
-}
-
-/* raise */
-
-ScmObj
-scm_p_srfi34_raise(ScmObj obj)
-{
- ScmObj handler, rest_handlers, thunk, err_obj;
- DECLARE_FUNCTION("raise", procedure_fixed_1);
-
- if (NULLP(current_exception_handlers)) {
- if (ERROBJP(obj))
- err_obj = obj;
- else
- err_obj
- = scm_make_error_obj(errmsg_fallback_exhausted, LIST_1(obj));
- scm_p_fatal_error(err_obj);
- /* NOTREACHED */
- }
-
- handler = CAR(current_exception_handlers);
- rest_handlers = CDR(current_exception_handlers);
- obj = LIST_2(SYM_QUOTE, obj);
- thunk = scm_s_lambda(SCM_NULL,
- LIST_2(LIST_2(handler, obj),
- LIST_3(sym_error,
- errmsg_handler_returned, obj)),
- SCM_INTERACTION_ENV);
- return with_exception_handlers(rest_handlers, thunk);
-}
-
-/* guard */
-
-ScmObj
-scm_s_srfi34_guard(ScmObj cond_catch, ScmObj body, ScmEvalState *eval_state)
-{
- ScmObj lex_env, proc_guard_int, ret;
- DECLARE_FUNCTION("guard", syntax_variadic_tailrec_1);
-
- ENSURE_CONS(cond_catch);
- ENSURE_CONS(body);
-
- lex_env = eval_state->env;
- eval_state->env
- = scm_extend_environment(LIST_3(sym_lex_env, sym_cond_catch, sym_body),
- LIST_3(lex_env, cond_catch, body),
- lex_env);
- proc_guard_int = scm_s_lambda(LIST_1(sym_guard_k),
- LIST_1(LIST_2(syn_guard_internal, sym_guard_k)),
- eval_state->env);
-
- ret = scm_call_with_current_continuation(proc_guard_int, eval_state);
- eval_state->env = lex_env;
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
- return scm_call(ret, SCM_NULL);
-}
-
-static ScmObj
-guard_internal(ScmObj q_guard_k, ScmObj env)
-{
- ScmObj handler, body;
- DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_1);
-
- handler = scm_s_lambda(LIST_1(sym_condition),
- LIST_1(LIST_2(syn_guard_handler, sym_condition)),
- env);
- body = scm_s_lambda(SCM_NULL,
- LIST_1(LIST_1(syn_guard_body)),
- env);
-
- return scm_p_srfi34_with_exception_handler(handler, body);
-}
-
-static ScmObj
-guard_handler(ScmObj q_condition, ScmEvalState *eval_state)
-{
- ScmObj handler_body, ret;
- DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_tailrec_1);
-
- handler_body
- = scm_s_lambda(LIST_1(sym_handler_k),
- LIST_1(LIST_2(syn_guard_handler_body, sym_handler_k)),
- eval_state->env);
- ret = scm_call_with_current_continuation(handler_body, eval_state);
- if (eval_state->ret_type == SCM_VALTYPE_NEED_EVAL) {
- ret = EVAL(ret, eval_state->env);
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
- }
- return scm_call(ret, SCM_NULL);
-}
-
-/* assumes that scm_s_delay() returns a closure */
-static ScmObj
-delay(ScmObj evaled_obj, ScmObj env)
-{
- ScmObj vals;
-
- if (VALUEPACKETP(evaled_obj)) {
- vals = SCM_VALUEPACKET_VALUES(evaled_obj);
- return scm_s_delay(LIST_3(syn_apply,
- proc_values, LIST_2(SYM_QUOTE, vals)),
- env);
- } else {
- return scm_s_delay(LIST_2(SYM_QUOTE, evaled_obj), env);
- }
-}
-
-/* assumes that scm_s_delay() returns a closure */
-static ScmObj
-guard_handler_body(ScmObj q_handler_k, ScmObj env)
-{
- ScmEvalState eval_state;
- ScmObj lex_env, cond_env, condition, cond_catch, guard_k, handler_k;
- ScmObj sym_var, clauses, caught, reraise;
- DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_1);
-
- lex_env = scm_symbol_value(sym_lex_env, env);
- condition = scm_symbol_value(sym_condition, env);
- cond_catch = scm_symbol_value(sym_cond_catch, env);
- guard_k = scm_symbol_value(sym_guard_k, env);
- handler_k = EVAL(q_handler_k, env);
-
- /* eval cond-catch block */
- sym_var = CAR(cond_catch);
- clauses = CDR(cond_catch);
- ENSURE_SYMBOL(sym_var);
- cond_env = scm_extend_environment(LIST_1(sym_var),
- LIST_1(condition),
- lex_env);
- SCM_EVAL_STATE_INIT1(eval_state, cond_env);
- caught = scm_s_cond_internal(clauses, SCM_INVALID, &eval_state);
-
- if (VALIDP(caught)) {
- if (eval_state.ret_type == SCM_VALTYPE_NEED_EVAL)
- caught = EVAL(caught, cond_env);
- scm_call_continuation(guard_k, delay(caught, cond_env));
- } else {
- reraise = scm_s_delay(LIST_2(sym_raise, LIST_2(SYM_QUOTE, condition)),
- cond_env);
- scm_call_continuation(handler_k, reraise);
- }
- /* NOTREACHED */
- return SCM_UNDEF;
-}
-
-static ScmObj
-guard_body(ScmEvalState *eval_state)
-{
- ScmEvalState lex_eval_state;
- ScmObj lex_env, guard_k, body, result;
- DECLARE_PRIVATE_FUNCTION("guard", syntax_fixed_tailrec_0);
-
- lex_env = scm_symbol_value(sym_lex_env, eval_state->env);
- guard_k = scm_symbol_value(sym_guard_k, eval_state->env);
- body = scm_symbol_value(sym_body, eval_state->env);
-
- /* evaluate the body */
- SCM_EVAL_STATE_INIT1(lex_eval_state, lex_env);
- result = scm_s_body(body, &lex_eval_state);
- if (lex_eval_state.ret_type == SCM_VALTYPE_NEED_EVAL)
- result = EVAL(result, lex_env);
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
-
- scm_call_continuation(guard_k, delay(result, lex_env));
- /* NOTREACHED */
- return SCM_UNDEF;
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi38.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi38.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi38.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,85 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi38.c
- * About : srfi38 shared structure I/O (currently only write/ss)
- *
- * Copyright (C) 2005-2006 Jun Inoue
- *
- * 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.
-===========================================================================*/
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi38(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi38_func_info_table);
-
- /* SRFI-38 allows providing (read/ss) and (write/ss) */
- scm_define_alias("write/ss", "write-with-shared-structure");
-
- scm_writess_func = scm_write_to_port_with_shared_structure;
-}
-
-/*===========================================================================
- SRFI38 : External Representation for Data With Shared Structure
-===========================================================================*/
-ScmObj
-scm_p_srfi38_write_with_shared_structure(ScmObj obj, ScmObj args)
-{
- ScmObj port;
- DECLARE_FUNCTION("write-with-shared-structure", procedure_variadic_1);
-
- port = scm_prepare_port(args, scm_out);
- scm_write_to_port_with_shared_structure(port, obj);
- return SCM_UNDEF;
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi6.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi6.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi6.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,144 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi6.c
- * About : Basic String Ports
- *
- * 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.
-===========================================================================*/
-
-/*=======================================
- System Include
-=======================================*/
-#include <stdlib.h>
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-#include "baseport.h"
-#include "strport.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-static void istrport_finalize(char **str, scm_bool ownership, void **opaque);
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi6(void)
-{
- scm_strport_init();
-
- SCM_REGISTER_FUNC_TABLE(scm_srfi6_func_info_table);
-}
-
-static void
-istrport_finalize(char **str, scm_bool ownership, void **opaque)
-{
- scm_gc_unprotect((ScmObj *)opaque);
-}
-
-ScmObj
-scm_p_srfi6_open_input_string(ScmObj str)
-{
- ScmObj *hold_str;
- ScmBytePort *bport;
- ScmCharPort *cport;
- DECLARE_FUNCTION("open-input-string", procedure_fixed_1);
-
- ENSURE_STRING(str);
-
- bport = ScmInputStrPort_new_const(SCM_STRING_STR(str), istrport_finalize);
- hold_str = (ScmObj *)ScmInputStrPort_ref_opaque(bport);
- scm_gc_protect_with_init(hold_str, str);
- cport = scm_make_char_port(bport);
- return MAKE_PORT(cport, SCM_PORTFLAG_INPUT);
-}
-
-ScmObj
-scm_p_srfi6_open_output_string(void)
-{
- ScmBytePort *bport;
- ScmCharPort *cport;
- DECLARE_FUNCTION("open-output-string", procedure_fixed_0);
-
- bport = ScmOutputStrPort_new(NULL);
- cport = scm_make_char_port(bport);
- return MAKE_PORT(cport, SCM_PORTFLAG_OUTPUT);
-}
-
-ScmObj
-scm_p_srfi6_get_output_string(ScmObj port)
-{
- ScmBaseCharPort *cport;
- const char *str;
- char *new_str;
- scm_int_t mb_len;
-#if SCM_USE_NULL_CAPABLE_STRING
- size_t size;
-#endif
- DECLARE_FUNCTION("get-output-string", procedure_fixed_1);
-
- ENSURE_PORT(port);
-
- SCM_ENSURE_LIVE_PORT(port);
- cport = SCM_CHARPORT_DYNAMIC_CAST(ScmBaseCharPort, SCM_PORT_IMPL(port));
-
- str = ScmOutputStrPort_str(cport->bport);
- /* FIXME: incorrect length for null-capable string */
- mb_len = scm_mb_bare_c_strlen(scm_port_codec(port), str);
-#if SCM_USE_NULL_CAPABLE_STRING
- size = ScmOutputStrPort_c_strlen(cport->bport) + sizeof("");
- new_str = scm_malloc(size);
- memcpy(new_str, str, size);
-#else
- new_str = scm_strdup(str);
-#endif
-
- return MAKE_STRING(new_str, mb_len);
-}
-
-
-/* FIXME: link conditionally with autoconf */
-#include "strport.c"
Deleted: branches/r5rs/sigscheme/src/operations-srfi60.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi60.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi60.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,158 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi60.c
- * About : SRFI-60 Integers as Bits
- *
- * Copyright (C) 2005-2006 YamaKen
- *
- * 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.
-===========================================================================*/
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-#define BITWISE_OPERATION_BODY(op, left, right) \
- do { \
- scm_int_t result; \
- \
- result = 0; \
- switch (*state) { \
- case SCM_REDUCE_0: \
- break; \
- case SCM_REDUCE_1: \
- ENSURE_INT(right); \
- return right; \
- case SCM_REDUCE_PARTWAY: \
- case SCM_REDUCE_LAST: \
- ENSURE_INT(left); \
- ENSURE_INT(right); \
- result = (SCM_INT_VALUE(left) op SCM_INT_VALUE(right)); \
- break; \
- default: \
- SCM_ASSERT(scm_false); \
- } \
- return MAKE_INT(result); \
- } while (/* CONSTCOND */ 0)
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi60(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi60_func_info_table);
-
- scm_define_alias("bitwise-and", "logand");
- scm_define_alias("bitwise-ior", "logior");
- scm_define_alias("bitwise-xor", "logxor");
- scm_define_alias("bitwise-not", "lognot");
- scm_define_alias("bitwise-merge", "bitwise-if");
- scm_define_alias("any-bits-set?", "logtest");
-}
-
-/* Bitwise Operations */
-ScmObj
-scm_p_srfi60_logand(ScmObj left, ScmObj right, enum ScmReductionState *state)
-{
- DECLARE_FUNCTION("logand", reduction_operator);
-
- BITWISE_OPERATION_BODY(&, left, right);
-}
-
-ScmObj
-scm_p_srfi60_logior(ScmObj left, ScmObj right, enum ScmReductionState *state)
-{
- DECLARE_FUNCTION("logior", reduction_operator);
-
- BITWISE_OPERATION_BODY(|, left, right);
-}
-
-ScmObj
-scm_p_srfi60_logxor(ScmObj left, ScmObj right, enum ScmReductionState *state)
-{
- DECLARE_FUNCTION("logxor", reduction_operator);
-
- BITWISE_OPERATION_BODY(^, left, right);
-}
-
-ScmObj
-scm_p_srfi60_lognot(ScmObj n)
-{
- DECLARE_FUNCTION("lognot", procedure_fixed_1);
-
- ENSURE_INT(n);
-
- return MAKE_INT(~SCM_INT_VALUE(n));
-}
-
-ScmObj
-scm_p_srfi60_bitwise_if(ScmObj mask, ScmObj n0, ScmObj n1)
-{
- scm_int_t result, c_mask;
- DECLARE_FUNCTION("bitwise-if", procedure_fixed_3);
-
- ENSURE_INT(mask);
- ENSURE_INT(n0);
- ENSURE_INT(n1);
-
- c_mask = SCM_INT_VALUE(mask);
- result = (c_mask & SCM_INT_VALUE(n0)) | (~c_mask & SCM_INT_VALUE(n1));
-
- return MAKE_INT(result);
-}
-
-ScmObj
-scm_p_srfi60_logtest(ScmObj j, ScmObj k)
-{
- DECLARE_FUNCTION("logtest", procedure_fixed_2);
-
- ENSURE_INT(j);
- ENSURE_INT(k);
-
- return MAKE_BOOL(SCM_INT_VALUE(j) & SCM_INT_VALUE(k));
-}
Deleted: branches/r5rs/sigscheme/src/operations-srfi8.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi8.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/operations-srfi8.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1,112 +0,0 @@
-/*===========================================================================
- * FileName : operations-srfi8.c
- * About : SRFI-8 receive: Binding to multiple values
- *
- * Copyright (C) 2005-2006 Jun Inoue
- *
- * 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.
-===========================================================================*/
-/*=======================================
- System Include
-=======================================*/
-
-/*=======================================
- Local Include
-=======================================*/
-#include "sigscheme.h"
-#include "sigschemeinternal.h"
-
-/*=======================================
- File Local Struct Declarations
-=======================================*/
-
-/*=======================================
- File Local Macro Declarations
-=======================================*/
-
-/*=======================================
- Variable Declarations
-=======================================*/
-
-/*=======================================
- File Local Function Declarations
-=======================================*/
-
-/*=======================================
- Function Implementations
-=======================================*/
-void
-scm_initialize_srfi8(void)
-{
- SCM_REGISTER_FUNC_TABLE(scm_srfi8_func_info_table);
-}
-
-ScmObj
-scm_s_srfi8_receive(ScmObj formals, ScmObj expr, ScmObj body,
- ScmEvalState *eval_state)
-{
- scm_int_t formals_len, actuals_len;
- ScmObj env, actuals;
- DECLARE_FUNCTION("receive", syntax_variadic_tailrec_2);
-
- env = eval_state->env;
-
- /*
- * (receive <formals> <expression> <body>)
- */
-
- formals_len = scm_validate_formals(formals);
- if (SCM_LISTLEN_ERRORP(formals_len))
- ERR_OBJ("bad formals", formals);
-
- /* FIXME: do we have to extend the environment first? The SRFI-8
- * document contradicts itself on this part. */
- /*
- * In my recognition, the description in SRFI-8 "The environment in which
- * the receive-expression is evaluated is extended by binding <variable1>,
- * ..." does not mean that the environment is extended for the evaluation
- * of the receive-expression. Probably it only specifies which environment
- * will be extended after the evaluation. So current implementation is
- * correct, I think. -- YamaKen 2006-01-05
- */
- actuals = EVAL(expr, env);
-
- if (SCM_VALUEPACKETP(actuals)) {
- actuals = SCM_VALUEPACKET_VALUES(actuals);
- actuals_len = scm_finite_length(actuals);
- } else {
- actuals = LIST_1(actuals);
- actuals_len = 1;
- }
-
- if (!scm_valid_environment_extension_lengthp(formals_len, actuals_len))
- ERR_OBJ("unmatched number of args for multiple values", actuals);
- eval_state->env = env = scm_extend_environment(formals, actuals, env);
-
- return scm_s_body(body, eval_state);
-}
Modified: branches/r5rs/sigscheme/src/procedure.c
===================================================================
--- branches/r5rs/sigscheme/src/procedure.c 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/procedure.c 2006-01-30 01:18:35 UTC (rev 3029)
@@ -33,7 +33,7 @@
===========================================================================*/
#include "config.h"
-/* FIXME: remove this for direct inclusion of operations-srfi6.c and
+/* FIXME: remove this for direct inclusion of module-srfi6.c and
* strport.c */
#include "config-asprintf.h"
@@ -406,35 +406,35 @@
}
#if SCM_USE_DEEP_CADRS
-#include "operations-r5rs-deepcadrs.c"
+#include "module-r5rs-deepcadrs.c"
#endif
#if SCM_USE_NONSTD_FEATURES
-#include "operations-nonstd.c"
+#include "module-nonstd.c"
#endif
#if SCM_USE_SRFI1
-#include "operations-srfi1.c"
+#include "module-srfi1.c"
#endif
#if SCM_USE_SRFI2
-#include "operations-srfi2.c"
+#include "module-srfi2.c"
#endif
#if SCM_USE_SRFI6
-#include "operations-srfi6.c"
+#include "module-srfi6.c"
#endif
#if SCM_USE_SRFI8
-#include "operations-srfi8.c"
+#include "module-srfi8.c"
#endif
#if SCM_USE_SRFI23
-#include "operations-srfi23.c"
+#include "module-srfi23.c"
#endif
#if SCM_USE_SRFI34
-#include "operations-srfi34.c"
+#include "module-srfi34.c"
#endif
#if SCM_USE_SRFI38
-#include "operations-srfi38.c"
+#include "module-srfi38.c"
#endif
#if SCM_USE_SRFI60
-#include "operations-srfi60.c"
+#include "module-srfi60.c"
#endif
#if SCM_COMPAT_SIOD
-#include "operations-siod.c"
+#include "module-siod.c"
#endif
Modified: branches/r5rs/sigscheme/src/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/src/sigscheme.h 2006-01-30 00:58:32 UTC (rev 3028)
+++ branches/r5rs/sigscheme/src/sigscheme.h 2006-01-30 01:18:35 UTC (rev 3029)
@@ -1294,7 +1294,7 @@
ScmObj scm_p_list2vector(ScmObj lst);
ScmObj scm_p_vector_filld(ScmObj vec, ScmObj fill);
-/* operations-r5rs-deepcadrs.c */
+/* module-r5rs-deepcadrs.c */
#if SCM_USE_DEEP_CADRS
ScmObj scm_p_caaar(ScmObj lst);
ScmObj scm_p_caadr(ScmObj lst);
@@ -1320,7 +1320,7 @@
ScmObj scm_p_cddddr(ScmObj lst);
#endif /* SCM_USE_DEEP_CADRS */
-/* operations-nonstd.c */
+/* module-nonstd.c */
#if SCM_USE_NONSTD_FEATURES
void scm_initialize_nonstd_features(void);
ScmObj scm_p_symbol_boundp(ScmObj sym, ScmObj rest);
@@ -1413,7 +1413,7 @@
SigScheme : Optional Funtions
===========================================================================*/
#if SCM_USE_SRFI1
-/* operations-srfi1.c */
+/* module-srfi1.c */
void scm_initialize_srfi1(void);
ScmObj scm_p_srfi1_xcons(ScmObj a, ScmObj b);
ScmObj scm_p_srfi1_consstar(ScmObj args);
@@ -1454,14 +1454,14 @@
#endif
#if SCM_USE_SRFI2
-/* operations-srfi2.c */
+/* module-srfi2.c */
void scm_initialize_srfi2(void);
ScmObj scm_s_srfi2_and_letstar(ScmObj claws, ScmObj body,
ScmEvalState *eval_state);
#endif
#if SCM_USE_SRFI6
-/* operations-srfi6.c */
+/* module-srfi6.c */
void scm_initialize_srfi6(void);
ScmObj scm_p_srfi6_open_input_string(ScmObj str);
ScmObj scm_p_srfi6_open_output_string(void);
@@ -1469,20 +1469,20 @@
#endif
#if SCM_USE_SRFI8
-/* operations-srfi8.c */
+/* module-srfi8.c */
void scm_initialize_srfi8(void);
ScmObj scm_s_srfi8_receive(ScmObj formals, ScmObj expr, ScmObj body,
ScmEvalState *eval_state);
#endif
#if SCM_USE_SRFI23
-/* operations-srfi23.c */
+/* module-srfi23.c */
void scm_initialize_srfi23(void);
ScmObj scm_p_srfi23_error(ScmObj reason, ScmObj args);
#endif
#if SCM_USE_SRFI34
-/* operations-srfi34.c */
+/* module-srfi34.c */
void scm_initialize_srfi34(void);
ScmObj scm_p_srfi34_with_exception_handler(ScmObj handler, ScmObj thunk);
ScmObj scm_s_srfi34_guard(ScmObj cond_catch, ScmObj body,
@@ -1491,13 +1491,13 @@
#endif
#if SCM_USE_SRFI38
-/* operations-srfi38.c */
+/* module-srfi38.c */
void scm_initialize_srfi38(void);
ScmObj scm_p_srfi38_write_with_shared_structure(ScmObj obj, ScmObj args);
#endif
#if SCM_USE_SRFI60
-/* operations-srfi60.c */
+/* module-srfi60.c */
void scm_initialize_srfi60(void);
ScmObj scm_p_srfi60_logand(ScmObj left, ScmObj right,
enum ScmReductionState *state);
@@ -1511,7 +1511,7 @@
#endif
#if SCM_COMPAT_SIOD
-/* operations-siod.c */
+/* module-siod.c */
void scm_initialize_siod(void);
ScmObj scm_p_symbol_value(ScmObj var);
ScmObj scm_p_set_symbol_valued(ScmObj var, ScmObj val);
More information about the uim-commit
mailing list