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/source_track.hpp>
00016 namespace mmx {
00017
00018
00019
00020
00021
00022 generic
00023 mmx_foreign (const generic& x) {
00024 if (N(x) == 4 && x[1] == "cpp" && x[2] == "export")
00025 return eval (x[3]);
00026 return void_value ();
00027 }
00028
00029
00030
00031
00032
00033 generic
00034 mmx_begin (const generic& x) {
00035 nat i, n= N(x);
00036 if (n==1) return void_value ();
00037 for (i=1; i<n-1; i++) {
00038
00039 generic aux= eval (x[i]);
00040 if (is<exception> (aux)) return aux;
00041 }
00042 return eval (x[i]);
00043 }
00044
00045
00046
00047
00048
00049 generic
00050 mmx_seqand (const generic& x) {
00051 if (N(x) != 3) return wrong_nr_args (x);
00052 generic r= eval_as<bool> (x[1]);
00053 if (is<exception> (r) || !as<bool> (r)) return r;
00054 return eval_as<bool> (x[2]);
00055 }
00056
00057 generic
00058 mmx_seqor (const generic& x) {
00059 if (N(x) != 3) return wrong_nr_args (x);
00060 generic r= eval_as<bool> (x[1]);
00061 if (is<exception> (r) || as<bool> (r)) return r;
00062 return eval_as<bool> (x[2]);
00063 }
00064
00065 bool
00066 mmx_not (const bool& x) {
00067 return !x;
00068 }
00069
00070 bool
00071 mmx_xor (const bool& x1, const bool& x2) {
00072 return x1 ^ x2;
00073 }
00074
00075
00076
00077
00078
00079 generic
00080 mmx_if (const generic& x) {
00081 if (N(x) < 3 || N(x) > 4) return wrong_nr_args (x);
00082 generic cond= eval_as<bool> (x[1]);
00083 if (is<exception> (cond)) return cond;
00084 if (as<bool> (cond)) return eval (x[2]);
00085 else if (N(x) == 4) return eval (x[3]);
00086 else return void_value ();
00087 }
00088
00089
00090
00091
00092
00093 generic
00094 mmx_loop (const generic& x) {
00095 nat i, n= N(x)-1;
00096 if (n < 1) return wrong_nr_args (x);
00097 bool stop= false;
00098 generic aux, ret= void_value ();
00099 select_evaluator (base_evaluator (current_ev));
00100
00101 table<iterator<generic>, generic> its;
00102 table<nat, generic> tps (0);
00103 for (i=1; i<n; i++)
00104 if (is_func (x[i], GEN_FOR, 1) && is_func (x[i][1], GEN_IN, 2)) {
00105 generic var= x[i][1][1];
00106 if (is_func (var, GEN_TYPE, 2)) {
00107 generic tp= eval (var[2]);
00108 if (is<exception> (tp)) { ret= tp; stop= true; break; }
00109 nat tid= type_id (tp);
00110 if (tid == 1) {
00111 ret= type_mismatch (GEN_TYPE_TYPE, var[2]); stop= true; break; }
00112 var= var[1];
00113 tps [var]= tid;
00114 }
00115 generic val= eval_as<iterator<generic> > (x[i][1][2]);
00116 if (is<exception> (val)) { ret= val; stop= true; break; }
00117 its [var]= as<iterator<generic> > (val);
00118 }
00119 else if (is_func (x[i], GEN_FOR, 1)) {
00120 aux= eval (x[i][1]);
00121 if (is<exception> (aux)) {
00122 stop= true;
00123 ret= aux;
00124 break;
00125 }
00126 }
00127
00128 while (!stop) {
00129 for (i=1; i<n; i++)
00130 if (is_func (x[i], GEN_FOR, 1) && is_func (x[i][1], GEN_IN, 2)) {
00131 generic var= x[i][1][1];
00132 bool typed= is_func (var, GEN_TYPE, 2);
00133 if (typed) var= var[1];
00134 iterator<generic>& it= its [var];
00135 if (done (it)) { stop= true; break; }
00136 aux= *it; ++it;
00137 if (typed) aux= convert_to (aux, read (tps, var), x[i][1][2]);
00138 if (is<exception> (aux)) { ret= aux; stop= true; break; }
00139 current_ev->set (var, aux);
00140 }
00141 else if (is_func (x[i], GEN_WHILE, 1)) {
00142 generic cond= eval_as<bool> (x[i][1]);
00143 if (is<exception> (cond)) { ret= cond; stop= true; break; }
00144 if (!as<bool> (cond)) { stop= true; break; }
00145 }
00146 if (stop) break;
00147
00148 select_evaluator (base_evaluator (current_ev));
00149 aux= eval (x[n]);
00150 restore_evaluator ();
00151
00152 if (is<exception> (aux)) {
00153 generic msg= *as<exception> (aux);
00154 if (exact_eq (msg, gen (GEN_CONTINUE)));
00155 else if (exact_eq (msg, gen (GEN_BREAK))) break;
00156 else { ret= aux; break; }
00157 }
00158
00159 for (i=1; i<n; i++)
00160 if (is_func (x[i], GEN_UNTIL, 1)) {
00161 generic cond= eval_as<bool> (x[i][1]);
00162 if (is<exception> (cond)) { ret= cond; stop= true; break; }
00163 if (as<bool> (cond)) { stop= true; break; }
00164 }
00165 else if (is_func (x[i], GEN_STEP, 1)) {
00166 aux= eval (x[i][1]);
00167 if (is<exception> (aux)) { ret= aux; stop= true; break; }
00168 }
00169 }
00170
00171 restore_evaluator ();
00172 return ret;
00173 }
00174
00175 generic
00176 mmx_break (const generic& x) {
00177 if (N(x) != 1) return wrong_nr_args (x);
00178 return as<generic> (exception (gen (GEN_BREAK)));
00179 }
00180
00181 generic
00182 mmx_continue (const generic& x) {
00183 if (N(x) != 1) return wrong_nr_args (x);
00184 return as<generic> (exception (gen (GEN_CONTINUE)));
00185 }
00186
00187
00188
00189
00190
00191 class count_iterator_rep: public iterator_rep<generic> {
00192 int start, end;
00193 public:
00194 count_iterator_rep (const int& s, const int& e): start (s), end (e) {}
00195 ~count_iterator_rep () {}
00196 protected:
00197 bool is_busy () { return start < end; }
00198 void advance () { start++; }
00199 generic current () { return as<generic> (start); }
00200 iterator_rep<generic>* clone () {
00201 return new count_iterator_rep (start, end); }
00202 };
00203
00204 static iterator<generic>
00205 count_iterator (const int& start, const int& end) {
00206 return iterator<generic> (new count_iterator_rep (start, end));
00207 }
00208
00209 generic
00210 mmx_count (const int& end) {
00211 return as<generic> (count_iterator (0, end));
00212 }
00213
00214 generic
00215 mmx_range (const generic& start, const generic& end) {
00216 return as<generic> (range_iterator<generic> (start, end, 1, true));
00217 }
00218
00219 generic
00220 mmx_to (const generic& start, const generic& end) {
00221 return as<generic> (range_iterator<generic> (start, end, 1, false));
00222 }
00223
00224 generic
00225 mmx_downto (const generic& start, const generic& end) {
00226 return as<generic> (range_iterator<generic> (start, end, -1, false));
00227 }
00228
00229
00230
00231
00232
00233 class extract_iterator_rep: public iterator_rep<generic> {
00234 evaluator ev;
00235 generic var;
00236 iterator<generic> it;
00237 generic cond;
00238 generic body;
00239 generic value;
00240
00241 void spool () {
00242 select_evaluator (ev);
00243 while (busy (it)) {
00244 generic val= *it;
00245 current_ev->set (var, val);
00246 generic ok= eval_as<bool> (cond);
00247 if (is<exception> (ok)) {
00248 value= ok;
00249 break;
00250 }
00251 else if (as<bool> (ok)) {
00252 value= eval (body);
00253 break;
00254 }
00255 else ++it;
00256 }
00257 restore_evaluator ();
00258 if (done (it)) value= void_value ();
00259 }
00260
00261 public:
00262 extract_iterator_rep (const evaluator& e, const generic& v,
00263 const iterator<generic>& i, const generic& c,
00264 const generic& b):
00265 ev (e), var (v), it (i), cond (c), body (b) { spool (); }
00266 ~extract_iterator_rep () {
00267
00268
00269
00270
00271
00272
00273
00274
00275 }
00276
00277 protected:
00278 bool is_busy () { return busy (it); }
00279 void advance () { ++it; spool(); }
00280 generic current () { return value; }
00281 iterator_rep<generic>* clone () {
00282 extract_iterator_rep* rep=
00283 new extract_iterator_rep (ev, var, it, cond, body);
00284 rep->value= value;
00285 return rep;
00286 }
00287 };
00288
00289
00290 inline iterator<generic>
00291 extract_iterator (const evaluator& ev, const generic& var,
00292 const iterator<generic>& it, const generic& cond,
00293 const generic& v)
00294 {
00295 return iterator<generic> (new extract_iterator_rep (ev, var, it, cond, v));
00296 }
00297
00298 class unnest_iterator_rep: public iterator_rep<generic> {
00299 iterator<generic> it;
00300 iterator<generic> subit;
00301
00302 void spool () {
00303 while (busy (it)) {
00304 generic val= *it; ++it;
00305 if (!is<exception> (val) && !is<iterator<generic> > (val))
00306 val= type_mismatch (gen (GEN_GENERATOR_TYPE, GEN_GENERIC_TYPE), val);
00307 if (is<exception> (val)) subit= seq<generic> (val);
00308 else subit= as<iterator<generic> > (val);
00309 if (busy (subit)) break;
00310 }
00311 }
00312
00313 public:
00314 unnest_iterator_rep (const iterator<generic>& i):
00315 it (i) { spool (); }
00316 unnest_iterator_rep (const iterator<generic>& i, const iterator<generic>& j):
00317 it (i), subit (j) {}
00318 ~unnest_iterator_rep () {}
00319
00320 protected:
00321 bool is_busy () { return busy (subit); }
00322 void advance () { ++subit; if (done (subit)) spool(); }
00323 generic current () { return *subit; }
00324 iterator_rep<generic>* clone () {
00325 unnest_iterator_rep* rep= new unnest_iterator_rep (it, subit);
00326 return rep;
00327 }
00328 };
00329
00330 inline iterator<generic>
00331 unnest_iterator (const iterator<generic>& it) {
00332 return iterator<generic> (new unnest_iterator_rep (it));
00333 }
00334
00335 generic
00336 mmx_where (const generic& x) {
00337 nat i, n= N(x);
00338 if (n < 3) return wrong_nr_args (x);
00339 if (is_func (x[1], GEN_IN, 2)) {
00340
00341
00342 return mmx_where (append (gen (x[0], x[1][1], x[1]), range (x, 2, N(x))));
00343 }
00344 if (!is_func (x[2], GEN_IN, 2))
00345 return std_exception ("'variable in generator' expected", x[2]);
00346 for (i=3; i<n; i++)
00347 if (is_func (x[i], GEN_IN, 2))
00348 break;
00349 if (i == n) {
00350 generic cond= GEN_TRUE;
00351 if (i > 3) {
00352 cond= x[i-1];
00353 for (nat j=i-2; j>=3; j--)
00354 cond= gen (GEN_SEQAND, x[j], cond);
00355 }
00356 generic body= x[1];
00357 generic var = x[2][1];
00358 if (is_func (var, GEN_TYPE, 2)) {
00359
00360 var = var[1];
00361 }
00362 if (!is<literal> (var)) return type_mismatch (GEN_LITERAL_TYPE, var);
00363 generic val= eval_as<iterator<generic> > (x[2][2]);
00364 if (is<exception> (val)) return val;
00365 evaluator ev= base_evaluator (current_ev);
00366 iterator<generic> it= as<iterator<generic> > (val);
00367 iterator<generic> r = extract_iterator (ev, var, it, cond, body);
00368 generic ret= as<generic> (r);
00369 return ret;
00370 }
00371 else {
00372 generic inner= append (gen (x[0], x[1]), range (x, i, n));
00373 generic outer= append (gen (x[0], inner), range (x, 2, i));
00374 generic it= mmx_where (outer);
00375 if (is<exception> (it)) return it;
00376 return as<generic> (unnest_iterator (as<iterator<generic> > (it)));
00377 }
00378 }
00379
00380
00381
00382
00383
00384 tuple<generic>
00385 mmx_fill (const generic& x, const int& nr) {
00386 ASSERT (nr >= 0, "positive integer expected");
00387 return as_tuple (fill<generic> (x, nr));
00388 }
00389
00390 tuple<generic>
00391 mmx_tuple (const tuple<generic>& t) {
00392 return t;
00393 }
00394
00395 iterator<generic>
00396 mmx_explode (const iterator<generic>& it) {
00397 return it;
00398 }
00399
00400 generic
00401 mmx_protect (const generic& x) {
00402 if (N(x) != 2) return wrong_nr_args (x);
00403 generic it= eval (x[1]);
00404 if (is<exception> (it)) return it;
00405 else return gen ("protect", it);
00406 }
00407
00408 generic
00409 mmx_unprotect (const generic& x) {
00410 if (N(x) != 2) return wrong_nr_args (x);
00411 generic it= eval (x[1]);
00412 if (is<compound> (it) && N(it) == 2 && it[0] == "protect") return it[1];
00413 return std_exception ("protected generator expected", x[1]);
00414 }
00415
00416
00417
00418
00419
00420 extern nat backtrace_depth;
00421
00422 class backtrace_depth_rep: public alias_rep<int> {
00423 MMX_ALLOCATORS
00424 int prec;
00425 public:
00426 inline backtrace_depth_rep () {}
00427 int get () const { return backtrace_depth; }
00428 int& open () const { return *((int*) ((void*) (&backtrace_depth))); }
00429 void close () const {}
00430 };
00431
00432 class var_exception {
00433 MMX_ALLOCATORS
00434 generic rep;
00435 public:
00436 inline generic operator * () const { return rep; }
00437 inline var_exception (const generic& g): rep (g) {}
00438 };
00439
00440 inline syntactic flatten (const var_exception& e) { return flatten (*e); }
00441 WRAP_INDIRECT_IMPL(inline,var_exception)
00442
00443 var_exception
00444 mmx_exception (const string& msg, const generic& where) {
00445 return var_exception (std_exception (msg, where));
00446 }
00447
00448 string
00449 mmx_exception_as_string (const var_exception& exc) {
00450 return source_exception (as<exception> (*exc));
00451 }
00452
00453 generic
00454 mmx_try (const generic& x) {
00455 if (N(x) < 2) return wrong_nr_args (x);
00456
00457 generic body= x[1];
00458 if (!is_func (body, GEN_BEGIN)) body= gen (GEN_BEGIN, body);
00459 vector<generic> v= compound_to_vector (x);
00460 v= range (v, 2, N(v));
00461 v << cdr (compound_to_vector (body));
00462 body= gen (GEN_BEGIN, v);
00463
00464 select_evaluator (base_evaluator (current_ev));
00465 generic r= eval (body);
00466 if (is<exception> (r)) {
00467 generic err= *as<exception> (r), ret;
00468 if (is<vector<generic> > (err[1]))
00469 ret= current_ev->apply (GEN_CATCH, as<vector<generic> > (err[1]));
00470 else ret= current_ev->apply (GEN_CATCH, as<generic> (var_exception (r)));
00471 if (!is_func (ret, GEN_CATCH)) r= ret;
00472 }
00473 restore_evaluator ();
00474
00475 return r;
00476 }
00477
00478 generic
00479 mmx_raise (const generic& x) {
00480 vector<generic> args;
00481 for (nat i=1; i<N(x); i++) {
00482 generic r= eval (x[i]);
00483 if (is<exception> (r)) return r;
00484 else args << r;
00485 }
00486 if (N(args) == 1 && is<var_exception> (args[0]))
00487 return *as<var_exception> (args[0]);
00488 else return user_exception (args, x);
00489 }
00490
00491
00492
00493
00494
00495 void
00496 glue_control () {
00497 static alias<int> depth= new backtrace_depth_rep ();
00498 define_constant<alias<int> > ("backtrace_depth", depth);
00499 define_type<var_exception> ("Exception");
00500 define_type<iterator<generic> > (gen("Generator",generic("Generic")));
00501 define_primitive (GEN_FOREIGN, mmx_foreign);
00502 define_primitive (GEN_BEGIN, mmx_begin);
00503 define_primitive (GEN_SEQAND, mmx_seqand);
00504 define_primitive (GEN_SEQOR, mmx_seqor);
00505 define (GEN_NOT, mmx_not);
00506 define (GEN_XOR, mmx_xor);
00507 define_primitive (GEN_IF, mmx_if);
00508 define_primitive (GEN_LOOP, mmx_loop);
00509 define_primitive (GEN_BREAK, mmx_break);
00510 define_primitive (GEN_CONTINUE, mmx_continue);
00511 define (GEN_RANGE, mmx_range);
00512 define ("count", mmx_count);
00513 define (GEN_TO, mmx_to);
00514 define (GEN_DOWNTO, mmx_downto);
00515 define_primitive (GEN_WHERE, mmx_where);
00516 define_primitive (GEN_VWHERE, mmx_where);
00517 define (GEN_FILL, mmx_fill);
00518 define (GEN_TUPLE, mmx_tuple);
00519 define (GEN_EXPLODE, mmx_explode);
00520 define_primitive ("protect", mmx_protect);
00521 define_primitive ("unprotect", mmx_unprotect);
00522 define ("exception", mmx_exception);
00523 define ("as_string", mmx_exception_as_string);
00524 define_primitive (GEN_TRY, mmx_try);
00525 define_primitive (GEN_RAISE, mmx_raise);
00526 }
00527
00528 }