1 /*
2 * $Id: task.c,v 1.16 2010-07-04 23:07:06 dhmunro Exp $
3 * Implement Yorick virtual machine.
4 */
5 /* Copyright (c) 2005, The Regents of the University of California.
6 * All rights reserved.
7 * This file is part of yorick (http://yorick.sourceforge.net).
8 * Read the accompanying LICENSE file for details.
9 */
10
11 #include "yapi.h"
12 #include "ydata.h"
13 #include "yio.h"
14 #include "pstdlib.h"
15 #include "play.h"
16
17 #include <string.h>
18
19 /* packages that need to clean up before Yorick exits should supply
20 CleanUpForExit, then call the one they found */
21 extern void (*CleanUpForExit)(void);
22 void (*CleanUpForExit)(void)= 0;
23
24 extern int YpParse(void *func); /* argument non-zero for YpReparse */
25
26 /* The offsetof macro may be defined in <stddef.h> (it is ANSI standard). */
27 /* #define offsetof(structure, member) ((long)&(((structure*)0)->member))
28 (does not work on Crays) */
29 #ifndef offsetof
30 #define offsetof(structure, member) \
31 ((long)((char *)&(((structure*)0)->member) - (char *)0))
32 #endif
33
34 /*--------------------------------------------------------------------------*/
35
36 extern BuiltIn Y_quit, Y_include, Y_require, Y_help, Y_exit, Y_error, Y_batch;
37 extern BuiltIn Y_current_include, Y_get_includes;
38 extern BuiltIn Y_plug_in, Y_plug_dir, Y_maybe_prompt, Y_suspend, Y_resume;
39 extern BuiltIn Y_after, Y__after_func, Y_include1, Y_vopen, Y_vclose;
40
41 extern ybuiltin_t Y_prompt_marker;
42
43 extern void YRun(void);
44 extern void YHalt(void);
45
46 extern int CheckForTasks(int wait);
47
48 extern VMaction Eval, Return, PushVariable;
49
50 extern void ClearTasks(void);
51 extern int DoTask(void);
52
53 extern Function *FuncContaining(Instruction *pc);
54
55 /* If yAutoDebug!=0, debug mode will be entered automatically whenever
56 a runtime error occurs. Otherwise, you must type "debug". */
57 extern int yAutoDebug;
58 int yAutoDebug= 0;
59
60 int yDebugLevel= 0;
61
62 /* most recent error message was built in yErrorMsg */
63 char yErrorMsg[192+12];
64 char yWarningMsg[192];
65
66 static int inYError= 0;
67
68 /* from fnctn.c */
69 extern Instruction *ClearStack(void);
70 extern Instruction *AbortReturn(void);
71
72 extern long ypBeginLine;
73
74 extern TextStream *NewTextStream(char *fullname,
75 void *stream, int permissions,
76 long line, long pos);
77
78 typedef struct DebugBlk DebugBlk;
79 extern DebugBlk *NewDebugBlk(Function *f, long pcerr, char *errFile,
80 long lnum);
81
82 /* stuff to implement catch */
83 extern BuiltIn Y_catch;
84 typedef struct Catcher Catcher;
85 struct Catcher {
86 Instruction *task;
87 Instruction *pc; /* of conditional branch instruction */
88 long isp; /* sp-spBottom of returnSym for calling function */
89 int category; /* of error to be caught */
90 };
91 static long n_catchers= 0;
92 static long max_catchers= 0;
93 static Catcher *catchers= 0;
94 extern void YCatchDrop(long isp); /* used in fnctn.c */
95 extern long ispCatch; /* used in fnctn.c */
96 long ispCatch= 0;
97 extern int y_catch_category;
98 int y_catch_category= 0x08;
99 static Catcher *CatchScan(const char *msg, int category);
100 static Catcher *CatchNew(void);
101 static int caughtTask= 0;
102
103 /* stuff to implement set_idler */
104 extern BuiltIn Y_set_idler;
105 Function *y_idler_function= 0;
106 static int y_idler_fault = 0;
107
108 /*--------------------------------------------------------------------------*/
109
110 Instruction *pc= 0;
111
112 static int ym_state= 0;
113 static int ym_fatal = 0;
114 extern int ym_dbenter;
115 int ym_dbenter = 0;
116 #define Y_QUITTING 1
117 #define Y_RUNNING 2
118 #define Y_SUSPENDED 4
119 #define Y_PENDING 8
120
121 void
YRun(void)122 YRun(void)
123 {
124 register VMaction *Action;
125 int run_state = ym_state & Y_RUNNING;
126 ym_state |= Y_RUNNING;
127 ym_dbenter = 0;
128
129 P_SOFTFPE_TEST;
130
131 while (!p_signalling) {
132 Action = (pc++)->Action;
133 Action();
134 }
135 if (p_signalling==-1 && !(ym_state&Y_RUNNING))
136 p_signalling = 0; /* p_signalling set by YHalt (?? see below) */
137
138 /* reset Y_RUNNING to value on entry -- allows YRun to recurse */
139 ym_state = (ym_state & ~Y_RUNNING) | run_state;
140
141 P_SOFTFPE_TEST;
142
143 if (p_signalling)
144 p_abort(); /* p_signalling set by real signal */
145 }
146
147 extern void ym_escape(void);
148 void
ym_escape(void)149 ym_escape(void)
150 {
151 Y_quit(0);
152 if (p_signalling==-1) p_signalling = 0;
153 p_abort();
154 }
155
156 void
YHalt(void)157 YHalt(void)
158 {
159 ym_state &= ~Y_RUNNING;
160 /* this may not be quite right -- a real signal might go unnoticed --
161 * but may only be possible for SIGINT when machine is halting anyway
162 * -- but if several other tasks queued, behavior might not be right */
163 if (!p_signalling) p_signalling = -1;
164 }
165
166 /* if read() interrupted by uncaught error, have a serious problem */
167 extern char *y_read_prompt;
168 extern Instruction *ym_suspend(void);
169 extern void ym_resume(Instruction *pc);
170
171 static Instruction ym_stopper;
172
173 Instruction *
ym_suspend(void)174 ym_suspend(void)
175 {
176 Instruction *ipc = pc;
177 if (caughtTask || (ym_state&(Y_SUSPENDED|Y_PENDING)))
178 YError("ym_suspend called while suspended or in catch");
179 ym_state |= Y_PENDING;
180 ym_stopper.Action = YHalt;
181 pc = &ym_stopper;
182 return ipc;
183 }
184
185 void
ym_resume(Instruction * ipc)186 ym_resume(Instruction *ipc)
187 {
188 int was_suspended = (ym_state&Y_SUSPENDED);
189 ym_state &= ~(Y_SUSPENDED|Y_PENDING);
190 if (!was_suspended)
191 YError("ym_resume called while not suspended");
192 if (!ipc) YError("(BUG) ym_resume from null pc");
193 pc = ipc;
194 caughtTask = 1;
195 /* protect against following sequence:
196 * (1) task suspends during include file, causing y_on_idle to return 0
197 * this marks idler_eligible==0 in p_on_idle (alarms.c)
198 * (2) event arrives (e.g.- expose) and is handled as a pending event
199 * before calling p_timeout; this event calls ym_resume
200 * (3) p_timeout is called, which should resume execution, but cannot
201 * because idler_eligible has never been reset
202 */
203 p_timeout();
204 }
205
206 /*--------------------------------------------------------------------------*/
207
208 static Function **tasks= 0;
209 static int nTasks= 0;
210 static int maxTasks= 0;
211
ClearTasks(void)212 void ClearTasks(void)
213 {
214 while (nTasks) { nTasks--; Unref(tasks[nTasks]); }
215 if (maxTasks>16) {
216 maxTasks= 0;
217 p_free(tasks);
218 tasks= 0;
219 }
220 }
221
222 void
PushTask(Function * task)223 PushTask(Function *task)
224 {
225 if (p_signalling) p_abort();
226 if (nTasks>=maxTasks) {
227 int newSize = maxTasks+16;
228 tasks = p_realloc(tasks, sizeof(Function *)*newSize);
229 maxTasks = newSize;
230 }
231 tasks[nTasks++] = Ref(task); /* WARNING-- this is the reference for when
232 * DoTask pushes the task onto the stack--
233 * you are still giving your reference to the
234 * Function* away when you call PushTask */
235 }
236
237 /* The task pseudo-code MUST be static, since YError may p_abort out
238 of the DoTask procedure. */
239 static Instruction taskCode[4];
240 static int taskCodeInit= 0;
241
242 static Instruction *ym_suspc = 0;
243 extern int yg_blocking; /* graph.c */
244
DoTask(void)245 int DoTask(void)
246 {
247 extern Operations debugOps;
248 if (caughtTask) {
249 caughtTask= 0;
250 } else if (nTasks>0) {
251 Function *task;
252 if (p_signalling) p_abort();
253 task = tasks[--nTasks];
254
255 CheckStack(1);
256 (sp+1)->ops= &dataBlockSym;
257 (sp+1)->value.db= (DataBlock *)task; /* use owned by stack */
258 sp++;
259
260 pc= taskCode; /* note that original pc is clobbered */
261 }
262 YRun();
263 if (yg_blocking == 4) { /* resume has been called */
264 yg_blocking = 0;
265 if (ym_suspc) {
266 Instruction *suspc = ym_suspc;
267 ym_suspc = 0;
268 ym_resume(suspc);
269 }
270 }
271 if (ym_state & Y_PENDING) {
272 ym_state &= ~Y_PENDING;
273 ym_state |= Y_SUSPENDED;
274 } else if (sp->ops!=&dataBlockSym || sp->value.db->ops!=&debugOps) {
275 /* actually, something is terribly wrong if this is not *main* */
276 Drop(1);
277 }
278 return nTasks;
279 }
280
281 /*--------------------------------------------------------------------------*/
282
283 extern int y_on_idle(void);
284 extern void y_on_exception(int signal, char *errmsg);
285 extern int y_on_quit(void);
286
287 extern void y_cleanup(void);
288
289 extern int nYpInputs; /* from yinput.c */
290 extern int yImpossible;
291 int yImpossible= 0;
292
293 extern int yBatchMode; /* may be set with -batch, see std0.c */
294 int yBatchMode= 0;
295
296 static int y_was_idle= 0;
297
298 /* prompt marker after prompts simplifies writing yorick controllers */
299 static char *prompt_marker = 0;
300 void
Y_prompt_marker(int argc)301 Y_prompt_marker(int argc)
302 {
303 char *marker = (argc==1)? ygets_q(0) : 0;
304 if (argc > 1) y_error("prompt_marker expecting single string argument");
305 if (marker && !marker[0]) marker = 0;
306 if (prompt_marker) {
307 char *old = prompt_marker;
308 prompt_marker = 0;
309 p_free(old);
310 }
311 if (marker)
312 prompt_marker = p_strcpy(marker);
313 }
314
315 static void ym_prompter(void);
316 extern char *y_read_prompt; /* ascio.c */
317 /* yp_did_prompt reset by y_on_stdin */
318 extern int yp_did_prompt;
319 int yp_did_prompt= 0;
320
321 static void
ym_prompter(void)322 ym_prompter(void)
323 {
324 if (!yp_did_prompt) {
325 if (y_read_prompt) {
326 if (y_read_prompt[0]) {
327 p_stdout(y_read_prompt);
328 if (prompt_marker) p_stdout(prompt_marker);
329 yp_did_prompt = 1;
330 }
331 } else {
332 extern void y_do_prompt(void); /* yorick.c */
333 if (!yg_blocking) {
334 y_do_prompt();
335 if (prompt_marker) p_stdout(prompt_marker);
336 yp_did_prompt = 1;
337 }
338 }
339 }
340 }
341
342 void
Y_maybe_prompt(int nargs)343 Y_maybe_prompt(int nargs)
344 {
345 if (nargs) YError("maybe_prompt accepts no arguments");
346 if (!yp_did_prompt && !y_read_prompt) ym_prompter();
347 }
348
349 /* suspend/resume is very primitive - would be nice to permit a
350 * queue of suspended tasks, but needs a bigger interpreted API
351 */
352 void
Y_suspend(int nargs)353 Y_suspend(int nargs)
354 {
355 if (ym_suspc || yg_blocking || y_read_prompt)
356 YError("suspend: already suspended, paused, or waiting for input");
357 ym_suspc = ym_suspend();
358 yg_blocking = 3; /* for y_on_stdin */
359 }
360
361 void
Y_resume(int nargs)362 Y_resume(int nargs)
363 {
364 /* cannot call ym_resume directly, signal DoTask to do that */
365 if (ym_suspc && yg_blocking==3) yg_blocking = 4;
366 }
367
368 static void ym_after(void *context);
369 static void ym_after_dq(int i);
370
371 typedef struct ym_after_t ym_after_t;
372 struct ym_after_t {
373 void *f, *d; /* yget_use function and data handles */
374 long fndx, dndx; /* same as closure object, see oxy.c */
375 int next;
376 };
377 static ym_after_t *ym_after_list = 0;
378 static int ym_after_n = 0; /* length of list, not number active */
379 static int ym_after_i = -1; /* index of first active list item */
380 static int ym_after_j = -1; /* index of first unused list item */
381 static int ym_after_k = -1; /* index of last active list item */
382 #define YM_AFTER_MAX 1024
383
Y__after_func(int argc)384 void Y__after_func(int argc)
385 {
386 extern void FormEvalOp(int nargs, Operand *obj);
387 ym_after_t *ao;
388 long dref;
389 void *p = 0;
390 Operand op;
391 if (ym_after_i<0 || ym_after_i>=ym_after_n)
392 y_error("(BUG?) bad link in _after_func");
393 ao = ym_after_list + ym_after_i;
394 ym_after_i = ao->next;
395 if (ym_after_i == -1) ym_after_k = -1;
396 ao->next = ym_after_j;
397 ym_after_j = ao - ym_after_list;
398 if (argc!=0 || !yarg_subroutine() || yarg_func(0)!=2)
399 y_error("_after_func must only be called by _after_work");
400 yarg_drop(1);
401 ypush_check(3);
402 dref = ao->dndx;
403 p = ao->f;
404 ao->f = 0;
405 if (ao->fndx >= 0) {
406 ypush_global(ao->fndx);
407 if (yarg_func(0)) dref = -1L;
408 } else {
409 ypush_use(p);
410 }
411 p = ao->d;
412 ao->d = 0;
413 if (dref >= -1L) {
414 if (dref < 0) {
415 ypush_use(p);
416 } else { /* object(member,...) semantics */
417 sp[1].ops = &referenceSym;
418 sp[1].index = dref;
419 sp++;
420 }
421 argc = 1;
422 } else {
423 argc = 0;
424 }
425 FormEvalOp(argc, &op);
426 op.ops->Eval(&op);
427 }
428
429 static Function *ym_after_work = 0; /* yget_use handle to _after_work */
430
431 void
Y_after(int argc)432 Y_after(int argc)
433 {
434 long range[3];
435 int flags = yget_range(argc-1, range);
436 double secs = -1.0;
437 long fndx=-1L, dndx=-1L;
438 if (!ym_after_work) { /* this is first call */
439 long w = yfind_global("_after_work", 0);
440 if (w > 0) {
441 ypush_global(w);
442 if (yarg_func(0) == 1) ym_after_work = yget_use(0);
443 yarg_drop(1);
444 }
445 if (!ym_after_work) y_error("(BUG) missing _after_work function");
446 }
447 if (flags==(Y_PSEUDO | Y_MIN_DFLT | Y_MAX_DFLT) && range[2]==1) {
448 if (argc == 1) {
449 ym_after_dq(-1); /* cancel everything, just like error */
450 return;
451 }
452 } else {
453 secs = ygets_d(argc-1);
454 if (secs < 0.0) secs = 0.0;
455 flags = 0; /* if not, previous line raised error */
456 }
457 if (argc!=2 && argc!=3)
458 y_error("after called with illegal number of arguments");
459 flags = yarg_func(argc-2);
460 if (!flags) {
461 yo_ops_t *ops;
462 if (yo_get(argc-2, &ops)) {
463 flags = -1;
464 } else if (yarg_string(argc-2)==1) {
465 char *name = ygets_q(argc-2);
466 if (name[0]=='o' && name[1]==':') name+=2, flags=-1;
467 else flags = -2;
468 fndx = yget_global(name, 0L);
469 } else {
470 y_error("unrecognized second argument to after");
471 }
472 }
473 if (argc == 3) {
474 dndx = yget_ref(0);
475 if (flags>0 || dndx<0) {
476 if (yarg_typeid(0) >= 100)
477 y_error("(BUG?) unrecognized third argument to after");
478 dndx = -1L;
479 }
480 } else {
481 dndx = -2L; /* no data argument */
482 }
483
484 yexec_after(secs, fndx, argc-2, dndx, argc-3);
485 }
486
487 void
yexec_after(double secs,long fndx,int farg,long dndx,int darg)488 yexec_after(double secs, long fndx, int farg, long dndx, int darg)
489 {
490 int i;
491
492 if (secs < 0.0) { /* dequeue anything which matches */
493 /* first check active list */
494 void *f = (fndx>=0)? 0 : yget_use(farg);
495 void *d = (dndx!=-1L)? 0 : yget_use(darg);
496 int j = -1;
497 if (f) ydrop_use(f);
498 if (d) ydrop_use(d);
499 for (i=ym_after_i ; i>=0 ; j=i,i=ym_after_list[i].next) {
500 if (ym_after_list[i].f==f && ym_after_list[i].fndx==fndx) {
501 if (dndx==-2L ||
502 (ym_after_list[i].d==d && ym_after_list[i].dndx==dndx)) {
503 if (j >= 0) ym_after_list[j].next = ym_after_list[i].next;
504 else ym_after_i = ym_after_list[i].next;
505 if (i == ym_after_k) ym_after_k = j;
506 ym_after_dq(i);
507 }
508 }
509 }
510 /* then check any waiting items (no list of these) */
511 for (i=0 ; i<ym_after_n ; i++) {
512 if (ym_after_list[i].next != -2) continue;
513 if (ym_after_list[i].f==f && ym_after_list[i].fndx==fndx) {
514 if (dndx==-2L &&
515 (ym_after_list[i].d==d && ym_after_list[i].dndx==dndx)) {
516 ym_after_dq(i);
517 }
518 }
519 }
520 return;
521 }
522
523 if (ym_after_j < 0) { /* need to lengthen list */
524 int j, k;
525 if (ym_after_n+ym_after_n > YM_AFTER_MAX)
526 y_error("runaway queue of after functions");
527 if (!ym_after_n) {
528 j = 0;
529 k = 4;
530 } else {
531 j = ym_after_n;
532 k = j+j;
533 }
534 ym_after_list = p_realloc(ym_after_list, sizeof(ym_after_t)*k);
535 for (i=j ; i<k ; i++) {
536 ym_after_list[i].f = ym_after_list[i].d = 0;
537 ym_after_list[i].fndx = ym_after_list[i].dndx = -1L;
538 ym_after_list[i].next = (i<k-1)? i+1 : -1;
539 }
540 ym_after_j = j;
541 ym_after_n = k;
542 }
543 i = ym_after_j;
544 ym_after_j = ym_after_list[i].next;
545 ym_after_list[i].next = -2;
546
547 ym_after_list[i].f = (fndx>=0)? 0 : yget_use(farg);
548 ym_after_list[i].fndx = fndx;
549 ym_after_list[i].d = (dndx!=-1L)? 0 : yget_use(darg);
550 ym_after_list[i].dndx = dndx;
551
552 p_set_alarm(secs, ym_after, i+(char*)0);
553 }
554
555 static void
ym_after(void * context)556 ym_after(void *context)
557 {
558 long i = (char *)context - (char*)0;
559 if (i>=0 && i<ym_after_n) {
560 if (ym_after_list[i].next != -2) return; /* cancelled */
561 if (ym_after_k>=0) ym_after_list[ym_after_k].next = i;
562 else ym_after_i = i;
563 ym_after_k = i;
564 ym_after_list[i].next = -1;
565 PushTask(ym_after_work);
566 } else {
567 y_error("(BUG) bad task.c:ym_after call");
568 }
569 }
570
571 static void
ym_after_dq(int i)572 ym_after_dq(int i)
573 {
574 if (i<0) {
575 for (i=ym_after_n-1 ; i>=0 ; i--) ym_after_dq(i);
576 ym_after_i = ym_after_k = -1;
577 } else {
578 void *p = ym_after_list[i].f;
579 if (p) {
580 ym_after_list[i].f = 0;
581 ydrop_use(p);
582 }
583 p = ym_after_list[i].d;
584 if (p) {
585 ym_after_list[i].d = 0;
586 ydrop_use(p);
587 }
588 ym_after_list[i].next = ym_after_j;
589 ym_after_j = i;
590 }
591 }
592
593 static int startup_done = 0;
594
595 int
y_on_idle(void)596 y_on_idle(void)
597 {
598 int more_work = 0;
599 int pending_stdin = 0;
600 int idler_fault = 0;
601
602 if (!taskCodeInit) {
603 taskCode[0].Action = &Eval;
604 taskCode[1].count = 0;
605 taskCode[2].Action = &YHalt;
606 taskCode[3].index = 0;
607 taskCodeInit = 1;
608 }
609
610 p_fpehandling(2); /* be sure yorick FPE handling set properly */
611
612 if (ym_state & Y_QUITTING) {
613 die_now:
614 y_cleanup();
615 p_quit();
616 return 0;
617 }
618 if (!(nTasks+caughtTask)) {
619 extern int y_pending_stdin(void); /* yinput.c */
620 if (nYpIncludes || nYpInputs) {
621 YpParse((void *)0);
622 } else {
623 if (startup_done) {
624 pending_stdin = y_pending_stdin();
625 } else {
626 /* make sure idler gets called once before any stdin
627 * - without this, starting with shell here-document makes
628 * lines passed as here-document execute before custom.i,
629 * not what user expects
630 */
631 if (!y_idler_function) pending_stdin = y_pending_stdin();
632 startup_done = 1;
633 }
634 if (!(nTasks+caughtTask || nYpIncludes || nYpInputs) &&
635 y_idler_function) {
636 Function *f = y_idler_function;
637 y_idler_function = 0;
638 /* this does not really detect when the after_error function
639 * itself has completed - a catch inside after_error can get
640 * complicated and probably defeat this loop detection attempt
641 */
642 idler_fault = y_idler_fault;
643 PushTask(f);
644 Unref(f);
645 }
646 }
647 }
648
649 if (nTasks+caughtTask) DoTask();
650 if (ym_state & Y_QUITTING) goto die_now;
651 if (idler_fault) y_idler_fault = 0;
652 more_work = (nTasks+caughtTask || nYpIncludes || nYpInputs ||
653 pending_stdin || y_idler_function);
654
655 /* non-0 return means we want to run again
656 * -- need to prompt if nothing left to do, but want to check
657 * for more input events before deciding
658 * thus, first time we are out of tasks return non-0 anyway,
659 * but prompt and return 0 second consecutive time we are out */
660 if (more_work)
661 {
662 y_was_idle = 0;
663
664 /* probably incorrect -- any tasks created before the suspend
665 * but not yet run will be blocked
666 * or maybe that's correct behavior? what are the implied
667 * dependencies of one task on another?
668 */
669
670 /* block on window,wait=1 or mouse() from #include file */
671 /* if (yg_blocking) more_work=0; */
672 /* block whenever suspended for any reason from #include file */
673 if (ym_state&Y_SUSPENDED) more_work = 0;
674 /* deliver prompt on read() or rdline() from #include file */
675 if (y_read_prompt) ym_prompter();
676 }
677 else if (y_was_idle)
678 y_was_idle=0, ym_prompter();
679 else
680 y_was_idle = more_work = !yBatchMode;
681 if (!(nTasks+caughtTask)) {
682 extern void yg_before_wait(void);
683 yg_before_wait();
684 }
685 return more_work;
686 }
687
Y_quit(int nArgs)688 void Y_quit(int nArgs)
689 {
690 ym_state|= Y_QUITTING;
691 ResetStack(0);
692 YHalt();
693 }
694
695 static int did_cleanup = 0;
696
697 int
y_on_quit(void)698 y_on_quit(void)
699 {
700 if (!did_cleanup) y_cleanup();
701 return ym_fatal;
702 }
703
704 static volatile int detectRecursion = 0;
705 static IOStream *yclean_file = 0;
706
707 void
y_cleanup(void)708 y_cleanup(void)
709 {
710 if (detectRecursion) {
711 if (detectRecursion < 2) {
712 detectRecursion = 3;
713 RemoveIOLink(yBinaryFiles, yclean_file);
714 } else {
715 yBinaryFiles = 0;
716 }
717 detectRecursion = 0;
718 }
719 /* attempt to close all binary files properly */
720 while (yBinaryFiles) {
721 yclean_file = yBinaryFiles->ios;
722 yclean_file->references = 0;
723 detectRecursion = 1;
724 Unref(yclean_file);
725 detectRecursion = 2;
726 RemoveIOLink(yBinaryFiles, yclean_file);
727 }
728
729 if (CleanUpForExit) CleanUpForExit();
730 did_cleanup = 1;
731 }
732
RunTaskNow(Function * task)733 void RunTaskNow(Function *task)
734 {
735 Instruction *pcHere = pc;
736 int t0 = nTasks;
737 if (ym_state & Y_SUSPENDED)
738 YError("RunTaskNow called while suspended waiting for event");
739 PushTask(Ref(task));
740 while (nTasks>t0 && !(ym_state&(Y_QUITTING|Y_SUSPENDED))) DoTask();
741 if (ym_state & Y_SUSPENDED)
742 YError("(read, pause, wait=1, etc.) suspended during RunTaskNow");
743 pc = pcHere; /* may have been clobbered by DoTask */
744 if (ym_state&Y_QUITTING) YHalt();
745 }
746
IncludeNow(void)747 void IncludeNow(void)
748 {
749 Instruction *pcHere= pc;
750 int i0= nYpIncludes;
751 int t0= nTasks;
752 if (ym_state & Y_SUSPENDED)
753 YError("IncludeNow called while suspended waiting for event");
754 for (;;) {
755 while (nTasks<=t0 && (nYpIncludes>i0 || (nYpIncludes==i0 &&
756 ypIncludes[i0-1].file))) YpParse((void *)0);
757 while (nTasks>t0 && !(ym_state&(Y_QUITTING|Y_SUSPENDED))) DoTask();
758 if ((ym_state&(Y_QUITTING|Y_SUSPENDED)) || nYpIncludes<i0 ||
759 !ypIncludes[i0-1].file) break;
760 }
761 if (ym_state & Y_SUSPENDED)
762 YError("(read, pause, wait=1, etc.) suspended during IncludeNow");
763 pc= pcHere; /* may have been clobbered by DoTask */
764 if (ym_state&Y_QUITTING) YHalt();
765 }
766
767 static char *y_include_arg(p_file **file);
768
769 void
Y_include(int nArgs)770 Y_include(int nArgs)
771 {
772 long now = 0;
773 char *name;
774 p_file *file = 0;
775 if (nArgs!=1 && nArgs!=2)
776 YError("include function takes exactly one or two arguments");
777 if (nArgs > 1) {
778 now = YGetInteger(sp);
779 Drop(1);
780 }
781 name = y_include_arg(&file);
782 if (name[0]) { /* name=="" special hack cleans out pending includes */
783 if (now >= 0) {
784 if (file) {
785 y_push_include(file, name);
786 } else if (!YpPushInclude(name)) {
787 if (!(now&2))
788 YError("missing include file specified in include function");
789 now = 0;
790 }
791 } else {
792 if (file) YError("include: now<0 only possible with filename argument");
793 YpPush(name); /* defer until all pending input parsed */
794 }
795 }
796 Drop(1);
797 if (now>0) IncludeNow(); /* parse and maybe execute file to be included
798 * -- without now, this won't happen until the
799 * next line is parsed naturally */
800 }
801
802 void
yexec_include(int iarg,int now)803 yexec_include(int iarg, int now)
804 {
805 ypush_use(yget_use(iarg));
806 ypush_int(now);
807 Y_include(2);
808 }
809
810 void
ytask_push(int iarg)811 ytask_push(int iarg)
812 {
813 if (iarg>=0 && yarg_func(iarg)==1) {
814 Function *f = (Function *)sp[-iarg].value.db;
815 PushTask(Ref(f));
816 } else {
817 YError("can only run interpreted functions as tasks");
818 }
819 }
820
821 void
ytask_run(int iarg)822 ytask_run(int iarg)
823 {
824 if (iarg>=0 && yarg_func(iarg)==1) {
825 Function *f = (Function *)sp[-iarg].value.db;
826 RunTaskNow(f);
827 } else {
828 YError("can only push interpreted functions onto task stack");
829 }
830 }
831
832 void
Y_include1(int nArgs)833 Y_include1(int nArgs)
834 {
835 int i0 = nYpIncludes;
836 int t0 = nTasks;
837 char *name;
838 p_file *file = 0;
839 if (nArgs != 1) YError("include1 function takes exactly one argument");
840 name = y_include_arg(&file);
841 if (file) y_push_include(file, name);
842 else if (!YpPushInclude(name))
843 YError("missing include file specified in include1 function");
844 Drop(nArgs);
845 if (ym_state & Y_SUSPENDED)
846 YError("include1 called while suspended waiting for event");
847 while (nTasks<=t0 && (nYpIncludes>i0 || (nYpIncludes==i0 &&
848 ypIncludes[i0-1].file))) YpParse((void *)0);
849 if (nTasks == t0+1) {
850 (sp+1)->ops = &dataBlockSym;
851 (sp+1)->value.db = (DataBlock *)tasks[--nTasks]; /* use owned by stack */
852 sp++;
853 } else if (nTasks <= t0) {
854 PushDataBlock(RefNC(&nilDB));
855 } else {
856 YError("include1 created more than one task (impossible?)");
857 }
858 }
859
860 static p_file *ynew_vopen(Array *array, int binary);
861 static char *y_vopen_name = "(vopen file)";
862
863 static char *
y_include_arg(p_file ** file)864 y_include_arg(p_file **file)
865 {
866 Operand op;
867 char *name = y_vopen_name;
868 if (!sp->ops) YError("unexpected keyword argument in include or include1");
869 sp->ops->FormOperand(sp, &op);
870 if (op.ops->typeID == T_STRING) {
871 if (!op.type.dims) {
872 char **q = op.value;
873 if (!q[0]) YError("string(0) filename to include or include1");
874 name = q[0];
875 } else {
876 *file = ynew_vopen((Array *)sp->value.db, 0);
877 name = y_vopen_name;
878 }
879 } else if (op.ops->typeID == T_CHAR) {
880 *file = ynew_vopen((Array *)sp->value.db, 0);
881 name = y_vopen_name;
882 } else if (op.ops == &textOps) {
883 /* first few members of TextStream same as IOStream */
884 name = ((IOStream *)op.value)->fullname;
885 } else {
886 if (op.ops == &streamOps)
887 YError("include or include1 cannot accept binary file handle");
888 YError("include or include1 cannot convert argument to text file handle");
889 }
890 return name;
891 }
892
893 /* ----- begin vopen implementation ----- */
894
895 static unsigned long yv_fsize(p_file *file);
896 static unsigned long yv_ftell(p_file *file);
897 static int yv_fseek(p_file *file, unsigned long addr);
898
899 static char *yv_fgets(p_file *file, char *buf, int buflen);
900 static int yv_fputs(p_file *file, const char *buf);
901 static unsigned long yv_fread(p_file *file,
902 void *buf, unsigned long nbytes);
903 static unsigned long yv_fwrite(p_file *file,
904 const void *buf, unsigned long nbytes);
905
906 static int yv_feof(p_file *file);
907 static int yv_ferror(p_file *file);
908 static int yv_fflush(p_file *file);
909 static int yv_fclose(p_file *file);
910
911 static p_file_ops y_vopen_ops = {
912 &yv_fsize, &yv_ftell, &yv_fseek,
913 &yv_fgets, &yv_fputs, &yv_fread, &yv_fwrite,
914 &yv_feof, &yv_ferror, &yv_fflush, &yv_fclose };
915
916 typedef struct y_vopen_t y_vopen_t;
917 struct y_vopen_t {
918 p_file_ops *ops;
919 Array *array;
920 long addr, maxaddr, offset;
921 int binary;
922 };
923
924 static p_file *
ynew_vopen(Array * array,int binary)925 ynew_vopen(Array *array, int binary)
926 {
927 y_vopen_t *file = p_malloc(sizeof(y_vopen_t));
928 file->ops = &y_vopen_ops;
929 file->array = Ref(array);
930 file->addr = file->offset = 0;
931 file->maxaddr = (binary&2)? 0 : ((y_vopen_t *)file)->array->type.number;
932 file->binary = binary;
933 return (p_file *)file;
934 }
935
936 void *
y_vopen_file(void * stream)937 y_vopen_file(void *stream)
938 {
939 y_vopen_t *file = stream;
940 return (file->ops==&y_vopen_ops)? file->array : 0;
941 }
942
943 void
Y_vopen(int argc)944 Y_vopen(int argc)
945 {
946 Operand op;
947 p_file *file = 0;
948 int binary = 0, wrt = 0;
949 if (argc == 2) {
950 if (!sp[-1].ops) YError("vopen: unexpected keyword argument");
951 binary = (YGetInteger(sp) != 0);
952 Drop(1);
953 } else if (argc != 1) {
954 YError("vopen takes one or two arguments");
955 }
956 sp->ops->FormOperand(sp, &op);
957 if (op.ops->typeID == T_VOID) {
958 Dimension *tmp = tmpDims;
959 tmpDims = 0;
960 FreeDimension(tmp);
961 tmpDims = NewDimension(binary? 16384L : 1024L, 1L, (Dimension *)0);
962 Drop(1);
963 if (binary) PushDataBlock(NewArray(&charStruct, tmpDims));
964 else PushDataBlock(NewArray(&stringStruct, tmpDims));
965 sp->ops->FormOperand(sp, &op);
966 binary |= (wrt = 2);
967 }
968 if (op.ops->typeID!=T_STRING && op.ops->typeID!=T_CHAR)
969 YError("vopen argument must be string or char array");
970 file = ynew_vopen((Array *)sp->value.db, binary);
971 if (binary&1)
972 PushDataBlock(NewIOStream(p_strcpy(y_vopen_name), file, 9|wrt));
973 else
974 PushDataBlock(NewTextStream(p_strcpy(y_vopen_name), file, 1|wrt, 0L, 0L));
975 }
976
977 void
Y_vclose(int argc)978 Y_vclose(int argc)
979 {
980 long index = -1;
981 Operand op;
982 if (argc != 1) YError("vclose takes exactly one argument");
983 if (sp->ops == &referenceSym) index = sp->index;
984 sp->ops->FormOperand(sp, &op);
985 if (op.ops==&textOps || op.ops==&streamOps) {
986 IOStream *ios = op.value; /* first few members match TextStream */
987 y_vopen_t *file = ios->stream;
988 if (file && file->ops==&y_vopen_ops) {
989 long len;
990 len = file->maxaddr;
991 if (!len) {
992 PushDataBlock(RefNC(&nilDB));
993 } else {
994 if (file->binary & 2) {
995 if (file->binary & 1) {
996 if (ios->CloseHook) {
997 ios->CloseHook(ios);
998 ios->CloseHook = 0;
999 len = file->maxaddr;
1000 }
1001 }
1002 if (file->array->type.number > len) {
1003 /* shrink array to elements actually used */
1004 file->array->type.number =
1005 file->array->type.dims->number = len;
1006 if (!(file->binary & 1)) len *= sizeof(char*);
1007 len += (char *)file->array->value.q - (char *)file->array;
1008 file->array = p_realloc(file->array, len);
1009 }
1010 }
1011 PushDataBlock(Ref(file->array));
1012 if ((file->binary & 3) == 3) {
1013 ios->ioOps->Close(ios);
1014 ios->stream = 0;
1015 }
1016 }
1017 if (index >= 0) {
1018 /* set reference argument to nil */
1019 Symbol *s = &globTab[index];
1020 if (s->ops==&dataBlockSym && s->value.db==op.value) {
1021 s->ops = &intScalar;
1022 Unref(s->value.db);
1023 s->value.db = RefNC(&nilDB);
1024 s->ops = &dataBlockSym;
1025 }
1026 }
1027 return;
1028 }
1029 }
1030 YError("vclose: already closed, not vopen handle, or not a file handle");
1031 }
1032
1033 static unsigned long
yv_fsize(p_file * file)1034 yv_fsize(p_file *file)
1035 {
1036 if (((y_vopen_t *)file)->binary & 2) return ((y_vopen_t *)file)->maxaddr;
1037 else return ((y_vopen_t *)file)->array->type.number;
1038 }
1039
1040 static unsigned long
yv_ftell(p_file * file)1041 yv_ftell(p_file *file)
1042 {
1043 return ((y_vopen_t *)file)->addr;
1044 }
1045
1046 static int
yv_fseek(p_file * file,unsigned long addr)1047 yv_fseek(p_file *file, unsigned long addr)
1048 {
1049 long len = ((y_vopen_t *)file)->array->type.number;
1050 if (((y_vopen_t *)file)->binary & 2) {
1051 if (((y_vopen_t *)file)->binary & 1) {
1052 if (addr > len) {
1053 long j, n = 2*((y_vopen_t *)file)->array->type.number;
1054 long nhead = (char *)((y_vopen_t *)file)->array->value.c -
1055 (char *)((y_vopen_t *)file)->array;
1056 while (n < addr) n += n;
1057 ((y_vopen_t *)file)->array = p_realloc(((y_vopen_t *)file)->array,
1058 nhead+n);
1059 for (j=len ; j<n ; j++) ((y_vopen_t *)file)->array->value.c[j] = '\0';
1060 ((y_vopen_t *)file)->array->type.number =
1061 ((y_vopen_t *)file)->array->type.dims->number = n;
1062 }
1063 len = addr;
1064 } else {
1065 len = ((y_vopen_t *)file)->maxaddr;
1066 }
1067 }
1068 if (addr<0 || addr>len) return -1;
1069 ((y_vopen_t *)file)->addr = addr;
1070 ((y_vopen_t *)file)->offset = 0;
1071 if (addr > ((y_vopen_t *)file)->maxaddr)
1072 ((y_vopen_t *)file)->maxaddr = addr;
1073 return 0;
1074 }
1075
1076 static char *
yv_fgets(p_file * file,char * buf,int buflen)1077 yv_fgets(p_file *file, char *buf, int buflen)
1078 {
1079 int strng = (((y_vopen_t *)file)->array->ops->typeID == T_STRING);
1080 char *txt, c='\0';
1081 long jeof;
1082 int i, j;
1083 if (!strng) {
1084 txt = ((y_vopen_t *)file)->array->value.c + ((y_vopen_t *)file)->addr;
1085 jeof = ((y_vopen_t *)file)->array->type.number - ((y_vopen_t *)file)->addr;
1086 } else {
1087 txt = ((y_vopen_t *)file)->array->value.q[((y_vopen_t *)file)->addr];
1088 txt += ((y_vopen_t *)file)->offset;
1089 jeof = 0L;
1090 }
1091 if (buflen <= 0) return 0;
1092 for (i=j=0 ; i<buflen-1 && c!='\n' ; i++,j++) {
1093 if (!strng && j>=jeof) break;
1094 if (!txt || !txt[j]) {
1095 c = '\n';
1096 } else if (txt[j] == '\r') {
1097 if (j<jeof-1 && txt[j+1]=='\n') j++;
1098 c = '\n';
1099 } else {
1100 c = txt[j];
1101 }
1102 buf[i] = c;
1103 }
1104 buf[i] = '\0';
1105 if (!strng) {
1106 ((y_vopen_t *)file)->addr += j;
1107 } else if (i>=buflen-1 && txt && txt[j] && j>0) {
1108 /* handle case where fgets stopped because buflen too short to hold line */
1109 ((y_vopen_t *)file)->offset += j;
1110 } else {
1111 ((y_vopen_t *)file)->addr++;
1112 ((y_vopen_t *)file)->offset = 0;
1113 }
1114 return buf;
1115 }
1116
1117 static int
yv_fputs(p_file * file,const char * buf)1118 yv_fputs(p_file *file, const char *buf)
1119 {
1120 if (!buf) return 0;
1121 if (((y_vopen_t *)file)->binary == 2) {
1122 long n, addr = ((y_vopen_t *)file)->addr;
1123 long len = ((y_vopen_t *)file)->array->type.number;
1124 long nhead = (char *)((y_vopen_t *)file)->array->value.q -
1125 (char *)((y_vopen_t *)file)->array;
1126 char *line;
1127 for (;;) {
1128 if (addr == len) {
1129 n = nhead + (len+len)*sizeof(char*);
1130 ((y_vopen_t *)file)->array = p_realloc(((y_vopen_t *)file)->array, n);
1131 for (n=0 ; n<len ; n++) ((y_vopen_t *)file)->array->value.q[len+n] = 0;
1132 ((y_vopen_t *)file)->array->type.number =
1133 ((y_vopen_t *)file)->array->type.dims->number = len + len;
1134 }
1135 for (n=0 ; buf[n] && buf[n]!='\n' ; n++);
1136 line = ((y_vopen_t *)file)->array->value.q[addr];
1137 if (n) {
1138 ((y_vopen_t *)file)->array->value.q[addr] = p_strncat(line, buf, n);
1139 if (line) p_free(line);
1140 } else if (!line) {
1141 ((y_vopen_t *)file)->array->value.q[addr] = p_strcpy("");
1142 }
1143 if (buf[n] == '\n') addr++, n++;
1144 if (!buf[n]) break;
1145 buf += n;
1146 }
1147 ((y_vopen_t *)file)->addr = addr;
1148 if (addr > ((y_vopen_t *)file)->maxaddr)
1149 ((y_vopen_t *)file)->maxaddr = addr;
1150 } else {
1151 YError("p_fputs to binary or read-only vopen file handle");
1152 }
1153 return 0;
1154 }
1155
1156 static unsigned long
yv_fread(p_file * file,void * buf,unsigned long nbytes)1157 yv_fread(p_file *file, void *buf, unsigned long nbytes)
1158 {
1159 int strng = (((y_vopen_t *)file)->array->ops->typeID == T_STRING);
1160 char *cbuf=buf, *txt=0;
1161 unsigned long j, jeof=0;
1162 if (!strng) {
1163 txt = ((y_vopen_t *)file)->array->value.c + ((y_vopen_t *)file)->addr;
1164 jeof = ((y_vopen_t *)file)->array->type.number - ((y_vopen_t *)file)->addr;
1165 } else {
1166 YError("p_fread from text vopen file handle");
1167 }
1168 if (!nbytes) return 0L;
1169 for (j=0 ; j<nbytes ; j++) {
1170 if (!strng && j>=jeof) break;
1171 cbuf[j] = txt[j];
1172 if (strng && !txt[j]) break;
1173 }
1174 if (!strng) ((y_vopen_t *)file)->addr += j;
1175 else ((y_vopen_t *)file)->addr++;
1176 return j;
1177 }
1178
1179 static unsigned long
yv_fwrite(p_file * file,const void * buf,unsigned long nbytes)1180 yv_fwrite(p_file *file, const void *buf, unsigned long nbytes)
1181 {
1182 if (((y_vopen_t *)file)->binary == 3) {
1183 long len = ((y_vopen_t *)file)->array->type.number;
1184 long i = ((y_vopen_t *)file)->addr;
1185 if (i+nbytes > len) {
1186 /* double array size if at eof */
1187 long j, n = len + len;
1188 long nhead = (char *)((y_vopen_t *)file)->array->value.c -
1189 (char *)((y_vopen_t *)file)->array;
1190 while (n < i+nbytes) n += n;
1191 ((y_vopen_t *)file)->array = p_realloc(((y_vopen_t *)file)->array,
1192 nhead + n);
1193 for (j=len ; j<n ; j++) ((y_vopen_t *)file)->array->value.c[j] = '\0';
1194 ((y_vopen_t *)file)->array->type.number =
1195 ((y_vopen_t *)file)->array->type.dims->number = n;
1196 }
1197 if (nbytes) memcpy(((y_vopen_t *)file)->array->value.c+i, buf, nbytes);
1198 ((y_vopen_t *)file)->addr = (i += nbytes);
1199 if (i > ((y_vopen_t *)file)->maxaddr) ((y_vopen_t *)file)->maxaddr = i;
1200 } else {
1201 YError("p_fwrite to text or read-only vopen file handle");
1202 }
1203 return nbytes;
1204 }
1205
1206 static int
yv_feof(p_file * file)1207 yv_feof(p_file *file)
1208 {
1209 return (((y_vopen_t *)file)->addr
1210 >= ((y_vopen_t *)file)->array->type.number);
1211 }
1212
yv_ferror(p_file * file)1213 static int yv_ferror(p_file *file) { return 0; }
yv_fflush(p_file * file)1214 static int yv_fflush(p_file *file) { return 0; }
1215
1216 static int
yv_fclose(p_file * file)1217 yv_fclose(p_file *file)
1218 {
1219 Array *array = ((y_vopen_t *)file)->array;
1220 ((y_vopen_t *)file)->array = 0;
1221 Unref(array);
1222 p_free(file);
1223 return 0;
1224 }
1225
1226 /* ----- end vopen implementation ----- */
1227
1228 static char **yplug_path = 0;
1229
1230 void
Y_plug_dir(int nArgs)1231 Y_plug_dir(int nArgs)
1232 {
1233 Dimension *dims = 0;
1234 char **d = (nArgs==1)? YGet_Q(sp, 1, &dims) : 0;
1235 long nd = d? TotalNumber(dims) : 0;
1236 int i;
1237 if (nArgs > 1)
1238 YError("plug_dir function takes at most one argument");
1239 if (nArgs && !CalledAsSubroutine()) {
1240 for (i=0 ; yplug_path && yplug_path[i] ; i++);
1241 if (i > 1) {
1242 int n = i - 1;
1243 Array *rslt;
1244 Dimension *tmp = tmpDims;
1245 tmpDims = 0;
1246 FreeDimension(tmp);
1247 tmpDims = NewDimension((long)n, 1L, (Dimension *)0);
1248 rslt = (Array *)PushDataBlock(NewArray(&stringStruct, tmpDims));
1249 for (i=0 ; i<n ; i++)
1250 rslt->value.q[i] = p_strcpy(yplug_path[i]);
1251 } else {
1252 PushDataBlock(RefNC(&nilDB));
1253 }
1254 if (!nd) return;
1255 }
1256 if (yplug_path) {
1257 for (i=0 ; yplug_path[i] ; i++) {
1258 p_free(yplug_path[i]);
1259 yplug_path[i] = 0;
1260 }
1261 p_free(yplug_path);
1262 yplug_path = 0;
1263 }
1264 yplug_path = p_malloc(sizeof(char *)*(nd+2));
1265 for (i=0 ; i<=nd ; i++) {
1266 if (i < nd) {
1267 yplug_path[i] = YExpandName(d[i]);
1268 YNameToHead(&yplug_path[i]);
1269 } else {
1270 yplug_path[i] = p_strncat(yHomeDir, "lib/", 0L);
1271 }
1272 }
1273 yplug_path[nd+1] = 0;
1274 }
1275
1276 struct y_package_t {
1277 char *name;
1278 y_pkg_t *init;
1279 char **ifiles;
1280 BuiltIn **code;
1281 void **data;
1282 char **varname;
1283 };
1284 static struct y_package_t *y_pkg_list = 0;
1285 static int y_npkg = 0;
1286 static int y_n0pkg = 0;
1287
1288 char *
y_pkg_name(int i)1289 y_pkg_name(int i)
1290 {
1291 return (i<0 || i>=y_npkg || !y_pkg_list)? 0 : y_pkg_list[i].name;
1292 }
1293
1294 int
y_pkg_count(int i)1295 y_pkg_count(int i)
1296 {
1297 return i? y_npkg : y_n0pkg;
1298 }
1299
1300 y_pkg_t *
y_pkg_lookup(char * name)1301 y_pkg_lookup(char *name)
1302 {
1303 int i;
1304 for (i=0 ; i<y_npkg ; i++)
1305 if (!strcmp(y_pkg_list[i].name, name))
1306 return y_pkg_list[i].init;
1307 return 0;
1308 }
1309
1310 void
y_pkg_add(y_pkg_t * init)1311 y_pkg_add(y_pkg_t *init)
1312 {
1313 char **ifiles, **varname;
1314 BuiltIn **code;
1315 void **data;
1316 char *pkgname = init(&ifiles, &code, &data, &varname);
1317 if (!y_pkg_list)
1318 y_pkg_list = p_malloc(sizeof(struct y_package_t)*8);
1319 else if (!(y_npkg & 7))
1320 y_pkg_list = p_realloc(y_pkg_list, sizeof(struct y_package_t)*(y_npkg+8));
1321 y_pkg_list[y_npkg].name = pkgname;
1322 y_pkg_list[y_npkg].init = init;
1323 y_pkg_list[y_npkg].ifiles = ifiles;
1324 y_pkg_list[y_npkg].code = code;
1325 y_pkg_list[y_npkg].data = data;
1326 y_pkg_list[y_npkg].varname = varname;
1327 y_npkg++;
1328 }
1329
1330 static void y_pkg_0link(char **varname, BuiltIn **code, void **data);
1331
1332 void
y_pkg_link(char * name)1333 y_pkg_link(char *name)
1334 {
1335 /* use name==0 to relink every package */
1336 int i;
1337 if (!y_n0pkg) y_n0pkg = y_npkg;
1338 for (i=0 ; i<y_npkg ; i++) {
1339 if (!name || !strcmp(y_pkg_list[i].name, name)) {
1340 y_pkg_0link(y_pkg_list[i].varname,
1341 y_pkg_list[i].code, y_pkg_list[i].data);
1342 if (name) break;
1343 }
1344 }
1345 }
1346
1347 static void
y_pkg_0link(char ** varname,BuiltIn ** code,void ** data)1348 y_pkg_0link(char **varname, BuiltIn **code, void **data)
1349 {
1350 long index;
1351 DataBlock *db;
1352
1353 /* initialize built-in functions */
1354 if (code) while (*code) {
1355 index = Globalize(*varname++, 0L);
1356 db = globTab[index].ops==&dataBlockSym? globTab[index].value.db : 0;
1357 if (!db || db->ops!=&builtinOps ||
1358 ((BIFunction *)db)->function!=*code) {
1359 globTab[index].value.db = (DataBlock *)NewBIFunction(*code, index);
1360 globTab[index].ops = &dataBlockSym;
1361 Unref(db);
1362 }
1363 code++;
1364 }
1365
1366 /* initialize compiled variables */
1367 if (data) while (*data) {
1368 index = Globalize(*varname++, 0L);
1369 db = globTab[index].ops==&dataBlockSym? globTab[index].value.db : 0;
1370 if (!db || db->ops!=&lvalueOps || ((LValue *)db)->type.base->file ||
1371 ((LValue *)db)->owner || ((LValue *)db)->address.m!=*data) {
1372 /* note: everything starts out as a scalar char at the correct address
1373 * - subsequent reshape will set true data type and dimensions
1374 */
1375 globTab[index].value.db =
1376 (DataBlock *)NewLValueM((Array *)0, *data++,
1377 &charStruct, (Dimension *)0);
1378 globTab[index].ops = &dataBlockSym;
1379 }
1380 Unref(db);
1381 }
1382 }
1383
1384 void
y_pkg_include(char * name,int now)1385 y_pkg_include(char *name, int now)
1386 {
1387 char **ifiles, *msg;
1388 int i;
1389 /* use name==0 to relink every package */
1390 if (now) {
1391 for (i=0 ; i<y_npkg ; i++) {
1392 if (!name || !strcmp(y_pkg_list[i].name, name)) {
1393 ifiles = y_pkg_list[i].ifiles;
1394 if (ifiles) while (ifiles[0]) {
1395 if (YpPushInclude(*ifiles++)) {
1396 IncludeNow();
1397 } else {
1398 msg= p_strncat("missing include file ", ifiles[-1], 0);
1399 YWarning(msg);
1400 p_free(msg);
1401 }
1402 }
1403 if (name) break;
1404 }
1405 }
1406 } else {
1407 /* when not immediate (e.g.- at startup) push in reverse order */
1408 for (i=y_npkg-1 ; i>=0 ; i--) {
1409 if (!name || !strcmp(y_pkg_list[i].name, name)) {
1410 ifiles = y_pkg_list[i].ifiles;
1411 if (ifiles) {
1412 while (ifiles[0]) ifiles++;
1413 for (ifiles-- ; ifiles>=y_pkg_list[i].ifiles ; ifiles--)
1414 YpPush(ifiles[0]);
1415 }
1416 if (name) break;
1417 }
1418 }
1419 }
1420 }
1421
1422 void
Y_plug_in(int nArgs)1423 Y_plug_in(int nArgs)
1424 {
1425 char *pname, *pkgname;
1426 y_pkg_t *init = 0;
1427 void *plug;
1428 int i;
1429 if (nArgs!=1) YError("plug_in function takes exactly one argument");
1430 pkgname = YGetString(sp-nArgs+1);
1431 if (!pkgname || !pkgname[0])
1432 YError("plug_in: package name argument is null");
1433 for (i=1 ; pkgname[i] ; i++);
1434 for (pname=pkgname+i-1 ; pname>pkgname ; pname--)
1435 if (pname[0]=='/' || pname[0]=='\\') break;
1436
1437 /* become a no-op if pkgname already plugged in */
1438 if (y_pkg_lookup(pname)) return;
1439
1440 if (!yplug_path) Y_plug_dir(0);
1441
1442 plug = p_dlopen(pkgname);
1443 if (!plug && !YIsAbsolute(pkgname)) {
1444 /* check in plug_dir and Y_HOME/lib before giving up */
1445 char *tmp;
1446 for (i=0 ; yplug_path[i] ; i++) {
1447 tmp = p_strncat(yplug_path[i], pkgname, 0L);
1448 plug = p_dlopen(tmp);
1449 p_free(tmp);
1450 if (plug) break;
1451 }
1452 }
1453 if (plug) {
1454 char *tmp = p_strncat("yk_", pname, 0);
1455 int failed = p_dlsym(plug, tmp, 0, &init);
1456 p_free(tmp);
1457 if (failed || !init)
1458 YError("plug_in: dynamic library missing yk_<pkgname> function");
1459 }
1460 if (init) {
1461 y_pkg_add(init);
1462 y_pkg_link(pname);
1463 } else {
1464 YError("plug_in: unable to find dynamic library file");
1465 }
1466 }
1467
Y_require(int nArgs)1468 void Y_require(int nArgs)
1469 {
1470 char *full, *name, *tail= 0;
1471 long i;
1472 if (nArgs!=1) YError("require function takes exactly one argument");
1473 full= YGetString(sp);
1474 name= YNameTail(full);
1475 for (i=0 ; i<sourceTab.nItems ; i++) {
1476 tail= YNameTail(sourceTab.names[i]);
1477 if (name && tail && strcmp(tail, name)==0) break;
1478 p_free(tail);
1479 tail= 0;
1480 }
1481 p_free(name);
1482 p_free(tail);
1483 if (i>=sourceTab.nItems && !YpPushInclude(full))
1484 YError("missing include file specified in require function");
1485 Drop(nArgs);
1486 if (i>=sourceTab.nItems)
1487 IncludeNow(); /* parse and maybe execute file to be included */
1488 }
1489
Y_current_include(int argc)1490 void Y_current_include(int argc)
1491 {
1492 if (argc != 1 || YNotNil(sp))
1493 y_error("current_include takes exactly one nil argument");
1494 if (nYpIncludes > 0 && ypIncludes[nYpIncludes-1].filename != NULL) {
1495 *ypush_q(NULL) = p_strcpy(ypIncludes[nYpIncludes-1].filename);
1496 } else {
1497 ypush_nil();
1498 }
1499 }
1500
Y_get_includes(int argc)1501 void Y_get_includes(int argc)
1502 {
1503 if (argc != 1 || YNotNil(sp))
1504 YError("get_includes takes exactly one nil argument");
1505 if (sourceTab.nItems > 0) {
1506 long i, n;
1507 long dims[2];
1508 char **s;
1509 dims[0] = 1L;
1510 dims[1] = (n = sourceTab.nItems);
1511 s = ypush_q(dims);
1512 for (i = 0; i < n; ++i) {
1513 s[i] = p_strcpy(sourceTab.names[i]);
1514 }
1515 } else {
1516 ypush_nil();
1517 }
1518 }
1519
1520 /*--------------------------------------------------------------------------*/
1521
1522 static int findingFunc= 0;
1523 /* error handling hacks (for mpy) set up with set_idler
1524 * bit
1525 * 1 do not print error messages (like .SYNC.)
1526 * 2 include [pc] after func name in error messages
1527 * 4 call after_error in dbug mode (rather than full stack reset)
1528 * - after_error responsible for calling dbexit
1529 * 8 reserved for use by y_errhook
1530 */
1531 PLUG_API int yerror_flags;
1532 int yerror_flags = 0;
1533
FuncContaining(Instruction * pc)1534 Function *FuncContaining(Instruction *pc)
1535 {
1536 Function *func= 0;
1537
1538 if (!findingFunc && pc) {
1539 long i = -1;
1540 if (pc>=taskCode && pc<=taskCode+4) return 0;
1541 findingFunc = 1;
1542 for (;; i++) {
1543 while (pc[i].Action) i++;
1544 if (pc[i-1].Action==&Return) break;
1545 }
1546 i++;
1547 /* Now pc[i] is the Instruction generated by following line
1548 in parse.c (YpFunc):
1549 vmCode[nextPC].index= codeSize= nPos+nKey+nLocal+ nextPC;
1550 (nextPC does NOT include the parameters or locals)
1551 */
1552 i -= pc[i].index;
1553 if (i<0) {
1554 /* see also Pointee function in ydata.c */
1555 func = (Function *)((char *)(pc+i) - offsetof(Function, code));
1556 findingFunc = 0;
1557 }
1558 }
1559
1560 if (findingFunc) {
1561 /* may get here after a disaster causing an interrupt above, as well
1562 as after scanning from a garbled initial pc */
1563 int no_pf = ((yerror_flags&1) != 0);
1564 findingFunc = 0;
1565 if (!no_pf) YputsErr("(BUG) lost function produced following error:");
1566 }
1567 return func;
1568 }
1569
1570 /*--------------------------------------------------------------------------*/
1571
ResetStack(int hard)1572 void ResetStack(int hard)
1573 {
1574 Instruction *pcRet;
1575 while ((pcRet= AbortReturn())) if (pcRet==&taskCode[2] && !hard) break;
1576 }
1577
1578 /*--------------------------------------------------------------------------*/
1579
1580 static int y_do_not_abort = 0;
1581
1582 void
y_on_exception(int signal,char * errmsg)1583 y_on_exception(int signal, char *errmsg)
1584 {
1585 /* signal==PSIG_SOFT for call to p_abort, otherwise this is real signal */
1586 if (signal != PSIG_SOFT) {
1587 y_do_not_abort = 1;
1588 if (signal==PSIG_INT)
1589 {
1590 y_catch_category= 0x04;
1591 YError("Keyboard interrupt received (SIGINT)");
1592 }
1593 else if (signal==PSIG_FPE)
1594 {
1595 y_catch_category= 0x01;
1596 YError("Floating point interrupt (SIGFPE)");
1597 }
1598 else if (signal==PSIG_SEGV)
1599 YError("Segmentation violation interrupt (SIGSEGV)");
1600 else if (signal==PSIG_ILL)
1601 YError("Illegal instruction interrupt (SIGILL)");
1602 else if (signal==PSIG_BUS)
1603 YError("Misaligned address interrupt (SIGBUS)");
1604 else if (signal==PSIG_IO)
1605 YError((errmsg&&errmsg[0])? errmsg : "I/O interrupt (SIGIO)");
1606 else
1607 YError((errmsg&&errmsg[0])? errmsg :
1608 "Unrecognized signal delivered to y_on_exception");
1609 }
1610 if (ym_state&Y_QUITTING) {
1611 y_cleanup();
1612 p_quit();
1613 }
1614 }
1615
YWarning(const char * msg)1616 void YWarning(const char *msg)
1617 {
1618 strcpy(yWarningMsg, "WARNING ");
1619 strncat(yWarningMsg, msg, 120);
1620 YputsErr(yWarningMsg);
1621 }
1622
1623 static char *includeFile= 0;
1624 static long mainIndex= -1;
1625 Instruction *yErrorPC= 0; /* for dbup function in debug.c */
1626
1627 static void yset_catchmsg(char *tmsg);
1628 static long after_index = -1;
1629
1630 PLUG_API int (*y_errhook)(const char *msg, long *after);
1631 int (*y_errhook)(const char *msg, long *after) = 0;
1632
1633 void
YError(const char * msg)1634 YError(const char *msg)
1635 {
1636 extern void yg_got_expose(void);
1637 long beginLine= ypBeginLine;
1638 Instruction *pcDebug= pc;
1639 Function *func;
1640 char *name;
1641 DebugBlk *dbg;
1642 Instruction *pcUp=yErrorPC, *pcue;
1643 int category;
1644 int no_abort = y_do_not_abort;
1645 int no_print = 0, no_pf = ((yerror_flags&1) != 0);
1646 int no_reset = ((yerror_flags&4) != 0);
1647
1648 int recursing= inYError;
1649 inYError++;
1650 yErrorPC= 0;
1651 y_do_not_abort = 0;
1652
1653 category= y_catch_category;
1654 y_catch_category= 0x08;
1655
1656 ym_state &= ~Y_PENDING;
1657 ym_dbenter = 0;
1658
1659 if (recursing>8 || yImpossible>8) {
1660 if (!no_pf) YputsErr("****FATAL**** YError looping -- quitting now");
1661 ym_state|= Y_QUITTING;
1662 ym_fatal = 3;
1663 if (!no_abort) p_abort();
1664 return;
1665 }
1666 yImpossible++; /* zeroed only by GetNextLine and after CatchScan */
1667
1668 if (!caughtTask && CatchScan(msg, category)) {
1669 /* resume at catch PC if this error has been caught --
1670 * is this really proof against catastrophic looping? */
1671 inYError= 0;
1672 yImpossible= 0;
1673 caughtTask= 1;
1674 if (!no_abort) p_abort();
1675 return;
1676 } else if (caughtTask) {
1677 caughtTask= 0;
1678 if (!no_pf) YputsErr("****OOPS**** error on read resume or throw/catch");
1679 }
1680
1681 if (y_idler_function) {
1682 /* remove any idler on error - after_error can reset if desired */
1683 Function *f= y_idler_function;
1684 y_idler_function= 0;
1685 Unref(f);
1686 }
1687 if (after_index < 0) after_index = yget_global("after_error", 0L);
1688 if (!y_idler_fault
1689 && globTab[after_index].ops == &dataBlockSym
1690 && globTab[after_index].value.db->ops == &functionOps) {
1691 /* if after_error function present, make it the idler */
1692 y_idler_function = (Function *)Ref(globTab[after_index].value.db);
1693 y_idler_fault = 1;
1694 } else {
1695 y_idler_fault = 0;
1696 }
1697
1698 /* this is a nasty hack for mpy and after_error */
1699 no_print = no_pf || (msg && !strcmp(msg, ".SYNC."));
1700
1701 for (;;) {
1702 func = (((ym_state&Y_RUNNING)||no_abort) && !recursing &&
1703 pcUp!=&taskCode[2])? FuncContaining(pcDebug) : 0;
1704 if (!func || !func->errup) break;
1705 ClearStack();
1706 pcue = AbortReturn();
1707 if (!pcue || pcue==&taskCode[2]) break;
1708 pcDebug = pc = pcue;
1709 func = 0;
1710 }
1711 name = func? globalTable.names[func->code[0].index] : "VM idle or lost";
1712
1713 /* Clear out include stack, but remember current include file name.
1714 If the error happened while executing a main program which came from
1715 the include file, then includeFile will be the filename, and
1716 ypBeginLine will be the line number at which the errant main
1717 program began. (No other line number information will be available
1718 for a main program?) */
1719 if (!recursing) {
1720 char *tmp= includeFile;
1721 includeFile= 0;
1722 p_free(tmp);
1723 if (nYpIncludes)
1724 includeFile= p_strcpy(ypIncludes[nYpIncludes-1].filename);
1725 }
1726 YpClearIncludes();
1727
1728 /* Clean up any Array temporaries (used for data format conversions). */
1729 if (recursing<2) ClearTmpArray();
1730
1731 /* Clear out any pending keyboard input or tasks. */
1732 if (recursing<3) {
1733 p_qclear();
1734 ClearTasks();
1735 } else if (nTasks) {
1736 if (!no_pf) YputsErr("WARNING unable to free task pointers in YError");
1737 nTasks = 0;
1738 }
1739
1740 /* Print error message, with name of current Yorick function prepended:
1741 ERROR (yorick_function) msg passed to YError
1742 ERROR (VM idle or lost) msg passed to YError
1743 The second form is used when the virtual machine is idle at the
1744 time of the error. */
1745 if (!pcUp || recursing)
1746 strcpy(yErrorMsg, "ERROR (");
1747 else
1748 strcpy(yErrorMsg, "Up to (");
1749 strncat(yErrorMsg, name, 40);
1750 if (func && (yerror_flags&2)!=0) {
1751 char relpc[32];
1752 sprintf(relpc, "[%ld]", (long)(pcDebug-func->code));
1753 strncat(yErrorMsg, relpc, 12);
1754 }
1755 strcat(yErrorMsg, ") ");
1756 if (!pcUp || recursing)
1757 strncat(yErrorMsg, msg, 140);
1758 if (y_errhook) {
1759 long index;
1760 int hook = y_errhook(yErrorMsg, &index);
1761 if (no_print != no_pf) no_pf = (hook & 1);
1762 else no_print = no_pf = (hook & 1);
1763 if ((hook & 2)
1764 && globTab[index].ops == &dataBlockSym
1765 && globTab[index].value.db->ops == &functionOps) {
1766 /* if alternate after_error function present, make it the idler */
1767 y_idler_function = (Function *)Ref(globTab[index].value.db);
1768 no_reset = ((hook & 4) != 0);
1769 }
1770 }
1771 if (!no_print) YputsErr(yErrorMsg);
1772
1773 if (recursing) {
1774 func= 0;
1775 if (!no_print) YputsErr("WARNING aborting on recursive calls to YError");
1776 } else if (ym_state&Y_SUSPENDED) {
1777 func= 0;
1778 if (y_read_prompt) {
1779 if (!no_print) YputsErr("WARNING aborting on YError"
1780 " during keyboard read()");
1781 } else if (ym_suspc) {
1782 if (!no_print) YputsErr("WARNING aborting on YError during suspend");
1783 } else {
1784 if (!no_print) YputsErr("WARNING aborting on YError"
1785 " after mouse() pause() or wait=1");
1786 }
1787 }
1788 ym_suspc = 0;
1789 if (yg_blocking==3 || yg_blocking==4) yg_blocking = 0;
1790
1791 if (func && !no_print) {
1792 /* Try to find the source code for this function. */
1793 long index= func->code[0].index;
1794 if (mainIndex<0) mainIndex= Globalize("*main*", 0L);
1795 if (index==mainIndex) {
1796 name= includeFile;
1797 } else {
1798 char *mess= YpReparse(func);
1799 if (nTasks) ClearTasks();
1800 if (mess[0]!='*') {
1801 /* reparse succeeded, skip to filename */
1802 name= 0;
1803 while (mess[0] && mess[0]!=':') mess++;
1804 if (mess[0]) do { mess++; } while (mess[0] && mess[0]!=':');
1805 if (mess[0]) {
1806 mess++;
1807 if (mess[0]==' ') mess++;
1808 if (mess[0]) name= mess;
1809 }
1810 } else {
1811 /* reparse failed */
1812 name= 0;
1813 }
1814 beginLine= 0; /* used only for *main* from includeFile */
1815 }
1816
1817 /* Push debug info (function and code index) onto stack. */
1818 ClearStack();
1819 CheckStack(2);
1820 dbg= NewDebugBlk(func, pcDebug-func->code, name, beginLine);
1821 if (dbg) {
1822 PushDataBlock(dbg);
1823 } else {
1824 ResetStack(0);
1825 YputsErr("Function corrupted, cannot enter debug mode.");
1826 }
1827
1828 if (y_idler_function) {
1829 /* special after_error function will get control */
1830 if (no_reset && yDebugLevel<=2 && !y_read_prompt) {
1831 if (yDebugLevel>1) ResetStack(0);
1832 } else {
1833 ResetStack(1);
1834 yr_reset();
1835 }
1836 yg_got_expose();
1837 } else if (!yBatchMode && !pcUp && (!yAutoDebug || yDebugLevel>1)) {
1838 if (yDebugLevel>1) {
1839 YputsErr(" To enter recursive debug level, type <RETURN> now");
1840 } else {
1841 YputsErr(" To enter debug mode, type <RETURN> now"
1842 " (then dbexit to get out)");
1843 }
1844 ym_dbenter = 1;
1845 }
1846
1847 } else {
1848 /* Clear the stack back to the most recent debugging level,
1849 * or completely clear if aborting a read() operation. */
1850 if (recursing<5) {
1851 ResetStack(y_read_prompt!=0);
1852 } else {
1853 if (!no_pf) YputsErr("****SEVERE**** YError unable to reset stack -- "
1854 "probably lost variables");
1855 sp= spBottom;
1856 }
1857 ym_state &= ~Y_SUSPENDED;
1858 if (y_read_prompt) yr_reset();
1859 yg_got_expose(); /* in case window,wait=1 or pause */
1860 }
1861 p_clr_alarm(0, 0);
1862 ym_after_dq(-1);
1863
1864 if (ym_state&Y_QUITTING) {
1865 if (!no_pf)
1866 YputsErr("****TERMINATING**** on error after main loop exit");
1867 if (!no_abort) p_abort();
1868 return;
1869 }
1870
1871 if ((yBatchMode && !y_idler_function) || !strncmp(msg,"(FATAL)",7)) {
1872 if (!no_pf) {
1873 if (yBatchMode) YputsErr("yorick: quitting on error in batch mode");
1874 else YputsErr("yorick: quitting on fatal error");
1875 }
1876 ym_fatal = yBatchMode? 1 : 2;
1877 ResetStack(0);
1878 ym_state|= Y_QUITTING;
1879 }
1880
1881 /* set catch_message variable for after_error function */
1882 if (y_idler_function) yset_catchmsg(yErrorMsg);
1883
1884 /* Go back to the main loop. */
1885 inYError= 0;
1886 if (!no_abort) p_abort();
1887 }
1888
1889 /*--------------------------------------------------------------------------*/
1890
1891 static Function *help_worker= 0;
1892
Y_help(int nArgs)1893 void Y_help(int nArgs)
1894 {
1895 Symbol *stack= sp-nArgs+1;
1896 long index, worker_arg, isrc=-1;
1897 int nAbove;
1898 p_file *file;
1899
1900 worker_arg= Globalize("help_topic", 0L);
1901
1902 while (stack<=sp && !stack->ops) stack+=2; /* skip any keywords */
1903 nAbove= sp-stack;
1904 if (nAbove>=0) {
1905 /* a legal argument has been supplied */
1906 if (stack->ops==&referenceSym) {
1907 index= stack->index;
1908 ReplaceRef(stack);
1909 } else {
1910 index= -1;
1911 }
1912 if (stack->ops==&dataBlockSym) {
1913 DataBlock *db= stack->value.db;
1914 Operations *ops= db->ops;
1915 if (ops==&functionOps) {
1916 Function *f= (Function *)db;
1917 index= f->code[0].index;
1918 isrc = f->isrc;
1919 } else if (ops==&structDefOps) {
1920 StructDef *base= (StructDef *)db;
1921 while (base->model) base= base->model;
1922 index= Globalize(yStructTable.names[base->index], 0L);
1923 } else if (ops==&builtinOps) {
1924 BIFunction *f= (BIFunction *)db;
1925 index= f->index;
1926 }
1927 }
1928 Drop(nAbove);
1929 nArgs-= nAbove+1;
1930 } else {
1931 /* no legal arguments, help function itself is target */
1932 BIFunction *f= (BIFunction *)(sp-nArgs)->value.db;
1933 index= f->index;
1934 PushDataBlock(RefNC(&nilDB));
1935 }
1936
1937 /* move help topic argument off stack into help_topic extern variable */
1938 PopTo(&globTab[worker_arg]); /* help_topic */
1939 Drop(nArgs); /* only argument of any conceivable value just saved */
1940
1941 if (!help_worker) {
1942 long help_index= Globalize("help_worker", 0L);
1943 if (globTab[help_index].ops!=&dataBlockSym ||
1944 (help_worker= (Function *)Ref(globTab[help_index].value.db))->ops
1945 !=&functionOps)
1946 YError("(BUG) help_worker function not found -- help unavailable");
1947 }
1948
1949 /* create help_file extern variable */
1950 if (index>=0 && (file= OpenSource(index, isrc)))
1951 PushDataBlock(NewTextStream(p_strcpy(ypIncludes[nYpIncludes-1].filename),
1952 file, 1, ypBeginLine-1, p_ftell(file)));
1953 else
1954 PushDataBlock(RefNC(&nilDB));
1955 worker_arg= Globalize("help_file", 0L);
1956 PopTo(&globTab[worker_arg]); /* help_file */
1957
1958 RunTaskNow(help_worker);
1959 }
1960
1961 /*--------------------------------------------------------------------------*/
1962
Y_exit(int nArgs)1963 void Y_exit(int nArgs)
1964 {
1965 char *msg= 0;
1966 if (nArgs>1) YError("exit takes exactly zero or one argument");
1967 if (nArgs==1 && YNotNil(sp)) msg= YGetString(sp);
1968 if (msg) YputsOut(msg);
1969 else YputsOut("EXIT called, back to main loop");
1970 ResetStack(0);
1971 p_abort();
1972 }
1973
Y_error(int nArgs)1974 void Y_error(int nArgs)
1975 {
1976 char *msg= 0;
1977 if (nArgs>1) YError("error takes exactly zero or one argument");
1978 if (nArgs==1 && YNotNil(sp)) msg= YGetString(sp);
1979 y_catch_category= 0x10;
1980 if (msg) YError(msg);
1981 else YError("<interpreted error function called>");
1982 }
1983
1984 /* FIXME: this should also turn off on_stdin event handling */
Y_batch(int nArgs)1985 void Y_batch(int nArgs)
1986 {
1987 int flag= 2;
1988 if (nArgs>1) YError("batch takes exactly zero or one argument");
1989 if (nArgs==1 && YNotNil(sp)) {
1990 flag= (YGetInteger(sp)!=0);
1991 Drop(1);
1992 }
1993 PushIntValue(yBatchMode);
1994 if (flag!=2) yBatchMode= flag;
1995 }
1996
1997 /*--------------------------------------------------------------------------*/
1998
CatchNew(void)1999 static Catcher *CatchNew(void)
2000 {
2001 if (n_catchers>=max_catchers) {
2002 catchers= p_realloc(catchers, (max_catchers+16)*sizeof(Catcher));
2003 max_catchers+= 16;
2004 }
2005 catchers[n_catchers].task= 0;
2006 catchers[n_catchers].pc= 0;
2007 catchers[n_catchers].isp= 0;
2008 catchers[n_catchers].category= 0;
2009 return &catchers[n_catchers++];
2010 }
2011
YCatchDrop(long isp)2012 void YCatchDrop(long isp)
2013 {
2014 while (n_catchers>0 && catchers[n_catchers-1].isp>=isp) {
2015 n_catchers--;
2016 catchers[n_catchers].category= 0;
2017 }
2018
2019 if (n_catchers>0) ispCatch= catchers[n_catchers-1].isp;
2020 else ispCatch= 0;
2021
2022 if ((max_catchers>>6) > n_catchers) {
2023 /* attempt to limit damage from runaway catch calls */
2024 catchers= p_realloc(catchers, (max_catchers>>6)*sizeof(Catcher));
2025 max_catchers>>= 6;
2026 }
2027 }
2028
CatchScan(const char * msg,int category)2029 static Catcher *CatchScan(const char *msg, int category)
2030 {
2031 long i= n_catchers-1;
2032 while (i>=0 && !(category&catchers[i].category)) {
2033 if (catchers[i].task != &taskCode[2]) i= 0;
2034 i--;
2035 }
2036
2037 if (i>=0) {
2038 char tmsg[144];
2039 Instruction *pcRet;
2040 Symbol *spCatch= spBottom + catchers[i].isp;
2041 catchers[i].category= 0; /* disable this catcher */
2042
2043 /* note: msg itself might be on stack! */
2044 strncpy(tmsg, msg, 140);
2045 tmsg[140]= '\0';
2046
2047 for (;;) {
2048 ClearStack();
2049 if (spCatch >= sp) break;
2050 pcRet= AbortReturn();
2051 if (!pcRet || pcRet==&taskCode[2])
2052 YError("catch does not work outside immediate include or require");
2053 }
2054 if (spCatch!=sp) YError("(BUG) impossible catch or corrupt stack");
2055 pc= catchers[i].pc;
2056 PushIntValue(1);
2057
2058 /* set catch_message variable (after stack cleared) */
2059 yset_catchmsg(tmsg);
2060
2061 return &catchers[i];
2062
2063 } else {
2064 return 0;
2065 }
2066 }
2067
2068 static void
yset_catchmsg(char * tmsg)2069 yset_catchmsg(char *tmsg)
2070 {
2071 Array *array;
2072 long cmsg = Globalize("catch_message", 0L);
2073 if (globTab[cmsg].ops==&dataBlockSym) {
2074 globTab[cmsg].ops = &intScalar;
2075 Unref(globTab[cmsg].value.db);
2076 }
2077 array= NewArray(&stringStruct, (Dimension *)0);
2078 globTab[cmsg].value.db = (DataBlock *)array;
2079 globTab[cmsg].ops = &dataBlockSym;
2080 array->value.q[0] = p_strcpy(tmsg);
2081 }
2082
2083 extern VMaction BranchFalse, BranchTrue;
2084
Y_catch(int nArgs)2085 void Y_catch(int nArgs)
2086 {
2087 Catcher *catcher= 0;
2088 long i= n_catchers-1;
2089 long isp= (sp-2) - spBottom;
2090 int category;
2091 if (nArgs!=1) YError("catch takes exactly one argument");
2092 category= YGetInteger(sp);
2093 if ((sp-2)->ops != &returnSym ||
2094 (pc->Action!=&BranchFalse && pc->Action!=&BranchTrue))
2095 YError("catch() must be the condition in an if or while statement");
2096
2097 while (i>=0 && catchers[i].task==&taskCode[2] && catchers[i].isp==isp) {
2098 if (catchers[i].pc==pc) {
2099 catcher= &catchers[i];
2100 break;
2101 }
2102 i--;
2103 }
2104 if (!catcher) catcher= CatchNew();
2105 catcher->task= &taskCode[2];
2106 catcher->pc= pc;
2107 catcher->isp= ispCatch= isp;
2108 catcher->category= category;
2109
2110 PushIntValue(0);
2111 }
2112
2113 /*--------------------------------------------------------------------------*/
2114
Y_set_idler(int nArgs)2115 void Y_set_idler(int nArgs)
2116 {
2117 Function *f;
2118 if (nArgs>1) {
2119 /* second argument is hack to add error handling features */
2120 if (nArgs==2 && sp[-1].ops) yerror_flags = YGetInteger(sp);
2121 else YError("set_idler function takes zero or one arguments");
2122 }
2123
2124 if (nArgs>0 && YNotNil(sp-nArgs+1)) {
2125 f = (Function *)sp[1-nArgs].value.db;
2126 if (sp[1-nArgs].ops!=&dataBlockSym || f->ops!=&functionOps)
2127 YError("set_idler expecting function as argument");
2128 y_idler_function = Ref(f);
2129
2130 } else if (y_idler_function) {
2131 f = y_idler_function;
2132 y_idler_function = 0;
2133 Unref(f);
2134 }
2135 }
2136
2137 /*--------------------------------------------------------------------------*/
2138