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 #include <basix/dynamic.hpp>
00016 namespace mmx {
00017
00018
00019
00020
00021
00022 static bool
00023 occurs (const generic& var, const generic& x) {
00024 if (x == var) return true;
00025 else if (is<compound> (x)) {
00026 for (nat i=0; i<N(x); i++)
00027 if (occurs (var, x[i]))
00028 return true;
00029 }
00030 return false;
00031 }
00032
00033 static generic
00034 replace (const generic& x, const generic& var, const generic& by) {
00035 if (x == var) return by;
00036 else if (by == GEN_GENERIC_TYPE && is_func (x, GEN_TYPE, 2) &&
00037 is<compound> (x[1]) && occurs (var, x[2]))
00038 return gen (GEN_TYPE, replace (x[1], var, by), GEN_GENERIC_TYPE);
00039 else if (is<compound> (x)) {
00040 vector<generic> s= compound_to_vector (x);
00041 vector<generic> r= fill<generic> (N(s));
00042 for (nat i=0; i<N(s); i++) r[i]= replace (s[i], var, by);
00043 return vector_to_compound (r);
00044 }
00045 else return x;
00046 }
00047
00048
00049
00050
00051
00052 static bool matches (const generic& tp, const generic& cat);
00053
00054 static bool
00055 matches_compute (const generic& tp, const generic& cat) {
00056 generic rad= (is<compound> (cat)? cat[0]: cat);
00057 if (!current_ev->contains (gen (GEN_CATEGORY, rad))) return false;
00058 if (cat == "Class") return true;
00059 if (tp == GEN_GENERIC_TYPE)
00060 return
00061 !is_func (cat, "Over") &&
00062 !is_func (cat, "Normed_Over") &&
00063 !is_func (cat, "Complex_Over");
00064 generic val = current_ev->get (gen (GEN_CATEGORY, rad));
00065 generic body= replace (val[2], GEN_THIS_TYPE, tp);
00066 if (is<compound> (cat)) {
00067 if (!is<compound> (val[1]) || N(val[1]) != N(cat)) return false;
00068 for (nat i=1; i<N(cat); i++)
00069 if (!is_func (val[1][i], GEN_TYPE, 2)) return false;
00070 else body= replace (body, val[1][i][1], cat[i]);
00071
00072 }
00073 if (!is_func (body, GEN_BEGIN)) return false;
00074 for (nat i=1; i<N(body); i++) {
00075
00076 if (is_func (body[i], GEN_TYPE, 2)) {
00077 if (is_func (body[i][2], GEN_INTO, 2)) {
00078 vector<generic> args= vec<generic> (body[i][2][2]);
00079 if (is_func (body[i][2][1], GEN_TUPLE))
00080 args << cdr (compound_to_vector (body[i][2][1]));
00081 else if (body[i][2][1] != GEN_VOID_TYPE)
00082 args << vec<generic> (body[i][2][1]);
00083 generic what= gen ("Function", args);
00084
00085 if (!current_ev->contains (body[i][1])) return false;
00086 generic rout= current_ev->get (body[i][1]);
00087 if (!is<routine> (rout)) return false;
00088 generic have= as<routine> (rout) -> function_type ();
00089
00090 bool ok= false;
00091 for (nat i=1; i<N(have); i++) ok= ok || have[i] == what;
00092 if (!ok) return false;
00093 }
00094 else if (!matches (body[i][1], body[i][2]))
00095 return false;
00096 }
00097 }
00098 return true;
00099 }
00100
00101 static bool
00102 matches (const generic& tp, const generic& cat) {
00103 if (!current_ev->contains (gen ("matches?", tp, cat)))
00104 current_ev->set (gen ("matches?", tp, cat),
00105 as<generic> (matches_compute (tp, cat)));
00106 return as<bool> (current_ev->get (gen ("matches?", tp, cat)));
00107 }
00108
00109
00110
00111
00112
00113 static bool
00114 types_defined (const generic& x, const vector<generic>& all) {
00115 if (is_func (x, GEN_FORALL)) {
00116 if (N(x) > 3)
00117 return types_defined (gen (x[0], gen (x[1]),
00118 gen (x[0], cdr (compound_to_vector (x)))),
00119 all);
00120 else {
00121 ASSERT (is_func (x[1], GEN_TYPE, 2), "syntax error");
00122 return types_defined (replace (x[2], x[1][1], GEN_GENERIC_TYPE), all);
00123 }
00124 }
00125 else if (is_func (x, GEN_TYPE, 2) || is_func (x, GEN_CONVERT, 2)) {
00126 generic tp= x[2];
00127 if (is_func (tp, GEN_ALIAS_TYPE, 1)) tp= tp[1];
00128 if (is_func (tp, GEN_TUPLE_TYPE, 1)) tp= tp[1];
00129 if (!contains (all, tp)) return false;
00130 return types_defined (x[1], all);
00131 }
00132 else if (is<compound> (x)) {
00133 for (nat i=0; i<N(x); i++)
00134 if (!types_defined (x[i], all))
00135 return false;
00136 }
00137 return true;
00138 }
00139
00140 generic
00141 mmx_forall (const generic& x) {
00142 if (N(x) < 2) return wrong_nr_args (x);
00143 if (N(x) == 2) return eval (x[1]);
00144 if (N(x) > 3)
00145 return eval (gen (x[0], gen (x[1]),
00146 gen (x[0], cdr (compound_to_vector (x)))));
00147 generic tvar= x[1];
00148 generic var = (is_func (tvar, GEN_TYPE, 2)? tvar[1]: tvar);
00149 generic cat = (is_func (tvar, GEN_TYPE, 2)? tvar[2]: generic ("Class"));
00150 if (!is<literal> (var)) return type_mismatch (GEN_LITERAL_TYPE, var);
00151 const vector<generic> all= all_type_names ();
00152 ASSERT (N(all) > 0 && all[0] == GEN_GENERIC_TYPE, "missing generic type");
00153
00154 for (nat i=0; i<N(all); i++) {
00155 if (!matches (all[i], cat)) continue;
00156 generic w= replace (x[2], var, all[i]);
00157 if (!types_defined (w, all)) continue;
00158
00159 generic r= eval (w);
00160 if (is<exception> (r)) return r;
00161 }
00162 return void_value ();
00163 }
00164
00165
00166
00167
00168
00169 generic
00170 mmx_assume (const generic& x) {
00171 if (N(x) != 3) return wrong_nr_args (x);
00172 if (x[1] == "interpreted") return eval (x[2]);
00173 return void_value ();
00174 }
00175
00176 generic
00177 mmx_penalty (const generic& x) {
00178 if (N(x) != 3) return wrong_nr_args (x);
00179 return void_value ();
00180 }
00181
00182
00183
00184
00185
00186 static generic
00187 perform_op (nat op, const generic& x, const generic& y) {
00188 switch (op) {
00189 case 1: return x+y;
00190 case 2: return x-y;
00191 case 3: return x*y;
00192 case 4: return x/y;
00193 default: ERROR ("invalid operation (perform_op)");
00194 }
00195 }
00196
00197 static generic
00198 mmx_op_assign (const generic& x, nat op) {
00199 generic var= eval (x[1]);
00200 if (is<exception> (var)) return var;
00201 if (is_alias_type (type (var))) {
00202 generic val= eval (x[2]);
00203 if (is<exception> (val)) return val;
00204 if (op != 0) {
00205 val= perform_op (op, get_alias (var), val);
00206 if (is<exception> (val)) return val;
00207 }
00208 val= convert_to (val, alias_to_scalar (type (var)), x[2]);
00209 if (is<exception> (val)) return val;
00210 return set_alias (var, val);
00211 }
00212 if (is_tuple_type (type (var))) {
00213 generic val= eval (x[2]);
00214 if (is<exception> (val)) return val;
00215 if (!is_tuple_type (type (val)))
00216 return type_mismatch (GEN_TUPLE_TYPE, x[1]);
00217 generic vars= *as<tuple<generic> > (var);
00218 generic vals= *as<tuple<generic> > (val);
00219 if (N(vars) != N(vals))
00220 return wrong_nr_args (x[2]);
00221 vector<generic> ret= fill<generic> (GEN_TUPLE, N(vars));
00222 for (nat i=1; i<N(vars); i++) {
00223 nat tid= type (vars[i]);
00224 if (!is_alias_type (tid))
00225 return type_mismatch (gen (GEN_TUPLE_TYPE, GEN_ALIAS_TYPE), x[1]);
00226 generic val= vals[i];
00227 if (op != 0) {
00228 val= perform_op (op, get_alias (vars[i]), val);
00229 if (is<exception> (val)) return val;
00230 }
00231 val= convert_to (val, alias_to_scalar (tid), x[2]);
00232 if (is<exception> (val)) return val;
00233 ret[i]= val;
00234 }
00235 for (nat i=1; i<N(vars); i++)
00236 ret[i]= set_alias (vars[i], ret[i]);
00237 return as<generic> (tuple<generic> (vector_to_compound (ret)));
00238 }
00239 if (is<dynamic> (var)) {
00240 generic val= eval (x[2]);
00241 assign (as<dynamic> (var), val);
00242 return val;
00243 }
00244 return type_mismatch (gen (GEN_OR, GEN_ALIAS_TYPE, GEN_TUPLE_TYPE), x[1]);
00245 }
00246
00247 generic
00248 mmx_plus_assign (const generic& x) {
00249 if (N(x) != 3) return wrong_nr_args (x);
00250 return mmx_op_assign (x, 1);
00251 }
00252
00253 generic
00254 mmx_minus_assign (const generic& x) {
00255 if (N(x) != 3) return wrong_nr_args (x);
00256 return mmx_op_assign (x, 2);
00257 }
00258
00259 generic
00260 mmx_times_assign (const generic& x) {
00261 if (N(x) != 3) return wrong_nr_args (x);
00262 return mmx_op_assign (x, 3);
00263 }
00264
00265 generic
00266 mmx_over_assign (const generic& x) {
00267 if (N(x) != 3) return wrong_nr_args (x);
00268 return mmx_op_assign (x, 4);
00269 }
00270
00271
00272
00273
00274
00275 generic
00276 mmx_define (const generic& x) {
00277 if (N(x) != 3) return wrong_nr_args (x);
00278 if (is_func (x[1], GEN_TYPE, 2)) {
00279 if (is<compound> (x[1][1])) {
00280 generic lambda= gen (GEN_LAMBDA, x[1][1], x[2], x[1][2]);
00281 return mmx_define (gen (GEN_DEFINE, car (x[1][1]), lambda));
00282 }
00283 else {
00284 if (!is<literal> (x[1][1]))
00285 return type_mismatch (GEN_SYMBOL_TYPE, x[1][1]);
00286 generic r= eval (gen (GEN_TRANSTYPE, x[2], x[1][2]));
00287 if (!is<exception> (r))
00288 mmx_overload (x[1][1], r);
00289 return r;
00290 }
00291 }
00292 else {
00293 if (is<compound> (x[1])) {
00294 generic lambda= gen (GEN_LAMBDA, x[1], x[2]);
00295 return mmx_define (gen (GEN_DEFINE, car (x[1]), lambda));
00296 }
00297 else {
00298 if (!is<literal> (x[1]))
00299 return type_mismatch (GEN_LITERAL_TYPE, x[1]);
00300 generic r= eval (gen (GEN_TRANSTYPE, x[2], GEN_GENERIC_TYPE));
00301 if (!is<exception> (r))
00302 mmx_overload (x[1], r);
00303 return r;
00304 }
00305 }
00306 }
00307
00308 generic
00309 mmx_assign (const generic& x) {
00310 if (N(x) != 3) return wrong_nr_args (x);
00311 if (is_func (x[1], GEN_TYPE, 2)) {
00312 if (is<compound> (x[1][1])) {
00313 generic var= gen (GEN_TYPE, car (x[1][1]), GEN_GENERIC_TYPE);
00314 generic lambda= gen (GEN_LAMBDA, x[1][1], x[2], x[1][2]);
00315 return mmx_assign (gen (GEN_ASSIGN, var, lambda));
00316 }
00317 else {
00318 if (!is<literal> (x[1][1]))
00319 return type_mismatch (GEN_SYMBOL_TYPE, x[1][1]);
00320 generic t= eval (x[1][2]);
00321 if (is<exception> (t)) return t;
00322 nat tid= type_id (t);
00323 if (tid == 1) return type_mismatch (GEN_TYPE_TYPE, x[1][2]);
00324 generic r= eval (x[2]);
00325 if (is<exception> (r)) return r;
00326 r= convert_to (r, tid, x[2]);
00327 if (is<exception> (r)) return r;
00328 if (tid == 0) r= as<generic> (alias<generic> (r));
00329 else r= current_ev->apply (GEN_ALIAS, r);
00330 mmx_set (x[1][1], r);
00331 return r;
00332 }
00333 }
00334 else if (is<literal> (x[1]) &&
00335 !current_ev->contains (x[1]) &&
00336 !current_ev->contains (gen (GEN_METHOD, x[1]))) {
00337 generic var= gen (GEN_TYPE, x[1], GEN_GENERIC_TYPE);
00338 return mmx_assign (gen (GEN_ASSIGN, var, x[2]));
00339 }
00340 else return mmx_op_assign (x, 0);
00341 }
00342
00343
00344
00345
00346
00347 class closure_routine_rep: public routine_rep {
00348 evaluator ev;
00349 vector<nat> sig;
00350 generic args;
00351 generic body;
00352 public:
00353 closure_routine_rep (const evaluator& e, const vector<nat>& s,
00354 const generic& a, const generic& b):
00355 routine_rep (GEN_CLOSURE), ev (e), sig (s), args (a), body (b) {}
00356 generic apply (const vector<generic>& v) const {
00357 nat i, n= N(args);
00358
00359
00360
00361 if (N(v) != n-1) {
00362 mmerr << "Routine : " << args[0] << "\n";
00363 mmerr << "Expected : " << cdr (compound_to_vector (args)) << "\n";
00364 mmerr << "Arguments: " << v << "\n";
00365 return wrong_nr_args (gen (args[0], v));
00366 }
00367 select_evaluator (base_evaluator (ev));
00368 for (i=1; i<n; i++) {
00369 if (sig[i] == 0) current_ev->set (args[i], v[i-1]);
00370 else {
00371
00372 generic r= convert_to (v[i-1], sig[i], args[i]);
00373 if (is<exception> (r)) {
00374 restore_evaluator ();
00375 return trace_push (r, gen (args[0], v));
00376 }
00377 current_ev->set (args[i], r);
00378 }
00379 }
00380 generic r= eval (body);
00381 if (is<exception> (r)) {
00382 generic msg= *as<exception> (r);
00383 if (is_func (msg, GEN_RETURN, 1)) r= msg[1];
00384 }
00385 if (sig[0] != 0 && !is<exception> (r))
00386 r= convert_to (r, sig[0], body);
00387 restore_evaluator ();
00388 if (is<exception> (r)) return trace_push (r, gen (args[0], v));
00389 return r;
00390 }
00391 vector<nat> signature () const { return sig; }
00392 generic function_body () const { return gen (GEN_MAPSTO, args, body); }
00393 };
00394
00395 routine
00396 closure (const evaluator& ev, const vector<nat>& sig,
00397 const generic& args, const generic& body)
00398 {
00399 return new closure_routine_rep (ev, sig, args, body);
00400 }
00401
00402 generic
00403 mmx_lambda (const generic& x) {
00404 if (N(x) < 3 || N(x) > 4) return wrong_nr_args (x);
00405 vector<generic> args= compound_to_vector (x[1]);
00406 vector<nat> sig= fill<nat> ((nat) 0, N(args));
00407 for (nat i=1; i<N(args); i++)
00408 if (is_func (args[i], GEN_TYPE)) {
00409 generic t= eval (args[i][2]);
00410 if (is<exception> (t)) return t;
00411 nat tid= type_id (t);
00412 if (tid == 1) return type_mismatch (GEN_TYPE_TYPE, args[i][2]);
00413 sig [i]= tid;
00414 args [i]= args[i][1];
00415 }
00416 if (N(x) == 4) {
00417 generic t= eval (x[3]);
00418 if (is<exception> (t)) return t;
00419 nat tid= type_id (t);
00420 if (tid == 1) return type_mismatch (GEN_TYPE_TYPE, x[3]);
00421 sig [0]= tid;
00422 }
00423 generic vars= vector_to_compound (args);
00424 return as<generic> (closure (current_ev, sig, vars, x[2]));
00425 }
00426
00427 generic
00428 mmx_mapsto (const generic& x) {
00429 if (N(x) != 3) return wrong_nr_args (x);
00430 vector<generic> args= vec<generic> (generic (GEN_TUPLE));
00431 if (is_func (x[1], GEN_TUPLE)) args << cdr (compound_to_vector (x[1]));
00432 else args << x[1];
00433 generic vars= vector_to_compound (args);
00434 if (is_func (x[2], GEN_TYPE, 2))
00435 return mmx_lambda (gen (GEN_LAMBDA, vars, x[2][1], x[2][2]));
00436 else return mmx_lambda (gen (GEN_LAMBDA, vars, x[2]));
00437 }
00438
00439 generic
00440 mmx_return (const generic& x) {
00441 if (N(x) == 1)
00442 return as<generic> (exception (gen (GEN_RETURN, void_value ())));
00443 if (N(x) != 2) return wrong_nr_args (x);
00444 generic ret= eval (x[1]);
00445 if (is<exception> (ret)) return ret;
00446 else return as<generic> (exception (gen (GEN_RETURN, ret)));
00447 }
00448
00449
00450
00451
00452
00453 static generic
00454 quote (const generic& x, nat level) {
00455 if (is<compound> (x)) {
00456 if (N(x) == 2 && exact_eq (x[0], GEN_QUOTE))
00457 return gen (x[0], quote (x[1], level+1));
00458 if (N(x) == 2 && exact_eq (x[0], GEN_BACKQUOTE)) {
00459 if (level == 0) return eval (x[1]);
00460 else return gen (x[0], quote (x[1], level-1));
00461 }
00462 else {
00463 const vector<generic> a= compound_to_vector (x);
00464 vector<generic> b= fill<generic> (N(a));
00465 for (nat i=0; i<N(a); i++)
00466 b[i]= quote (a[i], level);
00467 return vector_to_compound (b);
00468 }
00469 }
00470 else return x;
00471 }
00472
00473 generic
00474 mmx_quote (const generic& x) {
00475 if (N(x) != 2) return wrong_nr_args (x);
00476 return quote (x[1], 0);
00477 }
00478
00479 generic
00480 mmx_backquote (const generic& x) {
00481 if (N(x) != 2) return wrong_nr_args (x);
00482 generic r= eval (x[1]);
00483 if (is<exception> (r)) return r;
00484 else return eval (r);
00485 }
00486
00487 generic
00488 mmx_macro (const generic& x) {
00489 if (N(x) != 3) return wrong_nr_args (x);
00490 generic r= mmx_lambda (gen (x[0], x[1], gen (GEN_BACKQUOTE, x[2])));
00491 if (is<routine> (r)) {
00492 routine fun= as<routine> (r);
00493 return as<generic> (primitive (fun));
00494 }
00495 else return r;
00496 }
00497
00498 generic
00499 mmx_define_macro (const generic& x) {
00500 if (N(x) != 3) return wrong_nr_args (x);
00501 if (is<compound> (x[1])) {
00502 generic macro= gen (GEN_MACRO, x[1], x[2]);
00503 return mmx_define_macro (gen (GEN_DEFINE_MACRO, car (x[1]), macro));
00504 }
00505 else {
00506 if (!is<literal> (x[1]))
00507 return type_mismatch (GEN_LITERAL_TYPE, x[1]);
00508 generic r= eval (x[2]);
00509 if (!is<exception> (r))
00510 mmx_set (x[1], r);
00511 return r;
00512 }
00513 }
00514
00515 generic
00516 mmx_assign_macro (const generic& x) {
00517 static string file_var ("current_file");
00518 if (!current_ev->contains (gen (file_var)))
00519 current_ev->set (file_var, as<generic> (string ("")));
00520 string name= as<string> (current_ev->get (gen (file_var)));
00521 if (!ends (name, "basix/mmx/categories.mmx"))
00522 mmerr << "Warning: transcription " << x << " not implemented\n";
00523 return void_value ();
00524 }
00525
00526
00527
00528
00529
00530 routine
00531 mmx_compose_function (const routine& f, const generic& g) {
00532 return compose (f, vec (default_routine (g)));
00533 }
00534
00535 routine
00536 mmx_compose_literal (const literal& f, const generic& g) {
00537 return mmx_compose_function (default_routine (as<generic> (f)), g);
00538 }
00539
00540 routine
00541 mmx_compose_compound (const compound& f, const generic& g) {
00542 return mmx_compose_function (default_routine (as<generic> (f)), g);
00543 }
00544
00545
00546
00547
00548
00549 void
00550 glue_declare () {
00551 define_primitive (GEN_ASSUME, mmx_assume);
00552 define_primitive (GEN_PENALTY, mmx_penalty);
00553 define_primitive (GEN_FORALL, mmx_forall);
00554 define_primitive (GEN_DEFINE, mmx_define);
00555 define_primitive (GEN_ASSIGN, mmx_assign);
00556 define_primitive (GEN_PLUS_ASSIGN, mmx_plus_assign);
00557 define_primitive (GEN_MINUS_ASSIGN, mmx_minus_assign);
00558 define_primitive (GEN_TIMES_ASSIGN, mmx_times_assign);
00559 define_primitive (GEN_OVER_ASSIGN, mmx_over_assign);
00560 define_primitive (GEN_LAMBDA, mmx_lambda);
00561 define_primitive (GEN_MAPSTO, mmx_mapsto);
00562 define_primitive (GEN_RETURN, mmx_return);
00563 define_primitive (GEN_QUOTE, mmx_quote);
00564 define_primitive (GEN_BACKQUOTE, mmx_backquote);
00565 define_primitive (GEN_MACRO, mmx_macro);
00566 define_primitive (GEN_DEFINE_MACRO, mmx_define_macro);
00567 define_primitive (GEN_ASSIGN_MACRO, mmx_assign_macro);
00568 define (GEN_COMPOSE, mmx_compose_function);
00569 define (GEN_COMPOSE, mmx_compose_literal);
00570 define (GEN_COMPOSE, mmx_compose_compound);
00571 define ("matches_category?", matches);
00572 }
00573
00574 }
