src/src/Guile/Scheme/evaluate.cpp

   1
   2 /******************************************************************************
   3 * MODULE     : evaluate.cpp
   4 * DESCRIPTION: Execution of scheme commands via guile
   5 * COPYRIGHT  : (C) 1999  Joris van der Hoeven
   6 *******************************************************************************
   7 * This software falls under the GNU general public license version 3 or later.
   8 * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
   9 * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  10 ******************************************************************************/
  11
  12 #ifdef __MINGW32__
  13 //FIXME: if this include is not here we have compilation problems on mingw32
  14 //       (probably name clashes with Windows headers)
  15 #include "tree.hpp"
  16 #endif
  17 #include "Glue/glue.hpp"
  18 #include "guile.hpp"
  19 #include "Scheme/evaluate.hpp"
  20 #include "file.hpp"
  21 #include "timer.hpp"
  22
  23 SCM object_stack;
  24
  25 /******************************************************************************
  26 * Installation of guile and initialization of guile
  27 ******************************************************************************/
  28
  29 #ifdef GUILE_C
  30 static void (*old_call_back) (int, char**)= NULL;
  31 static void
  32 new_call_back (void *closure, int argc, char** argv) {
  33   old_call_back (argc, argv);
  34 }
  35 #endif
  36
  37 void
  38 start_guile (int argc, char** argv, void (*call_back) (int, char**)) {
  39 #ifdef GUILE_C
  40   old_call_back= call_back;
  41   scm_boot_guile (argc, argv, new_call_back, 0);
  42 #else
  43 #ifdef DOTS_OK
  44   gh_enter (argc, argv, (void (*)(...)) ((void*) call_back));
  45 #else
  46   gh_enter (argc, argv, call_back);
  47 #endif
  48 #endif
  49 }
  50
  51 void
  52 initialize_guile () {
  53   const char* init_prg =
  54     "(read-set! keywords 'prefix)\n"
  55     "(read-enable 'positions)\n"
  56     "(debug-enable 'debug)\n"
  57     ";(debug-enable 'backtrace)\n"
  58     "\n"
  59     "(define (display-to-string obj)\n"
  60     "  (call-with-output-string\n"
  61     "    (lambda (port) (display obj port))))\n"
  62     "(define (object->string obj)\n"
  63     "  (call-with-output-string\n"
  64     "    (lambda (port) (write obj port))))\n"
  65     "\n"
  66     "(define (texmacs-version) \"" TEXMACS_VERSION "\")\n"
  67     "(define object-stack '(()))";
  68
  69   scm_c_eval_string (init_prg);
  70   initialize_glue ();
  71   object_stack= scm_lookup_string ("object-stack");
  72 }
  73
  74 /******************************************************************************
  75 * Catching errors (with thanks to Dale P. Smith)
  76 ******************************************************************************/
  77
  78 SCM
  79 TeXmacs_lazy_catcher (void *data, SCM tag, SCM throw_args) {
  80   SCM eport= scm_current_error_port();
  81   scm_handle_by_message_noexit (data, tag, throw_args);
  82   scm_force_output (eport);
  83   scm_ithrow (tag, throw_args, 1);
  84   return SCM_UNSPECIFIED; /* never returns */
  85 }
  86
  87 SCM
  88 TeXmacs_catcher (void *data, SCM tag, SCM args) {
  89   (void) data;
  90   return scm_cons (tag, args);
  91 }
  92
  93 /******************************************************************************
  94 * Evaluation of files
  95 ******************************************************************************/
  96
  97 static SCM
  98 TeXmacs_lazy_eval_file (char *file) {
  99   return scm_internal_lazy_catch (SCM_BOOL_T,
 100     (scm_t_catch_body) scm_c_primitive_load, file,
 101     (scm_t_catch_handler) TeXmacs_lazy_catcher, file);
 102 }
 103
 104 static SCM
 105 TeXmacs_eval_file (char *file) {
 106   return scm_internal_catch (SCM_BOOL_T,
 107     (scm_t_catch_body) TeXmacs_lazy_eval_file, file,
 108     (scm_t_catch_handler) TeXmacs_catcher, file);
 109 }
 110
 111 SCM
 112 eval_scheme_file (string file) {
 113   //static int cumul= 0;
 114   //timer tm;
 115   if (DEBUG_STD) cout << "TeXmacs] Evaluating " << file << "...\n";
 116   char* _file= as_charp (file);
 117   SCM result= TeXmacs_eval_file (_file);
 118   tm_delete_array (_file);
 119   //int extra= tm->watch (); cumul += extra;
 120   //cout << extra << "\t" << cumul << "\t" << file << "\n";
 121   return result;
 122 }
 123
 124 /******************************************************************************
 125 * Evaluation of strings
 126 ******************************************************************************/
 127
 128 static SCM
 129 TeXmacs_lazy_eval_string (char *s) {
 130   return scm_internal_lazy_catch (SCM_BOOL_T,
 131     (scm_t_catch_body) scm_c_eval_string, s,
 132     (scm_t_catch_handler) TeXmacs_lazy_catcher, s);
 133 }
 134
 135 static SCM
 136 TeXmacs_eval_string (char *s) {
 137   return scm_internal_catch (SCM_BOOL_T,
 138     (scm_t_catch_body) TeXmacs_lazy_eval_string, s,
 139     (scm_t_catch_handler) TeXmacs_catcher, s);
 140 }
 141
 142 SCM
 143 eval_scheme (string s) {
 144   // cout << "Eval] " << s << "\n";
 145   char* _s= as_charp (s);
 146   SCM result= TeXmacs_eval_string (_s);
 147   tm_delete_array (_s);
 148   return result;
 149 }
 150
 151 /******************************************************************************
 152 * Using scheme objects as functions
 153 ******************************************************************************/
 154
 155 struct arg_list { int  n; SCM* a; };
 156
 157 static SCM
 158 TeXmacs_call (arg_list* args) {
 159   switch (args->n) {
 160   case 0: return scm_call_0 (args->a[0]); break;
 161   case 1: return scm_call_1 (args->a[0], args->a[1]); break;
 162   case 2: return scm_call_2 (args->a[0], args->a[1], args->a[2]); break;
 163   case 3:
 164     return scm_call_3 (args->a[0], args->a[1], args->a[2], args->a[3]); break;
 165   default:
 166     {
 167       int i;
 168       SCM l= SCM_NULL;
 169       for (i=args->n; i>=1; i--)
 170         l= scm_cons (args->a[i], l);
 171       return scm_apply_0 (args->a[0], l);
 172     }
 173   }
 174 }
 175
 176 static SCM
 177 TeXmacs_lazy_call_scm (arg_list* args) {
 178   return scm_internal_lazy_catch (SCM_BOOL_T,
 179     (scm_t_catch_body) TeXmacs_call, (void*) args,
 180     (scm_t_catch_handler) TeXmacs_lazy_catcher, (void*) args);
 181 }
 182
 183 static SCM
 184 TeXmacs_call_scm (arg_list *args) {
 185   return scm_internal_catch (SCM_BOOL_T,
 186     (scm_t_catch_body) TeXmacs_lazy_call_scm, (void*) args,
 187     (scm_t_catch_handler) TeXmacs_catcher, (void*) args);
 188 }
 189
 190 SCM
 191 call_scheme (SCM fun) {
 192   SCM a[]= { fun }; arg_list args= { 0, a };
 193   return TeXmacs_call_scm (&args);
 194 }
 195
 196 SCM
 197 call_scheme (SCM fun, SCM a1) {
 198   SCM a[]= { fun, a1 }; arg_list args= { 1, a };
 199   return TeXmacs_call_scm (&args);
 200 }
 201
 202 SCM
 203 call_scheme (SCM fun, SCM a1, SCM a2) {
 204   SCM a[]= { fun, a1, a2 }; arg_list args= { 2, a };
 205   return TeXmacs_call_scm (&args);
 206 }
 207
 208 SCM
 209 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3) {
 210   SCM a[]= { fun, a1, a2, a3 }; arg_list args= { 3, a };
 211   return TeXmacs_call_scm (&args);
 212 }
 213
 214 SCM
 215 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3, SCM a4) {
 216   SCM a[]= { fun, a1, a2, a3, a4 }; arg_list args= { 4, a };
 217   return TeXmacs_call_scm (&args);
 218 }
 219
 220 SCM
 221 call_scheme (SCM fun, array<SCM> a) {
 222   const int n= N(a);
 223   STACK_NEW_ARRAY(scm, SCM, n+1);
 224   int i;
 225   scm[0]= fun;
 226   for (i=0; i<n; i++) scm[i+1]= a[i];
 227   arg_list args= { n, scm };
 228   SCM ret= TeXmacs_call_scm (&args);
 229   STACK_DELETE_ARRAY(scm);
 230   return ret;
 231 }