1 /*===========================================================================
2 * Filename : legacy-macro.c
3 * About : Legacy 'define-macro' syntax
4 *
5 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
6 *
7 * All rights reserved.
8 *
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
11 * are met:
12 *
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
15 * 2. Redistributions in binary form must reproduce the above copyright
16 * notice, this list of conditions and the following disclaimer in the
17 * documentation and/or other materials provided with the distribution.
18 * 3. Neither the name of authors nor the names of its contributors
19 * may be used to endorse or promote products derived from this software
20 * without specific prior written permission.
21 *
22 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
23 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
24 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
25 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
26 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
27 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
28 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
29 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
30 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
31 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
32 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33 ===========================================================================*/
34
35 #include <config.h>
36
37 #include "sigscheme.h"
38 #include "sigschemeinternal.h"
39
40 /*=======================================
41 File Local Macro Definitions
42 =======================================*/
43
44 /*=======================================
45 File Local Type Definitions
46 =======================================*/
47
48 /*=======================================
49 Variable Definitions
50 =======================================*/
51 #include "functable-legacy-macro.c"
52
53 SCM_DEFINE_EXPORTED_VARS(legacy_macro);
54
55 /*=======================================
56 File Local Function Declarations
57 =======================================*/
58
59 /*=======================================
60 Function Definitions
61 =======================================*/
62 SCM_EXPORT void
scm_init_legacy_macro(void)63 scm_init_legacy_macro(void)
64 {
65 ScmObj syn_closure_env;
66
67 SCM_GLOBAL_VARS_INIT(legacy_macro);
68
69 scm_register_funcs(scm_functable_legacy_macro);
70
71 /* dummy environment as syntactic closure marker */
72 syn_closure_env
73 = scm_extend_environment(LIST_1(scm_intern("define-macro")),
74 LIST_1(SCM_FALSE),
75 SCM_INTERACTION_ENV);
76 scm_gc_protect_with_init(&scm_syntactic_closure_env, syn_closure_env);
77 }
78
79 /* To test ScmNestState, scm_s_define() needs ScmEvalState although this is not
80 * a tail-recursive syntax */
81 SCM_EXPORT ScmObj
scm_s_define_macro(ScmObj identifier,ScmObj rest,ScmEvalState * eval_state)82 scm_s_define_macro(ScmObj identifier, ScmObj rest, ScmEvalState *eval_state)
83 {
84 ScmObj closure;
85 DECLARE_FUNCTION("define-macro", syntax_variadic_tailrec_1);
86
87 scm_s_define(identifier, rest, eval_state);
88
89 /*=======================================================================
90 (define-macro <identifier> <closure>)
91 =======================================================================*/
92 if (IDENTIFIERP(identifier)) {
93 }
94
95 /*=======================================================================
96 (define-macro (<identifier> . <formals>) <body>)
97
98 => (define-macro <identifier>
99 (lambda <formals> <body>))
100 =======================================================================*/
101 else if (CONSP(identifier)) {
102 identifier = CAR(identifier);
103 } else {
104 ERR_OBJ("bad define-macro form",
105 CONS(scm_intern("define-macro"), CONS(identifier, rest)));
106 }
107
108 #if SCM_USE_HYGIENIC_MACRO
109 SCM_ASSERT(SYMBOLP(identifier) || SYMBOLP(SCM_FARSYMBOL_SYM(identifier)));
110 #else
111 SCM_ASSERT(SYMBOLP(identifier));
112 #endif
113 identifier = SCM_UNWRAP_KEYWORD(identifier);
114
115 closure = SCM_SYMBOL_VCELL(identifier);
116 if (!CLOSUREP(closure))
117 SCM_SYMBOL_SET_VCELL(identifier, SCM_UNBOUND);
118 ENSURE_CLOSURE(closure);
119 if (!scm_toplevel_environmentp(SCM_CLOSURE_ENV(closure)))
120 ERR("syntactic closure in SigScheme must have toplevel environment");
121 /* destructively mark the closure as syntactic */
122 SCM_CLOSURE_SET_ENV(closure, SCM_SYNTACTIC_CLOSURE_ENV);
123
124 eval_state->ret_type = SCM_VALTYPE_AS_IS;
125 return SCM_UNDEF;
126 }
127