/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_Compile
- Scm_CompilePartial
- Scm_CompileFinish
- synclo_print
- Scm_MakeSyntacticClosure
- synclo_env_get
- synclo_literals_get
- synclo_expr_get
- identifier_print
- get_binding_frame
- Scm_MakeIdentifier
- Scm_IdentifierBindingEqv
- Scm_CopyIdentifier
- identifier_name_get
- identifier_name_set
- identifier_module_get
- identifier_module_set
- identifier_env_get
- identifier_env_set
- unwrap_rec
- Scm_UnwrapSyntax
- Scm__InitCompaux
1 /*
2 * compaux.c - C API bridge for the compiler
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: compaux.c,v 1.11 2005/05/28 10:24:36 shirok Exp $
34 */
35
36 /* This file serves as a bridge to the compiler, which is implemented
37 in Scheme (see compile.scm) */
38
39 #include <stdlib.h>
40 #define LIBGAUCHE_BODY
41 #include "gauche.h"
42 #include "gauche/vm.h"
43 #include "gauche/vminsn.h"
44 #include "gauche/class.h"
45 #include "gauche/code.h"
46 #include "gauche/builtin-syms.h"
47
48 /*
49 * Syntax
50 */
51
52
53 /*
54 * Compiler Entry
55 */
56
57 static ScmGloc *compile_gloc = NULL;
58 static ScmGloc *compile_partial_gloc = NULL;
59 static ScmGloc *compile_finish_gloc = NULL;
60 static ScmGloc *init_compiler_gloc = NULL;
61
62 static ScmInternalMutex compile_finish_mutex;
63
64 ScmObj Scm_Compile(ScmObj program, ScmObj env)
65 {
66 return Scm_Apply(SCM_GLOC_GET(compile_gloc), SCM_LIST2(program, env));
67 }
68
69 ScmObj Scm_CompilePartial(ScmObj program, ScmObj env)
70 {
71 return Scm_Apply(SCM_GLOC_GET(compile_partial_gloc),
72 SCM_LIST2(program, env));
73 }
74
75 void Scm_CompileFinish(ScmCompiledCode *cc)
76 {
77 if (cc->code == NULL) {
78 SCM_INTERNAL_MUTEX_LOCK(compile_finish_mutex);
79 SCM_UNWIND_PROTECT {
80 if (cc->code == NULL) {
81 Scm_Apply(SCM_GLOC_GET(compile_finish_gloc),
82 SCM_LIST1(SCM_OBJ(cc)));
83 }
84 }
85 SCM_WHEN_ERROR {
86 SCM_INTERNAL_MUTEX_UNLOCK(compile_finish_mutex);
87 SCM_NEXT_HANDLER;
88 }
89 SCM_END_PROTECT;
90 SCM_INTERNAL_MUTEX_UNLOCK(compile_finish_mutex);
91 }
92 }
93
94 /*-------------------------------------------------------------
95 * Syntactic closure object
96 */
97
98 static void synclo_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
99 {
100 Scm_Printf(port, "#<syntactic-closure %S>",
101 SCM_SYNTACTIC_CLOSURE(obj)->expr);
102 }
103
104 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SyntacticClosureClass, synclo_print);
105
106 ScmObj Scm_MakeSyntacticClosure(ScmObj env, ScmObj literals, ScmObj expr)
107 {
108 ScmSyntacticClosure *s = SCM_NEW(ScmSyntacticClosure);
109 SCM_SET_CLASS(s, SCM_CLASS_SYNTACTIC_CLOSURE);
110 s->env = env;
111 s->literals = literals;
112 s->expr = expr;
113 return SCM_OBJ(s);
114 }
115
116 static ScmObj synclo_env_get(ScmObj obj)
117 {
118 return SCM_SYNTACTIC_CLOSURE(obj)->env;
119 }
120
121 static ScmObj synclo_literals_get(ScmObj obj)
122 {
123 return SCM_SYNTACTIC_CLOSURE(obj)->literals;
124 }
125
126 static ScmObj synclo_expr_get(ScmObj obj)
127 {
128 return SCM_SYNTACTIC_CLOSURE(obj)->expr;
129 }
130
131 static ScmClassStaticSlotSpec synclo_slots[] = {
132 SCM_CLASS_SLOT_SPEC("env", synclo_env_get, NULL),
133 SCM_CLASS_SLOT_SPEC("literals", synclo_literals_get, NULL),
134 SCM_CLASS_SLOT_SPEC("expr", synclo_expr_get, NULL),
135 SCM_CLASS_SLOT_SPEC_END()
136 };
137
138 /*-------------------------------------------------------------
139 * Identifier object
140 */
141
142 static void identifier_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
143 {
144 ScmIdentifier *id = SCM_IDENTIFIER(obj);
145 /* We may want to have an external identifier syntax, so that an
146 identifier can be written out and then read back. It will be
147 convenient if we can embed a reference to other module's global
148 binding directly in the program. However, it can also breaches
149 module-based sandbox implementation, so further consideration is
150 required.
151 */
152 Scm_Printf(port, "#<identifier %S#%S>", id->module->name, id->name);
153 }
154
155 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_IdentifierClass, identifier_print);
156
157 static ScmObj get_binding_frame(ScmObj var, ScmObj env)
158 {
159 ScmObj frame, fp;
160 SCM_FOR_EACH(frame, env) {
161 if (!SCM_PAIRP(SCM_CAR(frame))) continue;
162 SCM_FOR_EACH(fp, SCM_CDAR(frame)) {
163 if (SCM_CAAR(fp) == var) return frame;
164 }
165 }
166 return SCM_NIL;
167 }
168
169 ScmObj Scm_MakeIdentifier(ScmSymbol *name, ScmModule *mod, ScmObj env)
170 {
171 ScmIdentifier *id = SCM_NEW(ScmIdentifier);
172 SCM_SET_CLASS(id, SCM_CLASS_IDENTIFIER);
173 id->name = name;
174 id->module = mod? mod : SCM_CURRENT_MODULE();
175 id->env = (env == SCM_NIL)? SCM_NIL : get_binding_frame(SCM_OBJ(name), env);
176 return SCM_OBJ(id);
177 }
178
179 /* returns true if SYM has the same binding with ID in ENV. */
180 int Scm_IdentifierBindingEqv(ScmIdentifier *id, ScmSymbol *sym, ScmObj env)
181 {
182 ScmObj bf = get_binding_frame(SCM_OBJ(sym), env);
183 return (bf == id->env);
184 }
185
186 ScmObj Scm_CopyIdentifier(ScmIdentifier *orig)
187 {
188 ScmIdentifier *id = SCM_NEW(ScmIdentifier);
189 SCM_SET_CLASS(id, SCM_CLASS_IDENTIFIER);
190 id->name = orig->name;
191 id->module = orig->module;
192 id->env = orig->env;
193 return SCM_OBJ(id);
194 }
195
196 static ScmObj identifier_name_get(ScmObj obj)
197 {
198 return SCM_OBJ(SCM_IDENTIFIER(obj)->name);
199 }
200
201 static void identifier_name_set(ScmObj obj, ScmObj val)
202 {
203 if (!SCM_SYMBOLP(val)) {
204 Scm_Error("symbol required, but got %S", val);
205 }
206 SCM_IDENTIFIER(obj)->name = SCM_SYMBOL(val);
207 }
208
209 static ScmObj identifier_module_get(ScmObj obj)
210 {
211 return SCM_OBJ(SCM_IDENTIFIER(obj)->module);
212 }
213
214 static void identifier_module_set(ScmObj obj, ScmObj val)
215 {
216 if (!SCM_MODULEP(val)) {
217 Scm_Error("module required, but got %S", val);
218 }
219 SCM_IDENTIFIER(obj)->module = SCM_MODULE(val);
220 }
221
222 static ScmObj identifier_env_get(ScmObj obj)
223 {
224 return SCM_IDENTIFIER(obj)->env;
225 }
226
227 static void identifier_env_set(ScmObj obj, ScmObj val)
228 {
229 if (!SCM_LISTP(val)) {
230 Scm_Error("list required, but got %S", val);
231 }
232 SCM_IDENTIFIER(obj)->env = val;
233 }
234
235 static ScmClassStaticSlotSpec identifier_slots[] = {
236 SCM_CLASS_SLOT_SPEC("name", identifier_name_get, identifier_name_set),
237 SCM_CLASS_SLOT_SPEC("module", identifier_module_get, identifier_module_set),
238 SCM_CLASS_SLOT_SPEC("env", identifier_env_get, identifier_env_set),
239 { NULL }
240 };
241
242 /*------------------------------------------------------------------
243 * Utility functions
244 */
245
246 /* Convert all identifiers in form into a symbol.
247 This keeps linear history to avoid entering infinite loop if
248 the given form is circular; but it doens't recover the shared
249 substricture. */
250 static ScmObj unwrap_rec(ScmObj form, ScmObj history)
251 {
252 ScmObj newh;
253
254 if (!SCM_PTRP(form)) return form;
255 if (!SCM_FALSEP(Scm_Memq(form, history))) return form;
256
257 if (SCM_PAIRP(form)) {
258 ScmObj ca, cd;
259 newh = Scm_Cons(form, history);
260 ca = unwrap_rec(SCM_CAR(form), newh);
261 cd = unwrap_rec(SCM_CDR(form), newh);
262 if (ca == SCM_CAR(form) && cd == SCM_CDR(form)) {
263 return form;
264 } else {
265 return Scm_Cons(ca, cd);
266 }
267 }
268 if (SCM_IDENTIFIERP(form)) {
269 return SCM_OBJ(SCM_IDENTIFIER(form)->name);
270 }
271 if (SCM_VECTORP(form)) {
272 int i, j, len = SCM_VECTOR_SIZE(form);
273 ScmObj elt, *pelt = SCM_VECTOR_ELEMENTS(form);
274 newh = Scm_Cons(form, history);
275 for (i=0; i<len; i++, pelt++) {
276 elt = unwrap_rec(*pelt, newh);
277 if (elt != *pelt) {
278 ScmObj newvec = Scm_MakeVector(len, SCM_FALSE);
279 pelt = SCM_VECTOR_ELEMENTS(form);
280 for (j=0; j<i; j++, pelt++) {
281 SCM_VECTOR_ELEMENT(newvec, j) = *pelt;
282 }
283 SCM_VECTOR_ELEMENT(newvec, i) = elt;
284 for (; j<len; j++, pelt++) {
285 SCM_VECTOR_ELEMENT(newvec, j) = unwrap_rec(*pelt, newh);
286 }
287 return newvec;
288 }
289 }
290 return form;
291 }
292 return form;
293 }
294
295 ScmObj Scm_UnwrapSyntax(ScmObj form)
296 {
297 return unwrap_rec(form, SCM_NIL);
298 }
299
300 /*===================================================================
301 * Initializer
302 */
303
304 #define INIT_GLOC(gloc, name, mod) \
305 do { \
306 gloc = Scm_FindBinding(mod, SCM_SYMBOL(SCM_INTERN(name)), TRUE); \
307 if (gloc == NULL) { \
308 Scm_Panic("no " name " procedure in gauche.internal"); \
309 } \
310 } while (0)
311
312 void Scm__InitCompaux(void)
313 {
314 ScmModule *g = Scm_GaucheModule();
315 ScmModule *gi = Scm_GaucheInternalModule();
316
317 Scm_InitStaticClass(SCM_CLASS_SYNTACTIC_CLOSURE, "<syntactic-closure>", g,
318 synclo_slots, 0);
319 Scm_InitStaticClass(SCM_CLASS_IDENTIFIER, "<identifier>", g,
320 identifier_slots, 0);
321
322 SCM_INTERNAL_MUTEX_INIT(compile_finish_mutex);
323
324 /* Grab the entry points of compile.scm */
325 INIT_GLOC(init_compiler_gloc, "init-compiler", gi);
326 INIT_GLOC(compile_gloc, "compile", gi);
327 INIT_GLOC(compile_partial_gloc, "compile-partial", gi);
328 INIT_GLOC(compile_finish_gloc, "compile-finish", gi);
329
330 Scm_Apply(SCM_GLOC_GET(init_compiler_gloc), SCM_NIL);
331 }
332