]> git.ipfire.org Git - thirdparty/cups.git/blame - pstoraster/zcontrol.c
Copyright update...
[thirdparty/cups.git] / pstoraster / zcontrol.c
CommitLineData
caddbb58 1/*
efb2f309 2 Copyright 1993-2002 by Easy Software Products.
caddbb58 3 Copyright 1989, 1996, 1997, 1998 Aladdin Enterprises. All rights reserved.
4
8e4ff0ae 5 This file is part of GNU Ghostscript.
caddbb58 6
8e4ff0ae 7 GNU Ghostscript is distributed in the hope that it will be useful, but
caddbb58 8 WITHOUT ANY WARRANTY. No author or distributor accepts responsibility
9 to anyone for the consequences of using it or for whether it serves any
10 particular purpose or works at all, unless he says so in writing. Refer
11 to the GNU General Public License for full details.
12
8e4ff0ae 13 Everyone is granted permission to copy, modify and redistribute GNU
14 Ghostscript, but only under the conditions described in the GNU General
caddbb58 15 Public License. A copy of this license is supposed to have been given
16 to you along with GNU Ghostscript so you can know your rights and
8e4ff0ae 17 responsibilities. It should be in a file named COPYING. Among other
18 things, the copyright notice and this notice must be preserved on all
19 copies.
caddbb58 20
21 Aladdin Enterprises supports the work of the GNU Project, but is not
22 affiliated with the Free Software Foundation or the GNU Project. GNU
23 Ghostscript, as distributed by Aladdin Enterprises, does not require any
24 GNU software to build or run it.
8e4ff0ae 25*/
26
efb2f309 27/*$Id: zcontrol.c,v 1.4 2002/01/02 17:59:12 mike Exp $ */
8e4ff0ae 28/* Control operators */
29#include "string_.h"
30#include "ghost.h"
caddbb58 31#include "stream.h"
8e4ff0ae 32#include "oper.h"
33#include "estack.h"
caddbb58 34#include "files.h"
8e4ff0ae 35#include "ipacked.h"
36#include "iutil.h"
37#include "store.h"
38
39/* Make an invalid file object. */
caddbb58 40extern void make_invalid_file(P1(ref *)); /* in zfile.c */
8e4ff0ae 41
42/* Forward references */
caddbb58 43private int no_cleanup(P1(os_ptr));
44private uint count_exec_stack(P1(bool));
45private uint count_to_stopped(P1(long));
46private int unmatched_exit(P2(os_ptr, op_proc_p));
8e4ff0ae 47
48/* See the comment in opdef.h for an invariant which allows */
49/* more efficient implementation of for, loop, and repeat. */
50
51/* <[test0 body0 ...]> .cond - */
52private int cond_continue(P1(os_ptr));
53private int
54zcond(register os_ptr op)
caddbb58 55{
56 es_ptr ep = esp;
57
58 /* Push the array on the e-stack and call the continuation. */
59 if (!r_is_array(op))
60 return_op_typecheck(op);
61 check_execute(*op);
62 if ((r_size(op) & 1) != 0)
63 return_error(e_rangecheck);
64 if (r_size(op) == 0)
65 return zpop(op);
66 check_estack(3);
67 esp = ep += 3;
68 ref_assign(ep - 2, op); /* the cond body */
69 make_op_estack(ep - 1, cond_continue);
70 array_get(op, 0L, ep);
71 esfile_check_cache();
72 pop(1);
73 return o_push_estack;
8e4ff0ae 74}
75private int
76cond_continue(register os_ptr op)
caddbb58 77{
78 es_ptr ep = esp;
79 int code;
80
81 /* The top element of the e-stack is the remaining tail of */
82 /* the cond body. The top element of the o-stack should be */
83 /* the (boolean) result of the test that is the first element */
84 /* of the tail. */
85 check_type(*op, t_boolean);
86 if (op->value.boolval) { /* true */
87 array_get(ep, 1L, ep);
88 esfile_check_cache();
89 code = o_pop_estack;
90 } else if (r_size(ep) > 2) { /* false */
91 const ref_packed *elts = ep->value.packed;
92
93 check_estack(2);
94 r_dec_size(ep, 2);
95 elts = packed_next(elts);
96 elts = packed_next(elts);
97 ep->value.packed = elts;
98 array_get(ep, 0L, ep + 2);
99 make_op_estack(ep + 1, cond_continue);
100 esp = ep + 2;
101 esfile_check_cache();
102 code = o_push_estack;
103 } else { /* fall off end of cond */
104 esp = ep - 1;
105 code = o_pop_estack;
106 }
107 pop(1); /* get rid of the boolean */
108 return code;
8e4ff0ae 109}
110
111/* <obj> exec - */
112int
113zexec(register os_ptr op)
caddbb58 114{
115 check_op(1);
116 if (!r_has_attr(op, a_executable))
117 return 0; /* literal object just gets pushed back */
118 check_estack(1);
119 ++esp;
120 ref_assign(esp, op);
121 esfile_check_cache();
122 pop(1);
123 return o_push_estack;
124}
125
126/* <obj1> ... <objn> <n> .execn - */
127int
128zexecn(register os_ptr op)
129{
130 uint n, i;
131 es_ptr esp_orig;
132
133 check_int_leu(*op, max_uint - 1);
134 n = (uint) op->value.intval;
135 check_op(n + 1);
136 check_estack(n);
137 esp_orig = esp;
138 for (i = 0; i < n; ++i) {
139 const ref *rp = ref_stack_index(&o_stack, (long)(i + 1));
140
141 /* Make sure this object is legal to execute. */
142 if (ref_type_uses_access(r_type(rp))) {
143 if (!r_has_attr(rp, a_execute) &&
144 r_has_attr(rp, a_executable)
145 ) {
146 esp = esp_orig;
147 return_error(e_invalidaccess);
148 }
149 }
150 /* Executable nulls have a special meaning on the e-stack, */
151 /* so since they are no-ops, don't push them. */
152 if (!r_has_type_attrs(rp, t_null, a_executable)) {
153 ++esp;
154 ref_assign(esp, rp);
155 }
156 }
157 esfile_check_cache();
158 pop(n + 1);
159 return o_push_estack;
8e4ff0ae 160}
161
162/* <obj> superexec - */
163/* THIS IS NOT REALLY IMPLEMENTED YET. */
164private int
165zsuperexec(os_ptr op)
caddbb58 166{
167 return zexec(op);
8e4ff0ae 168}
169
170/* <bool> <proc> if - */
171int
172zif(register os_ptr op)
caddbb58 173{
174 check_type(op[-1], t_boolean);
175 check_proc(*op);
176 if (op[-1].value.boolval) {
177 check_estack(1);
178 ++esp;
179 ref_assign(esp, op);
180 esfile_check_cache();
181 }
182 pop(2);
183 return o_push_estack;
8e4ff0ae 184}
185
186/* <bool> <proc_true> <proc_false> ifelse - */
187int
188zifelse(register os_ptr op)
caddbb58 189{
190 check_type(op[-2], t_boolean);
191 check_proc(op[-1]);
192 check_proc(*op);
193 check_estack(1);
194 ++esp;
195 if (op[-2].value.boolval) {
196 ref_assign(esp, op - 1);
197 } else {
198 ref_assign(esp, op);
199 }
200 esfile_check_cache();
201 pop(3);
202 return o_push_estack;
8e4ff0ae 203}
204
205/* <init> <step> <limit> <proc> for - */
206private int
caddbb58 207 for_pos_int_continue(P1(os_ptr)), for_neg_int_continue(P1(os_ptr)),
208 for_real_continue(P1(os_ptr));
8e4ff0ae 209int
210zfor(register os_ptr op)
caddbb58 211{
212 register es_ptr ep;
213
214 check_estack(7);
215 ep = esp + 6;
216 check_proc(*op);
217 /* Push a mark, the control variable, the initial value, */
218 /* the increment, the limit, and the procedure, */
219 /* and invoke the continuation operator. */
220 if (r_has_type(op - 3, t_integer) &&
221 r_has_type(op - 2, t_integer)
222 ) {
223 make_int(ep - 4, op[-3].value.intval);
224 make_int(ep - 3, op[-2].value.intval);
225 switch (r_type(op - 1)) {
226 case t_integer:
227 make_int(ep - 2, op[-1].value.intval);
228 break;
229 case t_real:
230 make_int(ep - 2, (long)op[-1].value.realval);
231 break;
232 default:
233 return_op_typecheck(op - 1);
234 }
235 if (ep[-3].value.intval >= 0)
236 make_op_estack(ep, for_pos_int_continue);
8e4ff0ae 237 else
caddbb58 238 make_op_estack(ep, for_neg_int_continue);
239 } else {
240 float params[3];
241 int code;
242
243 if ((code = float_params(op - 1, 3, params)) < 0)
244 return code;
245 make_real(ep - 4, params[0]);
246 make_real(ep - 3, params[1]);
247 make_real(ep - 2, params[2]);
248 make_op_estack(ep, for_real_continue);
249 }
250 make_mark_estack(ep - 5, es_for, no_cleanup);
251 ref_assign(ep - 1, op);
252 esp = ep;
253 pop(4);
254 return o_push_estack;
8e4ff0ae 255}
256/* Continuation operators for for, separate for positive integer, */
257/* negative integer, and real. */
258/* Execution stack contains mark, control variable, increment, */
259/* limit, and procedure (procedure is topmost.) */
260/* Continuation operator for positive integers. */
261private int
262for_pos_int_continue(register os_ptr op)
caddbb58 263{
264 register es_ptr ep = esp;
265 long var = ep[-3].value.intval;
266
267 if (var > ep[-1].value.intval) {
268 esp -= 5; /* pop everything */
269 return o_pop_estack;
270 }
271 push(1);
272 make_int(op, var);
273 ep[-3].value.intval = var + ep[-2].value.intval;
274 ref_assign_inline(ep + 2, ep); /* saved proc */
275 esp = ep + 2;
276 return o_push_estack;
8e4ff0ae 277}
278/* Continuation operator for negative integers. */
279private int
280for_neg_int_continue(register os_ptr op)
caddbb58 281{
282 register es_ptr ep = esp;
283 long var = ep[-3].value.intval;
284
285 if (var < ep[-1].value.intval) {
286 esp -= 5; /* pop everything */
287 return o_pop_estack;
288 }
289 push(1);
290 make_int(op, var);
291 ep[-3].value.intval = var + ep[-2].value.intval;
292 ref_assign(ep + 2, ep); /* saved proc */
293 esp = ep + 2;
294 return o_push_estack;
8e4ff0ae 295}
296/* Continuation operator for reals. */
297private int
298for_real_continue(register os_ptr op)
caddbb58 299{
300 es_ptr ep = esp;
301 float var = ep[-3].value.realval;
302 float incr = ep[-2].value.realval;
303
304 if (incr >= 0 ? (var > ep[-1].value.realval) :
305 (var < ep[-1].value.realval)
306 ) {
307 esp -= 5; /* pop everything */
308 return o_pop_estack;
309 }
310 push(1);
311 ref_assign(op, ep - 3);
312 ep[-3].value.realval = var + incr;
313 esp = ep + 2;
314 ref_assign(ep + 2, ep); /* saved proc */
315 return o_push_estack;
8e4ff0ae 316}
317
318/* Here we provide an internal variant of 'for' that enumerates the */
319/* values 0, 1/N, 2/N, ..., 1 precisely. The arguments must be */
320/* the integers 0, 1, and N. We need this for */
321/* loading caches such as the transfer function cache. */
322private int for_fraction_continue(P1(os_ptr));
323int
324zfor_fraction(register os_ptr op)
caddbb58 325{
326 int code = zfor(op);
327
328 if (code < 0)
329 return code; /* shouldn't ever happen! */
330 make_op_estack(esp, for_fraction_continue);
331 return code;
8e4ff0ae 332}
333/* Continuation procedure */
334private int
335for_fraction_continue(register os_ptr op)
caddbb58 336{
337 register es_ptr ep = esp;
338 int code = for_pos_int_continue(op);
339
340 if (code != o_push_estack)
8e4ff0ae 341 return code;
caddbb58 342 /* We must use osp instead of op here, because */
343 /* for_pos_int_continue pushes a value on the o-stack. */
344 make_real(osp, (float)osp->value.intval / ep[-1].value.intval);
345 return code;
8e4ff0ae 346}
347
348/* <int> <proc> repeat - */
349private int repeat_continue(P1(os_ptr));
350private int
351zrepeat(register os_ptr op)
caddbb58 352{
353 check_type(op[-1], t_integer);
354 check_proc(*op);
355 if (op[-1].value.intval < 0)
356 return_error(e_rangecheck);
357 check_estack(5);
358 /* Push a mark, the count, and the procedure, and invoke */
359 /* the continuation operator. */
360 push_mark_estack(es_for, no_cleanup);
361 *++esp = op[-1];
362 *++esp = *op;
363 make_op_estack(esp + 1, repeat_continue);
364 pop(2);
365 return repeat_continue(op - 2);
8e4ff0ae 366}
367/* Continuation operator for repeat */
368private int
369repeat_continue(register os_ptr op)
caddbb58 370{
371 es_ptr ep = esp; /* saved proc */
372
373 if (--(ep[-1].value.intval) >= 0) { /* continue */
374 esp += 2;
375 ref_assign(esp, ep);
376 return o_push_estack;
377 } else { /* done */
378 esp -= 3; /* pop mark, count, proc */
379 return o_pop_estack;
380 }
8e4ff0ae 381}
382
383/* <proc> loop */
384private int loop_continue(P1(os_ptr));
385private int
386zloop(register os_ptr op)
caddbb58 387{
388 check_proc(*op);
389 check_estack(4);
390 /* Push a mark and the procedure, and invoke */
391 /* the continuation operator. */
392 push_mark_estack(es_for, no_cleanup);
393 *++esp = *op;
394 make_op_estack(esp + 1, loop_continue);
395 pop(1);
396 return loop_continue(op - 1);
8e4ff0ae 397}
398/* Continuation operator for loop */
399private int
400loop_continue(register os_ptr op)
caddbb58 401{
402 register es_ptr ep = esp; /* saved proc */
403
404 ref_assign(ep + 2, ep);
405 esp = ep + 2;
406 return o_push_estack;
8e4ff0ae 407}
408
409/* - exit - */
410private int
411zexit(register os_ptr op)
caddbb58 412{
413 ref_stack_enum_t rsenum;
414 uint scanned = 0;
415
416 ref_stack_enum_begin(&rsenum, &e_stack);
417 do {
418 uint used = rsenum.size;
419 es_ptr ep = rsenum.ptr + used - 1;
420 uint count = used;
421
422 for (; count; count--, ep--)
423 if (r_is_estack_mark(ep))
424 switch (estack_mark_index(ep)) {
425 case es_for:
426 pop_estack(scanned + (used - count + 1));
427 return o_pop_estack;
428 case es_stopped:
429 return_error(e_invalidexit); /* not a loop */
430 }
431 scanned += used;
432 } while (ref_stack_enum_next(&rsenum));
433 /* No mark, quit. (per Adobe documentation) */
434 push(2);
435 return unmatched_exit(op, zexit);
436}
437
438/*
439 * .stopped pushes the following on the e-stack:
440 * - A mark with type = es_stopped and procedure = no_cleanup.
441 * - The result to be pushed on a normal return.
442 * - The signal mask for .stop.
443 * - The procedure %stopped_push, to handle the normal return case.
444 */
445
446/* In the normal (no-error) case, pop the mask from the e-stack, */
447/* and move the result to the o-stack. */
448private int
449stopped_push(register os_ptr op)
450{
451 push(1);
452 *op = esp[-1];
453 esp -= 3;
454 return o_pop_estack;
8e4ff0ae 455}
456
caddbb58 457/* - stop - */
458/* Equivalent to true 1 .stop. */
459/* This is implemented in C because if were a pseudo-operator, */
460/* the stacks would get restored in case of an error. */
8e4ff0ae 461private int
462zstop(register os_ptr op)
caddbb58 463{
464 uint count = count_to_stopped(1L);
465
466 if (count) {
467 /*
468 * If there are any t_oparrays on the e-stack, they will pop
469 * any new items from the o-stack. Wait to push the 'true'
470 * until we have run all the unwind procedures.
471 */
472 check_ostack(2);
473 pop_estack(count);
474 op = osp;
475 push(1);
476 make_true(op);
477 return o_pop_estack;
478 }
479 /* No mark, quit. (per Adobe documentation) */
480 push(2);
481 return unmatched_exit(op, zstop);
8e4ff0ae 482}
483
caddbb58 484/* <result> <mask> .stop - */
8e4ff0ae 485private int
caddbb58 486zzstop(register os_ptr op)
487{
488 uint count;
489
490 check_type(*op, t_integer);
491 count = count_to_stopped(op->value.intval);
492 if (count) {
493 /*
494 * If there are any t_oparrays on the e-stack, they will pop
495 * any new items from the o-stack. Wait to push the result
496 * until we have run all the unwind procedures.
497 */
498 ref save_result;
499
500 check_op(2);
501 save_result = op[-1];
8e4ff0ae 502 pop(2);
caddbb58 503 pop_estack(count);
504 op = osp;
505 push(1);
506 *op = save_result;
507 return o_pop_estack;
508 }
509 /* No mark, quit. (per Adobe documentation) */
510 return unmatched_exit(op, zzstop);
511}
512
513/* <obj> stopped <stopped> */
514/* Equivalent to false 1 .stopped. */
515/* This is implemented in C because if were a pseudo-operator, */
516/* the stacks would get restored in case of an error. */
517private int
518zstopped(register os_ptr op)
519{
520 check_op(1);
521 /* Mark the execution stack, and push the default result */
522 /* in case control returns normally. */
523 check_estack(5);
524 push_mark_estack(es_stopped, no_cleanup);
525 ++esp;
526 make_false(esp); /* save the result */
527 ++esp;
528 make_int(esp, 1); /* save the signal mask */
529 push_op_estack(stopped_push);
530 *++esp = *op; /* execute the operand */
531 esfile_check_cache();
532 pop(1);
533 return o_push_estack;
534}
535
536/* <obj> <result> <mask> .stopped <result> */
537private int
538zzstopped(register os_ptr op)
539{
540 check_type(*op, t_integer);
541 check_op(3);
542 /* Mark the execution stack, and push the default result */
543 /* in case control returns normally. */
544 check_estack(5);
545 push_mark_estack(es_stopped, no_cleanup);
546 *++esp = op[-1]; /* save the result */
547 *++esp = *op; /* save the signal mask */
548 push_op_estack(stopped_push);
549 *++esp = op[-2]; /* execute the operand */
550 esfile_check_cache();
551 pop(3);
552 return o_push_estack;
8e4ff0ae 553}
554
caddbb58 555/* <mask> .instopped false */
556/* <mask> .instopped <result> true */
8e4ff0ae 557private int
558zinstopped(register os_ptr op)
caddbb58 559{
560 uint count;
561
562 check_type(*op, t_integer);
563 count = count_to_stopped(op->value.intval);
564 if (count) {
565 push(1);
566 op[-1] = *ref_stack_index(&e_stack, count - 2); /* default result */
567 make_true(op);
568 } else
569 make_false(op);
570 return 0;
8e4ff0ae 571}
572
caddbb58 573/* <include_marks> .countexecstack <int> */
8e4ff0ae 574/* - countexecstack <int> */
caddbb58 575/* countexecstack is an operator solely for the sake of the Genoa tests. */
8e4ff0ae 576private int
577zcountexecstack(register os_ptr op)
caddbb58 578{
579 push(1);
580 make_int(op, count_exec_stack(false));
581 return 0;
582}
583private int
584zcountexecstack1(register os_ptr op)
585{
586 check_type(*op, t_boolean);
587 make_int(op, count_exec_stack(op->value.boolval));
588 return 0;
8e4ff0ae 589}
590
caddbb58 591/* <array> <include_marks> .execstack <subarray> */
8e4ff0ae 592/* <array> execstack <subarray> */
caddbb58 593/* execstack is an operator solely for the sake of the Genoa tests. */
8e4ff0ae 594private int execstack_continue(P1(os_ptr));
caddbb58 595private int execstack2_continue(P1(os_ptr));
596private int
597push_execstack(os_ptr op1, bool include_marks, int (*cont)(P1(os_ptr)))
598{
599 uint size;
600 /*
601 * We can't do this directly, because the interpreter
602 * might have cached some state. To force the interpreter
603 * to update the stored state, we push a continuation on
604 * the exec stack; the continuation is executed immediately,
605 * and does the actual transfer.
606 */
607 uint depth;
608
609 check_write_type(*op1, t_array);
610 size = r_size(op1);
611 depth = count_exec_stack(include_marks);
612 if (depth > size)
613 return_error(e_rangecheck);
614 {
615 int code = ref_stack_store_check(&e_stack, op1, size, 0);
616
617 if (code < 0)
618 return code;
619 }
620 check_estack(1);
621 r_set_size(op1, depth);
622 push_op_estack(cont);
623 return o_push_estack;
624}
8e4ff0ae 625private int
626zexecstack(register os_ptr op)
caddbb58 627{
628 return push_execstack(op, false, execstack_continue);
629}
630private int
631zexecstack2(register os_ptr op)
632{
633 check_type(*op, t_boolean);
634 return push_execstack(op - 1, op->value.boolval, execstack2_continue);
8e4ff0ae 635}
636/* Continuation operator to do the actual transfer. */
caddbb58 637/* r_size(op1) was set just above. */
8e4ff0ae 638private int
caddbb58 639do_execstack(os_ptr op, bool include_marks, os_ptr op1)
640{
641 ref *arefs = op1->value.refs;
642 uint asize = r_size(op1);
643 uint i;
644 ref *rq;
645
646 /*
647 * Copy elements from the stack to the array,
648 * optionally skipping executable nulls.
649 * Clear the executable bit in any internal operators, and
650 * convert t_structs and t_astructs (which can only appear
651 * in connection with stack marks, which means that they will
652 * probably be freed when unwinding) to something harmless.
653 */
654 for (i = 0, rq = arefs + asize; rq != arefs; ++i) {
655 const ref *rp = ref_stack_index(&e_stack, (long)i);
656
657 if (r_has_type_attrs(rp, t_null, a_executable) && !include_marks)
658 continue;
659 --rq;
660 ref_assign_old(op1, rq, rp, "execstack");
661 switch (r_type(rq)) {
662 case t_operator: {
663 uint opidx = op_index(rq);
664
665 if (opidx == 0 || op_def_is_internal(op_def_table[opidx]))
666 r_clear_attrs(rq, a_executable);
8e4ff0ae 667 break;
caddbb58 668 }
8e4ff0ae 669 case t_struct:
caddbb58 670 case t_astruct: {
671 const char *tname =
672 gs_struct_type_name_string(
673 gs_object_type(imemory, rq->value.pstruct));
674
675 make_const_string(rq, a_readonly | avm_foreign,
8e4ff0ae 676 strlen(tname), (const byte *)tname);
677 break;
8e4ff0ae 678 }
caddbb58 679 default:
680 ;
681 }
682 }
683 pop(op - op1);
684 return 0;
685}
686private int
687execstack_continue(os_ptr op)
688{
689 return do_execstack(op, false, op);
690}
691private int
692execstack2_continue(os_ptr op)
693{
694 return do_execstack(op, op->value.boolval, op - 1);
8e4ff0ae 695}
696
697/* - .needinput - */
698private int
699zneedinput(register os_ptr op)
caddbb58 700{
701 return e_NeedInput; /* interpreter will exit to caller */
8e4ff0ae 702}
703
704/* <obj> <int> .quit - */
705private int
706zquit(register os_ptr op)
caddbb58 707{
708 check_op(2);
709 check_type(*op, t_integer);
710 return_error(e_Quit); /* Interpreter will do the exit */
8e4ff0ae 711}
712
713/* - currentfile <file> */
714private ref *zget_current_file(P0());
715private int
716zcurrentfile(register os_ptr op)
caddbb58 717{
718 ref *fp;
719
720 push(1);
721 /* Check the cache first */
722 if (esfile != 0) {
8e4ff0ae 723#ifdef DEBUG
caddbb58 724 /* Check that esfile is valid. */
725 ref *efp = zget_current_file();
726
727 if (esfile != efp) {
728 lprintf2("currentfile: esfile=0x%lx, efp=0x%lx\n",
729 (ulong) esfile, (ulong) efp);
730 ref_assign(op, efp);
731 } else
8e4ff0ae 732#endif
caddbb58 733 ref_assign(op, esfile);
734 } else if ((fp = zget_current_file()) == 0) { /* Return an invalid file object. */
735 /* This doesn't make a lot of sense to me, */
736 /* but it's what the PostScript manual specifies. */
737 make_invalid_file(op);
738 } else {
739 ref_assign(op, fp);
740 esfile_set_cache(fp);
741 }
742 /* Make the returned value literal. */
743 r_clear_attrs(op, a_executable);
744 return 0;
8e4ff0ae 745}
746/* Get the current file from which the interpreter is reading. */
747private ref *
748zget_current_file(void)
caddbb58 749{
750 ref_stack_enum_t rsenum;
751
752 ref_stack_enum_begin(&rsenum, &e_stack);
753 do {
754 uint count = rsenum.size;
755 es_ptr ep = rsenum.ptr + count - 1;
756
757 for (; count; count--, ep--)
758 if (r_has_type_attrs(ep, t_file, a_executable))
759 return ep;
760 } while (ref_stack_enum_next(&rsenum));
761 return 0;
8e4ff0ae 762}
763
764/* ------ Initialization procedure ------ */
765
caddbb58 766const op_def zcontrol_op_defs[] =
767{
768 {"1.cond", zcond},
769 {"0countexecstack", zcountexecstack},
770 {"1.countexecstack", zcountexecstack1},
771 {"0currentfile", zcurrentfile},
772 {"1exec", zexec},
773 {"1.execn", zexecn},
774 {"1execstack", zexecstack},
775 {"2.execstack", zexecstack2},
776 {"0exit", zexit},
777 {"2if", zif},
778 {"3ifelse", zifelse},
779 {"0.instopped", zinstopped},
780 {"0.needinput", zneedinput},
781 {"4for", zfor},
782 {"1loop", zloop},
783 {"2.quit", zquit},
784 {"2repeat", zrepeat},
785 {"0stop", zstop},
786 {"1.stop", zzstop},
787 {"1stopped", zstopped},
788 {"2.stopped", zzstopped},
8e4ff0ae 789 /* Internal operators */
caddbb58 790 {"1%cond_continue", cond_continue},
791 {"1%execstack_continue", execstack_continue},
792 {"2%execstack2_continue", execstack2_continue},
793 {"0%for_pos_int_continue", for_pos_int_continue},
794 {"0%for_neg_int_continue", for_neg_int_continue},
795 {"0%for_real_continue", for_real_continue},
796 {"4%for_fraction", zfor_fraction},
797 {"0%for_fraction_continue", for_fraction_continue},
798 {"0%loop_continue", loop_continue},
799 {"0%repeat_continue", repeat_continue},
800 {"0%stopped_push", stopped_push},
801 {"1superexec", zsuperexec},
802 op_def_end(0)
803};
8e4ff0ae 804
805/* ------ Internal routines ------ */
806
807/* Vacuous cleanup routine */
caddbb58 808private int
8e4ff0ae 809no_cleanup(os_ptr op)
caddbb58 810{
811 return 0;
8e4ff0ae 812}
813
caddbb58 814/*
815 * Count the number of elements on the exec stack, with or without
816 * the normally invisible elements (*op is a Boolean that indicates this).
817 */
8e4ff0ae 818private uint
caddbb58 819count_exec_stack(bool include_marks)
820{
821 uint count = ref_stack_count(&e_stack);
822
823 if (!include_marks) {
824 uint i;
825
826 for (i = count; i--;)
827 if (r_has_type_attrs(ref_stack_index(&e_stack, (long)i),
828 t_null, a_executable))
829 --count;
830 }
831 return count;
832}
833
834/*
835 * Count the number of elements down to and including the first 'stopped'
836 * mark on the e-stack with a given mask. Return 0 if there is no 'stopped'
837 * mark.
838 */
839private uint
840count_to_stopped(long mask)
841{
842 ref_stack_enum_t rsenum;
843 uint scanned = 0;
844
845 ref_stack_enum_begin(&rsenum, &e_stack);
846 do {
847 uint used = rsenum.size;
848 es_ptr ep = rsenum.ptr + used - 1;
849 uint count = used;
850
851 for (; count; count--, ep--)
852 if (r_is_estack_mark(ep) &&
853 estack_mark_index(ep) == es_stopped &&
854 (ep[2].value.intval & mask) != 0
855 )
856 return scanned + (used - count + 1);
857 scanned += used;
858 } while (ref_stack_enum_next(&rsenum));
859 return 0;
8e4ff0ae 860}
861
caddbb58 862/*
863 * Pop the e-stack, executing cleanup procedures as needed.
864 * We could make this more efficient using ref_stack_enum_*,
865 * but it isn't used enough to make this worthwhile.
866 */
8e4ff0ae 867void
868pop_estack(uint count)
caddbb58 869{
870 uint idx = 0;
871 uint popped = 0;
872
873 esfile_clear_cache();
874 for (; idx < count; idx++) {
875 ref *ep = ref_stack_index(&e_stack, idx - popped);
876
877 if (r_is_estack_mark(ep)) {
878 ref_stack_pop(&e_stack, idx + 1 - popped);
879 popped = idx + 1;
880 (*real_opproc(ep)) (osp);
8e4ff0ae 881 }
caddbb58 882 }
883 ref_stack_pop(&e_stack, count - popped);
884}
885
886/*
887 * Execute a quit in the case of an exit or stop with no appropriate
888 * enclosing control scope (loop or stopped). The caller has already
889 * ensured two free slots on the top of the o-stack.
890 */
891private int
892unmatched_exit(os_ptr op, op_proc_p opproc)
893{
894 make_oper(op - 1, 0, opproc);
895 make_int(op, e_invalidexit);
896 return_error(e_Quit);
8e4ff0ae 897}