00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include <mmxlight/mmxlight_glue.hpp>
00014 #include <mmxlight/base_evaluator.hpp>
00015 namespace mmx {
00016
00017
00018
00019
00020
00021 generic
00022 convert_to (const generic& r, nat t_id, const generic& where) {
00023 nat r_id= type (r);
00024 if (r_id == type_id<alias<generic> > ())
00025 return convert_to (specialize_alias (r), t_id, where);
00026 if (r_id == type_id<tuple<generic> > ())
00027 if (is_tuple_type (t_id))
00028 return r;
00029 if (r_id == t_id) return r;
00030 else {
00031 nat pen;
00032 generic cv= get_environment (current_ev)->get_converter (r_id, t_id, pen);
00033 if (is<routine> (cv) && pen < PENALTY_INVALID)
00034 return as<routine> (cv) -> apply (r);
00035 else if (r == as<generic> (vec<generic> ())) {
00036 generic sqbr;
00037 if (current_ev->get (GEN_SQTUPLE, sqbr) && is<routine> (sqbr)) {
00038 vector<routine> funs= as<routine> (sqbr) -> meanings ();
00039 for (nat i=0; i<N(funs); i++) {
00040 vector<nat> sig = funs[i]->signature();
00041 if (sig[0] == t_id) {
00042 if (N (sig) == 1) return funs[i]->apply ();
00043 if (N (sig) == 2 && is_tuple_type (sig[1])) {
00044 static generic empty= eval (gen (GEN_TUPLE));
00045 return funs[i]->apply (empty);
00046 }
00047 }
00048 }
00049 }
00050 }
00051 return type_mismatch (type_name (t_id), where);
00052 }
00053 }
00054
00055 generic
00056 mmx_transtype (const generic& g) {
00057 if (N(g) != 3) return wrong_nr_args (g);
00058 generic t= eval (g[2]);
00059 if (is<exception> (t)) return t;
00060 nat t_id= type_id (t);
00061 if (t_id == 1) return type_mismatch (GEN_TYPE_TYPE, g[2]);
00062 generic r= eval (g[1]);
00063 if (is<exception> (r)) return r;
00064 return convert_to (r, t_id, g[1]);
00065 }
00066
00067
00068
00069
00070
00071 class module_rep REP_STRUCT {
00072 public:
00073 generic name;
00074 environment env;
00075 table<vector<generic>,generic> exports;
00076 public:
00077 inline module_rep (const generic& name2):
00078 name (name2),
00079 env (get_environment (current_ev)),
00080 exports (vec<generic> ()) {}
00081 void overload (const generic& var, const generic& val) const {
00082 module_rep* me= const_cast<module_rep*> (this);
00083 if (is<routine> (val)) {
00084 if (!exports->contains (var) || !is<routine> (exports[var][0]))
00085 me->exports[var]= vec<generic> ();
00086 me->exports[var] << val;
00087 }
00088 else me->exports[var]= vec<generic> (val);
00089 }
00090 vector<generic> contents () const {
00091 return vector<generic> (entries (exports));
00092 }
00093 generic resolve (const generic& var) const {
00094 vector<generic> v= exports[var];
00095 if (N(v) == 0)
00096 return std_exception ("undefined symbol in module", var);
00097 else if (N(v) == 1) return v[0];
00098 else {
00099 routine r= overloaded_routine (var, env);
00100 for (nat i=0; i<N(v); i++)
00101 r->overload (as<routine> (v[i]));
00102 return as<generic> (r);
00103 }
00104 }
00105 };
00106
00107 class module {
00108 INDIRECT_PROTO (module, module_rep)
00109 public:
00110 inline const module_rep* operator * () const { return rep; }
00111 inline module (const generic& name): rep (new module_rep (name)) {}
00112 };
00113 INDIRECT_IMPL (module, module_rep)
00114
00115 inline syntactic flatten (const module& p) { return flatten (p->name); }
00116
00117 WRAP_INDIRECT_IMPL(inline,module)
00118
00119
00120
00121
00122
00123 void
00124 mmx_set (const generic& var, const generic& val) {
00125 current_ev -> set (var, val);
00126 if (get_environment_type (current_ev) == 1 &&
00127 current_ev -> get (GEN_CLASS_ENCAPSULATION) == "public")
00128 as<module> (current_ev -> get (GEN_CLASS_EXPORT)) -> overload (var, val);
00129 }
00130
00131 void
00132 mmx_overload (const generic& var, const generic& val) {
00133 current_ev -> overload (var, val);
00134 if (get_environment_type (current_ev) == 1 &&
00135 current_ev -> get (GEN_CLASS_ENCAPSULATION) == "public")
00136 as<module> (current_ev -> get (GEN_CLASS_EXPORT)) -> overload (var, val);
00137 }
00138
00139 vector<generic>
00140 mmx_module_contents (const module& m) {
00141 return m -> contents ();
00142 }
00143
00144 generic
00145 mmx_module_resolve (const module& m, const generic& var) {
00146 return m -> resolve (var);
00147 }
00148
00149 void
00150 mmx_import (const module& m) {
00151 vector<generic> vars= mmx_module_contents (m);
00152 for (nat i=0; i<N(vars); i++) {
00153 vector<generic> vals= m->exports[vars[i]];
00154 for (nat j=0; j<N(vals); j++)
00155 if (is<routine> (vals[j])) mmx_overload (vars[i], vals[j]);
00156 else mmx_set (vars[i], vals[j]);
00157 }
00158 }
00159
00160 static generic
00161 dottify (const generic& var) {
00162 string name= literal_to_string (var);
00163 return as<generic> (literal ("." * name));
00164 }
00165
00166 static generic
00167 undottify (const generic& var) {
00168 string name= literal_to_string (var);
00169 if (name == "" || name[0] != '.') return var;
00170 else return as<generic> (literal (name (1, N(name))));
00171 }
00172
00173 class resolve_routine_rep: public routine_rep {
00174 generic sym;
00175 public:
00176 resolve_routine_rep (const generic& sym2):
00177 routine_rep (dottify (sym2)), sym (sym2) {}
00178 generic apply (const generic& a) const {
00179 return as<module> (a) -> resolve (sym); }
00180 vector<nat> signature () const {
00181 return vec<nat> (0, type_id<module> ()); }
00182 };
00183
00184 routine
00185 resolve_routine (const generic& sym) {
00186 return new resolve_routine_rep (sym);
00187 }
00188
00189 void
00190 mmx_import_resolvers (const module& m) {
00191 vector<generic> vars= mmx_module_contents (m);
00192 for (nat i=0; i<N(vars); i++) {
00193 generic var= vars[i];
00194 while (true) {
00195 mmx_overload (dottify (var), as<generic> (resolve_routine (var)));
00196 if (undottify (var) == var) break;
00197 var= undottify (var);
00198 }
00199 }
00200 }
00201
00202
00203
00204
00205
00206 generic
00207 mmx_object (const generic& x, const generic& t) {
00208 return as_object (x, t);
00209 }
00210
00211 generic
00212 mmx_unobject (const generic& x) {
00213 return as_generic (x, type (x));
00214 }
00215
00216 class access_routine_rep: public routine_rep {
00217 nat index, arg_tp, dest_tp;
00218 public:
00219 access_routine_rep (nat i, nat a, nat d):
00220 routine_rep (GEN_ACCESS), index (i), arg_tp (a), dest_tp (d) {}
00221 generic apply (const generic& a) const {
00222 vector<generic> v= as<vector<generic> > (as_generic (a, arg_tp));
00223 ASSERT (N(v) > index, "invalid data structure");
00224 return v[index];
00225 }
00226 vector<nat> signature () const { return vec<nat> (dest_tp, arg_tp); }
00227 };
00228
00229 routine
00230 access_routine (nat i, nat a, nat d) {
00231 return new access_routine_rep (i, a, d);
00232 }
00233
00234 class object_field_rep: public alias_rep<generic> {
00235 alias<generic> a;
00236 nat i;
00237 generic* temp;
00238 public:
00239 inline object_field_rep (const alias<generic>& a2, nat i2):
00240 a (a2), i (i2), temp (NULL) {}
00241 generic get () const {
00242 vector<generic> v= as<vector<generic> > (mmx_unobject (get_alias (a)));
00243 return read (v, i); }
00244 generic& open () const {
00245 object_field_rep* me= const_cast<object_field_rep*> (this);
00246 vector<generic> v= as<vector<generic> > (mmx_unobject (get_alias (a)));
00247 me->temp= mmx_new_one<generic> (read (v, i));
00248 return *me->temp; }
00249 void close () const {
00250 object_field_rep* me= const_cast<object_field_rep*> (this);
00251 vector<generic> v= as<vector<generic> > (mmx_unobject (get_alias (a)));
00252 v[i]= *temp;
00253 (void) set_alias (a, as_object (as<generic> (v), type (get_alias (a))));
00254 mmx_delete_one<generic> (me->temp);
00255 me->temp= NULL; }
00256 };
00257
00258 alias<generic> object_field (const alias<generic>& a, const nat& i) {
00259 return new object_field_rep (a, i); }
00260
00261 class alias_access_routine_rep: public routine_rep {
00262 nat index, arg_tp;
00263 public:
00264 alias_access_routine_rep (nat i, nat a):
00265 routine_rep (GEN_ACCESS), index (i), arg_tp (a) {}
00266 generic apply (const generic& a) const {
00267 alias<generic> contents= as<alias<generic> > (as_generic (a, arg_tp));
00268 alias<generic> field = object_field (contents, index);
00269 return specialize_alias (as<generic> (field));
00270 }
00271 vector<nat> signature () const { return vec<nat> (0, arg_tp); }
00272 };
00273
00274 routine
00275 alias_access_routine (nat i, nat a) {
00276 return new alias_access_routine_rep (i, a);
00277 }
00278
00279
00280
00281
00282
00283 generic
00284 mmx_class_intern (const generic& x) {
00285
00286 if (!is_func (x, GEN_TYPE, 2))
00287 return std_exception ("invalid intern data field", x);
00288 if (!is<literal> (x[1]))
00289 return std_exception ("literal expected", x[1]);
00290 generic var= x[1];
00291 generic tp = eval (x[2]);
00292 if (is<exception> (tp)) return tp;
00293 if (type_id (tp) == 1)
00294 return std_exception ("type expected", x[2]);
00295 current_ev->set (gen (GEN_METHOD, var), as<generic> (true));
00296 generic sym= dottify (var);
00297 generic cl = current_ev->get (GEN_CLASS_NAME);
00298 vector<generic> fields=
00299 as<vector<generic> > (current_ev->get (GEN_CLASS_FIELDS));
00300 if (true) {
00301 routine r= access_routine (N(fields), type_id (cl), type_id (tp));
00302 mmx_overload (sym, as<generic> (r));
00303 }
00304 if (current_ev->get (GEN_CLASS_ACCESS) == "mutable") {
00305 routine r=
00306 alias_access_routine (N(fields), scalar_to_alias (type_id (cl)));
00307 mmx_overload (sym, as<generic> (r));
00308 }
00309 fields << gen (GEN_TYPE, var, tp);
00310 current_ev->set (GEN_CLASS_FIELDS, as<generic> (fields));
00311 return void_value ();
00312 }
00313
00314
00315
00316
00317
00318 static generic
00319 methodize (const generic& x) {
00320 if (is_func (x, GEN_DEFINE, 2) || is_func (x, GEN_TYPE, 2))
00321 return gen (x[0], methodize (x[1]), x[2]);
00322 else if (is<compound> (x)) {
00323 vector<generic> v= compound_to_vector (x);
00324 v[0]= methodize (v[0]);
00325 return vector_to_compound (v);
00326 }
00327 else if (is<literal> (x)) {
00328 current_ev->set (gen (GEN_METHOD, x), as<generic> (true));
00329 generic sym= dottify (x);
00330 generic cl = current_ev->get (GEN_CLASS_NAME);
00331 if (current_ev->get (GEN_CLASS_ACCESS) == "mutable")
00332 cl= gen (GEN_ALIAS_TYPE, cl);
00333 return gen (sym, gen (GEN_TYPE, GEN_THIS, cl));
00334 }
00335 else ERROR ("syntax error");
00336 }
00337
00338 generic
00339 mmx_class_method (const generic& x) {
00340
00341 if (!is_func (x, GEN_DEFINE, 2))
00342 return std_exception ("invalid method declaration", x);
00343 generic def= methodize (x);
00344
00345 generic r= mmx_define (def);
00346 if (is<exception> (r)) return r;
00347 return void_value ();
00348 }
00349
00350
00351
00352
00353
00354 generic
00355 mmx_class_extern (const generic& x) {
00356
00357 generic r= eval (x);
00358 if (is<exception> (r)) return r;
00359 return void_value ();
00360 }
00361
00362
00363
00364
00365
00366 generic
00367 mmx_class_constructor (const generic& x) {
00368
00369 if (!is_func (x, GEN_DEFINE, 2))
00370 return std_exception ("invalid constructor", x);
00371 generic head= x[1];
00372 if (is_func (head, GEN_TYPE, 2))
00373 return std_exception ("type is implicit", head);
00374 generic body= x[2];
00375 if (!is_func (body, GEN_BEGIN))
00376 body= gen (GEN_BEGIN, body);
00377 vector<generic> lhs=
00378 as<vector<generic> > (current_ev->get (GEN_CLASS_FIELDS));
00379 vector<generic> rhs= cdr (compound_to_vector (body));
00380 vector<generic> tup;
00381 if (N(lhs) != N(rhs))
00382 return std_exception ("initializers do not match", body);
00383 for (nat j=0; j<N(rhs); j++)
00384 if (!is_func (rhs[j], GEN_DEFINE, 2))
00385 return std_exception ("incorrect initializer", rhs[j]);
00386 else if (rhs[j][1] != lhs[j][1])
00387 return std_exception ("initializer does not match", rhs[j]);
00388 else tup << gen (GEN_TRANSTYPE, rhs[j][2], lhs[j][2]);
00389 generic cl = current_ev->get (GEN_CLASS_NAME);
00390 generic new_head= gen (GEN_TYPE, head, cl);
00391 generic new_body= gen ("object", gen (GEN_SQTUPLE, tup), cl);
00392 generic r= mmx_define (gen (GEN_DEFINE, new_head, new_body));
00393 if (is<exception> (r)) return r;
00394 return void_value ();
00395 }
00396
00397 generic
00398 mmx_class_destructor (const generic& x) {
00399
00400 (void) x;
00401 return void_value ();
00402 }
00403
00404
00405
00406
00407
00408 generic mmx_class_declaration (const generic& x);
00409
00410 generic
00411 mmx_class_modified (const generic& x, const generic& var, const generic& val) {
00412 generic old= current_ev->get (var);
00413 current_ev->set (var, val);
00414 generic r= mmx_class_declaration (x);
00415 current_ev->set (var, old);
00416 return r;
00417 }
00418
00419 generic
00420 mmx_class_declaration (const generic& x) {
00421
00422 if (is_func (x, GEN_BEGIN))
00423 for (nat i=1; i<N(x); i++) {
00424 generic r= mmx_class_declaration (x[i]);
00425 if (is<exception> (r)) return r;
00426 }
00427 else if (is_func (x, GEN_INTERN, 1))
00428 return mmx_class_modified (x[1], GEN_CLASS_MODE, "intern");
00429 else if (is_func (x, GEN_METHOD, 1))
00430 return mmx_class_modified (x[1], GEN_CLASS_MODE, "method");
00431 else if (is_func (x, GEN_EXTERN, 1))
00432 return mmx_class_modified (x[1], GEN_CLASS_MODE, "extern");
00433 else if (is_func (x, GEN_CONSTRUCTOR, 1))
00434 return mmx_class_modified (x[1], GEN_CLASS_MODE, "constructor");
00435 else if (is_func (x, GEN_DESTRUCTOR, 1))
00436 return mmx_class_destructor (x[1]);
00437 else if (is_func (x, GEN_CONSTANT, 1))
00438 return mmx_class_modified (x[1], GEN_CLASS_ACCESS, "constant");
00439 else if (is_func (x, GEN_MUTABLE, 1))
00440 return mmx_class_modified (x[1], GEN_CLASS_ACCESS, "mutable");
00441 else if (is_func (x, GEN_PRIVATE, 1))
00442 return mmx_class_modified (x[1], GEN_CLASS_ENCAPSULATION, "private");
00443 else if (is_func (x, GEN_PUBLIC, 1))
00444 return mmx_class_modified (x[1], GEN_CLASS_ENCAPSULATION, "public");
00445 else if (current_ev->get (GEN_CLASS_MODE) == "intern")
00446 return mmx_class_intern (x);
00447 else if (current_ev->get (GEN_CLASS_MODE) == "method")
00448 return mmx_class_method (x);
00449 else if (current_ev->get (GEN_CLASS_MODE) == "extern")
00450 return mmx_class_extern (x);
00451 else if (current_ev->get (GEN_CLASS_MODE) == "constructor")
00452 return mmx_class_constructor (x);
00453 else return std_exception ("invalid class declaration", x);
00454 return void_value ();
00455 }
00456
00457
00458
00459
00460
00461 generic
00462 mmx_class_module (const generic& x, bool module_flag) {
00463 if (N(x) != 2 && N(x) != 3) return wrong_nr_args (x);
00464 generic t= eval (x[1]);
00465 if (is<exception> (t)) return t;
00466 if (!module_flag) (void) as_object (generic (), t);
00467 if (N(x) == 2) return void_value ();
00468 select_evaluator (base_evaluator (current_ev));
00469 set_environment_type (current_ev, 1);
00470 current_ev->set (GEN_CLASS_NAME, t);
00471 current_ev->set (GEN_CLASS_MODE, module_flag? "extern": "intern");
00472 current_ev->set (GEN_CLASS_ENCAPSULATION, "public");
00473 current_ev->set (GEN_CLASS_ACCESS, "constant");
00474 current_ev->set (GEN_CLASS_FIELDS, as<generic> (vec<generic> ()));
00475 current_ev->set (GEN_CLASS_EXPORT, as<generic> (module (t)));
00476 generic r= mmx_class_declaration (x[2]);
00477 generic exports= current_ev->get (GEN_CLASS_EXPORT);
00478 restore_evaluator ();
00479 if (module_flag) {
00480 if (!is<literal> (t))
00481 return std_exception ("literal expected", x[1]);
00482 mmx_import_resolvers (as<module> (exports));
00483 mmx_set (t, exports);
00484 return exports;
00485 }
00486 else {
00487 mmx_import (as<module> (exports));
00488 return r;
00489 }
00490 }
00491
00492 generic
00493 mmx_class (const generic& x) {
00494 return mmx_class_module (x, false);
00495 }
00496
00497 generic
00498 mmx_module (const generic& x) {
00499 return mmx_class_module (x, true);
00500 }
00501
00502 generic
00503 mmx_category (const generic& x) {
00504 if (N(x) != 2 && N(x) != 3) return wrong_nr_args (x);
00505 if (N(x) == 2) return void_value ();
00506 generic name= x[1];
00507 if (is<compound> (name)) name= name[0];
00508 current_ev->set (gen (GEN_CATEGORY, name), x);
00509 return void_value ();
00510 }
00511
00512
00513
00514
00515
00516 string
00517 make_literal_string (const literal& lit) {
00518 string s= as_string (lit);
00519 return unquote (s);
00520 }
00521
00522 void
00523 glue_class () {
00524 current_ev->set (GEN_VOID_TYPE, GEN_GENERIC_TYPE);
00525 define_type<string> ("String");
00526 define ("literal_string", make_literal_string);
00527 define (GEN_DUPLICATE, (generic (*) (const generic&)) duplicate);
00528
00529 define_primitive (GEN_TRANSTYPE, mmx_transtype);
00530 define ("object", mmx_object);
00531 define ("unobject", mmx_unobject);
00532
00533 define_type<module> ("Module");
00534 define_primitive (GEN_CLASS, mmx_class);
00535 define_primitive (GEN_MODULE, mmx_module);
00536 define_primitive (GEN_CATEGORY, mmx_category);
00537 define (GEN_IMPORT, mmx_import);
00538 define ("contents", mmx_module_contents);
00539 define ("resolve", mmx_module_resolve);
00540 }
00541
00542 }
