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