Author: yamakenz
Date: Thu Jun 14 14:08:01 2007
New Revision: 4592
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/src/module-sscm-ext.c
sigscheme-trunk/src/sigscheme.h
Log:
* src/sigscheme.h
- (scm_s_let_optionalsstar): New function decl
* src/module-sscm-ext.c
- (ERRMSG_INVALID_BINDINGS, ERRMSG_INVALID_BINDING): New macro
- (scm_s_let_optionalsstar): New function
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Thu Jun 14 14:08:01 2007
@@ -3,6 +3,9 @@
* New features
+ - New syntax let-optionals* compatible with Gauche for optional argument
+ processing
+
- New debugging procedures %pair-mutable?, %string-mutable?,
%vector-mutable?
Modified: sigscheme-trunk/src/module-sscm-ext.c
==============================================================================
--- sigscheme-trunk/src/module-sscm-ext.c (original)
+++ sigscheme-trunk/src/module-sscm-ext.c Thu Jun 14 14:08:01 2007
@@ -48,6 +48,8 @@
/*=======================================
File Local Macro Definitions
=======================================*/
+#define ERRMSG_INVALID_BINDINGS "invalid bindings form"
+#define ERRMSG_INVALID_BINDING "invalid binding form"
/*=======================================
File Local Type Definitions
@@ -330,4 +332,68 @@
scm_finalize();
exit(status);
+}
+
+/* Conforms to the specification and the behavior of Gauche 0.8.8.
+ * http://gauche.sourceforge.jp/doc/gauche-refe_82.html */
+SCM_EXPORT ScmObj
+scm_s_let_optionalsstar(ScmObj args, ScmObj bindings, ScmObj body,
+ ScmEvalState *eval_state)
+{
+ ScmObj env, var, val, exp, binding;
+ DECLARE_FUNCTION("let-optionals*", syntax_variadic_tailrec_2);
+
+ env = eval_state->env;
+
+ args = EVAL(args, env);
+ ENSURE_LIST(args);
+
+ /*=======================================================================
+ (let-optionals* <restargs> (<binding spec>*) <body>)
+ (let-optionals* <restargs> (<binding spec>+ . <restvar>) <body>)
+ (let-optionals* <restargs> <restvar> <body>) ;; Gauche 0.8.8
+
+ <binding spec> --> (<variable> <expression>)
+ | <variable>
+ <restvar> --> <variable>
+ <body> --> <definition>* <sequence>
+ <definition> --> (define <variable> <expression>)
+ | (define (<variable> <def formals>) <body>)
+ | (begin <definition>*)
+ <sequence> --> <command>* <expression>
+ <command> --> <expression>
+ =======================================================================*/
+
+ FOR_EACH (binding, bindings) {
+ if (LIST_2_P(binding)) {
+ var = CAR(binding);
+ exp = CADR(binding);
+ } else {
+ var = binding;
+ exp = SCM_UNDEF;
+ }
+ if (!IDENTIFIERP(var))
+ ERR_OBJ(ERRMSG_INVALID_BINDING, binding);
+
+ if (NULLP(args)) {
+ /* the second element is only evaluated when there are not enough
+ * arguments */
+ val = EVAL(exp, env);
+ CHECK_VALID_EVALED_VALUE(val);
+ } else {
+ val = POP(args);
+ }
+
+ /* extend env for each variable */
+ env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
+ }
+ if (IDENTIFIERP(bindings)) {
+ var = bindings;
+ env = scm_extend_environment(LIST_1(var), LIST_1(args), env);
+ } else if (!NULLP(bindings)) {
+ ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
+ }
+
+ eval_state->env = env;
+ return scm_s_body(body, eval_state);
}
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Thu Jun 14 14:08:01 2007
@@ -1653,6 +1653,9 @@
SCM_EXPORT ScmObj scm_p_providedp(ScmObj feature);
SCM_EXPORT ScmObj scm_p_lengthstar(ScmObj lst);
SCM_EXPORT ScmObj scm_p_exit(ScmObj args) SCM_NORETURN;
+SCM_EXPORT ScmObj scm_s_let_optionalsstar(ScmObj args,
+ ScmObj bindings, ScmObj body,
+ ScmEvalState *eval_state);
#endif /* SCM_USE_SSCM_EXTENSIONS */
/* module-siod.c */
