Back to index

texmacs  1.0.7.15
glue.cpp
Go to the documentation of this file.
00001 
00002 /******************************************************************************
00003 * MODULE     : glue.cpp
00004 * DESCRIPTION: Glue for linking TeXmacs commands to scheme
00005 * COPYRIGHT  : (C) 1999-2011  Joris van der Hoeven and Massimiliano Gubinelli
00006 *******************************************************************************
00007 * This software falls under the GNU general public license version 3 or later.
00008 * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
00009 * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
00010 ******************************************************************************/
00011 
00012 #include "glue.hpp"
00013 
00014 #include "promise.hpp"
00015 #include "tree.hpp"
00016 
00017 #include "boxes.hpp"
00018 #include "editor.hpp"
00019 #include "analyze.hpp"
00020 #include "convert.hpp"
00021 #include "file.hpp"
00022 #include "tmfs.hpp"
00023 
00024 tmscm 
00025 blackboxP (tmscm  t) {
00026   bool b= tmscm_is_blackbox (t);
00027   return bool_to_tmscm (b);
00028 }
00029 
00030 #if 0
00031 template<class T> tmscm  box_to_tmscm (T o) {
00032   return blackbox_to_tmscm (close_box<T> (o)); }
00033 template<class T> T tmscm_to_box (tmscm  obj) { 
00034   return open_box<T>(tmscm_to_blackbox (obj));  }
00035 template<class T> tmscm  cmp_box (tmscm  o1, tmscm  o2) { 
00036   return bool_to_tmscm (tmscm_to_box<T> (o1) == tmscm_to_box<T> (o2)); }
00037 template<class T> tmscm  boxP (tmscm  t) {
00038   bool b= tmscm_is_blackbox (t) && 
00039           (type_box (blackboxvalue(t)) == type_helper<T>::id);
00040   return bool_to_tmscm (b);
00041 }
00042 #endif
00043 
00044 /******************************************************************************
00045 * Miscellaneous routines for use by glue only
00046 ******************************************************************************/
00047 
00048 string
00049 texmacs_version (string which) {
00050   if (which == "tgz") return TM_DEVEL;
00051   if (which == "rpm") return TM_DEVEL_RELEASE;
00052   if (which == "stgz") return TM_STABLE;
00053   if (which == "srpm") return TM_STABLE_RELEASE;
00054   if (which == "devel") return TM_DEVEL;
00055   if (which == "stable") return TM_STABLE;
00056   if (which == "devel-release") return TM_DEVEL_RELEASE;
00057   if (which == "stable-release") return TM_STABLE_RELEASE;
00058   return TEXMACS_VERSION;
00059 }
00060 
00061 void
00062 set_fast_environments (bool b) {
00063   enable_fastenv= b;
00064 }
00065 
00066 void
00067 win32_display (string s) {
00068   cout << s;
00069   cout.flush ();
00070 }
00071 
00072 void
00073 tm_output (string s) {
00074   cout << s;
00075   cout.flush ();
00076 }
00077 
00078 void
00079 tm_errput (string s) {
00080   cerr << s;
00081   cerr.flush ();
00082 }
00083 
00084 void
00085 cpp_error () {
00086   //char *np= 0; *np= 1;
00087   FAILED ("an error occurred");
00088 }
00089 
00090 array<int>
00091 get_bounding_rectangle (tree t) {
00092   editor ed= get_server () -> get_editor ();
00093   rectangle wr= ed -> get_window_extents ();
00094   path p= reverse (obtain_ip (t));
00095   selection sel= ed->search_selection (p * 0, p * right_index (t));
00096   rectangle selr= least_upper_bound (sel->rs) / 5;
00097   rectangle r= translate (selr, wr->x1, wr->y2);
00098   array<int> ret;
00099   ret << (r->x1) << (r->y1) << (r->x2) << (r->y2);
00100   //ret << (r->x1/PIXEL) << (r->y1/PIXEL) << (r->x2/PIXEL) << (r->y2/PIXEL);
00101   return ret;
00102 }
00103 
00104 /******************************************************************************
00105 * Redirections
00106 ******************************************************************************/
00107 
00108 void
00109 cout_buffer () {
00110   cout.buffer ();
00111 }
00112 
00113 string
00114 cout_unbuffer () {
00115   return cout.unbuffer ();
00116 }
00117 
00118 /******************************************************************************
00119 * Basic assertions
00120 ******************************************************************************/
00121 
00122 #define TMSCM_ASSERT_STRING(s,arg,rout) \
00123 TMSCM_ASSERT (tmscm_is_string (s), s, arg, rout)
00124 #define TMSCM_ASSERT_BOOL(flag,arg,rout) \
00125 TMSCM_ASSERT (tmscm_is_bool (flag), flag, arg, rout)
00126 #define TMSCM_ASSERT_INT(i,arg,rout) \
00127 TMSCM_ASSERT (tmscm_is_int (i), i, arg, rout);
00128 #define TMSCM_ASSERT_DOUBLE(i,arg,rout) \
00129   TMSCM_ASSERT (tmscm_is_double (i), i, arg, rout);
00130 //TMSCM_ASSERT (SCM_REALP (i), i, arg, rout);
00131 #define TMSCM_ASSERT_URL(u,arg,rout) \
00132 TMSCM_ASSERT (tmscm_is_url (u) || tmscm_is_string (u), u, arg, rout)
00133 #define TMSCM_ASSERT_BLACKBOX(t,arg,rout) \
00134 TMSCM_ASSERT (tmscm_is_blackbox (t), t, arg, rout)
00135 #define TMSCM_ASSERT_SYMBOL(s,arg,rout) \
00136   TMSCM_ASSERT (tmscm_is_symbol (s), s, arg, rout)
00137 //TMSCM_ASSERT (SCM_NFALSEP (tmscm_symbol_p (s)), s, arg, rout)
00138 
00139 #define TMSCM_ASSERT_OBJECT(a,b,c)
00140 // no check
00141 
00142 /******************************************************************************
00143 * Tree labels
00144 ******************************************************************************/
00145 
00146 #define TMSCM_ASSERT_TREE_LABEL(p,arg,rout) TMSCM_ASSERT_SYMBOL(p,arg,rout)
00147 
00148 tmscm 
00149 tree_label_to_tmscm (tree_label l) {
00150   string s= as_string (l);
00151   return symbol_to_tmscm (s);
00152 }
00153 
00154 tree_label
00155 tmscm_to_tree_label (tmscm  p) {
00156   string s= tmscm_to_symbol (p);
00157   return make_tree_label (s);
00158 }
00159 
00160 /******************************************************************************
00161 * Trees
00162 ******************************************************************************/
00163 
00164 #define TMSCM_ASSERT_TREE(t,arg,rout) TMSCM_ASSERT (tmscm_is_tree (t), t, arg, rout)
00165 
00166 
00167 bool
00168 tmscm_is_tree (tmscm  u) {
00169   return (tmscm_is_blackbox (u) && 
00170          (type_box (tmscm_to_blackbox(u)) == type_helper<tree>::id));
00171 }
00172 
00173 tmscm 
00174 tree_to_tmscm (tree o) {
00175   return blackbox_to_tmscm (close_box<tree> (o));
00176 }
00177 
00178 tree
00179 tmscm_to_tree (tmscm  obj) {
00180   return open_box<tree>(tmscm_to_blackbox (obj));
00181 }
00182 
00183 tmscm 
00184 treeP (tmscm  t) {
00185   bool b= tmscm_is_blackbox (t) && 
00186           (type_box (tmscm_to_blackbox(t)) == type_helper<tree>::id);
00187   return bool_to_tmscm (b);
00188 }
00189 
00190 tree
00191 coerce_string_tree (string s) {
00192   return s;
00193 }
00194 
00195 string
00196 coerce_tree_string (tree t) {
00197   return as_string (t);
00198 }
00199 
00200 tree
00201 tree_ref (tree t, int i) {
00202   return t[i];
00203 }
00204 
00205 tree
00206 tree_set (tree t, int i, tree u) {
00207   t[i]= u;
00208   return u;
00209 }
00210 
00211 tree
00212 tree_range (tree t, int i, int j) {
00213   return t(i,j);
00214 }
00215 
00216 tree
00217 tree_append (tree t1, tree t2) {
00218   return t1 * t2;
00219 }
00220 
00221 bool
00222 tree_active (tree t) {
00223   path ip= obtain_ip (t);
00224   return is_nil (ip) || last_item (ip) != DETACHED;
00225 }
00226 
00227 tree
00228 tree_child_insert (tree t, int pos, tree x) {
00229   //cout << "t= " << t << "\n";
00230   //cout << "x= " << x << "\n";
00231   int i, n= N(t);
00232   tree r (t, n+1);
00233   for (i=0; i<pos; i++) r[i]= t[i];
00234   r[pos]= x;
00235   for (i=pos; i<n; i++) r[i+1]= t[i];
00236   return r;
00237 }
00238 
00239 /******************************************************************************
00240 * Document modification routines
00241 ******************************************************************************/
00242 
00243 extern tree the_et;
00244 
00245 tree
00246 tree_assign (tree r, tree t) {
00247   path ip= copy (obtain_ip (r));
00248   if (ip_attached (ip)) {
00249     assign (reverse (ip), copy (t));
00250     return subtree (the_et, reverse (ip));
00251   }
00252   else {
00253     assign (r, copy (t));
00254     return r;
00255   }
00256 }
00257 
00258 tree
00259 tree_insert (tree r, int pos, tree t) {
00260   path ip= copy (obtain_ip (r));
00261   if (ip_attached (ip)) {
00262     insert (reverse (path (pos, ip)), copy (t));
00263     return subtree (the_et, reverse (ip));
00264   }
00265   else {
00266     insert (r, pos, copy (t));
00267     return r;
00268   }
00269 }
00270 
00271 tree
00272 tree_remove (tree r, int pos, int nr) {
00273   path ip= copy (obtain_ip (r));
00274   if (ip_attached (ip)) {
00275     remove (reverse (path (pos, ip)), nr);
00276     return subtree (the_et, reverse (ip));
00277   }
00278   else {
00279     remove (r, pos, nr);
00280     return r;
00281   }
00282 }
00283 
00284 tree
00285 tree_split (tree r, int pos, int at) {
00286   path ip= copy (obtain_ip (r));
00287   if (ip_attached (ip)) {
00288     split (reverse (path (at, pos, ip)));
00289     return subtree (the_et, reverse (ip));
00290   }
00291   else {
00292     split (r, pos, at);
00293     return r;
00294   }
00295 }
00296 
00297 tree
00298 tree_join (tree r, int pos) {
00299   path ip= copy (obtain_ip (r));
00300   if (ip_attached (ip)) {
00301     join (reverse (path (pos, ip)));
00302     return subtree (the_et, reverse (ip));
00303   }
00304   else {
00305     join (r, pos);
00306     return r;
00307   }
00308 }
00309 
00310 tree
00311 tree_assign_node (tree r, tree_label op) {
00312   path ip= copy (obtain_ip (r));
00313   if (ip_attached (ip)) {
00314     assign_node (reverse (ip), op);
00315     return subtree (the_et, reverse (ip));
00316   }
00317   else {
00318     assign_node (r, op);
00319     return r;
00320   }
00321 }
00322 
00323 tree
00324 tree_insert_node (tree r, int pos, tree t) {
00325   path ip= copy (obtain_ip (r));
00326   if (ip_attached (ip)) {
00327     insert_node (reverse (path (pos, ip)), copy (t));
00328     return subtree (the_et, reverse (ip));
00329   }
00330   else {
00331     insert_node (r, pos, copy (t));
00332     return r;
00333   }
00334 }
00335 
00336 tree
00337 tree_remove_node (tree r, int pos) {
00338   path ip= copy (obtain_ip (r));
00339   if (ip_attached (ip)) {
00340     remove_node (reverse (path (pos, ip)));
00341     return subtree (the_et, reverse (ip));
00342   }
00343   else {
00344     remove_node (r, pos);
00345     return r;
00346   }
00347 }
00348 
00349 /******************************************************************************
00350 * Scheme trees
00351 ******************************************************************************/
00352 
00353 #define TMSCM_ASSERT_SCHEME_TREE(p,arg,rout)
00354 
00355 tmscm 
00356 scheme_tree_to_tmscm (scheme_tree t) {
00357   if (is_atomic (t)) {
00358     string s= t->label;
00359     if (s == "#t") return tmscm_true ();
00360     if (s == "#f") return tmscm_false ();
00361     if (is_int (s)) return int_to_tmscm (as_int (s));
00362     if (is_quoted (s))
00363       return string_to_tmscm (scm_unquote (s));
00364     //if ((N(s)>=2) && (s[0]=='\42') && (s[N(s)-1]=='\42'))
00365     //return string_to_tmscm (s (1, N(s)-1));
00366     return symbol_to_tmscm (s);
00367   }
00368   else {
00369     int i;
00370     tmscm  p= tmscm_null ();
00371     for (i=N(t)-1; i>=0; i--)
00372       p= tmscm_cons (scheme_tree_to_tmscm (t[i]), p);
00373     return p;
00374   }
00375 }
00376 
00377 scheme_tree
00378 tmscm_to_scheme_tree (tmscm  p) {
00379   if (tmscm_is_list (p)) {
00380     tree t (TUPLE);
00381     while (!tmscm_is_null (p)) {
00382       t << tmscm_to_scheme_tree (tmscm_car (p));
00383       p= tmscm_cdr (p);
00384     }
00385     return t;
00386   }
00387   if (tmscm_is_symbol (p)) return tmscm_to_symbol (p);
00388   if (tmscm_is_string (p)) return scm_quote (tmscm_to_string (p));
00389   //if (tmscm_is_string (p)) return "\"" * tmscm_to_string (p) * "\"";
00390   if (tmscm_is_int (p)) return as_string ((int) tmscm_to_int (p));
00391   if (tmscm_is_bool (p)) return (tmscm_to_bool (p)? string ("#t"): string ("#f"));
00392   if (tmscm_is_tree (p)) return tree_to_scheme_tree (tmscm_to_tree (p));
00393   return "?";
00394 }
00395 
00396 /******************************************************************************
00397 * Content
00398 ******************************************************************************/
00399 
00400 bool
00401 tmscm_is_content (tmscm  p) {
00402   if (tmscm_is_string (p) || tmscm_is_tree (p)) return true;
00403   else if (!tmscm_is_pair (p) || !tmscm_is_symbol (tmscm_car (p))) return false;
00404   else {
00405     for (p= tmscm_cdr (p); !tmscm_is_null (p); p= tmscm_cdr (p))
00406       if (!tmscm_is_content (tmscm_car (p))) return false;
00407     return true;
00408   }
00409 }
00410 
00411 #define content tree
00412 #define TMSCM_ASSERT_CONTENT(p,arg,rout) \
00413    TMSCM_ASSERT (tmscm_is_content (p), p, arg, rout)
00414 #define content_to_tmscm tree_to_tmscm
00415 
00416 tree
00417 tmscm_to_content (tmscm  p) {
00418   if (tmscm_is_string (p)) return tmscm_to_string (p);
00419   if (tmscm_is_tree (p)) return tmscm_to_tree (p);
00420   if (tmscm_is_pair (p)) {
00421     if (!tmscm_is_symbol (tmscm_car (p))) return "?";
00422     tree t (make_tree_label (tmscm_to_symbol (tmscm_car (p))));
00423     p= tmscm_cdr (p);
00424     while (!tmscm_is_null (p)) {
00425       t << tmscm_to_content (tmscm_car (p));
00426       p= tmscm_cdr (p);
00427     }
00428     return t;
00429   }
00430   return "?";
00431 }
00432 
00433 tmscm 
00434 contentP (tmscm  t) {
00435   bool b= tmscm_is_content (t);
00436   return bool_to_tmscm (b);
00437 }
00438 
00439 /******************************************************************************
00440 * Paths
00441 ******************************************************************************/
00442 
00443 bool
00444 tmscm_is_path (tmscm  p) {
00445   if (tmscm_is_null (p)) return true;
00446   else return tmscm_is_int (tmscm_car (p)) && tmscm_is_path (tmscm_cdr (p));
00447 }
00448 
00449 #define TMSCM_ASSERT_PATH(p,arg,rout) \
00450 TMSCM_ASSERT (tmscm_is_path (p), p, arg, rout)
00451 
00452 tmscm 
00453 path_to_tmscm (path p) {
00454   if (is_nil (p)) return tmscm_null ();
00455   else return tmscm_cons (int_to_tmscm (p->item), path_to_tmscm (p->next));
00456 }
00457 
00458 path
00459 tmscm_to_path (tmscm  p) {
00460   if (tmscm_is_null (p)) return path ();
00461   else return path ((int) tmscm_to_int (tmscm_car (p)), 
00462                           tmscm_to_path (tmscm_cdr (p)));
00463 }
00464 
00465 
00466 /******************************************************************************
00467 * Observers
00468 ******************************************************************************/
00469 
00470 #define TMSCM_ASSERT_OBSERVER(o,arg,rout) \
00471 TMSCM_ASSERT (tmscm_is_observer (o), o, arg, rout)
00472 
00473 
00474 bool
00475 tmscm_is_observer (tmscm  o) {
00476   return (tmscm_is_blackbox (o) &&
00477          (type_box (tmscm_to_blackbox(o)) == type_helper<observer>::id));
00478 }
00479 
00480 tmscm 
00481 observer_to_tmscm (observer o) {
00482   return blackbox_to_tmscm (close_box<observer> (o));
00483 }
00484 
00485 static observer
00486 tmscm_to_observer (tmscm  obj) {
00487   return open_box<observer>(tmscm_to_blackbox (obj));
00488 }
00489 
00490 tmscm 
00491 observerP (tmscm  t) {
00492   bool b= tmscm_is_blackbox (t) && 
00493   (type_box (tmscm_to_blackbox(t)) == type_helper<observer>::id);
00494   return bool_to_tmscm (b);
00495 }
00496 
00497 
00498 /******************************************************************************
00499 * Widgets
00500 ******************************************************************************/
00501 
00502 #define TMSCM_ASSERT_WIDGET(o,arg,rout) \
00503 TMSCM_ASSERT (tmscm_is_widget (o), o, arg, rout)
00504 
00505 bool
00506 tmscm_is_widget (tmscm  u) {
00507   return (tmscm_is_blackbox (u) &&
00508          (type_box (tmscm_to_blackbox(u)) == type_helper<widget>::id));
00509 }
00510 
00511 
00512 static tmscm 
00513 widget_to_tmscm (widget o) {
00514   return blackbox_to_tmscm (close_box<widget> (o));
00515 }
00516 
00517 widget
00518 tmscm_to_widget (tmscm  o) {
00519   return open_box<widget> (tmscm_to_blackbox (o));
00520 }
00521 
00522 /******************************************************************************
00523 * Commands
00524 ******************************************************************************/
00525 
00526 #define TMSCM_ASSERT_COMMAND(o,arg,rout) \
00527 TMSCM_ASSERT (tmscm_is_command (o), o, arg, rout)
00528 
00529 bool
00530 tmscm_is_command (tmscm  u) {
00531   return (tmscm_is_blackbox (u) && 
00532       (type_box (tmscm_to_blackbox(u)) == type_helper<command>::id));
00533 }
00534 
00535 static tmscm 
00536 command_to_tmscm (command o) {
00537   return blackbox_to_tmscm (close_box<command> (o));
00538 }
00539 
00540 static command
00541 tmscm_to_command (tmscm  o) {
00542   return open_box<command> (tmscm_to_blackbox (o));
00543 }
00544 
00545 
00546 /******************************************************************************
00547 *  Widget Factory
00548 ******************************************************************************/
00549 
00550 typedef promise<widget> promise_widget;
00551 
00552 #define TMSCM_ASSERT_PROMISE_WIDGET(o,arg,rout) \
00553 TMSCM_ASSERT (tmscm_is_promise_widget (o), o, arg, rout)
00554 
00555 bool
00556 tmscm_is_promise_widget (tmscm  u) {
00557   return (tmscm_is_blackbox (u) && 
00558          (type_box (tmscm_to_blackbox(u)) == type_helper<promise_widget>::id));
00559 }
00560 
00561 
00562 
00563 static tmscm 
00564 promise_widget_to_tmscm (promise_widget o) {
00565   return blackbox_to_tmscm (close_box<promise_widget> (o));
00566 }
00567 
00568 static promise_widget
00569 tmscm_to_promise_widget (tmscm  o) {
00570   return open_box<promise_widget> (tmscm_to_blackbox (o));
00571 }
00572 
00573 /******************************************************************************
00574 * Urls
00575 ******************************************************************************/
00576 
00577 bool
00578 tmscm_is_url (tmscm  u) {
00579   return (tmscm_is_blackbox (u)
00580               && (type_box (tmscm_to_blackbox(u)) == type_helper<url>::id))
00581          || (tmscm_is_string(u));
00582 }
00583 
00584 tmscm 
00585 url_to_tmscm (url u) {
00586   return blackbox_to_tmscm (close_box<url> (u));
00587 }
00588 
00589 url
00590 tmscm_to_url (tmscm  obj) {
00591   if (tmscm_is_string (obj))
00592 #ifdef __MINGW32__
00593     return url_system (tmscm_to_string (obj));
00594 #else
00595   return tmscm_to_string (obj);
00596 #endif
00597   return open_box<url> (tmscm_to_blackbox (obj));
00598 }
00599 
00600 tmscm 
00601 urlP (tmscm  t) {
00602   bool b= tmscm_is_url (t);
00603   return bool_to_tmscm (b);
00604 }
00605 
00606 url url_concat (url u1, url u2) { return u1 * u2; }
00607 url url_or (url u1, url u2) { return u1 | u2; }
00608 void string_save (string s, url u) { (void) save_string (u, s); }
00609 string string_load (url u) {
00610   string s; (void) load_string (u, s, false); return s; }
00611 url url_ref (url u, int i) { return u[i]; }
00612 
00613 
00614 /******************************************************************************
00615 * Table types
00616 ******************************************************************************/
00617 
00618 typedef hashmap<string,string> table_string_string;
00619 
00620 static bool
00621 tmscm_is_table_string_string (tmscm  p) {
00622   if (tmscm_is_null (p)) return true;
00623   else if (!tmscm_is_pair (p)) return false;
00624   else {
00625     tmscm  f= tmscm_car (p);
00626     return tmscm_is_pair (f) &&
00627     tmscm_is_string (tmscm_car (f)) &&
00628     tmscm_is_string (tmscm_cdr (f)) &&
00629     tmscm_is_table_string_string (tmscm_cdr (p));
00630   }
00631 }
00632 
00633 #define TMSCM_ASSERT_TABLE_STRING_STRING(p,arg,rout) \
00634 TMSCM_ASSERT (tmscm_is_table_string_string (p), p, arg, rout)
00635 
00636 tmscm 
00637 table_string_string_to_tmscm (hashmap<string,string> t) {
00638   tmscm  p= tmscm_null ();
00639   iterator<string> it= iterate (t);
00640   while (it->busy ()) {
00641     string s= it->next ();
00642     tmscm  n= tmscm_cons (string_to_tmscm (s), string_to_tmscm (t[s]));
00643     p= tmscm_cons (n, p);
00644   }
00645   return p;
00646 }
00647 
00648 hashmap<string,string>
00649 tmscm_to_table_string_string (tmscm  p) {
00650   hashmap<string,string> t;
00651   while (!tmscm_is_null (p)) {
00652     tmscm  n= tmscm_car (p);
00653     t (tmscm_to_string (tmscm_car (n)))= tmscm_to_string (tmscm_cdr (n));
00654     p= tmscm_cdr (p);
00655   }
00656   return t;
00657 }
00658 
00659 #define tmscm_is_solution tmscm_is_table_string_string
00660 #define TMSCM_ASSERT_SOLUTION(p,arg,rout) \
00661 TMSCM_ASSERT (tmscm_is_solution(p), p, arg, rout)
00662 #define solution_to_tmscm table_string_string_to_tmscm
00663 #define tmscm_to_solution tmscm_to_table_string_string
00664 
00665 /******************************************************************************
00666 * Several array types
00667 ******************************************************************************/
00668 
00669 typedef array<int> array_int;
00670 typedef array<string> array_string;
00671 typedef array<tree> array_tree;
00672 typedef array<widget> array_widget;
00673 typedef array<double> array_double;
00674 typedef array<array<double> > array_array_double;
00675 typedef array<array<array<double> > > array_array_array_double;
00676 
00677 static bool
00678 tmscm_is_array_int (tmscm  p) {
00679   if (tmscm_is_null (p)) return true;
00680   else return tmscm_is_pair (p) &&
00681     tmscm_is_int (tmscm_car (p)) &&
00682     tmscm_is_array_int (tmscm_cdr (p));
00683 }
00684 
00685 #define TMSCM_ASSERT_ARRAY_INT(p,arg,rout) \
00686 TMSCM_ASSERT (tmscm_is_array_int (p), p, arg, rout)
00687 
00688 /* static */ tmscm 
00689 array_int_to_tmscm (array<int> a) {
00690   int i, n= N(a);
00691   tmscm  p= tmscm_null ();
00692   for (i=n-1; i>=0; i--) p= tmscm_cons (int_to_tmscm (a[i]), p);
00693   return p;
00694 }
00695 
00696 /* static */ array<int>
00697 tmscm_to_array_int (tmscm  p) {
00698   array<int> a;
00699   while (!tmscm_is_null (p)) {
00700     a << ((int) tmscm_to_int (tmscm_car (p)));
00701     p= tmscm_cdr (p);
00702   }
00703   return a;
00704 }
00705 
00706 static bool
00707 tmscm_is_array_string (tmscm  p) {
00708   if (tmscm_is_null (p)) return true;
00709   else return tmscm_is_pair (p) && 
00710     tmscm_is_string (tmscm_car (p)) &&
00711     tmscm_is_array_string (tmscm_cdr (p));
00712 }
00713 
00714 
00715 static bool
00716 tmscm_is_array_double (tmscm  p) {
00717   if (tmscm_is_null (p)) return true;
00718   else return tmscm_is_pair (p) &&
00719     tmscm_is_double (tmscm_car (p)) &&
00720     tmscm_is_array_double (tmscm_cdr (p));
00721 }
00722 
00723 #define TMSCM_ASSERT_ARRAY_DOUBLE(p,arg,rout) \
00724 TMSCM_ASSERT (tmscm_is_array_double (p), p, arg, rout)
00725 
00726 /* static */ tmscm 
00727 array_double_to_tmscm (array<double> a) {
00728   int i, n= N(a);
00729   tmscm  p= tmscm_null();
00730   for (i=n-1; i>=0; i--) p= tmscm_cons (double_to_tmscm (a[i]), p);
00731   return p;
00732 }
00733 
00734 /* static */ array<double>
00735 tmscm_to_array_double (tmscm  p) {
00736   array<double> a;
00737   while (!tmscm_is_null (p)) {
00738     a << ((double) tmscm_to_double (tmscm_car (p)));
00739     p= tmscm_cdr (p);
00740   }
00741   return a;
00742 }
00743 
00744 static bool
00745 tmscm_is_array_array_double (tmscm   p) {
00746   if (tmscm_is_null (p)) return true;
00747   else return tmscm_is_pair (p) &&
00748     tmscm_is_array_double (tmscm_car (p)) &&
00749     tmscm_is_array_array_double (tmscm_cdr (p));
00750 }
00751 
00752 #define TMSCM_ASSERT_ARRAY_ARRAY_DOUBLE(p,arg,rout) \
00753 TMSCM_ASSERT (tmscm_is_array_array_double (p), p, arg, rout)
00754 
00755 /* static */ tmscm 
00756 array_array_double_to_tmscm (array<array_double> a) {
00757   int i, n= N(a);
00758   tmscm  p= tmscm_null ();
00759   for (i=n-1; i>=0; i--) p= tmscm_cons (array_double_to_tmscm (a[i]), p);
00760   return p;
00761 }
00762 
00763 /* static */ array<array_double>
00764 tmscm_to_array_array_double (tmscm  p) {
00765   array<array_double> a;
00766   while (!tmscm_is_null (p)) {
00767     a << ((array_double) tmscm_to_array_double (tmscm_car (p)));
00768     p= tmscm_cdr (p);
00769   }
00770   return a;
00771 }
00772 
00773 static bool
00774 tmscm_is_array_array_array_double (tmscm  p) {
00775   if (tmscm_is_null (p)) return true;
00776   else return tmscm_is_pair (p) &&
00777     tmscm_is_array_array_double (tmscm_car (p)) &&
00778     tmscm_is_array_array_array_double (tmscm_cdr (p));
00779 }
00780 
00781 #define TMSCM_ASSERT_ARRAY_ARRAY_ARRAY_DOUBLE(p,arg,rout) \
00782 TMSCM_ASSERT (tmscm_is_array_array_array_double (p), p, arg, rout)
00783 
00784 /* static */ tmscm 
00785 array_array_array_double_to_tmscm (array<array_array_double> a) {
00786   int i, n= N(a);
00787   tmscm  p= tmscm_null ();
00788   for (i=n-1; i>=0; i--) p= tmscm_cons (array_array_double_to_tmscm (a[i]), p);
00789   return p;
00790 }
00791 
00792 /* static */ array<array_array_double>
00793 tmscm_to_array_array_array_double (tmscm  p) {
00794   array<array_array_double> a;
00795   while (!tmscm_is_null (p)) {
00796     a << ((array_array_double) tmscm_to_array_array_double (tmscm_car (p)));
00797     p= tmscm_cdr (p);
00798   }
00799   return a;
00800 }
00801 
00802 void register_glyph (string s, array_array_array_double gl);
00803 string recognize_glyph (array_array_array_double gl);
00804 
00805 
00806 
00807 #define TMSCM_ASSERT_ARRAY_STRING(p,arg,rout) \
00808 TMSCM_ASSERT (tmscm_is_array_string (p), p, arg, rout)
00809 
00810 /* static */ tmscm 
00811 array_string_to_tmscm (array<string> a) {
00812   int i, n= N(a);
00813   tmscm  p= tmscm_null ();
00814   for (i=n-1; i>=0; i--) p= tmscm_cons (string_to_tmscm (a[i]), p);
00815   return p;
00816 }
00817 
00818 /* static */ array<string>
00819 tmscm_to_array_string (tmscm  p) {
00820   array<string> a;
00821   while (!tmscm_is_null (p)) {
00822     a << tmscm_to_string (tmscm_car (p));
00823     p= tmscm_cdr (p);
00824   }
00825   return a;
00826 }
00827 
00828 #define tmscm_is_property tmscm_is_array_string
00829 #define TMSCM_ASSERT_PROPERTY(p,arg,rout) TMSCM_ASSERT_ARRAY_STRING (p,arg,rout)
00830 #define property_to_tmscm array_string_to_tmscm
00831 #define tmscm_to_property tmscm_to_array_string
00832 
00833 static bool
00834 tmscm_is_array_tree (tmscm  p) {
00835   if (tmscm_is_null (p)) return true;
00836   else return tmscm_is_pair (p) && 
00837     tmscm_is_tree (tmscm_car (p)) &&
00838     tmscm_is_array_tree (tmscm_cdr (p));
00839 }
00840 
00841 #define TMSCM_ASSERT_ARRAY_TREE(p,arg,rout) \
00842 TMSCM_ASSERT (tmscm_is_array_tree (p), p, arg, rout)
00843 
00844 /* static */ tmscm 
00845 array_tree_to_tmscm (array<tree> a) {
00846   int i, n= N(a);
00847   tmscm  p= tmscm_null ();
00848   for (i=n-1; i>=0; i--) p= tmscm_cons (tree_to_tmscm (a[i]), p);
00849   return p;
00850 }
00851 
00852 /* static */ array<tree>
00853 tmscm_to_array_tree (tmscm  p) {
00854   array<tree> a;
00855   while (!tmscm_is_null (p)) {
00856     a << tmscm_to_tree (tmscm_car (p));
00857     p= tmscm_cdr (p);
00858   }
00859   return a;
00860 }
00861 
00862 static bool
00863 tmscm_is_array_widget (tmscm  p) {
00864   if (tmscm_is_null (p)) return true;
00865   else return tmscm_is_pair (p) &&
00866     tmscm_is_widget (tmscm_car (p)) &&
00867     tmscm_is_array_widget (tmscm_cdr (p));
00868 }
00869 
00870 #define TMSCM_ASSERT_ARRAY_WIDGET(p,arg,rout) \
00871 TMSCM_ASSERT (tmscm_is_array_widget (p), p, arg, rout)
00872 
00873 /* static */ tmscm 
00874 array_widget_to_tmscm (array<widget> a) {
00875   int i, n= N(a);
00876   tmscm  p= tmscm_null ();
00877   for (i=n-1; i>=0; i--) p= tmscm_cons (widget_to_tmscm (a[i]), p);
00878   return p;
00879 }
00880 
00881 /* static */ array<widget>
00882 tmscm_to_array_widget (tmscm  p) {
00883   array<widget> a;
00884   while (!tmscm_is_null (p)) {
00885     a << tmscm_to_widget (tmscm_car (p));
00886     p= tmscm_cdr (p);
00887   }
00888   return a;
00889 }
00890 
00891 static bool
00892 tmscm_is_properties (tmscm  p) {
00893   if (tmscm_is_null (p)) return true;
00894   else return tmscm_is_pair (p) &&
00895     tmscm_is_property (tmscm_car (p)) &&
00896     tmscm_is_properties (tmscm_cdr (p));
00897 }
00898 
00899 #define TMSCM_ASSERT_PROPERTIES(p,arg,rout) \
00900 TMSCM_ASSERT (tmscm_is_properties (p), p, arg, rout)
00901 
00902 tmscm 
00903 properties_to_tmscm (array<property> a) {
00904   int i, n= N(a);
00905   tmscm  p= tmscm_null ();
00906   for (i=n-1; i>=0; i--) p= tmscm_cons (property_to_tmscm (a[i]), p);
00907   return p;
00908 }
00909 
00910 array<property>
00911 tmscm_to_properties (tmscm  p) {
00912   array<property> a;
00913   while (!tmscm_is_null (p)) {
00914     a << tmscm_to_property (tmscm_car (p));
00915     p= tmscm_cdr (p);
00916   }
00917   return a;
00918 }
00919 
00920 static bool
00921 tmscm_is_solutions (tmscm  p) {
00922   if (tmscm_is_null (p)) return true;
00923   else return tmscm_is_pair (p) &&
00924     tmscm_is_solution (tmscm_car (p)) &&
00925     tmscm_is_solutions (tmscm_cdr (p));
00926 }
00927 
00928 #define TMSCM_ASSERT_SOLUTIONS(p,arg,rout) \
00929 TMSCM_ASSERT (tmscm_is_solutions (p), p, arg, rout)
00930 
00931 tmscm 
00932 solutions_to_tmscm (array<solution> a) {
00933   int i, n= N(a);
00934   tmscm  p= tmscm_null ();
00935   for (i=n-1; i>=0; i--) p= tmscm_cons (solution_to_tmscm (a[i]), p);
00936   return p;
00937 }
00938 
00939 array<solution>
00940 tmscm_to_solutions (tmscm  p) {
00941   array<solution> a;
00942   while (!tmscm_is_null (p)) {
00943     a << tmscm_to_solution (tmscm_car (p));
00944     p= tmscm_cdr (p);
00945   }
00946   return a;
00947 }
00948 
00949 /******************************************************************************
00950 * List types
00951 ******************************************************************************/
00952 
00953 typedef list<string> list_string;
00954 
00955 bool
00956 tmscm_is_list_string (tmscm  p) {
00957   if (tmscm_is_null (p)) return true;
00958   else return tmscm_is_pair (p) &&
00959     tmscm_is_string (tmscm_car (p)) &&
00960     tmscm_is_list_string (tmscm_cdr (p));
00961 }
00962 
00963 #define TMSCM_ASSERT_LIST_STRING(p,arg,rout) \
00964 TMSCM_ASSERT (tmscm_is_list_string (p), p, arg, rout)
00965 
00966 tmscm 
00967 list_string_to_tmscm (list_string l) {
00968   if (is_nil (l)) return tmscm_null ();
00969   return tmscm_cons (string_to_tmscm (l->item),
00970            list_string_to_tmscm (l->next));
00971 }
00972 
00973 list_string
00974 tmscm_to_list_string (tmscm  p) {
00975   if (tmscm_is_null (p)) return list_string ();
00976   return list_string (tmscm_to_string (tmscm_car (p)),
00977             tmscm_to_list_string (tmscm_cdr (p)));
00978 }
00979 
00980 typedef list<tree> list_tree;
00981 
00982 bool
00983 tmscm_is_list_tree (tmscm  p) {
00984   if (tmscm_is_null (p)) return true;
00985   else return tmscm_is_pair (p) &&
00986     tmscm_is_tree (tmscm_car (p)) &&
00987     tmscm_is_list_tree (tmscm_cdr (p));
00988 }
00989 
00990 #define TMSCM_ASSERT_LIST_TREE(p,arg,rout) \
00991 TMSCM_ASSERT (tmscm_is_list_tree (p), p, arg, rout)
00992 
00993 tmscm 
00994 list_tree_to_tmscm (list_tree l) {
00995   if (is_nil (l)) return tmscm_null ();
00996   return tmscm_cons (tree_to_tmscm (l->item),
00997            list_tree_to_tmscm (l->next));
00998 }
00999 
01000 list_tree
01001 tmscm_to_list_tree (tmscm  p) {
01002   if (tmscm_is_null (p)) return list_tree ();
01003   return list_tree (tmscm_to_tree (tmscm_car (p)),
01004             tmscm_to_list_tree (tmscm_cdr (p)));
01005 }
01006 
01007 /******************************************************************************
01008 * Other wrapper types
01009 ******************************************************************************/
01010 
01011 #define TMSCM_ASSERT_COLLECTION(p,arg,rout) \
01012 TMSCM_ASSERT (tmscm_is_array_string (p), p, arg, rout)
01013 
01014 tmscm 
01015 collection_to_tmscm (collection ss) {
01016   return array_string_to_tmscm (as_strings (ss));
01017 }
01018 
01019 collection
01020 tmscm_to_collection (tmscm  p) {
01021   return as_collection (tmscm_to_array_string (p));
01022 }
01023 
01024 /******************************************************************************
01025 * Gluing
01026 ******************************************************************************/
01027 
01028 #include "server.hpp"
01029 #include "tm_window.hpp"
01030 #include "boot.hpp"
01031 #include "connect.hpp"
01032 #include "convert.hpp"
01033 #include "file.hpp"
01034 #include "image_files.hpp"
01035 #include "sys_utils.hpp"
01036 #include "tmfs.hpp"
01037 #include "client_server.hpp"
01038 #include "analyze.hpp"
01039 #include "tree_traverse.hpp"
01040 #include "tree_analyze.hpp"
01041 #include "tree_correct.hpp"
01042 #include "tree_modify.hpp"
01043 #include "tm_frame.hpp"
01044 #include "Concat/concater.hpp"
01045 #include "converter.hpp"
01046 #include "timer.hpp"
01047 #include "Metafont/tex_files.hpp"
01048 #include "Freetype/tt_file.hpp"
01049 #include "Bibtex/bibtex.hpp"
01050 #include "Bibtex/bibtex_functions.hpp"
01051 #include "link.hpp"
01052 #include "dictionary.hpp"
01053 #include "patch.hpp"
01054 #include "packrat.hpp"
01055 #include "new_style.hpp"
01056 
01057 #include "../Glue/glue_basic.cpp"
01058 #include "../Glue/glue_editor.cpp"
01059 #include "../Glue/glue_server.cpp"
01060 
01061 void
01062 initialize_glue () {
01063   tmscm_install_procedure ("tree?",  treeP, 1, 0, 0);
01064   tmscm_install_procedure ("tm?",  contentP, 1, 0, 0);
01065   tmscm_install_procedure ("observer?",  observerP, 1, 0, 0);
01066   tmscm_install_procedure ("url?",  urlP, 1, 0, 0);
01067   tmscm_install_procedure ("blackbox?",  blackboxP, 1, 0, 0);
01068   
01069   initialize_glue_basic ();
01070   initialize_glue_editor ();
01071   initialize_glue_server ();
01072 }