src/src/Style/Evaluate/evaluate_rewrite.cpp

   1
   2 /******************************************************************************
   3 * MODULE     : evaluate_rewrite.cpp
   4 * DESCRIPTION: tree rewriting before evaluation
   5 * COPYRIGHT  : (C) 2006  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 #include "evaluate_main.hpp"
  13 #include "memorizer.hpp"
  14 #include "std_environment.hpp"
  15 #include "vars.hpp"
  16 #include "scheme.hpp"
  17
  18 extern int script_status;
  19
  20 /******************************************************************************
  21 * Memorizing rewritings
  22 ******************************************************************************/
  23
  24 static tree no_tree (UNINIT);
  25
  26 class memorizer;
  27 class rewrite_memorizer_rep: public compound_memorizer_rep {
  28   environment env_in;
  29   tree t_in;
  30   environment env_out;
  31   tree t_out;
  32
  33 public:
  34   inline rewrite_memorizer_rep (environment env, tree t):
  35     env_in (env), t_in (t), env_out (), t_out (no_tree) {}
  36   void print (tm_ostream& out) {
  37     out << "rewrite_memorizer (" << t_in << ")"; }
  38
  39   int type () { return MEMORIZE_REWRITE; }
  40   int hash () { return weak_hash (env_in) ^ weak_hash (t_in); }
  41   bool equal (memorizer_rep* mem) {
  42     rewrite_memorizer_rep* rep= (rewrite_memorizer_rep*) mem;
  43     return weak_equal (env_in, rep->env_in) && weak_equal (t_in, rep->t_in); }
  44
  45   void set_environment (environment env) { env_out= env; }
  46   environment get_environment () { return env_out; }
  47   void set_tree (tree t) { t_out= t; }
  48   tree get_tree () { return t_out; }
  49 };
  50
  51 inline memorizer
  52 rewrite_memorizer (environment env, tree t) {
  53   return (memorizer_rep*) tm_new<rewrite_memorizer_rep> (env, t);
  54 }
  55
  56 /******************************************************************************
  57 * Reentrant evaluations
  58 ******************************************************************************/
  59
  60 // Hack to transmit the current environment back to C++
  61 // across the Scheme level, and to maintain reentrancy.
  62 static environment reenter_rewrite_env;
  63
  64 tree
  65 texmacs_evaluate (environment env, tree t) {
  66   // re-entrancy
  67   if (!is_nil (reenter_rewrite_env)) env= reenter_rewrite_env;
  68   environment old_env= std_env;
  69   std_env= env;
  70   tree r= evaluate (t);
  71   std_env= old_env;
  72   return r;
  73 }
  74
  75 /******************************************************************************
  76 * Rewriting (scheme-like macro expansion)
  77 ******************************************************************************/
  78
  79 tree
  80 rewrite_impl (tree t) {
  81   switch (L(t)) {
  82   case EXTERN:
  83     {
  84       int i, n= N(t);
  85       tree r (TUPLE, n);
  86       for (i=0; i<n; i++)
  87         r[i]= evaluate (t[i]);
  88       object expr= null_object ();
  89       for (i=n-1; i>0; i--)
  90         expr= cons (object (r[i]), expr);
  91       string fun= evaluate_string (t[0]);
  92       expr= cons (string_to_object (fun), expr);
  93       (void) eval ("(lazy-markup-modules-force)");
  94       bool secure= as_bool (std_env ["secure"]);
  95       if (!secure && script_status < 2) {
  96         if (!as_bool (call ("secure?", expr)))
  97           return tree (ERROR, "insecure script");
  98       }
  99       environment old_env= reenter_rewrite_env;
 100       reenter_rewrite_env= std_env;
 101       object o= eval (expr);
 102       reenter_rewrite_env= old_env;
 103       return content_to_tree (o);
 104     }
 105 #ifdef CLASSICAL_MACRO_EXPANSION
 106   case MAP_ARGS:
 107     {
 108       if (!(is_atomic (t[0]) && is_atomic (t[1]) && is_atomic (t[2])))
 109         return evaluate_error ("invalid map-args");
 110       if (macro_top_level (std_env))
 111         return evaluate_error ("undefined", t[2]);
 112       basic_environment local= macro_arguments (std_env);
 113       int key= make_tree_label (t[2]->label);
 114       if (!local->contains (key))
 115         return evaluate_error ("undefined", t[2]);
 116       tree v= local [key];
 117       if (is_atomic (v))
 118         return evaluate_error ("invalid-map-args");
 119       macro_up (std_env);
 120
 121       int start= 0, end= N(v);
 122       if (N(t)>=4) start= as_int (evaluate (t[3]));
 123       if (N(t)>=5) end  = as_int (evaluate (t[4]));
 124       int i, n= max (0, end-start);
 125       tree r (make_tree_label (t[1]->label), n);
 126       for (i=0; i<n; i++)
 127         r[i]= tree (make_tree_label (t[0]->label),
 128                     tree (ARG, copy (t[2]), as_string (start+i)),
 129                     as_string (start+i));
 130
 131       macro_redown (std_env, local);
 132       return r;
 133     }
 134 #endif // CLASSICAL_MACRO_EXPANSION
 135   case INCLUDE:
 136     {
 137       url base_file_name (as_string (std_env ["base-file-name"]));
 138       url file_name= url_system (evaluate_string (t[0]));
 139       return load_inclusion (relative (base_file_name, file_name));
 140     }
 141   case REWRITE_INACTIVE:
 142     {
 143 #ifdef CLASSICAL_MACRO_EXPANSION
 144       if ((!is_func (t[0], ARG)) || is_compound (t[0][0]))
 145         return evaluate_error ("invalid rewrite-inactive");
 146       if (macro_top_level (std_env))
 147         return evaluate_error ("undefined", t[0][0]);
 148       basic_environment local= macro_arguments (std_env);
 149       int key= make_tree_label (t[0][0]->label);
 150       if (!local->contains (key))
 151         return evaluate_error ("undefined", t[0][0]);
 152       tree val= local [key];
 153       int i, n= N(t[0]);
 154       for (i=1; i<n; i++) {
 155         int j= as_int (t[0][i]);
 156         if ((j>=0) && (j<N(val))) val= val[j];
 157         else return evaluate_error ("invalid rewrite-inactive");
 158       }
 159 #else
 160       tree val= t[0];
 161 #endif
 162       int inactive_mode= INACTIVE_INLINE_RECURSE;
 163       if (t[1] == "recurse") inactive_mode= INACTIVE_INLINE_RECURSE;
 164       else if (t[1] == "recurse*") inactive_mode= INACTIVE_BLOCK_RECURSE;
 165       else if (t[1] == "once") inactive_mode= INACTIVE_INLINE_ONCE;
 166       else if (t[1] == "once*") inactive_mode= INACTIVE_BLOCK_ONCE;
 167       else if (t[1] == "error") inactive_mode= INACTIVE_INLINE_ERROR;
 168       else if (t[1] == "error*") inactive_mode= INACTIVE_BLOCK_ERROR;
 169       return rewrite_inactive (val, inactive_mode);
 170     }
 171   default:
 172     return t;
 173   }
 174 }
 175
 176 /******************************************************************************
 177 * Main rewriting routines
 178 ******************************************************************************/
 179
 180 tree
 181 rewrite (tree t) {
 182   cout << "Rewrite "
 183     //<< "[" << (t.operator -> ())
 184     //<< ", " << (std_env.operator -> ()) << "] "
 185        << t << INDENT << LF;
 186   memorizer mem= rewrite_memorizer (std_env, t);
 187   if (is_memorized (mem)) {
 188     cout << UNINDENT << "Memorized " << mem->get_tree () << LF;
 189     std_env= mem->get_environment ();
 190     return mem->get_tree ();
 191   }
 192   memorize_start ();
 193   tree r= rewrite_impl (t);
 194   decorate_ip (t, r);
 195   mem->set_tree (r);
 196   mem->set_environment (std_env);
 197   memorize_end ();
 198   cout << UNINDENT << "Rewritten as " << mem->get_tree () << LF;
 199   return mem->get_tree ();
 200 }
 201
 202 tree
 203 evaluate_rewrite (tree t) {
 204   return evaluate (rewrite (t));
 205 }