Back to index

texmacs  1.0.7.15
guile_tm.cpp
Go to the documentation of this file.
00001 /******************************************************************************
00002  * MODULE     : guile_tm.cpp
00003  * DESCRIPTION: Interface to Guile
00004  * COPYRIGHT  : (C) 1999-2011  Joris van der Hoeven and Massimiliano Gubinelli
00005  *******************************************************************************
00006  * This software falls under the GNU general public license version 3 or later.
00007  * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
00008  * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
00009  ******************************************************************************/
00010 
00011 #ifdef __MINGW32__
00012 //FIXME: if this include is not here we have compilation problems on mingw32 
00013 //       (probably name clashes with Windows headers)
00014 //#include "tree.hpp"
00015 #endif
00016 //#include "Glue/glue.hpp"
00017 
00018 #include "guile_tm.hpp"
00019 #include "blackbox.hpp"
00020 #include "file.hpp"
00021 #include "../Scheme/glue.hpp"
00022 #include "convert.hpp" // tree_to_texmacs (should not belong here)
00023 
00024 /******************************************************************************
00025  * Installation of guile and initialization of guile
00026  ******************************************************************************/
00027 
00028 #if (defined(GUILE_C) || defined(GUILE_D))
00029 static void (*old_call_back) (int, char**)= NULL;
00030 static void
00031 new_call_back (void *closure, int argc, char** argv) {
00032        (void) closure;
00033   
00034        old_call_back (argc, argv);
00035 }
00036 #endif
00037 
00038 
00039 int guile_argc;
00040 char **guile_argv;
00041 
00042 void
00043 start_scheme (int argc, char** argv, void (*call_back) (int, char**)) {
00044        guile_argc = argc;
00045        guile_argv = argv;
00046 #if (defined(GUILE_C) || defined(GUILE_D))
00047        old_call_back= call_back;
00048        scm_boot_guile (argc, argv, new_call_back, 0);
00049 #else
00050 #ifdef DOTS_OK
00051        gh_enter (argc, argv, (void (*)(...)) ((void*) call_back));
00052 #else
00053        gh_enter (argc, argv, call_back);
00054 #endif
00055 #endif
00056 }
00057 
00058 
00059 
00060 /******************************************************************************
00061  * Catching errors (with thanks to Dale P. Smith)
00062  ******************************************************************************/
00063 
00064 SCM
00065 TeXmacs_lazy_catcher (void *data, SCM tag, SCM throw_args) {
00066        SCM eport= scm_current_error_port();
00067        scm_handle_by_message_noexit (data, tag, throw_args);
00068        scm_force_output (eport);
00069        scm_ithrow (tag, throw_args, 1);
00070        return SCM_UNSPECIFIED; /* never returns */
00071 }
00072 
00073 SCM
00074 TeXmacs_catcher (void *data, SCM tag, SCM args) {
00075        (void) data;
00076        return scm_cons (tag, args);
00077 }
00078 
00079 /******************************************************************************
00080  * Evaluation of files
00081  ******************************************************************************/
00082 
00083 static SCM
00084 TeXmacs_lazy_eval_file (char *file) {
00085        return scm_internal_lazy_catch (SCM_BOOL_T,
00086                                                                (scm_t_catch_body) scm_c_primitive_load, file,
00087                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, file);
00088 }
00089 
00090 static SCM
00091 TeXmacs_eval_file (char *file) {
00092        return scm_internal_catch (SCM_BOOL_T,
00093                                                     (scm_t_catch_body) TeXmacs_lazy_eval_file, file,
00094                                                     (scm_t_catch_handler) TeXmacs_catcher, file);
00095 }
00096 
00097 SCM
00098 eval_scheme_file (string file) {
00099        //static int cumul= 0;
00100        //timer tm;
00101        if (DEBUG_STD) cout << "TeXmacs] Evaluating " << file << "...\n";
00102        char* _file= as_charp (file);
00103        SCM result= TeXmacs_eval_file (_file);
00104        tm_delete_array (_file);
00105        //int extra= tm->watch (); cumul += extra;
00106        //cout << extra << "\t" << cumul << "\t" << file << "\n";
00107        return result;
00108 }
00109 
00110 /******************************************************************************
00111  * Evaluation of strings
00112  ******************************************************************************/
00113 
00114 static SCM
00115 TeXmacs_lazy_eval_string (char *s) {
00116        return scm_internal_lazy_catch (SCM_BOOL_T,
00117                                                                (scm_t_catch_body) scm_c_eval_string, s,
00118                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, s);
00119 }
00120 
00121 static SCM
00122 TeXmacs_eval_string (char *s) {
00123        return scm_internal_catch (SCM_BOOL_T,
00124                                                     (scm_t_catch_body) TeXmacs_lazy_eval_string, s,
00125                                                     (scm_t_catch_handler) TeXmacs_catcher, s);
00126 }
00127 
00128 SCM
00129 eval_scheme (string s) {
00130        // cout << "Eval] " << s << "\n";
00131        char* _s= as_charp (s);
00132        SCM result= TeXmacs_eval_string (_s);
00133        tm_delete_array (_s);
00134        return result;
00135 }
00136 
00137 /******************************************************************************
00138  * Using scheme objects as functions
00139  ******************************************************************************/
00140 
00141 struct arg_list { int  n; SCM* a; };
00142 
00143 static SCM
00144 TeXmacs_call (arg_list* args) {
00145        switch (args->n) {
00146               case 0: return scm_call_0 (args->a[0]); break;
00147               case 1: return scm_call_1 (args->a[0], args->a[1]); break;
00148               case 2: return scm_call_2 (args->a[0], args->a[1], args->a[2]); break;
00149               case 3:
00150                      return scm_call_3 (args->a[0], args->a[1], args->a[2], args->a[3]); break;
00151               default:
00152               {
00153                      int i;
00154                      SCM l= SCM_NULL;
00155                      for (i=args->n; i>=1; i--)
00156                             l= scm_cons (args->a[i], l);
00157                      return scm_apply_0 (args->a[0], l);
00158               }
00159        }
00160 }
00161 
00162 static SCM
00163 TeXmacs_lazy_call_scm (arg_list* args) {
00164        return scm_internal_lazy_catch (SCM_BOOL_T,
00165                                                                (scm_t_catch_body) TeXmacs_call, (void*) args,
00166                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, (void*) args);
00167 }
00168 
00169 static SCM
00170 TeXmacs_call_scm (arg_list *args) {
00171        return scm_internal_catch (SCM_BOOL_T,
00172                                                     (scm_t_catch_body) TeXmacs_lazy_call_scm, (void*) args,
00173                                                     (scm_t_catch_handler) TeXmacs_catcher, (void*) args);
00174 }
00175 
00176 SCM
00177 call_scheme (SCM fun) {
00178        SCM a[]= { fun }; arg_list args= { 0, a };
00179        return TeXmacs_call_scm (&args);
00180 }
00181 
00182 SCM
00183 call_scheme (SCM fun, SCM a1) {
00184        SCM a[]= { fun, a1 }; arg_list args= { 1, a };
00185        return TeXmacs_call_scm (&args);
00186 }
00187 
00188 SCM
00189 call_scheme (SCM fun, SCM a1, SCM a2) {
00190        SCM a[]= { fun, a1, a2 }; arg_list args= { 2, a };
00191        return TeXmacs_call_scm (&args);
00192 }
00193 
00194 SCM
00195 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3) {
00196        SCM a[]= { fun, a1, a2, a3 }; arg_list args= { 3, a };
00197        return TeXmacs_call_scm (&args);
00198 }
00199 
00200 SCM
00201 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3, SCM a4) {
00202        SCM a[]= { fun, a1, a2, a3, a4 }; arg_list args= { 4, a };
00203        return TeXmacs_call_scm (&args);
00204 }
00205 
00206 SCM
00207 call_scheme (SCM fun, array<SCM> a) {
00208        const int n= N(a);
00209        STACK_NEW_ARRAY(scm, SCM, n+1);
00210        int i;
00211        scm[0]= fun;
00212        for (i=0; i<n; i++) scm[i+1]= a[i];
00213        arg_list args= { n, scm };
00214        SCM ret= TeXmacs_call_scm (&args);
00215        STACK_DELETE_ARRAY(scm);
00216        return ret;
00217 }
00218 
00219 
00220 /******************************************************************************
00221  * Miscellaneous routines for use by glue only
00222  ******************************************************************************/
00223 
00224 string
00225 scheme_dialect () {
00226 #ifdef GUILE_A
00227        return "guile-a";
00228 #else
00229 #ifdef GUILE_B
00230        return "guile-b";
00231 #else
00232 #ifdef GUILE_C
00233        return "guile-c";
00234 #else
00235 #ifdef GUILE_D
00236        return "guile-d";
00237 #else
00238        return "unknown";
00239 #endif
00240 #endif
00241 #endif
00242 #endif
00243 }
00244 
00245 #if (defined(GUILE_C) || defined(GUILE_D))
00246 #define SET_SMOB(smob,data,type)   \
00247 SCM_NEWSMOB (smob, SCM_UNPACK (type), data);
00248 #else
00249 #define SET_SMOB(smob,data,type)   \
00250 SCM_NEWCELL (smob);              \
00251 SCM_SETCAR (smob, (SCM) (type)); \
00252 SCM_SETCDR (smob, (SCM) (data));
00253 #endif
00254 
00255 
00256 /******************************************************************************
00257  * Booleans
00258  ******************************************************************************/
00259 
00260 
00261 SCM
00262 bool_to_scm (bool flag) {
00263        return scm_bool2scm (flag);
00264 }
00265 
00266 #if (defined(GUILE_A) || defined(GUILE_B))
00267 int
00268 scm_to_bool (SCM flag) {
00269        return scm_scm2bool (flag);
00270 }
00271 #endif
00272 
00273 /******************************************************************************
00274  * Integers
00275  ******************************************************************************/
00276 
00277 
00278 SCM
00279 int_to_scm (int i) {
00280        return scm_long2scm ((long) i);
00281 }
00282 
00283 #if (defined(GUILE_A) || defined(GUILE_B))
00284 int
00285 scm_to_int (SCM i) {
00286        return (int) scm_scm2long (i);
00287 }
00288 #endif
00289 
00290 /******************************************************************************
00291  * Floating point numbers
00292  ******************************************************************************/
00293 #if 0
00294 bool scm_is_double (scm o) {
00295   return SCM_REALP(o);
00296 }
00297 #endif
00298 
00299 SCM
00300 double_to_scm (double i) {
00301        return scm_double2scm (i);
00302 }
00303 
00304 #if (defined(GUILE_A) || defined(GUILE_B))
00305 double
00306 scm_to_double (SCM i) {
00307        return scm_scm2double (i);
00308 }
00309 #endif
00310 
00311 /******************************************************************************
00312  * Strings
00313  ******************************************************************************/
00314 
00315 
00316 tmscm
00317 string_to_tmscm (string s) {
00318        char* _s= as_charp (s);
00319        SCM r= scm_str2scm (_s, N(s));
00320        tm_delete_array (_s);
00321        return r;
00322 }
00323 
00324 string
00325 tmscm_to_string (tmscm s) {
00326        guile_str_size_t len_r;
00327        char* _r= scm_scm2str (s, &len_r);
00328        string r (_r, len_r);
00329 #ifdef OS_WIN32
00330        scm_must_free(_r);
00331 #else
00332        free (_r);
00333 #endif
00334        return r;
00335 }
00336 
00337 /******************************************************************************
00338  * Symbols
00339  ******************************************************************************/
00340 
00341 #if 0
00342 bool tmscm_is_symbol (tmscm s) {
00343   return SCM_NFALSEP (scm_symbol_p (s));
00344 }
00345 #endif
00346 
00347 tmscm
00348 symbol_to_tmscm (string s) {
00349        char* _s= as_charp (s);
00350        SCM r= scm_symbol2scm (_s);
00351        tm_delete_array (_s);
00352        return r;
00353 }
00354 
00355 string
00356 tmscm_to_symbol (tmscm s) {
00357        guile_str_size_t len_r;
00358        char* _r= scm_scm2symbol (s, &len_r);
00359        string r (_r, len_r);
00360 #ifdef OS_WIN32
00361        scm_must_free(_r);
00362 #else
00363        free (_r);
00364 #endif
00365        return r;
00366 }
00367 
00368 /******************************************************************************
00369  * Blackbox
00370  ******************************************************************************/
00371 
00372 static long blackbox_tag;
00373 
00374 #define SCM_BLACKBOXP(t) \
00375 (SCM_NIMP (t) && (((long) SCM_CAR (t)) == blackbox_tag))
00376 
00377 bool
00378 tmscm_is_blackbox (tmscm t) {
00379        return SCM_BLACKBOXP (t);
00380 }
00381 
00382 tmscm
00383 blackbox_to_tmscm (blackbox b) {
00384        SCM blackbox_smob;
00385        SET_SMOB (blackbox_smob, (void*) (tm_new<blackbox> (b)), (SCM) blackbox_tag);
00386        return blackbox_smob;
00387 }
00388 
00389 blackbox
00390 tmscm_to_blackbox (tmscm blackbox_smob) {
00391        return *((blackbox*) SCM_CDR (blackbox_smob));
00392 }
00393 
00394 static SCM
00395 mark_blackbox (SCM blackbox_smob) {
00396        (void) blackbox_smob;
00397        return SCM_BOOL_F;
00398 }
00399 
00400 static scm_sizet
00401 free_blackbox (SCM blackbox_smob) {
00402        blackbox *ptr = (blackbox *) SCM_CDR (blackbox_smob);
00403        tm_delete (ptr);
00404        return 0;
00405 }
00406 
00407 int
00408 print_blackbox (SCM blackbox_smob, SCM port, scm_print_state *pstate) {
00409        (void) pstate;
00410        string s = "<blackbox>";
00411        int type_ = type_box (tmscm_to_blackbox(blackbox_smob)) ;
00412        if (type_ == type_helper<tree>::id)
00413        {
00414               tree   t= tmscm_to_tree (blackbox_smob);
00415               s= "<tree " * tree_to_texmacs (t) * ">";
00416        } else if (type_ == type_helper<observer>::id)
00417        {
00418               s= "<observer>";
00419        } else if (type_ == type_helper<widget>::id)
00420        {
00421               s= "<widget>";
00422        } else if (type_ == type_helper<promise<widget> >::id)
00423        {
00424               s= "<promise-widget>";
00425        } else if (type_ == type_helper<command>::id) 
00426        {
00427               s= "<command>";
00428        } else if (type_ == type_helper<url>::id)
00429        {
00430               url    u= tmscm_to_url (blackbox_smob);
00431               s= "<url " * as_string (u) * ">";
00432        }
00433        
00434        scm_display (string_to_tmscm (s), port);
00435        return 1;
00436 }
00437 
00438 static SCM
00439 cmp_blackbox (SCM t1, SCM t2) {
00440        return scm_bool2scm (tmscm_to_blackbox (t1) == tmscm_to_blackbox (t2));
00441 }
00442 
00443 
00444 
00445 /******************************************************************************
00446  * Initialization
00447  ******************************************************************************/
00448 
00449 
00450 #ifdef SCM_NEWSMOB
00451 void
00452 initialize_smobs () {
00453        blackbox_tag= scm_make_smob_type (const_cast<char*> ("blackbox"), 0);
00454        scm_set_smob_mark (blackbox_tag, mark_blackbox);
00455        scm_set_smob_free (blackbox_tag, free_blackbox);
00456        scm_set_smob_print (blackbox_tag, print_blackbox);
00457        scm_set_smob_equalp (blackbox_tag, cmp_blackbox);
00458 }
00459 
00460 #else
00461 
00462 scm_smobfuns blackbox_smob_funcs = {
00463        mark_blackbox, free_blackbox, print_blackbox, cmp_blackbox
00464 };
00465 
00466 
00467 void
00468 initialize_smobs () {
00469        blackbox_tag= scm_newsmob (&blackbox_smob_funcs);
00470 }
00471 
00472 #endif
00473 
00474 tmscm object_stack;
00475 
00476 void
00477 initialize_scheme () {
00478        const char* init_prg =
00479     "(read-set! keywords 'prefix)\n"
00480     "(read-enable 'positions)\n"
00481     "(debug-enable 'debug)\n"
00482     ";(debug-enable 'backtrace)\n"
00483     "\n"
00484     "(define (display-to-string obj)\n"
00485     "  (call-with-output-string\n"
00486     "    (lambda (port) (display obj port))))\n"
00487     "(define (object->string obj)\n"
00488     "  (call-with-output-string\n"
00489     "    (lambda (port) (write obj port))))\n"
00490     "\n"
00491     "(define (texmacs-version) \"" TEXMACS_VERSION "\")\n"
00492     "(define object-stack '(()))";
00493        
00494        scm_c_eval_string (init_prg);
00495        initialize_smobs ();
00496        initialize_glue ();
00497        object_stack= scm_lookup_string ("object-stack");
00498        
00499 // uncomment to have a guile repl available at startup  
00500 //     gh_repl(guile_argc, guile_argv);
00501   //scm_shell (guile_argc, guile_argv);
00502   
00503 
00504 }
00505