Author: yamakenz
Date: Sun Aug 19 10:39:49 2007
New Revision: 4867
Added:
sigscheme-trunk/src/legacy-macro.c
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/QALog
sigscheme-trunk/configure.in
sigscheme-trunk/sigscheme.pc.in
sigscheme-trunk/src/Makefile.am
sigscheme-trunk/src/eval.c
sigscheme-trunk/src/sigscheme.c
sigscheme-trunk/src/sigscheme.h
sigscheme-trunk/src/sigschemeinternal.h
sigscheme-trunk/src/write.c
Log:
* This commit add define-macro. Implementation is done and basically working,
but not well tested yet
* src/sigscheme.h
- (SCM_SYNTACTIC_OBJECTP): Add SCM_SYNTACTIC_CLOSUREP()
- (SCM_SYNTACTIC_CLOSURE_ENV, SCM_SYNTACTIC_CLOSUREP): New macro
- (scm_syntactic_closure_env): New variable decl
- (scm_s_define_macro): New function decl
* src/sigschemeinternal.h
- (SYNTACTIC_CLOSUREP): New macro
- (scm_init_legacy_macro): New function decl
* src/legacy-macro.c
- New file
- (scm_init_legacy_macro, scm_s_define_macro): New function
* src/eval.c
- (call): Add syntactic closure hack
* src/write.c
- (write_obj): Support #<syntactic closure ...>
* src/sigscheme.c
- (scm_initialize_internal): Add scm_init_legacy_macro()
* src/Makefile.am
- (FUNC_TABLES): Add functable-legacy-macro.c
- (libsscm_sources): Add legacy-macro.c
* configure.in
- Add --enable-legacy-macro and enable it by default
* sigscheme.pc.in
- Add sscm_legacy_macro variable
* QALog
- Add legacy-macro.c entry
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Sun Aug 19 10:39:49 2007
@@ -15,6 +15,9 @@
- R5RS promises (delay and force)
+ - legacy define-macro, expected to be compatible with other Scheme
+ implementations
+
- New syntax let-optionals* compatible with Gauche, for optional argument
processing
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Sun Aug 19 10:39:49 2007
@@ -185,6 +185,7 @@
- Optional Features (opt)
+ * legacy-macro.c
* module-sscm-ext.c
* module-siod.c
@@ -279,6 +280,7 @@
yyyy yyy srfi module-srfi48.c
yyyy yy srfi module-srfi55.c
yyyyyyyy srfi module-srfi60.c
+ opt legacy-macro.c
y yy y opt module-sscm-ext.c
y yy y opt module-siod.c
other main.c
@@ -1048,6 +1050,17 @@
coding style: [EMAIL PROTECTED]
normal case tests: [EMAIL PROTECTED]
corner case tests: [EMAIL PROTECTED]
+
+file: legacy-macro.c
+category: opt
+spec by eyes:
+spec by tests:
+general review:
+64-bit by eyes:
+64-bit by tests:
+coding style:
+normal case tests:
+corner case tests:
file: module-sscm-ext.c
category: opt
Modified: sigscheme-trunk/configure.in
==============================================================================
--- sigscheme-trunk/configure.in (original)
+++ sigscheme-trunk/configure.in Sun Aug 19 10:39:49 2007
@@ -525,6 +525,7 @@
# SigScheme-specific extensions
case "$enable_conf" in
full|r5rs|dev)
+ use_legacy_macro=yes
use_sscm_extensions=yes
use_sscm_format_extension=yes
use_compat_siod=no
@@ -532,6 +533,7 @@
use_eval_c_string=yes
;;
small)
+ use_legacy_macro=no
use_sscm_extensions=no
use_sscm_format_extension=no
use_compat_siod=no
@@ -539,6 +541,7 @@
use_eval_c_string=no
;;
siod)
+ use_legacy_macro=no
use_sscm_extensions=yes
use_sscm_format_extension=no
use_compat_siod=yes
@@ -546,6 +549,7 @@
use_eval_c_string=yes
;;
uim)
+ use_legacy_macro=yes
use_sscm_extensions=yes
use_sscm_format_extension=yes
use_compat_siod=yes
@@ -668,7 +672,7 @@
# Common Scheme features
AX_FEATURE_VAR_N(syntax-case, ['syntax-case' (not implemented yet)])
AX_FEATURE_VAR_N(unhygienic-macro, [syntactic closure (not implemented yet)])
-AX_FEATURE_VAR_N(legacy-macro, ['define-macro' (not implemented yet)])
+AX_FEATURE_ARG_Y(legacy-macro, ['define-macro' syntactic closure])
# SigScheme-specific features
AX_FEATURE_ARG_Y(sscm-extensions, [SigScheme-specific extensions])
@@ -965,6 +969,7 @@
AC_SUBST(use_srfi95)
AC_SUBST(use_r6rs_chars)
AC_SUBST(use_r6rs_named_chars)
+AC_SUBST(use_legacy_macro)
AC_SUBST(use_sscm_extensions)
AC_SUBST(use_sscm_format_extension)
AC_SUBST(use_compat_siod)
@@ -1126,6 +1131,7 @@
R6RS named chars: $use_r6rs_named_chars
[SigScheme-specific extensions]
+define-macro: $use_legacy_macro
SigScheme extensions: $use_sscm_extensions
format+ procedure: $use_sscm_format_extension
SIOD compatibilities: $use_compat_siod
Modified: sigscheme-trunk/sigscheme.pc.in
==============================================================================
--- sigscheme-trunk/sigscheme.pc.in (original)
+++ sigscheme-trunk/sigscheme.pc.in Sun Aug 19 10:39:49 2007
@@ -50,6 +50,7 @@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
[EMAIL PROTECTED]@
Modified: sigscheme-trunk/src/Makefile.am
==============================================================================
--- sigscheme-trunk/src/Makefile.am (original)
+++ sigscheme-trunk/src/Makefile.am Sun Aug 19 10:39:49 2007
@@ -33,6 +33,7 @@
functable-r5rs-write.c \
functable-r5rs-load.c \
functable-r5rs-deep-cadrs.c \
+ functable-legacy-macro.c \
functable-sscm-ext.c \
functable-siod.c \
functable-srfi1.c \
@@ -90,6 +91,8 @@
functable-r5rs-deep-cadrs.c: deep-cadrs.c $(BUILD_FUNCTBL_DEPS)
$(BUILD_FUNCTBL_CMD) $@ "scm_functable_r5rs_deep_cadrs" $<
# Optional modules
+functable-legacy-macro.c: legacy-macro.c $(BUILD_FUNCTBL_DEPS)
+ $(BUILD_FUNCTBL_CMD) $@ "scm_functable_legacy_macro" $<
functable-sscm-ext.c: module-sscm-ext.c $(BUILD_FUNCTBL_DEPS)
$(BUILD_FUNCTBL_CMD) $@ "scm_functable_sscm_ext" $<
functable-siod.c: module-siod.c $(BUILD_FUNCTBL_DEPS)
@@ -261,10 +264,12 @@
if USE_QUASIQUOTE
libsscm_sources += qquote.c
endif
-# FIXME: support SCM_USE_SYNTAX_CASE, SCM_USE_UNHYGIENIC_MACRO and
-# SCM_USE_LEGACY_MACRO
+# FIXME: support SCM_USE_SYNTAX_CASE
if USE_HYGIENIC_MACRO
libsscm_sources += macro.c
+endif
+if USE_LEGACY_MACRO
+ libsscm_sources += legacy-macro.c
endif
if USE_PROMISE
libsscm_sources += promise.c
Modified: sigscheme-trunk/src/eval.c
==============================================================================
--- sigscheme-trunk/src/eval.c (original)
+++ sigscheme-trunk/src/eval.c Sun Aug 19 10:39:49 2007
@@ -250,8 +250,34 @@
proc = EVAL(proc, env);
while (!FUNCP(proc)) {
- if (CLOSUREP(proc))
- return call_closure(proc, args, eval_state, need_eval);
+ if (CLOSUREP(proc)) {
+#if SCM_USE_LEGACY_MACRO
+ if (SYNTACTIC_CLOSUREP(proc)) {
+ ScmObj ret;
+
+ if (!need_eval)
+ ERR_OBJ("can't apply/map a macro", proc);
+
+ ret = call_closure(proc, args, eval_state, SCM_VALTYPE_AS_IS);
+ /* eval the result into an as-is object */
+ ret = SCM_FINISH_TAILREC_CALL(ret, eval_state);
+ /* restore previous env */
+ eval_state->env = env;
+ /* eval returned object again as a syntactic form. */
+ eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
+#if SCM_STRICT_TOPLEVEL_DEFINITIONS
+ /* Workaround to allow toplevel definitions by the returned
+ * form. See scm_eval(). */
+ eval_state->nest = SCM_NEST_RETTYPE_BEGIN;
+#endif
+
+ return ret;
+ } else
+#endif /* SCM_USE_LEGACY_MACRO */
+ {
+ return call_closure(proc, args, eval_state, need_eval);
+ }
+ }
#if SCM_USE_HYGIENIC_MACRO
if (HMACROP(proc)) {
if (!need_eval)
Added: sigscheme-trunk/src/legacy-macro.c
==============================================================================
--- (empty file)
+++ sigscheme-trunk/src/legacy-macro.c Sun Aug 19 10:39:49 2007
@@ -0,0 +1,124 @@
+/*===========================================================================
+ * Filename : legacy-macro.c
+ * About : Legacy 'define-macro' syntax
+ *
+ * Copyright (c) 2007 SigScheme Project <uim-en AT googlegroups.com>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of authors nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+ * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+ * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+ * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+ * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+===========================================================================*/
+
+#include <config.h>
+
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Macro Definitions
+=======================================*/
+
+/*=======================================
+ File Local Type Definitions
+=======================================*/
+
+/*=======================================
+ Variable Definitions
+=======================================*/
+#include "functable-legacy-macro.c"
+
+SCM_DEFINE_EXPORTED_VARS(legacy_macro);
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Definitions
+=======================================*/
+SCM_EXPORT void
+scm_init_legacy_macro(void)
+{
+ ScmObj syn_closure_env;
+
+ SCM_GLOBAL_VARS_INIT(legacy_macro);
+
+ scm_register_funcs(scm_functable_legacy_macro);
+
+ /* dummy environment as syntactic closure marker */
+ syn_closure_env
+ = scm_extend_environment(LIST_1(scm_intern("define-macro")),
+ LIST_1(SCM_FALSE),
+ SCM_INTERACTION_ENV);
+ scm_gc_protect_with_init(&scm_syntactic_closure_env, syn_closure_env);
+}
+
+/* To test ScmNestState, scm_s_define() needs eval_state although this is not a
+ * tail-recursive syntax */
+SCM_EXPORT ScmObj
+scm_s_define_macro(ScmObj identifier, ScmObj rest, ScmEvalState *eval_state)
+{
+ ScmObj closure;
+ DECLARE_FUNCTION("define-macro", syntax_variadic_tailrec_1);
+
+ scm_s_define(identifier, rest, eval_state);
+
+ /*=======================================================================
+ (define-macro <identifier> <closure>)
+ =======================================================================*/
+ if (IDENTIFIERP(identifier)) {
+ }
+
+ /*=======================================================================
+ (define-macro (<identifier> . <formals>) <body>)
+
+ => (define-macro <identifier>
+ (lambda <formals> <body>))
+ =======================================================================*/
+ else if (CONSP(identifier)) {
+ identifier = CAR(identifier);
+ } else {
+ ERR_OBJ("bad define-macro form",
+ CONS(scm_intern("define-macro"), CONS(identifier, rest)));
+ }
+
+#if SCM_USE_HYGIENIC_MACRO
+ SCM_ASSERT(SYMBOLP(identifier) || SYMBOLP(SCM_FARSYMBOL_SYM(identifier)));
+#else
+ SCM_ASSERT(SYMBOLP(identifier));
+#endif
+ identifier = SCM_UNWRAP_KEYWORD(identifier);
+
+ closure = SCM_SYMBOL_VCELL(identifier);
+ ENSURE_CLOSURE(closure);
+ if (!scm_toplevel_environmentp(SCM_CLOSURE_ENV(closure)))
+ ERR_OBJ("syntactic closure must have toplevel environment");
+ /* destructively mark the closure as syntactic */
+ SCM_CLOSURE_SET_ENV(closure, SCM_SYNTACTIC_CLOSURE_ENV);
+
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+ return SCM_UNDEF;
+}
Modified: sigscheme-trunk/src/sigscheme.c
==============================================================================
--- sigscheme-trunk/src/sigscheme.c (original)
+++ sigscheme-trunk/src/sigscheme.c Sun Aug 19 10:39:49 2007
@@ -321,6 +321,9 @@
scm_define_alias("r5rs:member", "member");
scm_define_alias("r5rs:assoc", "assoc");
+#if SCM_USE_LEGACY_MACRO
+ scm_init_legacy_macro();
+#endif
#if SCM_USE_SSCM_EXTENSIONS
scm_require_module("sscm-ext");
#endif
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Sun Aug 19 10:39:49 2007
@@ -819,12 +819,25 @@
&& !(SCM_FUNC_TYPECODE(o) & SCM_FUNCTYPE_SYNTAX)) \
|| SCM_CLOSUREP(o) \
|| SCM_CONTINUATIONP(o))
-#if SCM_USE_HYGIENIC_MACRO
+
+#if (SCM_USE_HYGIENIC_MACRO && SCM_USE_LEGACY_MACRO)
+#define SCM_SYNTACTIC_OBJECTP(o) (SCM_SYNTAXP(o) || SCM_HMACROP(o) \
+ || SCM_SYNTACTIC_CLOSUREP(o))
+#elif SCM_USE_HYGIENIC_MACRO
#define SCM_SYNTACTIC_OBJECTP(o) (SCM_SYNTAXP(o) || SCM_HMACROP(o))
+#elif SCM_USE_LEGACY_MACRO
+#define SCM_SYNTACTIC_OBJECTP(o) (SCM_SYNTAXP(o) || SCM_SYNTACTIC_CLOSUREP(o))
#else
#define SCM_SYNTACTIC_OBJECTP(o) (SCM_SYNTAXP(o))
#endif
+#if SCM_USE_LEGACY_MACRO
+#define SCM_SYNTACTIC_CLOSURE_ENV scm_syntactic_closure_env
+#define SCM_SYNTACTIC_CLOSUREP(o) \
+ (SCM_CLOSUREP(o) \
+ && SCM_EQ(SCM_CLOSURE_ENV(o), SCM_SYNTACTIC_CLOSURE_ENV))
+#endif
+
#define SCM_CLOSUREP(o) SCM_SAL_CLOSUREP(o)
#define SCM_CLOSURE_EXP(o) SCM_SAL_CLOSURE_EXP(o)
#define SCM_CLOSURE_ENV(o) SCM_SAL_CLOSURE_ENV(o)
@@ -1235,6 +1248,18 @@
#define scm_sym_ellipsis SCM_GLOBAL_VAR(syntax, scm_sym_ellipsis)
SCM_DECLARE_EXPORTED_VARS(syntax);
+/* legacy-macro.c */
+#if SCM_USE_LEGACY_MACRO
+/* Don't use scm_syntactic_closure_env directly. Use SCM_SYNTACTIC_CLOSURE_ENV
+ * instead. */
+SCM_GLOBAL_VARS_BEGIN(legacy_macro);
+ScmObj scm_syntactic_closure_env;
+SCM_GLOBAL_VARS_END(legacy_macro);
+#define scm_syntactic_closure_env \
+ SCM_GLOBAL_VAR(legacy_macro, scm_syntactic_closure_env)
+SCM_DECLARE_EXPORTED_VARS(legacy_macro);
+#endif /* SCM_USE_LEGACY_MACRO */
+
/*=======================================
Function Declarations
=======================================*/
@@ -1651,6 +1676,12 @@
/*===========================================================================
SigScheme: Optional Funtions
===========================================================================*/
+/* legacy-macro.c */
+#if SCM_USE_LEGACY_MACRO
+SCM_EXPORT ScmObj scm_s_define_macro(ScmObj identifier, ScmObj rest,
+ ScmEvalState *eval_state);
+#endif /* SCM_USE_LEGACY_MACRO */
+
/* module-sscm-ext.c */
#if SCM_USE_SSCM_EXTENSIONS
SCM_EXPORT void scm_require(const char *filename);
Modified: sigscheme-trunk/src/sigschemeinternal.h
==============================================================================
--- sigscheme-trunk/src/sigschemeinternal.h (original)
+++ sigscheme-trunk/src/sigschemeinternal.h Sun Aug 19 10:39:49 2007
@@ -137,6 +137,7 @@
#define FUNCP SCM_FUNCP
#define SYNTAXP SCM_SYNTAXP
#define CLOSUREP SCM_CLOSUREP
+#define SYNTACTIC_CLOSUREP SCM_SYNTACTIC_CLOSUREP
#define PROCEDUREP SCM_PROCEDUREP
#define SYNTACTIC_OBJECTP SCM_SYNTACTIC_OBJECTP
#define VECTORP SCM_VECTORP
@@ -767,6 +768,11 @@
/* sigscheme.c */
SCM_EXPORT char **scm_interpret_argv(char **argv);
SCM_EXPORT void scm_free_argv(char **argv);
+
+/* legacy-macro.c */
+#if SCM_USE_LEGACY_MACRO
+SCM_EXPORT void scm_init_legacy_macro(void);
+#endif
/*
* modules
Modified: sigscheme-trunk/src/write.c
==============================================================================
--- sigscheme-trunk/src/write.c (original)
+++ sigscheme-trunk/src/write.c Sun Aug 19 10:39:49 2007
@@ -286,7 +286,12 @@
break;
#endif /* SCM_USE_HYGIENIC_MACRO */
case ScmClosure:
- scm_port_puts(port, "#<closure ");
+#if SCM_USE_LEGACY_MACRO
+ if (SYNTACTIC_CLOSUREP(obj))
+ scm_port_puts(port, "#<syntactic closure ");
+ else
+#endif
+ scm_port_puts(port, "#<closure ");
write_obj(port, SCM_CLOSURE_EXP(obj), otype);
scm_port_put_char(port, '>');
break;
