Back to index

texmacs  1.0.7.15
tinyscheme_tm.cpp
Go to the documentation of this file.
00001 
00002 /******************************************************************************
00003  * MODULE     : tinyscheme_tm.cpp
00004  * DESCRIPTION: TinyScheme interface
00005  * COPYRIGHT  : (C) 2011 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 "tinyscheme_tm.hpp"
00013 #include "object.hpp"
00014 #include "glue.hpp"
00015 
00016 
00017 
00018 
00019 #define TST_BLACKBOX   17
00020 
00021 
00022 scheme* the_scheme = scheme_init_new();
00023 
00024 
00025 void finalize_blackbox(void *p) {
00026        tm_delete((blackbox*)p);
00027 }
00028 
00029 
00030 
00031 /******************************************************************************
00032  * Entry points to Scheme
00033  ******************************************************************************/
00034 
00035 
00036 scm scm_eval_string (const char *str) 
00037 {
00038        scheme_load_string(the_scheme, (char*)str);
00039        return the_scheme->value;
00040 }
00041 
00042 scm scm_eval_file (FILE *f) 
00043 {
00044        scheme_load_file(the_scheme,f);
00045        return the_scheme->value;
00046 }
00047 
00048 scm scm_apply (scm func, scm args) 
00049 {
00050        scheme_call(the_scheme, func, args);
00051        return the_scheme->value;
00052 }
00053 
00054 
00055 scm scm_lookup_string(const char *name)
00056 {
00057        return scheme_eval(the_scheme, mk_symbol(the_scheme, name));
00058 }
00059 
00060 void scm_define(scm symbol, scm value)
00061 {
00062        scheme_define(the_scheme, the_scheme->global_env, symbol, value);
00063 }
00064 
00065 scm object_stack;
00066 
00067 /******************************************************************************
00068  * Installation of guile and initialization of guile
00069  ******************************************************************************/
00070 
00071 void
00072 start_scheme (int argc, char** argv, void (*call_back) (int, char**)) {
00073        // gh_enter (argc, argv, call_back);
00074        call_back(argc, argv);
00075        
00076 }
00077 
00078 void
00079 initialize_scheme () {
00080        if(!scheme_init(the_scheme)) {
00081               cout << "Could not initialize TinyScheme" << LF;
00082        }
00083        scheme_set_output_port_file(the_scheme, stdout);
00084        scheme_set_input_port_file(the_scheme, stdin);
00085 
00086        const char* init_prg =
00087 #if 0
00088        "(read-set! keywords 'prefix)\n"
00089        "(read-enable 'positions)\n"
00090        "(debug-enable 'debug)\n"
00091        ";(debug-enable 'backtrace)\n"
00092        "\n"
00093 #endif
00094        "(define (display-to-string obj)\n"
00095        "  (call-with-output-string\n"
00096        "    (lambda (port) (display obj port))))\n"
00097        "(define (object->string obj)\n"
00098        "  (call-with-output-string\n"
00099        "    (lambda (port) (write obj port))))\n"
00100        "\n"
00101        "(define (texmacs-version) \"" TEXMACS_VERSION "\")\n"
00102        "(define object-stack '(()))";
00103        
00104        scm_eval_string (init_prg);
00105        initialize_glue ();
00106        object_stack= scm_lookup_string ("object-stack");
00107        
00108        
00109        scm_eval_string("(load (url-concretize \"$TEXMACS_PATH/progs/init-tinyscheme.scm\"))");
00110        scm_eval_string("(load (url-concretize \"$TEXMACS_PATH/progs/init-scheme-tm.scm\"))");
00111        
00112        //REPL
00113        //scm_eval_file (stdin);
00114        scheme_load_named_file(the_scheme,stdin,0);
00115 
00116 }
00117 
00118 #if 0
00119 /******************************************************************************
00120  * Catching errors (with thanks to Dale P. Smith)
00121  ******************************************************************************/
00122 
00123 scm
00124 TeXmacs_lazy_catcher (void *data, scm tag, scm throw_args) {
00125        scm eport= scm_current_error_port();
00126        scm_handle_by_message_noexit (data, tag, throw_args);
00127        scm_force_output (eport);
00128        scm_ithrow (tag, throw_args, 1);
00129        return scm_UNSPECIFIED; /* never returns */
00130 }
00131 
00132 scm
00133 TeXmacs_catcher (void *data, scm tag, scm args) {
00134        (void) data;
00135        return scm_cons (tag, args);
00136 }
00137 #endif
00138 
00139 /******************************************************************************
00140  * Evaluation of files
00141  ******************************************************************************/
00142 #if 0
00143 static scm
00144 TeXmacs_lazy_eval_file (char *file) {
00145        
00146        return scm_internal_lazy_catch (scm_BOOL_T,
00147                                                                (scm_t_catch_body) scm_c_primitive_load, file,
00148                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, file);
00149 }
00150 
00151 static scm
00152 TeXmacs_eval_file (char *file) {
00153        return scm_internal_catch (scm_BOOL_T,
00154                                                     (scm_t_catch_body) TeXmacs_lazy_eval_file, file,
00155                                                     (scm_t_catch_handler) TeXmacs_catcher, file);
00156 }
00157 #endif 
00158 scm
00159 eval_scheme_file (string file) {
00160        //static int cumul= 0;
00161        //timer tm;
00162        if (DEBUG_STD) cout << "TeXmacs] Evaluating " << file << "...\n";
00163        char* _file= as_charp (file);
00164        FILE *f = fopen(_file, "r");
00165        scm result= scm_eval_file (f);
00166        fclose(f);
00167        tm_delete_array (_file);
00168        //int extra= tm->watch (); cumul += extra;
00169        //cout << extra << "\t" << cumul << "\t" << file << "\n";
00170        return result;
00171 }
00172 
00173 /******************************************************************************
00174  * Evaluation of strings
00175  ******************************************************************************/
00176 #if 0
00177 static scm
00178 TeXmacs_lazy_eval_string (char *s) {
00179        return scm_internal_lazy_catch (scm_BOOL_T,
00180                                                                (scm_t_catch_body) scm_c_eval_string, s,
00181                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, s);
00182 }
00183 
00184 static scm
00185 TeXmacs_eval_string (char *s) {
00186        return scm_internal_catch (scm_BOOL_T,
00187                                                     (scm_t_catch_body) TeXmacs_lazy_eval_string, s,
00188                                                     (scm_t_catch_handler) TeXmacs_catcher, s);
00189 }
00190 #endif
00191 scm
00192 eval_scheme (string s) {
00193        // cout << "Eval] " << s << "\n";
00194        char* _s= as_charp (s);
00195        scm result= scm_eval_string (_s);
00196        tm_delete_array (_s);
00197        return result;
00198 }
00199 
00200 /******************************************************************************
00201  * Using scheme objects as functions
00202  ******************************************************************************/
00203 
00204 struct arg_list { int  n; scm* a; };
00205 
00206 scm
00207 TeXmacs_call_scm (arg_list* args) {
00208        switch (args->n) {
00209               default:
00210               {
00211                      int i;
00212                      scm l= scm_null ();
00213                      for (i=args->n; i>=1; i--)
00214                             l= scm_cons (args->a[i], l);
00215                      return scm_apply (args->a[0], l);
00216               }
00217        }
00218 }
00219 #if 0
00220 static scm
00221 TeXmacs_lazy_call_scm (arg_list* args) {
00222        return scm_internal_lazy_catch (scm_BOOL_T,
00223                                                                (scm_t_catch_body) TeXmacs_call, (void*) args,
00224                                                                (scm_t_catch_handler) TeXmacs_lazy_catcher, (void*) args);
00225 }
00226 
00227 static scm
00228 TeXmacs_call_scm (arg_list *args) {
00229        return scm_internal_catch (scm_BOOL_T,
00230                                                     (scm_t_catch_body) TeXmacs_lazy_call_scm, (void*) args,
00231                                                     (scm_t_catch_handler) TeXmacs_catcher, (void*) args);
00232 }
00233 #endif
00234 scm
00235 call_scheme (scm fun) {
00236        scm a[]= { fun }; arg_list args= { 0, a };
00237        return TeXmacs_call_scm (&args);
00238 }
00239 
00240 scm
00241 call_scheme (scm fun, scm a1) {
00242        scm a[]= { fun, a1 }; arg_list args= { 1, a };
00243        return TeXmacs_call_scm (&args);
00244 }
00245 
00246 scm
00247 call_scheme (scm fun, scm a1, scm a2) {
00248        scm a[]= { fun, a1, a2 }; arg_list args= { 2, a };
00249        return TeXmacs_call_scm (&args);
00250 }
00251 
00252 scm
00253 call_scheme (scm fun, scm a1, scm a2, scm a3) {
00254        scm a[]= { fun, a1, a2, a3 }; arg_list args= { 3, a };
00255        return TeXmacs_call_scm (&args);
00256 }
00257 
00258 scm
00259 call_scheme (scm fun, scm a1, scm a2, scm a3, scm a4) {
00260        scm a[]= { fun, a1, a2, a3, a4 }; arg_list args= { 4, a };
00261        return TeXmacs_call_scm (&args);
00262 }
00263 
00264 scm
00265 call_scheme (scm fun, array<scm> a) {
00266        const int n= N(a);
00267        STACK_NEW_ARRAY(v, scm, n+1);
00268        int i;
00269        v[0]= fun;
00270        for (i=0; i<n; i++) v[i+1]= a[i];
00271        arg_list args= { n, v };
00272        scm ret= TeXmacs_call_scm (&args);
00273        STACK_DELETE_ARRAY(scm);
00274        return ret;
00275 }
00276 
00277 
00278 /******************************************************************************
00279  * Gluing
00280  ******************************************************************************/
00281 
00282 
00283 string
00284 scheme_dialect () {
00285        return "littlescheme";
00286 }
00287 
00288 void scm_define_glue(const char *name, scm_foreign_func f)
00289 {
00290        //  cout << "Define glue: " << name << LF;
00291        scm_define(symbol_to_scm(name), mk_foreign_func (the_scheme, f));
00292 }
00293 
00294 
00295 
00296 
00297 /******************************************************************************
00298  * Strings
00299  ******************************************************************************/
00300 
00301 scm
00302 string_to_scm (string s) {
00303        char* _s= as_charp (s);
00304        scm r= mk_counted_string (the_scheme,_s, N(s));
00305        tm_delete_array (_s);
00306        return r;
00307 }
00308 
00309 /******************************************************************************
00310  * Symbols
00311  ******************************************************************************/
00312 
00313 scm
00314 symbol_to_scm (string s) {
00315        char* _s= as_charp (s);
00316        scm r= mk_symbol (the_scheme,_s);
00317        tm_delete_array (_s);
00318        return r;
00319 }
00320