1
2 /******************************************************************************
3 * MODULE : env_exec.cpp
4 * DESCRIPTION: evaluation of trees w.r.t. the environment
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 #include "env.hpp"
13 #include "convert.hpp"
14 #include "file.hpp"
15 #include "image_files.hpp"
16 #include "scheme.hpp"
17 #include "page_type.hpp"
18 #include "typesetter.hpp"
19 #include "drd_mode.hpp"
20 #include "dictionary.hpp"
21
22 extern int script_status;
23
24 /******************************************************************************
25 * Subroutines
26 ******************************************************************************/
27
28 string
exec_string(tree t)29 edit_env_rep::exec_string (tree t) {
30 tree r= exec (t);
31 if (is_atomic (r)) return r->label;
32 else return "";
33 }
34
35 /******************************************************************************
36 * Rewriting (scheme-like macro expansion)
37 ******************************************************************************/
38
39 // Hack to transmit the current environment back to C++
40 // across the Scheme level, and to maintain reentrancy.
41 static edit_env current_rewrite_env= edit_env ();
42
43 tree
rewrite(tree t)44 edit_env_rep::rewrite (tree t) {
45 switch (L(t)) {
46 case EXTERN:
47 {
48 int i, n= N(t);
49 if (n < 1) return tree (ERROR, "invalid extern");
50 string fun= tm_decode(exec_string (t[0]));
51 tree r (TUPLE, n);
52 for (i=1; i<n; i++)
53 r[i]= exec (t[i]);
54 object expr= null_object ();
55 for (i=n-1; i>0; i--)
56 expr= cons (object (r[i]), expr);
57 expr= cons (string_to_object (fun), expr);
58 if (!secure && script_status < 2) {
59 if (!as_bool (call ("secure?", expr)))
60 return tree (ERROR, "insecure script");
61 }
62 edit_env old_env= current_rewrite_env;
63 current_rewrite_env= edit_env (this);
64 object o= eval (expr);
65 current_rewrite_env= old_env;
66 return content_to_tree (o);
67 }
68 case MAP_ARGS:
69 {
70 if (N(t) < 3 ||
71 !(is_atomic (t[0]) && is_atomic (t[1]) && is_atomic (t[2])))
72 return tree (ERROR, "invalid map arguments");
73 if (is_nil (macro_arg) || (!macro_arg->item->contains (t[2]->label)))
74 return tree (ERROR, "map arguments " * t[2]->label);
75 tree v= macro_arg->item [t[2]->label];
76 if (is_atomic (v))
77 return tree (ERROR, "map arguments " * t[2]->label);
78 list<hashmap<string,tree> > old_var= macro_arg;
79 list<hashmap<string,path> > old_src= macro_src;
80 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
81 if (!is_nil (macro_src)) macro_src= macro_src->next;
82
83 int start= 0, end= N(v);
84 if (N(t)>=4) start= as_int (exec (t[3]));
85 if (N(t)>=5) end = as_int (exec (t[4]));
86 int i, n= max (0, end-start);
87 tree r (make_tree_label (t[1]->label), n);
88 if (t[0]->label == "identity")
89 for (i=0; i<n; i++)
90 r[i]= tree (ARG, copy (t[2]), as_string (start+i));
91 else
92 for (i=0; i<n; i++)
93 r[i]= tree (make_tree_label (t[0]->label),
94 tree (ARG, copy (t[2]), as_string (start+i)),
95 as_string (start+i));
96 macro_arg= old_var;
97 macro_src= old_src;
98 return r;
99 }
100 case VAR_INCLUDE:
101 {
102 if (N(t) == 0) return tree (ERROR, "invalid include");
103 url file_name= url_unix (exec_string (t[0]));
104 //cout << "file_name= " << as_tree (file_name) << LF;
105 return load_inclusion (relative (base_file_name, file_name));
106 }
107 case REWRITE_INACTIVE:
108 {
109 if (N(t) == 0 || N(t[0]) == 0)
110 return tree (ERROR, "invalid rewrite-inactive");
111 if ((!is_func (t[0], ARG)) ||
112 is_compound (t[0][0]) ||
113 is_nil (macro_arg) ||
114 (!macro_arg->item->contains (t[0][0]->label)))
115 return tree (ERROR, "invalid rewrite-inactive");
116 tree val= macro_arg->item [t[0][0]->label];
117 int i, n= N(t[0]);
118 for (i=1; i<n; i++) {
119 int j= as_int (t[0][i]);
120 if ((j>=0) && (j<N(val))) val= val[j];
121 else return tree (ERROR, "invalid rewrite-inactive");
122 }
123 if (N(t) < 2)
124 return tree (ERROR, "invalid rewrite-inactive");
125 if (t[1] == "recurse") inactive_mode= INACTIVE_INLINE_RECURSE;
126 else if (t[1] == "recurse*") inactive_mode= INACTIVE_BLOCK_RECURSE;
127 else if (t[1] == "once") inactive_mode= INACTIVE_INLINE_ONCE;
128 else if (t[1] == "once*") inactive_mode= INACTIVE_BLOCK_ONCE;
129 else if (t[1] == "error") inactive_mode= INACTIVE_INLINE_ERROR;
130 else if (t[1] == "error*") inactive_mode= INACTIVE_BLOCK_ERROR;
131 else inactive_mode= INACTIVE_INLINE_RECURSE;
132 return rewrite_inactive (val, t[0]);
133 }
134 default:
135 return t;
136 }
137 }
138
139 tree
exec_rewrite(tree t)140 edit_env_rep::exec_rewrite (tree t) {
141 /*
142 cout << "t= " << t << "\n";
143 tree r= rewrite (t);
144 r= exec (r);
145 cout << "r= " << r << "\n";
146 return r;
147 */
148 return exec (rewrite (t));
149 }
150
151 bool
exec_until_rewrite(tree t,path p,string var,int level)152 edit_env_rep::exec_until_rewrite (tree t, path p, string var, int level) {
153 /*
154 cout << "Execute " << t << " (" << var << ", "
155 << level << ") until " << p << "\n"
156 << " -> " << rewrite (t) << "\n";
157 */
158 return exec_until (rewrite (t), p, var, level);
159 }
160
161 tree
texmacs_exec(edit_env env,tree cmd)162 texmacs_exec (edit_env env, tree cmd) {
163 // re-entrancy
164 if (!is_nil (current_rewrite_env)) env= current_rewrite_env;
165 return env->exec (cmd);
166 }
167
168 /******************************************************************************
169 * Evaluation of trees
170 ******************************************************************************/
171
172 tree
exec(tree t)173 edit_env_rep::exec (tree t) {
174 // cout << "Execute: " << t << "\n";
175 if (is_atomic (t)) return t;
176 switch (L(t)) {
177 case DATOMS:
178 return exec_formatting (t, ATOM_DECORATIONS);
179 case DLINES:
180 return exec_formatting (t, LINE_DECORATIONS);
181 case DPAGES:
182 return exec_formatting (t, PAGE_DECORATIONS);
183 case TFORMAT:
184 return exec_formatting (t, CELL_FORMAT);
185 case TABLE:
186 return exec_table (t);
187 case ASSIGN:
188 return exec_assign (t);
189 case WITH:
190 return exec_with (t);
191 case PROVIDES:
192 return exec_provides (t);
193 case VALUE:
194 return exec_value (t);
195 case QUOTE_VALUE:
196 return exec_quote_value (t);
197 case MACRO:
198 return copy (t);
199 case DRD_PROPS:
200 return exec_drd_props (t);
201 case ARG:
202 return exec_arg (t);
203 case QUOTE_ARG:
204 return exec_quote_arg (t);
205 case COMPOUND:
206 return exec_compound (t);
207 case XMACRO:
208 return copy (t);
209 case GET_LABEL:
210 return exec_get_label (t);
211 case GET_ARITY:
212 return exec_get_arity (t);
213 case MAP_ARGS:
214 return exec_rewrite (t);
215 case EVAL_ARGS:
216 return exec_eval_args (t);
217 case MARK:
218 if (N(t) < 2)
219 return tree (ERROR, "invalid mark");
220 return tree (MARK, copy (t[0]), exec (t[1]));
221 case EXPAND_AS:
222 if (N(t) < 2)
223 return tree (ERROR, "invalid expand-as");
224 return exec (t[1]);
225 case EVAL:
226 if (N(t) < 1)
227 return tree (ERROR, "invalid eval");
228 return exec (exec (t[0]));
229 case QUOTE:
230 if (N(t) < 1)
231 return tree (ERROR, "invalid quote");
232 return t[0];
233 case QUASI:
234 if (N(t) < 1)
235 return tree (ERROR, "invalid quasi");
236 return exec (exec_quasiquoted (t[0]));
237 case QUASIQUOTE:
238 if (N(t) < 1)
239 return tree (ERROR, "invalid quasiquote");
240 return exec_quasiquoted (t[0]);
241 case UNQUOTE:
242 if (N(t) < 1)
243 return tree (ERROR, "invalid unquote");
244 return exec (t[0]);
245 case VAR_UNQUOTE:
246 if (N(t) < 1)
247 return tree (ERROR, "invalid var-unquote");
248 return exec (t[0]);
249 case COPY:
250 if (N(t) < 1)
251 return tree (ERROR, "invalid copy");
252 return copy (exec (t[0]));
253 case IF:
254 case VAR_IF:
255 return exec_if (t);
256 case CASE:
257 return exec_case (t);
258 case WHILE:
259 return exec_while (t);
260 case FOR_EACH:
261 return exec_for_each (t);
262 case EXTERN:
263 return exec_rewrite (t);
264 case VAR_INCLUDE:
265 return exec_rewrite (t);
266 case USE_PACKAGE:
267 return exec_use_package (t);
268 case USE_MODULE:
269 return exec_use_module (t);
270
271 case OR:
272 return exec_or (t);
273 case XOR:
274 return exec_xor (t);
275 case AND:
276 return exec_and (t);
277 case NOT:
278 return exec_not (t);
279 case PLUS:
280 case MINUS:
281 return exec_plus_minus (t);
282 case TIMES:
283 case OVER:
284 return exec_times_over (t);
285 case DIV:
286 return exec_divide (t);
287 case MOD:
288 return exec_modulo (t);
289 case MINIMUM:
290 case MAXIMUM:
291 return exec_min_max (t);
292 case MATH_SQRT:
293 return exec_math_sqrt (t);
294 case EXP:
295 return exec_exp (t);
296 case LOG:
297 return exec_log (t);
298 case POW:
299 return exec_pow (t);
300 case COS:
301 return exec_cos (t);
302 case SIN:
303 return exec_sin (t);
304 case TAN:
305 return exec_tan (t);
306 case MERGE:
307 return exec_merge (t);
308 case LENGTH:
309 return exec_length (t);
310 case RANGE:
311 return exec_range (t);
312 case NUMBER:
313 return exec_number (t);
314 case _DATE:
315 return exec_date (t);
316 case TRANSLATE:
317 return exec_translate (t);
318 case CHANGE_CASE:
319 return exec_change_case (t);
320 case FIND_FILE:
321 return exec_find_file (t);
322 case FIND_FILE_UPWARDS:
323 return exec_find_file_upwards (t);
324 case IS_TUPLE:
325 return exec_is_tuple (t);
326 case LOOK_UP:
327 return exec_lookup (t);
328 case EQUAL:
329 return exec_equal (t);
330 case UNEQUAL:
331 return exec_unequal (t);
332 case LESS:
333 return exec_less (t);
334 case LESSEQ:
335 return exec_lesseq (t);
336 case GREATER:
337 return exec_greater (t);
338 case GREATEREQ:
339 return exec_greatereq (t);
340 case BLEND:
341 return exec_blend (t);
342
343 case CM_LENGTH:
344 return exec_cm_length ();
345 case MM_LENGTH:
346 return exec_mm_length ();
347 case IN_LENGTH:
348 return exec_in_length ();
349 case PT_LENGTH:
350 return exec_pt_length ();
351 case BP_LENGTH:
352 return exec_bp_length ();
353 case DD_LENGTH:
354 return exec_dd_length ();
355 case PC_LENGTH:
356 return exec_pc_length ();
357 case CC_LENGTH:
358 return exec_cc_length ();
359 case FS_LENGTH:
360 return exec_fs_length ();
361 case FBS_LENGTH:
362 return exec_fbs_length ();
363 case EM_LENGTH:
364 return exec_em_length ();
365 case LN_LENGTH:
366 return exec_ln_length ();
367 case SEP_LENGTH:
368 return exec_sep_length ();
369 case YFRAC_LENGTH:
370 return exec_yfrac_length ();
371 case EX_LENGTH:
372 return exec_ex_length ();
373 case FN_LENGTH:
374 return exec_fn_length ();
375 case FNS_LENGTH:
376 return exec_fns_length ();
377 case BLS_LENGTH:
378 return exec_bls_length ();
379 case FNBOT_LENGTH:
380 return exec_fnbot_length ();
381 case FNTOP_LENGTH:
382 return exec_fntop_length ();
383 case SPC_LENGTH:
384 return exec_spc_length ();
385 case XSPC_LENGTH:
386 return exec_xspc_length ();
387 case PAR_LENGTH:
388 return exec_par_length ();
389 case PAG_LENGTH:
390 return exec_pag_length ();
391 case GW_LENGTH:
392 return exec_gw_length ();
393 case GH_LENGTH:
394 return exec_gh_length ();
395 case GU_LENGTH:
396 return exec_gu_length ();
397 case TMPT_LENGTH:
398 return exec_tmpt_length ();
399 case PX_LENGTH:
400 return exec_px_length ();
401 case MSEC_LENGTH:
402 return exec_msec_length ();
403 case SEC_LENGTH:
404 return exec_sec_length ();
405 case MIN_LENGTH:
406 return exec_min_length ();
407 case HR_LENGTH:
408 return exec_hr_length ();
409
410 case STYLE_WITH:
411 case VAR_STYLE_WITH:
412 if (N(t) < 1)
413 return tree (ERROR, "invalid style-with");
414 return exec (t[N(t)-1]);
415 case STYLE_ONLY:
416 case VAR_STYLE_ONLY:
417 case ACTIVE:
418 case VAR_ACTIVE:
419 case INACTIVE:
420 case VAR_INACTIVE:
421 return exec_compound (t);
422 case REWRITE_INACTIVE:
423 return exec_rewrite (t);
424
425 case HARD_ID:
426 return exec_hard_id (t);
427 case SCRIPT:
428 return exec_script (t);
429 case FIND_ACCESSIBLE:
430 return exec_find_accessible (t);
431 case HLINK:
432 case ACTION:
433 return exec_compound (t);
434 case SET_BINDING:
435 return exec_set_binding (t);
436 case GET_BINDING:
437 return exec_get_binding (t);
438 case GET_ATTACHMENT:
439 return exec_get_attachment (t);
440
441 case PATTERN:
442 return exec_pattern (t);
443
444 case _POINT:
445 return exec_point (t);
446
447 case EFF_MOVE:
448 return exec_eff_move (t);
449 case EFF_BUBBLE:
450 return exec_eff_bubble (t);
451 case EFF_GAUSSIAN:
452 return exec_eff_gaussian (t);
453 case EFF_OVAL:
454 return exec_eff_oval (t);
455 case EFF_RECTANGULAR:
456 return exec_eff_rectangular (t);
457 case EFF_MOTION:
458 return exec_eff_motion (t);
459
460 case BOX_INFO:
461 return exec_box_info (t);
462 case FRAME_DIRECT:
463 return exec_frame_direct (t);
464 case FRAME_INVERSE:
465 return exec_frame_inverse (t);
466
467 default:
468 if (L(t) < START_EXTENSIONS) {
469 int i, n= N(t);
470 // cout << "Executing " << t << "\n";
471 tree r (t, n);
472 for (i=0; i<n; i++) r[i]= exec (t[i]);
473 // cout << "Executed " << t << " -> " << r << "\n";
474 return r;
475 }
476 else return exec_compound (t);
477 }
478 }
479
480 tree
exec_formatting(tree t,string v)481 edit_env_rep::exec_formatting (tree t, string v) {
482 int i, n= N(t);
483 if (n < 1)
484 return tree (ERROR, "bad formatting");
485 tree r (t, n);
486 for (i=0; i<n-1; i++) r[i]= exec (t[i]);
487 tree oldv= read (v);
488 tree newv= oldv * r (0, n-1);
489 // monitored_write_update (v, newv);
490 write_update (v, newv);
491 r[n-1]= exec (t[n-1]);
492 write_update (v, oldv);
493 return r;
494 }
495
496 tree
exec_table(tree t)497 edit_env_rep::exec_table (tree t) {
498 tree oldv= read (CELL_FORMAT);
499 // should execute values in oldv
500 // monitored_write_update (CELL_FORMAT, tree (TFORMAT));
501 write_update (CELL_FORMAT, tree (TFORMAT));
502 int i, n= N(t);
503 tree r (t, n);
504 for (i=0; i<n; i++) r[i]= exec (t[i]);
505 write_update (CELL_FORMAT, oldv);
506 return r;
507 }
508
509 tree
exec_assign(tree t)510 edit_env_rep::exec_assign (tree t) {
511 if (N(t)!=2) return tree (ERROR, "bad assign");
512 tree r= exec (t[0]);
513 if (is_compound (r)) return tree (ERROR, "bad assign");
514 assign (r->label, copy (t[1]));
515 tree v= read (r->label);
516 if (is_atomic (v) || is_func (v, MACRO));
517 else v= tree (QUOTE, v);
518 return tree (ASSIGN, r, v);
519 }
520
521 tree
exec_with(tree t)522 edit_env_rep::exec_with (tree t) {
523 int i, n= N(t), k= (n-1)>>1; // is k=0 allowed ?
524 if ((n&1) != 1) return tree (ERROR, "bad with");
525 STACK_NEW_ARRAY(vars,string,k);
526 STACK_NEW_ARRAY(oldv,tree,k);
527 STACK_NEW_ARRAY(newv,tree,k);
528 for (i=0; i<k; i++) {
529 tree var_t= exec (t[i<<1]);
530 if (is_atomic (var_t)) {
531 string var= var_t->label;
532 vars[i]= var;
533 oldv[i]= read (var);
534 newv[i]= exec (t[(i<<1)+1]);
535 }
536 else {
537 STACK_DELETE_ARRAY(vars);
538 STACK_DELETE_ARRAY(oldv);
539 STACK_DELETE_ARRAY(newv);
540 return tree (ERROR, "bad with");
541 }
542 }
543
544 // for (i=0; i<k; i++) monitored_write_update (vars[i], newv[i]);
545 for (i=0; i<k; i++) write_update (vars[i], newv[i]);
546 tree r= exec (t[n-1]);
547 for (i=k-1; i>=0; i--) write_update (vars[i], oldv[i]);
548
549 tree u (WITH, n);
550 for (i=0; i<k; i++) {
551 u[i<<1] = vars[i];
552 u[(i<<1)+1]= tree (QUOTE, newv[i]);
553 }
554 u[n-1]= r;
555 STACK_DELETE_ARRAY(vars);
556 STACK_DELETE_ARRAY(oldv);
557 STACK_DELETE_ARRAY(newv);
558 return u;
559 }
560
561 tree
exec_compound(tree t)562 edit_env_rep::exec_compound (tree t) {
563 int d; tree f;
564 if (L(t) == COMPOUND) {
565 if (N(t)<1) return tree (ERROR, "bad compound");
566 d= 1;
567 f= t[0];
568 if (is_compound (f)) f= exec (f);
569 if (is_atomic (f)) {
570 string var= f->label;
571 if (!provides (var)) return tree (ERROR, "compound " * var);
572 f= read (var);
573 }
574 }
575 else {
576 string var= as_string (L(t));
577 if (!provides (var)) return tree (ERROR, "compound " * var);
578 d= 0;
579 f= read (var);
580 }
581
582 if (is_applicable (f)) {
583 int i, n=N(f)-1, m=N(t)-d;
584 macro_arg= list<hashmap<string,tree> > (
585 hashmap<string,tree> (UNINIT), macro_arg);
586 macro_src= list<hashmap<string,path> > (
587 hashmap<string,path> (path (DECORATION)), macro_src);
588 if (L(f) == XMACRO) {
589 if (is_atomic (f[0]))
590 macro_arg->item (f[0]->label)= t;
591 }
592 else for (i=0; i<n; i++)
593 if (is_atomic (f[i])) {
594 tree st= i<m? t[i+d]: tree (UNINIT);
595 macro_arg->item (f[i]->label)= st;
596 macro_src->item (f[i]->label)= obtain_ip (st);
597 }
598 tree r= exec (f[n]);
599 macro_arg= macro_arg->next;
600 macro_src= macro_src->next;
601 return r;
602 }
603 else return exec (f);
604 }
605
606 tree
exec_drd_props(tree t)607 edit_env_rep::exec_drd_props (tree t) {
608 int i, n= N(t);
609 if ((n>=3) && is_atomic (t[0]))
610 for (i=1; i<n-1; i+=2) {
611 if (!is_atomic (t[i])) continue;
612 string var = t[0]->label;
613 string prop = t[i]->label;
614 tree val = t[i+1];
615 tree_label l= make_tree_label (var);
616 if (prop == "arity") {
617 if (is_tuple (val, "repeat", 2))
618 drd->set_arity (l, as_int (val [1]), as_int (val [2]),
619 ARITY_REPEAT, CHILD_BIFORM);
620 else if (is_tuple (val, "repeat*", 2))
621 drd->set_arity (l, as_int (val [1]), as_int (val [2]),
622 ARITY_VAR_REPEAT, CHILD_BIFORM);
623 else if (is_tuple (val, "options", 2))
624 drd->set_arity (l, as_int (val [1]), as_int (val [2]),
625 ARITY_OPTIONS, CHILD_BIFORM);
626 else
627 drd->set_arity (l, as_int (val), 0,
628 ARITY_NORMAL, CHILD_DETAILED);
629 drd->freeze_arity (l);
630 }
631 else if (prop == "name") {
632 if (is_atomic (val))
633 drd->set_attribute (l, prop, val->label);
634 }
635 else if (prop == "syntax")
636 drd->set_syntax (l, val);
637 else if (prop == "border") {
638 if (val == "yes") drd->set_border (l, BORDER_YES);
639 if (val == "inner") drd->set_border (l, BORDER_INNER);
640 if (val == "outer") drd->set_border (l, BORDER_OUTER);
641 if (val == "no") drd->set_border (l, BORDER_INNER);
642 drd->freeze_border (l);
643 }
644 else if (prop == "with-like") {
645 if (val == "yes") drd->set_with_like (l, true);
646 if (val == "no") drd->set_with_like (l, false);
647 drd->freeze_with_like (l);
648 }
649 else if (prop == "locals") {
650 int i, n= drd->get_nr_indices (l);
651 for (i=0; i<n; i++) {
652 drd->set_env (l, i, val);
653 drd->freeze_env (l, i);
654 }
655 }
656 else if (prop == "unaccessible" ||
657 prop == "hidden" ||
658 prop == "accessible")
659 {
660 int prop_code= ACCESSIBLE_NEVER;
661 if (prop == "hidden") prop_code= ACCESSIBLE_HIDDEN;
662 if (prop == "accessible") prop_code= ACCESSIBLE_ALWAYS;
663 if (val == "none") prop_code= ACCESSIBLE_NEVER;
664 if (is_int (val)) {
665 int i= as_int (val);
666 drd->set_accessible (l, i, prop_code);
667 drd->freeze_accessible (l, i);
668 }
669 else if (val == "none" || val == "all") {
670 int i, n= drd->get_nr_indices (l);
671 for (i=0; i<n; i++) {
672 drd->set_accessible (l, i, prop_code);
673 drd->freeze_accessible (l, i);
674 }
675 }
676 }
677 else if (prop == "normal-writability" ||
678 prop == "disable-writability" ||
679 prop == "enable-writability")
680 {
681 int prop_code= WRITABILITY_NORMAL;
682 if (prop == "disable-writability") prop_code= WRITABILITY_DISABLE;
683 if (prop == "enable-writability") prop_code= WRITABILITY_ENABLE;
684 if (is_int (val)) {
685 int i= as_int (val);
686 drd->set_writability (l, i, prop_code);
687 drd->freeze_writability (l, i);
688 }
689 else if (val == "all") {
690 int i, n= drd->get_nr_indices (l);
691 for (i=0; i<n; i++) {
692 drd->set_writability (l, i, prop_code);
693 drd->freeze_writability (l, i);
694 }
695 }
696 }
697 else if (prop == "returns" && drd_encode_type (as_string (val)) >= 0) {
698 drd->set_type (l, drd_encode_type (as_string (val)));
699 drd->freeze_type (l);
700 }
701 else if (prop == "parameter" &&
702 drd_encode_type (as_string (val)) >= 0) {
703 drd->set_var_type (l, VAR_PARAMETER);
704 drd->set_type (l, drd_encode_type (as_string (val)));
705 drd->freeze_var_type (l);
706 drd->freeze_type (l);
707 }
708 else if (prop == "macro-parameter" &&
709 drd_encode_type (as_string (val)) >= 0) {
710 drd->set_var_type (l, VAR_MACRO_PARAMETER);
711 drd->set_type (l, drd_encode_type (as_string (val)));
712 drd->freeze_var_type (l);
713 drd->freeze_type (l);
714 }
715 else if (drd_encode_type (prop) >= 0) {
716 int tp= drd_encode_type (prop);
717 if (is_int (val)) {
718 int i= as_int (val);
719 drd->set_type (l, i, tp);
720 drd->freeze_type (l, i);
721 }
722 else if (val == "all") {
723 int i, n= drd->get_nr_indices (l);
724 for (i=0; i<n; i++) {
725 drd->set_type (l, i, tp);
726 drd->freeze_type (l, i);
727 }
728 }
729 }
730 }
731 return t;
732 }
733
734 tree
exec_provides(tree t)735 edit_env_rep::exec_provides (tree t) {
736 if (N(t)<1) return tree (ERROR, "bad provides");
737 tree r= exec (t[0]);
738 if (is_compound (r)) return tree (ERROR, "bad provides");
739 if (provides (r->label)) return "true"; else return "false";
740 }
741
742 tree
exec_value(tree t)743 edit_env_rep::exec_value (tree t) {
744 if (N(t)<1) return tree (ERROR, "bad value");
745 tree r= exec (t[0]);
746 if (is_compound (r)) return tree (ERROR, "bad value");
747 return exec (read (r->label));
748 }
749
750 tree
exec_quote_value(tree t)751 edit_env_rep::exec_quote_value (tree t) {
752 if (N(t)<1) return tree (ERROR, "bad quote-value");
753 tree r= exec (t[0]);
754 if (is_compound (r)) return tree (ERROR, "bad quote-value");
755 return read (r->label);
756 }
757
758 tree
exec_arg(tree t)759 edit_env_rep::exec_arg (tree t) {
760 if (N(t)<1) return tree (ERROR, "bad arg");
761 tree r= t[0];
762 if (is_compound (r))
763 return tree (ERROR, "bad arg");
764 if (is_nil (macro_arg) || (!macro_arg->item->contains (r->label)))
765 return tree (ERROR, "arg " * r->label);
766 r= macro_arg->item [r->label];
767 list<hashmap<string,tree> > old_var= macro_arg;
768 list<hashmap<string,path> > old_src= macro_src;
769 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
770 if (!is_nil (macro_src)) macro_src= macro_src->next;
771 bool err= false;
772 if (N(t) > 1) {
773 int i, n= N(t);
774 for (i=1; i<n; i++) {
775 tree u= exec (t[i]);
776 if (!is_int (u)) { err= true; break; }
777 int nr= as_int (u);
778 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) { err= true; break; }
779 r= r[nr];
780 }
781 }
782 if (err) r= tree (ERROR, "arg " * r->label);
783 else r= exec (r);
784 macro_arg= old_var;
785 macro_src= old_src;
786 return r;
787 }
788
789 static bool quote_substitute= false;
790
791 tree
exec_quote_arg(tree t)792 edit_env_rep::exec_quote_arg (tree t) {
793 if (N(t)<1) return tree (ERROR, "bad quote-arg");
794 tree r= t[0];
795 if (is_compound (r))
796 return tree (ERROR, "bad quote-arg");
797 if (is_nil (macro_arg) || (!macro_arg->item->contains (r->label)))
798 return tree (ERROR, "quoted argument " * r->label);
799 r= macro_arg->item [r->label];
800 if (N(t) > 1) {
801 int i, n= N(t);
802 for (i=1; i<n; i++) {
803 tree u= exec (t[i]);
804 if (!is_int (u)) break;
805 int nr= as_int (u);
806 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
807 r= r[nr];
808 }
809 }
810 if (quote_substitute && !is_func (r, ARG)) {
811 int i, n= N(r);
812 tree s (r, n);
813 for (i=0; i<n; i++)
814 s[i]= tree (ARG, A(t)) * tree (ARG, as_string (i));
815 return s;
816 }
817 return r;
818 }
819
820 tree
exec_get_label(tree t)821 edit_env_rep::exec_get_label (tree t) {
822 if (N(t)<1) return tree (ERROR, "bad get-label");
823 tree r= exec (t[0]);
824 return copy (as_string (L(r)));
825 }
826
827 tree
exec_get_arity(tree t)828 edit_env_rep::exec_get_arity (tree t) {
829 if (N(t)<1) return tree (ERROR, "bad get-arity");
830 tree r= exec (t[0]);
831 return as_string (arity (r));
832 }
833
834 tree
exec_eval_args(tree t)835 edit_env_rep::exec_eval_args (tree t) {
836 if (N(t)<1) return tree (ERROR, "bad eval-args");
837 if(is_nil(macro_arg)) return tree(ERROR, "nil argument");
838 tree v= macro_arg->item [as_string (t[0])];
839 if (is_atomic (v)) return tree (ERROR, "eval arguments " * t[0]->label);
840 list<hashmap<string,tree> > old_var= macro_arg;
841 list<hashmap<string,path> > old_src= macro_src;
842 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
843 if (!is_nil (macro_src)) macro_src= macro_src->next;
844
845 int i, n= N(v);
846 tree r (v, n);
847 for (i=0; i<n; i++)
848 r[i]= exec (v[i]);
849
850 macro_arg= old_var;
851 macro_src= old_src;
852 return r;
853 }
854
855 tree
exec_quasiquoted(tree t)856 edit_env_rep::exec_quasiquoted (tree t) {
857 if (is_atomic (t)) return t;
858 else if (is_func (t, UNQUOTE, 1)) return exec (t[0]);
859 else {
860 int i, n= N(t);
861 tree r (L(t));
862 for (i=0; i<n; i++) {
863 if (is_func (t[i], VAR_UNQUOTE, 1)) {
864 tree ins= exec (t[i]);
865 if (is_compound (ins)) r << A(ins);
866 else r << tree (ERROR, "bad unquote*");
867 }
868 else r << exec_quasiquoted (t[i]);
869 }
870 return r;
871 }
872 }
873
874 tree
exec_if(tree t)875 edit_env_rep::exec_if (tree t) {
876 // This case must be kept consistent with
877 // concater_rep::typeset_if(tree, path)
878 // in ../Concat/concat_active.cpp
879 if ((N(t)!=2) && (N(t)!=3)) return tree (ERROR, "bad if");
880 tree tt= exec (t[0]);
881 if (is_compound (tt) || !is_bool (tt->label))
882 return tree (ERROR, "bad if");
883 if (as_bool (tt->label)) return exec (t[1]);
884 if (N(t)==3) return exec (t[2]);
885 return "";
886 }
887
888 tree
exec_case(tree t)889 edit_env_rep::exec_case (tree t) {
890 // This case must be kept consistent with
891 // concater_rep::typeset_case(tree, path)
892 // in ../Concat/concat_active.cpp
893 if (N(t)<2) return tree (ERROR, "bad case");
894 int i, n= N(t);
895 for (i=0; i<(n-1); i+=2) {
896 tree tt= exec (t[i]);
897 if (is_compound (tt) || ! is_bool (tt->label))
898 return tree (ERROR, "bad case");
899 if (as_bool (tt->label)) return exec (t[i+1]);
900 }
901 if (i<n) return exec (t[i]);
902 return "";
903 }
904
905 tree
exec_while(tree t)906 edit_env_rep::exec_while (tree t) {
907 if (N(t)!=2) return tree (ERROR, "bad while");
908 tree r (CONCAT);
909 while (1) {
910 tree tt= exec (t[0]);
911 if (is_compound (tt)) return tree (ERROR, "bad while");
912 if (! is_bool (tt->label)) return tree (ERROR, "bad while");
913 if (! as_bool(tt->label)) break;
914 r << exec (t[1]);
915 }
916 if (N(r) == 0) return "";
917 if (N(r) == 1) return r[0];
918 return r;
919 }
920
921 tree
exec_for_each(tree t)922 edit_env_rep::exec_for_each (tree t) {
923 if (N(t)!=2) return tree (ERROR, "bad for-each");
924 tree fun = exec (t[0]);
925 tree args= exec (t[1]);
926 if (!is_tuple (args)) return tree (ERROR, "bad for-each");
927 int i, n= N(args);
928 for (i=0; i<n; i++)
929 exec (tree (COMPOUND, fun, args[i]));
930 return "";
931 }
932
933 static tree
filter_style(tree t)934 filter_style (tree t) {
935 if (is_atomic (t)) return t;
936 else switch (L(t)) {
937 case STYLE_WITH:
938 case VAR_STYLE_WITH:
939 return filter_style (t[N(t)-1]);
940 case STYLE_ONLY:
941 case VAR_STYLE_ONLY:
942 if (is_atomic (t[0])) return "";
943 else return filter_style (t[0][N(t[0])-1]);
944 case ACTIVE:
945 case VAR_ACTIVE:
946 case INACTIVE:
947 case VAR_INACTIVE:
948 return filter_style (t[0]);
949 default:
950 {
951 int i, n= N(t);
952 tree r (t, n);
953 for (i=0; i<n; i++)
954 r[i]= filter_style (t[i]);
955 return r;
956 }
957 }
958 }
959
960 tree
exec_use_package(tree t)961 edit_env_rep::exec_use_package (tree t) {
962 int i, n= N(t);
963 for (i=0; i<n; i++) {
964 //cout << "Package " << as_string (t[i]) << "\n";
965 url name= url_none ();
966 url styp= "$TEXMACS_STYLE_PATH";
967 if (is_rooted (base_file_name, "default"))
968 styp= styp | ::expand (head (base_file_name) * url_ancestor ());
969 else styp= styp | head (base_file_name);
970 if (ends (as_string (t[i]), ".ts")) name= as_string (t[i]);
971 else name= styp * (as_string (t[i]) * string (".ts"));
972 name= resolve (name);
973 //cout << as_string (t[i]) << " -> " << name << "\n";
974 string doc_s;
975 if (!load_string (name, doc_s, false)) {
976 tree doc= texmacs_document_to_tree (doc_s);
977 if (is_compound (doc))
978 exec (filter_style (extract (doc, "body")));
979 }
980 }
981 return "";
982 }
983
984 tree
exec_use_module(tree t)985 edit_env_rep::exec_use_module (tree t) {
986 int i, n= N(t);
987 for (i=0; i<n; i++) {
988 string s= exec_string (t[i]);
989 if (starts (s, "(")) eval ("(use-modules " * s * ")");
990 else if (s != "") eval ("(plugin-initialize '" * s * ")");
991 assign (THE_MODULES, read (THE_MODULES) * tuple (s));
992 }
993 return "";
994 }
995
996 tree
exec_or(tree t)997 edit_env_rep::exec_or (tree t) {
998 if (N(t) < 2) return tree (ERROR, "bad or");
999 for (int i=0; i<N(t); i++) {
1000 tree ti= exec (t[i]);
1001 if (ti != "false") return ti;
1002 }
1003 return as_string_bool (false);
1004 }
1005
1006 tree
exec_xor(tree t)1007 edit_env_rep::exec_xor (tree t) {
1008 if (N(t) != 2) return tree (ERROR, "bad xor");
1009 tree t1= exec (t[0]);
1010 tree t2= exec (t[1]);
1011 if (is_compound (t1) || is_compound (t2)) return tree (ERROR, "bad xor");
1012 if (!is_bool (t1->label) || !is_bool (t2->label))
1013 return tree (ERROR, "bad xor");
1014 return as_string_bool (as_bool (t1->label) ^ as_bool (t2->label));
1015 }
1016
1017 tree
exec_and(tree t)1018 edit_env_rep::exec_and (tree t) {
1019 if (N(t) < 2) return tree (ERROR, "bad and");
1020 for (int i=0; i<N(t)-1; i++) {
1021 tree ti= exec (t[i]);
1022 if (ti == "false") return ti;
1023 }
1024 return exec (t[N(t)-1]);
1025 }
1026
1027 tree
exec_not(tree t)1028 edit_env_rep::exec_not (tree t) {
1029 if (N(t) != 1) return tree (ERROR, "bad not");
1030 tree tt= exec (t[0]);
1031 if (tt == "false") return "true";
1032 else return "false";
1033 }
1034
1035 tree
exec_plus_minus(tree t)1036 edit_env_rep::exec_plus_minus (tree t) {
1037 int i, n= N(t);
1038 if (n==0) return tree (ERROR, "bad plus/minus");
1039 tree inc= exec (t[0]);
1040 if (is_double (inc)) {
1041 double acc= as_double (inc);
1042 if ((n==1) && is_func (t, MINUS))
1043 acc= -acc;
1044 for (i=1; i<n; i++) {
1045 tree inc= exec (t[i]);
1046 if (!is_double (inc))
1047 return tree (ERROR, "bad plus/minus");
1048 if ((i == n-1) && is_func (t, MINUS))
1049 acc -= as_double (inc);
1050 else acc += as_double (inc);
1051 }
1052 return as_string (acc);
1053 }
1054 else if (is_anylen (inc)) {
1055 tree acc= as_tmlen (inc);
1056 if ((n==1) && is_func (t, MINUS))
1057 acc= tmlen_times (-1, acc);
1058 for (i=1; i<n; i++) {
1059 tree inc= exec (t[i]);
1060 if (!is_anylen (inc))
1061 return tree (ERROR, "bad plus/minus");
1062 inc= as_tmlen (inc);
1063 if ((i == n-1) && is_func (t, MINUS))
1064 inc= tmlen_times (-1, inc);
1065 acc= tmlen_plus (acc, inc);
1066 }
1067 return acc;
1068 }
1069 else return tree (ERROR, "bad plus/minus");
1070 }
1071
1072 tree
exec_min_max(tree t)1073 edit_env_rep::exec_min_max (tree t) {
1074 int i, n= N(t);
1075 if (n==0) return tree (ERROR, "bad min/max");
1076 tree first= exec (t[0]);
1077 if (is_double (first)) {
1078 double ret= as_double (first);
1079 for (i=1; i<n; i++) {
1080 tree next= exec (t[i]);
1081 if (!is_double (next))
1082 return tree (ERROR, "bad min/max");
1083 if (is_func (t, MINIMUM))
1084 ret= min (ret, as_double (next));
1085 else
1086 ret= max (ret, as_double (next));
1087 }
1088 return as_string (ret);
1089 }
1090 else if (is_anylen (first)) {
1091 tree ret= as_tmlen (first);
1092 if ((n==1) && is_func (t, MINUS))
1093 ret= tmlen_times (-1, ret);
1094 for (i=1; i<n; i++) {
1095 tree next= exec (t[i]);
1096 if (!is_anylen (next))
1097 return tree (ERROR, "bad min/max");
1098 next= as_tmlen (next);
1099 if (is_func (t, MINIMUM))
1100 ret= tmlen_min (ret, next);
1101 else
1102 ret= tmlen_max (ret, next);
1103 }
1104 return ret;
1105 }
1106 else return tree (ERROR, "bad min/max");
1107 }
1108
1109 tree
exec_times_over(tree t)1110 edit_env_rep::exec_times_over (tree t) {
1111 int i, n= N(t);
1112 if (n==0) return tree (ERROR, "bad times/over");
1113 tree prod= exec (t[0]);
1114 if (is_double (prod));
1115 else if (is_anylen (prod)) prod= as_tmlen (prod);
1116 else if (is_percentage (prod)) prod= as_tree (as_percentage (prod));
1117 else return tree (ERROR, "bad times/over");
1118 if ((n==1) && is_func (t, OVER)) {
1119 if (is_double (prod)) return as_string (1 / as_double (prod));
1120 else return tree (ERROR, "bad times/over");
1121 }
1122 // cout << t << "\n";
1123 // cout << " 0\t" << prod << "\n";
1124 for (i=1; i<n; i++) {
1125 tree mul= exec (t[i]);
1126 if (is_double (mul)) {
1127 double _mul= as_double (mul);
1128 if ((i == n-1) && is_func (t, OVER))
1129 _mul= 1 / _mul;
1130 if (is_double (prod))
1131 prod= as_string (_mul * as_double (prod));
1132 else prod= tmlen_times (_mul, prod);
1133 }
1134 else if (is_anylen (mul)) {
1135 mul= as_tmlen (mul);
1136 if ((i == n-1) && is_func (t, OVER)) {
1137 if (!is_func (prod, TMLEN))
1138 return tree (ERROR, "bad times/over");
1139 return tmlen_over (prod, mul);
1140 }
1141 if (is_double (prod))
1142 prod= tmlen_times (as_double (prod), mul);
1143 else return tree (ERROR, "bad times/over");
1144 }
1145 else if (is_percentage (mul)) {
1146 double _mul= as_percentage (mul);
1147 if (is_double (prod))
1148 prod= as_string (_mul * as_double (prod));
1149 else prod= tmlen_times (_mul, prod);
1150 }
1151 else return tree (ERROR, "bad times/over");
1152 // cout << " " << i << "\t" << prod << "\n";
1153 }
1154 return prod;
1155 }
1156
1157 tree
exec_divide(tree t)1158 edit_env_rep::exec_divide (tree t) {
1159 /* this doesn't match the documentation */
1160 if (N(t)!=2) return tree (ERROR, "bad divide");
1161 tree t1= exec (t[0]);
1162 tree t2= exec (t[1]);
1163 if (is_compound (t1) || is_compound (t2))
1164 return tree (ERROR, "bad divide");
1165 if (is_int (t1->label) && (is_int (t2->label))) {
1166 int den= as_int (t2->label);
1167 if (den == 0) return tree (ERROR, "division by zero");
1168 return as_string (as_int (t1->label) / den);
1169 }
1170 if (is_double (t1->label) && (is_double (t2->label))) {
1171 double den= as_double (t2->label);
1172 if (den == 0) return tree (ERROR, "division by zero");
1173 return as_string (floor (as_double (t1->label) / den));
1174 }
1175 if (is_anylen (t1->label) && (is_anylen (t2->label)))
1176 return as_string (tmlen_div (as_tmlen (t1), as_tmlen (t2)));
1177 return tree (ERROR, "bad divide");
1178 }
1179
1180 tree
exec_modulo(tree t)1181 edit_env_rep::exec_modulo (tree t) {
1182 if (N(t)!=2) return tree (ERROR, "bad modulo");
1183 tree t1= exec (t[0]);
1184 tree t2= exec (t[1]);
1185 if (is_compound (t1) || is_compound (t2))
1186 return tree (ERROR, "bad modulo");
1187 if (is_int (t1->label) && (is_int (t2->label))) {
1188 int den= as_int (t2->label);
1189 if (den == 0) return tree (ERROR, "modulo zero");
1190 return as_string (as_int (t1->label) % den);
1191 }
1192 if (is_double (t1->label) && (is_double (t2->label))) {
1193 double num= as_double (t1->label);
1194 double den= as_double (t2->label);
1195 if (den == 0) return tree (ERROR, "modulo zero");
1196 double div= floor (num / den);
1197 return as_string (num - div * den);
1198 }
1199 if (is_anylen (t1->label) && (is_anylen (t2->label)))
1200 return tmlen_mod (as_tmlen (t1), as_tmlen (t2));
1201 return tree (ERROR, "bad modulo");
1202 }
1203
1204 tree
exec_math_sqrt(tree t)1205 edit_env_rep::exec_math_sqrt (tree t) {
1206 if (N(t)!=1) return tree (ERROR, "bad sqrt");
1207 tree t1= exec (t[0]);
1208 if (is_double (t1))
1209 return as_tree (sqrt (as_double (t1)));
1210 return tree (ERROR, "bad sqrt");
1211 }
1212
1213 tree
exec_exp(tree t)1214 edit_env_rep::exec_exp (tree t) {
1215 if (N(t)!=1) return tree (ERROR, "bad exp");
1216 tree t1= exec (t[0]);
1217 if (is_double (t1))
1218 return as_tree (exp (as_double (t1)));
1219 return tree (ERROR, "bad exp");
1220 }
1221
1222 tree
exec_log(tree t)1223 edit_env_rep::exec_log (tree t) {
1224 if (N(t)!=1) return tree (ERROR, "bad log");
1225 tree t1= exec (t[0]);
1226 if (is_double (t1))
1227 return as_tree (log (as_double (t1)));
1228 return tree (ERROR, "bad log");
1229 }
1230
1231 tree
exec_pow(tree t)1232 edit_env_rep::exec_pow (tree t) {
1233 if (N(t)!=2) return tree (ERROR, "bad pow");
1234 tree t1= exec (t[0]);
1235 tree t2= exec (t[1]);
1236 if (is_double (t1) && is_double (t2))
1237 return as_tree (pow (as_double (t1), as_double (t2)));
1238 return tree (ERROR, "bad pow");
1239 }
1240
1241 tree
exec_cos(tree t)1242 edit_env_rep::exec_cos (tree t) {
1243 if (N(t)!=1) return tree (ERROR, "bad cos");
1244 tree t1= exec (t[0]);
1245 if (is_double (t1))
1246 return as_tree (cos (as_double (t1)));
1247 return tree (ERROR, "bad cos");
1248 }
1249
1250 tree
exec_sin(tree t)1251 edit_env_rep::exec_sin (tree t) {
1252 if (N(t)!=1) return tree (ERROR, "bad sin");
1253 tree t1= exec (t[0]);
1254 if (is_double (t1))
1255 return as_tree (sin (as_double (t1)));
1256 return tree (ERROR, "bad sin");
1257 }
1258
1259 tree
exec_tan(tree t)1260 edit_env_rep::exec_tan (tree t) {
1261 if (N(t)!=1) return tree (ERROR, "bad tan");
1262 tree t1= exec (t[0]);
1263 if (is_double (t1))
1264 return as_tree (tan (as_double (t1)));
1265 return tree (ERROR, "bad tan");
1266 }
1267
1268 tree
exec_merge(tree t)1269 edit_env_rep::exec_merge (tree t) {
1270 int i, n= N(t);
1271 if (n == 0) return "";
1272 tree acc= exec (t[0]);
1273 if (is_concat (acc)) acc= tree_as_string (acc);
1274 for (i=1; i<n; i++) {
1275 tree add= exec (t[i]);
1276 if (is_atomic (acc) &&
1277 (is_atomic (add) || is_concat (add) || is_document (add)))
1278 acc= acc->label * tree_as_string (add);
1279 else if (is_tuple (acc) && is_tuple (add))
1280 acc= acc * add;
1281 else if (is_func (acc, MACRO) && is_func (add, MACRO) &&
1282 (N(acc) == N(add)) &&
1283 (acc (0, N(acc)-1) == add (0, N(add)-1)))
1284 {
1285 tree r = copy (acc);
1286 tree u1= copy (acc[N(acc)-1]);
1287 tree u2= copy (add[N(add)-1]);
1288 tree u (CONCAT, u1, u2);
1289 if (u1 == "") u= u2;
1290 else if (u2 == "") u= u1;
1291 else if (is_atomic (u1) && is_atomic (u2))
1292 u= u1->label * u2->label;
1293 r[N(r)-1]= u;
1294 acc= r;
1295 }
1296 else {
1297 //cout << "acc= " << acc << "\n";
1298 //cout << "add= " << add << "\n";
1299 return tree (ERROR, "bad merge");
1300 }
1301 }
1302 return acc;
1303 }
1304
1305 tree
exec_length(tree t)1306 edit_env_rep::exec_length (tree t) {
1307 if (N(t)!=1) return tree (ERROR, "bad length");
1308 tree t1= exec (t[0]);
1309 if (is_compound (t1)) {
1310 if (is_tuple (t1)) return as_string (N (t1));
1311 return tree (ERROR, "bad length");
1312 }
1313 return as_string (N (t1->label));
1314 }
1315
1316 tree
exec_range(tree t)1317 edit_env_rep::exec_range (tree t) {
1318 if (N(t)!=3) return tree (ERROR, "bad range");
1319 tree t1= exec (t[0]);
1320 tree t2= exec (t[1]);
1321 tree t3= exec (t[2]);
1322 if (!(is_int (t2) && is_int (t3))) return tree (ERROR, "bad range");
1323 if (is_compound (t1)) {
1324 if (is_tuple (t1)) {
1325 int i1= max (0, as_int (t2));
1326 int i2= min (N (t1), as_int (t3));
1327 i2 = max (i1, i2);
1328 return t1 (i1, i2);
1329 }
1330 return tree (ERROR, "bad range");
1331 }
1332 int i1= max (0, as_int (t2));
1333 int i2= min (N(t1->label), as_int (t3));
1334 i2 = max (i1, i2);
1335 return t1->label (i1, i2);
1336 }
1337
1338 tree
exec_number(tree t)1339 edit_env_rep::exec_number (tree t) {
1340 if (N(t)!=2) return tree (ERROR, "bad number");
1341 tree t1= exec (t[0]);
1342 tree t2= exec (t[1]);
1343 if (is_compound (t1) || is_compound (t2))
1344 return tree (ERROR, "bad number");
1345 string s1= t1->label;
1346 string s2= t2->label;
1347 int nr= as_int (s1);
1348 if (s2 == "arabic") return as_string (nr);
1349 if (s2 == "roman") return roman_nr (nr);
1350 if (s2 == "Roman") return Roman_nr (nr);
1351 if (s2 == "alpha") return alpha_nr (nr);
1352 if (s2 == "Alpha") return Alpha_nr (nr);
1353 if (s2 == "fnsymbol")
1354 return tree (WITH, MODE, "math", tree (RIGID, fnsymbol_nr (nr)));
1355 return tree (ERROR, "bad number");
1356 }
1357
1358 tree
exec_date(tree t)1359 edit_env_rep::exec_date (tree t) {
1360 if (N(t)>2) return tree (ERROR, "bad date");
1361 string lan= get_string (LANGUAGE);
1362 if (N(t) == 2) {
1363 tree u= exec (t[1]);
1364 if (is_compound (u)) return tree (ERROR, "bad date");
1365 lan= u->label;
1366 }
1367 string fm= "";
1368 if (N(t) != 0) {
1369 tree u= exec (t[0]);
1370 if (is_compound (u)) return tree (ERROR, "bad date");
1371 fm= u->label;
1372 }
1373 return get_date (lan, fm);
1374 }
1375
1376 tree
exec_translate(tree t)1377 edit_env_rep::exec_translate (tree t) {
1378 if (N(t)!=3) return tree (ERROR, "bad translate");
1379 tree t1= exec (t[0]);
1380 tree t2= exec (t[1]);
1381 tree t3= exec (t[2]);
1382 if (is_compound (t1) || is_compound (t2) || is_compound (t3)) return t1;
1383 return translate (t1->label, t2->label, t3->label);
1384 }
1385
1386 tree
exec_change_case(tree t,tree nc,bool exec_flag,bool first)1387 edit_env_rep::exec_change_case (tree t, tree nc, bool exec_flag, bool first) {
1388 if (is_atomic (t)) {
1389 string s= t->label;
1390 tree r= copy (s);
1391 int i, n= N(s);
1392
1393 bool all= true;
1394 bool up = false;
1395 bool lo = false;
1396 if (nc == "Upcase") { all= false; up= true; }
1397 else if (nc == "UPCASE") { up= true; }
1398 else if (nc == "locase") { lo= true; }
1399
1400 for (i=0; i<n; tm_char_forwards (s, i))
1401 if (is_iso_alpha (s[i]) && (all || (first && (i==0)))) {
1402 if (up && is_locase (s[i])) r->label[i]= upcase (s[i]);
1403 if (lo && is_upcase (s[i])) r->label[i]= locase (s[i]);
1404 }
1405 r->obs= list_observer (ip_observer (obtain_ip (t)), r->obs);
1406 return r;
1407 }
1408 else if (is_concat (t)) {
1409 int i, n= N(t);
1410 tree r (t, n);
1411 for (i=0; i<n; i++)
1412 r[i]= exec_change_case (t[i], nc, exec_flag, first && (i==0));
1413 r->obs= list_observer (ip_observer (obtain_ip (t)), r->obs);
1414 return r;
1415 }
1416 else {
1417 if (exec_flag) return t;
1418 else return exec_change_case (exec (t), nc, true, first);
1419 }
1420 }
1421
1422 tree
exec_change_case(tree t)1423 edit_env_rep::exec_change_case (tree t) {
1424 if (N(t) < 2) return tree (ERROR, "bad change case");
1425 return exec_change_case (t[0], exec (t[1]), false, true);
1426 }
1427
1428 tree
exec_find_file(tree t)1429 edit_env_rep::exec_find_file (tree t) {
1430 int i, n=N(t);
1431 array<tree> r (n);
1432 for (i=0; i<n; i++) {
1433 r[i]= exec (t[i]);
1434 if (is_compound (r[i]))
1435 return tree (ERROR, "bad find file");
1436 }
1437 for (i=0; i<(n-1); i++) {
1438 url u= resolve (url (r[i]->label, r[n-1]->label));
1439 if (!is_none (u)) {
1440 url d= delta (base_file_name, u);
1441 if (!is_rooted (d) && !(is_concat (d) && is_parent (d[1])))
1442 return as_string (d);
1443 if (is_rooted (u, "default")) u= reroot (u, "file");
1444 return as_string (u);
1445 }
1446 }
1447 url u= resolve (base_file_name * url_parent () * r[n-1]->label);
1448 if (!is_none (u)) {
1449 url d= delta (base_file_name, u);
1450 if (!is_rooted (d) && !(is_concat (d) && is_parent (d[1])))
1451 return as_string (d);
1452 if (is_rooted (u, "default")) u= reroot (u, "file");
1453 return as_string (u);
1454 }
1455 return "false";
1456 }
1457
1458 tree
exec_find_file_upwards(tree t)1459 edit_env_rep::exec_find_file_upwards (tree t) {
1460 if (N(t) < 1) return tree (ERROR, "bad find file upwards");
1461 tree name= exec (t[0]);
1462 array<string> roots;
1463 for (int i=1; i<N(t); i++) {
1464 tree root= exec (t[i]);
1465 if (!is_atomic (name) || !is_atomic (root))
1466 return tree (ERROR, "bad find file upwards");
1467 roots << root->label;
1468 }
1469 url u= search_file_upwards (base_file_name, name->label, roots);
1470 if (!is_none (u)) {
1471 url d= delta (base_file_name, u);
1472 if (!is_rooted (d))
1473 return as_string (d);
1474 //if (is_rooted (u, "default")) u= reroot (u, "file");
1475 return as_string (u);
1476 }
1477 return "false";
1478 }
1479
1480 tree
exec_is_tuple(tree t)1481 edit_env_rep::exec_is_tuple (tree t) {
1482 if (N(t)!=1) return tree (ERROR, "bad tuple query");
1483 return as_string_bool(is_tuple (exec (t[0])));
1484 }
1485
1486 tree
exec_lookup(tree t)1487 edit_env_rep::exec_lookup (tree t) {
1488 if (N(t)!=2) return tree (ERROR, "bad look up");
1489 tree t1= exec (t[0]);
1490 tree t2= exec (t[1]);
1491 if (!(is_compound (t1) && is_int (t2))) return tree (ERROR, "bad look up");
1492 int i= as_int (t2);
1493 if (i<0 || i>=N(t1)) return tree (ERROR, "index out of range in look up");
1494 return t1[i];
1495 }
1496
1497 tree
exec_equal(tree t)1498 edit_env_rep::exec_equal (tree t) {
1499 if (N(t)!=2) return tree (ERROR, "bad equal");
1500 tree t1= exec (t[0]);
1501 tree t2= exec (t[1]);
1502 if (is_atomic (t1) && is_atomic (t2)
1503 && is_length (t1->label) && is_length (t2->label))
1504 return as_string_bool (as_length (t1) == as_length (t2));
1505 return as_string_bool (t1 == t2);
1506 }
1507
1508 tree
exec_unequal(tree t)1509 edit_env_rep::exec_unequal (tree t) {
1510 if (N(t)!=2) return tree (ERROR, "bad unequal");
1511 tree t1= exec (t[0]);
1512 tree t2= exec (t[1]);
1513 if (is_atomic(t1) && is_atomic(t2)
1514 && is_length(t1->label) && is_length(t2->label))
1515 return as_string_bool (as_length (t1) != as_length (t2));
1516 return as_string_bool (t1 != t2);
1517 }
1518
1519 tree
exec_less(tree t)1520 edit_env_rep::exec_less (tree t) {
1521 if (N(t)!=2) return tree (ERROR, "bad less");
1522 tree t1= exec (t[0]);
1523 tree t2= exec (t[1]);
1524 if (is_compound (t1) || is_compound (t2))
1525 return tree (ERROR, "bad less");
1526 string s1= t1->label;
1527 string s2= t2->label;
1528 if (is_double (s1) && is_double (s2))
1529 return as_string_bool (as_double (s1) < as_double (s2));
1530 if (is_length (s1) && is_length (s2))
1531 return as_string_bool (as_length (s1) < as_length (s2));
1532 return tree (ERROR, "bad less");
1533 }
1534
1535 tree
exec_lesseq(tree t)1536 edit_env_rep::exec_lesseq (tree t) {
1537 if (N(t)!=2) return tree (ERROR, "bad less or equal");
1538 tree t1= exec (t[0]);
1539 tree t2= exec (t[1]);
1540 if (is_compound (t1) || is_compound (t2))
1541 return tree (ERROR, "bad less or equal");
1542 string s1= t1->label;
1543 string s2= t2->label;
1544 if (is_double (s1) && (is_double (s2)))
1545 return as_string_bool (as_double (s1) <= as_double (s2));
1546 if (is_length (s1) && is_length (s2))
1547 return as_string_bool (as_length (s1) <= as_length (s2));
1548 return tree (ERROR, "bad less or equal");
1549 }
1550
1551 tree
exec_greater(tree t)1552 edit_env_rep::exec_greater (tree t) {
1553 if (N(t)!=2) return tree (ERROR, "bad greater");
1554 tree t1= exec (t[0]);
1555 tree t2= exec (t[1]);
1556 if (is_compound (t1) || is_compound (t2))
1557 return tree (ERROR, "bad greater");
1558 string s1= t1->label;
1559 string s2= t2->label;
1560 if (is_double (s1) && (is_double (s2)))
1561 return as_string_bool (as_double (s1) > as_double (s2));
1562 if (is_length (s1) && is_length (s2))
1563 return as_string_bool (as_length (s1) > as_length (s2));
1564 return tree (ERROR, "bad greater");
1565 }
1566
1567 tree
exec_greatereq(tree t)1568 edit_env_rep::exec_greatereq (tree t) {
1569 if (N(t)!=2) return tree (ERROR, "bad greater or equal");
1570 tree t1= exec (t[0]);
1571 tree t2= exec (t[1]);
1572 if (is_compound (t1) || is_compound (t2))
1573 return tree (ERROR, "bad greater or equal");
1574 string s1= t1->label;
1575 string s2= t2->label;
1576 if (is_double (s1) && (is_double (s2)))
1577 return as_string_bool (as_double (s1) >= as_double (s2));
1578 if (is_length (s1) && is_length (s2))
1579 return as_string_bool (as_length (s1) >= as_length (s2));
1580 return tree (ERROR, "bad greater or equal");
1581 }
1582
1583 tree
exec_blend(tree t)1584 edit_env_rep::exec_blend (tree t) {
1585 if (N(t)!=2) return tree (ERROR, "bad blend");
1586 tree t1= exec (t[0]);
1587 tree t2= exec (t[1]);
1588 if (is_compound (t1) || is_compound (t2))
1589 return tree (ERROR, "bad blend");
1590 string s1= t1->label;
1591 string s2= t2->label;
1592 if (is_color_name (s1) && (is_color_name (s2))) {
1593 color c1= named_color (s1);
1594 color c2= named_color (s2);
1595 return get_hex_color (blend_colors (c1, c2));
1596 }
1597 return tree (ERROR, "bad blend");
1598 }
1599
1600 tree
exec_hard_id(tree t)1601 edit_env_rep::exec_hard_id (tree t) {
1602 pointer ptr= (pointer) this;
1603 if (N(t) == 0)
1604 return "%" * as_hexadecimal (ptr);
1605 else {
1606 t= expand (t[0], true);
1607 pointer tptr= (pointer) t.operator -> ();
1608 if (is_accessible (obtain_ip (t)))
1609 return "%" * as_hexadecimal (ptr) *
1610 "-" * as_hexadecimal (tptr);
1611 else {
1612 int h= hash (t);
1613 return "%" * as_hexadecimal (ptr) *
1614 "-" * as_hexadecimal (tptr) *
1615 "-" * as_hexadecimal (h);
1616 }
1617 }
1618 }
1619
1620 tree
exec_script(tree t)1621 edit_env_rep::exec_script (tree t) {
1622 int i, n= N(t);
1623 if (n < 1) return tree (ERROR, "bad script");
1624 tree r (t, n);
1625 r[0]= exec (t[0]);
1626 for (i=1; i<n; i++)
1627 r[i]= exec (t[i]);
1628 return r;
1629 }
1630
1631 tree
exec_find_accessible(tree t)1632 edit_env_rep::exec_find_accessible (tree t) {
1633 if (N(t) < 1) return tree (ERROR, "bad find-accessible");
1634 return expand (t[0], true);
1635 }
1636
1637 tree
exec_set_binding(tree t)1638 edit_env_rep::exec_set_binding (tree t) {
1639 tree keys, value;
1640 if (N(t) == 1) {
1641 keys= read ("the-tags");
1642 if (!is_tuple (keys)) {
1643 //cout << "t= " << t << "\n";
1644 //cout << "keys= " << keys << "\n";
1645 return tree (ERROR, "bad set binding");
1646 }
1647 for (int i=0; i<N(keys); i++)
1648 if (!is_atomic (keys[i])) {
1649 //cout << "t= " << t << "\n";
1650 //cout << "keys= " << keys << "\n";
1651 return tree (ERROR, "bad set binding");
1652 }
1653 value= exec (t[0]);
1654 assign (string ("the-tags"), tree (TUPLE));
1655 assign (string ("the-label"), copy (value));
1656 }
1657 else if (N(t) >= 2) {
1658 tree key= exec (t[0]);
1659 if (!is_atomic (key)) {
1660 //cout << "t= " << t << "\n";
1661 //cout << "key= " << key << "\n";
1662 return tree (ERROR, "bad set binding");
1663 }
1664 keys= tuple (key);
1665 value= exec (t[1]);
1666 }
1667 else {
1668 //cout << "t= " << t << "\n";
1669 return tree (ERROR, "bad set binding");
1670 }
1671 //cout << t << ": " << keys << " -> " << value << "\n";
1672
1673 for (int i=0; i<N(keys); i++) {
1674 string key= keys[i]->label;
1675 tree old_value= local_ref[key];
1676 string part= as_string (read ("current-part"));
1677 if (is_func (old_value, TUPLE) && (N(old_value) >= 2))
1678 local_ref (key)= tuple (copy (value), old_value[1]);
1679 else local_ref (key)= tuple (copy (value), "?");
1680 if (cur_file_name != base_file_name || N(part) != 0) {
1681 string extra;
1682 if (cur_file_name != base_file_name)
1683 extra << as_string (delta (base_file_name, cur_file_name));
1684 if (N(part) != 0)
1685 extra << "#" << part (1, N(part));
1686 local_ref (key) << extra;
1687 }
1688 if (complete && is_tuple (old_value) && N(old_value) >= 1) {
1689 string old_s= tree_as_string (old_value[0]);
1690 string new_s= tree_as_string (value);
1691 if (new_s != old_s && !starts (key, "auto-")) {
1692 redefined << tree (TUPLE, key, new_s);
1693 //if (new_s == "") typeset_warning << "Redefined " << key << LF;
1694 //else typeset_warning << "Redefined " << key << " as " << new_s << LF;
1695 }
1696 }
1697 }
1698 return tree (HIDDEN, keys);
1699 }
1700
1701 tree
exec_get_binding(tree t)1702 edit_env_rep::exec_get_binding (tree t) {
1703 if (N(t) != 1 && N(t) != 2) return tree (ERROR, "bad get binding");
1704 string key= exec_string (t[0]);
1705 tree value= local_ref->contains (key)? local_ref [key]: global_ref [key];
1706 int type= (N(t) == 1? 0: as_int (exec_string (t[1])));
1707 if (type != 0 && type != 1) type= 0;
1708 if (is_func (value, TUPLE) && (N(value) >= 2)) value= value[type];
1709 else if (type == 1) value= tree (UNINIT);
1710 if (complete && value == tree (UNINIT))
1711 if (get_bool (WARN_MISSING)) {
1712 missing (key)= tree (GET_BINDING, key);
1713 //typeset_warning << "Undefined reference " << key << LF;
1714 }
1715 //cout << t << ": " << key << " -> " << value << "\n";
1716 return value;
1717 }
1718
1719 tree
exec_get_attachment(tree t)1720 edit_env_rep::exec_get_attachment (tree t) {
1721 if (N(t) != 1) return tree (ERROR, "bad get attachment");
1722 string key= exec_string (t[0]);
1723 tree value= local_att->contains (key)? local_att [key]: global_att [key];
1724 return value;
1725 }
1726
1727 tree
exec_pattern(tree t)1728 edit_env_rep::exec_pattern (tree t) {
1729 if (N(t)<1) return tree (ERROR, "bad pattern");
1730 if (no_patterns && N(t) == 4) return exec (t[3]);
1731 url im= exec_string (t[0]);
1732 url image= resolve (relative (base_file_name, im));
1733 if (is_none (image))
1734 image= resolve (url ("$TEXMACS_PATTERN_PATH") * im);
1735 if (is_none (image)) return "white";
1736 int imw_pt, imh_pt;
1737 image_size (image, imw_pt, imh_pt);
1738 double pt= ((double) dpi*PIXEL) / 72.0;
1739 SI imw= (SI) (((double) imw_pt) * pt);
1740 SI imh= (SI) (((double) imh_pt) * pt);
1741 if (imw <= 0 || imh <= 0) return "white";
1742 if (N(t)<3) return tree (ERROR, "bad pattern");
1743 string w= exec_string (t[1]);
1744 string h= exec_string (t[2]);
1745 if (is_length (w))
1746 w= as_string (as_length (w));
1747 else if (is_magnification (w))
1748 w= as_string ((SI) (get_magnification (w) * ((double) imw)));
1749 if (is_length (h))
1750 h= as_string (as_length (h));
1751 else if (is_magnification (h))
1752 h= as_string ((SI) (get_magnification (h) * ((double) imh)));
1753 if (w == "" && h != "") {
1754 if (is_int (h)) w= as_string ((SI) ((as_double (h) * imw) / imh));
1755 else if (is_percentage (h))
1756 w= as_string (100.0 * (as_percentage (h) * imw) / imh) * "@";
1757 else return "white";
1758 }
1759 else if (h == "" && w != "") {
1760 if (is_int (w)) h= as_string ((SI) ((as_double (w) * imh) / imw));
1761 else if (is_percentage (w))
1762 h= as_string (100.0 * (as_percentage (w) * imh) / imw) * "@";
1763 else return "white";
1764 }
1765 else if (w == "" && h == "") {
1766 w= as_string (imw);
1767 h= as_string (imh);
1768 }
1769 else if ((!is_int (w) && !is_percentage (w) && !is_percentage (w, "@")) ||
1770 (!is_int (h) && !is_percentage (h) && !is_percentage (h, "@")))
1771 return "white";
1772 tree r (PATTERN, as_string (image), w, h);
1773 if (N(t) == 4) r << exec (t[3]);
1774 return r;
1775 }
1776
1777 tree
exec_point(tree t)1778 edit_env_rep::exec_point (tree t) {
1779 int i, n= N(t);
1780 tree u (_POINT, n);
1781 for (i=0; i<n; i++)
1782 u[i]= exec (t[i]);
1783 if (n==0 || is_double (u[0])) return u;
1784 return as_tree (as_point (u));
1785 }
1786
1787 tree
exec_eff_move(tree t)1788 edit_env_rep::exec_eff_move (tree t) {
1789 if (N(t) < 3) return tree (ERROR, "bad eff-move");
1790 tree body= exec (t[0]);
1791 tree dx = as_tree (as_length (exec (t[1])));
1792 tree dy = as_tree (as_length (exec (t[2])));
1793 return tree (EFF_MOVE, body, dx, dy);
1794 }
1795
1796 tree
exec_eff_bubble(tree t)1797 edit_env_rep::exec_eff_bubble (tree t) {
1798 if (N(t) < 3) return tree (ERROR, "bad eff-bubble");
1799 tree body= exec (t[0]);
1800 tree r = as_tree (as_length (exec (t[1])));
1801 tree a = exec (t[2]);
1802 return tree (EFF_BUBBLE, body, r, a);
1803 }
1804
1805 tree
exec_eff_gaussian(tree t)1806 edit_env_rep::exec_eff_gaussian (tree t) {
1807 if (N(t) < 1) return tree (ERROR, "bad eff-gaussian");
1808 tree rx= as_tree (as_length (exec (t[0])));
1809 if (N(t) == 1) return tree (EFF_GAUSSIAN, as_tree (rx));
1810 if (N(t) < 3) return tree (ERROR, "bad eff-gaussian");
1811 tree ry= as_tree (as_length (exec (t[1])));
1812 return tree (EFF_GAUSSIAN, rx, ry, exec (t[2]));
1813 }
1814
1815 tree
exec_eff_oval(tree t)1816 edit_env_rep::exec_eff_oval (tree t) {
1817 if (N(t) < 1) return tree (ERROR, "bad eff-oval");
1818 tree rx= as_tree (as_length (exec (t[0])));
1819 if (N(t) == 1) return tree (EFF_OVAL, as_tree (rx));
1820 if (N(t) < 3) return tree (ERROR, "bad eff-oval");
1821 tree ry= as_tree (as_length (exec (t[1])));
1822 return tree (EFF_OVAL, rx, ry, exec (t[2]));
1823 }
1824
1825 tree
exec_eff_rectangular(tree t)1826 edit_env_rep::exec_eff_rectangular (tree t) {
1827 if (N(t) < 1) return tree (ERROR, "bad eff-rectangular");
1828 tree rx= as_tree (as_length (exec (t[0])));
1829 if (N(t) == 1) return tree (EFF_RECTANGULAR, as_tree (rx));
1830 if (N(t) < 3) return tree (ERROR, "bad eff-rectangular");
1831 tree ry= as_tree (as_length (exec (t[1])));
1832 return tree (EFF_RECTANGULAR, rx, ry, exec (t[2]));
1833 }
1834
1835 tree
exec_eff_motion(tree t)1836 edit_env_rep::exec_eff_motion (tree t) {
1837 if (N(t) < 2) return tree (ERROR, "bad eff-motion");
1838 tree dx= as_tree (as_length (exec (t[0])));
1839 tree dy= as_tree (as_length (exec (t[1])));
1840 return tree (EFF_MOTION, dx, dy);
1841 }
1842
1843 tree
exec_box_info(tree t)1844 edit_env_rep::exec_box_info (tree t) {
1845 if (N(t)<2) return tree (ERROR, "bad box-info");
1846 tree t1= t[0];
1847 tree t2= t[1];
1848 if (!is_string (t2))
1849 return tree (ERROR, "bad box info");
1850 return box_info (edit_env (this), t1, as_string (t2));
1851 }
1852
1853 tree
exec_frame_direct(tree t)1854 edit_env_rep::exec_frame_direct (tree t) {
1855 if (N(t)<1) return tree (ERROR, "bad frame-direct");
1856 tree t1= exec (t[0]);
1857 return as_tree (!is_nil (fr) ? fr (::as_point (t1)) : point ());
1858 }
1859
1860 tree
exec_frame_inverse(tree t)1861 edit_env_rep::exec_frame_inverse (tree t) {
1862 if (N(t)<1) return tree (ERROR, "bad frame-inverse");
1863 tree t1= exec (t[0]);
1864 return as_tree (!is_nil (fr) ? fr [::as_point (t1)] : point ());
1865 }
1866
1867 /******************************************************************************
1868 * Partial evaluation of trees
1869 ******************************************************************************/
1870
1871 void
exec_until(tree t,path p)1872 edit_env_rep::exec_until (tree t, path p) {
1873 // cout << "Execute " << t << " until " << p << "\n";
1874 if (is_nil (p)) return;
1875 if (is_atom (p)) {
1876 if (p->item!=0)
1877 (void) exec (t);
1878 return;
1879 }
1880
1881 switch (L(t)) {
1882 case DATOMS:
1883 exec_until_formatting (t, p, ATOM_DECORATIONS);
1884 return;
1885 case DLINES:
1886 exec_until_formatting (t, p, LINE_DECORATIONS);
1887 return;
1888 case DPAGES:
1889 exec_until_formatting (t, p, PAGE_DECORATIONS);
1890 return;
1891 case TFORMAT:
1892 exec_until_formatting (t, p, CELL_FORMAT);
1893 return;
1894 case TABLE:
1895 exec_until_table (t, p);
1896 return;
1897 case WITH:
1898 exec_until_with (t, p);
1899 return;
1900 case COMPOUND:
1901 exec_until_compound (t, p);
1902 return;
1903 case MARK:
1904 if (p->item == 1) exec_until (t[1], p->next);
1905 return;
1906 case STYLE_WITH:
1907 case VAR_STYLE_WITH:
1908 if (p->item == (N(t)-1)) exec_until (t[N(t)-1], p->next);
1909 return;
1910 case STYLE_ONLY:
1911 case VAR_STYLE_ONLY:
1912 case ACTIVE:
1913 case VAR_ACTIVE:
1914 case INACTIVE:
1915 case VAR_INACTIVE:
1916 exec_until_compound (t, p);
1917 return;
1918 case HLINK:
1919 case ACTION:
1920 exec_until_compound (t, p);
1921 return;
1922 default:
1923 if (L(t) < START_EXTENSIONS) {
1924 int i;
1925 for (i=0; i<p->item; i++) (void) exec (t[i]);
1926 exec_until (t[p->item], p->next);
1927 }
1928 else exec_until_compound (t, p);
1929 return;
1930 }
1931 }
1932
1933 void
exec_until_formatting(tree t,path p,string v)1934 edit_env_rep::exec_until_formatting (tree t, path p, string v) {
1935 int n= N(t);
1936 if (p->item != n-1) return;
1937 tree oldv= read (v);
1938 tree newv= oldv * t (0, n-1);
1939 monitored_write_update (v, newv);
1940 exec_until (t[n-1], p->next);
1941 }
1942
1943 void
exec_until_table(tree t,path p)1944 edit_env_rep::exec_until_table (tree t, path p) {
1945 // should execute values in oldv
1946 monitored_write_update (CELL_FORMAT, tree (TFORMAT));
1947 int i;
1948 for (i=0; i<p->item; i++)
1949 (void) exec (t[i]);
1950 exec_until (t[p->item], p->next);
1951 return;
1952 }
1953
1954 void
exec_until_with(tree t,path p)1955 edit_env_rep::exec_until_with (tree t, path p) {
1956 int i, n= N(t), k= (n-1)>>1; // is k=0 allowed ?
1957 if (((n&1) != 1) || (p->item != n-1)) return;
1958 STACK_NEW_ARRAY(vars,string,k);
1959 STACK_NEW_ARRAY(newv,tree,k);
1960 for (i=0; i<k; i++) {
1961 tree var_t= exec (t[i<<1]);
1962 if (is_atomic (var_t)) {
1963 string var= var_t->label;
1964 vars[i]= var;
1965 newv[i]= exec (t[(i<<1)+1]);
1966 }
1967 else {
1968 STACK_DELETE_ARRAY(vars);
1969 STACK_DELETE_ARRAY(newv);
1970 return;
1971 }
1972 }
1973 for (i=0; i<k; i++) monitored_write_update (vars[i], newv[i]);
1974 exec_until (t[n-1], p->next);
1975 STACK_DELETE_ARRAY(vars);
1976 STACK_DELETE_ARRAY(newv);
1977 return;
1978 }
1979
1980 void
exec_until_compound(tree t,path p)1981 edit_env_rep::exec_until_compound (tree t, path p) {
1982 int d; tree f;
1983 if (L(t) == COMPOUND) {
1984 d= 1;
1985 f= t[0];
1986 if (is_compound (f)) f= exec (f);
1987 if (is_compound (f)) return;
1988 string fname= f->label;
1989 if (!provides (fname)) return;
1990 f= read (fname);
1991 }
1992 else {
1993 string fname= as_string (L(t));
1994 if (!provides (fname)) return;
1995 d= 0;
1996 f= read (fname);
1997 }
1998
1999 string var;
2000 if (L(f) == XMACRO) var= f[0]->label;
2001 else {
2002 if ((p->item < d) || (p->item >= N(f)) ||
2003 is_compound (f[p->item-d])) return;
2004 var= f[p->item-d]->label;
2005 }
2006
2007 if (is_applicable (f)) {
2008 int i, n=N(f)-1, m=N(t)-d;
2009 macro_arg= list<hashmap<string,tree> >
2010 (hashmap<string,tree> (UNINIT), macro_arg);
2011 macro_src= list<hashmap<string,path> >
2012 (hashmap<string,path> (path (DECORATION)), macro_src);
2013 if (L(f) == XMACRO) {
2014 if (is_atomic (f[0])) {
2015 macro_arg->item (f[0]->label)= t;
2016 macro_src->item (f[0]->label)= obtain_ip (t);
2017 }
2018 (void) exec_until (f[n], p, var, 0);
2019 }
2020 else {
2021 for (i=0; i<n; i++)
2022 if (is_atomic (f[i])) {
2023 tree st= i<m? t[i+d]: tree (UNINIT);
2024 macro_arg->item (f[i]->label)= st;
2025 macro_src->item (f[i]->label)= obtain_ip (st);
2026 }
2027 (void) exec_until (f[n], p->next, var, 0);
2028 }
2029 macro_arg= macro_arg->next;
2030 macro_src= macro_src->next;
2031 }
2032 }
2033
2034 bool
exec_until(tree t,path p,string var,int level)2035 edit_env_rep::exec_until (tree t, path p, string var, int level) {
2036 // cout << "Execute " << t << " until " << p
2037 // << " inside " << var << " level " << level << "\n";
2038 if (is_atomic (t)) return false;
2039 switch (L(t)) {
2040 case DATOMS:
2041 return exec_until_formatting (t, p, var, level, ATOM_DECORATIONS);
2042 case DLINES:
2043 return exec_until_formatting (t, p, var, level, LINE_DECORATIONS);
2044 case DPAGES:
2045 return exec_until_formatting (t, p, var, level, PAGE_DECORATIONS);
2046 case TFORMAT:
2047 return exec_until_formatting (t, p, var, level, CELL_FORMAT);
2048 case TABLE:
2049 return exec_until_table (t, p, var, level);
2050 case ASSIGN:
2051 (void) exec (t);
2052 return false;
2053 case WITH:
2054 return exec_until_with (t, p, var, level);
2055 case PROVIDES:
2056 (void) exec (t);
2057 return false;
2058 case VALUE:
2059 /*
2060 {
2061 tree r= t[0];
2062 if (is_compound (r)) r= exec (r);
2063 if (is_atomic (r) && (r->label == var)) {
2064 exec_until (read (r->label), p);
2065 return true;
2066 }
2067 }
2068 */
2069 (void) exec (t);
2070 return false;
2071 case QUOTE_VALUE:
2072 (void) exec (t);
2073 return false;
2074 case MACRO:
2075 case DRD_PROPS:
2076 (void) exec (t);
2077 return false;
2078 case ARG:
2079 return exec_until_arg (t, p, var, level);
2080 case QUOTE_ARG:
2081 (void) exec (t);
2082 return false;
2083 case COMPOUND:
2084 return exec_until_compound (t, p, var, level);
2085 case XMACRO:
2086 case GET_LABEL:
2087 case GET_ARITY:
2088 (void) exec (t);
2089 return false;
2090 case MAP_ARGS:
2091 case EVAL_ARGS:
2092 return exec_until_rewrite (t, p, var, level);
2093 case MARK:
2094 return exec_until_mark (t, p, var, level);
2095 case EVAL:
2096 return exec_until (exec (t), p, var, level);
2097 case QUOTE:
2098 (void) exec (t);
2099 return false;
2100 case QUASI:
2101 return exec_until_quasi (t, p, var, level);
2102 case QUASIQUOTE:
2103 case UNQUOTE:
2104 case VAR_UNQUOTE:
2105 (void) exec (t);
2106 return false;
2107 case IF:
2108 case VAR_IF:
2109 return exec_until_if (t, p, var, level);
2110 case CASE:
2111 return exec_until_case (t, p, var, level);
2112 case WHILE:
2113 return exec_until_while (t, p, var, level);
2114 case FOR_EACH:
2115 (void) exec (t);
2116 return false;
2117 case EXTERN:
2118 case VAR_INCLUDE:
2119 return exec_until_rewrite (t, p, var, level);
2120 case USE_PACKAGE:
2121 case USE_MODULE:
2122 case OR:
2123 case XOR:
2124 case AND:
2125 case NOT:
2126 case PLUS:
2127 case MINUS:
2128 case TIMES:
2129 case OVER:
2130 case DIV:
2131 case MOD:
2132 case MERGE:
2133 case LENGTH:
2134 case RANGE:
2135 case NUMBER:
2136 case _DATE:
2137 case TRANSLATE:
2138 case FIND_FILE:
2139 case FIND_FILE_UPWARDS:
2140 case IS_TUPLE:
2141 case LOOK_UP:
2142 case EQUAL:
2143 case UNEQUAL:
2144 case LESS:
2145 case LESSEQ:
2146 case GREATER:
2147 case GREATEREQ:
2148 case BLEND:
2149 (void) exec (t);
2150 return false;
2151 case STYLE_WITH:
2152 case VAR_STYLE_WITH:
2153 return exec_until (t[N(t)-1], p, var, level);
2154 case STYLE_ONLY:
2155 case VAR_STYLE_ONLY:
2156 case ACTIVE:
2157 case VAR_ACTIVE:
2158 case INACTIVE:
2159 case VAR_INACTIVE:
2160 return exec_until_compound (t, p, var, level);
2161 case REWRITE_INACTIVE:
2162 return exec_until_rewrite (t, p, var, level);
2163 case HLINK:
2164 case ACTION:
2165 return exec_until_compound (t, p, var, level);
2166 default:
2167 if (L(t) < START_EXTENSIONS) {
2168 int i, n= N(t);
2169 for (i=0; i<n; i++)
2170 if (exec_until (t[i], p, var, level))
2171 return true;
2172 return false;
2173 }
2174 else return exec_until_compound (t, p, var, level);
2175 }
2176 }
2177
2178 bool
exec_until_formatting(tree t,path p,string var,int level,string v)2179 edit_env_rep::exec_until_formatting (
2180 tree t, path p, string var, int level, string v)
2181 {
2182 int n= N(t);
2183 tree oldv= read (v);
2184 tree newv= oldv * t (0, n-1);
2185 monitored_write_update (v, newv);
2186 if (exec_until (t[n-1], p, var, level)) return true;
2187 monitored_write_update (v, oldv);
2188 return false;
2189 }
2190
2191 bool
exec_until_table(tree t,path p,string var,int level)2192 edit_env_rep::exec_until_table (tree t, path p, string var, int level) {
2193 tree oldv= read (CELL_FORMAT);
2194 // should execute values in oldv
2195 monitored_write_update (CELL_FORMAT, tree (TFORMAT));
2196 int i, n= N(t);
2197 for (i=0; i<n; i++)
2198 if (exec_until (t[i], p, var, level))
2199 return true;
2200 monitored_write_update (CELL_FORMAT, oldv);
2201 return false;
2202 }
2203
2204 bool
exec_until_with(tree t,path p,string var,int level)2205 edit_env_rep::exec_until_with (tree t, path p, string var, int level) {
2206 int i, n= N(t), k= (n-1)>>1; // is k=0 allowed ?
2207 if ((n&1) != 1) return false;
2208 STACK_NEW_ARRAY(vars,string,k);
2209 STACK_NEW_ARRAY(oldv,tree,k);
2210 STACK_NEW_ARRAY(newv,tree,k);
2211 for (i=0; i<k; i++) {
2212 tree var_t= exec (t[i<<1]);
2213 if (is_atomic (var_t)) {
2214 string var= var_t->label;
2215 vars[i]= var;
2216 oldv[i]= read (var);
2217 newv[i]= exec (t[(i<<1)+1]);
2218 }
2219 else {
2220 STACK_DELETE_ARRAY(vars);
2221 STACK_DELETE_ARRAY(oldv);
2222 STACK_DELETE_ARRAY(newv);
2223 return false;
2224 }
2225 }
2226
2227 for (i=0; i<k; i++) monitored_write_update (vars[i], newv[i]);
2228 if (exec_until (t[n-1], p, var, level)) {
2229 STACK_DELETE_ARRAY(vars);
2230 STACK_DELETE_ARRAY(oldv);
2231 STACK_DELETE_ARRAY(newv);
2232 return true;
2233 }
2234 for (i=k-1; i>=0; i--) write_update (vars[i], oldv[i]);
2235 STACK_DELETE_ARRAY(vars);
2236 STACK_DELETE_ARRAY(oldv);
2237 STACK_DELETE_ARRAY(newv);
2238 return false;
2239 }
2240
2241 bool
exec_until_compound(tree t,path p,string var,int level)2242 edit_env_rep::exec_until_compound (tree t, path p, string var, int level) {
2243 int d; tree f;
2244 if (L(t) == COMPOUND) {
2245 d= 1;
2246 f= t[0];
2247 if (is_compound (f)) f= exec (f);
2248 if (is_atomic (f)) {
2249 string var= f->label;
2250 if (!provides (var)) return false;
2251 f= read (var);
2252 }
2253 }
2254 else {
2255 string fname= as_string (L(t));
2256 if (!provides (fname)) return false;
2257 d= 0;
2258 f= read (fname);
2259 }
2260
2261 if (is_applicable (f)) {
2262 int i, n=N(f)-1, m=N(t)-d;
2263 macro_arg= list<hashmap<string,tree> >
2264 (hashmap<string,tree> (UNINIT), macro_arg);
2265 macro_src= list<hashmap<string,path> >
2266 (hashmap<string,path> (path (DECORATION)), macro_src);
2267 if (L(f) == XMACRO) {
2268 if (is_atomic (f[0]))
2269 macro_arg->item (f[0]->label)= t;
2270 }
2271 for (i=0; i<n; i++)
2272 if (is_atomic (f[i])) {
2273 tree st= i<m? t[i+d]: tree (UNINIT);
2274 macro_arg->item (f[i]->label)= st;
2275 macro_src->item (f[i]->label)= obtain_ip (st);
2276 }
2277 bool done= exec_until (f[n], p, var, level+1);
2278 macro_arg= macro_arg->next;
2279 macro_src= macro_src->next;
2280 return done;
2281 }
2282 return false;
2283 }
2284
2285 bool
exec_until_arg(tree t,path p,string var,int level)2286 edit_env_rep::exec_until_arg (tree t, path p, string var, int level) {
2287 // cout << " " << macro_arg << "\n";
2288 tree r= t[0];
2289 if (is_atomic (r) && (!is_nil (macro_arg)) &&
2290 macro_arg->item->contains (r->label))
2291 {
2292 bool found;
2293 tree arg= macro_arg->item [r->label];
2294 list<hashmap<string,tree> > old_var= macro_arg;
2295 list<hashmap<string,path> > old_src= macro_src;
2296 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
2297 if (!is_nil (macro_src)) macro_src= macro_src->next;
2298 if (level == 0) {
2299 found= (r->label == var);
2300 if ((N(t) > 1) && found) {
2301 int i, n= N(t);
2302 for (i=1; i<n; i++) {
2303 tree u= exec (t[i]);
2304 if (!is_int (u)) { found= false; break; }
2305 int nr= as_int (u);
2306 if ((!is_compound (arg)) || (nr<0) || (nr>=N(arg)) || is_nil (p)) {
2307 found= false; break; }
2308 if (p->item != nr) found= false;
2309 arg= arg[nr];
2310 p = p->next;
2311 }
2312 }
2313 if (found) exec_until (arg, p);
2314 else exec (arg);
2315 }
2316 else found= exec_until (arg, p, var, level-1);
2317 macro_arg= old_var;
2318 macro_src= old_src;
2319 return found;
2320 }
2321 else return false;
2322 /*
2323 cout << " " << macro_arg << "\n";
2324 tree r= t[0];
2325 if (is_atomic (r) && (r->label == var) && (!is_nil (macro_arg))) {
2326 bool found= (level == 0) && macro_arg->item->contains (r->label);
2327 tree arg = macro_arg->item [var];
2328 list<hashmap<string,tree> > old_var= macro_arg;
2329 list<hashmap<string,path> > old_src= macro_src;
2330 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
2331 if (!is_nil (macro_src)) macro_src= macro_src->next;
2332 if (found) exec_until (arg, p);
2333 else found= exec_until (arg, p, var, level-1);
2334 macro_arg= old_var;
2335 macro_src= old_src;
2336 return found;
2337 }
2338 */
2339 }
2340
2341 bool
exec_until_mark(tree t,path p,string var,int level)2342 edit_env_rep::exec_until_mark (tree t, path p, string var, int level) {
2343 bool border= false;
2344 if ((level == 0) && is_func (t[0], ARG) && (t[0][0] == var)) {
2345 // cout << "\n\tTest: " << t[0] << ", " << p << "\n";
2346 path q= p;
2347 int i, n= N(t[0]);
2348 for (i=1; (!is_nil (q)) && (i<n); i++, q= q->next)
2349 if (t[0][i] != as_string (q->item))
2350 break;
2351 border= (i == n) && is_atom (q);
2352 // FIXME: in order to be clean, we should check whether q->item
2353 // is on the border of the contents of the argument t[0].
2354 // Nevertheless, this only matters for strings and
2355 // the present implementation seems to be OK for the moment.
2356 // cout << "\tBorder= " << border << "\n\n";
2357 }
2358 if (border) return exec_until (t[0], p, var, level);
2359 else return exec_until (t[1], p, var, level);
2360 }
2361
2362 bool
exec_until_quasi(tree t,path p,string var,int level)2363 edit_env_rep::exec_until_quasi (tree t, path p, string var, int level) {
2364 bool old= quote_substitute;
2365 quote_substitute= true;
2366 tree u= exec_quasiquoted (t[0]);
2367 quote_substitute= old;
2368 return exec_until (u, p, var, level);
2369 }
2370
2371 bool
exec_until_if(tree t,path p,string var,int level)2372 edit_env_rep::exec_until_if (tree t, path p, string var, int level) {
2373 if ((N(t)!=2) && (N(t)!=3)) return false;
2374 tree tt= exec (t[0]);
2375 if (is_compound (tt) || !is_bool (tt->label)) return false;
2376 if (as_bool (tt->label)) return exec_until (t[1], p, var, level);
2377 if (N(t)==3) return exec_until (t[2], p, var, level);
2378 return false;
2379 }
2380
2381 bool
exec_until_case(tree t,path p,string var,int level)2382 edit_env_rep::exec_until_case (tree t, path p, string var, int level) {
2383 if (N(t)<2) return false;
2384 int i, n= N(t);
2385 for (i=0; i<(n-1); i+=2) {
2386 tree tt= exec (t[i]);
2387 if (is_compound (tt) || ! is_bool (tt->label)) return false;
2388 if (as_bool (tt->label)) return exec_until (t[i+1], p, var, level);
2389 }
2390 if (i<n) return exec_until (t[i], p, var, level);
2391 return false;
2392 }
2393
2394 bool
exec_until_while(tree t,path p,string var,int level)2395 edit_env_rep::exec_until_while (tree t, path p, string var, int level) {
2396 if (N(t)!=2) return false;
2397 while (1) {
2398 tree tt= exec (t[0]);
2399 if (is_compound (tt)) return false;
2400 if (!is_bool (tt->label)) return false;
2401 if (!as_bool (tt->label)) break;
2402 if (exec_until (t[1], p, var, level)) return true;
2403 }
2404 return false;
2405 }
2406
2407 /******************************************************************************
2408 * Extra routines for macro expansion and function application
2409 ******************************************************************************/
2410
2411 tree
expand(tree t,bool search_accessible)2412 edit_env_rep::expand (tree t, bool search_accessible) {
2413 if (is_atomic (t) || is_nil (macro_arg)) return t;
2414 else if (is_func (t, ARG) || is_func (t, QUOTE_ARG)) {
2415 if (N(t) < 1)
2416 return tree (ERROR, "bad argument application");
2417 if (is_compound (t[0]))
2418 return tree (ERROR, "bad argument application");
2419 if (!macro_arg->item->contains (t[0]->label))
2420 return tree (ERROR, "argument " * t[0]->label);
2421 tree r= macro_arg->item [t[0]->label];
2422 list<hashmap<string,tree> > old_var= macro_arg;
2423 list<hashmap<string,path> > old_src= macro_src;
2424 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
2425 if (!is_nil (macro_src)) macro_src= macro_src->next;
2426 if (N(t) > 1) {
2427 int i, n= N(t);
2428 for (i=1; i<n; i++) {
2429 tree u= exec (t[i]);
2430 if (!is_int (u)) break;
2431 int nr= as_int (u);
2432 if ((!is_compound (r)) || (nr<0) || (nr>=N(r))) break;
2433 r= r[nr];
2434 }
2435 }
2436 if (is_func (t, ARG))
2437 r= expand (r, search_accessible);
2438 macro_arg= old_var;
2439 macro_src= old_src;
2440 return r;
2441 }
2442 else if (is_func (t, EXPAND_AS, 2)) {
2443 if (N(t) < 1)
2444 return tree (ERROR, "bad argument application");
2445 return expand (t[0], search_accessible);
2446 } else if (search_accessible && is_accessible (obtain_ip (t)))
2447 return t;
2448 else {
2449 int i, n= N(t);
2450 tree r (t, n);
2451 for (i=0; i<n; i++) {
2452 r[i]= expand (t[i], search_accessible);
2453 if (search_accessible &&
2454 is_accessible (obtain_ip (r[i])) &&
2455 drd->is_accessible_child (t, i))
2456 return r[i];
2457 }
2458 if (search_accessible) return t;
2459 return r;
2460 }
2461 }
2462
2463 bool
depends(tree t,string s,int level)2464 edit_env_rep::depends (tree t, string s, int level) {
2465 /*
2466 cout << "Depends? " << t << ", " << s << ", " << level
2467 << " " << macro_arg << "\n";
2468 */
2469
2470 if (is_atomic (t) || is_nil (macro_arg)) return false;
2471 else if (is_func (t, ARG) ||
2472 is_func (t, QUOTE_ARG) ||
2473 is_func (t, MAP_ARGS) ||
2474 is_func (t, EVAL_ARGS))
2475 {
2476 // FIXME: this does not handle more complex dependencies,
2477 // like those encountered after rewritings (VAR_INCLUDE, EXTERN, etc.)
2478 tree v= (L(t) == MAP_ARGS? t[2]: t[0]);
2479 if (is_compound (v)) return false;
2480 if (!macro_arg->item->contains (v->label)) return false;
2481 if (level == 0) return v->label == s;
2482 tree r= macro_arg->item [v->label];
2483 list<hashmap<string,tree> > old_var= macro_arg;
2484 list<hashmap<string,path> > old_src= macro_src;
2485 if (!is_nil (macro_arg)) macro_arg= macro_arg->next;
2486 if (!is_nil (macro_src)) macro_src= macro_src->next;
2487 bool dep= depends (r, s, level-1);
2488 macro_arg= old_var;
2489 macro_src= old_src;
2490 return dep;
2491 }
2492 else {
2493 int i, n= N(t);
2494 for (i=0; i<n; i++)
2495 if (depends (t[i], s, level))
2496 return true;
2497 return false;
2498 }
2499 }
2500