1 /*
2 Copyright (c) 1991-1999 Thomas T. Wetmore IV
3
4 Permission is hereby granted, free of charge, to any person
5 obtaining a copy of this software and associated documentation
6 files (the "Software"), to deal in the Software without
7 restriction, including without limitation the rights to use, copy,
8 modify, merge, publish, distribute, sublicense, and/or sell copies
9 of the Software, and to permit persons to whom the Software is
10 furnished to do so, subject to the following conditions:
11
12 The above copyright notice and this permission notice shall be
13 included in all copies or substantial portions of the Software.
14
15 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
19 BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
20 ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
21 CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
22 SOFTWARE.
23 */
24 /* modified 05 Jan 2000 by Paul B. McBride (pmcbride@tiac.net) */
25 /*=============================================================
26 * interp.c -- Interpret program statements
27 * Copyright(c) 1991-95 by T.T. Wetmore IV; all rights reserved
28 * 2.3.4 - 24 Jun 93 2.3.5 - 16 Aug 93
29 * 3.0.0 - 26 Jul 94 3.0.2 - 25 Mar 95
30 * 3.0.3 - 22 Sep 95
31 *===========================================================*/
32
33 #include <time.h>
34 #include "llstdlib.h"
35 #include "table.h"
36 #include "translat.h"
37 #include "gedcom.h"
38 #include "cache.h"
39 #include "interpi.h"
40 #include "indiseq.h"
41 #include "rptui.h"
42 #include "feedback.h"
43 #include "arch.h"
44 #include "lloptions.h"
45 #include "parse.h"
46 #include "zstr.h"
47 #include "icvt.h"
48 #include "date.h"
49 #include "xlat.h"
50
51 #ifndef INCLUDED_STDARG_H
52 #include <stdarg.h>
53 #define INCLUDED_STDARG_H
54 #endif
55
56 /*********************************************
57 * global/exported variables
58 *********************************************/
59
60 /*
61 TODO: Move most of these into parseinfo structure
62 Perry 2002.07.14
63 One problem -- finishrassa closes foutfp, so it may need longer lifetime
64 that parseinfo currently has
65 */
66 TABLE gproctab=0, gfunctab=0;
67 SYMTAB globtab = NULL;
68 PATHINFO cur_pathinfo = 0; /* program currently being parsed or run */
69 FILE *Poutfp = NULL; /* file to write program output to */
70 STRING Poutstr = NULL; /* string to write program output to */
71 INT Perrors = 0;
72 LIST Plist = NULL; /* list of program files still to read */
73 PNODE Pnode = NULL; /* node being interpreted */
74 BOOLEAN explicitvars = FALSE; /* all vars must be declared */
75 BOOLEAN rpt_cancelled = FALSE;
76
77 /*********************************************
78 * external/imported variables
79 *********************************************/
80
81 extern INT progerror;
82 extern BOOLEAN progrunning, progparsing;
83 extern STRING qSwhatrpt;
84 extern STRING qSunsupuniv;
85
86 /*********************************************
87 * local function prototypes
88 *********************************************/
89
90 static STRING check_rpt_requires(PACTX pactx, STRING fname);
91 static void clean_orphaned_rptlocks(void);
92 static void delete_pathinfo(PATHINFO * pathinfo);
93 static void enqueue_parse_error(const char * fmt, ...);
94 static BOOLEAN find_program(CNSTRING fname, STRING localdir, STRING *pfull,BOOLEAN include);
95 static void init_pactx(PACTX pactx);
96 static BOOLEAN interpret_prog(PNODE begin, SYMTAB stab);
97 static PATHINFO new_pathinfo(CNSTRING fname, STRING fullpath);
98 static void parse_file(PACTX pactx, STRING fname, STRING fullpath);
99 static void print_report_duration(INT duration, INT uiduration);
100 static void progmessage(MSG_LEVEL level, STRING);
101 static void remove_tables(PACTX pactx);
102 static void wipe_pactx(PACTX pactx);
103
104 /*********************************************
105 * local variables
106 *********************************************/
107
108 static LIST outstanding_parse_errors = 0;
109
110 /*********************************************
111 * local function definitions
112 * body of module
113 *********************************************/
114
115
116 /*====================================+
117 * initinterp -- Initialize interpreter
118 *===================================*/
119 void
initinterp(void)120 initinterp (void)
121 {
122 initrassa();
123 Perrors = 0;
124 rpt_cancelled = FALSE;
125 explicitvars = FALSE;
126 }
127 /*==================================+
128 * finishinterp -- Finish interpreter
129 *=================================*/
130 void
finishinterp(void)131 finishinterp (void)
132 {
133 finishrassa();
134
135 /* clean up any orphaned report locks on records */
136 clean_orphaned_rptlocks();
137
138 if (progerror) {
139 refresh_stdout();
140 /* we used to sleep for 5 seconds here */
141 }
142
143 }
144 /*================================================================+
145 * progmessage -- Display a status message about the report program
146 * level: [IN] error, info, status (use enum MSG_LEVEL)
147 * msg: [IN] string to display (progname is added if there is room)
148 *===============================================================*/
149 static void
progmessage(MSG_LEVEL level,STRING msg)150 progmessage (MSG_LEVEL level, STRING msg)
151 {
152 char buf[120];
153 char *ptr=buf;
154 INT mylen=sizeof(buf);
155 INT maxwidth = msg_width();
156 INT msglen = strlen(msg);
157 if (maxwidth >= 0 && maxwidth < mylen)
158 mylen = maxwidth;
159 if (cur_pathinfo && *cur_pathinfo->fullpath && msglen+20 < maxwidth) {
160 INT len = 99999;
161 if (msg_width() >= 0) {
162 len = sizeof(buf)-3-msglen;
163 }
164 llstrcatn(&ptr, msg, &mylen);
165 llstrcatn(&ptr, " [", &mylen);
166 llstrcatn(&ptr, compress_path(cur_pathinfo->fullpath, len), &mylen);
167 llstrcatn(&ptr, "] ", &mylen);
168 } else {
169 llstrcatn(&ptr, msg, &mylen);
170 }
171 msg_output(level, buf);
172 }
173 /*=============================================+
174 * new_pathinfo -- Return new, filled-out pathinfo object
175 * all memory is newly heap-allocated
176 *============================================*/
177 static PATHINFO
new_pathinfo(CNSTRING fname,STRING fullpath)178 new_pathinfo (CNSTRING fname, STRING fullpath)
179 {
180 PATHINFO pathinfo = (PATHINFO)stdalloc(sizeof(*pathinfo));
181 memset(pathinfo, 0, sizeof(*pathinfo));
182 pathinfo->fname = strdup(fname);
183 pathinfo->fullpath = strdup(fullpath);
184 return pathinfo;
185 }
186 /*=============================================+
187 * delete_pathinfo -- Free memory inside pathinfo
188 *============================================*/
189 static void
delete_pathinfo(PATHINFO * pathinfo)190 delete_pathinfo (PATHINFO * pathinfo)
191 {
192 if (pathinfo && *pathinfo) {
193 strfree(&(*pathinfo)->fname);
194 strfree(&(*pathinfo)->fullpath);
195 stdfree(*pathinfo);
196 *pathinfo = 0;
197 }
198 }
199 /*=============================================+
200 * interp_program_list -- Interpret LifeLines program
201 * proc: [IN] proc to call
202 * nargs: [IN] number of arguments
203 * args: [IN] arguments
204 * ifiles: [IN] program files
205 * ofile: [IN] output file - can be NULL
206 * picklist: [IN] show user list of existing reports ?
207 * returns 0 if it didn't actually run (eg, not found, or no report picked)
208 *============================================*/
209 static INT
interp_program_list(STRING proc,INT nargs,VPTR * args,LIST lifiles,STRING ofile,BOOLEAN picklist)210 interp_program_list (STRING proc, INT nargs, VPTR *args, LIST lifiles
211 , STRING ofile, BOOLEAN picklist)
212 {
213 LIST plist=0, donelist=0;
214 SYMTAB stab = NULL;
215 INT i;
216 INT nfiles = length_list(lifiles);
217 PNODE first, parm;
218 struct tag_pactx pact;
219 PACTX pactx = &pact;
220 STRING rootfilepath=0;
221 INT ranit=0;
222
223 init_pactx(pactx);
224
225 pvalues_begin();
226
227 /* Get the initial list of program files */
228 plist = create_list();
229 /* list of pathinfos finished */
230 donelist = create_list();
231
232 if (nfiles > 0) {
233 for (i = 1; i < nfiles+1; i++) {
234 STRING fullpath = 0;
235 STRING progfile = get_list_element(lifiles, i, NULL);
236 if (find_program(progfile, 0, &fullpath,FALSE)) {
237 PATHINFO pathinfo = new_pathinfo(progfile, fullpath);
238 strfree(&fullpath);
239 enqueue_list(plist, pathinfo);
240 if (i==1)
241 strupdate(&rootfilepath, pathinfo->fullpath);
242 } else {
243 enqueue_parse_error(_("Report not found: %s "), progfile);
244 }
245 }
246 } else {
247 PATHINFO pathinfo = 0;
248 STRING fname=0, fullpath=0;
249 STRING programsdir = getlloptstr("LLPROGRAMS", ".");
250 if (!rptui_ask_for_program(LLREADTEXT, _(qSwhatrpt), &fname, &fullpath
251 , programsdir, ".ll", picklist)) {
252 if (fname) {
253 /* tried & failed to open report program */
254 llwprintf(_("Error: file <%s> not found"), fname);
255 }
256 strfree(&fname);
257 strfree(&fullpath);
258 goto interp_program_notfound;
259 }
260 pathinfo = new_pathinfo(fname, fullpath);
261 strfree(&fname);
262 strfree(&fullpath);
263
264 strupdate(&rootfilepath, pathinfo->fullpath);
265 enqueue_list(plist, pathinfo);
266 }
267
268 progparsing = TRUE;
269
270 /* Parse each file in the list -- don't reparse any file */
271 /* (paths are resolved before files are enqueued, & stored in pathinfo) */
272
273 gproctab = create_table_obj();
274 globtab = create_symtab_global();
275 gfunctab = create_table_obj();
276 initinterp();
277
278 while (!is_empty_list(plist)) {
279 cur_pathinfo = (PATHINFO) dequeue_list(plist);
280 if (!in_table(pactx->filetab, cur_pathinfo->fullpath)) {
281 STRING str;
282 insert_table_obj(pactx->filetab, cur_pathinfo->fullpath, 0);
283 Plist = plist;
284 parse_file(pactx, cur_pathinfo->fname, cur_pathinfo->fullpath);
285 if ((str = check_rpt_requires(pactx, cur_pathinfo->fullpath)) != 0) {
286 progmessage(MSG_ERROR, str);
287 goto interp_program_exit;
288 }
289 enqueue_list(donelist, cur_pathinfo);
290 } else {
291 /* skip references to files we've already parsed */
292 delete_pathinfo(&cur_pathinfo);
293 }
294 cur_pathinfo = 0;
295 }
296 destroy_list(plist);
297 plist=NULL;
298
299
300 if (outstanding_parse_errors) {
301 STRING str;
302 FORLIST(outstanding_parse_errors, el)
303 str = (STRING)el;
304 prog_error(NULL, str);
305 ++Perrors;
306 ENDLIST
307 destroy_list(outstanding_parse_errors);
308 outstanding_parse_errors=0;
309 }
310
311 if (Perrors) {
312 progmessage(MSG_ERROR, _("Program contains errors.\n"));
313 goto interp_program_exit;
314 }
315
316 /* Find top procedure */
317
318 if (!(first = (PNODE) valueof_ptr(get_rptinfo(rootfilepath)->proctab, proc))) {
319 progmessage(MSG_ERROR, _("Program needs a starting procedure.\n"));
320 goto interp_program_exit;
321 }
322
323 /* Open output file if name is provided */
324
325 if (ofile) {
326 if (!start_output_file(ofile)) {
327 goto interp_program_exit;
328 }
329 }
330 if (Poutfp) setbuf(Poutfp, NULL);
331
332 /* Link arguments to parameters in symbol table */
333
334 parm = ipdefn_args(first);
335 if (nargs != num_params(parm)) {
336 msg_error(_("Proc %s must be called with %d (not %d) parameters."),
337 proc, num_params(parm), nargs);
338 goto interp_program_exit;
339 }
340 stab = create_symtab_proc(proc, NULL);
341 for (i = 0; i < nargs; i++) {
342 insert_symtab(stab, iident_name(parm), args[0]);
343 parm = inext(parm);
344 }
345
346 /* Interpret top procedure */
347 ranit = 1;
348 progparsing = FALSE;
349 progrunning = TRUE;
350 progerror = 0;
351 progmessage(MSG_STATUS, _("Program is running..."));
352 ranit = interpret_prog((PNODE) ibody(first), stab);
353
354 /* Clean up and return */
355
356 progrunning = FALSE;
357 finishinterp(); /* includes 5 sec delay if errors on-screen */
358 if (Poutfp) fclose(Poutfp);
359 Poutfp = NULL;
360
361 interp_program_exit:
362
363 remove_tables(pactx);
364 if (stab) {
365 remove_symtab(stab);
366 stab = NULL;
367 }
368
369 interp_program_notfound:
370
371 symbol_tables_end();
372 pvalues_end();
373 wipe_pactx(pactx);
374 xl_free_adhoc_xlats();
375
376 /* kill any orphaned pathinfos */
377 while (!is_empty_list(plist)) {
378 PATHINFO pathinfo = (PATHINFO)dequeue_list(plist);
379 delete_pathinfo(&pathinfo);
380 }
381 /* Assumption -- pactx->fullpath stays live longer than all pnodes */
382 while (!is_empty_list(donelist)) {
383 PATHINFO pathinfo = (PATHINFO)dequeue_list(donelist);
384 delete_pathinfo(&pathinfo);
385 }
386 strfree(&rootfilepath);
387 destroy_list(donelist);
388 destroy_list(plist);
389 return ranit;
390 }
391 /*===============================================
392 * interpret_prog -- execute a report program
393 *=============================================*/
394 static BOOLEAN
interpret_prog(PNODE begin,SYMTAB stab)395 interpret_prog (PNODE begin, SYMTAB stab)
396 {
397 PVALUE dummy=0;
398 INT rtn = interpret(begin, stab, &dummy);
399
400 delete_pvalue(dummy);
401 dummy=0;
402
403 switch(rtn) {
404 case INTOKAY:
405 case INTRETURN:
406 progmessage(MSG_INFO, _("Program was run successfully.\n"));
407 return TRUE;
408 default:
409 if (rpt_cancelled) {
410 progmessage(MSG_STATUS, _("Program was cancelled.\n"));
411 } else
412 progmessage(MSG_STATUS, _("Program was not run because of errors.\n"));
413 return FALSE;
414 }
415 }
416 /*===============================================
417 * init_pactx -- initialize global parsing context
418 *=============================================*/
419 static void
init_pactx(PACTX pactx)420 init_pactx (PACTX pactx)
421 {
422 memset(pactx, 0, sizeof(*pactx));
423 pactx->filetab = create_table_obj(); /* table of tables */
424 }
425 /*===============================================
426 * wipe_pactx -- destroy global parsing context
427 *=============================================*/
428 static void
wipe_pactx(PACTX pactx)429 wipe_pactx (PACTX pactx)
430 {
431 destroy_table(pactx->filetab);
432 pactx->filetab=NULL;
433 memset(pactx, 0, sizeof(*pactx));
434 }
435 /*===========================================+
436 * remove_tables -- Remove interpreter's tables
437 *==========================================*/
438 static void
remove_tables(PACTX pactx)439 remove_tables (PACTX pactx)
440 {
441 pactx=pactx; /* unused */
442 destroy_table(gproctab);
443 gproctab=NULL;
444 remove_symtab(globtab);
445 globtab = NULL;
446 destroy_table(gfunctab);
447 gfunctab=NULL;
448 }
449 /*======================================+
450 * find_program -- search for program file
451 * fname: [IN] filename desired
452 * pfull: [OUT] full path found (stdalloc'd)
453 * Returns TRUE if found
454 *=====================================*/
455 static BOOLEAN
find_program(CNSTRING fname,STRING localdir,STRING * pfull,BOOLEAN include)456 find_program (CNSTRING fname, STRING localdir, STRING *pfull,BOOLEAN include)
457 {
458 STRING programsdir = getlloptstr("LLPROGRAMS", ".");
459 FILE * fp = 0;
460 ZSTR zstr=zs_new();
461 BOOLEAN rtn=FALSE;
462 if (!fname || *fname == 0) goto end_find_program;
463 /* prefer local dir, so prefix path with localdir */
464 if (localdir && localdir[0]) {
465 zs_sets(zstr, localdir);
466 zs_apps(zstr, LLSTRPATHSEPARATOR);
467 }
468 zs_apps(zstr, programsdir);
469 if (include) {
470 fp = fopenpath(fname, LLREADTEXT, zs_str(zstr), ".li", uu8, pfull);
471 if (fp) {
472 fclose(fp);
473 rtn = TRUE;
474 goto end_find_program;
475 }
476 }
477 fp = fopenpath(fname, LLREADTEXT, zs_str(zstr), ".ll", uu8, pfull);
478 if (fp) {
479 fclose(fp);
480 rtn = TRUE;
481 }
482
483 end_find_program:
484 zs_free(&zstr);
485 return rtn;
486 }
487 /*======================================+
488 * parse_file -- Parse single program file
489 * pactx: [I/O] pointer to global parsing context
490 * ifile: [IN] file to parse
491 * Parse file (yyparse may wind up adding entries to plist, via include statements)
492 *=====================================*/
493 static void
parse_file(PACTX pactx,STRING fname,STRING fullpath)494 parse_file (PACTX pactx, STRING fname, STRING fullpath)
495 {
496 STRING unistr=0;
497
498 ASSERT(!pactx->Pinfp);
499 if (!fullpath || !fullpath[0]) return;
500 pactx->Pinfp = fopen(fullpath, LLREADTEXT);
501 if (!pactx->Pinfp) {
502 llwprintf(_("Error: file <%s> not found: %s\n"), fname, fullpath);
503 Perrors++;
504 return;
505 }
506
507 if ((unistr=check_file_for_unicode(pactx->Pinfp)) && !eqstr(unistr, "UTF-8")) {
508 msg_error(_(qSunsupuniv), unistr);
509 Perrors++;
510 return;
511 }
512
513 /* Assumption -- pactx->fullpath stays live longer than all pnodes */
514 pactx->ifile = fname;
515 pactx->fullpath = fullpath;
516 pactx->lineno = 0;
517 pactx->charpos = 0;
518
519 yyparse(pactx);
520
521 closefp(&pactx->Pinfp);
522 pactx->ifile = 0;
523 pactx->fullpath = 0;
524 pactx->lineno = 0;
525 pactx->charpos = 0;
526 }
527 /*====================================+
528 * report_duration -- print report duration
529 *===================================*/
530 static void
print_report_duration(INT duration,INT uiduration)531 print_report_duration (INT duration, INT uiduration)
532 {
533 ZSTR zt1=approx_time(duration-uiduration), zt2=approx_time(uiduration);
534 llwprintf(_("\nReport duration %s (ui duration %s)\n")
535 , zs_str(zt1), zs_str(zt2));
536 zs_free(&zt1);
537 zs_free(&zt2);
538 }
539 /*====================================+
540 * interp_main -- Interpreter main proc
541 * picklist: [IN]
542 * ifiles: [IN] program files
543 * ofile: [IN] output file - can be NULL
544 * picklist: [IN] show user list of existing reports ?
545 * timing: [IN] show report elapsed time info ?
546 *===================================*/
547 void
interp_main(LIST lifiles,STRING ofile,BOOLEAN picklist,BOOLEAN timing)548 interp_main (LIST lifiles, STRING ofile, BOOLEAN picklist, BOOLEAN timing)
549 {
550 time_t begin = time(NULL);
551 int elapsed, uitime;
552 int ranit=0;
553 /* whilst still in uilocale, check if we need to reload report strings
554 (in case first time or uilocale changed) */
555 interp_load_lang();
556 prog_trace = FALSE; /* clear report debug flag */
557 init_debugger();
558 rptui_init(); /* clear ui time counter */
559
560 rptlocale();
561 ranit = interp_program_list("main", 0, NULL, lifiles, ofile, picklist);
562 uilocale();
563 elapsed = time(NULL) - begin;
564 uitime = rptui_elapsed();
565
566 if (ranit && timing)
567 print_report_duration(elapsed, uitime);
568
569 /*
570 TO DO: unlock all cache elements (2001/03/17, Perry)
571 in case any were left locked by report
572 */
573 }
574 /*======================================
575 * interpret -- Interpret statement list
576 * PNODE node: first node to interpret
577 * TABLE stab: current symbol table
578 * PVALUE *pval: possible return value
579 *====================================*/
580 INTERPTYPE
interpret(PNODE node,SYMTAB stab,PVALUE * pval)581 interpret (PNODE node, SYMTAB stab, PVALUE *pval)
582 {
583 STRING str;
584 BOOLEAN eflg = FALSE;
585 INTERPTYPE irc;
586 PVALUE val;
587
588 *pval = NULL;
589
590 while (node) {
591 Pnode = node;
592 if (prog_trace) {
593 trace_out("d%d: ", iline(node)+1);
594 trace_pnode(node);
595 trace_endl();
596 }
597 switch (itype(node)) {
598 case ISCONS:
599 poutput(pvalue_to_string(node->vars.iscons.value), &eflg);
600 if (eflg)
601 goto interp_fail;
602 break;
603 case IIDENT:
604 val = eval_and_coerce(PSTRING, node, stab, &eflg);
605 if (eflg) {
606 prog_error(node, _("identifier: %s should be a string\n"),
607 iident_name(node));
608 goto interp_fail;
609 }
610 str = pvalue_to_string(val);
611 if (str) {
612 poutput(str, &eflg);
613 if (eflg) {
614 goto interp_fail;
615 }
616 }
617 delete_pvalue(val);
618 break;
619 case IBCALL:
620 val = evaluate_func(node, stab, &eflg);
621 if (eflg) {
622 goto interp_fail;
623 }
624 if (!val) break;
625 if (which_pvalue_type(val) == PSTRING) {
626 str = pvalue_to_string(val);
627 if (str) {
628 poutput(str, &eflg);
629 if (eflg)
630 goto interp_fail;
631 }
632 }
633 delete_pvalue(val);
634 break;
635 case IFCALL:
636 val = evaluate_ufunc(node, stab, &eflg);
637 if (eflg) {
638 goto interp_fail;
639 }
640 if (!val) break;
641 if (which_pvalue_type(val) == PSTRING) {
642 str = pvalue_to_string(val);
643 if (str) {
644 poutput(str, &eflg);
645 if (eflg)
646 goto interp_fail;
647 }
648 }
649 delete_pvalue(val);
650 break;
651 case IPDEFN:
652 FATAL();
653 case ICHILDREN:
654 switch (irc = interp_children(node, stab, pval)) {
655 case INTOKAY:
656 case INTBREAK:
657 break;
658 case INTERROR:
659 goto interp_fail;
660 default:
661 return irc;
662 }
663 break;
664 case IFAMILYSPOUSES:
665 switch (irc = interp_familyspouses(node, stab, pval)) {
666 case INTOKAY:
667 case INTBREAK:
668 break;
669 case INTERROR:
670 goto interp_fail;
671 default:
672 return irc;
673 }
674 break;
675 case ISPOUSES:
676 switch (irc = interp_spouses(node, stab, pval)) {
677 case INTOKAY:
678 case INTBREAK:
679 break;
680 case INTERROR:
681 goto interp_fail;
682 default:
683 return irc;
684 }
685 break;
686 case IFAMILIES:
687 switch (irc = interp_families(node, stab, pval)) {
688 case INTOKAY:
689 case INTBREAK:
690 break;
691 case INTERROR:
692 goto interp_fail;
693 default:
694 return irc;
695 }
696 break;
697 case IFATHS:
698 switch (irc = interp_fathers(node, stab, pval)) {
699 case INTOKAY:
700 case INTBREAK:
701 break;
702 case INTERROR:
703 goto interp_fail;
704 default:
705 return irc;
706 }
707 break;
708 case IMOTHS:
709 switch (irc = interp_mothers(node, stab, pval)) {
710 case INTOKAY:
711 case INTBREAK:
712 break;
713 case INTERROR:
714 goto interp_fail;
715 default:
716 return irc;
717 }
718 break;
719 case IFAMCS:
720 switch (irc = interp_parents(node, stab, pval)) {
721 case INTOKAY:
722 case INTBREAK:
723 break;
724 case INTERROR:
725 goto interp_fail;
726 default:
727 return irc;
728 }
729 break;
730 case ISET:
731 switch (irc = interp_indisetloop(node, stab, pval)) {
732 case INTOKAY:
733 case INTBREAK:
734 break;
735 case INTERROR:
736 goto interp_fail;
737 default:
738 return irc;
739 }
740 break;
741 case IINDI:
742 switch (irc = interp_forindi(node, stab, pval)) {
743 case INTOKAY:
744 case INTBREAK:
745 break;
746 case INTERROR:
747 goto interp_fail;
748 default:
749 return irc;
750 }
751 break;
752 case IFAM:
753 switch (irc = interp_forfam(node, stab, pval)) {
754 case INTOKAY:
755 case INTBREAK:
756 break;
757 case INTERROR:
758 goto interp_fail;
759 default:
760 return irc;
761 }
762 break;
763 case ISOUR:
764 switch (irc = interp_forsour(node, stab, pval)) {
765 case INTOKAY:
766 case INTBREAK:
767 break;
768 case INTERROR:
769 goto interp_fail;
770 default:
771 return irc;
772 }
773 break;
774 case IEVEN:
775 switch (irc = interp_foreven(node, stab, pval)) {
776 case INTOKAY:
777 case INTBREAK:
778 break;
779 case INTERROR:
780 goto interp_fail;
781 default:
782 return irc;
783 }
784 break;
785 case IOTHR:
786 switch (irc = interp_forothr(node, stab, pval)) {
787 case INTOKAY:
788 case INTBREAK:
789 break;
790 case INTERROR:
791 goto interp_fail;
792 default:
793 return irc;
794 }
795 break;
796 case ILIST:
797 switch (irc = interp_forlist(node, stab, pval)) {
798 case INTOKAY:
799 case INTBREAK:
800 break;
801 case INTERROR:
802 goto interp_fail;
803 default:
804 return irc;
805 }
806 break;
807 case INOTES:
808 switch (irc = interp_fornotes(node, stab, pval)) {
809 case INTOKAY:
810 case INTBREAK:
811 break;
812 case INTERROR:
813 goto interp_fail;
814 default:
815 return irc;
816 }
817 break;
818 case INODES:
819 switch (irc = interp_fornodes(node, stab, pval)) {
820 case INTOKAY:
821 case INTBREAK:
822 break;
823 case INTERROR:
824 goto interp_fail;
825 default:
826 return irc;
827 }
828 break;
829 case ITRAV:
830 switch (irc = interp_traverse(node, stab, pval)) {
831 case INTOKAY:
832 case INTBREAK:
833 break;
834 case INTERROR:
835 goto interp_fail;
836 default:
837 return irc;
838 }
839 break;
840 case IIF:
841 switch (irc = interp_if(node, stab, pval)) {
842 case INTOKAY:
843 break;
844 case INTERROR:
845 goto interp_fail;
846 default:
847 return irc;
848 }
849 break;
850 case IWHILE:
851 switch (irc = interp_while(node, stab, pval)) {
852 case INTOKAY:
853 case INTBREAK:
854 break;
855 case INTERROR:
856 goto interp_fail;
857 default:
858 return irc;
859 }
860 break;
861 case IPCALL:
862 switch (irc = interp_call(node, stab, pval)) {
863 case INTOKAY:
864 break;
865 case INTERROR:
866 goto interp_fail;
867 default:
868 return irc;
869 }
870 break;
871 case IBREAK:
872 return INTBREAK;
873 case ICONTINUE:
874 return INTCONTINUE;
875 case IRETURN:
876 if (iargs(node))
877 *pval = evaluate(iargs(node), stab, &eflg);
878 if (eflg && getlloptint("FullReportCallStack", 0) > 0)
879 prog_error(node, "in return statement");
880 return INTRETURN;
881 default:
882 llwprintf("itype(node) is %d\n", itype(node));
883 llwprintf("HUH, HUH, HUH, HUNH!\n");
884 goto interp_fail;
885 }
886 node = inext(node);
887 }
888 return TRUE;
889
890 interp_fail:
891 if (getlloptint("FullReportCallStack", 0) > 0) {
892 llwprintf("e%d: ", iline(node)+1);
893 debug_show_one_pnode(node);
894 llwprintf("\n");
895 }
896 return INTERROR;
897 }
898 /*========================================+
899 * interp_children -- Interpret child loop
900 * usage: children(INDI,INDI_V,INT_V) {...}
901 *=======================================*/
902 INTERPTYPE
interp_children(PNODE node,SYMTAB stab,PVALUE * pval)903 interp_children (PNODE node, SYMTAB stab, PVALUE *pval)
904 {
905 BOOLEAN eflg = FALSE;
906 INT nchil;
907 CACHEEL fcel, cel;
908 INTERPTYPE irc;
909 PVALUE val;
910 NODE fam = (NODE) eval_fam(iloopexp(node), stab, &eflg, &fcel);
911 if (eflg) {
912 prog_error(node, nonfamx, "children", "1");
913 return INTERROR;
914 }
915 if (fam && nestr(ntag(fam), "FAM")) {
916 prog_error(node, badargx, "children", "1");
917 return INTERROR;
918 }
919 if (!fam) return INTOKAY;
920 lock_cache(fcel);
921 FORCHILDRENx(fam, chil, nchil)
922 val = create_pvalue_from_indi(chil);
923 insert_symtab(stab, ichild(node), val);
924 insert_symtab(stab, inum(node), create_pvalue_from_int(nchil));
925 /* val should be real person, because it came from FORCHILDREN */
926 cel = pvalue_to_cel(val);
927 lock_cache(cel);
928 irc = interpret((PNODE) ibody(node), stab, pval);
929 unlock_cache(cel);
930 switch (irc) {
931 case INTCONTINUE:
932 case INTOKAY:
933 goto aloop;
934 default:
935 goto aleave;
936 }
937 aloop: ;
938 ENDCHILDRENx
939 irc = INTOKAY;
940 aleave:
941 delete_symtab_element(stab, ichild(node));
942 delete_symtab_element(stab, inum(node));
943 unlock_cache(fcel);
944 return irc;
945 }
946 /*========================================+
947 * interp_familyspouses -- Interpret familyspouses loop
948 * usage: familyspouses(FAM,INDI_V,INT_V) {...}
949 *=======================================*/
950 INTERPTYPE
interp_familyspouses(PNODE node,SYMTAB stab,PVALUE * pval)951 interp_familyspouses (PNODE node, SYMTAB stab, PVALUE *pval)
952 {
953 BOOLEAN eflg = FALSE;
954 INT nspouse;
955 CACHEEL fcel, cel;
956 INTERPTYPE irc;
957 PVALUE val;
958 NODE fam = (NODE) eval_fam(iloopexp(node), stab, &eflg, &fcel);
959 if (eflg) {
960 prog_error(node, nonfamx, "family spouses", "1");
961 return INTERROR;
962 }
963 if (fam && nestr(ntag(fam), "FAM")) {
964 prog_error(node, badargx, "family spouses", "1");
965 return INTERROR;
966 }
967 if (!fam) return INTOKAY;
968 lock_cache(fcel);
969 FORFAMSPOUSES(fam, spouse, nspouse)
970 val = create_pvalue_from_indi(spouse);
971 insert_symtab(stab, ichild(node), val);
972 insert_symtab(stab, inum(node), create_pvalue_from_int(nspouse));
973 /* val should be real person, because it came from FORFAMSPOUSES */
974 cel = pvalue_to_cel(val);
975 lock_cache(cel);
976 irc = interpret((PNODE) ibody(node), stab, pval);
977 unlock_cache(cel);
978 switch (irc) {
979 case INTCONTINUE:
980 case INTOKAY:
981 goto aloop;
982 default:
983 goto aleave;
984 }
985 aloop: ;
986 ENDFAMSPOUSES
987 irc = INTOKAY;
988 aleave:
989 delete_symtab_element(stab, ichild(node));
990 delete_symtab_element(stab, inum(node));
991 unlock_cache(fcel);
992 return irc;
993 }
994 /*==============================================+
995 * interp_spouses -- Interpret spouse loop
996 * usage: spouses(INDI,INDI_V,FAM_V,INT_V) {...}
997 *=============================================*/
998 INTERPTYPE
interp_spouses(PNODE node,SYMTAB stab,PVALUE * pval)999 interp_spouses (PNODE node, SYMTAB stab, PVALUE *pval)
1000 {
1001 BOOLEAN eflg = FALSE;
1002 INT nspouses;
1003 CACHEEL icel, scel, fcel;
1004 INTERPTYPE irc;
1005 PVALUE sval, fval, nval;
1006 NODE indi = (NODE) eval_indi(iloopexp(node), stab, &eflg, &icel);
1007 if (eflg) {
1008 prog_error(node, nonindx, "spouses", "1");
1009 return INTERROR;
1010 }
1011 if (indi && nestr(ntag(indi), "INDI")) {
1012 prog_error(node, badargx, "spouses", "1");
1013 return INTERROR;
1014 }
1015 if (!indi) return TRUE;
1016 lock_cache(icel);
1017 FORSPOUSES(indi, spouse, fam, nspouses)
1018 sval = create_pvalue_from_indi(spouse);
1019 insert_symtab(stab, ispouse(node), sval);
1020 fval = create_pvalue_from_fam(fam);
1021 insert_symtab(stab, ifamily(node), fval);
1022 nval = create_pvalue_from_int(nspouses);
1023 insert_symtab(stab, inum(node), nval);
1024 /* sval should be real person, because it came from FORSPOUSES */
1025 scel = pvalue_to_cel(sval);
1026 /* fval should be real person, because it came from FORSPOUSES */
1027 fcel = pvalue_to_cel(fval);
1028 lock_cache(scel);
1029 lock_cache(fcel);
1030 irc = interpret((PNODE) ibody(node), stab, pval);
1031 unlock_cache(scel);
1032 unlock_cache(fcel);
1033 switch (irc) {
1034 case INTCONTINUE:
1035 case INTOKAY:
1036 goto bloop;
1037 default:
1038 goto bleave;
1039 }
1040 bloop: ;
1041 ENDSPOUSES
1042 irc = INTOKAY;
1043 bleave:
1044 delete_symtab_element(stab, ispouse(node));
1045 delete_symtab_element(stab, ifamily(node));
1046 delete_symtab_element(stab, inum(node));
1047 unlock_cache(icel);
1048 return irc;
1049 }
1050 /*===============================================+
1051 * interp_families -- Interpret family loop
1052 * usage: families(INDI,FAM_V,INDI_V,INT_V) {...}
1053 * 2001/03/17 Revised by Perry Rapp
1054 * to call insert_symtab_pvalue, get_cel_from_pvalue
1055 * to delete its loop pvalues when finished
1056 *==============================================*/
1057 INTERPTYPE
interp_families(PNODE node,SYMTAB stab,PVALUE * pval)1058 interp_families (PNODE node, SYMTAB stab, PVALUE *pval)
1059 {
1060 BOOLEAN eflg = FALSE;
1061 INT nfams;
1062 CACHEEL icel, fcel, scel;
1063 INTERPTYPE irc;
1064 PVALUE fval, sval, nval;
1065 NODE indi = (NODE) eval_indi(iloopexp(node), stab, &eflg, &icel);
1066 if (eflg) {
1067 prog_error(node, nonindx, "families", "1");
1068 return INTERROR;
1069 }
1070 if (indi && nestr(ntag(indi), "INDI")) {
1071 prog_error(node, badargx, "families", "1");
1072 return INTERROR;
1073 }
1074 if (!indi) return INTOKAY;
1075 lock_cache(icel);
1076 FORFAMSS(indi, fam, spouse, nfams)
1077 fval = create_pvalue_from_fam(fam);
1078 insert_symtab(stab, ifamily(node), fval);
1079 sval = create_pvalue_from_indi(spouse);
1080 insert_symtab(stab, ispouse(node), sval);
1081 nval = create_pvalue_from_int(nfams);
1082 insert_symtab(stab, inum(node), nval);
1083 /* fval should be real person, because it came from FORFAMSS */
1084 fcel = pvalue_to_cel(fval);
1085 /* sval may not be a person -- so scel may be NULL */
1086 scel = pvalue_to_cel(sval);
1087 lock_cache(fcel);
1088 if (scel) lock_cache(scel);
1089 irc = interpret((PNODE) ibody(node), stab, pval);
1090 unlock_cache(fcel);
1091 if (scel) unlock_cache(scel);
1092 switch (irc) {
1093 case INTCONTINUE:
1094 case INTOKAY:
1095 goto cloop;
1096 default:
1097 goto cleave;
1098 }
1099 cloop: ;
1100 ENDFAMSS
1101 irc = INTOKAY;
1102 cleave:
1103 delete_symtab_element(stab, ifamily(node));
1104 delete_symtab_element(stab, ispouse(node));
1105 delete_symtab_element(stab, inum(node));
1106 unlock_cache(icel);
1107 return irc;
1108 }
1109 /*========================================+
1110 * interp_fathers -- Interpret fathers loop
1111 * 2001/03/17 Revised by Perry Rapp
1112 * to call insert_symtab_pvalue, get_cel_from_pvalue
1113 * to delete its loop pvalues when finished
1114 *=======================================*/
1115 INTERPTYPE
interp_fathers(PNODE node,SYMTAB stab,PVALUE * pval)1116 interp_fathers (PNODE node, SYMTAB stab, PVALUE *pval)
1117 {
1118 BOOLEAN eflg = FALSE;
1119 INT nfams;
1120 INT ncount = 1;
1121 CACHEEL icel, fcel, scel;
1122 INTERPTYPE irc;
1123 PVALUE sval, fval;
1124 NODE indi = (NODE) eval_indi(iloopexp(node), stab, &eflg, &icel);
1125 if (eflg) {
1126 prog_error(node, nonindx, "fathers", "1");
1127 return INTERROR;
1128 }
1129 if (indi && nestr(ntag(indi), "INDI")) {
1130 prog_error(node, badargx, "fathers", "1");
1131 return INTERROR;
1132 }
1133 if (!indi) return TRUE;
1134 lock_cache(icel);
1135 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1136 FORFAMCS(indi, fam, husb, wife, nfams)
1137 sval = create_pvalue_from_indi(husb);
1138 scel = pvalue_to_cel(sval);
1139 if (!scel) goto dloop;
1140 fval = create_pvalue_from_fam(fam);
1141 fcel = pvalue_to_cel(fval);
1142 insert_symtab(stab, ifamily(node), fval);
1143 insert_symtab(stab, iiparent(node), create_pvalue_from_cel(PINDI, scel));
1144 insert_symtab(stab, inum(node), create_pvalue_from_int(ncount++));
1145 lock_cache(fcel);
1146 lock_cache(scel);
1147 irc = interpret((PNODE) ibody(node), stab, pval);
1148 unlock_cache(fcel);
1149 unlock_cache(scel);
1150 switch (irc) {
1151 case INTCONTINUE:
1152 case INTOKAY:
1153 irc = INTOKAY;
1154 goto dloop;
1155 default:
1156 goto dleave;
1157 }
1158 dloop: ;
1159 ENDFAMCS
1160 irc = INTOKAY;
1161 dleave:
1162 delete_symtab_element(stab, ifamily(node));
1163 delete_symtab_element(stab, iiparent(node));
1164 delete_symtab_element(stab, inum(node));
1165 unlock_cache(icel);
1166 return irc;
1167 }
1168 /*========================================+
1169 * interp_mothers -- Interpret mothers loop
1170 * 2001/03/18 Revised by Perry Rapp
1171 * to call insert_symtab_pvalue, get_cel_from_pvalue
1172 * to delete its loop pvalues when finished
1173 *=======================================*/
1174 INTERPTYPE
interp_mothers(PNODE node,SYMTAB stab,PVALUE * pval)1175 interp_mothers (PNODE node, SYMTAB stab, PVALUE *pval)
1176 {
1177 BOOLEAN eflg = FALSE;
1178 INT nfams;
1179 INT ncount = 1;
1180 CACHEEL icel, fcel, scel;
1181 INTERPTYPE irc;
1182 PVALUE sval, fval;
1183 NODE indi = (NODE) eval_indi(iloopexp(node), stab, &eflg, &icel);
1184 if (eflg) {
1185 prog_error(node, nonindx, "mothers", "1");
1186 return INTERROR;
1187 }
1188 if (indi && nestr(ntag(indi), "INDI")) {
1189 prog_error(node, badargx, "mothers", "1");
1190 return INTERROR;
1191 }
1192 if (!indi) return TRUE;
1193 lock_cache(icel);
1194 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1195 FORFAMCS(indi, fam, husb, wife, nfams)
1196 sval = create_pvalue_from_indi(wife);
1197 scel = pvalue_to_cel(sval);
1198 if (!scel) goto eloop;
1199 fval = create_pvalue_from_fam(fam);
1200 fcel = pvalue_to_cel(fval);
1201 insert_symtab(stab, ifamily(node), fval);
1202 insert_symtab(stab, iiparent(node), create_pvalue_from_cel(PINDI, scel));
1203 insert_symtab(stab, inum(node), create_pvalue_from_int(ncount++));
1204 lock_cache(fcel);
1205 lock_cache(scel);
1206 irc = interpret((PNODE) ibody(node), stab, pval);
1207 unlock_cache(fcel);
1208 unlock_cache(scel);
1209 switch (irc) {
1210 case INTCONTINUE:
1211 case INTOKAY:
1212 goto eloop;
1213 default:
1214 goto eleave;
1215 }
1216 eloop: ;
1217 ENDFAMCS
1218 irc = INTOKAY;
1219 eleave:
1220 delete_symtab_element(stab, ifamily(node));
1221 delete_symtab_element(stab, iiparent(node));
1222 delete_symtab_element(stab, inum(node));
1223 unlock_cache(icel);
1224 return irc;
1225 }
1226 /*========================================+
1227 * interp_parents -- Interpret parents loop
1228 * 2001/03/18 Revised by Perry Rapp
1229 * to call insert_symtab_pvalue, get_cel_from_pvalue
1230 * to delete its loop pvalues when finished
1231 *=======================================*/
1232 INTERPTYPE
interp_parents(PNODE node,SYMTAB stab,PVALUE * pval)1233 interp_parents (PNODE node, SYMTAB stab, PVALUE *pval)
1234 {
1235 BOOLEAN eflg = FALSE;
1236 INT nfams;
1237 CACHEEL icel, fcel;
1238 INTERPTYPE irc;
1239 PVALUE fval;
1240 NODE indi = (NODE) eval_indi(iloopexp(node), stab, &eflg, &icel);
1241 if (eflg) {
1242 prog_error(node, nonindx, "parents", "1");
1243 return INTERROR;
1244 }
1245 if (indi && nestr(ntag(indi), "INDI")) {
1246 prog_error(node, badargx, "parents", "1");
1247 return INTERROR;
1248 }
1249 if (!indi) return TRUE;
1250 lock_cache(icel);
1251 FORFAMCS(indi, fam, husb, wife, nfams)
1252 fval = create_pvalue_from_fam(fam);
1253 insert_symtab(stab, ifamily(node), fval);
1254 insert_symtab(stab, inum(node), create_pvalue_from_int(nfams));
1255 fcel = pvalue_to_cel(fval);
1256 lock_cache(fcel);
1257 irc = interpret((PNODE) ibody(node), stab, pval);
1258 unlock_cache(fcel);
1259 switch (irc) {
1260 case INTCONTINUE:
1261 case INTOKAY:
1262 goto floop;
1263 default:
1264 goto fleave;
1265 }
1266 floop: ;
1267 ENDFAMCS
1268 irc = INTOKAY;
1269 fleave:
1270 delete_symtab_element(stab, ifamily(node));
1271 delete_symtab_element(stab, inum(node));
1272 unlock_cache(icel);
1273 return INTOKAY;
1274 }
1275 /*=======================================
1276 * interp_fornotes -- Interpret NOTE loop
1277 *=====================================*/
1278 INTERPTYPE
interp_fornotes(PNODE node,SYMTAB stab,PVALUE * pval)1279 interp_fornotes (PNODE node, SYMTAB stab, PVALUE *pval)
1280 {
1281 BOOLEAN eflg = FALSE;
1282 INTERPTYPE irc;
1283 NODE root;
1284 PVALUE val = eval_and_coerce(PGNODE, iloopexp(node), stab, &eflg);
1285 if (eflg) {
1286 prog_error(node, nonrecx, "fornotes", "1");
1287 return INTERROR;
1288 }
1289 root = pvalue_to_node(val);
1290 delete_pvalue(val);
1291 if (!root) return INTOKAY;
1292 FORTAGVALUES(root, "NOTE", sub, vstring)
1293 insert_symtab(stab, ielement(node), create_pvalue_from_string(vstring));
1294 irc = interpret((PNODE) ibody(node), stab, pval);
1295 switch (irc) {
1296 case INTCONTINUE:
1297 case INTOKAY:
1298 goto gloop;
1299 default:
1300 goto gleave;
1301 }
1302 gloop: ;
1303 ENDTAGVALUES
1304 irc = INTOKAY;
1305 gleave:
1306 delete_symtab_element(stab, ielement(node));
1307 return irc;
1308 }
1309 /*==========================================+
1310 * interp_fornodes -- Interpret fornodes loop
1311 * usage: fornodes(NODE,NODE_V) {...}
1312 * 2001/03/19 Revised by Perry Rapp
1313 * to delete its loop pvalue when finished
1314 *=========================================*/
1315 INTERPTYPE
interp_fornodes(PNODE node,SYMTAB stab,PVALUE * pval)1316 interp_fornodes (PNODE node, SYMTAB stab, PVALUE *pval)
1317 {
1318 BOOLEAN eflg = FALSE;
1319 INTERPTYPE irc;
1320 NODE sub, root=NULL;
1321 PVALUE val = eval_and_coerce(PGNODE, iloopexp(node), stab, &eflg);
1322 if (eflg) {
1323 prog_error(node, nonrecx, "fornodes", "1");
1324 return INTERROR;
1325 }
1326 root = pvalue_to_node(val);
1327 delete_pvalue(val);
1328 if (!root) return INTOKAY;
1329 sub = nchild(root);
1330 while (sub) {
1331 insert_symtab(stab, ielement(node), create_pvalue_from_node(sub));
1332 irc = interpret((PNODE) ibody(node), stab, pval);
1333 switch (irc) {
1334 case INTCONTINUE:
1335 case INTOKAY:
1336 sub = nsibling(sub);
1337 goto hloop;
1338 default:
1339 goto hleave;
1340 }
1341 hloop: ;
1342 }
1343 irc = INTOKAY;
1344 hleave:
1345 delete_symtab_element(stab, ielement(node));
1346 return irc;
1347 }
1348 /*========================================+
1349 * printkey -- Make key from keynum
1350 *=======================================*/
1351 #ifdef UNUSED_CODE
1352 static void
printkey(STRING key,char type,INT keynum)1353 printkey (STRING key, char type, INT keynum)
1354 {
1355 if (keynum>9999999 || keynum<0)
1356 keynum=0;
1357 sprintf(key, "%c%d", type, keynum);
1358 }
1359 #endif
1360 /*========================================+
1361 * interp_forindi -- Interpret forindi loop
1362 * usage: forindi(INDI_V,INT_V) {...}
1363 * 2001/03/18 Revised by Perry Rapp
1364 * to call create_pvalue_from_indi_keynum, get_cel_from_pvalue
1365 * to delete its loop pvalues when finished
1366 *=======================================*/
1367 INTERPTYPE
interp_forindi(PNODE node,SYMTAB stab,PVALUE * pval)1368 interp_forindi (PNODE node, SYMTAB stab, PVALUE *pval)
1369 {
1370 CACHEEL icel=NULL;
1371 INTERPTYPE irc;
1372 PVALUE ival=NULL;
1373 INT count = 0;
1374 INT icount = 0;
1375 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1376 while (TRUE) {
1377 count = xref_nexti(count);
1378 if (!count) {
1379 irc = INTOKAY;
1380 goto ileave;
1381 }
1382 ival = create_pvalue_from_indi_keynum(count);
1383 icel = pvalue_to_cel(ival);
1384 if (!icel) { /* apparently missing record */
1385 delete_pvalue(ival);
1386 continue;
1387 }
1388 icount++;
1389 lock_cache(icel); /* keep current indi in cache during loop body */
1390 /* set loop variables */
1391 insert_symtab(stab, ielement(node), ival);
1392 insert_symtab(stab, inum(node), create_pvalue_from_int(icount));
1393 /* execute loop body */
1394 irc = interpret((PNODE) ibody(node), stab, pval);
1395 unlock_cache(icel);
1396 switch (irc) {
1397 case INTCONTINUE:
1398 case INTOKAY:
1399 continue;
1400 default:
1401 goto ileave;
1402 }
1403 }
1404 ileave:
1405 delete_symtab_element(stab, ielement(node));
1406 delete_symtab_element(stab, inum(node));
1407 return irc;
1408 }
1409 /*========================================+
1410 * interp_forsour -- Interpret forsour loop
1411 * usage: forsour(SOUR_V,INT_V) {...}
1412 * 2001/03/20 Revised by Perry Rapp
1413 * to call create_pvalue_from_indi_keynum, get_cel_from_pvalue
1414 * to delete its loop pvalues when finished
1415 *=======================================*/
1416 INTERPTYPE
interp_forsour(PNODE node,SYMTAB stab,PVALUE * pval)1417 interp_forsour (PNODE node, SYMTAB stab, PVALUE *pval)
1418 {
1419 CACHEEL scel=NULL;
1420 INTERPTYPE irc;
1421 PVALUE sval=NULL;
1422 INT count = 0;
1423 INT scount = 0;
1424 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1425 while (TRUE) {
1426 count = xref_nexts(count);
1427 if (!count) {
1428 irc = INTOKAY;
1429 goto sourleave;
1430 }
1431 sval = create_pvalue_from_sour_keynum(count);
1432 scel = pvalue_to_cel(sval);
1433 if (!scel) { /* apparently missing record */
1434 delete_pvalue(sval);
1435 continue;
1436 }
1437 scount++;
1438 lock_cache(scel); /* keep current source in cache during loop body */
1439 /* set loop variables */
1440 insert_symtab(stab, ielement(node), sval);
1441 insert_symtab(stab, inum(node), create_pvalue_from_int(scount));
1442 /* execute loop body */
1443 irc = interpret((PNODE) ibody(node), stab, pval);
1444 unlock_cache(scel);
1445 switch (irc) {
1446 case INTCONTINUE:
1447 case INTOKAY:
1448 continue;
1449 default:
1450 goto sourleave;
1451 }
1452 }
1453 sourleave:
1454 /* remove loop variables from symbol table */
1455 delete_symtab_element(stab, ielement(node));
1456 delete_symtab_element(stab, inum(node));
1457 return irc;
1458 }
1459 /*========================================+
1460 * interp_foreven -- Interpret foreven loop
1461 * usage: foreven(EVEN_V,INT_V) {...}
1462 *=======================================*/
1463 INTERPTYPE
interp_foreven(PNODE node,SYMTAB stab,PVALUE * pval)1464 interp_foreven (PNODE node, SYMTAB stab, PVALUE *pval)
1465 {
1466 CACHEEL ecel=NULL;
1467 INTERPTYPE irc;
1468 PVALUE eval=NULL;
1469 INT count = 0;
1470 INT ecount = 0;
1471 insert_symtab(stab, inum(node), create_pvalue_from_int(count));
1472 while (TRUE) {
1473 count = xref_nexte(count);
1474 if (!count) {
1475 irc = INTOKAY;
1476 goto evenleave;
1477 }
1478 eval = create_pvalue_from_even_keynum(count);
1479 ecel = pvalue_to_cel(eval);
1480 if (!ecel) { /* apparently missing record */
1481 delete_pvalue(eval);
1482 continue;
1483 }
1484 ecount++;
1485 lock_cache(ecel); /* keep current event in cache during loop body */
1486 /* set loop variables */
1487 insert_symtab(stab, ielement(node), eval);
1488 insert_symtab(stab, inum(node), create_pvalue_from_int(ecount));
1489 /* execute loop body */
1490 irc = interpret((PNODE) ibody(node), stab, pval);
1491 unlock_cache(ecel);
1492 switch (irc) {
1493 case INTCONTINUE:
1494 case INTOKAY:
1495 continue;
1496 default:
1497 goto evenleave;
1498 }
1499 }
1500 evenleave:
1501 /* remove loop variables from symbol table */
1502 delete_symtab_element(stab, ielement(node));
1503 delete_symtab_element(stab, inum(node));
1504 return irc;
1505 }
1506 /*========================================+
1507 * interp_forothr -- Interpret forothr loop
1508 * usage: forothr(OTHR_V,INT_V) {...}
1509 *=======================================*/
1510 INTERPTYPE
interp_forothr(PNODE node,SYMTAB stab,PVALUE * pval)1511 interp_forothr (PNODE node, SYMTAB stab, PVALUE *pval)
1512 {
1513 CACHEEL xcel;
1514 INTERPTYPE irc;
1515 PVALUE xval;
1516 INT count = 0;
1517 INT xcount = 0;
1518 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1519 while (TRUE) {
1520 count = xref_nextx(count);
1521 if (!count) {
1522 irc = INTOKAY;
1523 goto othrleave;
1524 }
1525 xval = create_pvalue_from_othr_keynum(count);
1526 xcel = pvalue_to_cel(xval);
1527 if (!xcel) { /* apparently missing record */
1528 delete_pvalue(xval);
1529 continue;
1530 }
1531 xcount++;
1532 lock_cache(xcel); /* keep current source in cache during loop body */
1533 /* set loop variables */
1534 insert_symtab(stab, ielement(node), xval);
1535 insert_symtab(stab, inum(node), create_pvalue_from_int(xcount));
1536 /* execute loop body */
1537 irc = interpret((PNODE) ibody(node), stab, pval);
1538 unlock_cache(xcel);
1539 switch (irc) {
1540 case INTCONTINUE:
1541 case INTOKAY:
1542 continue;
1543 default:
1544 goto othrleave;
1545 }
1546 }
1547 othrleave:
1548 delete_symtab_element(stab, ielement(node));
1549 delete_symtab_element(stab, inum(node));
1550 return irc;
1551 }
1552 /*======================================+
1553 * interp_forfam -- Interpret forfam loop
1554 * usage: forfam(FAM_V,INT_V) {...}
1555 *=====================================*/
1556 INTERPTYPE
interp_forfam(PNODE node,SYMTAB stab,PVALUE * pval)1557 interp_forfam (PNODE node, SYMTAB stab, PVALUE *pval)
1558 {
1559 CACHEEL fcel=NULL;
1560 INTERPTYPE irc;
1561 PVALUE fval=NULL;
1562 INT count = 0;
1563 INT fcount = 0;
1564 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1565 while (TRUE) {
1566 count = xref_nextf(count);
1567 if (!count) {
1568 irc = INTOKAY;
1569 goto mleave;
1570 }
1571 fval = create_pvalue_from_fam_keynum(count);
1572 fcel = pvalue_to_cel(fval);
1573 if (!fcel) { /* apparently missing record */
1574 delete_pvalue(fval);
1575 continue;
1576 }
1577 fcount++;
1578 lock_cache(fcel);
1579 insert_symtab(stab, ielement(node), fval);
1580 insert_symtab(stab, inum(node), create_pvalue_from_int(fcount));
1581 irc = interpret((PNODE) ibody(node), stab, pval);
1582 unlock_cache(fcel);
1583 switch (irc) {
1584 case INTCONTINUE:
1585 case INTOKAY:
1586 continue;
1587 default:
1588 goto mleave;
1589 }
1590 }
1591 mleave:
1592 delete_symtab_element(stab, ielement(node));
1593 delete_symtab_element(stab, inum(node));
1594 return irc;
1595 }
1596 /*============================================+
1597 * interp_indisetloop -- Interpret indiset loop
1598 * 2001/03/21 Revised by Perry Rapp
1599 * to delete its loop pvalues when finished
1600 *===========================================*/
1601 INTERPTYPE
interp_indisetloop(PNODE node,SYMTAB stab,PVALUE * pval)1602 interp_indisetloop (PNODE node, SYMTAB stab, PVALUE *pval)
1603 {
1604 BOOLEAN eflg = FALSE;
1605 INTERPTYPE irc;
1606 PVALUE indival=0, loopval=0;
1607 INDISEQ seq = NULL;
1608 PVALUE val = evaluate(iloopexp(node), stab, &eflg);
1609 if (eflg || !val || ptype(val) != PSET) {
1610 prog_error(node, "1st arg to forindiset must be set expr");
1611 return INTERROR;
1612 }
1613 seq = pvalue_to_seq(val);
1614 if (!seq) {
1615 delete_pvalue(val); /* delete temp evaluated val - may destruct seq */
1616 return INTOKAY;
1617 }
1618 /* can't delete val until we're done with seq */
1619 /* initialize counter */
1620 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1621 FORINDISEQ(seq, el, ncount)
1622 /* put current indi in symbol table */
1623 indival = create_pvalue_from_indi_key(element_skey(el));
1624 insert_symtab(stab, ielement(node), indival);
1625 /* put current indi's value in symbol table */
1626 loopval = element_pval(el);
1627 if (loopval)
1628 loopval = copy_pvalue(loopval);
1629 else
1630 loopval = create_pvalue_any();
1631 insert_symtab(stab, ivalvar(node), loopval);
1632 /* put counter in symbol table */
1633 insert_symtab(stab, inum(node), create_pvalue_from_int(ncount + 1));
1634 switch (irc = interpret((PNODE) ibody(node), stab, pval)) {
1635 case INTCONTINUE:
1636 case INTOKAY:
1637 goto hloop;
1638 default:
1639 goto hleave;
1640 }
1641 hloop: ;
1642 ENDINDISEQ
1643 irc = INTOKAY;
1644 hleave:
1645 delete_pvalue(val); /* delete temp evaluated val - may destruct seq */
1646 delete_symtab_element(stab, ielement(node)); /* remove indi */
1647 delete_symtab_element(stab, ivalvar(node)); /* remove indi's value */
1648 delete_symtab_element(stab, inum(node)); /* remove counter */
1649 return irc;
1650 }
1651 /*=====================================+
1652 * interp_forlist -- Interpret list loop
1653 * 2001/03/21 Revised by Perry Rapp
1654 * to delete its loop pvalues when finished
1655 *====================================*/
1656 INTERPTYPE
interp_forlist(PNODE node,SYMTAB stab,PVALUE * pval)1657 interp_forlist (PNODE node, SYMTAB stab, PVALUE *pval)
1658 {
1659 BOOLEAN eflg = FALSE;
1660 INTERPTYPE irc;
1661 INT ncount = 1;
1662 LIST list;
1663 PVALUE val = eval_and_coerce(PLIST, iloopexp(node), stab, &eflg);
1664 if (eflg || !val || ptype(val) != PLIST) {
1665 prog_error(node, "1st arg to forlist is not a list");
1666 return INTERROR;
1667 }
1668 list = pvalue_to_list(val);
1669 /* can't delete val until we're done with list */
1670 if (!list) {
1671 delete_pvalue(val); /* delete temp evaluated val - may destruct list */
1672 prog_error(node, "1st arg to forlist is in error");
1673 return INTERROR;
1674 }
1675 insert_symtab(stab, inum(node), create_pvalue_from_int(0));
1676 FORLIST(list, el)
1677 /* insert/update current element in symbol table */
1678 insert_symtab(stab, ielement(node), copy_pvalue(el));
1679 /* insert/update counter in symbol table */
1680 insert_symtab(stab, inum(node), create_pvalue_from_int(ncount++));
1681 switch (irc = interpret((PNODE) ibody(node), stab, pval)) {
1682 case INTCONTINUE:
1683 case INTOKAY:
1684 goto iloop;
1685 default:
1686 STOPLIST
1687 goto ileave;
1688 }
1689 iloop: ;
1690 ENDLIST
1691 irc = INTOKAY;
1692 ileave:
1693 delete_pvalue(val); /* delete temp evaluated val - may destruct list */
1694 /* remove element & counter from symbol table */
1695 delete_symtab_element(stab, ielement(node));
1696 delete_symtab_element(stab, inum(node));
1697 return irc;
1698 }
1699 /*===================================+
1700 * interp_if -- Interpret if structure
1701 *==================================*/
1702 INTERPTYPE
interp_if(PNODE node,SYMTAB stab,PVALUE * pval)1703 interp_if (PNODE node, SYMTAB stab, PVALUE *pval)
1704 {
1705 BOOLEAN eflg = FALSE;
1706 PNODE icond = node->vars.iif.icond;
1707 PNODE ithen = node->vars.iif.ithen;
1708 PNODE ielse = node->vars.iif.ielse;
1709 BOOLEAN cond = evaluate_cond(icond, stab, &eflg);
1710 if (eflg) return INTERROR;
1711 if (cond) return interpret(ithen, stab, pval);
1712 if (ielse) return interpret(ielse, stab, pval);
1713 return INTOKAY;
1714 }
1715 /*=========================================+
1716 * interp_while -- Interpret while structure
1717 *========================================*/
1718 INTERPTYPE
interp_while(PNODE node,SYMTAB stab,PVALUE * pval)1719 interp_while (PNODE node, SYMTAB stab, PVALUE *pval)
1720 {
1721 BOOLEAN eflg=FALSE, cond=FALSE;
1722 INTERPTYPE irc;
1723 while (TRUE) {
1724 PNODE icond = node->vars.iwhile.icond;
1725 PNODE ibody = node->vars.iwhile.ibody;
1726 cond = evaluate_cond(icond, stab, &eflg);
1727 if (eflg) return INTERROR;
1728 if (!cond) return INTOKAY;
1729 switch (irc = interpret(ibody, stab, pval)) {
1730 case INTCONTINUE:
1731 case INTOKAY:
1732 continue;
1733 default:
1734 return irc;
1735 }
1736 }
1737 }
1738 /*=======================================+
1739 * get_proc_node -- Find proc (or func) in local or global table
1740 * returns NULL if error, and sets *count to how many global listing
1741 * (ie, 0 or more than 1)
1742 * Created: 2002/11/30 (Perry Rapp)
1743 *======================================*/
1744 PNODE
get_proc_node(CNSTRING procname,TABLE loctab,TABLE gtab,INT * count)1745 get_proc_node (CNSTRING procname, TABLE loctab, TABLE gtab, INT * count)
1746 {
1747 LIST list=0;
1748 PNODE proc = valueof_ptr(loctab, procname);
1749 if (proc) return proc;
1750 /* now look for global proc, and must be unique */
1751 list = valueof_obj(gtab, procname);
1752 if (!list) {
1753 *count = 0;
1754 return NULL;
1755 }
1756 if (length_list(list)>1) {
1757 *count = length_list(list);
1758 return NULL;
1759 }
1760 proc = peek_list_head(list);
1761 ASSERT(proc);
1762 return proc;
1763 }
1764 /*=======================================+
1765 * interp_call -- Interpret call structure
1766 *======================================*/
1767 INTERPTYPE
interp_call(PNODE node,SYMTAB stab,PVALUE * pval)1768 interp_call (PNODE node, SYMTAB stab, PVALUE *pval)
1769 {
1770 SYMTAB newstab = NULL;
1771 INTERPTYPE irc=INTERROR;
1772 PNODE arg=NULL, parm=NULL, proc=NULL;
1773 CNSTRING procname = node->vars.ipcall.fname;
1774 INT count=0;
1775 /* find proc in local or global table */
1776 proc = get_proc_node(procname, irptinfo(node)->proctab, gproctab, &count);
1777 if (!proc) {
1778 if (!count)
1779 prog_error(node, _("Undefined proc: %s"), procname);
1780 else
1781 prog_error(node, _("Ambiguous call to proc: %s"), procname);
1782 irc = INTERROR;
1783 goto call_leave;
1784 }
1785 ASSERT(itype(proc) == IPDEFN);
1786 newstab = create_symtab_proc(procname, stab);
1787 arg = node->vars.ipcall.fargs; /* call instance */
1788 parm = (PNODE) iargs(proc); /* declaration */
1789 while (arg && parm) {
1790 BOOLEAN eflg = FALSE;
1791 PVALUE value = evaluate(arg, stab, &eflg);
1792 if (eflg) {
1793 irc = INTERROR;
1794 goto call_leave;
1795 }
1796 insert_symtab(newstab, iident_name(parm), value);
1797 arg = inext(arg);
1798 parm = inext(parm);
1799 }
1800 if (arg || parm) {
1801 prog_error(node, "``%s'': mismatched args and params\n", iname(node));
1802 irc = INTERROR;
1803 goto call_leave;
1804 }
1805 irc = interpret((PNODE) ibody(proc), newstab, pval);
1806 switch (irc) {
1807 case INTRETURN:
1808 case INTOKAY:
1809 irc = INTOKAY;
1810 break;
1811 case INTBREAK:
1812 case INTCONTINUE:
1813 case INTERROR:
1814 default:
1815 irc = INTERROR;
1816 break;
1817 }
1818
1819 call_leave:
1820 if (newstab) {
1821 remove_symtab(newstab);
1822 newstab = NULL;
1823 }
1824 return irc;
1825 }
1826 /*==============================================+
1827 * interp_traverse -- Interpret traverse iterator
1828 * usage: traverse(NODE,NODE_V,INT_V) {...}
1829 * TO DO - doesn't clean up its symtab entries (2001/03/24)
1830 *=============================================*/
1831 INTERPTYPE
interp_traverse(PNODE node,SYMTAB stab,PVALUE * pval)1832 interp_traverse (PNODE node, SYMTAB stab, PVALUE *pval)
1833 {
1834 NODE snode, stack[100];
1835 BOOLEAN eflg = FALSE;
1836 INTERPTYPE irc;
1837 INT lev = -1;
1838 NODE root;
1839 PVALUE val = eval_and_coerce(PGNODE, iloopexp(node), stab, &eflg);
1840 if (eflg) {
1841 prog_var_error(node, stab, iloopexp(node), val, nonrecx, "traverse", "1");
1842 irc = INTERROR;
1843 goto traverse_leave;
1844 }
1845 root = pvalue_to_node(val);
1846 if (!root) {
1847 irc = INTOKAY;
1848 goto traverse_leave;
1849 }
1850 stack[++lev] = snode = root;
1851 while (TRUE) {
1852 insert_symtab(stab, ielement(node), create_pvalue_from_node(snode));
1853 insert_symtab(stab, ilev(node), create_pvalue_from_int(lev));
1854 switch (irc = interpret((PNODE) ibody(node), stab, pval)) {
1855 case INTCONTINUE:
1856 case INTOKAY:
1857 break;
1858 case INTBREAK:
1859 irc = INTOKAY;
1860 goto traverse_leave;
1861 default:
1862 goto traverse_leave;
1863 }
1864 if (nchild(snode)) {
1865 snode = stack[++lev] = nchild(snode);
1866 continue;
1867 }
1868 if (lev>0 && nsibling(snode)) {
1869 snode = stack[lev] = nsibling(snode);
1870 continue;
1871 }
1872 while (--lev >= 1 && !nsibling(stack[lev]))
1873 ;
1874 if (lev <= 0) break;
1875 snode = stack[lev] = nsibling(stack[lev]);
1876 }
1877 irc = INTOKAY;
1878 traverse_leave:
1879 delete_symtab_element(stab, ielement(node));
1880 delete_symtab_element(stab, ilev(node));
1881 delete_pvalue(val);
1882 val=NULL;
1883 return irc;
1884 }
1885 /*=============================================+
1886 * pa_handle_global -- declare global variable
1887 * Called directly from generated parser code (ie, from code in yacc.y)
1888 *=============================================*/
1889 void
pa_handle_global(STRING iden)1890 pa_handle_global (STRING iden)
1891 {
1892 insert_symtab(globtab, iden, create_pvalue_any());
1893 }
1894 /*=============================================+
1895 * pa_handle_option -- process option specified in report
1896 * Called directly from generated parser code (ie, from code in yacc.y)
1897 *=============================================*/
1898 void
pa_handle_option(CNSTRING optname)1899 pa_handle_option (CNSTRING optname)
1900 {
1901 if (eqstr(optname, "explicitvars")) {
1902 explicitvars = 1;
1903 } else {
1904 /* TODO - figure out how to set the error flag & report error */
1905 }
1906 }
1907 /*=============================================+
1908 * pa_handle_char_encoding -- report command char_encoding("...")
1909 * parse-time handling of report command
1910 * node: [IN] current parse node
1911 * vpinfo: [I/O] pointer to parseinfo structure (parse globals)
1912 * Called directly from generated parser code (ie, from code in yacc.y)
1913 *=============================================*/
1914 void
pa_handle_char_encoding(PACTX pactx,PNODE node)1915 pa_handle_char_encoding (PACTX pactx, PNODE node)
1916 {
1917 CNSTRING codeset = get_internal_string_node_value(node);
1918 pactx=pactx; /* unused */
1919 strupdate(&irptinfo(node)->codeset, codeset);
1920 }
1921 /*=============================================+
1922 * make_internal_string_node -- make string node
1923 * do any needed codeset conversion here
1924 * lexical analysis time (same as parse-time) handling of string constants
1925 *=============================================*/
1926 PNODE
make_internal_string_node(PACTX pactx,STRING str)1927 make_internal_string_node (PACTX pactx, STRING str)
1928 {
1929 PNODE node = 0;
1930 ZSTR zstr = zs_news(str);
1931 if (str && str[0]) {
1932 STRING fname = pactx->fullpath;
1933 STRING rptcodeset = get_rptinfo(fname)->codeset;
1934 XLAT xlat = transl_get_xlat_to_int(rptcodeset);
1935 transl_xlat(xlat, zstr);
1936 }
1937 node = create_string_node(pactx, zs_str(zstr));
1938 zs_free(&zstr);
1939 return node;
1940 }
1941 /*=============================================+
1942 * pa_handle_include -- report command include("...")
1943 * parse-time handling of report command
1944 *=============================================*/
1945 void
pa_handle_include(PACTX pactx,PNODE node)1946 pa_handle_include (PACTX pactx, PNODE node)
1947 {
1948 /*STRING fname = ifname(node); */ /* current file */
1949 CNSTRING newfname = get_internal_string_node_value(node);
1950 STRING fullpath=0, localpath=0;
1951 ZSTR zstr=0;
1952 PATHINFO pathinfo = 0;
1953 pactx=pactx; /* unused */
1954
1955 /* if it is relative, get local path to give to find_program */
1956 if (!is_path(newfname)) {
1957 localpath = zs_str(irptinfo(node)->localpath);
1958 }
1959
1960 if (find_program(newfname, localpath, &fullpath,TRUE)) {
1961 pathinfo = new_pathinfo(newfname, fullpath);
1962 strfree(&fullpath);
1963 enqueue_list(Plist, pathinfo);
1964 } else {
1965 prog_error(node, "included file not found: %s\n", newfname);
1966 ++Perrors;
1967 }
1968 zs_free(&zstr);
1969 }
1970 /*=============================================+
1971 * pa_handle_require -- report command require("...")
1972 * pactx: [I/O] pointer to parseinfo structure (parse globals)
1973 * node: [IN] current parse node
1974 *=============================================*/
1975 void
pa_handle_require(PACTX pactx,PNODE node)1976 pa_handle_require (PACTX pactx, PNODE node)
1977 {
1978 CNSTRING reqver = get_internal_string_node_value(node);
1979 STRING propstr = "requires_lifelines-reports.version:";
1980 TABLE tab=0;
1981 pactx=pactx; /* unused */
1982
1983 tab = (TABLE)valueof_obj(pactx->filetab, pactx->fullpath);
1984 if (!tab) {
1985 tab = create_table_str();
1986 insert_table_obj(pactx->filetab, cur_pathinfo->fullpath, tab);
1987 release_table(tab); /* release our reference, pactx->filetab owns now */
1988 }
1989
1990 insert_table_str(tab, propstr, reqver);
1991 }
1992 /*=============================================+
1993 * pa_handle_proc -- proc declaration (parse time)
1994 * Created: 2002/11/30 (Perry Rapp)
1995 *=============================================*/
1996 void
pa_handle_proc(PACTX pactx,CNSTRING procname,PNODE nd_args,PNODE nd_body)1997 pa_handle_proc (PACTX pactx, CNSTRING procname, PNODE nd_args, PNODE nd_body)
1998 {
1999 RPTINFO rptinfo = get_rptinfo(pactx->fullpath);
2000 PNODE procnode;
2001 LIST list;
2002
2003 /* check for local duplicates, else add to local proc table */
2004 procnode = (PNODE)valueof_ptr(rptinfo->proctab, procname);
2005 if (procnode) {
2006 enqueue_parse_error(_("Duplicate proc %s (lines %d and %d) in report: %s")
2007 , procname, iline(procnode)+1, iline(nd_body)+1, pactx->fullpath);
2008 }
2009 /* consumes procname */
2010 procnode = create_proc_node(pactx, procname, nd_args, nd_body);
2011 insert_table_ptr(rptinfo->proctab, procname, procnode);
2012
2013 /* add to global proc table */
2014 list = (LIST)valueof_obj(gproctab, procname);
2015 if (!list) {
2016 list = create_list2(LISTNOFREE);
2017 insert_table_obj(gproctab, procname, list);
2018 release_list(list); /* now table owns list */
2019 }
2020 enqueue_list(list, procnode);
2021 }
2022 /*=============================================+
2023 * pa_handle_func -- func declaration (parse time)
2024 * Created: 2002/11/30 (Perry Rapp)
2025 *=============================================*/
2026 void
pa_handle_func(PACTX pactx,CNSTRING procname,PNODE nd_args,PNODE nd_body)2027 pa_handle_func (PACTX pactx, CNSTRING procname, PNODE nd_args, PNODE nd_body)
2028 {
2029 RPTINFO rptinfo = get_rptinfo(pactx->fullpath);
2030 PNODE procnode=0;
2031 LIST list=0;
2032
2033 /* check for local duplicates, else add to local proc table */
2034 procnode = (PNODE)valueof_ptr(rptinfo->functab, procname);
2035 if (procnode) {
2036 enqueue_parse_error(_("Duplicate func %s (lines %d and %d) in report: %s")
2037 , procname, iline(procnode)+1, iline(nd_body)+1, pactx->fullpath);
2038 }
2039 /* consumes procname */
2040 procnode = fdef_node(pactx, procname, nd_args, nd_body);
2041 insert_table_ptr(rptinfo->functab, procname, procnode);
2042
2043 /* add to global proc table */
2044 list = (LIST)valueof_obj(gfunctab, procname);
2045 if (!list) {
2046 list = create_list2(LISTNOFREE);
2047 insert_table_obj(gfunctab, procname, list);
2048 release_list(list); /* now table owns list */
2049 }
2050 enqueue_list(list, procnode);
2051 }
2052 /*=============================================+
2053 * parse_error -- handle bison parse error
2054 * pactx: [I/O] pointer to parseinfo structure (parse globals)
2055 * ploc: [IN] token location
2056 * node: [IN] current parse node
2057 *=============================================*/
2058 void
parse_error(PACTX pactx,STRING str)2059 parse_error (PACTX pactx, STRING str)
2060 {
2061 /* TO DO - how to pass current pnode ? */
2062 prog_error(NULL, "Syntax Error (%s): %s: line %d, char %d\n"
2063 , str, pactx->fullpath, pactx->lineno+1, pactx->charpos+1);
2064 Perrors++;
2065 }
2066 /*=============================================+
2067 * check_rpt_requires -- check any prerequisites for
2068 * this report file -- return desc. string if fail
2069 *=============================================*/
2070 static STRING
check_rpt_requires(PACTX pactx,STRING fullpath)2071 check_rpt_requires (PACTX pactx, STRING fullpath)
2072 {
2073 TABLE tab = (TABLE)valueof_obj(pactx->filetab, fullpath);
2074 STRING str;
2075 STRING propstr = "requires_lifelines-reports.version:";
2076 INT ours=0, desired=0;
2077 STRING optr=LIFELINES_REPORTS_VERSION;
2078 STRING dptr=0;
2079 if (!tab)
2080 return 0;
2081 str = valueof_str(tab, propstr);
2082 if (str) {
2083 dptr=str+strlen(propstr)-strlen("requires_");
2084 while (1) {
2085 ours=0;
2086 desired=0;
2087 while (optr[0] && !isdigit(optr[0]))
2088 ++optr;
2089 while (dptr[0] && !isdigit(dptr[0]))
2090 ++dptr;
2091 if (!optr[0] && !dptr[0])
2092 return 0;
2093 /* no UTF-8 allowed here, only regular digits */
2094 while (isdigit(optr[0]))
2095 ours = ours*10 + (*optr++ -'0');
2096 while (isdigit(dptr[0]))
2097 desired = desired*10 + (*dptr++ - '0');
2098 if (desired > ours)
2099 return _("This report requires a newer program to run\n");
2100 if (desired < ours)
2101 return 0;
2102 /* else equal, continue to minor version blocks */
2103 }
2104 }
2105 return 0;
2106 }
2107 /*=============================================+
2108 * enqueue_parse_error -- Queue up a parsing error
2109 * for display after parsing complete
2110 * (this is fatal; it will prevent report execution)
2111 * Created: 2002/11/30 (Perry Rapp)
2112 *=============================================*/
2113 static void
enqueue_parse_error(const char * fmt,...)2114 enqueue_parse_error (const char * fmt, ...)
2115 {
2116 char buffer[512];
2117 va_list args;
2118 va_start(args, fmt);
2119
2120 if (!outstanding_parse_errors) {
2121 outstanding_parse_errors = create_list2(LISTDOFREE);
2122 }
2123 llstrsetvf(buffer, sizeof(buffer), 0, fmt, args);
2124 va_end(args);
2125 enqueue_list(outstanding_parse_errors, strsave(buffer));
2126 }
2127
2128 /*=============================================+
2129 * get_report_error_message - Return error message
2130 * for display during signal processing
2131 * Created: 2003/07/01 (Matt Emmerton)
2132 *=============================================*/
2133 ZSTR
get_report_error_msg(STRING msg)2134 get_report_error_msg (STRING msg)
2135 {
2136 ZSTR zstr=0;
2137
2138 if (progrunning) {
2139 char line[20];
2140 snprintf(line, sizeof(line), "%ld", iline(Pnode)+1);
2141 zstr = zprintpic2(_(msg), irptinfo(Pnode)->fullpath, line);
2142 }
2143 return zstr;
2144 }
2145 /*=============================================+
2146 * clean_orphaned_rptlocks - Clean up any locks on
2147 * records that report didn't unlock
2148 *=============================================*/
2149 static
clean_orphaned_rptlocks(void)2150 void clean_orphaned_rptlocks (void)
2151 {
2152 int ct = free_all_rprtlocks();
2153 if (ct) {
2154 char msg[256];
2155 sprintf(msg, _pl("Program forgot to unlock %d record",
2156 "Program forgot to unlock %d records", ct), ct);
2157 progmessage(MSG_ERROR, msg);
2158
2159 }
2160 }
2161