root/src/compaux.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. Scm_Compile
  2. Scm_CompilePartial
  3. Scm_CompileFinish
  4. synclo_print
  5. Scm_MakeSyntacticClosure
  6. synclo_env_get
  7. synclo_literals_get
  8. synclo_expr_get
  9. identifier_print
  10. get_binding_frame
  11. Scm_MakeIdentifier
  12. Scm_IdentifierBindingEqv
  13. Scm_CopyIdentifier
  14. identifier_name_get
  15. identifier_name_set
  16. identifier_module_get
  17. identifier_module_set
  18. identifier_env_get
  19. identifier_env_set
  20. unwrap_rec
  21. Scm_UnwrapSyntax
  22. 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 

/* [<][>][^][v][top][bottom][index][help] */