Back to index

texmacs  1.0.7.15
object.cpp
Go to the documentation of this file.
00001 
00002 /******************************************************************************
00003  * MODULE     : object.cpp
00004  * DESCRIPTION: Implementation of scheme objects
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 
00013 
00014 #include "object.hpp"
00015 #include "glue.hpp"
00016 
00017 #include "config.h"
00018 #include "list.hpp"
00019 #include "array.hpp"
00020 #include "promise.hpp"
00021 #include "widget.hpp"
00022 
00023 /******************************************************************************
00024  * The object representation class
00025  ******************************************************************************/
00026 
00027 
00028 
00029 static list<tmscm > destroy_list;
00030 
00031 extern tmscm  object_stack;
00032 
00033 tmscm_object_rep::tmscm_object_rep (tmscm  obj) {
00034        while (!is_nil (destroy_list)) {
00035               tmscm  handle= destroy_list->item;
00036               
00037               tmscm_set_car (handle, tmscm_null ());
00038               while (tmscm_is_pair (tmscm_cdr (handle)) && tmscm_is_null (tmscm_cadr (handle)))
00039                      tmscm_set_cdr (handle, tmscm_cddr( (handle)) );
00040               destroy_list= destroy_list->next;
00041        }
00042        handle = tmscm_cons ( tmscm_cons (obj, tmscm_null ()), tmscm_car (object_stack) );
00043        tmscm_set_car (object_stack, handle);
00044 }
00045 
00046 tmscm_object_rep::~tmscm_object_rep () {
00047        // Be careful: can't call Scheme code from this destructor,
00048        // because the destructor can be called during garbage collection.
00049        destroy_list= list<tmscm > ( handle, destroy_list);
00050 }
00051 
00052 
00053 
00054 
00055 /******************************************************************************
00056  * Routines on objects
00057  ******************************************************************************/
00058 
00059 tm_ostream&
00060 operator << (tm_ostream& out, object obj) {
00061        out.flush ();
00062        if (out == cout) call ("write", obj);
00063        else if (out == cerr) call ("write-err", obj);
00064        else FAILED ("not yet implemented");
00065        call ("force-output");
00066        return out;
00067 }
00068 
00069 bool
00070 operator == (object obj1, object obj2) {
00071        tmscm  o1= object_to_tmscm (obj1), o2= object_to_tmscm (obj2);
00072        return tmscm_is_equal (o1, o2);
00073 }
00074 
00075 bool
00076 operator != (object obj1, object obj2) {
00077        return !(obj1 == obj2);
00078 }
00079 
00080 int
00081 hash (object obj) {
00082        return as_int (call ("hash", obj, object (1234567)));
00083 }
00084 
00085 /******************************************************************************
00086  * Utilities
00087  ******************************************************************************/
00088 
00089 object null_object () {
00090        return tmscm_to_object (tmscm_null ()); }
00091 object cons (object obj1, object obj2) {
00092        return tmscm_to_object (tmscm_cons (object_to_tmscm (obj1), object_to_tmscm (obj2))); }
00093 object list_object (object obj1) {
00094        return cons (obj1, null_object ()); }
00095 object list_object (object obj1, object obj2) {
00096        return cons (obj1, cons (obj2, null_object ())); }
00097 object list_object (object obj1, object obj2, object obj3) {
00098        return cons (obj1, cons (obj2, cons (obj3, null_object ()))); }
00099 object symbol_object (string s) {
00100        return tmscm_to_object ( symbol_to_tmscm  (s) ); }
00101 object car (object obj) {
00102        return tmscm_to_object (tmscm_car (object_to_tmscm (obj))); }
00103 object cdr (object obj) {
00104        return tmscm_to_object (tmscm_cdr (object_to_tmscm (obj))); }
00105 object caar (object obj) {
00106        return tmscm_to_object (tmscm_caar (object_to_tmscm (obj))); }
00107 object cdar (object obj) {
00108        return tmscm_to_object (tmscm_cdar (object_to_tmscm (obj))); }
00109 object cadr (object obj) {
00110        return tmscm_to_object (tmscm_cadr (object_to_tmscm (obj))); }
00111 object cddr (object obj) {
00112        return tmscm_to_object (tmscm_cddr (object_to_tmscm (obj))); }
00113 object caddr (object obj) {
00114        return tmscm_to_object (tmscm_caddr (object_to_tmscm (obj))); }
00115 object cadddr (object obj) {
00116        return tmscm_to_object (tmscm_cadddr (object_to_tmscm (obj))); }
00117 
00118 
00119 /******************************************************************************
00120  * Predicates
00121  ******************************************************************************/
00122 
00123 bool is_null (object obj) { return tmscm_is_null (object_to_tmscm (obj)); }
00124 bool is_list (object obj) { return tmscm_is_list (object_to_tmscm (obj)); }
00125 bool is_bool (object obj) { return tmscm_is_bool (object_to_tmscm (obj)); }
00126 bool is_int (object obj) { return tmscm_is_int (object_to_tmscm (obj)); }
00127 bool is_double (object obj) { return tmscm_is_double (object_to_tmscm (obj)); }
00128 bool is_string (object obj) { return tmscm_is_string (object_to_tmscm (obj)); }
00129 bool is_symbol (object obj) { return tmscm_is_symbol (object_to_tmscm (obj)); }
00130 bool is_tree (object obj) { return tmscm_is_tree (object_to_tmscm (obj)); }
00131 bool is_path (object obj) { return tmscm_is_path (object_to_tmscm (obj)); }
00132 bool is_url (object obj) { return tmscm_is_url (object_to_tmscm (obj)); }
00133 
00134 /******************************************************************************
00135  * Basic conversions
00136  ******************************************************************************/
00137 object::object (tmscm_object_rep* o): rep (static_cast<object_rep*>(o)) {}
00138 object::object (): rep (tm_new<tmscm_object_rep> (tmscm_null ())) {}
00139 object::object (bool b): rep (tm_new<tmscm_object_rep> (bool_to_tmscm  (b))) {}
00140 object::object (int i): rep (tm_new<tmscm_object_rep> (int_to_tmscm  (i))) {}
00141 object::object (double x): rep (tm_new<tmscm_object_rep> (double_to_tmscm  (x))) {}
00142 object::object (const char* s):
00143 rep (tm_new<tmscm_object_rep> (string_to_tmscm  (string (s)))) {}
00144 object::object (string s): rep (tm_new<tmscm_object_rep> (string_to_tmscm  (s))) {}
00145 object::object (tree t): rep (tm_new<tmscm_object_rep> (tree_to_tmscm  (t))) {}
00146 object::object (list<string> l):
00147 rep (tm_new<tmscm_object_rep> (list_string_to_tmscm (l))) {}
00148 object::object (list<tree> l):
00149 rep (tm_new<tmscm_object_rep> (list_tree_to_tmscm  (l))) {}
00150 object::object (path p): rep (tm_new<tmscm_object_rep> (path_to_tmscm  (p))) {}
00151 object::object (url u): rep (tm_new<tmscm_object_rep> (url_to_tmscm  (u))) {}
00152 
00153 bool
00154 as_bool (object obj) {
00155        tmscm  b= object_to_tmscm (obj);
00156        if (!tmscm_is_bool (b)) return false;
00157        return tmscm_to_bool (b);
00158 }
00159 
00160 int
00161 as_int (object obj) {
00162        tmscm  i= object_to_tmscm (obj);
00163        if (!tmscm_is_int (i)) return 0;
00164        return tmscm_to_int (i);
00165 }
00166 
00167 double
00168 as_double (object obj) {
00169        tmscm  x= object_to_tmscm (obj);
00170        if (!tmscm_is_double (x)) return 0.0;
00171        return tmscm_to_double (x);
00172 }
00173 
00174 string
00175 as_string (object obj) {
00176        tmscm  s= object_to_tmscm (obj);
00177        if (!tmscm_is_string (s)) return "";
00178        return tmscm_to_string (s);
00179 }
00180 
00181 string
00182 as_symbol (object obj) {
00183        tmscm  s= object_to_tmscm (obj);
00184        if (!tmscm_is_symbol (s)) return "";
00185        return tmscm_to_symbol (s);
00186 }
00187 
00188 tree
00189 as_tree (object obj) {
00190        tmscm  t= object_to_tmscm (obj);
00191        if (!tmscm_is_tree (t)) return tree ();
00192        return tmscm_to_tree (t);
00193 }
00194 
00195 scheme_tree
00196 as_tmscm_tree (object obj) {
00197        tmscm  t= object_to_tmscm (obj);
00198        return tmscm_to_scheme_tree (t);
00199 }
00200 
00201 list<string>
00202 as_list_string (object obj) {
00203        tmscm  l= object_to_tmscm (obj);
00204        if (!tmscm_is_list_string (l)) return list<string> ();
00205        return tmscm_to_list_string (l);
00206 }
00207 
00208 list<tree>
00209 as_list_tree (object obj) {
00210        tmscm  l= object_to_tmscm (obj);
00211        if (!tmscm_is_list_tree (l)) return list<tree> ();
00212        return tmscm_to_list_tree (l);
00213 }
00214 
00215 path
00216 as_path (object obj) {
00217        tmscm  t= object_to_tmscm (obj);
00218        if (!tmscm_is_path (t)) return path ();
00219        return tmscm_to_path (t);
00220 }
00221 
00222 array<object>
00223 as_array_object (object obj) {
00224        ASSERT (is_list (obj), "list expected");
00225        array<object> ret;
00226        while (!is_null (obj)) {
00227               ret << car (obj);
00228               obj= cdr (obj);
00229        }
00230        return ret;
00231 }
00232 
00233 url
00234 as_url (object obj) {
00235        tmscm  t= object_to_tmscm (obj);
00236        if (!tmscm_is_url (t)) return url ("");
00237        return tmscm_to_url (t);
00238 }
00239 
00240 widget
00241 as_widget (object obj) {
00242        tmscm  w= object_to_tmscm (obj);
00243        if (!tmscm_is_widget (w)) return widget ();
00244        return tmscm_to_widget (w);
00245 }
00246 
00247 object
00248 tree_to_stree (scheme_tree t) {
00249        return call ("tree->stree", t);
00250 }
00251 
00252 tree
00253 stree_to_tree (object obj) {
00254        return as_tree (call ("stree->tree", obj));
00255 }
00256 
00257 tree
00258 content_to_tree (object obj) {
00259        return tmscm_to_content (object_to_tmscm (obj));
00260        // return as_tree (call ("content->tree", obj));
00261 }
00262 
00263 object
00264 string_to_object (string s) {
00265        return call ("string->object", s);
00266 }
00267 
00268 string
00269 object_to_string (object obj) {
00270        return as_string (call ("object->string", obj));
00271 }
00272 
00273 object
00274 scheme_cmd (const char* s) {
00275        return eval ("(lambda () " * string (s) * ")");
00276 }
00277 
00278 object
00279 scheme_cmd (string s) {
00280        return eval ("(lambda () " * s * ")");
00281 }
00282 
00283 object
00284 scheme_cmd (object cmd) {
00285        cmd= cons (cmd, null_object ());
00286        cmd= cons (null_object (), cmd);
00287        cmd= cons (eval ("'lambda"), cmd);
00288        return eval (cmd);
00289 }
00290 
00291 /******************************************************************************
00292  * Conversions to functional objects
00293  ******************************************************************************/
00294 
00295 static inline array<tmscm >
00296 array_lookup (array<object> a) {
00297        const int n=N(a);
00298        array<tmscm > tmscm (n);
00299        int i;
00300        for (i=0; i<n; i++) tmscm [i]= object_to_tmscm (a[i]);
00301        return tmscm ;
00302 }
00303 
00304 class object_command_rep: public command_rep {
00305        object obj;
00306 public:
00307        object_command_rep (object obj2): obj (obj2) {}
00308        void apply () { (void) call_scheme (object_to_tmscm  (obj)); }
00309        void apply (object args) {
00310               (void) call_scheme (object_to_tmscm (obj),
00311                                                  array_lookup (as_array_object (args))); }
00312        tm_ostream& print (tm_ostream& out) { return out << obj; }
00313 };
00314 
00315 command
00316 as_command (object obj) {
00317        return tm_new<object_command_rep> (obj);
00318 }
00319 
00320 class object_promise_widget_rep: public promise_rep<widget> {
00321        object obj;
00322 public:
00323        object_promise_widget_rep (object obj2): obj (obj2) {}
00324        tm_ostream& print (tm_ostream& out) { return out << obj; }
00325        widget eval () {
00326               tmscm  result= call_scheme (object_to_tmscm  (obj));
00327               if (tmscm_is_widget (result)) return tmscm_to_widget (result);
00328               else {
00329                      FAILED ("widget expected");
00330                      return glue_widget ();
00331               }
00332        }
00333 };
00334 
00335 promise<widget>
00336 as_promise_widget (object obj) {
00337        return tm_new<object_promise_widget_rep> (obj);
00338 }
00339 
00340 /******************************************************************************
00341  * Evaluation and function calls
00342  ******************************************************************************/
00343 
00344 object eval (const char* expr) {
00345        return tmscm_to_object (eval_scheme (expr)); }
00346 object eval (string expr) {
00347        return tmscm_to_object (eval_scheme (expr)); }
00348 object eval (object expr) {
00349        return call ("eval", expr); }
00350 object eval_secure (string expr) {
00351        return eval ("(wrap-eval-secure " * expr * ")"); }
00352 object eval_file (string name) {
00353        return tmscm_to_object (eval_scheme_file (name)); }
00354 bool exec_file (url u) {
00355        object ret= eval_file (materialize (u));
00356        return ret != object ("#<unspecified>"); }
00357 
00358 object call (const char* fun) {
00359        return tmscm_to_object (call_scheme (eval_scheme(fun))); }
00360 object call (const char* fun, object a1) {
00361        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1))); }
00362 object call (const char* fun, object a1, object a2) {
00363        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1), object_to_tmscm (a2))); }
00364 object call (const char* fun, object a1, object a2, object a3) {
00365        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1),
00366                                                         object_to_tmscm (a2), object_to_tmscm (a3))); }
00367 object call (const char* fun, object a1, object a2, object a3, object a4) {
00368        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1),
00369                                                         object_to_tmscm (a2), object_to_tmscm (a3), object_to_tmscm (a4))); }
00370 object call (const char* fun, array<object> a) {
00371        return tmscm_to_object (call_scheme (eval_scheme(fun), array_lookup(a))); }
00372 
00373 object call (string fun) {
00374        return tmscm_to_object (call_scheme (eval_scheme(fun))); }
00375 object call (string fun, object a1) {
00376        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1))); }
00377 object call (string fun, object a1, object a2) {
00378        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1), object_to_tmscm (a2))); }
00379 object call (string fun, object a1, object a2, object a3) {
00380        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1),
00381                                                         object_to_tmscm (a2), object_to_tmscm (a3))); }
00382 object call (string fun, object a1, object a2, object a3, object a4) {
00383        return tmscm_to_object (call_scheme (eval_scheme(fun), object_to_tmscm (a1),
00384                                                         object_to_tmscm (a2), object_to_tmscm (a3), object_to_tmscm (a4))); }
00385 object call (string fun, array<object> a) {
00386        return tmscm_to_object (call_scheme (eval_scheme(fun), array_lookup(a))); }
00387 
00388 object call (object fun) {
00389        return tmscm_to_object (call_scheme (object_to_tmscm (fun))); }
00390 object call (object fun, object a1) {
00391        return tmscm_to_object (call_scheme (object_to_tmscm (fun), object_to_tmscm (a1))); }
00392 object call (object fun, object a1, object a2) {
00393        return tmscm_to_object (call_scheme (object_to_tmscm (fun), object_to_tmscm (a1), object_to_tmscm (a2))); }
00394 object call (object fun, object a1, object a2, object a3) {
00395        return tmscm_to_object (call_scheme (object_to_tmscm (fun), object_to_tmscm (a1),
00396                                                         object_to_tmscm (a2), object_to_tmscm (a3))); }
00397 object call (object fun, object a1, object a2, object a3, object a4) {
00398        return tmscm_to_object (call_scheme (object_to_tmscm (fun), object_to_tmscm (a1),
00399                                                         object_to_tmscm (a2), object_to_tmscm (a3), object_to_tmscm (a4))); }
00400 object call (object fun, array<object> a) {
00401        return tmscm_to_object (call_scheme (object_to_tmscm (fun), array_lookup(a))); }
00402 
00403 /******************************************************************************
00404  * User preferences
00405  ******************************************************************************/
00406 
00407 static bool preferences_ok= false;
00408 
00409 void
00410 notify_preferences_loaded () {
00411        preferences_ok= true;
00412 }
00413 
00414 
00415 string
00416 get_preference (string var) {
00417        if (!preferences_ok) return "uninitialized";
00418        else return as_string (call ("get-preference", var));
00419 }
00420 
00421 /******************************************************************************
00422  * Delayed evaluation
00423  ******************************************************************************/
00424 
00425 #ifndef QTTEXMACS
00426 static array<object> delayed_queue;
00427 static array<time_t> start_queue;
00428 
00429 void
00430 exec_delayed (object cmd) {
00431        delayed_queue << cmd;
00432        start_queue << (((time_t) texmacs_time ()) - 1000000000);
00433 }
00434 
00435 void
00436 exec_delayed_pause (object cmd) {
00437        delayed_queue << cmd;
00438        start_queue << ((time_t) texmacs_time ());
00439 }
00440 
00441 void
00442 exec_pending_commands () {
00443        array<object> a= delayed_queue;
00444        array<time_t> b= start_queue;
00445        delayed_queue= array<object> (0);
00446        start_queue  = array<time_t> (0);
00447        int i, n= N(a);
00448        for (i=0; i<n; i++) {
00449               time_t now= (time_t) texmacs_time ();
00450               if ((now - b[i]) >= 0) {
00451                      object obj= call (a[i]);
00452                      if (is_int (obj) && (now - b[i] < 1000000000)) {
00453                             //cout << "pause= " << obj << "\n";
00454                             delayed_queue << a[i];
00455                             start_queue << (now + as_int (obj));
00456                      }
00457               }
00458               else {
00459                      delayed_queue << a[i];
00460                      start_queue << b[i];
00461               }
00462        }
00463 }
00464 
00465 void
00466 clear_pending_commands () {
00467        delayed_queue= array<object> (0);
00468        start_queue  = array<time_t> (0);
00469 }
00470 #endif // QTTEXMACS
00471