Back to index

texmacs  1.0.7.15
evaluate_rewrite.cpp
Go to the documentation of this file.
00001 
00002 /******************************************************************************
00003 * MODULE     : evaluate_rewrite.cpp
00004 * DESCRIPTION: tree rewriting before evaluation
00005 * COPYRIGHT  : (C) 2006  Joris van der Hoeven
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 "evaluate_main.hpp"
00013 #include "memorizer.hpp"
00014 #include "std_environment.hpp"
00015 #include "vars.hpp"
00016 #include "scheme.hpp"
00017 
00018 extern int script_status;
00019 
00020 /******************************************************************************
00021 * Memorizing rewritings
00022 ******************************************************************************/
00023 
00024 static tree no_tree (UNINIT);
00025 
00026 class memorizer;
00027 class rewrite_memorizer_rep: public compound_memorizer_rep {
00028   environment env_in;
00029   tree t_in;
00030   environment env_out;
00031   tree t_out;
00032 
00033 public:
00034   inline rewrite_memorizer_rep (environment env, tree t):
00035     env_in (env), t_in (t), env_out (), t_out (no_tree) {}
00036   void print (tm_ostream& out) {
00037     out << "rewrite_memorizer (" << t_in << ")"; }
00038 
00039   int type () { return MEMORIZE_REWRITE; }
00040   int hash () { return weak_hash (env_in) ^ weak_hash (t_in); }
00041   bool equal (memorizer_rep* mem) {
00042     rewrite_memorizer_rep* rep= (rewrite_memorizer_rep*) mem;
00043     return weak_equal (env_in, rep->env_in) && weak_equal (t_in, rep->t_in); }
00044 
00045   void set_environment (environment env) { env_out= env; }
00046   environment get_environment () { return env_out; }
00047   void set_tree (tree t) { t_out= t; }
00048   tree get_tree () { return t_out; }
00049 };
00050 
00051 inline memorizer
00052 rewrite_memorizer (environment env, tree t) {
00053   return (memorizer_rep*) tm_new<rewrite_memorizer_rep> (env, t);
00054 }
00055 
00056 /******************************************************************************
00057 * Reentrant evaluations
00058 ******************************************************************************/
00059 
00060 // Hack to transmit the current environment back to C++
00061 // across the Scheme level, and to maintain reentrancy.
00062 static environment reenter_rewrite_env;
00063 
00064 tree
00065 texmacs_evaluate (environment env, tree t) {
00066   // re-entrancy
00067   if (!is_nil (reenter_rewrite_env)) env= reenter_rewrite_env;
00068   environment old_env= std_env;
00069   std_env= env;
00070   tree r= evaluate (t);
00071   std_env= old_env;
00072   return r;
00073 }
00074 
00075 /******************************************************************************
00076 * Rewriting (scheme-like macro expansion)
00077 ******************************************************************************/
00078 
00079 tree
00080 rewrite_impl (tree t) {
00081   switch (L(t)) {
00082   case EXTERN:
00083     {
00084       int i, n= N(t);
00085       tree r (TUPLE, n);
00086       for (i=0; i<n; i++)
00087        r[i]= evaluate (t[i]);
00088       object expr= null_object ();
00089       for (i=n-1; i>0; i--)
00090        expr= cons (object (r[i]), expr);
00091       string fun= evaluate_string (t[0]);
00092       expr= cons (string_to_object (fun), expr);
00093       bool secure= as_bool (std_env ["secure"]);
00094       if (!secure && script_status < 2) {
00095        if (!as_bool (call ("secure?", expr)))
00096          return tree (ERROR, "insecure script");
00097       }
00098       environment old_env= reenter_rewrite_env;
00099       reenter_rewrite_env= std_env;
00100       object o= eval (expr);
00101       reenter_rewrite_env= old_env;
00102       return content_to_tree (o);
00103     }
00104 #ifdef CLASSICAL_MACRO_EXPANSION
00105   case MAP_ARGS:
00106     {
00107       if (!(is_atomic (t[0]) && is_atomic (t[1]) && is_atomic (t[2])))
00108        return evaluate_error ("invalid map-args");
00109       if (macro_top_level (std_env))
00110        return evaluate_error ("undefined", t[2]);
00111       basic_environment local= macro_arguments (std_env);
00112       int key= make_tree_label (t[2]->label);
00113       if (!local->contains (key))
00114        return evaluate_error ("undefined", t[2]);
00115       tree v= local [key];
00116       if (is_atomic (v))
00117        return evaluate_error ("invalid-map-args");
00118       macro_up (std_env);
00119 
00120       int start= 0, end= N(v);
00121       if (N(t)>=4) start= as_int (evaluate (t[3]));
00122       if (N(t)>=5) end  = as_int (evaluate (t[4]));
00123       int i, n= max (0, end-start);
00124       tree r (make_tree_label (t[1]->label), n);
00125       for (i=0; i<n; i++)
00126        r[i]= tree (make_tree_label (t[0]->label),
00127                   tree (ARG, copy (t[2]), as_string (start+i)),
00128                   as_string (start+i));
00129 
00130       macro_redown (std_env, local);
00131       return r;
00132     }
00133 #endif // CLASSICAL_MACRO_EXPANSION
00134   case INCLUDE:
00135     {
00136       url base_file_name (as_string (std_env ["base-file-name"]));
00137       url file_name= url_system (evaluate_string (t[0]));
00138       return load_inclusion (relative (base_file_name, file_name));
00139     }
00140   case REWRITE_INACTIVE:
00141     {
00142 #ifdef CLASSICAL_MACRO_EXPANSION      
00143       if ((!is_func (t[0], ARG)) || is_compound (t[0][0]))
00144        return evaluate_error ("invalid rewrite-inactive");
00145       if (macro_top_level (std_env))
00146        return evaluate_error ("undefined", t[0][0]);
00147       basic_environment local= macro_arguments (std_env);
00148       int key= make_tree_label (t[0][0]->label);
00149       if (!local->contains (key))
00150        return evaluate_error ("undefined", t[0][0]);
00151       tree val= local [key];
00152       int i, n= N(t[0]);
00153       for (i=1; i<n; i++) {
00154        int j= as_int (t[0][i]);
00155        if ((j>=0) && (j<N(val))) val= val[j];
00156        else return evaluate_error ("invalid rewrite-inactive");
00157       }
00158 #else
00159       tree val= t[0];
00160 #endif
00161       int inactive_mode= INACTIVE_INLINE_RECURSE;
00162       if (t[1] == "recurse") inactive_mode= INACTIVE_INLINE_RECURSE;
00163       else if (t[1] == "recurse*") inactive_mode= INACTIVE_BLOCK_RECURSE;
00164       else if (t[1] == "once") inactive_mode= INACTIVE_INLINE_ONCE;
00165       else if (t[1] == "once*") inactive_mode= INACTIVE_BLOCK_ONCE;
00166       else if (t[1] == "error") inactive_mode= INACTIVE_INLINE_ERROR;
00167       else if (t[1] == "error*") inactive_mode= INACTIVE_BLOCK_ERROR;
00168       return rewrite_inactive (val, inactive_mode);
00169     }
00170   default:
00171     return t;
00172   }
00173 }
00174 
00175 /******************************************************************************
00176 * Main rewriting routines
00177 ******************************************************************************/
00178 
00179 tree
00180 rewrite (tree t) {
00181   cout << "Rewrite "
00182     //<< "[" << (t.operator -> ())
00183     //<< ", " << (std_env.operator -> ()) << "] "
00184        << t << INDENT << LF;
00185   memorizer mem= rewrite_memorizer (std_env, t);
00186   if (is_memorized (mem)) {
00187     cout << UNINDENT << "Memorized " << mem->get_tree () << LF;
00188     std_env= mem->get_environment ();
00189     return mem->get_tree ();
00190   }
00191   memorize_start ();
00192   tree r= rewrite_impl (t);
00193   decorate_ip (t, r);
00194   mem->set_tree (r);
00195   mem->set_environment (std_env);
00196   memorize_end ();
00197   cout << UNINDENT << "Rewritten as " << mem->get_tree () << LF;
00198   return mem->get_tree ();
00199 }
00200 
00201 tree
00202 evaluate_rewrite (tree t) {
00203   return evaluate (rewrite (t));
00204 }