1 /*
2 * gretl -- Gnu Regression, Econometrics and Time-series Library
3 * Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
4 *
5 * This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 *
18 */
19
20 #define FULL_XML_HEADERS
21
22 #include "libgretl.h"
23 #include "version.h"
24 #include "monte_carlo.h"
25 #include "gretl_func.h"
26 #include "libset.h"
27 #include "usermat.h"
28 #include "gretl_xml.h"
29 #include "cmd_private.h"
30 #include "gretl_string_table.h"
31 #include "gretl_typemap.h"
32 #include "gretl_zip.h"
33 #include "uservar.h"
34 #include "flow_control.h"
35 #include "system.h"
36 #include "genparse.h"
37 #include "genr_optim.h"
38
39 #ifdef HAVE_MPI
40 # include "gretl_mpi.h"
41 #endif
42
43 #include <errno.h>
44 #include <glib.h>
45 #include <glib/gstdio.h>
46
47 #include <sys/types.h>
48 #include <sys/stat.h>
49 #include <fcntl.h>
50
51 #define MINIMAL_SETVARS 1 /* activated 2021-02-07 */
52 #define STRICT_CONST 1 /* activated 2021-04-08 */
53
54 #define LSDEBUG 0 /* debug handling of saved loops */
55 #define FNPARSE_DEBUG 0 /* debug parsing of function code */
56 #define EXEC_DEBUG 0 /* debugging of function execution */
57 #define UDEBUG 0 /* debug handling of args */
58 #define PKG_DEBUG 0 /* debug handling of function packages */
59 #define FN_DEBUG 0 /* miscellaneous debugging */
60 #define DDEBUG 0 /* debug the debugger */
61
62 #define INT_USE_XLIST (-999)
63 #define INT_USE_MYLIST (-777)
64
65 typedef struct fn_param_ fn_param;
66 typedef struct fn_arg_ fn_arg;
67 typedef struct fn_line_ fn_line;
68 typedef struct obsinfo_ obsinfo;
69
70 enum {
71 FP_CONST = 1 << 0,
72 FP_OPTIONAL = 1 << 1
73 };
74
75 /* structure representing a parameter of a user-defined function */
76
77 struct fn_param_ {
78 char *name; /* the name of the parameter */
79 char type; /* its type */
80 char *descrip; /* its description */
81 char **labels; /* value labels, if applicable */
82 int nlabels; /* number of value labels */
83 char flags; /* additional information (e.g. "const" flag) */
84 double deflt; /* default value */
85 double min; /* minimum value (scalar parameters only) */
86 double max; /* maximum value (scalar parameters only) */
87 double step; /* step increment (scalars only) */
88 char immut; /* state: immutable (const) at run-time */
89 };
90
91 /* structure representing a line of a user-defined function */
92
93 struct fn_line_ {
94 int idx; /* 1-based line index (allowing for blanks) */
95 char *s; /* text of command line */
96 LOOPSET *loop; /* attached "compiled" loop */
97 int next_idx; /* line index to skip to after loop */
98 int ignore; /* flag for comment lines */
99 };
100
101 #define UNSET_VALUE (-1.0e200)
102 #define default_unset(p) (p->deflt == UNSET_VALUE)
103
104 /* structure representing sample information at start of
105 a function call */
106
107 struct obsinfo_ {
108 int structure; /* time-series, etc. */
109 int pd; /* data frequency */
110 int t1, t2; /* starting and ending observations */
111 int added; /* number of observations added within function */
112 char changed; /* sample has been changed within the function call? */
113 char stobs[OBSLEN]; /* string representation of starting obs */
114 };
115
116 /* structure representing a call to a user-defined function */
117
118 typedef enum {
119 FC_RECURSING = 1 << 0,
120 FC_PREV_MSGS = 1 << 1,
121 FC_PREV_ECHO = 1 << 2,
122 FC_PRESERVE = 1 << 3
123 } FCFlags;
124
125 /* Note: the FC_PRESERVE flag is specific to the case of
126 overloaded functions whose return type is 'numeric'.
127 In that case the caller doesn't know in advance what
128 specific type to expect, and needs to be able to access
129 the function-call struct (fncall) to determine the type.
130 Therefore, the fncall must not be destroyed when
131 execution terminates (as usual). The caller then takes
132 on responsibility for destroying the call. The only
133 relevant caller is eval_ufunc(), in geneval.c.
134 */
135
136 struct fncall_ {
137 ufunc *fun; /* the function called */
138 int argc; /* argument count */
139 int orig_v; /* number of series defined on entry */
140 fn_arg *args; /* argument array */
141 int *ptrvars; /* list of pointer arguments */
142 int *listvars; /* list of series included in a list argument */
143 GList *lists; /* list of names of list arguments */
144 char *retname; /* name of return value (or dummy string) */
145 GretlType rtype; /* return type (when not fixed in advance) */
146 obsinfo obs; /* sample info */
147 FCFlags flags; /* indicators for recursive call, etc */
148 };
149
150 /* structure representing a user-defined function */
151
152 struct ufunc_ {
153 char name[FN_NAMELEN]; /* identifier */
154 fnpkg *pkg; /* pointer to parent package, or NULL */
155 int pkg_role; /* printer, plotter, etc. */
156 UfunAttrs flags; /* private, plugin, etc. */
157 int line_idx; /* current line index (compiling) */
158 int n_lines; /* number of lines of code */
159 fn_line *lines; /* array of lines of code */
160 int n_params; /* number of parameters */
161 fn_param *params; /* parameter info array */
162 int rettype; /* return type (if any) */
163 int debug; /* are we debugging this function? */
164 };
165
166 /* structure representing a function package */
167
168 struct fnpkg_ {
169 char name[FN_NAMELEN]; /* package name */
170 char *fname; /* filename */
171 char *author; /* author's name */
172 char *email; /* author's email address */
173 char *version; /* package version string */
174 char *date; /* last revision date */
175 char *descrip; /* package description */
176 char *help; /* package help text */
177 char *gui_help; /* GUI-specific help (optional) */
178 char *Rdeps; /* R dependencies (if any) */
179 char *sample; /* sample caller script */
180 char *help_fname; /* filename: package help text */
181 char *gui_help_fname; /* filename: GUI-specific help text */
182 char *sample_fname; /* filename: sample caller script */
183 char *tags; /* tag string(s) */
184 char *label; /* for use in GUI menus */
185 char *mpath; /* menu path in GUI */
186 int minver; /* minimum required gretl version */
187 char uses_subdir; /* lives in subdirectory (0/1) */
188 char prechecked; /* already checked for data requirement */
189 char data_access; /* wants access to full data range */
190 DataReq dreq; /* data requirement */
191 int modelreq; /* required model type, if applicable */
192 ufunc **pub; /* pointers to public interfaces */
193 ufunc **priv; /* pointers to private functions */
194 int n_pub; /* number of public functions */
195 int n_priv; /* number of private functions */
196 char overrides; /* number of overrides of built-in functions */
197 char **datafiles; /* names of packaged data files */
198 char **depends; /* names of dependencies */
199 char *provider; /* name of "provider" package, if applicable */
200 int n_files; /* number of data files */
201 int n_depends; /* number of dependencies */
202 void *editor; /* for GUI use */
203 };
204
205 /* acceptable types for parameters of user-defined functions */
206
207 #define ok_function_arg_type(t) (t == GRETL_TYPE_BOOL || \
208 t == GRETL_TYPE_INT || \
209 t == GRETL_TYPE_OBS || \
210 t == GRETL_TYPE_DOUBLE || \
211 t == GRETL_TYPE_SERIES || \
212 t == GRETL_TYPE_LIST || \
213 t == GRETL_TYPE_MATRIX || \
214 t == GRETL_TYPE_STRING || \
215 t == GRETL_TYPE_BUNDLE || \
216 t == GRETL_TYPE_SCALAR_REF || \
217 t == GRETL_TYPE_SERIES_REF || \
218 t == GRETL_TYPE_MATRIX_REF || \
219 t == GRETL_TYPE_BUNDLE_REF || \
220 t == GRETL_TYPE_STRING_REF || \
221 t == GRETL_TYPE_STRINGS || \
222 t == GRETL_TYPE_MATRICES || \
223 t == GRETL_TYPE_BUNDLES|| \
224 t == GRETL_TYPE_LISTS || \
225 t == GRETL_TYPE_ARRAYS || \
226 t == GRETL_TYPE_STRINGS_REF || \
227 t == GRETL_TYPE_MATRICES_REF || \
228 t == GRETL_TYPE_BUNDLES_REF || \
229 t == GRETL_TYPE_LISTS_REF || \
230 t == GRETL_TYPE_ARRAYS_REF || \
231 t == GRETL_TYPE_NUMERIC)
232
233 /* structure representing an argument to a user-defined function */
234
235 struct fn_arg_ {
236 char type; /* argument type */
237 char shifted; /* level was shifted for execution */
238 const char *upname; /* name of supplied arg at caller level */
239 user_var *uvar; /* reference to "parent", if any */
240 union {
241 int idnum; /* named series arg (series ID) */
242 double x; /* scalar arg */
243 double *px; /* anonymous series arg */
244 gretl_matrix *m; /* matrix arg */
245 char *str; /* string arg */
246 int *list; /* list arg */
247 gretl_bundle *b; /* anonymous bundle pointer */
248 gretl_array *a; /* array argument */
249 } val;
250 };
251
252 static int n_ufuns; /* number of user-defined functions in memory */
253 static ufunc **ufuns; /* array of pointers to user-defined functions */
254 static ufunc *current_fdef; /* pointer to function currently being defined */
255 static GList *callstack; /* stack of function calls */
256 static int n_pkgs; /* number of loaded function packages */
257 static fnpkg **pkgs; /* array of pointers to loaded packages */
258 static fnpkg *current_pkg; /* pointer to package currently being edited */
259
260 static int function_package_record (fnpkg *pkg);
261 static void function_package_free (fnpkg *pkg);
262 static int load_function_package (const char *fname,
263 gretlopt opt,
264 GArray *pstack,
265 PRN *prn);
266
267 /* record of state, and communication of state with outside world */
268
269 static int compiling; /* boolean: are we compiling a function currently? */
270 static int fn_executing; /* depth of function call stack */
271 static int compiling_python;
272 #ifdef HAVE_MPI
273 static char mpi_caller[FN_NAMELEN];
274 #endif
275
276 #define function_is_private(f) (f->flags & UFUN_PRIVATE)
277 #define function_is_plugin(f) (f->flags & UFUN_PLUGIN)
278 #define function_is_noprint(f) (f->flags & UFUN_NOPRINT)
279 #define function_is_menu_only(f) (f->flags & UFUN_MENU_ONLY)
280
281 #define set_call_recursing(c) (c->flags |= FC_RECURSING)
282 #define unset_call_recursing(c) (c->flags &= ~FC_RECURSING)
283 #define is_recursing(c) (c->flags & FC_RECURSING)
284
285 struct flag_and_key {
286 int flag;
287 const char *key;
288 };
289
290 static struct flag_and_key pkg_lookups[] = {
291 { UFUN_BUNDLE_PRINT, BUNDLE_PRINT },
292 { UFUN_BUNDLE_PLOT, BUNDLE_PLOT },
293 { UFUN_BUNDLE_TEST, BUNDLE_TEST },
294 { UFUN_BUNDLE_FCAST, BUNDLE_FCAST },
295 { UFUN_BUNDLE_EXTRA, BUNDLE_EXTRA },
296 { UFUN_GUI_MAIN, GUI_MAIN },
297 { UFUN_GUI_PRECHECK, GUI_PRECHECK },
298 { UFUN_LIST_MAKER, LIST_MAKER },
299 { -1, NULL }
300 };
301
302 #define pkg_aux_role(r) (r == UFUN_BUNDLE_PRINT || \
303 r == UFUN_BUNDLE_PLOT || \
304 r == UFUN_BUNDLE_TEST || \
305 r == UFUN_BUNDLE_FCAST || \
306 r == UFUN_BUNDLE_EXTRA)
307
pkg_key_get_role(const char * key)308 static int pkg_key_get_role (const char *key)
309 {
310 int i;
311
312 if (key != NULL && *key != '\0') {
313 for (i=0; pkg_lookups[i].flag > 0; i++) {
314 if (!strcmp(key, pkg_lookups[i].key)) {
315 return pkg_lookups[i].flag;
316 }
317 }
318 }
319
320 return UFUN_ROLE_NONE;
321 }
322
package_role_get_key(int flag)323 const char *package_role_get_key (int flag)
324 {
325 int i;
326
327 for (i=0; pkg_lookups[i].flag > 0; i++) {
328 if (flag == pkg_lookups[i].flag) {
329 return pkg_lookups[i].key;
330 }
331 }
332
333 return NULL;
334 }
335
set_function_private(ufunc * u,gboolean s)336 static void set_function_private (ufunc *u, gboolean s)
337 {
338 if (s) {
339 u->flags |= UFUN_PRIVATE;
340 } else {
341 u->flags &= ~UFUN_PRIVATE;
342 }
343 }
344
gretl_compiling_function(void)345 int gretl_compiling_function (void)
346 {
347 return compiling;
348 }
349
gretl_compiling_python(const char * line)350 int gretl_compiling_python (const char *line)
351 {
352 if (compiling_python) {
353 char s1[4], s2[8];
354
355 if (sscanf(line, "%3s %7s", s1, s2) == 2 &&
356 !strcmp(s1, "end") && !strcmp(s2, "foreign")) {
357 compiling_python = 0;
358 }
359 }
360
361 return compiling_python;
362 }
363
set_compiling_on(void)364 static void set_compiling_on (void)
365 {
366 compiling = 1;
367 }
368
set_compiling_off(void)369 static void set_compiling_off (void)
370 {
371 compiling = compiling_python = 0;
372 }
373
gretl_function_depth(void)374 int gretl_function_depth (void)
375 {
376 return fn_executing;
377 }
378
adjust_array_arg_type(fn_arg * arg)379 static void adjust_array_arg_type (fn_arg *arg)
380 {
381 GretlType t = gretl_array_get_type(arg->val.a);
382
383 if (arg->type == GRETL_TYPE_ARRAY_REF) {
384 arg->type = gretl_type_get_ref_type(t);
385 } else {
386 arg->type = t;
387 }
388 }
389
fn_arg_set_data(fn_arg * arg,const char * name,user_var * uvar,GretlType type,void * p)390 static int fn_arg_set_data (fn_arg *arg, const char *name,
391 user_var *uvar, GretlType type,
392 void *p)
393 {
394 int err = 0;
395
396 arg->type = type;
397 arg->shifted = 0;
398 arg->upname = name;
399 arg->uvar = uvar;
400
401 if (type == GRETL_TYPE_NONE) {
402 arg->val.x = 0;
403 } else if (type == GRETL_TYPE_DOUBLE ||
404 type == GRETL_TYPE_SCALAR_REF) {
405 arg->val.x = *(double *) p;
406 } else if (type == GRETL_TYPE_INT ||
407 type == GRETL_TYPE_OBS) {
408 arg->val.x = *(int *) p;
409 } else if (type == GRETL_TYPE_SERIES) {
410 arg->val.px = (double *) p;
411 } else if (type == GRETL_TYPE_MATRIX ||
412 type == GRETL_TYPE_MATRIX_REF) {
413 arg->val.m = (gretl_matrix *) p;
414 } else if (type == GRETL_TYPE_STRING ||
415 type == GRETL_TYPE_STRING_REF) {
416 arg->val.str = (char *) p;
417 } else if (type == GRETL_TYPE_LIST) {
418 arg->val.list = (int *) p;
419 } else if (type == GRETL_TYPE_SERIES_REF ||
420 type == GRETL_TYPE_USERIES) {
421 arg->val.idnum = *(int *) p;
422 } else if (type == GRETL_TYPE_BUNDLE ||
423 type == GRETL_TYPE_BUNDLE_REF) {
424 arg->val.b = (gretl_bundle *) p;
425 } else if (type == GRETL_TYPE_ARRAY ||
426 type == GRETL_TYPE_ARRAY_REF) {
427 arg->val.a = (gretl_array *) p;
428 adjust_array_arg_type(arg);
429 } else {
430 err = E_TYPES;
431 }
432
433 return err;
434 }
435
fncall_add_args_array(fncall * fc)436 static int fncall_add_args_array (fncall *fc)
437 {
438 int i, np = fc->fun->n_params;
439 int err = 0;
440
441 fc->args = malloc(np * sizeof *fc->args);
442
443 if (fc->args == NULL) {
444 err = E_ALLOC;
445 } else {
446 for (i=0; i<np; i++) {
447 fc->args[i].type = 0;
448 fc->args[i].shifted = 0;
449 fc->args[i].upname = NULL;
450 fc->args[i].uvar = NULL;
451 }
452 }
453
454 return err;
455 }
456
maybe_set_param_const(fn_param * fp)457 static void maybe_set_param_const (fn_param *fp)
458 {
459 #if STRICT_CONST
460 fp->flags |= FP_CONST;
461 #else
462 if (fp->type != GRETL_TYPE_LIST &&
463 !gretl_is_scalar_type(fp->type)) {
464 fp->flags |= FP_CONST;
465 }
466 #endif
467 }
468
469 /**
470 * push_function_arg:
471 * @fc: pointer to function call.
472 * @name: name of variable (or NULL for anonymous).
473 * @uvar: reference to user_var or NULL.
474 * @type: type of argument to add.
475 * @value: pointer to value to add.
476 *
477 * Writes a new argument of the specified type and value into the
478 * argument array of @fc.
479 *
480 * Returns: 0 on success, non-zero on failure.
481 */
482
push_function_arg(fncall * fc,const char * name,void * uvar,GretlType type,void * value)483 int push_function_arg (fncall *fc, const char *name,
484 void *uvar, GretlType type,
485 void *value)
486 {
487 int err = 0;
488
489 if (fc == NULL || fc->fun == NULL) {
490 err = E_DATA;
491 } else if (fc->argc >= fc->fun->n_params) {
492 fprintf(stderr, "function %s has %d parameters but argc = %d\n",
493 fc->fun->name, fc->fun->n_params, fc->argc);
494 err = E_DATA;
495 } else if (fc->args == NULL) {
496 err = fncall_add_args_array(fc);
497 }
498
499 if (!err) {
500 err = fn_arg_set_data(&fc->args[fc->argc], name, uvar, type, value);
501 fc->argc += 1;
502 }
503
504 return err;
505 }
506
507 /**
508 * push_anon_function_arg:
509 * @fc: pointer to function call.
510 * @type: type of argument to add.
511 * @value: pointer to value to add.
512 *
513 * Writes a new argument of the specified type and value into the
514 * argument array of @fc.
515 *
516 * Returns: 0 on success, non-zero on failure.
517 */
518
push_anon_function_arg(fncall * fc,GretlType type,void * value)519 int push_anon_function_arg (fncall *fc, GretlType type,
520 void *value)
521 {
522 int err = 0;
523
524 if (fc == NULL || fc->fun == NULL) {
525 err = E_DATA;
526 } else if (fc->argc >= fc->fun->n_params) {
527 fprintf(stderr, "function %s has %d parameters but argc = %d\n",
528 fc->fun->name, fc->fun->n_params, fc->argc);
529 err = E_DATA;
530 } else if (fc->args == NULL) {
531 err = fncall_add_args_array(fc);
532 }
533
534 if (!err) {
535 err = fn_arg_set_data(&fc->args[fc->argc], NULL, NULL, type, value);
536 fc->argc += 1;
537 }
538
539 return err;
540 }
541
542 /**
543 * push_function_args:
544 * @fc: pointer to function call.
545 *
546 * Writes multiple entries into the argument array of @fc.
547 * Each argument must be given in the form {type, value},
548 * The list of entries must be terminated with -1.
549 *
550 * Returns: 0 on success, non-zero on failure.
551 */
552
push_function_args(fncall * fc,...)553 int push_function_args (fncall *fc, ...)
554 {
555 va_list ap;
556 int argtype;
557 void *value;
558 int i, err = 0;
559
560 va_start(ap, fc);
561 for (i=0; !err; i++) {
562 argtype = va_arg(ap, int);
563 if (argtype < 0) {
564 /* reached the end of the args */
565 break;
566 }
567 value = va_arg(ap, void *);
568 err = push_function_arg(fc, NULL, NULL, argtype, value);
569 }
570 va_end(ap);
571
572 return err;
573 }
574
575 /* fncall_new: if @preserve is non-zero, we don't destroy
576 the fncall struct automatically on completion of
577 function execution -- in which case the caller of this
578 function is responsible for calling fncall_destroy()
579 at a suitable point in the proceedings.
580 */
581
fncall_new(ufunc * fun,int preserve)582 fncall *fncall_new (ufunc *fun, int preserve)
583 {
584 fncall *call = malloc(sizeof *call);
585
586 if (call != NULL) {
587 call->fun = fun;
588 call->ptrvars = NULL;
589 call->listvars = NULL;
590 call->lists = NULL;
591 call->retname = NULL;
592 call->rtype = fun->rettype;
593 call->argc = 0;
594 call->args = NULL;
595 call->flags = preserve ? FC_PRESERVE : 0;
596 }
597
598 return call;
599 }
600
fncall_destroy(fncall * call)601 void fncall_destroy (fncall *call)
602 {
603 if (call != NULL) {
604 free(call->args);
605 free(call->ptrvars);
606 free(call->listvars);
607 free(call->retname);
608 g_list_free(call->lists);
609 free(call);
610 }
611 }
612
maybe_destroy_fncall(fncall * call)613 static void maybe_destroy_fncall (fncall *call)
614 {
615 if (call != NULL && !(call->flags & FC_PRESERVE)) {
616 fncall_destroy(call);
617 }
618 }
619
620 /* For use with overloaded functions whose return type is
621 'numeric'. The specific return type is not known
622 until execution is completed; we can supply it here.
623 */
624
fncall_get_return_type(fncall * call)625 GretlType fncall_get_return_type (fncall *call)
626 {
627 if (call != NULL) {
628 return call->rtype;
629 }
630
631 return GRETL_TYPE_NONE;
632 }
633
634 /* Portmanteau function to get a caller struct for a
635 function named @funcname from a function package
636 named @pkgname. We first check if the specified package
637 is already in memory; if not we try to find it in
638 the local filesystem, and load it into memory if
639 successful.
640
641 If/once the package is in fact loaded we look up the
642 specified function; and if that's successful we
643 allocate a caller struct and return it.
644
645 The @pkgpath argument can be given as NULL, but if
646 the path to the package is known to the caller and
647 is provided via this argument this will speed up the
648 look-up in case the package is not already loaded.
649 */
650
get_pkg_function_call(const char * funcname,const char * pkgname,const char * pkgpath)651 fncall *get_pkg_function_call (const char *funcname,
652 const char *pkgname,
653 const char *pkgpath)
654 {
655 fncall *fc = NULL;
656 ufunc *uf = NULL;
657 fnpkg *pkg;
658
659 /* is the package already loaded? */
660 pkg = get_function_package_by_name(pkgname);
661 if (pkg == NULL) {
662 /* no, so look it up */
663 int err = 0;
664
665 if (pkgpath != NULL) {
666 /* path was supplied by caller */
667 pkg = get_function_package_by_filename(pkgpath, &err);
668 } else {
669 /* we need to search */
670 char *mypath;
671
672 mypath = gretl_function_package_get_path(pkgname, PKG_ALL);
673 if (mypath != NULL) {
674 pkg = get_function_package_by_filename(mypath, &err);
675 free(mypath);
676 }
677 }
678 }
679
680 if (pkg != NULL) {
681 uf = get_function_from_package(funcname, pkg);
682 }
683
684 if (uf == NULL) {
685 gretl_errmsg_sprintf(_("Couldn't find function %s"), funcname);
686 } else {
687 fc = fncall_new(uf, 0); /* FIXME second arg? */
688 }
689
690 return fc;
691 }
692
function_package_alloc(const char * fname)693 static fnpkg *function_package_alloc (const char *fname)
694 {
695 fnpkg *pkg = malloc(sizeof *pkg);
696
697 if (pkg == NULL) {
698 return NULL;
699 }
700
701 pkg->fname = gretl_strdup(fname);
702 if (pkg->fname == NULL) {
703 free(pkg);
704 return NULL;
705 }
706
707 #if PKG_DEBUG
708 fprintf(stderr, "function_package_alloc: fname='%s'\n", fname);
709 #endif
710
711 pkg->name[0] = '\0';
712 pkg->author = NULL;
713 pkg->email = NULL;
714 pkg->version = NULL;
715 pkg->date = NULL;
716 pkg->descrip = NULL;
717 pkg->help = NULL;
718 pkg->gui_help = NULL;
719 pkg->Rdeps = NULL;
720 pkg->sample = NULL;
721 pkg->help_fname = NULL;
722 pkg->gui_help_fname = NULL;
723 pkg->sample_fname = NULL;
724 pkg->tags = NULL;
725 pkg->label = NULL;
726 pkg->mpath = NULL;
727 pkg->dreq = FN_NEEDS_DATA;
728 pkg->modelreq = 0;
729 pkg->minver = 0;
730 pkg->uses_subdir = 0;
731 pkg->prechecked = 0;
732 pkg->data_access = 0;
733
734 pkg->pub = pkg->priv = NULL;
735 pkg->n_pub = pkg->n_priv = 0;
736 pkg->overrides = 0;
737 pkg->datafiles = NULL;
738 pkg->n_files = 0;
739 pkg->depends = NULL;
740 pkg->n_depends = 0;
741 pkg->provider = NULL;
742 pkg->editor = NULL;
743
744 return pkg;
745 }
746
747 /* For function call @call, set the 'listarg' status of any named
748 series provided to the called function via list arguments. This is
749 required for correct handling of namespaces.
750 */
751
set_listargs_from_call(fncall * call,DATASET * dset)752 static void set_listargs_from_call (fncall *call, DATASET *dset)
753 {
754 int i, vi;
755
756 if (dset == NULL) {
757 return;
758 }
759
760 for (i=1; i<dset->v; i++) {
761 series_unset_flag(dset, i, VAR_LISTARG);
762 }
763
764 if (call != NULL && call->listvars != NULL) {
765 for (i=1; i<=call->listvars[0]; i++) {
766 vi = call->listvars[i];
767 #if UDEBUG
768 fprintf(stderr, "setting listarg status on var %d (%s)\n",
769 vi, dset->varname[vi]);
770 #endif
771 series_set_flag(dset, vi, VAR_LISTARG);
772 }
773 }
774 }
775
set_executing_off(fncall * call,DATASET * dset,PRN * prn)776 static void set_executing_off (fncall *call, DATASET *dset, PRN *prn)
777 {
778 int dbg = gretl_debugging_on();
779 fncall *popcall = NULL;
780
781 destroy_option_params_at_level(fn_executing);
782 set_previous_depth(fn_executing);
783 fn_executing--;
784
785 callstack = g_list_remove(callstack, call);
786
787 #if EXEC_DEBUG
788 fprintf(stderr, "set_executing_off: removing call to %s, depth now %d\n",
789 call->fun->name, g_list_length(callstack));
790 #endif
791
792 if (dbg) {
793 pputs(prn, "*** ");
794 bufspace(gretl_function_depth(), prn);
795 pprintf(prn, "exiting function %s, ", call->fun->name);
796 }
797
798 maybe_destroy_fncall(call);
799
800 if (fn_executing > 0) {
801 GList *tmp = g_list_last(callstack);
802
803 popcall = tmp->data;
804 } else {
805 g_list_free(callstack);
806 callstack = NULL;
807 gretl_insert_builtin_string("pkgdir", NULL);
808 }
809
810 if (dset != NULL) {
811 set_listargs_from_call(popcall, dset);
812 }
813
814 if (popcall == NULL) {
815 /* returning to main */
816 switch_uservar_hash(0);
817 if (dset != NULL) {
818 series_ensure_level_zero(dset);
819 }
820 }
821
822 if (dbg) {
823 if (popcall != NULL) {
824 pprintf(prn, "returning to %s\n", popcall->fun->name);
825 } else {
826 pputs(prn, "returning to main\n");
827 }
828 }
829 }
830
831 /**
832 * n_user_functions:
833 *
834 * Returns: the number of hansl functions currently loaded in memory.
835 */
836
n_user_functions(void)837 int n_user_functions (void)
838 {
839 return n_ufuns;
840 }
841
842 /**
843 * n_free_functions:
844 *
845 * Returns: the number of functions loaded in memory
846 * that are not currently attached to any function package,
847 * and are therefore available for packaging.
848 */
849
n_free_functions(void)850 int n_free_functions (void)
851 {
852 int i, n = 0;
853
854 for (i=0; i<n_ufuns; i++) {
855 if (ufuns[i]->pkg == NULL) {
856 n++;
857 }
858 }
859
860 return n;
861 }
862
863 /**
864 * get_user_function_by_index:
865 * @idx: index number.
866 *
867 * Returns: pointer to the user-function that currently
868 * occupies (0-based) slot @idx in the array of loaded
869 * functions, or %NULL if @idx is out of bounds.
870 */
871
get_user_function_by_index(int idx)872 const ufunc *get_user_function_by_index (int idx)
873 {
874 return (idx < 0 || idx >= n_ufuns)? NULL : ufuns[idx];
875 }
876
877 /**
878 * fn_n_params:
879 * @fun: pointer to user-function.
880 *
881 * Returns: the number of parameters associated with @fun.
882 */
883
fn_n_params(const ufunc * fun)884 int fn_n_params (const ufunc *fun)
885 {
886 return fun->n_params;
887 }
888
889 /**
890 * fn_param_type:
891 * @fun: pointer to user-function.
892 * @i: 0-based parameter index.
893 *
894 * Returns: the type of parameter @i of function
895 * @fun.
896 */
897
fn_param_type(const ufunc * fun,int i)898 int fn_param_type (const ufunc *fun, int i)
899 {
900 return (i < 0 || i >= fun->n_params)? 0 :
901 fun->params[i].type;
902 }
903
904 /**
905 * fn_param_name:
906 * @fun: pointer to user-function.
907 * @i: 0-based parameter index.
908 *
909 * Returns: the name of parameter @i of function
910 * @fun.
911 */
912
fn_param_name(const ufunc * fun,int i)913 const char *fn_param_name (const ufunc *fun, int i)
914 {
915 return (i < 0 || i >= fun->n_params)? NULL :
916 fun->params[i].name;
917 }
918
919 /**
920 * fn_param_descrip:
921 * @fun: pointer to user-function.
922 * @i: 0-based parameter index.
923 *
924 * Returns: the description of parameter @i of function
925 * @fun (if any), otherwise %NULL.
926 */
927
fn_param_descrip(const ufunc * fun,int i)928 const char *fn_param_descrip (const ufunc *fun, int i)
929 {
930 return (i < 0 || i >= fun->n_params)? NULL :
931 fun->params[i].descrip;
932 }
933
934 /**
935 * fn_param_value_labels:
936 * @fun: pointer to user-function.
937 * @i: 0-based parameter index.
938 * @n: location to receive number of labels.
939 *
940 * Returns: the value-labels associated with parameter @i
941 * of function @fun (if any), otherwise %NULL.
942 */
943
fn_param_value_labels(const ufunc * fun,int i,int * n)944 const char **fn_param_value_labels (const ufunc *fun, int i,
945 int *n)
946 {
947 if (i >= 0 && i < fun->n_params) {
948 *n = fun->params[i].nlabels;
949 return (const char **) fun->params[i].labels;
950 } else {
951 *n = 0;
952 return NULL;
953 }
954 }
955
956 /**
957 * fn_param_has_default:
958 * @fun: pointer to user-function.
959 * @i: 0-based parameter index.
960 *
961 * Returns: 1 if the (scalar) parameter @i of function @fun
962 * (if any) has a default value set, otherwise 0.
963 */
964
fn_param_has_default(const ufunc * fun,int i)965 int fn_param_has_default (const ufunc *fun, int i)
966 {
967 if (i < 0 || i >= fun->n_params) {
968 return 0;
969 } else {
970 fn_param *fp = &fun->params[i];
971
972 return !default_unset(fp);
973 }
974 }
975
976 /**
977 * fn_param_default:
978 * @fun: pointer to user-function.
979 * @i: 0-based parameter index.
980 *
981 * Returns: the default value of (scalar) parameter @i of
982 * function @fun (if any), otherwise #NADBL.
983 */
984
fn_param_default(const ufunc * fun,int i)985 double fn_param_default (const ufunc *fun, int i)
986 {
987 if (i < 0 || i >= fun->n_params) {
988 return NADBL;
989 } else {
990 fn_param *fp = &fun->params[i];
991
992 return default_unset(fp)? NADBL : fp->deflt;
993 }
994 }
995
996 /**
997 * fn_param_minval:
998 * @fun: pointer to user-function.
999 * @i: 0-based parameter index.
1000 *
1001 * Returns: the minimum value of (scalar) parameter @i of
1002 * function @fun (if any), otherwise #NADBL.
1003 */
1004
fn_param_minval(const ufunc * fun,int i)1005 double fn_param_minval (const ufunc *fun, int i)
1006 {
1007 return (i < 0 || i >= fun->n_params)? NADBL :
1008 fun->params[i].min;
1009 }
1010
1011 /**
1012 * fn_param_maxval:
1013 * @fun: pointer to user-function.
1014 * @i: 0-based parameter index.
1015 *
1016 * Returns: the maximum value of (scalar) parameter @i of
1017 * function @fun (if any), otherwise #NADBL.
1018 */
1019
fn_param_maxval(const ufunc * fun,int i)1020 double fn_param_maxval (const ufunc *fun, int i)
1021 {
1022 return (i < 0 || i >= fun->n_params)? NADBL :
1023 fun->params[i].max;
1024 }
1025
1026 /**
1027 * fn_param_step:
1028 * @fun: pointer to user-function.
1029 * @i: 0-based parameter index.
1030 *
1031 * Returns: the step value for (scalar) parameter @i of
1032 * function @fun (if any), otherwise #NADBL.
1033 */
1034
fn_param_step(const ufunc * fun,int i)1035 double fn_param_step (const ufunc *fun, int i)
1036 {
1037 return (i < 0 || i >= fun->n_params)? NADBL :
1038 fun->params[i].step;
1039 }
1040
arg_may_be_optional(GretlType t)1041 static int arg_may_be_optional (GretlType t)
1042 {
1043 return gretl_ref_type(t) || gretl_is_array_type(t) ||
1044 t == GRETL_TYPE_SERIES ||
1045 t == GRETL_TYPE_MATRIX ||
1046 t == GRETL_TYPE_BUNDLE ||
1047 t == GRETL_TYPE_LIST ||
1048 t == GRETL_TYPE_STRING;
1049 }
1050
1051 /**
1052 * fn_param_optional:
1053 * @fun: pointer to user-function.
1054 * @i: 0-based parameter index.
1055 *
1056 * Returns: 1 if parameter @i of function @fun is optional,
1057 * otherwise 0.
1058 */
1059
fn_param_optional(const ufunc * fun,int i)1060 int fn_param_optional (const ufunc *fun, int i)
1061 {
1062 if (i < 0 || i >= fun->n_params) {
1063 return 0;
1064 }
1065
1066 return arg_may_be_optional(fun->params[i].type) &&
1067 (fun->params[i].flags & FP_OPTIONAL);
1068 }
1069
1070 /**
1071 * fn_param_uses_xlist:
1072 * @fun: pointer to user-function.
1073 * @i: 0-based parameter index.
1074 *
1075 * Returns: 1 if parameter @i of function @fun is
1076 * designed to select an integer based on a gretl
1077 * model's list of regressors, otherwise 0.
1078 */
1079
fn_param_uses_xlist(const ufunc * fun,int i)1080 int fn_param_uses_xlist (const ufunc *fun, int i)
1081 {
1082 if (i < 0 || i >= fun->n_params) {
1083 return 0;
1084 }
1085
1086 return (fun->params[i].type == GRETL_TYPE_INT &&
1087 fun->params[i].deflt == INT_USE_XLIST);
1088 }
1089
1090 /**
1091 * fn_param_uses_mylist:
1092 * @fun: pointer to user-function.
1093 * @i: 0-based parameter index.
1094 *
1095 * Returns: 1 if parameter @i of function @fun is
1096 * designed to select an integer based on a custom
1097 * list, constructed by the function, otherwise 0.
1098 */
1099
fn_param_uses_mylist(const ufunc * fun,int i)1100 int fn_param_uses_mylist (const ufunc *fun, int i)
1101 {
1102 if (i < 0 || i >= fun->n_params) {
1103 return 0;
1104 }
1105
1106 return (fun->params[i].type == GRETL_TYPE_INT &&
1107 fun->params[i].deflt == INT_USE_MYLIST);
1108 }
1109
1110 /**
1111 * user_func_get_return_type:
1112 * @fun: pointer to user-function.
1113 *
1114 * Returns: the return type of function @fun.
1115 */
1116
user_func_get_return_type(const ufunc * fun)1117 int user_func_get_return_type (const ufunc *fun)
1118 {
1119 if (fun == NULL) {
1120 return GRETL_TYPE_NONE;
1121 } else {
1122 return fun->rettype;
1123 }
1124 }
1125
1126 /**
1127 * user_func_is_noprint:
1128 * @fun: pointer to user-function.
1129 *
1130 * Returns: 1 if the function is not designed to print anything.
1131 */
1132
user_func_is_noprint(const ufunc * fun)1133 int user_func_is_noprint (const ufunc *fun)
1134 {
1135 if (fun == NULL) {
1136 return 0;
1137 } else {
1138 return function_is_noprint(fun);
1139 }
1140 }
1141
1142 /**
1143 * user_func_is_menu_only:
1144 * @fun: pointer to user-function.
1145 *
1146 * Returns: 1 if the function is not designed to be called
1147 * other than via a GUI menu.
1148 */
1149
user_func_is_menu_only(const ufunc * fun)1150 int user_func_is_menu_only (const ufunc *fun)
1151 {
1152 if (fun == NULL) {
1153 return 0;
1154 } else {
1155 return function_is_menu_only(fun);
1156 }
1157 }
1158
1159 /**
1160 * user_function_name_by_index:
1161 * @i: the position of a user-function in the array of
1162 * loaded functions.
1163 *
1164 * Returns: the name of the function, or %NULL if
1165 * @i is out of bounds.
1166 */
1167
user_function_name_by_index(int i)1168 const char *user_function_name_by_index (int i)
1169 {
1170 if (i >= 0 && i < n_ufuns) {
1171 return ufuns[i]->name;
1172 } else {
1173 return NULL;
1174 }
1175 }
1176
1177 /**
1178 * user_function_index_by_name:
1179 * @name: function name.
1180 * @pkg: reference function package, or NULL.
1181 *
1182 * Looks up the 0-based index of the named function
1183 * in the current array of user-functions. If @pkg is
1184 * non-NULL the search for @name is confined to functions
1185 * that belong to @pkg; otherwise the index of the first
1186 * match is returned.
1187 *
1188 * Returns: 0-based index or -1 on failure.
1189 */
1190
user_function_index_by_name(const char * name,fnpkg * pkg)1191 int user_function_index_by_name (const char *name,
1192 fnpkg *pkg)
1193 {
1194 int i;
1195
1196 for (i=0; i<n_ufuns; i++) {
1197 if ((pkg == NULL || ufuns[i]->pkg == pkg) &&
1198 !strcmp(name, ufuns[i]->name)) {
1199 return i;
1200 }
1201 }
1202
1203 return -1;
1204 }
1205
1206 static int fname_idx;
1207
function_names_init(void)1208 void function_names_init (void)
1209 {
1210 fname_idx = 0;
1211 }
1212
1213 /* Apparatus used in the GUI selector for composing a new function
1214 package, or editing an existing one. In the first case we want a
1215 list of names of currently unpackaged functions (and the @pkg
1216 argument should be NULL); in the second the list should include
1217 both unpackaged functions and those belonging to the package
1218 in question (specified via the @pkg arg).
1219
1220 The caller should first invoke function_names_init(), then keep
1221 calling next_available_function_name() until it returns %NULL. The
1222 pointer argument @idxp provides a means to grab the "index number"
1223 (position in the current functions array) corresponding to the
1224 returned function name.
1225 */
1226
next_available_function_name(fnpkg * pkg,int * idxp)1227 const char *next_available_function_name (fnpkg *pkg, int *idxp)
1228 {
1229 const char *ret = NULL;
1230 ufunc *fun;
1231
1232 if (n_ufuns == 0) {
1233 fname_idx = 0;
1234 return NULL;
1235 }
1236
1237 while (fname_idx < n_ufuns) {
1238 fun = ufuns[fname_idx++];
1239 if (fun->pkg == NULL || fun->pkg == pkg) {
1240 ret = fun->name;
1241 *idxp = fname_idx - 1;
1242 break;
1243 }
1244 }
1245
1246 return ret;
1247 }
1248
1249 /* end GUI function-name apparatus */
1250
current_function_call(void)1251 static fncall *current_function_call (void)
1252 {
1253 if (callstack != NULL) {
1254 GList *tmp = g_list_last(callstack);
1255
1256 return tmp->data;
1257 } else {
1258 return NULL;
1259 }
1260 }
1261
currently_called_function(void)1262 static ufunc *currently_called_function (void)
1263 {
1264 fncall *call = current_function_call();
1265
1266 return (call != NULL)? call->fun : NULL;
1267 }
1268
current_function_info(char const ** funcname,char const ** pkgname)1269 void current_function_info (char const **funcname,
1270 char const **pkgname)
1271 {
1272 ufunc *u = currently_called_function();
1273
1274 if (u != NULL) {
1275 if (funcname != NULL) {
1276 *funcname = u->name;
1277 }
1278 if (pkgname != NULL && u->pkg != NULL) {
1279 *pkgname = u->pkg->name;
1280 }
1281 }
1282 }
1283
get_active_function_package(gretlopt opt)1284 fnpkg *get_active_function_package (gretlopt opt)
1285 {
1286 ufunc *u = currently_called_function();
1287
1288 if (u != NULL && u->pkg != NULL) {
1289 if (opt == OPT_NONE) {
1290 return u->pkg;
1291 } else if ((opt & OPT_O) && u->pkg->overrides) {
1292 /* in this case we're only interested if the
1293 package overrides any built-in functions
1294 */
1295 return u->pkg;
1296 }
1297 }
1298
1299 return NULL;
1300 }
1301
gretl_function_get_package(const ufunc * fun)1302 fnpkg *gretl_function_get_package (const ufunc *fun)
1303 {
1304 return fun == NULL ? NULL : fun->pkg;
1305 }
1306
1307 /* see if a function is currently employed in the call stack */
1308
function_in_use(ufunc * fun)1309 static int function_in_use (ufunc *fun)
1310 {
1311 GList *tmp = callstack;
1312 fncall *call;
1313
1314 while (tmp != NULL) {
1315 call = tmp->data;
1316 if (fun == call->fun) {
1317 return 1;
1318 }
1319 tmp = tmp->next;
1320 }
1321
1322 return 0;
1323 }
1324
gretl_function_recursing(void)1325 int gretl_function_recursing (void)
1326 {
1327 if (callstack != NULL) {
1328 GList *tmp = g_list_last(callstack);
1329 fncall *call = tmp->data;
1330
1331 return is_recursing(call);
1332 } else {
1333 return 0;
1334 }
1335 }
1336
1337 #ifdef HAVE_MPI
1338
find_caller_package(const char * name)1339 static fnpkg *find_caller_package (const char *name)
1340 {
1341 fnpkg *pkg = NULL;
1342 int i;
1343
1344 for (i=0; i<n_ufuns; i++) {
1345 if (!strcmp(name, ufuns[i]->name)) {
1346 if (ufuns[i]->pkg != NULL) {
1347 ufuns[i]->pkg->prechecked = 1;
1348 pkg = ufuns[i]->pkg;
1349 }
1350 break;
1351 }
1352 }
1353
1354 return pkg;
1355 }
1356
1357 #endif
1358
1359 /**
1360 * get_user_function_by_name:
1361 * @name: name to test.
1362 *
1363 * Returns: pointer to a user-function, if there exists a
1364 * function of the given name and it is accessible in
1365 * context (i.e. it's not private to a package other than
1366 * the one that's currently active, if any), otherwise
1367 * %NULL.
1368 */
1369
get_user_function_by_name(const char * name)1370 ufunc *get_user_function_by_name (const char *name)
1371 {
1372 fnpkg *pkg = current_pkg;
1373 ufunc *fun = NULL;
1374 int i;
1375
1376 if (n_ufuns == 0) {
1377 return NULL;
1378 }
1379
1380 if (pkg == NULL) {
1381 fun = currently_called_function();
1382 if (fun != NULL) {
1383 pkg = fun->pkg;
1384 fun = NULL;
1385 }
1386 }
1387
1388 #ifdef HAVE_MPI
1389 if (pkg == NULL && *mpi_caller != '\0') {
1390 pkg = find_caller_package(mpi_caller);
1391 }
1392 #endif
1393
1394 if (pkg != NULL) {
1395 /* There's an active function package: try first
1396 for functions that belong to the package.
1397 */
1398 for (i=0; i<pkg->n_pub; i++) {
1399 /* public members */
1400 if (!strcmp(name, pkg->pub[i]->name)) {
1401 fun = pkg->pub[i];
1402 break;
1403 }
1404 }
1405 if (fun == NULL) {
1406 /* private members */
1407 for (i=0; i<pkg->n_priv; i++) {
1408 if (!strcmp(name, pkg->priv[i]->name)) {
1409 fun = pkg->priv[i];
1410 break;
1411 }
1412 }
1413 }
1414 if (fun == NULL && pkg->provider != NULL) {
1415 /* functions shared by provider */
1416 fnpkg *ppkg = get_function_package_by_name(pkg->provider);
1417
1418 if (ppkg != NULL) {
1419 for (i=0; i<ppkg->n_priv; i++) {
1420 if (!strcmp(name, ppkg->priv[i]->name)) {
1421 fun = ppkg->priv[i];
1422 break;
1423 }
1424 }
1425 }
1426 }
1427 }
1428
1429 if (fun == NULL) {
1430 /* Match any non-private function */
1431 for (i=0; i<n_ufuns; i++) {
1432 if (!function_is_private(ufuns[i]) &&
1433 !strcmp(name, ufuns[i]->name)) {
1434 fun = ufuns[i];
1435 break;
1436 }
1437 }
1438 }
1439
1440 #if FN_DEBUG > 1
1441 if (fun != NULL) {
1442 fprintf(stderr, "get_user_function_by_name: name = '%s' (n_ufuns = %d);"
1443 " found match\n", name, n_ufuns);
1444 }
1445 #endif
1446
1447 return fun;
1448 }
1449
1450 /**
1451 * get_function_from_package:
1452 * @funname: name of function to retrieve.
1453 * @pkg: function package.
1454 *
1455 * Returns: pointer to a user-function, if there exists a
1456 * function of the given @funname that is associated with
1457 * function package @pkg, otherwise NULL. This is used
1458 * in the gretl function package editor.
1459 */
1460
get_function_from_package(const char * funname,fnpkg * pkg)1461 ufunc *get_function_from_package (const char *funname, fnpkg *pkg)
1462 {
1463 int i;
1464
1465 for (i=0; i<n_ufuns; i++) {
1466 if (ufuns[i]->pkg == pkg &&
1467 !strcmp(funname, ufuns[i]->name)) {
1468 return ufuns[i];
1469 }
1470 }
1471
1472 return NULL;
1473 }
1474
1475 /* allocate and initialize a new array of @n parameters */
1476
allocate_params(int n)1477 static fn_param *allocate_params (int n)
1478 {
1479 fn_param *params;
1480 int i;
1481
1482 params = malloc(n * sizeof *params);
1483 if (params == NULL) {
1484 return NULL;
1485 }
1486
1487 for (i=0; i<n; i++) {
1488 params[i].name = NULL;
1489 params[i].type = 0;
1490 params[i].descrip = NULL;
1491 params[i].labels = NULL;
1492 params[i].nlabels = 0;
1493 params[i].flags = 0;
1494 params[i].deflt = UNSET_VALUE;
1495 params[i].min = NADBL;
1496 params[i].max = NADBL;
1497 params[i].step = NADBL;
1498 }
1499
1500 return params;
1501 }
1502
ufunc_new(void)1503 static ufunc *ufunc_new (void)
1504 {
1505 ufunc *fun = malloc(sizeof *fun);
1506
1507 if (fun == NULL) {
1508 return NULL;
1509 }
1510
1511 fun->name[0] = '\0';
1512 fun->pkg = NULL;
1513 fun->flags = 0;
1514 fun->pkg_role = 0;
1515
1516 fun->n_lines = 0;
1517 fun->line_idx = 1;
1518 fun->lines = NULL;
1519
1520 fun->n_params = 0;
1521 fun->params = NULL;
1522
1523 fun->rettype = GRETL_TYPE_NONE;
1524
1525 fun->debug = 0;
1526
1527 return fun;
1528 }
1529
free_lines_array(fn_line * lines,int n)1530 static void free_lines_array (fn_line *lines, int n)
1531 {
1532 int i;
1533
1534 if (lines == NULL) return;
1535
1536 for (i=0; i<n; i++) {
1537 free(lines[i].s);
1538 if (lines[i].loop != NULL) {
1539 gretl_loop_destroy(lines[i].loop);
1540 }
1541 }
1542
1543 free(lines);
1544 }
1545
free_params_array(fn_param * params,int n)1546 static void free_params_array (fn_param *params, int n)
1547 {
1548 int i;
1549
1550 if (params == NULL) return;
1551
1552 for (i=0; i<n; i++) {
1553 free(params[i].name);
1554 free(params[i].descrip);
1555 strings_array_free(params[i].labels, params[i].nlabels);
1556 }
1557 free(params);
1558 }
1559
clear_ufunc_data(ufunc * fun)1560 static void clear_ufunc_data (ufunc *fun)
1561 {
1562 free_lines_array(fun->lines, fun->n_lines);
1563 free_params_array(fun->params, fun->n_params);
1564
1565 fun->lines = NULL;
1566 fun->params = NULL;
1567
1568 fun->n_lines = 0;
1569 fun->line_idx = 1;
1570 fun->n_params = 0;
1571
1572 fun->rettype = GRETL_TYPE_NONE;
1573 }
1574
ufunc_free(ufunc * fun)1575 static void ufunc_free (ufunc *fun)
1576 {
1577 free_lines_array(fun->lines, fun->n_lines);
1578 free_params_array(fun->params, fun->n_params);
1579 free(fun);
1580 }
1581
add_allocated_ufunc(ufunc * fun)1582 static int add_allocated_ufunc (ufunc *fun)
1583 {
1584 int nf = n_ufuns;
1585 ufunc **myfuns;
1586
1587 myfuns = realloc(ufuns, (nf + 1) * sizeof *myfuns);
1588
1589 if (myfuns == NULL) {
1590 return E_ALLOC;
1591 }
1592
1593 ufuns = myfuns;
1594 ufuns[nf] = fun;
1595 n_ufuns++;
1596
1597 #if PKG_DEBUG
1598 fprintf(stderr, "add_allocated_ufunc: name '%s', n_ufuns = %d\n",
1599 fun->name, n_ufuns);
1600 #endif
1601
1602 return 0;
1603 }
1604
add_ufunc(const char * fname)1605 static ufunc *add_ufunc (const char *fname)
1606 {
1607 ufunc *fun = ufunc_new();
1608
1609 #if FN_DEBUG
1610 fprintf(stderr, "add_ufunc: '%s'\n", fname);
1611 #endif
1612
1613 if (fun != NULL) {
1614 strncat(fun->name, fname, FN_NAMELEN - 1);
1615 if (add_allocated_ufunc(fun)) {
1616 ufunc_free(fun);
1617 fun = NULL;
1618 }
1619 }
1620
1621 return fun;
1622 }
1623
no_scalar_default(fn_param * fp)1624 static int no_scalar_default (fn_param *fp)
1625 {
1626 int ret = 0;
1627
1628 if (default_unset(fp)) {
1629 ret = 1;
1630 } else if (fp->type != GRETL_TYPE_DOUBLE && na(fp->deflt)) {
1631 ret = 1;
1632 }
1633
1634 return ret;
1635 }
1636
1637 /* handling of XML function packages */
1638
1639 enum {
1640 FUNCS_INFO,
1641 FUNCS_LOAD,
1642 FUNCS_CODE,
1643 FUNCS_SAMPLE,
1644 FUNCS_HELP,
1645 FUNCS_QUERY
1646 };
1647
arg_type_xml_string(int t)1648 static const char *arg_type_xml_string (int t)
1649 {
1650 if (t == GRETL_TYPE_SCALAR_REF) {
1651 return "scalarref";
1652 } else if (t == GRETL_TYPE_SERIES_REF) {
1653 return "seriesref";
1654 } else if (t == GRETL_TYPE_MATRIX_REF) {
1655 return "matrixref";
1656 } else if (t == GRETL_TYPE_BUNDLE_REF) {
1657 return "bundleref";
1658 } else if (t == GRETL_TYPE_STRING_REF) {
1659 return "stringref";
1660 } else if (t == GRETL_TYPE_STRINGS_REF) {
1661 return "stringsref";
1662 } else if (t == GRETL_TYPE_MATRICES_REF) {
1663 return "matricesref";
1664 } else if (t == GRETL_TYPE_BUNDLES_REF) {
1665 return "bundlesref";
1666 } else if (t == GRETL_TYPE_LISTS_REF) {
1667 return "listsref"; /* not actually allowed */
1668 } else {
1669 return gretl_type_get_name(t);
1670 }
1671 }
1672
return_type_from_string(const char * s,int * err)1673 static GretlType return_type_from_string (const char *s,
1674 int *err)
1675 {
1676 GretlType t;
1677
1678 if (!strcmp(s, "void")) {
1679 /* not OK as arg type, but OK as return */
1680 t = GRETL_TYPE_VOID;
1681 } else {
1682 t = gretl_type_from_string(s);
1683 }
1684
1685 if (!ok_function_return_type(t)) {
1686 if (*s == '\0') {
1687 gretl_errmsg_sprintf(_("Missing function return type"));
1688 } else if (t == GRETL_TYPE_NONE) {
1689 gretl_errmsg_sprintf(_("Expected a function return type, found '%s'"),
1690 s);
1691 } else {
1692 gretl_errmsg_sprintf(_("%s: invalid return type for function"),
1693 s);
1694 }
1695 *err = E_TYPES;
1696 }
1697
1698 return t;
1699 }
1700
param_field_to_type(const char * s,const char * funname,int * err)1701 static GretlType param_field_to_type (const char *s,
1702 const char *funname,
1703 int *err)
1704 {
1705 GretlType t = gretl_type_from_string(s);
1706
1707 if (!ok_function_arg_type(t)) {
1708 gretl_errmsg_sprintf("function %s: invalid parameter type '%s'",
1709 funname, s);
1710 *err = E_INVARG;
1711 }
1712
1713 return t;
1714 }
1715
1716 /* read the parameter info for a function from XML file */
1717
func_read_params(xmlNodePtr node,xmlDocPtr doc,ufunc * fun)1718 static int func_read_params (xmlNodePtr node, xmlDocPtr doc,
1719 ufunc *fun)
1720 {
1721 xmlNodePtr cur;
1722 char *field;
1723 int n, err = 0;
1724
1725 if (!gretl_xml_get_prop_as_int(node, "count", &n) || n < 0) {
1726 fprintf(stderr, "Couldn't read param count\n");
1727 return E_DATA;
1728 }
1729
1730 if (n == 0) {
1731 return 0;
1732 }
1733
1734 fun->params = allocate_params(n);
1735 if (fun->params == NULL) {
1736 return E_ALLOC;
1737 }
1738
1739 fun->n_params = n;
1740
1741 gretl_push_c_numeric_locale();
1742
1743 cur = node->xmlChildrenNode;
1744 n = 0;
1745
1746 while (cur != NULL && !err) {
1747 if (!xmlStrcmp(cur->name, (XUC) "param")) {
1748 fn_param *param = &fun->params[n++];
1749
1750 if (gretl_xml_get_prop_as_string(cur, "name", &field)) {
1751 param->name = field;
1752 } else {
1753 err = E_DATA;
1754 break;
1755 }
1756 if (gretl_xml_get_prop_as_string(cur, "type", &field)) {
1757 param->type = param_field_to_type(field, fun->name, &err);
1758 free(field);
1759 if (gretl_scalar_type(param->type)) {
1760 double x;
1761
1762 if (gretl_xml_get_prop_as_double(cur, "default", &x)) {
1763 param->deflt = x;
1764 } else {
1765 param->deflt = UNSET_VALUE;
1766 }
1767 if (param->type != GRETL_TYPE_BOOL) {
1768 gretl_xml_get_prop_as_double(cur, "min", ¶m->min);
1769 gretl_xml_get_prop_as_double(cur, "max", ¶m->max);
1770 gretl_xml_get_prop_as_double(cur, "step", ¶m->step);
1771 }
1772 }
1773 if (gretl_xml_get_prop_as_bool(cur, "optional")) {
1774 param->flags |= FP_OPTIONAL;
1775 }
1776 if (gretl_xml_get_prop_as_bool(cur, "const")) {
1777 maybe_set_param_const(param);
1778 }
1779 } else {
1780 err = E_DATA;
1781 break;
1782 }
1783 gretl_xml_child_get_string(cur, doc, "description",
1784 ¶m->descrip);
1785 gretl_xml_child_get_strings_array(cur, doc, "labels",
1786 ¶m->labels,
1787 ¶m->nlabels);
1788 }
1789 cur = cur->next;
1790 }
1791
1792 gretl_pop_c_numeric_locale();
1793
1794 if (!err && n != fun->n_params) {
1795 err = E_DATA;
1796 }
1797
1798 return err;
1799 }
1800
push_function_line(ufunc * fun,char * s,int donate)1801 static int push_function_line (ufunc *fun, char *s, int donate)
1802 {
1803 int err = 0;
1804
1805 if (string_is_blank(s)) {
1806 fun->line_idx += 1;
1807 } else {
1808 fn_line *lines;
1809 int n = fun->n_lines + 1;
1810
1811 lines = realloc(fun->lines, n * sizeof *lines);
1812
1813 if (lines == NULL) {
1814 err = E_ALLOC;
1815 } else {
1816 int i = n - 1;
1817
1818 fun->lines = lines;
1819 lines[i].idx = fun->line_idx;
1820 if (donate) {
1821 lines[i].s = s;
1822 } else {
1823 lines[i].s = gretl_strdup(s);
1824 if (lines[i].s == NULL) {
1825 err = E_ALLOC;
1826 }
1827 }
1828 if (!err) {
1829 lines[i].loop = NULL;
1830 lines[i].next_idx = -1;
1831 lines[i].ignore = 0;
1832 fun->n_lines = n;
1833 fun->line_idx += 1;
1834 }
1835 }
1836 }
1837
1838 return err;
1839 }
1840
1841 /* read the actual code lines from the XML representation of a
1842 function */
1843
func_read_code(xmlNodePtr node,xmlDocPtr doc,ufunc * fun)1844 static int func_read_code (xmlNodePtr node, xmlDocPtr doc, ufunc *fun)
1845 {
1846 char line[MAXLINE];
1847 char *buf, *s;
1848 gint8 uses_set = 0;
1849 int err = 0;
1850
1851 buf = (char *) xmlNodeListGetString(doc, node->xmlChildrenNode, 1);
1852 if (buf == NULL) {
1853 return 1;
1854 }
1855
1856 bufgets_init(buf);
1857
1858 while (bufgets(line, sizeof line, buf) && !err) {
1859 s = line;
1860 while (isspace(*s)) s++;
1861 if (uses_set == 0 && !strncmp(s, "set ", 4)) {
1862 uses_set = 1;
1863 }
1864 tailstrip(s);
1865 err = push_function_line(fun, s, 0);
1866 }
1867
1868 if (uses_set) {
1869 fun->flags |= UFUN_USES_SET;
1870 }
1871
1872 bufgets_finalize(buf);
1873
1874 free(buf);
1875
1876 return err;
1877 }
1878
print_opt_flags(fn_param * param,PRN * prn)1879 static void print_opt_flags (fn_param *param, PRN *prn)
1880 {
1881 if (param->flags & FP_OPTIONAL) {
1882 pputs(prn, "[null]");
1883 }
1884 }
1885
print_param_description(fn_param * param,PRN * prn)1886 static void print_param_description (fn_param *param, PRN *prn)
1887 {
1888 if (param->descrip != NULL && *param->descrip != '\0') {
1889 pprintf(prn, " \"%s\"", param->descrip);
1890 }
1891 }
1892
print_param_labels(fn_param * param,PRN * prn)1893 static void print_param_labels (fn_param *param, PRN *prn)
1894 {
1895 int i;
1896
1897 pputs(prn, " {");
1898
1899 for (i=0; i<param->nlabels; i++) {
1900 pprintf(prn, "\"%s\"", param->labels[i]);
1901 if (i < param->nlabels - 1) {
1902 pputs(prn, ", ");
1903 }
1904 }
1905
1906 pputc(prn, '}');
1907 }
1908
print_min_max_deflt(fn_param * param,PRN * prn)1909 static void print_min_max_deflt (fn_param *param, PRN *prn)
1910 {
1911 if (na(param->min) && na(param->max) && default_unset(param)) {
1912 return; /* no-op */
1913 } else if (na(param->min) && na(param->max)) {
1914 /* got a default value only? */
1915 if (!default_unset(param)) {
1916 if (na(param->deflt)) {
1917 pputs(prn, "[NA]");
1918 } else {
1919 pprintf(prn, "[%g]", param->deflt);
1920 }
1921 }
1922 return;
1923 }
1924
1925 pputc(prn, '[');
1926
1927 /* minimum */
1928 if (!na(param->min)) pprintf(prn, "%g", param->min);
1929 pputc(prn, ':');
1930
1931 /* maximum */
1932 if (!na(param->max)) pprintf(prn, "%g", param->max);
1933 pputc(prn, ':');
1934
1935 /* default */
1936 if (!default_unset(param)) {
1937 if (na(param->deflt)) {
1938 pputs(prn, "NA");
1939 } else {
1940 pprintf(prn, "%g", param->deflt);
1941 }
1942 }
1943
1944 if (!na(param->step)) {
1945 /* step */
1946 pputc(prn, ':');
1947 pprintf(prn, "%g", param->step);
1948 }
1949
1950 pputc(prn, ']');
1951 }
1952
1953 /* free @fun and also remove it from the list of loaded
1954 functions */
1955
ufunc_unload(ufunc * fun)1956 static void ufunc_unload (ufunc *fun)
1957 {
1958 int i, j, found = 0;
1959
1960 if (n_ufuns == 0 || fun == NULL) {
1961 return;
1962 }
1963
1964 #if PKG_DEBUG
1965 fprintf(stderr, "ufunc_unload: name %s, pkg %p\n",
1966 fun->name, (void *) fun->pkg);
1967 #endif
1968
1969 /* remove this function from the array of loaded functions */
1970
1971 for (i=0; i<n_ufuns; i++) {
1972 if (ufuns[i] == fun) {
1973 for (j=i; j<n_ufuns-1; j++) {
1974 ufuns[j] = ufuns[j+1];
1975 }
1976 found = 1;
1977 break;
1978 }
1979 }
1980
1981 if (fun->pkg != NULL && fun->pkg->overrides) {
1982 delete_function_override(fun->name, fun->pkg->name);
1983 }
1984 ufunc_free(fun);
1985
1986 if (found) {
1987 n_ufuns--;
1988 }
1989 }
1990
1991 /* remove a package from the current listing and free it;
1992 if @full is non-zero, also unload any member functions
1993 */
1994
real_function_package_unload(fnpkg * pkg,int full)1995 static void real_function_package_unload (fnpkg *pkg, int full)
1996 {
1997 int i, j, found = 0;
1998
1999 #if PKG_DEBUG
2000 fprintf(stderr, "function_package_unload: unloading '%s', full=%d\n",
2001 pkg->name, full);
2002 #endif
2003
2004 /* unload children? */
2005 if (full) {
2006 for (i=0; i<pkg->n_priv; i++) {
2007 ufunc_unload(pkg->priv[i]);
2008 }
2009 for (i=0; i<pkg->n_pub; i++) {
2010 ufunc_unload(pkg->pub[i]);
2011 }
2012 }
2013
2014 /* remove this package from the array of loaded packages */
2015 for (i=0; i<n_pkgs; i++) {
2016 if (pkgs[i] == pkg) {
2017 for (j=i; j<n_pkgs-1; j++) {
2018 pkgs[j] = pkgs[j+1];
2019 }
2020 found = 1;
2021 break;
2022 }
2023 }
2024
2025 /* free the package itself */
2026 function_package_free(pkg);
2027
2028 if (found) {
2029 n_pkgs--;
2030 }
2031 }
2032
2033 /* Append a pointer to @fun to the array of child-pointers in @pkg: we
2034 do this when reading the definition of a packaged function from an
2035 XML file. Note that this action does not add the functions to the
2036 array of loaded functions -- that's done separately, if we're
2037 loading the package 'for real'.
2038 */
2039
attach_ufunc_to_package(ufunc * fun,fnpkg * pkg)2040 static int attach_ufunc_to_package (ufunc *fun, fnpkg *pkg)
2041 {
2042 ufunc **ufs;
2043 int n, err = 0;
2044
2045 if (function_is_private(fun)) {
2046 n = pkg->n_priv;
2047 ufs = realloc(pkg->priv, (n + 1) * sizeof *ufs);
2048 if (ufs == NULL) {
2049 err = E_ALLOC;
2050 } else {
2051 pkg->priv = ufs;
2052 pkg->priv[n] = fun;
2053 pkg->n_priv += 1;
2054 }
2055 } else {
2056 n = pkg->n_pub;
2057 ufs = realloc(pkg->pub, (n + 1) * sizeof *ufs);
2058 if (ufs == NULL) {
2059 err = E_ALLOC;
2060 } else {
2061 pkg->pub = ufs;
2062 pkg->pub[n] = fun;
2063 pkg->n_pub += 1;
2064 }
2065 }
2066
2067 #if PKG_DEBUG
2068 fprintf(stderr, "attach_ufunc_to_package: package = %s, "
2069 "private = %d, err = %d\n", pkg->name,
2070 function_is_private(fun), err);
2071 #endif
2072
2073 return err;
2074 }
2075
maybe_set_menu_only(ufunc * fun,fnpkg * pkg)2076 static void maybe_set_menu_only (ufunc *fun, fnpkg *pkg)
2077 {
2078 if (pkg->mpath != NULL && strstr(pkg->mpath, "MODELWIN")) {
2079 if (fun->pkg_role == UFUN_GUI_MAIN) {
2080 fun->flags |= UFUN_MENU_ONLY;
2081 }
2082 }
2083 }
2084
2085 /* read a single user-function definition from XML file: if the
2086 function is a child of a package, the @pkg argument will
2087 be non-NULL
2088 */
2089
read_ufunc_from_xml(xmlNodePtr node,xmlDocPtr doc,fnpkg * pkg)2090 static int read_ufunc_from_xml (xmlNodePtr node, xmlDocPtr doc, fnpkg *pkg)
2091 {
2092 ufunc *fun = ufunc_new();
2093 xmlNodePtr cur;
2094 char *tmp;
2095 int err = 0;
2096
2097 if (fun == NULL) {
2098 return E_ALLOC;
2099 }
2100
2101 if (!gretl_xml_get_prop_as_string(node, "name", &tmp)) {
2102 ufunc_free(fun);
2103 return E_DATA;
2104 }
2105
2106 strncat(fun->name, tmp, FN_NAMELEN - 1);
2107 free(tmp);
2108
2109 if (pkg != NULL) {
2110 fun->pkg = pkg;
2111 }
2112
2113 if (gretl_xml_get_prop_as_string(node, "type", &tmp)) {
2114 fun->rettype = return_type_from_string(tmp, &err);
2115 free(tmp);
2116 } else {
2117 fun->rettype = GRETL_TYPE_VOID;
2118 }
2119
2120 if (err) {
2121 ufunc_free(fun);
2122 return err;
2123 }
2124
2125 if (gretl_xml_get_prop_as_bool(node, "private")) {
2126 fun->flags |= UFUN_PRIVATE;
2127 }
2128
2129 if (gretl_xml_get_prop_as_bool(node, "plugin-wrapper")) {
2130 fun->flags |= UFUN_PLUGIN;
2131 }
2132
2133 if (gretl_xml_get_prop_as_bool(node, "no-print")) {
2134 fun->flags |= UFUN_NOPRINT;
2135 }
2136
2137 if (gretl_xml_get_prop_as_bool(node, "menu-only")) {
2138 fun->flags |= UFUN_MENU_ONLY;
2139 }
2140
2141 if (gretl_xml_get_prop_as_string(node, "pkg-role", &tmp)) {
2142 fun->pkg_role = pkg_key_get_role(tmp);
2143 free(tmp);
2144 }
2145
2146 if (!(fun->flags & UFUN_MENU_ONLY) && pkg != NULL) {
2147 maybe_set_menu_only(fun, pkg);
2148 }
2149
2150 #if PKG_DEBUG
2151 fprintf(stderr, "read_ufunc_from_xml: name '%s', type %d\n"
2152 " private = %d, plugin = %d\n", fun->name, fun->rettype,
2153 function_is_private(fun), function_is_plugin(fun));
2154 #endif
2155
2156 if (pkg == NULL && (function_is_private(fun) || function_is_plugin(fun))) {
2157 fprintf(stderr, "unpackaged function: can't be private or plugin\n");
2158 ufunc_free(fun);
2159 return E_DATA;
2160 }
2161
2162 cur = node->xmlChildrenNode;
2163
2164 while (cur != NULL && !err) {
2165 if (!xmlStrcmp(cur->name, (XUC) "help")) {
2166 /* backward compatibility: help used to be attached to
2167 a package's public interface */
2168 if (pkg->help != NULL) {
2169 free(pkg->help);
2170 }
2171 pkg->help = gretl_xml_get_string(cur, doc);
2172 } else if (!xmlStrcmp(cur->name, (XUC) "params")) {
2173 err = func_read_params(cur, doc, fun);
2174 if (err) {
2175 fprintf(stderr, "%s: error parsing function parameters\n",
2176 fun->name);
2177 }
2178 } else if (!xmlStrcmp(cur->name, (XUC) "return")) {
2179 gretl_errmsg_set("Old-style function definitions no longer supported");
2180 err = E_DATA;
2181 } else if (!xmlStrcmp(cur->name, (XUC) "code")) {
2182 err = func_read_code(cur, doc, fun);
2183 }
2184 cur = cur->next;
2185 }
2186
2187 if (!err) {
2188 if (pkg != NULL) {
2189 /* function belongs to a package */
2190 err = attach_ufunc_to_package(fun, pkg);
2191 } else {
2192 /* reading a standalone function from session file */
2193 err = add_allocated_ufunc(fun);
2194 }
2195 }
2196
2197 if (err) {
2198 ufunc_free(fun);
2199 }
2200
2201 #if PKG_DEBUG
2202 fprintf(stderr, "read_ufunc_from_xml: returning %d\n", err);
2203 #endif
2204
2205 return err;
2206 }
2207
wordmatch(const char * s,const char * test)2208 static int wordmatch (const char *s, const char *test)
2209 {
2210 int n = strlen(test);
2211
2212 return (!strncmp(s, test, n) && (s[n] == '\0' || isspace(s[n])));
2213 }
2214
adjust_indent(const char * s,int * this_indent,int * next_indent)2215 void adjust_indent (const char *s, int *this_indent, int *next_indent)
2216 {
2217 const char *block_starts[] = {
2218 "loop", "if", "nls", "mle", "gmm", "mpi", "plot",
2219 "function", "restrict", "system", "foreign", NULL
2220 };
2221 int ti = *next_indent;
2222 int ni = *next_indent;
2223 int i, matched = 0;
2224
2225 if (*s == '\0') {
2226 *this_indent = *next_indent;
2227 return;
2228 }
2229
2230 /* skip "catch" if present */
2231 if (!strncmp(s, "catch ", 6)) {
2232 s += 6;
2233 s += strspn(s, " ");
2234 }
2235
2236 for (i=0; block_starts[i] != NULL && !matched; i++) {
2237 if (wordmatch(s, block_starts[i])) {
2238 matched = 1;
2239 ni++;
2240 }
2241 }
2242
2243 if (!matched && wordmatch(s, "outfile")) {
2244 /* Current syntax is "outfile <lines> end outfile", with
2245 options --append, --quiet, --buffer available on
2246 the initial line. Legacy syntax is "outfile --write"
2247 (or --append) to start and "outfile --close" to
2248 finish. We should indent <lines> in the first case
2249 but not the second.
2250 */
2251 if (strstr(s, "--close") || strstr(s, "--write")) {
2252 ; /* no-op */
2253 } else {
2254 /* note: --append is ambiguous wrt indenting! */
2255 ni++;
2256 }
2257 matched = 1;
2258 }
2259
2260 if (!matched) {
2261 if (wordmatch(s, "end") ||
2262 wordmatch(s, "endif") ||
2263 wordmatch(s, "endloop")) {
2264 ti--;
2265 ni--;
2266 } else if (wordmatch(s, "else") ||
2267 wordmatch(s, "elif")) {
2268 ni = ti;
2269 ti--;
2270 }
2271 }
2272
2273 *this_indent = ti;
2274 *next_indent = ni;
2275 }
2276
2277 /* ensure use of canonical forms "endif", "endloop" */
2278
maybe_correct_line(char * line)2279 static void maybe_correct_line (char *line)
2280 {
2281 char *p = strstr(line, "end if");
2282
2283 if (p == NULL) {
2284 p = strstr(line, "end loop");
2285 }
2286
2287 if (p != NULL && (p == line || *(p-1) == ' ')) {
2288 shift_string_left(p + 3, 1);
2289 }
2290 }
2291
2292 #define parm_has_children(p) (p->descrip != NULL || p->nlabels > 0)
2293
2294 /* write out a single user-defined function as XML, according to
2295 gretlfunc.dtd */
2296
write_function_xml(ufunc * fun,PRN * prn)2297 static int write_function_xml (ufunc *fun, PRN *prn)
2298 {
2299 int rtype = fun->rettype;
2300 int this_indent = 0;
2301 int next_indent = 0;
2302 int i, j;
2303
2304 if (rtype == GRETL_TYPE_NONE) {
2305 rtype = GRETL_TYPE_VOID;
2306 }
2307
2308 pprintf(prn, "<gretl-function name=\"%s\" type=\"%s\"",
2309 fun->name, gretl_type_get_name(rtype));
2310
2311 if (function_is_private(fun)) {
2312 pputs(prn, " private=\"1\"");
2313 }
2314 if (function_is_plugin(fun)) {
2315 pputs(prn, " plugin-wrapper=\"1\"");
2316 }
2317 if (function_is_noprint(fun)) {
2318 pputs(prn, " no-print=\"1\"");
2319 }
2320 if (function_is_menu_only(fun)) {
2321 pputs(prn, " menu-only=\"1\"");
2322 }
2323
2324 if (fun->pkg_role) {
2325 pprintf(prn, " pkg-role=\"%s\"", package_role_get_key(fun->pkg_role));
2326 }
2327
2328 pputs(prn, ">\n");
2329
2330 if (fun->n_params > 0) {
2331
2332 gretl_push_c_numeric_locale();
2333
2334 pprintf(prn, " <params count=\"%d\">\n", fun->n_params);
2335 for (i=0; i<fun->n_params; i++) {
2336 fn_param *param = &fun->params[i];
2337
2338 pprintf(prn, " <param name=\"%s\" type=\"%s\"",
2339 param->name, arg_type_xml_string(param->type));
2340 if (!na(param->min)) {
2341 pprintf(prn, " min=\"%g\"", param->min);
2342 }
2343 if (!na(param->max)) {
2344 pprintf(prn, " max=\"%g\"", param->max);
2345 }
2346 if (!default_unset(param)) {
2347 if (na(param->deflt)) {
2348 pputs(prn, " default=\"NA\"");
2349 } else {
2350 pprintf(prn, " default=\"%g\"", param->deflt);
2351 }
2352 }
2353 if (!na(param->step)) {
2354 pprintf(prn, " step=\"%g\"", param->step);
2355 }
2356 if (param->flags & FP_OPTIONAL) {
2357 pputs(prn, " optional=\"true\"");
2358 }
2359 if (param->flags & FP_CONST) {
2360 pputs(prn, " const=\"true\"");
2361 }
2362 if (parm_has_children(param)) {
2363 pputs(prn, ">\n"); /* terminate opening tag */
2364 if (param->descrip != NULL) {
2365 gretl_xml_put_tagged_string("description",
2366 param->descrip,
2367 prn);
2368 }
2369 if (param->nlabels > 0) {
2370 gretl_xml_put_strings_array_quoted("labels",
2371 (const char **) param->labels,
2372 param->nlabels, prn);
2373 }
2374 pputs(prn, " </param>\n");
2375 } else {
2376 pputs(prn, "/>\n"); /* terminate opening tag */
2377 }
2378 }
2379 pputs(prn, " </params>\n");
2380
2381 gretl_pop_c_numeric_locale();
2382 }
2383
2384 pputs(prn, "<code>");
2385
2386 for (i=0; i<fun->n_lines; i++) {
2387 adjust_indent(fun->lines[i].s, &this_indent, &next_indent);
2388 for (j=0; j<this_indent; j++) {
2389 pputs(prn, " ");
2390 }
2391 maybe_correct_line(fun->lines[i].s);
2392 gretl_xml_put_string(fun->lines[i].s, prn);
2393 pputs(prn, "\n");
2394 }
2395
2396 pputs(prn, "</code>\n");
2397 pputs(prn, "</gretl-function>\n");
2398
2399 return 0;
2400 }
2401
2402 /* script-style output */
2403
print_function_start(ufunc * fun,PRN * prn)2404 static void print_function_start (ufunc *fun, PRN *prn)
2405 {
2406 const char *s;
2407 int i, pos = 0;
2408
2409 if (fun->rettype == GRETL_TYPE_NONE) {
2410 pos += pprintf(prn, "function void %s ", fun->name);
2411 } else {
2412 const char *typestr = gretl_type_get_name(fun->rettype);
2413
2414 pos += pprintf(prn, "function %s %s ", typestr, fun->name);
2415 }
2416
2417 gretl_push_c_numeric_locale();
2418
2419 if (fun->n_params == 0) {
2420 pputs(prn, "(void)");
2421 } else {
2422 pos += pputc(prn, '(');
2423 }
2424
2425 for (i=0; i<fun->n_params; i++) {
2426 fn_param *fp = &fun->params[i];
2427
2428 if (fp->flags & FP_CONST) {
2429 pputs(prn, "const ");
2430 }
2431 s = gretl_type_get_name(fp->type);
2432 if (s[strlen(s) - 1] == '*') {
2433 pprintf(prn, "%s%s", s, fp->name);
2434 } else {
2435 pprintf(prn, "%s %s", s, fp->name);
2436 }
2437 if (fp->type == GRETL_TYPE_BOOL) {
2438 if (!default_unset(fp) && !na(fp->deflt)) {
2439 pprintf(prn, "[%g]", fp->deflt); /* FIXME? */
2440 }
2441 } else if (gretl_scalar_type(fp->type)) {
2442 print_min_max_deflt(fp, prn);
2443 } else if (arg_may_be_optional(fp->type)) {
2444 print_opt_flags(&fun->params[i], prn);
2445 }
2446 print_param_description(fp, prn);
2447 if (fp->nlabels > 0) {
2448 print_param_labels(fp, prn);
2449 }
2450 if (i == fun->n_params - 1) {
2451 pputc(prn, ')');
2452 } else {
2453 pputs(prn, ",\n");
2454 bufspace(pos, prn);
2455 }
2456 }
2457
2458 pputc(prn, '\n');
2459
2460 gretl_pop_c_numeric_locale();
2461 }
2462
2463 /**
2464 * gretl_function_print_code:
2465 * @u: pointer to user-function.
2466 * @tabwidth: number of spaces per "tab" (logical indent).
2467 * @prn: printing struct.
2468 *
2469 * Prints out function @fun to @prn, script-style.
2470 *
2471 * Returns: 0 on success, non-zero if @fun is %NULL.
2472 */
2473
gretl_function_print_code(ufunc * u,int tabwidth,PRN * prn)2474 int gretl_function_print_code (ufunc *u, int tabwidth, PRN *prn)
2475 {
2476 int this_indent = 0;
2477 int next_indent = 0;
2478 int i, j;
2479
2480 if (u == NULL) {
2481 return E_DATA;
2482 }
2483
2484 if (tabwidth == 0) {
2485 tabwidth = 2;
2486 }
2487
2488 print_function_start(u, prn);
2489
2490 for (i=0; i<u->n_lines; i++) {
2491 adjust_indent(u->lines[i].s, &this_indent, &next_indent);
2492 for (j=0; j<=this_indent; j++) {
2493 bufspace(tabwidth, prn);
2494 }
2495 pputs(prn, u->lines[i].s);
2496 if (i < u->n_lines - 1) {
2497 if (u->lines[i+1].idx > u->lines[i].idx + 1) {
2498 pputc(prn, '\n');
2499 }
2500 }
2501 pputc(prn, '\n');
2502 }
2503
2504 pputs(prn, "end function\n");
2505
2506 return 0;
2507 }
2508
gretl_function_retrieve_code(ufunc * u,int * nlines)2509 char **gretl_function_retrieve_code (ufunc *u, int *nlines)
2510 {
2511 char **S = NULL;
2512 int i, j = 0;
2513
2514 for (i=0; i<u->n_lines; i++) {
2515 if (!u->lines[i].ignore) {
2516 j++;
2517 }
2518 }
2519
2520 if (j > 0) {
2521 S = strings_array_new(j);
2522 }
2523
2524 if (S != NULL) {
2525 *nlines = j;
2526 j = 0;
2527 for (i=0; i<u->n_lines; i++) {
2528 if (!u->lines[i].ignore) {
2529 S[j++] = u->lines[i].s;
2530 }
2531 }
2532 }
2533
2534 return S;
2535 }
2536
2537 /* construct a name for @pkg based on its filename member:
2538 take the basename and knock off ".gfn"
2539 */
2540
name_package_from_filename(fnpkg * pkg)2541 static void name_package_from_filename (fnpkg *pkg)
2542 {
2543 char *p = strrslash(pkg->fname);
2544 int n;
2545
2546 if (p != NULL) {
2547 p++;
2548 } else {
2549 p = pkg->fname;
2550 }
2551
2552 n = strlen(p);
2553 if (has_suffix(p, ".gfn")) {
2554 n -= 4;
2555 }
2556
2557 if (n > FN_NAMELEN - 1) {
2558 n = FN_NAMELEN - 1;
2559 }
2560
2561 *pkg->name = '\0';
2562 strncat(pkg->name, p, n);
2563
2564 #if PKG_DEBUG
2565 fprintf(stderr, "filename '%s' -> pkgname '%s'\n",
2566 pkg->fname, pkg->name);
2567 #endif
2568 }
2569
2570 /* name lookup for functions to be connected to a package,
2571 allowing for the possibility that they're already
2572 connected */
2573
get_uf_array_member(const char * name,fnpkg * pkg)2574 static ufunc *get_uf_array_member (const char *name, fnpkg *pkg)
2575 {
2576 int i;
2577
2578 for (i=0; i<n_ufuns; i++) {
2579 if (ufuns[i]->pkg == pkg || ufuns[i]->pkg == NULL) {
2580 if (!strcmp(name, ufuns[i]->name)) {
2581 return ufuns[i];
2582 }
2583 }
2584 }
2585
2586 return NULL;
2587 }
2588
check_special_comments(ufunc * fun)2589 static void check_special_comments (ufunc *fun)
2590 {
2591 int i;
2592
2593 for (i=0; i<fun->n_lines; i++) {
2594 if (strstr(fun->lines[i].s, "## plugin-wrapper ##")) {
2595 fun->flags |= UFUN_PLUGIN;
2596 } else if (strstr(fun->lines[i].s, "## no-print ##")) {
2597 fun->flags |= UFUN_NOPRINT;
2598 } else if (strstr(fun->lines[i].s, "## menu-only ##")) {
2599 fun->flags |= UFUN_MENU_ONLY;
2600 }
2601 }
2602 }
2603
2604 /* before revising the function members of an existing
2605 package, detach all its current functions
2606 */
2607
package_disconnect_funcs(fnpkg * pkg)2608 static void package_disconnect_funcs (fnpkg *pkg)
2609 {
2610 int i;
2611
2612 if (pkg->pub != NULL) {
2613 for (i=0; i<pkg->n_pub; i++) {
2614 pkg->pub[i]->pkg = NULL;
2615 }
2616 free(pkg->pub);
2617 pkg->pub = NULL;
2618 pkg->n_pub = 0;
2619 }
2620
2621 if (pkg->priv != NULL) {
2622 for (i=0; i<pkg->n_priv; i++) {
2623 pkg->priv[i]->pkg = NULL;
2624 set_function_private(pkg->priv[i], FALSE);
2625 }
2626 free(pkg->priv);
2627 pkg->priv = NULL;
2628 pkg->n_priv = 0;
2629 }
2630 }
2631
2632 /* Given an array of @n function names in @names, set up a
2633 corresponding array of pointers to the named functions in @pkg,
2634 Flag an error if any of the function names are bad, or if
2635 allocation fails.
2636 */
2637
set_uf_array_from_names(fnpkg * pkg,char ** names,int n,int priv)2638 static int set_uf_array_from_names (fnpkg *pkg, char **names,
2639 int n, int priv)
2640 {
2641 ufunc **uf = NULL;
2642 ufunc *fun;
2643 int i, j;
2644
2645 /* check the supplied names */
2646 for (i=0; i<n; i++) {
2647 for (j=0; j<i; j++) {
2648 if (!strcmp(names[j], names[i])) {
2649 gretl_errmsg_sprintf("Duplicated function name '%s'", names[i]);
2650 return E_DATA;
2651 }
2652 }
2653 if (get_uf_array_member(names[i], NULL) == NULL) {
2654 fprintf(stderr, "%s: function not found!\n", names[i]);
2655 return E_DATA;
2656 }
2657 }
2658
2659 /* allocate storage */
2660 if (n > 0) {
2661 uf = malloc(n * sizeof *uf);
2662 if (uf == NULL) {
2663 return E_ALLOC;
2664 }
2665 }
2666
2667 /* connect the specified functions */
2668 for (i=0; i<n; i++) {
2669 fun = get_uf_array_member(names[i], NULL);
2670 fun->pkg = pkg;
2671 set_function_private(fun, priv);
2672 check_special_comments(fun);
2673 uf[i] = fun;
2674 }
2675
2676 /* set up the package info */
2677 if (priv) {
2678 pkg->priv = uf;
2679 pkg->n_priv = n;
2680 } else {
2681 pkg->pub = uf;
2682 pkg->n_pub = n;
2683 }
2684
2685 return 0;
2686 }
2687
2688 /**
2689 * function_package_connect_funcs:
2690 * @pkg: function package.
2691 * @pubnames: array of names of public functions.
2692 * @n_pub: number of strings in @pubnames.
2693 * @privnames: array of names of private functions (or %NULL).
2694 * @n_priv: number of strings in @privnames (may be 0).
2695 *
2696 * Looks up the functions named in @pubnames and @privnames
2697 * and adds pointers to these functions to @pkg, hence marking
2698 * the functions as belonging to @pkg.
2699 *
2700 * Returns: 0 on success, non-zero on error.
2701 */
2702
function_package_connect_funcs(fnpkg * pkg,char ** pubnames,int n_pub,char ** privnames,int n_priv)2703 int function_package_connect_funcs (fnpkg *pkg,
2704 char **pubnames, int n_pub,
2705 char **privnames, int n_priv)
2706 {
2707 int err;
2708
2709 /* clear the decks first */
2710 package_disconnect_funcs(pkg);
2711
2712 err = set_uf_array_from_names(pkg, pubnames, n_pub, 0);
2713
2714 if (!err) {
2715 err = set_uf_array_from_names(pkg, privnames, n_priv, 1);
2716 }
2717
2718 return err;
2719 }
2720
2721 /**
2722 * function_package_new:
2723 * @fname: filename for package.
2724 * @pubnames: array of names of public functions.
2725 * @n_pub: number of strings in @pubnames.
2726 * @privnames: array of names of private functions (or %NULL).
2727 * @n_priv: number of strings in @privnames (may be 0).
2728 * @err: location to receive error code.
2729 *
2730 * Allocates a new package with filename-member @fname, including
2731 * the public and private functions named in @pubnames and
2732 * @privnames. Note that this function does not cause the
2733 * package to be written to file; for that, see
2734 * write_function_package().
2735 *
2736 * Returns: pointer to package on success, %NULL on error.
2737 */
2738
function_package_new(const char * fname,char ** pubnames,int n_pub,char ** privnames,int n_priv,int * err)2739 fnpkg *function_package_new (const char *fname,
2740 char **pubnames, int n_pub,
2741 char **privnames, int n_priv,
2742 int *err)
2743 {
2744 fnpkg *pkg = NULL;
2745
2746 if (n_pub <= 0) {
2747 /* we need at least one public function */
2748 *err = E_DATA;
2749 } else {
2750 pkg = function_package_alloc(fname);
2751 if (pkg == NULL) {
2752 *err = E_ALLOC;
2753 }
2754 }
2755
2756 if (*err) {
2757 return NULL;
2758 }
2759
2760 name_package_from_filename(pkg);
2761
2762 *err = function_package_connect_funcs(pkg, pubnames, n_pub,
2763 privnames, n_priv);
2764
2765 if (!*err) {
2766 *err = function_package_record(pkg);
2767 }
2768
2769 if (*err) {
2770 /* note: this does not free the packaged functions, if any */
2771 function_package_free(pkg);
2772 pkg = NULL;
2773 }
2774
2775 return pkg;
2776 }
2777
trim_text(char * s)2778 static char *trim_text (char *s)
2779 {
2780 while (isspace(*s)) s++;
2781 return tailstrip(s);
2782 }
2783
package_write_translatable_strings(fnpkg * pkg,PRN * prn)2784 static int package_write_translatable_strings (fnpkg *pkg, PRN *prn)
2785 {
2786 FILE *fp;
2787 gchar *trname;
2788 char **S = NULL;
2789 int i, n = 0;
2790
2791 trname = g_strdup_printf("%s-i18n.c", pkg->name);
2792
2793 fp = gretl_fopen(trname, "wb");
2794 if (fp == NULL) {
2795 gretl_errmsg_sprintf(_("Couldn't open %s"), trname);
2796 g_free(trname);
2797 return E_FOPEN;
2798 }
2799
2800 if (pkg->pub != NULL) {
2801 int j, k;
2802
2803 for (i=0; i<pkg->n_pub; i++) {
2804 ufunc *fun = pkg->pub[i];
2805
2806 for (j=0; j<fun->n_params; j++) {
2807 fn_param *param = &fun->params[j];
2808
2809 if (param->descrip != NULL) {
2810 strings_array_add(&S, &n, param->descrip);
2811 }
2812 for (k=0; k<param->nlabels; k++) {
2813 strings_array_add(&S, &n, param->labels[k]);
2814 }
2815 }
2816 }
2817 }
2818
2819 if (pkg->label != NULL || S != NULL) {
2820 fprintf(fp, "const char *%s_translations[] = {\n", pkg->name);
2821 if (pkg->label != NULL) {
2822 fprintf(fp, " N_(\"%s\"),\n", pkg->label);
2823 }
2824 if (S != NULL) {
2825 strings_array_sort(&S, &n, OPT_U);
2826 for (i=0; i<n; i++) {
2827 fprintf(fp, " N_(\"%s\")", S[i]);
2828 if (i < n-1) {
2829 fputc(',', fp);
2830 }
2831 fputc('\n', fp);
2832 }
2833 strings_array_free(S, n);
2834 }
2835 fputs("};\n", fp);
2836 }
2837
2838 fclose(fp);
2839
2840 pprintf(prn, "Wrote translations file %s\n", trname);
2841 g_free(trname);
2842
2843 return 0;
2844 }
2845
package_write_index(fnpkg * pkg,PRN * inprn)2846 static int package_write_index (fnpkg *pkg, PRN *inprn)
2847 {
2848 PRN *prn;
2849 gchar *idxname;
2850 int err = 0;
2851
2852 idxname = g_strdup_printf("%s.xml", pkg->name);
2853
2854 prn = gretl_print_new_with_filename(idxname, &err);
2855 if (prn == NULL) {
2856 g_free(idxname);
2857 return err;
2858 }
2859
2860 gretl_xml_header(prn);
2861
2862 pprintf(prn, "<gretl-addon name=\"%s\"", pkg->name);
2863
2864 if (pkg->dreq == FN_NEEDS_TS) {
2865 pprintf(prn, " %s=\"true\"", NEEDS_TS);
2866 } else if (pkg->dreq == FN_NEEDS_QM) {
2867 pprintf(prn, " %s=\"true\"", NEEDS_QM);
2868 } else if (pkg->dreq == FN_NEEDS_PANEL) {
2869 pprintf(prn, " %s=\"true\"", NEEDS_PANEL);
2870 } else if (pkg->dreq == FN_NODATA_OK) {
2871 pprintf(prn, " %s=\"true\"", NO_DATA_OK);
2872 }
2873
2874 if (pkg->modelreq > 0) {
2875 pprintf(prn, " model-requirement=\"%s\"",
2876 gretl_command_word(pkg->modelreq));
2877 }
2878
2879 if (pkg->minver > 0) {
2880 char vstr[8];
2881
2882 pprintf(prn, " minver=\"%s\"",
2883 gretl_version_string(vstr, pkg->minver));
2884 }
2885
2886 if (pkg->uses_subdir) {
2887 pputs(prn, " lives-in-subdir=\"true\"");
2888 }
2889
2890 if (pkg->data_access) {
2891 pputs(prn, " wants-data-access=\"true\"");
2892 }
2893
2894 pputs(prn, ">\n");
2895
2896 gretl_xml_put_tagged_string("author", pkg->author, prn);
2897 gretl_xml_put_tagged_string("version", pkg->version, prn);
2898 gretl_xml_put_tagged_string("date", pkg->date, prn);
2899 gretl_xml_put_tagged_string("description", pkg->descrip, prn);
2900
2901 if (pkg->tags != NULL) {
2902 gretl_xml_put_tagged_string("tags", pkg->tags, prn);
2903 }
2904
2905 if (pkg->label != NULL) {
2906 gretl_xml_put_tagged_string("label", pkg->label, prn);
2907 }
2908
2909 if (pkg->mpath != NULL) {
2910 gretl_xml_put_tagged_string("menu-attachment", pkg->mpath, prn);
2911 }
2912
2913 pputs(prn, "</gretl-addon>\n");
2914
2915 gretl_print_destroy(prn);
2916
2917 pprintf(inprn, "Wrote index file %s\n", idxname);
2918 g_free(idxname);
2919
2920 return 0;
2921 }
2922
2923 /* Write out a function package as XML. If @fp is NULL, then we write
2924 this as a package file in its own right, using the filename given
2925 in the package (the 'standalone' case), otherwise we're writing it
2926 as a component of the functions listing in a gretl session file,
2927 which already has an associated open stream.
2928 */
2929
real_write_function_package(fnpkg * pkg,PRN * prn)2930 static int real_write_function_package (fnpkg *pkg, PRN *prn)
2931 {
2932 int standalone = (prn == NULL);
2933 int i, err = 0;
2934
2935 if (standalone) {
2936 prn = gretl_print_new_with_filename(pkg->fname, &err);
2937 if (prn == NULL) {
2938 return err;
2939 } else {
2940 gretl_xml_header(prn);
2941 pputs(prn, "<gretl-functions>\n");
2942 }
2943 }
2944
2945 pputs(prn, "<gretl-function-package");
2946
2947 if (pkg->name[0] == '\0') {
2948 name_package_from_filename(pkg);
2949 }
2950
2951 pprintf(prn, " name=\"%s\"", pkg->name);
2952
2953 if (pkg->dreq == FN_NEEDS_TS) {
2954 pprintf(prn, " %s=\"true\"", NEEDS_TS);
2955 } else if (pkg->dreq == FN_NEEDS_QM) {
2956 pprintf(prn, " %s=\"true\"", NEEDS_QM);
2957 } else if (pkg->dreq == FN_NEEDS_PANEL) {
2958 pprintf(prn, " %s=\"true\"", NEEDS_PANEL);
2959 } else if (pkg->dreq == FN_NODATA_OK) {
2960 pprintf(prn, " %s=\"true\"", NO_DATA_OK);
2961 }
2962
2963 if (pkg->modelreq > 0) {
2964 pprintf(prn, " model-requirement=\"%s\"",
2965 gretl_command_word(pkg->modelreq));
2966 }
2967
2968 if (pkg->minver > 0) {
2969 char vstr[8];
2970
2971 pprintf(prn, " minver=\"%s\"", gretl_version_string(vstr, pkg->minver));
2972 }
2973
2974 if (pkg->uses_subdir) {
2975 pprintf(prn, " lives-in-subdir=\"true\"");
2976 }
2977
2978 if (pkg->data_access) {
2979 pprintf(prn, " wants-data-access=\"true\"");
2980 }
2981
2982 pputs(prn, ">\n");
2983
2984 if (pkg->email != NULL && *pkg->email != '\0') {
2985 gretl_xml_put_tagged_string_plus("author", pkg->author,
2986 "email", pkg->email,
2987 prn);
2988 } else {
2989 gretl_xml_put_tagged_string("author", pkg->author, prn);
2990 }
2991 gretl_xml_put_tagged_string("version", pkg->version, prn);
2992 gretl_xml_put_tagged_string("date", pkg->date, prn);
2993 gretl_xml_put_tagged_string("description", pkg->descrip, prn);
2994
2995 if (pkg->tags != NULL) {
2996 gretl_xml_put_tagged_string("tags", pkg->tags, prn);
2997 }
2998
2999 if (pkg->label != NULL) {
3000 gretl_xml_put_tagged_string("label", pkg->label, prn);
3001 }
3002
3003 if (pkg->mpath != NULL) {
3004 gretl_xml_put_tagged_string("menu-attachment", pkg->mpath, prn);
3005 }
3006
3007 if (pkg->help != NULL) {
3008 if (pkg->help_fname != NULL) {
3009 pprintf(prn, "<help filename=\"%s\">\n", pkg->help_fname);
3010 } else {
3011 pputs(prn, "<help>\n");
3012 }
3013 gretl_xml_put_string(trim_text(pkg->help), prn);
3014 pputs(prn, "\n</help>\n");
3015 }
3016
3017 if (pkg->gui_help != NULL) {
3018 if (pkg->gui_help_fname != NULL) {
3019 pprintf(prn, "<gui-help filename=\"%s\">\n",
3020 pkg->gui_help_fname);
3021 } else {
3022 pputs(prn, "<gui-help>\n");
3023 }
3024 gretl_xml_put_string(trim_text(pkg->gui_help), prn);
3025 pputs(prn, "\n</gui-help>\n");
3026 }
3027
3028 if (pkg->datafiles != NULL) {
3029 gretl_xml_put_strings_array("data-files",
3030 (const char **) pkg->datafiles,
3031 pkg->n_files, prn);
3032 }
3033
3034 if (pkg->depends != NULL) {
3035 gretl_xml_put_strings_array("depends",
3036 (const char **) pkg->depends,
3037 pkg->n_depends, prn);
3038 }
3039
3040 if (pkg->provider != NULL) {
3041 gretl_xml_put_tagged_string("provider", pkg->provider, prn);
3042 }
3043
3044 if (pkg->Rdeps != NULL) {
3045 gretl_xml_put_tagged_string("R-depends", pkg->Rdeps, prn);
3046 }
3047
3048 if (pkg->pub != NULL) {
3049 for (i=0; i<pkg->n_pub; i++) {
3050 write_function_xml(pkg->pub[i], prn);
3051 }
3052 }
3053
3054 if (pkg->priv != NULL) {
3055 for (i=0; i<pkg->n_priv; i++) {
3056 write_function_xml(pkg->priv[i], prn);
3057 }
3058 }
3059
3060 if (pkg->sample != NULL) {
3061 if (pkg->sample_fname != NULL) {
3062 pprintf(prn, "<sample-script filename=\"%s\">\n",
3063 pkg->sample_fname);
3064 } else {
3065 pputs(prn, "<sample-script>\n");
3066 }
3067 gretl_xml_put_string(trim_text(pkg->sample), prn);
3068 pputs(prn, "\n</sample-script>\n");
3069 }
3070
3071 pputs(prn, "</gretl-function-package>\n");
3072
3073 if (standalone) {
3074 pputs(prn, "</gretl-functions>\n");
3075 gretl_print_destroy(prn);
3076 }
3077
3078 return err;
3079 }
3080
3081 /**
3082 * function_package_write_file:
3083 * @pkg: function package.
3084 *
3085 * Write out @pkg as an XML file, using the filename
3086 * recorded in the package.
3087 *
3088 * Returns: 0 on success, non-zero on error.
3089 */
3090
function_package_write_file(fnpkg * pkg)3091 int function_package_write_file (fnpkg *pkg)
3092 {
3093 return real_write_function_package(pkg, NULL);
3094 }
3095
3096 /* below: apparatus for constructing and saving a gfn function
3097 package from the command line
3098 */
3099
is_unclaimed(const char * s,char ** S,int n)3100 static int is_unclaimed (const char *s, char **S, int n)
3101 {
3102 int i;
3103
3104 for (i=0; i<n; i++) {
3105 if (strcmp(s, S[i]) == 0) {
3106 return 0;
3107 }
3108 }
3109
3110 return 1;
3111 }
3112
strip_cr(gchar * s)3113 static void strip_cr (gchar *s)
3114 {
3115 while (*s) {
3116 if (*s == 0x0d && *(s+1) == 0x0a) {
3117 /* CR + LF -> LF */
3118 memmove(s, s+1, strlen(s));
3119 s++;
3120 }
3121 s++;
3122 }
3123 }
3124
pkg_aux_content(const char * fname,int * err)3125 static gchar *pkg_aux_content (const char *fname, int *err)
3126 {
3127 gchar *ret = NULL;
3128 GError *gerr = NULL;
3129 gsize len = 0;
3130
3131 g_file_get_contents(fname, &ret, &len, &gerr);
3132
3133 if (gerr != NULL) {
3134 gretl_errmsg_set(gerr->message);
3135 g_error_free(gerr);
3136 *err = E_FOPEN;
3137 } else if (strchr(ret, '\r')) {
3138 strip_cr(ret);
3139 }
3140
3141 return ret;
3142 }
3143
pkg_set_dreq(fnpkg * pkg,const char * s)3144 static int pkg_set_dreq (fnpkg *pkg, const char *s)
3145 {
3146 int err = 0;
3147
3148 if (!strcmp(s, NEEDS_TS)) {
3149 pkg->dreq = FN_NEEDS_TS;
3150 } else if (!strcmp(s, NEEDS_QM)) {
3151 pkg->dreq = FN_NEEDS_QM;
3152 } else if (!strcmp(s, NEEDS_PANEL)) {
3153 pkg->dreq = FN_NEEDS_PANEL;
3154 } else if (!strcmp(s, NO_DATA_OK)) {
3155 pkg->dreq = FN_NODATA_OK;
3156 } else {
3157 err = E_PARSE;
3158 }
3159
3160 return err;
3161 }
3162
pkg_set_modelreq(fnpkg * pkg,const char * s)3163 static int pkg_set_modelreq (fnpkg *pkg, const char *s)
3164 {
3165 int ci = gretl_command_number(s);
3166
3167 if (ci > 0) {
3168 pkg->modelreq = ci;
3169 return 0;
3170 } else {
3171 return E_PARSE;
3172 }
3173 }
3174
pkg_set_datafiles(fnpkg * pkg,const char * s)3175 static int pkg_set_datafiles (fnpkg *pkg, const char *s)
3176 {
3177 int err = 0;
3178
3179 if (string_is_blank(s)) {
3180 err = E_DATA;
3181 } else {
3182 int n = 0;
3183
3184 pkg->datafiles = gretl_string_split(s, &n, NULL);
3185 if (pkg->datafiles == NULL) {
3186 pkg->n_files = 0;
3187 err = E_ALLOC;
3188 } else {
3189 pkg->n_files = n;
3190 }
3191 }
3192
3193 if (!err) {
3194 pkg->uses_subdir = 1;
3195 }
3196
3197 return err;
3198 }
3199
pkg_set_depends(fnpkg * pkg,const char * s)3200 static int pkg_set_depends (fnpkg *pkg, const char *s)
3201 {
3202 int err = 0;
3203
3204 if (string_is_blank(s)) {
3205 err = E_DATA;
3206 } else {
3207 int n = 0;
3208
3209 pkg->depends = gretl_string_split(s, &n, NULL);
3210 if (pkg->depends == NULL) {
3211 pkg->n_depends = 0;
3212 err = E_ALLOC;
3213 } else {
3214 pkg->n_depends = n;
3215 }
3216 }
3217
3218 return err;
3219 }
3220
pkg_boolean_from_string(const char * s)3221 static int pkg_boolean_from_string (const char *s)
3222 {
3223 if (!strcmp(s, "true")) {
3224 return 1;
3225 } else {
3226 return 0;
3227 }
3228 }
3229
pkg_remove_role(fnpkg * pkg,int role)3230 static int pkg_remove_role (fnpkg *pkg, int role)
3231 {
3232 ufunc *u;
3233 int i;
3234
3235 for (i=0; i<pkg->n_priv; i++) {
3236 u = pkg->priv[i];
3237 if (u->pkg_role == role) {
3238 u->pkg_role = UFUN_ROLE_NONE;
3239 return 0;
3240 }
3241 }
3242 for (i=0; i<pkg->n_pub; i++) {
3243 u = pkg->pub[i];
3244 if (u->pkg_role == role) {
3245 u->pkg_role = UFUN_ROLE_NONE;
3246 return 0;
3247 }
3248 }
3249
3250 return E_DATA;
3251 }
3252
valid_list_maker(ufunc * u)3253 static int valid_list_maker (ufunc *u)
3254 {
3255 if (u->n_params == 0) {
3256 return 1; /* OK */
3257 } else if (u->n_params == 1 &&
3258 u->params[0].type == GRETL_TYPE_LIST) {
3259 return 1; /* OK */
3260 } else {
3261 return 0;
3262 }
3263 }
3264
function_set_package_role(const char * name,fnpkg * pkg,const char * attr,PRN * prn)3265 int function_set_package_role (const char *name, fnpkg *pkg,
3266 const char *attr, PRN *prn)
3267 {
3268 ufunc *u = NULL;
3269 int role = pkg_key_get_role(attr);
3270 int i, j, err = 0;
3271
3272 if (name == NULL) {
3273 /* removing a role */
3274 pkg_remove_role(pkg, role);
3275 return 0;
3276 }
3277
3278 if (role == UFUN_ROLE_NONE) {
3279 for (i=0; i<pkg->n_priv; i++) {
3280 if (!strcmp(name, pkg->priv[i]->name)) {
3281 u = pkg->priv[i];
3282 u->pkg_role = role;
3283 return 0;
3284 }
3285 }
3286 for (i=0; i<pkg->n_pub; i++) {
3287 if (!strcmp(name, pkg->pub[i]->name)) {
3288 u = pkg->pub[i];
3289 u->pkg_role = role;
3290 return 0;
3291 }
3292 }
3293 return E_DATA;
3294 }
3295
3296 /* check that the function in question satisfies the
3297 requirements for its role, and if so, hook it up
3298 */
3299
3300 if (role == UFUN_GUI_PRECHECK) {
3301 /* the pre-checker must be a private function */
3302 for (i=0; i<pkg->n_priv; i++) {
3303 if (!strcmp(name, pkg->priv[i]->name)) {
3304 u = pkg->priv[i];
3305 if (u->rettype != GRETL_TYPE_DOUBLE) {
3306 pprintf(prn, "%s: must return a scalar\n", attr);
3307 err = E_TYPES;
3308 } else if (u->n_params > 0) {
3309 pprintf(prn, "%s: no parameters are allowed\n", attr);
3310 err = E_TYPES;
3311 }
3312 if (!err) {
3313 u->pkg_role = role;
3314 }
3315 return err; /* found */
3316 }
3317 }
3318 /* not found */
3319 pprintf(prn, "%s: %s: no such private function\n", attr, name);
3320 return E_DATA;
3321 } else if (role == UFUN_LIST_MAKER) {
3322 /* this too must be a private function */
3323 for (i=0; i<pkg->n_priv; i++) {
3324 if (!strcmp(name, pkg->priv[i]->name)) {
3325 u = pkg->priv[i];
3326 if (u->rettype != GRETL_TYPE_LIST) {
3327 pprintf(prn, "%s: must return a list\n", attr);
3328 err = E_TYPES;
3329 } else if (!valid_list_maker(u)) {
3330 pprintf(prn, "%s: must have 0 parameters or a single "
3331 "list parameter\n", attr);
3332 err = E_TYPES;
3333 }
3334 if (!err) {
3335 u->pkg_role = role;
3336 }
3337 return err; /* found */
3338 }
3339 }
3340 /* not found */
3341 pprintf(prn, "%s: %s: no such private function\n", attr, name);
3342 return E_DATA;
3343 }
3344
3345 for (i=0; i<pkg->n_pub; i++) {
3346 /* all other special-role functions must be public */
3347 if (!strcmp(name, pkg->pub[i]->name)) {
3348 u = pkg->pub[i];
3349 if (role == UFUN_GUI_MAIN) {
3350 ; /* OK, type does not matter */
3351 } else {
3352 /* bundle-print, bundle-plot, etc. */
3353 int fcast = (role == UFUN_BUNDLE_FCAST);
3354 int pmin = fcast ? 2 : 1;
3355 GretlType pjt;
3356
3357 if (u->n_params == 0) {
3358 pprintf(prn, "%s: must take a %s argument\n", attr,
3359 gretl_type_get_name(GRETL_TYPE_BUNDLE_REF));
3360 err = E_TYPES;
3361 }
3362 for (j=0; j<u->n_params && !err; j++) {
3363 pjt = u->params[j].type;
3364 if (j == 0 && pjt != GRETL_TYPE_BUNDLE_REF) {
3365 pprintf(prn, "%s: first param type must be %s\n",
3366 attr, gretl_type_get_name(GRETL_TYPE_BUNDLE_REF));
3367 err = E_TYPES;
3368 } else if (j == 1 && pjt != GRETL_TYPE_INT) {
3369 pprintf(prn, "%s: second param type must be %s\n",
3370 attr, gretl_type_get_name(GRETL_TYPE_INT));
3371 err = E_TYPES;
3372 } else if (j == 2 && fcast && pjt != GRETL_TYPE_INT) {
3373 pprintf(prn, "%s: third param type must be %s\n",
3374 attr, gretl_type_get_name(GRETL_TYPE_INT));
3375 err = E_TYPES;
3376 } else if (j > pmin && !fn_param_optional(u, j) &&
3377 na(fn_param_default(u, j))) {
3378 pprintf(prn, "%s: extra params must be optional\n",
3379 attr);
3380 err = E_TYPES;
3381 }
3382 }
3383 }
3384 if (!err) {
3385 u->pkg_role = role;
3386 }
3387 return err;
3388 }
3389 }
3390
3391 pprintf(prn, "%s: %s: no such public function\n", attr, name);
3392
3393 return E_DATA;
3394 }
3395
3396 /* called from the GUI package editor to check whether
3397 a given function of name @name can be shown as a
3398 candidate for a specified GUI-special @role
3399 */
3400
function_ok_for_package_role(const char * name,int role)3401 int function_ok_for_package_role (const char *name,
3402 int role)
3403 {
3404 ufunc *u = NULL;
3405 int i, err = 0;
3406
3407 if (name == NULL || role == UFUN_ROLE_NONE) {
3408 return 0;
3409 }
3410
3411 for (i=0; i<n_ufuns; i++) {
3412 if (!strcmp(name, ufuns[i]->name)) {
3413 u = ufuns[i];
3414 break;
3415 }
3416 }
3417
3418 if (u == NULL) {
3419 return 0;
3420 }
3421
3422 if (role == UFUN_GUI_PRECHECK) {
3423 if (u->rettype != GRETL_TYPE_DOUBLE) {
3424 err = E_TYPES;
3425 } else if (u->n_params > 0) {
3426 err = E_TYPES;
3427 }
3428 return !err; /* found */
3429 } else if (role == UFUN_LIST_MAKER) {
3430 if (u->rettype != GRETL_TYPE_LIST) {
3431 err = E_TYPES;
3432 } else if (u->n_params > 0) {
3433 err = E_TYPES;
3434 }
3435 return !err; /* found */
3436 }
3437
3438 if (role == UFUN_GUI_MAIN) {
3439 ; /* OK, we don't mind what type it is */
3440 } else {
3441 /* bundle-print, bundle-plot, etc. */
3442 if (u->n_params == 0) {
3443 err = E_TYPES;
3444 }
3445 for (i=0; i<u->n_params && !err; i++) {
3446 if (i == 0 && u->params[i].type != GRETL_TYPE_BUNDLE_REF) {
3447 err = E_TYPES;
3448 } else if (i == 1 && u->params[i].type != GRETL_TYPE_INT) {
3449 err = E_TYPES;
3450 } else if (i > 1 && !fn_param_optional(u, i) &&
3451 na(fn_param_default(u, i))) {
3452 err = E_TYPES;
3453 }
3454 }
3455 }
3456
3457 return !err;
3458 }
3459
pkg_set_funcs_attribute(fnpkg * pkg,const char * s,int flag)3460 static int pkg_set_funcs_attribute (fnpkg *pkg, const char *s,
3461 int flag)
3462 {
3463 char **S;
3464 int ns = 0, err = 0;
3465
3466 S = gretl_string_split(s, &ns, NULL);
3467 if (ns == 0) {
3468 err = E_DATA;
3469 } else {
3470 int i, j, match;
3471
3472 for (i=0; i<ns && !err; i++) {
3473 match = 0;
3474 for (j=0; j<pkg->n_pub; j++) {
3475 if (!strcmp(S[i], pkg->pub[j]->name)) {
3476 pkg->pub[j]->flags |= flag;
3477 match = 1;
3478 break;
3479 }
3480 }
3481 if (!match) {
3482 err = E_DATA;
3483 }
3484 }
3485
3486 strings_array_free(S, ns);
3487 }
3488
3489 return err;
3490 }
3491
function_package_set_auxfile(fnpkg * pkg,const char * id,const char * fname)3492 static void function_package_set_auxfile (fnpkg *pkg,
3493 const char *id,
3494 const char *fname)
3495 {
3496 gchar *test = NULL;
3497
3498 /* Maybe set the source filename for an element
3499 of a function package read from file, but only
3500 if it's not the standard, default filename for
3501 the element in question.
3502 */
3503
3504 if (!strcmp(id, "help-fname")) {
3505 test = g_strdup_printf("%s_help.txt", pkg->name);
3506 } else if (!strcmp(id, "gui-help-fname")) {
3507 test = g_strdup_printf("%s_gui_help.txt", pkg->name);
3508 } else if (!strcmp(id, "sample-fname")) {
3509 test = g_strdup_printf("%s_sample.inp", pkg->name);
3510 }
3511
3512 if (test != NULL) {
3513 if (strcmp(fname, test)) {
3514 function_package_set_properties(pkg, id, fname, NULL);
3515 }
3516 g_free(test);
3517 }
3518 }
3519
check_for_pdf_ref(const char * s,fnpkg * pkg,int * err)3520 static int check_for_pdf_ref (const char *s, fnpkg *pkg,
3521 int *err)
3522 {
3523 int len, ret = 0;
3524
3525 if (!strncmp(s, "pdfdoc:", 7)) {
3526 s += 7;
3527 }
3528
3529 len = strlen(s);
3530 if (len < 64 && strchr(s, ' ') == NULL && has_suffix(s, ".pdf")) {
3531 char *tmp = gretl_strndup(s, len - 4);
3532
3533 if (strcmp(tmp, pkg->name)) {
3534 gretl_errmsg_sprintf(_("PDF doc should be called %s.pdf"), pkg->name);
3535 *err = E_DATA;
3536 } else {
3537 ret = 1;
3538 }
3539 free(tmp);
3540 }
3541
3542 return ret;
3543 }
3544
is_pdf_ref(const char * s)3545 static int is_pdf_ref (const char *s)
3546 {
3547 if (!strncmp(s, "pdfdoc:", 7)) {
3548 s += 7;
3549 }
3550
3551 return strlen(s) < 64 && strchr(s, ' ') == NULL &&
3552 has_suffix(s, ".pdf");
3553 }
3554
check_R_depends(const char * s)3555 static int check_R_depends (const char *s)
3556 {
3557 int err = 0;
3558
3559 if (strncmp(s, "R ", 2)) {
3560 err = E_DATA;
3561 } else {
3562 /* skip "R " */
3563 s += 2;
3564 s += strcspn(s, " ");
3565 if (*s == '\0') {
3566 err = E_DATA;
3567 } else {
3568 /* skip R version */
3569 s += strcspn(s, " ");
3570 while (*s && !err) {
3571 s += strspn(s, " ");
3572 if (*s == '\0') break;
3573 /* R package? */
3574 s += strcspn(s, " ");
3575 s += strspn(s, " ");
3576 if (*s == '\0') {
3577 /* no version given? */
3578 err = E_DATA;
3579 } else {
3580 /* skip package version */
3581 s += strcspn(s, " ");
3582 }
3583 }
3584 }
3585 }
3586
3587 if (err) {
3588 gretl_errmsg_set("Invalid R-depends line");
3589 }
3590
3591 return err;
3592 }
3593
3594 /* Having assembled and checked the function-listing for a new
3595 package, now retrieve the additional information from the
3596 spec file (named by @fname, opened as @fp).
3597 */
3598
new_package_info_from_spec(fnpkg * pkg,const char * fname,FILE * fp,gretlopt opt,PRN * prn)3599 static int new_package_info_from_spec (fnpkg *pkg, const char *fname,
3600 FILE *fp, gretlopt opt,
3601 PRN *prn)
3602 {
3603 const char *okstr, *failed;
3604 gchar *currdir = NULL;
3605 int quiet = (opt & OPT_Q);
3606 char *p, line[1024];
3607 int got = 0;
3608 int err = 0;
3609
3610 if (opt & OPT_G) {
3611 /* GUI use */
3612 okstr = "<@ok>\n";
3613 failed = "<@fail>\n";
3614 } else {
3615 okstr = "OK\n";
3616 failed = "failed\n";
3617 }
3618
3619 if (strrslash(fname) != NULL) {
3620 /* directory change needed */
3621 char dirname[FILENAME_MAX];
3622
3623 strcpy(dirname, fname);
3624 p = strrslash(dirname);
3625 *p = '\0';
3626 currdir = g_get_current_dir();
3627 err = gretl_chdir(dirname);
3628 }
3629
3630 #if PKG_DEBUG
3631 fprintf(stderr, "new_package_info_from_spec\n");
3632 #endif
3633
3634 while (fgets(line, sizeof line, fp) && !err) {
3635 if (*line == '#' || string_is_blank(line)) {
3636 continue;
3637 }
3638 tailstrip(line);
3639 p = strchr(line, '=');
3640 if (p == NULL) {
3641 continue;
3642 } else {
3643 p++;
3644 p += strspn(p, " ");
3645 if (!strncmp(line, "author", 6)) {
3646 err = function_package_set_properties(pkg, "author", p, NULL);
3647 if (!err) got++;
3648 } else if (!strncmp(line, "email", 5)) {
3649 err = function_package_set_properties(pkg, "email", p, NULL);
3650 } else if (!strncmp(line, "version", 7)) {
3651 err = function_package_set_properties(pkg, "version", p, NULL);
3652 if (!err) got++;
3653 } else if (!strncmp(line, "date", 4)) {
3654 err = function_package_set_properties(pkg, "date", p, NULL);
3655 if (!err) got++;
3656 } else if (!strncmp(line, "description", 11)) {
3657 err = function_package_set_properties(pkg, "description", p, NULL);
3658 if (!err) got++;
3659 } else if (!strncmp(line, "tags", 4)) {
3660 err = function_package_set_properties(pkg, "tags", p, NULL);
3661 } else if (!strncmp(line, "label", 5)) {
3662 err = function_package_set_properties(pkg, "label", p, NULL);
3663 } else if (!strncmp(line, "menu-attachment", 15)) {
3664 err = function_package_set_properties(pkg, "menu-attachment", p, NULL);
3665 } else if (!strncmp(line, "provider", 8)) {
3666 if (!quiet) {
3667 pprintf(prn, "Recording provider %s\n", p);
3668 }
3669 err = function_package_set_properties(pkg, "provider", p, NULL);
3670 } else if (!strncmp(line, "help", 4)) {
3671 gchar *hstr = NULL;
3672 int pdfdoc;
3673
3674 pdfdoc = check_for_pdf_ref(p, pkg, &err);
3675 if (pdfdoc) {
3676 if (!quiet) {
3677 pprintf(prn, "Recording help reference %s\n", p);
3678 }
3679 hstr = g_strdup_printf("pdfdoc:%s", p);
3680 } else if (!err) {
3681 if (!quiet) {
3682 pprintf(prn, "Looking for help text in %s... ", p);
3683 }
3684 hstr = pkg_aux_content(p, &err);
3685 if (err) {
3686 pputs(prn, failed);
3687 } else {
3688 pputs(prn, okstr);
3689 }
3690 }
3691 if (!err) {
3692 err = function_package_set_properties(pkg, "help", hstr, NULL);
3693 if (!err) {
3694 got++;
3695 if (!pdfdoc) {
3696 function_package_set_auxfile(pkg, "help-fname", p);
3697 }
3698 }
3699 }
3700 g_free(hstr);
3701 } else if (!strncmp(line, "gui-help", 8)) {
3702 gchar *ghstr = NULL;
3703
3704 if (!quiet) {
3705 pprintf(prn, "Looking for GUI help text in %s... ", p);
3706 }
3707 ghstr = pkg_aux_content(p, &err);
3708 if (err) {
3709 pputs(prn, failed);
3710 } else {
3711 pputs(prn, okstr);
3712 err = function_package_set_properties(pkg, "gui-help", ghstr, NULL);
3713 if (!err) {
3714 function_package_set_auxfile(pkg, "gui-help-fname", p);
3715 }
3716 }
3717 g_free(ghstr);
3718 } else if (!strncmp(line, "sample-script", 13)) {
3719 gchar *script = NULL;
3720
3721 if (!quiet) {
3722 pprintf(prn, "Looking for sample script in %s... ", p);
3723 }
3724 script = pkg_aux_content(p, &err);
3725 if (err) {
3726 pputs(prn, failed);
3727 } else {
3728 pputs(prn, okstr);
3729 err = function_package_set_properties(pkg, "sample-script", script, NULL);
3730 if (!err) {
3731 got++;
3732 function_package_set_auxfile(pkg, "sample-fname", p);
3733 }
3734 }
3735 g_free(script);
3736 } else if (!strncmp(line, "data-files", 10)) {
3737 if (!quiet) {
3738 pprintf(prn, "Recording data-file list: %s\n", p);
3739 }
3740 err = pkg_set_datafiles(pkg, p);
3741 } else if (!strncmp(line, "depends", 7)) {
3742 if (!quiet) {
3743 pprintf(prn, "Recording dependency list: %s\n", p);
3744 }
3745 err = pkg_set_depends(pkg, p);
3746 } else if (!strncmp(line, "R-depends", 9)) {
3747 err = check_R_depends(p);
3748 if (!err) {
3749 if (!quiet) {
3750 pprintf(prn, "Recording R dependency list: %s\n", p);
3751 }
3752 err = function_package_set_properties(pkg, "R-depends",p, NULL);
3753 }
3754 } else if (!strncmp(line, "data-requirement", 16)) {
3755 err = pkg_set_dreq(pkg, p);
3756 } else if (!strncmp(line, "model-requirement", 17)) {
3757 err = pkg_set_modelreq(pkg, p);
3758 } else if (!strncmp(line, "min-version", 11)) {
3759 pkg->minver = gretl_version_number(p);
3760 got++;
3761 } else if (!strncmp(line, "lives-in-subdir", 15)) {
3762 pkg->uses_subdir = pkg_boolean_from_string(p);
3763 } else if (!strncmp(line, "wants-data-access", 17)) {
3764 pkg->data_access = pkg_boolean_from_string(p);
3765 } else if (!strncmp(line, "no-print", 8)) {
3766 err = pkg_set_funcs_attribute(pkg, p, UFUN_NOPRINT);
3767 } else if (!strncmp(line, "menu-only", 9)) {
3768 err = pkg_set_funcs_attribute(pkg, p, UFUN_MENU_ONLY);
3769 } else {
3770 const char *key;
3771 int i;
3772
3773 for (i=0; pkg_lookups[i].key != NULL; i++) {
3774 key = pkg_lookups[i].key;
3775 if (!strncmp(line, key, strlen(key))) {
3776 err = function_set_package_role(p, pkg, key, prn);
3777 if (!err && !quiet) {
3778 pprintf(prn, "%s function is %s, %s", key, p, okstr);
3779 }
3780 break;
3781 }
3782 }
3783 }
3784 }
3785 }
3786
3787 if (!err && pkg->provider != NULL) {
3788 /* in case provider isn't registered as a dependency */
3789 err = strings_array_prepend_uniq(&pkg->depends, &pkg->n_depends,
3790 pkg->provider);
3791 }
3792
3793 if (currdir != NULL) {
3794 /* go back where we came from */
3795 gretl_chdir(currdir);
3796 g_free(currdir);
3797 }
3798
3799 if (!err && got < 7) {
3800 gretl_errmsg_set("Some required information was missing");
3801 err = E_DATA;
3802 }
3803
3804 return err;
3805 }
3806
is_public_funcs_line(const char * line,int * offset)3807 static int is_public_funcs_line (const char *line, int *offset)
3808 {
3809 const char *s = line;
3810
3811 if (!strncmp(s, "public", 6)) {
3812 s += 6;
3813 s += strspn(s, " ");
3814 if (*s == '=') {
3815 *offset = 1 + s - line;
3816 return 1;
3817 }
3818 }
3819
3820 return 0;
3821 }
3822
new_pkg_from_spec_file(const char * gfnname,gretlopt opt,PRN * prn,int * err)3823 static fnpkg *new_pkg_from_spec_file (const char *gfnname, gretlopt opt,
3824 PRN *prn, int *err)
3825 {
3826 fnpkg *pkg = NULL;
3827 char fname[FILENAME_MAX];
3828 char line[4096], cont[1024];
3829 int quiet = (opt & OPT_Q);
3830 FILE *fp;
3831
3832 if (!has_suffix(gfnname, ".gfn")) {
3833 gretl_errmsg_set("Output must have extension \".gfn\"");
3834 *err = E_DATA;
3835 return NULL;
3836 }
3837
3838 switch_ext(fname, gfnname, "spec");
3839 fp = gretl_fopen(fname, "r"); /* "rb" ? */
3840
3841 if (fp == NULL) {
3842 *err = E_FOPEN;
3843 } else {
3844 char **pubnames = NULL;
3845 char **privnames = NULL;
3846 int npub = 0, npriv = 0;
3847 ufunc *uf;
3848 int i;
3849
3850 if (!quiet) {
3851 pprintf(prn, "Found spec file '%s'\n", fname);
3852 }
3853
3854 /* first pass: gather names of public functions */
3855
3856 while (fgets(line, sizeof line, fp) && !*err) {
3857 int offset = 0;
3858
3859 if (is_public_funcs_line(line, &offset)) {
3860 while (ends_with_backslash(line)) {
3861 gretl_charsub(line, '\\', '\0');
3862 *cont = '\0';
3863 if (fgets(cont, sizeof cont, fp)) {
3864 strcat(line, cont);
3865 } else {
3866 *err = E_PARSE;
3867 }
3868 }
3869 if (!*err) {
3870 tailstrip(line);
3871 pubnames = gretl_string_split(line + offset, &npub, NULL);
3872 }
3873 break;
3874 }
3875 }
3876
3877 if (npub == 0) {
3878 pprintf(prn, "no specification of public functions was found\n");
3879 *err = E_DATA;
3880 }
3881
3882 if (!*err) {
3883 if (!quiet) {
3884 pprintf(prn, "number of public interfaces = %d\n", npub);
3885 }
3886 for (i=0; i<npub && !*err; i++) {
3887 uf = get_user_function_by_name(pubnames[i]);
3888 if (!quiet) {
3889 pprintf(prn, " %s", pubnames[i]);
3890 }
3891 if (uf == NULL) {
3892 if (!quiet) {
3893 pputs(prn, ": *** not found");
3894 }
3895 gretl_errmsg_sprintf("'%s': no such function", pubnames[i]);
3896 *err = E_DATA;
3897 }
3898 if (!quiet) {
3899 pputc(prn, '\n');
3900 }
3901 }
3902 }
3903
3904 /* note: any other functions currently loaded are assumed to be
3905 private functions for this package */
3906
3907 if (!*err) {
3908 npriv = n_free_functions() - npub;
3909 if (npriv < 0) {
3910 npriv = 0;
3911 }
3912 }
3913
3914 if (!*err && npriv > 0) {
3915 npriv = 0;
3916 for (i=0; i<n_ufuns && !*err; i++) {
3917 if (ufuns[i]->pkg == NULL && is_unclaimed(ufuns[i]->name, pubnames, npub)) {
3918 *err = strings_array_add(&privnames, &npriv, ufuns[i]->name);
3919 }
3920 }
3921 }
3922
3923 if (!quiet && !*err && npriv > 0) {
3924 pprintf(prn, "number of private functions = %d\n", npriv);
3925 for (i=0; i<npriv; i++) {
3926 pprintf(prn, " %s\n", privnames[i]);
3927 }
3928 }
3929
3930 if (!*err) {
3931 pkg = function_package_new(gfnname, pubnames, npub,
3932 privnames, npriv, err);
3933 }
3934
3935 strings_array_free(pubnames, npub);
3936 strings_array_free(privnames, npriv);
3937
3938 if (!*err) {
3939 rewind(fp);
3940 *err = new_package_info_from_spec(pkg, fname, fp, opt, prn);
3941 }
3942
3943 if (*err && pkg != NULL) {
3944 real_function_package_unload(pkg, 0);
3945 pkg = NULL;
3946 }
3947
3948 fclose(fp);
3949 }
3950
3951 return pkg;
3952 }
3953
cli_validate_package_file(const char * fname,gretlopt opt,PRN * prn)3954 static int cli_validate_package_file (const char *fname,
3955 gretlopt opt, PRN *prn)
3956 {
3957 char dtdname[FILENAME_MAX];
3958 xmlDocPtr doc = NULL;
3959 xmlDtdPtr dtd = NULL;
3960 int err;
3961
3962 err = gretl_xml_open_doc_root(fname, NULL, &doc, NULL);
3963 if (err) {
3964 pprintf(prn, "Couldn't parse %s\n", fname);
3965 return 1;
3966 }
3967
3968 *dtdname = '\0';
3969
3970 if (opt & OPT_D) {
3971 const char *dpath = get_optval_string(MAKEPKG, OPT_D);
3972
3973 if (dpath != NULL && *dpath != '\0') {
3974 strcat(dtdname, dpath);
3975 }
3976 } else {
3977 sprintf(dtdname, "%sfunctions%cgretlfunc.dtd", gretl_home(), SLASH);
3978 }
3979
3980 if (*dtdname != '\0') {
3981 dtd = xmlParseDTD(NULL, (const xmlChar *) dtdname);
3982 }
3983
3984 if (dtd == NULL) {
3985 pputs(prn, "Couldn't open DTD to check package\n");
3986 } else {
3987 const char *pkgname = path_last_element(fname);
3988 xmlValidCtxtPtr cvp = xmlNewValidCtxt();
3989
3990 if (cvp == NULL) {
3991 pputs(prn, "Couldn't get an XML validation context\n");
3992 xmlFreeDtd(dtd);
3993 xmlFreeDoc(doc);
3994 return 0;
3995 }
3996
3997 cvp->userData = (void *) prn;
3998 cvp->error = (xmlValidityErrorFunc) pprintf2;
3999 cvp->warning = (xmlValidityWarningFunc) pprintf2;
4000
4001 pprintf(prn, "Checking against %s\n", dtdname);
4002
4003 if (!xmlValidateDtd(cvp, doc, dtd)) {
4004 err = 1;
4005 } else {
4006 pprintf(prn, _("%s: validated against DTD OK"), pkgname);
4007 pputc(prn, '\n');
4008 }
4009
4010 xmlFreeValidCtxt(cvp);
4011 xmlFreeDtd(dtd);
4012 }
4013
4014 xmlFreeDoc(doc);
4015
4016 return err;
4017 }
4018
get_gfn_info_for_zip(const char * fname,int * pdfdoc,char *** datafiles,int * n_datafiles)4019 static int get_gfn_info_for_zip (const char *fname,
4020 int *pdfdoc,
4021 char ***datafiles,
4022 int *n_datafiles)
4023 {
4024 xmlDocPtr doc = NULL;
4025 xmlNodePtr node = NULL;
4026 xmlNodePtr sub;
4027 int found = 0;
4028 int err = 0;
4029
4030 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
4031 if (err) {
4032 return err;
4033 }
4034
4035 node = node->xmlChildrenNode;
4036 while (node != NULL && found < 2) {
4037 if (!xmlStrcmp(node->name, (XUC) "gretl-function-package")) {
4038 sub = node->xmlChildrenNode;
4039 while (sub != NULL && found < 2) {
4040 if (!xmlStrcmp(sub->name, (XUC) "help")) {
4041 char *s = NULL;
4042
4043 gretl_xml_node_get_trimmed_string(sub, doc, &s);
4044 *pdfdoc = is_pdf_ref(s);
4045 free(s);
4046 found++;
4047 } else if (!xmlStrcmp(sub->name, (XUC) "data-files")) {
4048 *datafiles =
4049 gretl_xml_get_strings_array(sub, doc, n_datafiles,
4050 0, &err);
4051 found++;
4052 } else if (!xmlStrcmp(sub->name, (XUC) "gretl-function")) {
4053 /* we've overshot */
4054 found = 2;
4055 }
4056 sub = sub->next;
4057 }
4058 }
4059 node = node->next;
4060 }
4061
4062 if (doc != NULL) {
4063 xmlFreeDoc(doc);
4064 }
4065
4066 return err;
4067 }
4068
cli_build_zip_package(const char * fname,const char * gfnname,fnpkg * pkg,PRN * prn)4069 static int cli_build_zip_package (const char *fname,
4070 const char *gfnname,
4071 fnpkg *pkg,
4072 PRN *prn)
4073 {
4074 char **datafiles = NULL;
4075 int n_datafiles = 0;
4076 int pdfdoc = 0;
4077 int freeit = 0;
4078 int err = 0;
4079
4080 if (pkg != NULL) {
4081 datafiles = pkg->datafiles;
4082 n_datafiles = pkg->n_files;
4083 pdfdoc = is_pdf_ref(pkg->help);
4084 } else {
4085 /* grope in the gfn file */
4086 err = get_gfn_info_for_zip(gfnname,
4087 &pdfdoc,
4088 &datafiles,
4089 &n_datafiles);
4090 freeit = 1;
4091 }
4092
4093 if (!err) {
4094 err = package_make_zipfile(gfnname,
4095 pdfdoc,
4096 datafiles,
4097 n_datafiles,
4098 NULL,
4099 fname,
4100 OPT_NONE,
4101 prn);
4102 }
4103
4104 if (freeit) {
4105 strings_array_free(datafiles, n_datafiles);
4106 }
4107
4108 return err;
4109 }
4110
should_rebuild_gfn(const char * gfnname)4111 static int should_rebuild_gfn (const char *gfnname)
4112 {
4113 char testname[FILENAME_MAX];
4114 struct stat b1, b2, b3;
4115 int err;
4116
4117 err = gretl_stat(gfnname, &b1);
4118 if (err) {
4119 /* gfn not found: so have to rebuild */
4120 return 1;
4121 }
4122
4123 switch_ext(testname, gfnname, "inp");
4124 err = gretl_stat(testname, &b2);
4125 if (err) {
4126 /* no corresponding inp: can't rebuild */
4127 return 0;
4128 }
4129
4130 switch_ext(testname, gfnname, "spec");
4131 err = gretl_stat(testname, &b3);
4132 if (err) {
4133 /* no corresponding spec: can't rebuild */
4134 return 0;
4135 }
4136
4137 if (b2.st_mtime > b1.st_mtime ||
4138 b3.st_mtime > b1.st_mtime) {
4139 /* inp or spec is newer than gfn */
4140 return 1;
4141 }
4142
4143 return 0;
4144 }
4145
4146 /**
4147 * create_and_write_function_package:
4148 * @fname: filename for function package.
4149 * @opt: may include OPT_I to write a package-index entry,
4150 * OPT_T to write translatable strings.
4151 * @prn: printer struct for feedback.
4152 *
4153 * Create a package based on the functions currently loaded, and
4154 * write it out as an XML file. Responds to the makepkg command.
4155 *
4156 * Returns: 0 on success, non-zero on error.
4157 */
4158
create_and_write_function_package(const char * fname,gretlopt opt,PRN * prn)4159 int create_and_write_function_package (const char *fname,
4160 gretlopt opt,
4161 PRN *prn)
4162 {
4163 char gfnname[FILENAME_MAX];
4164 fnpkg *pkg = NULL;
4165 int build_gfn = 1;
4166 int build_zip = 0;
4167 int err = 0;
4168
4169 if (has_suffix(fname, ".zip")) {
4170 /* building a zip package */
4171 switch_ext(gfnname, fname, "gfn");
4172 build_gfn = should_rebuild_gfn(gfnname);
4173 build_zip = 1;
4174 } else {
4175 /* just building a gfn file */
4176 strcpy(gfnname, fname);
4177 }
4178
4179 if (build_gfn && n_free_functions() == 0) {
4180 gretl_errmsg_set(_("No functions are available for packaging at present."));
4181 err = E_DATA;
4182 } else if (build_gfn) {
4183 pkg = new_pkg_from_spec_file(gfnname, opt, prn, &err);
4184 if (pkg != NULL) {
4185 err = function_package_write_file(pkg);
4186 if (!err) {
4187 err = cli_validate_package_file(gfnname, opt, prn);
4188 /* should we delete @gfnname ? */
4189 }
4190 if (!err) {
4191 if (opt & OPT_T) {
4192 package_write_translatable_strings(pkg, prn);
4193 }
4194 if (opt & OPT_I) {
4195 package_write_index(pkg, prn);
4196 }
4197 }
4198 }
4199 }
4200
4201 if (!err && build_zip) {
4202 err = cli_build_zip_package(fname, gfnname, pkg, prn);
4203 }
4204
4205 return err;
4206 }
4207
4208 /**
4209 * function_package_get_name:
4210 * @pkg: function package.
4211 *
4212 * Returns: the name of the package.
4213 */
4214
function_package_get_name(fnpkg * pkg)4215 const char *function_package_get_name (fnpkg *pkg)
4216 {
4217 return (pkg != NULL)? pkg->name : NULL;
4218 }
4219
4220 /**
4221 * function_package_get_version:
4222 * @pkg: function package.
4223 *
4224 * Returns: the name of the package.
4225 */
4226
function_package_get_version(fnpkg * pkg)4227 double function_package_get_version (fnpkg *pkg)
4228 {
4229 if (pkg == NULL) {
4230 return NADBL;
4231 } else {
4232 return dot_atof(pkg->version);
4233 }
4234 }
4235
maybe_replace_string_var(char ** svar,const char * src)4236 static int maybe_replace_string_var (char **svar, const char *src)
4237 {
4238 if (src == NULL) {
4239 gretl_errmsg_set("string value is missing");
4240 return E_DATA;
4241 } else {
4242 free(*svar);
4243 *svar = gretl_strdup(src);
4244 return (*svar == NULL)? E_ALLOC : 0;
4245 }
4246 }
4247
4248 /* unlike the case above, here we'll accept NULL for @src, to wipe
4249 out an existing string var */
4250
maybe_replace_optional_string_var(char ** svar,const char * src)4251 static int maybe_replace_optional_string_var (char **svar, const char *src)
4252 {
4253 if (src == NULL) {
4254 free(*svar);
4255 *svar = NULL;
4256 return 0;
4257 } else {
4258 free(*svar);
4259 *svar = gretl_strdup(src);
4260 return (*svar == NULL)? E_ALLOC : 0;
4261 }
4262 }
4263
4264 /* Called (indirectly) from GUI function packager. Note that we're
4265 careful not to touch UFUN_PRIVATE or UFUN_PLUGIN on the uf->flags
4266 side, since these flags are not represented in @attrs.
4267 */
4268
pkg_set_gui_attrs(fnpkg * pkg,const unsigned char * attrs)4269 static void pkg_set_gui_attrs (fnpkg *pkg, const unsigned char *attrs)
4270 {
4271 ufunc *uf;
4272 int i, r;
4273
4274 for (r=1; r<UFUN_GUI_PRECHECK; r++) {
4275 uf = NULL;
4276 for (i=0; i<n_ufuns; i++) {
4277 if (ufuns[i]->pkg == pkg && ufuns[i]->pkg_role == r) {
4278 uf = ufuns[i];
4279 break;
4280 }
4281 }
4282 if (uf != NULL) {
4283 if (attrs[r-1] & UFUN_NOPRINT) {
4284 uf->flags |= UFUN_NOPRINT;
4285 } else {
4286 uf->flags &= ~UFUN_NOPRINT;
4287 }
4288 if (attrs[r-1] & UFUN_MENU_ONLY) {
4289 uf->flags |= UFUN_MENU_ONLY;
4290 } else {
4291 uf->flags &= ~UFUN_MENU_ONLY;
4292 }
4293 }
4294 }
4295 }
4296
4297 /* Called (indirectly) from GUI function packager. Note that we scrub
4298 UFUN_PRIVATE and UFUN_PLUGIN from the user function flags passed to
4299 the packager: UFUN_PLUGIN is irrelevant and UFUN_PRIVATE is handled
4300 by a different mechanism.
4301 */
4302
pkg_get_gui_attrs(fnpkg * pkg,unsigned char * attrs)4303 static void pkg_get_gui_attrs (fnpkg *pkg, unsigned char *attrs)
4304 {
4305 ufunc *uf;
4306 int i, r;
4307
4308 for (r=1; r<UFUN_GUI_PRECHECK; r++) {
4309 uf = NULL;
4310 for (i=0; i<n_ufuns; i++) {
4311 if (ufuns[i]->pkg == pkg && ufuns[i]->pkg_role == r) {
4312 uf = ufuns[i];
4313 break;
4314 }
4315 }
4316 if (uf == NULL) {
4317 attrs[r-1] = 0;
4318 } else {
4319 attrs[r-1] = uf->flags & ~(UFUN_PRIVATE | UFUN_PLUGIN);
4320 }
4321 }
4322 }
4323
pkg_strvar_pointer(fnpkg * pkg,const char * key,int * optional)4324 static char **pkg_strvar_pointer (fnpkg *pkg, const char *key,
4325 int *optional)
4326 {
4327 *optional = 0;
4328
4329 if (!strcmp(key, "fname")) {
4330 return &pkg->fname;
4331 } else if (!strcmp(key, "author")) {
4332 return &pkg->author;
4333 } else if (!strcmp(key, "email")) {
4334 return &pkg->email;
4335 } else if (!strcmp(key, "version")) {
4336 return &pkg->version;
4337 } else if (!strcmp(key, "date")) {
4338 return &pkg->date;
4339 } else if (!strcmp(key, "description")) {
4340 return &pkg->descrip;
4341 } else if (!strcmp(key, "help")) {
4342 return &pkg->help;
4343 } else if (!strcmp(key, "sample-script")) {
4344 return &pkg->sample;
4345 }
4346
4347 *optional = 1;
4348
4349 if (!strcmp(key, "tags")) {
4350 return &pkg->tags; /* FIXME should be non-optional */
4351 } else if (!strcmp(key, "label")) {
4352 return &pkg->label;
4353 } else if (!strcmp(key, "menu-attachment")) {
4354 return &pkg->mpath;
4355 } else if (!strcmp(key, "gui-help")) {
4356 return &pkg->gui_help;
4357 } else if (!strcmp(key, "R-depends")) {
4358 return &pkg->Rdeps;
4359 } else if (!strcmp(key, "help-fname")) {
4360 return &pkg->help_fname;
4361 } else if (!strcmp(key, "gui-help-fname")) {
4362 return &pkg->gui_help_fname;
4363 } else if (!strcmp(key, "sample-fname")) {
4364 return &pkg->sample_fname;
4365 } else if (!strcmp(key, "provider")) {
4366 return &pkg->provider;
4367 }
4368
4369 return NULL;
4370 }
4371
4372 /* varargs function for setting the properties of a function
4373 package: the settings take the form of a NULL-terminated
4374 set of (key, value) pairs.
4375 */
4376
function_package_set_properties(fnpkg * pkg,...)4377 int function_package_set_properties (fnpkg *pkg, ...)
4378 {
4379 va_list ap;
4380 const char *key;
4381 char **sptr;
4382 int optional;
4383 int i, err = 0;
4384
4385 va_start(ap, pkg);
4386
4387 for (i=1; !err; i++) {
4388 key = va_arg(ap, const char *);
4389 if (key == NULL) {
4390 break;
4391 }
4392
4393 sptr = pkg_strvar_pointer(pkg, key, &optional);
4394
4395 if (sptr != NULL) {
4396 const char *sval = va_arg(ap, const char *);
4397
4398 if (optional) {
4399 err = maybe_replace_optional_string_var(sptr, sval);
4400 } else {
4401 err = maybe_replace_string_var(sptr, sval);
4402 }
4403
4404 if (!err && !strcmp(key, "help")) {
4405 if (!strncmp(sval, "pdfdoc", 6) ||
4406 is_pdf_ref(sval)) {
4407 pkg->uses_subdir = 1;
4408 }
4409 }
4410 } else if (!strcmp(key, "gui-attrs")) {
4411 const unsigned char *np = va_arg(ap, const unsigned char *);
4412
4413 pkg_set_gui_attrs(pkg, np);
4414 } else {
4415 int ival = va_arg(ap, int);
4416
4417 if (!strcmp(key, "data-requirement")) {
4418 pkg->dreq = ival;
4419 } else if (!strcmp(key, "model-requirement")) {
4420 pkg->modelreq = ival;
4421 } else if (!strcmp(key, "min-version")) {
4422 pkg->minver = ival;
4423 } else if (!strcmp(key, "lives-in-subdir")) {
4424 pkg->uses_subdir = (ival != 0);
4425 } else if (!strcmp(key, "wants-data-access")) {
4426 pkg->data_access = (ival != 0);
4427 }
4428 }
4429 }
4430
4431 va_end(ap);
4432
4433 return err;
4434 }
4435
4436 enum {
4437 PUBLIST,
4438 GUILIST,
4439 PRIVLIST
4440 };
4441
4442 /* From a function package get a list of either its public or its
4443 private functions, in the form of a simple gretl list. The
4444 elements of this list are just the positions of these functions in
4445 the current recorder array for user-functions. This is fine if
4446 the information is to be used right away (as in the GUI function
4447 call dialog), but it should _not_ be assumed that the identifiers
4448 will remain valid indefinitely.
4449 */
4450
function_package_get_list(fnpkg * pkg,int code,int n)4451 static int *function_package_get_list (fnpkg *pkg, int code, int n)
4452 {
4453 int *list = NULL;
4454 int j = 0;
4455
4456 if (n > 0) {
4457 list = gretl_list_new(n);
4458 if (list != NULL) {
4459 int i, priv, menu_only;
4460
4461 for (i=0; i<n_ufuns; i++) {
4462 if (ufuns[i]->pkg == pkg) {
4463 priv = function_is_private(ufuns[i]);
4464 menu_only = function_is_menu_only(ufuns[i]);
4465 if (code == PRIVLIST && priv) {
4466 list[++j] = i;
4467 } else if (code == PUBLIST && !priv) {
4468 list[++j] = i;
4469 } else if (code == GUILIST && !priv && !menu_only &&
4470 !pkg_aux_role(ufuns[i]->pkg_role)) {
4471 /* in the GUI list of public functions, don't
4472 display post-processing functions
4473 */
4474 list[++j] = i;
4475 }
4476 }
4477 }
4478 }
4479 }
4480
4481 if (list != NULL) {
4482 if (j == 0) {
4483 free(list);
4484 list = NULL;
4485 } else {
4486 list[0] = j;
4487 }
4488 }
4489
4490 return list;
4491 }
4492
pkg_get_special_func_name(fnpkg * pkg,UfunRole role)4493 static char *pkg_get_special_func_name (fnpkg *pkg, UfunRole role)
4494 {
4495 int i;
4496
4497 for (i=0; i<n_ufuns; i++) {
4498 if (ufuns[i]->pkg == pkg && ufuns[i]->pkg_role == role) {
4499 return g_strdup(ufuns[i]->name);
4500 }
4501 }
4502
4503 return NULL;
4504 }
4505
pkg_get_special_func_id(fnpkg * pkg,UfunRole role)4506 static int pkg_get_special_func_id (fnpkg *pkg, UfunRole role)
4507 {
4508 int i;
4509
4510 for (i=0; i<n_ufuns; i++) {
4511 if (ufuns[i]->pkg == pkg && ufuns[i]->pkg_role == role) {
4512 return i;
4513 }
4514 }
4515
4516 return -1;
4517 }
4518
handle_optional_string(char ** ps,const char * src)4519 static void handle_optional_string (char **ps, const char *src)
4520 {
4521 if (src == NULL) {
4522 *ps = NULL;
4523 } else {
4524 *ps = g_strdup(src);
4525 }
4526 }
4527
4528 /* varargs function for retrieving the properties of a function
4529 package: the arguments after @pkg take the form of a
4530 NULL-terminated set of (key, pointer) pairs; values are written to
4531 the locations given by the pointers.
4532 */
4533
function_package_get_properties(fnpkg * pkg,...)4534 int function_package_get_properties (fnpkg *pkg, ...)
4535 {
4536 va_list ap;
4537 int npub = 0;
4538 int npriv = 0;
4539 int **plist;
4540 const char *key;
4541 void *ptr;
4542 char **ps;
4543 int *pi;
4544 int i, err = 0;
4545
4546 g_return_val_if_fail(pkg != NULL, E_DATA);
4547
4548 for (i=0; i<n_ufuns; i++) {
4549 if (ufuns[i]->pkg == pkg) {
4550 if (function_is_private(ufuns[i])) {
4551 npriv++;
4552 } else {
4553 npub++;
4554 }
4555 }
4556 }
4557
4558 va_start(ap, pkg);
4559
4560 for (i=1; ; i++) {
4561 key = va_arg(ap, const char *);
4562 if (key == NULL) {
4563 break;
4564 }
4565 ptr = va_arg(ap, void *);
4566 if (ptr == NULL) {
4567 break;
4568 }
4569 if (!strcmp(key, "name")) {
4570 ps = (char **) ptr;
4571 *ps = g_strdup(pkg->name);
4572 } else if (!strcmp(key, "author")) {
4573 ps = (char **) ptr;
4574 *ps = g_strdup(pkg->author);
4575 } else if (!strcmp(key, "email")) {
4576 ps = (char **) ptr;
4577 if (pkg->email != NULL) {
4578 *ps = g_strdup(pkg->email);
4579 } else {
4580 *ps = g_strdup(""); /* ? */
4581 }
4582 } else if (!strcmp(key, "date")) {
4583 ps = (char **) ptr;
4584 *ps = g_strdup(pkg->date);
4585 } else if (!strcmp(key, "version")) {
4586 ps = (char **) ptr;
4587 *ps = g_strdup(pkg->version);
4588 } else if (!strcmp(key, "description")) {
4589 ps = (char **) ptr;
4590 *ps = g_strdup(pkg->descrip);
4591 } else if (!strcmp(key, "help")) {
4592 ps = (char **) ptr;
4593 *ps = g_strdup(pkg->help);
4594 } else if (!strcmp(key, "gui-help")) {
4595 ps = (char **) ptr;
4596 handle_optional_string(ps, pkg->gui_help);
4597 } else if (!strcmp(key, "R-depends")) {
4598 ps = (char **) ptr;
4599 handle_optional_string(ps, pkg->Rdeps);
4600 } else if (!strcmp(key, "sample-script")) {
4601 ps = (char **) ptr;
4602 *ps = g_strdup(pkg->sample);
4603 } else if (!strcmp(key, "help-fname")) {
4604 ps = (char **) ptr;
4605 handle_optional_string(ps, pkg->help_fname);
4606 } else if (!strcmp(key, "gui-help-fname")) {
4607 ps = (char **) ptr;
4608 handle_optional_string(ps, pkg->gui_help_fname);
4609 } else if (!strcmp(key, "sample-fname")) {
4610 ps = (char **) ptr;
4611 handle_optional_string(ps, pkg->sample_fname);
4612 } else if (!strcmp(key, "tags")) {
4613 ps = (char **) ptr;
4614 *ps = g_strdup(pkg->tags);
4615 } else if (!strcmp(key, "label")) {
4616 ps = (char **) ptr;
4617 *ps = g_strdup(pkg->label);
4618 } else if (!strcmp(key, "menu-attachment")) {
4619 ps = (char **) ptr;
4620 *ps = g_strdup(pkg->mpath);
4621 } else if (!strcmp(key, "provider")) {
4622 ps = (char **) ptr;
4623 *ps = g_strdup(pkg->provider);
4624 } else if (!strcmp(key, "data-requirement")) {
4625 pi = (int *) ptr;
4626 *pi = pkg->dreq;
4627 } else if (!strcmp(key, "model-requirement")) {
4628 pi = (int *) ptr;
4629 *pi = pkg->modelreq;
4630 } else if (!strcmp(key, "min-version")) {
4631 pi = (int *) ptr;
4632 *pi = pkg->minver;
4633 } else if (!strcmp(key, "lives-in-subdir")) {
4634 pi = (int *) ptr;
4635 *pi = pkg->uses_subdir;
4636 } else if (!strcmp(key, "wants-data-access")) {
4637 pi = (int *) ptr;
4638 *pi = pkg->data_access;
4639 } else if (!strcmp(key, "publist")) {
4640 plist = (int **) ptr;
4641 *plist = function_package_get_list(pkg, PUBLIST, npub);
4642 } else if (!strcmp(key, "gui-publist")) {
4643 plist = (int **) ptr;
4644 *plist = function_package_get_list(pkg, GUILIST, npub);
4645 } else if (!strcmp(key, "privlist")) {
4646 plist = (int **) ptr;
4647 *plist = function_package_get_list(pkg, PRIVLIST, npriv);
4648 } else if (!strcmp(key, "gui-main-id")) {
4649 pi = (int *) ptr;
4650 *pi = pkg_get_special_func_id(pkg, UFUN_GUI_MAIN);
4651 } else if (!strcmp(key, BUNDLE_PRINT)) {
4652 ps = (char **) ptr;
4653 *ps = pkg_get_special_func_name(pkg, UFUN_BUNDLE_PRINT);
4654 } else if (!strcmp(key, BUNDLE_PLOT)) {
4655 ps = (char **) ptr;
4656 *ps = pkg_get_special_func_name(pkg, UFUN_BUNDLE_PLOT);
4657 } else if (!strcmp(key, BUNDLE_TEST)) {
4658 ps = (char **) ptr;
4659 *ps = pkg_get_special_func_name(pkg, UFUN_BUNDLE_TEST);
4660 } else if (!strcmp(key, BUNDLE_FCAST)) {
4661 ps = (char **) ptr;
4662 *ps = pkg_get_special_func_name(pkg, UFUN_BUNDLE_FCAST);
4663 } else if (!strcmp(key, BUNDLE_EXTRA)) {
4664 ps = (char **) ptr;
4665 *ps = pkg_get_special_func_name(pkg, UFUN_BUNDLE_EXTRA);
4666 } else if (!strcmp(key, GUI_MAIN)) {
4667 ps = (char **) ptr;
4668 *ps = pkg_get_special_func_name(pkg, UFUN_GUI_MAIN);
4669 } else if (!strcmp(key, GUI_PRECHECK)) {
4670 ps = (char **) ptr;
4671 *ps = pkg_get_special_func_name(pkg, UFUN_GUI_PRECHECK);
4672 } else if (!strcmp(key, LIST_MAKER)) {
4673 ps = (char **) ptr;
4674 *ps = pkg_get_special_func_name(pkg, UFUN_LIST_MAKER);
4675 } else if (!strcmp(key, "gui-attrs")) {
4676 unsigned char *s = (unsigned char *) ptr;
4677
4678 pkg_get_gui_attrs(pkg, s);
4679 }
4680 }
4681
4682 va_end(ap);
4683
4684 return err;
4685 }
4686
4687 /* don't tamper with return value! */
4688
function_package_get_string(fnpkg * pkg,const char * id)4689 const char *function_package_get_string (fnpkg *pkg,
4690 const char *id)
4691 {
4692 if (pkg == NULL || id == NULL) {
4693 return NULL;
4694 } else if (!strcmp(id, "fname")) {
4695 return pkg->fname;
4696 } else if (!strcmp(id, "help-fname")) {
4697 return pkg->help_fname;
4698 } else if (!strcmp(id, "gui-help-fname")) {
4699 return pkg->gui_help_fname;
4700 } else if (!strcmp(id, "sample-fname")) {
4701 return pkg->sample_fname;
4702 } else if (!strcmp(id, "sample-script")) {
4703 return pkg->sample;
4704 } else if (!strcmp(id, "help")) {
4705 return pkg->help;
4706 } else if (!strcmp(id, "gui-help")) {
4707 return pkg->gui_help;
4708 } else if (!strcmp(id, "R-depends")) {
4709 return pkg->Rdeps;
4710 } else {
4711 return NULL;
4712 }
4713 }
4714
function_package_get_data_files(fnpkg * pkg,int * n)4715 char **function_package_get_data_files (fnpkg *pkg, int *n)
4716 {
4717 char **S = NULL;
4718
4719 *n = 0;
4720 if (pkg->datafiles != NULL) {
4721 S = strings_array_dup(pkg->datafiles, pkg->n_files);
4722 if (S != NULL) {
4723 *n = pkg->n_files;
4724 }
4725 }
4726
4727 return S;
4728 }
4729
function_package_get_depends(fnpkg * pkg,int * n)4730 char **function_package_get_depends (fnpkg *pkg, int *n)
4731 {
4732 char **S = NULL;
4733
4734 *n = 0;
4735 if (pkg->depends != NULL) {
4736 S = strings_array_dup(pkg->depends, pkg->n_depends);
4737 if (S != NULL) {
4738 *n = pkg->n_depends;
4739 }
4740 }
4741
4742 return S;
4743 }
4744
function_package_set_data_files(fnpkg * pkg,char ** S,int n)4745 int function_package_set_data_files (fnpkg *pkg, char **S, int n)
4746 {
4747 int err = 0;
4748
4749 if (pkg->datafiles != NULL) {
4750 strings_array_free(pkg->datafiles, pkg->n_files);
4751 pkg->datafiles = NULL;
4752 pkg->n_files = 0;
4753 }
4754
4755 if (n > 0) {
4756 if (S == NULL) {
4757 err = E_DATA;
4758 } else {
4759 pkg->datafiles = strings_array_dup(S, n);
4760 if (pkg->datafiles == NULL) {
4761 err = E_ALLOC;
4762 } else {
4763 pkg->n_files = n;
4764 pkg->uses_subdir = 1;
4765 }
4766 }
4767 }
4768
4769 return err;
4770 }
4771
function_package_set_depends(fnpkg * pkg,char ** S,int n)4772 int function_package_set_depends (fnpkg *pkg, char **S, int n)
4773 {
4774 int err = 0;
4775
4776 if (pkg->depends != NULL) {
4777 strings_array_free(pkg->depends, pkg->n_depends);
4778 pkg->depends = NULL;
4779 pkg->n_depends = 0;
4780 }
4781
4782 if (n > 0) {
4783 if (S == NULL) {
4784 err = E_DATA;
4785 } else {
4786 pkg->depends = strings_array_dup(S, n);
4787 if (pkg->depends == NULL) {
4788 err = E_ALLOC;
4789 } else {
4790 pkg->n_depends = n;
4791 }
4792 }
4793 }
4794
4795 if (!err && pkg->provider != NULL) {
4796 err = strings_array_prepend_uniq(&pkg->depends,
4797 &pkg->n_depends,
4798 pkg->provider);
4799 }
4800
4801 return err;
4802 }
4803
4804 /* quick check to see if there's a gross problem with a package,
4805 in the context of considering packing it into a gretl
4806 session file
4807 */
4808
validate_function_package(fnpkg * pkg)4809 static int validate_function_package (fnpkg *pkg)
4810 {
4811 if (pkg->pub == NULL || pkg->author == NULL ||
4812 pkg->version == NULL || pkg->date == NULL ||
4813 pkg->descrip == NULL) {
4814 return 0;
4815 } else if (pkg->name[0] == '\0') {
4816 return 0;
4817 }
4818
4819 return 1;
4820 }
4821
4822 /* for session file use, and also MPI: dump all currently defined
4823 functions, packaged or not, into a single XML file */
4824
write_loaded_functions_file(const char * fname,int mpicall)4825 int write_loaded_functions_file (const char *fname, int mpicall)
4826 {
4827 PRN *prn;
4828 int i, err = 0;
4829
4830 if (n_ufuns == 0) {
4831 return 0;
4832 }
4833
4834 prn = gretl_print_new_with_filename(fname, &err);
4835 if (prn == NULL) {
4836 return err;
4837 }
4838
4839 gretl_xml_header(prn);
4840 pputs(prn, "<gretl-functions>\n");
4841
4842 #ifdef HAVE_MPI
4843 if (mpicall) {
4844 /* if we're launching MPI, record the name of the
4845 currently executing function, if any
4846 */
4847 ufunc *u = currently_called_function();
4848
4849 if (u != NULL) {
4850 pprintf(prn, "<caller>%s</caller>\n", u->name);
4851 }
4852 }
4853 #endif
4854
4855 /* write any loaded function packages */
4856
4857 for (i=0; i<n_pkgs; i++) {
4858 if (validate_function_package(pkgs[i])) {
4859 real_write_function_package(pkgs[i], prn);
4860 }
4861 }
4862
4863 /* then any unpackaged functions */
4864
4865 for (i=0; i<n_ufuns; i++) {
4866 if (ufuns[i]->pkg == NULL) {
4867 write_function_xml(ufuns[i], prn);
4868 }
4869 }
4870
4871 pputs(prn, "</gretl-functions>\n");
4872
4873 gretl_print_destroy(prn);
4874
4875 return 0;
4876 }
4877
4878 /* De-allocate a function package: this can be done in either of two
4879 modes. If 'full' is non-zero then we destroy all functions that
4880 are children of the given package, otherwise we leave the
4881 function-children alone (just 'detaching' them from the parent
4882 package).
4883 */
4884
real_function_package_free(fnpkg * pkg,int full)4885 static void real_function_package_free (fnpkg *pkg, int full)
4886 {
4887 if (pkg != NULL) {
4888 int i;
4889
4890 if (full) {
4891 for (i=0; i<pkg->n_pub; i++) {
4892 ufunc_free(pkg->pub[i]);
4893 }
4894 for (i=0; i<pkg->n_priv; i++) {
4895 ufunc_free(pkg->priv[i]);
4896 }
4897 } else {
4898 for (i=0; i<n_ufuns; i++) {
4899 if (ufuns[i]->pkg == pkg) {
4900 /* remove package info */
4901 ufuns[i]->pkg = NULL;
4902 set_function_private(ufuns[i], FALSE);
4903 }
4904 }
4905 }
4906
4907 if (pkg->datafiles != NULL && pkg->n_files > 0) {
4908 strings_array_free(pkg->datafiles, pkg->n_files);
4909 }
4910
4911 if (pkg->depends != NULL && pkg->n_depends > 0) {
4912 strings_array_free(pkg->depends, pkg->n_depends);
4913 }
4914
4915 free(pkg->pub);
4916 free(pkg->priv);
4917 free(pkg->fname);
4918 free(pkg->author);
4919 free(pkg->email);
4920 free(pkg->version);
4921 free(pkg->date);
4922 free(pkg->descrip);
4923 free(pkg->help);
4924 free(pkg->gui_help);
4925 free(pkg->Rdeps);
4926 free(pkg->sample);
4927 free(pkg->help_fname);
4928 free(pkg->gui_help_fname);
4929 free(pkg->sample_fname);
4930 free(pkg->tags);
4931 free(pkg->label);
4932 free(pkg->mpath);
4933 free(pkg->provider);
4934 free(pkg);
4935 }
4936 }
4937
function_package_free(fnpkg * pkg)4938 static void function_package_free (fnpkg *pkg)
4939 {
4940 real_function_package_free(pkg, 0);
4941 }
4942
function_package_free_full(fnpkg * pkg)4943 static void function_package_free_full (fnpkg *pkg)
4944 {
4945 real_function_package_free(pkg, 1);
4946 }
4947
4948 /* is the package with filename @fname already in memory? */
4949
get_loaded_pkg_by_filename(const char * fname,const char ** version)4950 static fnpkg *get_loaded_pkg_by_filename (const char *fname,
4951 const char **version)
4952 {
4953 int i;
4954
4955 if (fname == NULL) {
4956 return NULL;
4957 }
4958
4959 for (i=0; i<n_pkgs; i++) {
4960 if (!strcmp(fname, pkgs[i]->fname)) {
4961 if (version != NULL) {
4962 *version = pkgs[i]->version;
4963 }
4964 return pkgs[i];
4965 }
4966 }
4967
4968 return NULL;
4969 }
4970
4971 /**
4972 * function_package_unload_by_filename:
4973 * @fname: package filename.
4974 *
4975 * Unloads the specified function package from memory, if it
4976 * is currently loaded. The functions 'owned' by the package
4977 * are not destroyed; they become available for inclusion in
4978 * other packages.
4979 */
4980
function_package_unload_by_filename(const char * fname)4981 void function_package_unload_by_filename (const char *fname)
4982 {
4983 fnpkg *pkg = get_loaded_pkg_by_filename(fname, NULL);
4984
4985 if (pkg != NULL) {
4986 real_function_package_unload(pkg, 0);
4987 }
4988 }
4989
4990 /**
4991 * function_package_unload_full_by_filename:
4992 * @fname: package filename.
4993 *
4994 * Unloads the specified function package from memory, if it
4995 * is currently loaded. The functions 'owned' by the package
4996 * are also unloaded from memory.
4997 */
4998
function_package_unload_full_by_filename(const char * fname)4999 void function_package_unload_full_by_filename (const char *fname)
5000 {
5001 fnpkg *pkg = get_loaded_pkg_by_filename(fname, NULL);
5002
5003 if (pkg != NULL) {
5004 real_function_package_unload(pkg, 1);
5005 }
5006 }
5007
5008 /* append a function package to the recorder array of loaded
5009 packages */
5010
function_package_record(fnpkg * pkg)5011 static int function_package_record (fnpkg *pkg)
5012 {
5013 fnpkg **tmp;
5014 int err = 0;
5015
5016 tmp = realloc(pkgs, (n_pkgs + 1) * sizeof *tmp);
5017
5018 if (tmp == NULL) {
5019 err = E_ALLOC;
5020 } else {
5021 pkgs = tmp;
5022 pkgs[n_pkgs] = pkg;
5023 n_pkgs++;
5024 }
5025
5026 return err;
5027 }
5028
broken_package_error(fnpkg * pkg)5029 static int broken_package_error (fnpkg *pkg)
5030 {
5031 gretl_errmsg_sprintf("'%s': package contains "
5032 "duplicated function names",
5033 pkg->name);
5034 return E_DATA;
5035 }
5036
5037 #define fn_redef_msg(s) fprintf(stderr, "Redefining function '%s'\n", s)
5038
5039 /* When loading a private function the only real conflict would be
5040 with a function of the same name owned by the same package.
5041 Obviously this shouldn't happen but we'll whack it if it does.
5042 */
5043
load_private_function(fnpkg * pkg,int i)5044 static int load_private_function (fnpkg *pkg, int i)
5045 {
5046 ufunc *fun = pkg->priv[i];
5047 int j, err = 0;
5048
5049 for (j=0; j<n_ufuns; j++) {
5050 if (!strcmp(fun->name, ufuns[j]->name)) {
5051 if (pkg == ufuns[j]->pkg) {
5052 err = broken_package_error(pkg);
5053 break;
5054 }
5055 }
5056 }
5057
5058 if (!err) {
5059 err = add_allocated_ufunc(fun);
5060 }
5061
5062 if (!err && function_lookup(fun->name)) {
5063 gretl_warnmsg_sprintf(_("'%s' is the name of a built-in function"),
5064 fun->name);
5065 install_function_override(fun->name, fun->pkg->name, fun);
5066 pkg->overrides += 1;
5067 }
5068
5069 return err;
5070 }
5071
5072 /* When loading a public, packaged function we want to avoid conflicts
5073 with any non-private functions of the same name. In case we get a
5074 conflict with a public member of an already loaded distinct package
5075 we'll flag an error (otherwise things will get too confusing).
5076 */
5077
load_public_function(fnpkg * pkg,int i)5078 static int load_public_function (fnpkg *pkg, int i)
5079 {
5080 ufunc *fun = pkg->pub[i];
5081 int j, done = 0;
5082 int err = 0;
5083
5084 for (j=0; j<n_ufuns; j++) {
5085 if (!strcmp(fun->name, ufuns[j]->name)) {
5086 if (pkg == ufuns[j]->pkg) {
5087 /* name duplication in single package */
5088 err = broken_package_error(pkg);
5089 } else if (ufuns[j]->pkg == NULL) {
5090 /* conflicting unpackaged function */
5091 ufunc_free(ufuns[j]);
5092 ufuns[j] = fun;
5093 done = 1;
5094 } else if (!function_is_private(ufuns[j])) {
5095 /* got a conflicting package */
5096 gretl_errmsg_sprintf("The function %s is already defined "
5097 "by package '%s'", fun->name,
5098 ufuns[j]->pkg->name);
5099 err = E_DATA;
5100 break;
5101 }
5102 }
5103 }
5104
5105 if (!err && !done && function_lookup(fun->name)) {
5106 if (strcmp(fun->name, "bkw")) {
5107 /* for now, don't throw an error on loading Lee Adkins'
5108 bkw package */
5109 gretl_errmsg_sprintf(_("'%s' is the name of a built-in function"),
5110 fun->name);
5111 fprintf(stderr, "%s: function %s would override a built-in\n",
5112 pkg->name, fun->name);
5113 err = E_DATA;
5114 }
5115 }
5116
5117 if (!err && !done) {
5118 err = add_allocated_ufunc(fun);
5119 }
5120
5121 return err;
5122 }
5123
pkg_in_stack(const char * name,GArray * pstack)5124 static int pkg_in_stack (const char *name, GArray *pstack)
5125 {
5126 char *s;
5127 int i;
5128
5129 for (i=0; i<pstack->len; i++) {
5130 s = g_array_index(pstack, char *, i);
5131 if (!strcmp(name, s)) {
5132 return 1;
5133 }
5134 }
5135
5136 return 0;
5137 }
5138
load_gfn_dependencies(fnpkg * pkg,GArray * pstack)5139 static int load_gfn_dependencies (fnpkg *pkg, GArray *pstack)
5140 {
5141 int err = 0;
5142
5143 if (pkg->depends != NULL) {
5144 char *pkgpath;
5145 int i;
5146
5147 fprintf(stderr, "*** load_gfn_dependencies for %s ***\n", pkg->name);
5148
5149 for (i=0; i<pkg->n_depends && !err; i++) {
5150 const char *dep = pkg->depends[i];
5151
5152 if (get_function_package_by_name(dep) != NULL) {
5153 ; /* OK, already loaded */
5154 } else if (pkg_in_stack(dep, pstack)) {
5155 fprintf(stderr, " found %s in pstack\n", dep);
5156 ; /* don't go into infinite loop! */
5157 } else {
5158 fprintf(stderr, " trying for %s\n", dep);
5159 pkgpath = gretl_function_package_get_path(dep, PKG_ALL);
5160 if (pkgpath == NULL) {
5161 err = E_DATA;
5162 gretl_errmsg_sprintf("%s: dependency %s was not found",
5163 pkg->name, dep);
5164 } else {
5165 err = load_function_package(pkgpath, OPT_NONE,
5166 pstack, NULL);
5167 free(pkgpath);
5168 if (!err) {
5169 g_array_append_val(pstack, dep);
5170 }
5171 }
5172 }
5173 }
5174 }
5175
5176 return err;
5177 }
5178
5179 /* A 'real load' is in contrast to just reading some info from a
5180 package, as is done in various GUI contexts. We do the real load
5181 in response to some GUI commands, the "include" command, and also
5182 when re-opening a gretl session file that contains function
5183 packages.
5184 */
5185
real_load_package(fnpkg * pkg,GArray * pstack)5186 static int real_load_package (fnpkg *pkg, GArray *pstack)
5187 {
5188 int i, err = 0;
5189
5190 #if PKG_DEBUG
5191 fprintf(stderr, "real_load_package:\n loading '%s'\n", pkg->fname);
5192 #endif
5193
5194 gretl_error_clear();
5195
5196 if (pstack != NULL) {
5197 err = load_gfn_dependencies(pkg, pstack);
5198 }
5199
5200 if (!err && pkg->pub != NULL) {
5201 for (i=0; i<pkg->n_pub && !err; i++) {
5202 err = load_public_function(pkg, i);
5203 }
5204 }
5205
5206 if (!err && pkg->priv != NULL) {
5207 for (i=0; i<pkg->n_priv && !err; i++) {
5208 err = load_private_function(pkg, i);
5209 }
5210 }
5211
5212 if (!err && pkg->provider != NULL) {
5213 /* check that provider really got loaded */
5214 if (get_function_package_by_name(pkg->provider) == NULL) {
5215 gretl_errmsg_sprintf("Provider package %s is not loaded\n",
5216 pkg->provider);
5217 err = E_DATA;
5218 }
5219 }
5220
5221 if (!err) {
5222 /* add to array of loaded packages */
5223 err = function_package_record(pkg);
5224 }
5225
5226 return err;
5227 }
5228
data_needs_string(DataReq dr)5229 static const char *data_needs_string (DataReq dr)
5230 {
5231 if (dr == FN_NEEDS_TS) {
5232 return N_("Time-series data");
5233 } else if (dr == FN_NEEDS_QM) {
5234 return N_("Quarterly or monthly data");
5235 } else if (dr == FN_NEEDS_PANEL) {
5236 return N_("Panel data");
5237 } else if (dr == FN_NODATA_OK) {
5238 return N_("none");
5239 } else {
5240 return N_("some sort of dataset");
5241 }
5242 }
5243
print_package_info(const fnpkg * pkg,const char * fname,PRN * prn)5244 static void print_package_info (const fnpkg *pkg, const char *fname, PRN *prn)
5245 {
5246 char vstr[8];
5247 int remote, pdfdoc;
5248 int i;
5249
5250 remote = (strstr(fname, "dltmp.") != NULL);
5251
5252 if (!remote && g_path_is_absolute(fname)) {
5253 pprintf(prn, "<@itl=\"File\">: %s\n\n", fname);
5254 }
5255
5256 if (pkg->name[0] == '\0' || pkg->author == NULL ||
5257 pkg->minver <= 0 || pkg->descrip == NULL ||
5258 pkg->version == NULL || pkg->date == NULL ||
5259 pkg->help == NULL) {
5260 pprintf(prn, "\nBroken package! Basic information is missing\n");
5261 return;
5262 }
5263
5264 gretl_version_string(vstr, pkg->minver);
5265 pdfdoc = is_pdf_ref(pkg->help);
5266
5267 pprintf(prn, "<@itl=\"Package\">: %s %s (%s)\n", pkg->name, pkg->version,
5268 pkg->date);
5269 pprintf(prn, "<@itl=\"Author\">: %s\n", pkg->author);
5270 if (pkg->email != NULL && *pkg->email != '\0') {
5271 pprintf(prn, "<@itl=\"Email\">: %s\n", pkg->email);
5272 }
5273 pprintf(prn, "<@itl=\"Required gretl version\">: %s\n", vstr);
5274 pprintf(prn, "<@itl=\"Data requirement\">: %s\n", _(data_needs_string(pkg->dreq)));
5275 pprintf(prn, "<@itl=\"Description\">: %s\n", gretl_strstrip(pkg->descrip));
5276 if (pkg->n_depends > 0) {
5277 pputs(prn, "<@itl=\"Dependencies\">: ");
5278 for (i=0; i<pkg->n_depends; i++) {
5279 pprintf(prn, "%s%s", pkg->depends[i],
5280 (i < pkg->n_depends-1)? ", " : "\n");
5281 }
5282 }
5283 if (pkg->provider != NULL) {
5284 pprintf(prn, "<@itl=\"Provider\">: %s\n", pkg->provider);
5285 }
5286
5287 if (pdfdoc) {
5288 const char *s = strrchr(pkg->help, ':');
5289
5290 if (remote) {
5291 pprintf(prn, "<@itl=\"Documentation\">: %s\n\n", s + 1);
5292 } else {
5293 gchar *localpdf = g_strdup(fname);
5294 gchar *p = strrchr(localpdf, '.');
5295
5296 *p = '\0';
5297 strcat(p, ".pdf");
5298 pprintf(prn, "<@itl=\"Documentation\">: <@adb=\"%s\">\n\n", localpdf);
5299 g_free(localpdf);
5300 }
5301 } else {
5302 pputc(prn, '\n');
5303 }
5304
5305 if (pkg->pub != NULL) {
5306 if (pkg->n_pub == 1) {
5307 if (strcmp(pkg->pub[0]->name, pkg->name)) {
5308 pputs(prn, "<@itl=\"Public interface\">: ");
5309 pputs(prn, "<mono>\n");
5310 pprintf(prn, "%s()\n", pkg->pub[0]->name);
5311 pputs(prn, "</mono>\n\n");
5312 }
5313 } else {
5314 pputs(prn, "<@itl=\"Public interfaces\">:\n\n");
5315 pputs(prn, "<mono>\n");
5316 for (i=0; i<pkg->n_pub; i++) {
5317 pprintf(prn, " %s()\n", pkg->pub[i]->name);
5318 }
5319 pputs(prn, "</mono>\n\n");
5320 }
5321 }
5322
5323 if (!pdfdoc) {
5324 pputs(prn, "<@itl=\"Help text\">:\n\n");
5325 pputs(prn, "<mono>\n");
5326 pputs(prn, pkg->help);
5327 pputs(prn, "\n\n");
5328 pputs(prn, "</mono>\n");
5329 }
5330
5331 if (remote && pkg->sample != NULL) {
5332 pputs(prn, "<@itl=\"Sample script\">:\n\n");
5333 pputs(prn, "<code>\n");
5334 pputs(prn, pkg->sample);
5335 pputs(prn, "</code>\n");
5336 pputc(prn, '\n');
5337 }
5338 }
5339
plain_print_package_info(const fnpkg * pkg,const char * fname,PRN * prn)5340 static void plain_print_package_info (const fnpkg *pkg,
5341 const char *fname,
5342 PRN *prn)
5343 {
5344 char vstr[8];
5345 int i;
5346
5347 if (g_path_is_absolute(fname) && !strstr(fname, "dltmp.")) {
5348 pprintf(prn, "File: %s\n", fname);
5349 }
5350 if (pkg->name[0] == '\0' || pkg->author == NULL ||
5351 pkg->minver <= 0 || pkg->descrip == NULL ||
5352 pkg->version == NULL || pkg->date == NULL ||
5353 pkg->help == NULL) {
5354 pprintf(prn, "Broken package! Basic information is missing\n");
5355 return;
5356 }
5357
5358 gretl_version_string(vstr, pkg->minver);
5359
5360 pprintf(prn, "Package: %s %s (%s)\n", pkg->name, pkg->version, pkg->date);
5361 pprintf(prn, "Author: %s\n", pkg->author);
5362 if (pkg->email != NULL && *pkg->email != '\0') {
5363 pprintf(prn, "Email: %s\n", pkg->email);
5364 }
5365 pprintf(prn, "Required gretl version: %s (%d)\n", vstr, pkg->minver);
5366 pprintf(prn, "Data requirement: %s\n", _(data_needs_string(pkg->dreq)));
5367 pprintf(prn, "Description: %s\n", gretl_strstrip(pkg->descrip));
5368 if (pkg->n_depends > 0) {
5369 pputs(prn, "Dependencies: ");
5370 for (i=0; i<pkg->n_depends; i++) {
5371 pprintf(prn, "%s%s", pkg->depends[i],
5372 (i < pkg->n_depends-1)? ", " : "\n");
5373 }
5374 }
5375 if (pkg->provider != NULL) {
5376 pprintf(prn, "Provider: %s\n", pkg->provider);
5377 }
5378 pputc(prn, '\n');
5379 }
5380
real_bundle_package_info(const fnpkg * pkg,const char * fname,gretl_bundle * b)5381 static void real_bundle_package_info (const fnpkg *pkg,
5382 const char *fname,
5383 gretl_bundle *b)
5384 {
5385 int err = 0;
5386
5387 if (g_path_is_absolute(fname) && !strstr(fname, "dltmp.")) {
5388 gretl_bundle_set_string(b, "file", fname);
5389 }
5390 if (pkg->name[0] == '\0' || pkg->author == NULL ||
5391 pkg->minver <= 0 || pkg->descrip == NULL ||
5392 pkg->version == NULL || pkg->date == NULL ||
5393 pkg->help == NULL) {
5394 gretl_bundle_set_int(b, "broken", 1);
5395 return;
5396 }
5397
5398 gretl_bundle_set_string(b, "name", pkg->name);
5399 gretl_bundle_set_string(b, "author", pkg->author);
5400 gretl_bundle_set_scalar(b, "version", dot_atof(pkg->version));
5401 gretl_bundle_set_string(b, "date", pkg->date);
5402 if (pkg->email != NULL && *pkg->email != '\0') {
5403 gretl_bundle_set_string(b, "email", pkg->email);
5404 }
5405 gretl_bundle_set_int(b, "gretl_version", pkg->minver);
5406 gretl_bundle_set_string(b, "description", gretl_strstrip(pkg->descrip));
5407 gretl_bundle_set_int(b, "gretl_version", pkg->minver);
5408 gretl_bundle_set_string(b, "data_requirement", data_needs_string(pkg->dreq));
5409
5410 if (pkg->n_depends > 0) {
5411 gretl_array *D = gretl_array_from_strings(pkg->depends,
5412 pkg->n_depends,
5413 1, &err);
5414 gretl_bundle_donate_data(b, "depends", D, GRETL_TYPE_ARRAY, 0);
5415 }
5416 if (pkg->provider != NULL) {
5417 gretl_bundle_set_string(b, "provider", pkg->provider);
5418 }
5419 }
5420
5421 /* simple plain-text help output */
5422
print_package_help(const fnpkg * pkg,const char * fname,PRN * prn)5423 static void print_package_help (const fnpkg *pkg,
5424 const char *fname,
5425 PRN *prn)
5426 {
5427 char *rem, line[2048];
5428 int i, lmax = 76;
5429
5430 pprintf(prn, "%s %s (%s), %s\n", pkg->name, pkg->version,
5431 pkg->date, pkg->author);
5432 pputs(prn, gretl_strstrip(pkg->descrip));
5433 pputs(prn, "\n\n");
5434
5435 /* try reflowing the help text if lines are too long
5436 for presentation in console */
5437
5438 bufgets_init(pkg->help);
5439 while (bufgets(line, sizeof line, pkg->help)) {
5440 if (strlen(line) <= lmax) {
5441 pputs(prn, line);
5442 } else {
5443 rem = line;
5444 while (strlen(rem) > lmax) {
5445 for (i=lmax-1; i>0; i--) {
5446 if (rem[i] == ' ') {
5447 rem[i] = '\0';
5448 pprintf(prn, "%s\n", rem);
5449 rem = rem + i + 1;
5450 break;
5451 }
5452 }
5453 if (rem - line == 0) {
5454 /* let's not get into an infinite loop */
5455 break;
5456 }
5457 }
5458 if (*rem != '\0') {
5459 pputs(prn, rem);
5460 }
5461 }
5462 }
5463 bufgets_finalize(pkg->help);
5464
5465 pputs(prn, "\n\n");
5466 }
5467
print_package_code(const fnpkg * pkg,int tabwidth,PRN * prn)5468 static void print_package_code (const fnpkg *pkg,
5469 int tabwidth,
5470 PRN *prn)
5471 {
5472 int i;
5473
5474 pprintf(prn, "# hansl code from package %s %s (%s)\n\n",
5475 pkg->name, pkg->version, pkg->date);
5476
5477 if (pkg->priv != NULL) {
5478 pputs(prn, "# private functions\n\n");
5479 for (i=0; i<pkg->n_priv; i++) {
5480 gretl_function_print_code(pkg->priv[i], tabwidth, prn);
5481 pputc(prn, '\n');
5482 }
5483 }
5484
5485 if (pkg->pub != NULL) {
5486 pputs(prn, "# public functions\n\n");
5487 for (i=0; i<pkg->n_pub; i++) {
5488 gretl_function_print_code(pkg->pub[i], tabwidth, prn);
5489 pputc(prn, '\n');
5490 }
5491 }
5492 }
5493
5494 /* Handle any old references to Model/TSModels/TSMulti;
5495 now moved to Model/TSMulti (2019-12-07).
5496 */
5497
maybe_update_ts_path(fnpkg * pkg)5498 static void maybe_update_ts_path (fnpkg *pkg)
5499 {
5500 if (pkg->mpath != NULL) {
5501 if (!strcmp(pkg->mpath, "MAINWIN/Model/TSModels/TSMulti")) {
5502 free(pkg->mpath);
5503 pkg->mpath = gretl_strdup("MAINWIN/Model/TSMulti");
5504 }
5505 }
5506 }
5507
5508 /* allocate a fnpkg structure and read from XML file into it */
5509
5510 static fnpkg *
real_read_package(xmlDocPtr doc,xmlNodePtr node,const char * fname,int get_funcs,int * err)5511 real_read_package (xmlDocPtr doc, xmlNodePtr node,
5512 const char *fname, int get_funcs,
5513 int *err)
5514 {
5515 xmlNodePtr cur;
5516 fnpkg *pkg;
5517 char *tmp = NULL;
5518
5519 #if PKG_DEBUG
5520 fprintf(stderr, "real_read_package: fname='%s'\n", fname);
5521 #endif
5522
5523 pkg = function_package_alloc(fname);
5524 if (pkg == NULL) {
5525 *err = E_ALLOC;
5526 return NULL;
5527 }
5528
5529 gretl_xml_get_prop_as_string(node, "name", &tmp);
5530
5531 if (tmp == NULL) {
5532 fprintf(stderr, "real_read_package: package has no name\n");
5533 *err = E_DATA;
5534 function_package_free(pkg);
5535 return NULL;
5536 }
5537
5538 strncat(pkg->name, tmp, FN_NAMELEN - 1);
5539 free(tmp);
5540
5541 if (gretl_xml_get_prop_as_bool(node, NEEDS_TS)) {
5542 pkg->dreq = FN_NEEDS_TS;
5543 } else if (gretl_xml_get_prop_as_bool(node, NEEDS_QM)) {
5544 pkg->dreq = FN_NEEDS_QM;
5545 } else if (gretl_xml_get_prop_as_bool(node, NEEDS_PANEL)) {
5546 pkg->dreq = FN_NEEDS_PANEL;
5547 } else if (gretl_xml_get_prop_as_bool(node, NO_DATA_OK)) {
5548 pkg->dreq = FN_NODATA_OK;
5549 }
5550
5551 if (gretl_xml_get_prop_as_string(node, "model-requirement", &tmp)) {
5552 pkg->modelreq = gretl_command_number(tmp);
5553 free(tmp);
5554 }
5555
5556 if (gretl_xml_get_prop_as_string(node, "minver", &tmp)) {
5557 pkg->minver = gretl_version_number(tmp);
5558 free(tmp);
5559 }
5560
5561 pkg->uses_subdir = gretl_xml_get_prop_as_bool(node, "lives-in-subdir");
5562 pkg->data_access = gretl_xml_get_prop_as_bool(node, "wants-data-access");
5563
5564 cur = node->xmlChildrenNode;
5565
5566 while (cur != NULL) {
5567 if (!xmlStrcmp(cur->name, (XUC) "author")) {
5568 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->author);
5569 gretl_xml_get_prop_as_string(cur, "email", &pkg->email);
5570 } else if (!xmlStrcmp(cur->name, (XUC) "version")) {
5571 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->version);
5572 } else if (!xmlStrcmp(cur->name, (XUC) "date")) {
5573 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->date);
5574 } else if (!xmlStrcmp(cur->name, (XUC) "description")) {
5575 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->descrip);
5576 } else if (!xmlStrcmp(cur->name, (XUC) "help")) {
5577 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->help);
5578 gretl_xml_get_prop_as_string(cur, "filename", &pkg->help_fname);
5579 } else if (!xmlStrcmp(cur->name, (XUC) "gui-help")) {
5580 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->gui_help);
5581 gretl_xml_get_prop_as_string(cur, "filename", &pkg->gui_help_fname);
5582 } else if (!xmlStrcmp(cur->name, (XUC) "R-depends")) {
5583 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->Rdeps);
5584 } else if (!xmlStrcmp(cur->name, (XUC) "sample-script")) {
5585 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->sample);
5586 gretl_xml_get_prop_as_string(cur, "filename", &pkg->sample_fname);
5587 } else if (!xmlStrcmp(cur->name, (XUC) "tags")) {
5588 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->tags);
5589 } else if (!xmlStrcmp(cur->name, (XUC) "label")) {
5590 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->label);
5591 } else if (!xmlStrcmp(cur->name, (XUC) "menu-attachment")) {
5592 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->mpath);
5593 maybe_update_ts_path(pkg);
5594 } else if (!xmlStrcmp(cur->name, (XUC) "provider")) {
5595 gretl_xml_node_get_trimmed_string(cur, doc, &pkg->provider);
5596 } else if (!xmlStrcmp(cur->name, (XUC) "data-files")) {
5597 pkg->datafiles =
5598 gretl_xml_get_strings_array(cur, doc, &pkg->n_files,
5599 0, err);
5600 } else if (!xmlStrcmp(cur->name, (XUC) "depends")) {
5601 pkg->depends =
5602 gretl_xml_get_strings_array(cur, doc, &pkg->n_depends,
5603 0, err);
5604 }
5605
5606 cur = cur->next;
5607 }
5608
5609 if (get_funcs) {
5610 cur = node->xmlChildrenNode;
5611 while (cur != NULL && !*err) {
5612 if (!xmlStrcmp(cur->name, (XUC) "gretl-function")) {
5613 *err = read_ufunc_from_xml(cur, doc, pkg);
5614 }
5615 cur = cur->next;
5616 }
5617 }
5618
5619 #if PKG_DEBUG
5620 fprintf(stderr, "real_read_package: err = %d\n", *err);
5621 #endif
5622
5623 return pkg;
5624 }
5625
5626 /* read aggregated file that may contain one or more function packages
5627 and one or more "loose" functions */
5628
read_session_functions_file(const char * fname)5629 int read_session_functions_file (const char *fname)
5630 {
5631 fnpkg *pkg = NULL;
5632 xmlDocPtr doc = NULL;
5633 xmlNodePtr node = NULL;
5634 xmlNodePtr cur;
5635 #ifdef HAVE_MPI
5636 int get_caller = 0;
5637 #endif
5638 int err = 0;
5639
5640 #if PKG_DEBUG
5641 fprintf(stderr, "read_session_functions_file: starting on '%s'\n", fname);
5642 #endif
5643
5644 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
5645 if (err) {
5646 return err;
5647 }
5648
5649 #ifdef HAVE_MPI
5650 if (gretl_mpi_rank() >= 0) {
5651 get_caller = 1;
5652 }
5653 #endif
5654
5655 /* get any function packages from this file */
5656 cur = node->xmlChildrenNode;
5657 while (cur != NULL && !err) {
5658 if (!xmlStrcmp(cur->name, (XUC) "gretl-function-package")) {
5659 pkg = real_read_package(doc, cur, fname, 1, &err);
5660 if (!err) {
5661 err = real_load_package(pkg, NULL);
5662 }
5663 }
5664 #ifdef HAVE_MPI
5665 else if (get_caller && !xmlStrcmp(cur->name, (XUC) "caller")) {
5666 /* are these functions being loaded from within a
5667 function that's calling mpi?
5668 */
5669 char *caller = gretl_xml_get_string(cur, doc);
5670
5671 if (caller != NULL) {
5672 strcpy(mpi_caller, caller);
5673 free(caller);
5674 }
5675 get_caller = 0;
5676 }
5677 #endif
5678 cur = cur->next;
5679 }
5680
5681 /* then get any unpackaged functions */
5682 if (!err) {
5683 cur = node->xmlChildrenNode;
5684 while (cur != NULL && !err) {
5685 if (!xmlStrcmp(cur->name, (XUC) "gretl-function")) {
5686 err = read_ufunc_from_xml(cur, doc, NULL);
5687 }
5688 cur = cur->next;
5689 }
5690 }
5691
5692 if (doc != NULL) {
5693 xmlFreeDoc(doc);
5694 }
5695
5696 #if PKG_DEBUG
5697 fprintf(stderr, "read_session_functions_file: returning %d\n", err);
5698 #endif
5699
5700 return err;
5701 }
5702
5703 /* Parse an XML function package file and return an allocated
5704 package struct with the functions attached. Note that this
5705 function does not actually "load" the package (making it
5706 available to users) and does not check dependencies.
5707 */
5708
read_package_file(const char * fname,int get_funcs,int * err)5709 static fnpkg *read_package_file (const char *fname,
5710 int get_funcs,
5711 int *err)
5712 {
5713 fnpkg *pkg = NULL;
5714 xmlDocPtr doc = NULL;
5715 xmlNodePtr node = NULL;
5716 xmlNodePtr cur;
5717
5718 #if PKG_DEBUG
5719 fprintf(stderr, "read_package_file: got '%s'\n", fname);
5720 #endif
5721
5722 *err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
5723 if (*err) {
5724 return NULL;
5725 }
5726
5727 cur = node->xmlChildrenNode;
5728 while (cur != NULL && !*err) {
5729 if (!xmlStrcmp(cur->name, (XUC) "gretl-function-package")) {
5730 pkg = real_read_package(doc, cur, fname, get_funcs, err);
5731 break;
5732 }
5733 cur = cur->next;
5734 }
5735
5736 if (doc != NULL) {
5737 xmlFreeDoc(doc);
5738 }
5739
5740 if (!*err && pkg == NULL) {
5741 *err = E_DATA;
5742 }
5743
5744 #if PKG_DEBUG
5745 fprintf(stderr, "read_function_package: err = %d\n", *err);
5746 #endif
5747
5748 return pkg;
5749 }
5750
package_peek_dependencies(const char * fname,int * ndeps)5751 char **package_peek_dependencies (const char *fname, int *ndeps)
5752 {
5753 char **deps = NULL;
5754 fnpkg *pkg;
5755 int err = 0;
5756
5757 pkg = read_package_file(fname, 0, &err);
5758
5759 if (pkg != NULL) {
5760 deps = pkg->depends; /* stolen! */
5761 *ndeps = pkg->n_depends;
5762 pkg->depends = NULL;
5763 pkg->n_depends = 0;
5764 function_package_free(pkg);
5765 } else {
5766 *ndeps = 0;
5767 }
5768
5769 return deps;
5770 }
5771
5772 /**
5773 * function_package_is_loaded:
5774 * @fname: full path to gfn file.
5775 * @version: location to receive version info, or NULL.
5776 *
5777 * Returns: 1 if the function package with filename @fname is
5778 * loaded in memory, otherwise 0.
5779 */
5780
function_package_is_loaded(const char * fname,const char ** version)5781 int function_package_is_loaded (const char *fname,
5782 const char **version)
5783 {
5784 return (get_loaded_pkg_by_filename(fname, version) != NULL);
5785 }
5786
5787 /**
5788 * gfn_is_loaded:
5789 * @gfnname: basename of gfn file, including suffix.
5790 *
5791 * Returns: 1 if the function package with basename @gfnname is
5792 * loaded in memory, otherwise 0.
5793 */
5794
gfn_is_loaded(const char * gfnname)5795 int gfn_is_loaded (const char *gfnname)
5796 {
5797 int ret = 0;
5798
5799 if (strchr(gfnname, SLASH) == NULL && has_suffix(gfnname, ".gfn")) {
5800 /* plain basename of gfn file */
5801 gchar *test = g_strdup(gfnname);
5802 gchar *p = strrchr(test, '.');
5803
5804 *p = '\0';
5805 if (get_function_package_by_name(test)) {
5806 ret = 1;
5807 }
5808 g_free(test);
5809 }
5810
5811 return ret;
5812 }
5813
not_mpi_duplicate(void)5814 static int not_mpi_duplicate (void)
5815 {
5816 #ifdef HAVE_MPI
5817 return gretl_mpi_rank() < 1;
5818 #else
5819 return 0;
5820 #endif
5821 }
5822
check_for_loaded(const char * fname,gretlopt opt)5823 static fnpkg *check_for_loaded (const char *fname, gretlopt opt)
5824 {
5825 fnpkg *pkg = get_loaded_pkg_by_filename(fname, NULL);
5826
5827 if (pkg != NULL) {
5828 if (opt & OPT_F) {
5829 /* force re-reading from file */
5830 real_function_package_unload(pkg, 1);
5831 pkg = NULL;
5832 }
5833 }
5834
5835 return pkg;
5836 }
5837
maybe_print_R_info(fnpkg * pkg,PRN * prn)5838 static void maybe_print_R_info (fnpkg *pkg, PRN *prn)
5839 {
5840 if (pkg->Rdeps != NULL) {
5841 pputs(prn, "# Notice: this package requires GNU R.\n"
5842 "# It is known to work with the following version of R,\n"
5843 "# plus required R package(s) if applicable:\n");
5844 pprintf(prn, "#\n# %s\n#\n", pkg->Rdeps);
5845 pputs(prn, "# It will likely work with later versions but that is\n"
5846 "# not guaranteed.\n\n");
5847 }
5848 }
5849
5850 /**
5851 * load_function_package:
5852 * @fname: full path to gfn file.
5853 * @opt: may include OPT_F to force loading even when
5854 * the package is already loaded.
5855 * @prn: gretl printer.
5856 *
5857 * Loads the function package located by @fname into
5858 * memory, if possible. Supports gretl's "include" command
5859 * for gfn files.
5860 *
5861 * Returns: 0 on success, non-zero code on error.
5862 */
5863
load_function_package(const char * fname,gretlopt opt,GArray * pstack,PRN * prn)5864 static int load_function_package (const char *fname,
5865 gretlopt opt,
5866 GArray *pstack,
5867 PRN *prn)
5868 {
5869 fnpkg *pkg;
5870 int err = 0;
5871
5872 pkg = check_for_loaded(fname, opt);
5873 if (pkg != NULL) {
5874 return 0;
5875 }
5876
5877 pkg = read_package_file(fname, 1, &err);
5878 if (!err) {
5879 /* Let's double-check that we don't have a
5880 colliding package (it would have to be
5881 with a different filename).
5882 */
5883 fnpkg *oldpkg;
5884
5885 oldpkg = get_function_package_by_name(pkg->name);
5886 if (oldpkg != NULL) {
5887 real_function_package_unload(oldpkg, 1);
5888 }
5889 err = real_load_package(pkg, pstack);
5890 }
5891
5892 if (err) {
5893 fprintf(stderr, "load function package: failed on %s\n", fname);
5894 } else if (pkg != NULL) {
5895 if (prn != NULL && not_mpi_duplicate()) {
5896 pprintf(prn, "%s %s, %s (%s)\n", pkg->name, pkg->version,
5897 pkg->date, pkg->author);
5898 maybe_print_R_info(pkg, prn);
5899 }
5900 }
5901
5902 return err;
5903 }
5904
5905 /**
5906 * include_gfn:
5907 * @fname: full path to gfn file.
5908 * @opt: may include OPT_F to force loading even when
5909 * the package is already loaded.
5910 * @prn: gretl printer.
5911 *
5912 * Loads the function package located by @fname into
5913 * memory, if possible. Supports gretl's "include" command
5914 * for gfn files.
5915 *
5916 * Returns: 0 on success, non-zero code on error.
5917 */
5918
include_gfn(const char * fname,gretlopt opt,PRN * prn)5919 int include_gfn (const char *fname, gretlopt opt, PRN *prn)
5920 {
5921 GArray *pstack;
5922 gchar *p, *pkgname;
5923 int err;
5924
5925 pkgname = g_path_get_basename(fname);
5926 p = strrchr(pkgname, '.');
5927 if (p != NULL) {
5928 *p = '\0';
5929 }
5930
5931 pstack = g_array_new(FALSE, FALSE, sizeof(char *));
5932 g_array_append_val(pstack, pkgname);
5933 err = load_function_package(fname, opt, pstack, prn);
5934 g_array_free(pstack, TRUE);
5935 g_free(pkgname);
5936
5937 return err;
5938 }
5939
5940 /**
5941 * get_function_package_by_filename:
5942 * @fname: gfn filename.
5943 * @err: location to receive error code.
5944 *
5945 * If the package whose filename is @fname is already loaded,
5946 * returns the package pointer, otherwise attempts to load the
5947 * package from file. Similar to include_gfn() but returns
5948 * the package pointer rather than just a status code.
5949 *
5950 * Returns: package-pointer on success, NULL on error.
5951 */
5952
get_function_package_by_filename(const char * fname,int * err)5953 fnpkg *get_function_package_by_filename (const char *fname, int *err)
5954 {
5955 fnpkg *pkg = NULL;
5956 int i, myerr = 0;
5957
5958 for (i=0; i<n_pkgs; i++) {
5959 if (!strcmp(fname, pkgs[i]->fname)) {
5960 pkg = pkgs[i];
5961 break;
5962 }
5963 }
5964
5965 if (pkg == NULL) {
5966 myerr = include_gfn(fname, OPT_NONE, NULL);
5967 if (!myerr) {
5968 for (i=0; i<n_pkgs; i++) {
5969 if (!strcmp(fname, pkgs[i]->fname)) {
5970 pkg = pkgs[i];
5971 break;
5972 }
5973 }
5974 }
5975 }
5976
5977 if (err != NULL) {
5978 *err = myerr;
5979 }
5980
5981 return pkg;
5982 }
5983
5984 /**
5985 * get_function_package_by_name:
5986 * @pkgname: name of function package.
5987 *
5988 * Returns: pointer to function package if a package named
5989 * @pkgname is already in memory, otherwise NULL.
5990 */
5991
get_function_package_by_name(const char * pkgname)5992 fnpkg *get_function_package_by_name (const char *pkgname)
5993 {
5994 int i;
5995
5996 if (has_suffix(pkgname, ".gfn") || has_suffix(pkgname, ".zip")) {
5997 /* just in case: strip off the extension */
5998 gchar *tmp = g_strdup(pkgname);
5999 gchar *p = strrchr(tmp, '.');
6000 fnpkg *ret = NULL;
6001
6002 *p = '\0';
6003 for (i=0; i<n_pkgs; i++) {
6004 if (!strcmp(tmp, pkgs[i]->name)) {
6005 ret = pkgs[i];
6006 break;
6007 }
6008 }
6009 g_free(tmp);
6010 return ret;
6011 } else {
6012 for (i=0; i<n_pkgs; i++) {
6013 if (!strcmp(pkgname, pkgs[i]->name)) {
6014 return pkgs[i];
6015 }
6016 }
6017 return NULL;
6018 }
6019 }
6020
6021 /**
6022 * get_function_package_path_by_name:
6023 * @pkgname: name of function package.
6024 *
6025 * Returns: the full path to the named function package if it
6026 * is already in memory, otherwise NULL.
6027 */
6028
get_function_package_path_by_name(const char * pkgname)6029 const char *get_function_package_path_by_name (const char *pkgname)
6030 {
6031 int i;
6032
6033 for (i=0; i<n_pkgs; i++) {
6034 if (!strcmp(pkgname, pkgs[i]->name)) {
6035 return pkgs[i]->fname;
6036 }
6037 }
6038
6039 return NULL;
6040 }
6041
gfn_version_fail(const char * fname,PRN * prn)6042 static int gfn_version_fail (const char *fname, PRN *prn)
6043 {
6044 FILE *fp = gretl_fopen(fname, "r");
6045 int err = 0;
6046
6047 if (fp != NULL) {
6048 char line[128];
6049
6050 if (fgets(line, sizeof line, fp) &&
6051 strchr(line, '<') == NULL &&
6052 strstr(line, "requires gretl") != NULL) {
6053 gretl_errmsg_set(gretl_strstrip(line));
6054 err = 1;
6055 }
6056 fclose(fp);
6057 }
6058
6059 return err;
6060 }
6061
6062 /* Retrieve summary info, sample script, or code listing for a
6063 function package, identified by its filename. This is called
6064 (indirectly) from the GUI (see below for the actual callbacks).
6065 */
6066
real_print_gfn_data(const char * fname,PRN * prn,int tabwidth,int task,gretl_bundle * b)6067 static int real_print_gfn_data (const char *fname, PRN *prn,
6068 int tabwidth, int task,
6069 gretl_bundle *b)
6070 {
6071 fnpkg *pkg = NULL;
6072 int free_pkg = 0;
6073 int err = 0;
6074
6075 #if PKG_DEBUG
6076 fprintf(stderr, "real_print_gfn_data: fname='%s', task %d\n", fname, task);
6077 #endif
6078
6079 if (task == FUNCS_INFO && prn != NULL && strstr(fname, "dltmp.")) {
6080 if (gfn_version_fail(fname, prn)) {
6081 return 1;
6082 }
6083 }
6084
6085 pkg = get_loaded_pkg_by_filename(fname, NULL);
6086
6087 #if PKG_DEBUG
6088 fprintf(stderr, "real_print_gfn_data: pkg=%p\n", (void *) pkg);
6089 #endif
6090
6091 if (pkg == NULL) {
6092 /* package is not loaded, read it now */
6093 int get_funcs = 1;
6094
6095 if (task == FUNCS_HELP || task == FUNCS_INFO ||
6096 task == FUNCS_SAMPLE || task == FUNCS_QUERY) {
6097 get_funcs = 0;
6098 }
6099 pkg = read_package_file(fname, get_funcs, &err);
6100 free_pkg = 1;
6101 }
6102
6103 if (!err) {
6104 if (task == FUNCS_HELP) {
6105 print_package_help(pkg, fname, prn);
6106 } else if (task == FUNCS_INFO) {
6107 print_package_info(pkg, fname, prn);
6108 } else if (task == FUNCS_QUERY) {
6109 if (b != NULL) {
6110 real_bundle_package_info(pkg, fname, b);
6111 } else {
6112 plain_print_package_info(pkg, fname, prn);
6113 }
6114 } else if (task == FUNCS_SAMPLE) {
6115 pputs(prn, pkg->sample);
6116 } else {
6117 print_package_code(pkg, tabwidth, prn);
6118 }
6119 if (free_pkg) {
6120 function_package_free_full(pkg);
6121 }
6122 }
6123
6124 #if PKG_DEBUG
6125 fprintf(stderr, "real_get_function_file_info: err = %d (free_pkg = %d)\n",
6126 err, free_pkg);
6127 #endif
6128
6129 return err;
6130 }
6131
6132 /* callback used in the GUI function package browser */
6133
print_function_package_info(const char * fname,int gui_mode,PRN * prn)6134 int print_function_package_info (const char *fname, int gui_mode,
6135 PRN *prn)
6136 {
6137 int mode = gui_mode ? FUNCS_INFO : FUNCS_QUERY;
6138
6139 return real_print_gfn_data(fname, prn, 0, mode, NULL);
6140 }
6141
6142 /* callback used by "pkg" command with query action + --quiet */
6143
bundle_function_package_info(const char * fname,gretl_bundle * b)6144 int bundle_function_package_info (const char *fname, gretl_bundle *b)
6145 {
6146 return real_print_gfn_data(fname, NULL, 0, FUNCS_QUERY, b);
6147 }
6148
6149 /* callback used in the GUI function package browser */
6150
print_function_package_code(const char * fname,int tabwidth,PRN * prn)6151 int print_function_package_code (const char *fname, int tabwidth,
6152 PRN *prn)
6153 {
6154 return real_print_gfn_data(fname, prn, tabwidth, FUNCS_CODE, NULL);
6155 }
6156
6157 /* callback used in the GUI function package browser */
6158
print_function_package_sample(const char * fname,int tabwidth,PRN * prn)6159 int print_function_package_sample (const char *fname, int tabwidth,
6160 PRN *prn)
6161 {
6162 return real_print_gfn_data(fname, prn, tabwidth, FUNCS_SAMPLE, NULL);
6163 }
6164
6165 /* callback used via command line */
6166
print_function_package_help(const char * fname,PRN * prn)6167 int print_function_package_help (const char *fname, PRN *prn)
6168 {
6169 return real_print_gfn_data(fname, prn, 0, FUNCS_HELP, NULL);
6170 }
6171
maybe_fix_broken_date(char ** pdate)6172 static void maybe_fix_broken_date (char **pdate)
6173 {
6174 char *date = *pdate;
6175
6176 if (strlen(date) < 10 && date[4] == '-') {
6177 int y, m, d;
6178
6179 if (sscanf(date, "%d-%d-%d", &y, &m, &d) == 3) {
6180 char tmp[12];
6181
6182 sprintf(tmp, "%d-%02d-%02d", y, m, d);
6183 free(*pdate);
6184 *pdate = gretl_strdup(tmp);
6185 }
6186 }
6187 }
6188
6189 /* Read the header from a function package file -- this is used when
6190 displaying the available packages in the GUI. We write the
6191 description into *pdesc and a string representation of version
6192 number into *pver.
6193 */
6194
get_function_file_header(const char * fname,char ** pdesc,char ** pver,char ** pdate,char ** pauthor,int * pdfdoc)6195 int get_function_file_header (const char *fname, char **pdesc,
6196 char **pver, char **pdate,
6197 char **pauthor, int *pdfdoc)
6198 {
6199 xmlDocPtr doc = NULL;
6200 xmlNodePtr node = NULL;
6201 xmlNodePtr sub;
6202 int docdone = 0;
6203 int err = 0;
6204
6205 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
6206 if (err) {
6207 return err;
6208 }
6209
6210 if (pdfdoc == NULL) {
6211 /* not wanted, so count it as "done" already */
6212 docdone = 1;
6213 } else {
6214 *pdfdoc = 0;
6215 }
6216
6217 node = node->xmlChildrenNode;
6218 while (node != NULL) {
6219 if (!xmlStrcmp(node->name, (XUC) "gretl-function-package")) {
6220 sub = node->xmlChildrenNode;
6221 while (sub != NULL) {
6222 if (!xmlStrcmp(sub->name, (XUC) "description")) {
6223 gretl_xml_node_get_trimmed_string(sub, doc, pdesc);
6224 } else if (!xmlStrcmp(sub->name, (XUC) "version")) {
6225 gretl_xml_node_get_trimmed_string(sub, doc, pver);
6226 } else if (pdate != NULL && !xmlStrcmp(sub->name, (XUC) "date")) {
6227 gretl_xml_node_get_trimmed_string(sub, doc, pdate);
6228 if (*pdate != NULL) {
6229 maybe_fix_broken_date(pdate);
6230 }
6231 } else if (pauthor != NULL && !xmlStrcmp(sub->name, (XUC) "author")) {
6232 gretl_xml_node_get_trimmed_string(sub, doc, pauthor);
6233 } else if (pdfdoc != NULL && !xmlStrcmp(sub->name, (XUC) "help")) {
6234 char *tmp = NULL;
6235
6236 gretl_xml_node_get_trimmed_string(sub, doc, &tmp);
6237 if (tmp != NULL) {
6238 if (!strncmp(tmp, "pdfdoc", 6) || is_pdf_ref(tmp)) {
6239 *pdfdoc = 1;
6240 }
6241 free(tmp);
6242 }
6243 docdone = 1;
6244 }
6245 if (*pdesc != NULL && *pver != NULL && docdone) {
6246 break;
6247 }
6248 sub = sub->next;
6249 }
6250 if (*pdesc != NULL && *pver != NULL) {
6251 /* already got what we want */
6252 break;
6253 }
6254 }
6255 node = node->next;
6256 }
6257
6258 if (doc != NULL) {
6259 xmlFreeDoc(doc);
6260 }
6261
6262 if (*pdesc == NULL) {
6263 *pdesc = gretl_strdup(_("No description available"));
6264 }
6265
6266 if (*pver == NULL) {
6267 *pver = gretl_strdup("unknown");
6268 }
6269
6270 if (*pdesc == NULL || *pver == NULL) {
6271 err = E_ALLOC;
6272 }
6273
6274 return err;
6275 }
6276
package_has_menu_attachment(const char * fname,char ** pkgname,char ** attach,char ** label)6277 int package_has_menu_attachment (const char *fname,
6278 char **pkgname,
6279 char **attach,
6280 char **label)
6281 {
6282 xmlDocPtr doc = NULL;
6283 xmlNodePtr node = NULL;
6284 xmlNodePtr sub;
6285 char *tmp = NULL;
6286 int got_label = 0;
6287 int got_attach = 0;
6288 int stop = 0;
6289 int err = 0;
6290
6291 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
6292 if (err) {
6293 return 0;
6294 }
6295
6296 node = node->xmlChildrenNode;
6297
6298 while (!stop && node != NULL) {
6299 if (!xmlStrcmp(node->name, (XUC) "gretl-function-package")) {
6300 if (pkgname != NULL) {
6301 gretl_xml_get_prop_as_string(node, "name", pkgname);
6302 if (*pkgname != NULL && !strcmp(*pkgname, "ridge")) {
6303 /* don't put it into menu */
6304 stop = 1;
6305 }
6306 }
6307 sub = node->xmlChildrenNode;
6308 while (!stop && sub != NULL) {
6309 if (!xmlStrcmp(sub->name, (XUC) "menu-attachment")) {
6310 gretl_xml_node_get_trimmed_string(sub, doc, &tmp);
6311 if (tmp != NULL) {
6312 got_attach = 1;
6313 if (got_attach && got_label) {
6314 stop = 1;
6315 }
6316 if (attach != NULL) {
6317 *attach = tmp;
6318 } else {
6319 free(tmp);
6320 }
6321 }
6322 } else if (!xmlStrcmp(sub->name, (XUC) "label")) {
6323 gretl_xml_node_get_trimmed_string(sub, doc, &tmp);
6324 if (tmp != NULL) {
6325 got_label = 1;
6326 if (got_attach && got_label) {
6327 stop = 1;
6328 }
6329 if (label != NULL) {
6330 *label = tmp;
6331 } else {
6332 free(tmp);
6333 }
6334 }
6335 } else if (!xmlStrcmp(sub->name, (XUC) "help")) {
6336 /* we've overshot */
6337 stop = 1;
6338 }
6339 sub = sub->next;
6340 }
6341 }
6342 node = node->next;
6343 }
6344
6345 if (doc != NULL) {
6346 xmlFreeDoc(doc);
6347 }
6348
6349 return got_attach && got_label;
6350 }
6351
package_needs_zipping(const char * fname,int * pdfdoc,char *** datafiles,int * n_files)6352 int package_needs_zipping (const char *fname,
6353 int *pdfdoc,
6354 char ***datafiles,
6355 int *n_files)
6356 {
6357 xmlDocPtr doc = NULL;
6358 xmlNodePtr node = NULL;
6359 xmlNodePtr sub;
6360 char *tmp = NULL;
6361 int stop = 0;
6362 int retmax = 1;
6363 int ret = 0;
6364 int err = 0;
6365
6366 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
6367 if (err) {
6368 return 0;
6369 }
6370
6371 if (datafiles != NULL) {
6372 retmax = 2;
6373 }
6374
6375 node = node->xmlChildrenNode;
6376
6377 while (!stop && node != NULL) {
6378 if (!xmlStrcmp(node->name, (XUC) "gretl-function-package")) {
6379 sub = node->xmlChildrenNode;
6380 while (!stop && sub != NULL) {
6381 if (!xmlStrcmp(sub->name, (XUC) "help")) {
6382 gretl_xml_node_get_trimmed_string(sub, doc, &tmp);
6383 if (tmp != NULL && !strncmp(tmp, "pdfdoc:", 7)) {
6384 if (pdfdoc != NULL) {
6385 *pdfdoc = 1;
6386 }
6387 ret++;
6388 }
6389 free(tmp);
6390 } else if (!xmlStrcmp(sub->name, (XUC) "data-files")) {
6391 if (datafiles != NULL) {
6392 *datafiles = gretl_xml_get_strings_array(sub, doc, n_files,
6393 0, &err);
6394 }
6395 ret++;
6396 } else if (!xmlStrcmp(sub->name, (XUC) "gretl-function")) {
6397 /* we've overshot */
6398 stop = 1;
6399 }
6400 if (ret == retmax) {
6401 stop = 1;
6402 } else {
6403 sub = sub->next;
6404 }
6405 }
6406 }
6407 node = node->next;
6408 }
6409
6410 if (doc != NULL) {
6411 xmlFreeDoc(doc);
6412 }
6413
6414 return ret;
6415 }
6416
gfn_file_get_version(const char * fname)6417 double gfn_file_get_version (const char *fname)
6418 {
6419 xmlDocPtr doc = NULL;
6420 xmlNodePtr node;
6421 double version = NADBL;
6422 int err;
6423
6424 err = gretl_xml_open_doc_root(fname, "gretl-functions", &doc, &node);
6425
6426 if (!err) {
6427 xmlNodePtr sub;
6428 int found = 0;
6429
6430 node = node->xmlChildrenNode;
6431 while (node != NULL && !found) {
6432 if (!xmlStrcmp(node->name, (XUC) "gretl-function-package")) {
6433 sub = node->xmlChildrenNode;
6434 while (sub != NULL && !found) {
6435 if (!xmlStrcmp(sub->name, (XUC) "version")) {
6436 gretl_xml_node_get_double(sub, doc, &version);
6437 found = 1;
6438 }
6439 sub = sub->next;
6440 }
6441 }
6442 node = node->next;
6443 }
6444 }
6445
6446 if (doc != NULL) {
6447 xmlFreeDoc(doc);
6448 }
6449
6450 return version;
6451 }
6452
6453 /**
6454 * gretl_is_public_user_function:
6455 * @name: name to test.
6456 *
6457 * Returns: 1 if @name is the name of a user-defined
6458 * function that is not a private member of a function
6459 * package, otherwise 0.
6460 */
6461
gretl_is_public_user_function(const char * name)6462 int gretl_is_public_user_function (const char *name)
6463 {
6464 ufunc *fun = get_user_function_by_name(name);
6465
6466 return (fun != NULL && !function_is_private(fun));
6467 }
6468
set_current_function_package(fnpkg * pkg)6469 void set_current_function_package (fnpkg *pkg)
6470 {
6471 current_pkg = pkg;
6472 }
6473
skip_private_func(ufunc * ufun)6474 static int skip_private_func (ufunc *ufun)
6475 {
6476 int skip = 0;
6477
6478 if (function_is_private(ufun)) {
6479 /* skip it, unless we're "authorized" to edit it,
6480 i.e. coming from the gui package editor */
6481 skip = 1;
6482 if (ufun->pkg != NULL && ufun->pkg == current_pkg) {
6483 skip = 0;
6484 }
6485 }
6486
6487 return skip;
6488 }
6489
check_func_name(const char * name,ufunc ** pfun,const DATASET * dset,PRN * prn)6490 static int check_func_name (const char *name, ufunc **pfun,
6491 const DATASET *dset, PRN *prn)
6492 {
6493 int i, err = 0;
6494
6495 #if FN_DEBUG
6496 fprintf(stderr, "check_func_name: '%s'\n", name);
6497 #endif
6498
6499 if (!isalpha((unsigned char) *name)) {
6500 gretl_errmsg_set(_("Function names must start with a letter"));
6501 err = 1;
6502 } else if (gretl_reserved_word(name)) {
6503 err = 1;
6504 } else if (function_lookup(name)) {
6505 gretl_errmsg_sprintf(_("'%s' is the name of a built-in function"), name);
6506 err = 1;
6507 } else if (gretl_is_user_var(name)) {
6508 gretl_errmsg_sprintf(_("'%s' is the name of a variable"), name);
6509 err = 1;
6510 } else if (gretl_is_series(name, dset)) {
6511 gretl_errmsg_sprintf(_("'%s' is the name of a variable"), name);
6512 err = 1;
6513 } else {
6514 /* @name is OK, now check for existing function of the same name */
6515 for (i=0; i<n_ufuns; i++) {
6516 if (!skip_private_func(ufuns[i]) && !strcmp(name, ufuns[i]->name)) {
6517 #if FN_DEBUG
6518 fprintf(stderr, "'%s': found an existing function of this name\n", name);
6519 #endif
6520 if (ufuns[i]->pkg != NULL && ufuns[i]->pkg != current_pkg) {
6521 /* don't allow overwriting */
6522 gretl_errmsg_sprintf("The function %s is already defined "
6523 "by package '%s'", name,
6524 ufuns[i]->pkg->name);
6525 err = E_DATA;
6526 } else if (pfun != NULL) {
6527 clear_ufunc_data(ufuns[i]);
6528 *pfun = ufuns[i];
6529 } else {
6530 ufunc_unload(ufuns[i]);
6531 }
6532 break;
6533 }
6534 }
6535 }
6536
6537 return err;
6538 }
6539
maybe_delete_function(const char * fname,PRN * prn)6540 static int maybe_delete_function (const char *fname, PRN *prn)
6541 {
6542 ufunc *fun = get_user_function_by_name(fname);
6543 int err = 0;
6544
6545 if (fun == NULL) {
6546 ; /* no-op */
6547 } else if (function_in_use(fun)) {
6548 gretl_errmsg_sprintf("%s: function is in use", fname);
6549 err = 1;
6550 } else if (fun->pkg != NULL) {
6551 gretl_errmsg_sprintf("%s: function belongs to package", fname);
6552 err = 1;
6553 } else {
6554 ufunc_unload(fun);
6555 if (gretl_messages_on()) {
6556 pprintf(prn, _("Deleted function '%s'\n"), fname);
6557 }
6558 }
6559
6560 return err;
6561 }
6562
6563 /* next: apparatus for parsing function definitions */
6564
comma_count(const char * s)6565 static int comma_count (const char *s)
6566 {
6567 int quoted = 0;
6568 int braced = 0;
6569 int nc = 0;
6570
6571 while (*s) {
6572 if (!quoted) {
6573 if (*s == '{') {
6574 braced++;
6575 } else if (*s == '}') {
6576 braced--;
6577 }
6578 }
6579 if (*s == '"') {
6580 quoted = !quoted;
6581 } else if (!quoted && !braced && *s == ',') {
6582 nc++;
6583 }
6584 s++;
6585 }
6586
6587 return nc;
6588 }
6589
check_parm_min_max(fn_param * p,const char * name,int * nvals)6590 static int check_parm_min_max (fn_param *p, const char *name,
6591 int *nvals)
6592 {
6593 int err = 0;
6594
6595 if (p->type != GRETL_TYPE_DOUBLE && na(p->deflt)) {
6596 gretl_errmsg_sprintf("%s: parameters of type %s cannot have a "
6597 "default value of NA", name,
6598 gretl_type_get_name(p->type));
6599 err = E_DATA;
6600 }
6601
6602 if (!err && !na(p->min) && !na(p->max)) {
6603 if (p->min > p->max) {
6604 gretl_errmsg_sprintf("%s: min > max", name);
6605 err = E_DATA;
6606 } else if (!na(p->step) && p->step > p->max - p->min) {
6607 gretl_errmsg_sprintf("%s: step > max - min", name);
6608 err = E_DATA;
6609 }
6610 if (!err) {
6611 *nvals = (int) p->max - (int) p->min + 1;
6612 }
6613 }
6614
6615 if (!err && !na(p->deflt) && !default_unset(p)) {
6616 if (!na(p->min) && p->deflt < p->min) {
6617 gretl_errmsg_sprintf("%s: default value out of bounds", name);
6618 err = E_DATA;
6619 } else if (!na(p->max) && p->deflt > p->max) {
6620 gretl_errmsg_sprintf("%s: default value out of bounds", name);
6621 err = E_DATA;
6622 }
6623 }
6624
6625 return err;
6626 }
6627
colon_count(const char * p)6628 static int colon_count (const char *p)
6629 {
6630 int n = 0;
6631
6632 while (*p && *p != ']') {
6633 if (*p == ':') {
6634 n++;
6635 }
6636 p++;
6637 }
6638
6639 return n;
6640 }
6641
6642 #define VALDEBUG 0
6643
read_min_max_deflt(char ** ps,fn_param * param,const char * name,int * nvals)6644 static int read_min_max_deflt (char **ps, fn_param *param,
6645 const char *name, int *nvals)
6646 {
6647 char *p = *ps;
6648 int err = 0;
6649
6650 gretl_push_c_numeric_locale();
6651
6652 errno = 0;
6653
6654 if (!strcmp(p, "[null]")) {
6655 gretl_errmsg_set("'null' is not a valid default for scalars");
6656 err = E_TYPES;
6657 } else if (param->type == GRETL_TYPE_BOOL) {
6658 if (!strncmp(p, "[TRUE]", 6)) {
6659 param->deflt = 1;
6660 } else if (!strncmp(p, "[FALSE]", 7)) {
6661 param->deflt = 0;
6662 } else if (sscanf(p, "[%lf]", ¶m->deflt) != 1) {
6663 err = E_PARSE;
6664 }
6665 } else if (!strncmp(p, "[$xlist]", 8)) {
6666 param->deflt = INT_USE_XLIST;
6667 } else if (!strncmp(p, "[$mylist]", 9)) {
6668 param->deflt = INT_USE_MYLIST;
6669 } else {
6670 int i, len, nf = colon_count(p) + 1;
6671 char *test, valstr[32];
6672 char *q = p + 1;
6673 double x[4] = {NADBL, NADBL, UNSET_VALUE, NADBL};
6674
6675 for (i=0; i<nf && !err; i++) {
6676 len = strcspn(q, ":]");
6677 if (len > 31) {
6678 err = E_PARSE;
6679 } else if (len > 0) {
6680 *valstr = '\0';
6681 strncat(valstr, q, len);
6682 #if VALDEBUG > 1
6683 fprintf(stderr, "valstr(%d) = '%s'\n", i, valstr);
6684 #endif
6685 if (!strcmp(valstr, "NA")) {
6686 x[i] = NADBL;
6687 } else {
6688 x[i] = strtod(valstr, &test);
6689 if (*test != '\0' || errno) {
6690 err = E_PARSE;
6691 }
6692 }
6693 }
6694 q += len + 1;
6695 }
6696
6697 if (!err) {
6698 if (nf == 1) {
6699 /* we take a single value with no colons as
6700 indicating a default */
6701 param->deflt = x[0];
6702 } else {
6703 param->min = x[0];
6704 param->max = x[1];
6705 param->deflt = x[2];
6706 param->step = x[3];
6707 }
6708 #if VALDEBUG
6709 fprintf(stderr, "min %g, max %g, deflt %g, step %g\n",
6710 param->min, param->max, param->deflt, param->step);
6711 #endif
6712 err = check_parm_min_max(param, name, nvals);
6713 }
6714 }
6715
6716 gretl_pop_c_numeric_locale();
6717
6718 if (!err) {
6719 p = strchr(p, ']');
6720 if (p == NULL) {
6721 err = E_PARSE;
6722 } else {
6723 *ps = p + 1;
6724 }
6725 }
6726
6727 return err;
6728 }
6729
read_param_option(char ** ps,fn_param * param)6730 static int read_param_option (char **ps, fn_param *param)
6731 {
6732 int err = 0;
6733
6734 #if FNPARSE_DEBUG
6735 fprintf(stderr, "read_param_option: got '%s'\n", *ps);
6736 #endif
6737
6738 if (!strncmp(*ps, "[null]", 6)) {
6739 param->flags |= FP_OPTIONAL;
6740 *ps += 6;
6741 } else {
6742 gretl_errmsg_sprintf(_("got invalid field '%s'"), *ps);
6743 err = E_PARSE;
6744 }
6745
6746 return err;
6747 }
6748
6749 /* get the descriptive string for a function parameter */
6750
read_param_descrip(char ** ps,fn_param * param)6751 static int read_param_descrip (char **ps, fn_param *param)
6752 {
6753 char *p = *ps + 1; /* skip opening quote */
6754 int len = 0;
6755 int err = E_PARSE;
6756
6757 while (*p) {
6758 if (*p == '"') {
6759 /* OK, found closing quote */
6760 err = 0;
6761 break;
6762 }
6763 len++;
6764 p++;
6765 }
6766
6767 if (!err && len > 0) {
6768 p = *ps + 1;
6769 param->descrip = gretl_strndup(p, len);
6770 if (param->descrip == NULL) {
6771 err = E_ALLOC;
6772 } else {
6773 *ps = p + len + 1;
6774 }
6775 }
6776
6777 return err;
6778 }
6779
6780 /* get the value labels for a function parameter */
6781
read_param_labels(char ** ps,fn_param * param,const char * name,int nvals)6782 static int read_param_labels (char **ps, fn_param *param,
6783 const char *name, int nvals)
6784 {
6785 char *p = *ps + 1; /* skip opening '{' */
6786 int len = 0;
6787 int err = E_PARSE;
6788
6789 while (*p) {
6790 if (*p == '}') {
6791 /* OK, found closing brace */
6792 err = 0;
6793 break;
6794 }
6795 len++;
6796 p++;
6797 }
6798
6799 if (!err && len > 0) {
6800 char *tmp;
6801
6802 p = *ps + 1;
6803 tmp = gretl_strndup(p, len);
6804
6805 if (tmp == NULL) {
6806 err = E_ALLOC;
6807 } else {
6808 *ps = p + len + 1;
6809 param->labels = gretl_string_split_quoted(tmp, ¶m->nlabels,
6810 " ,", &err);
6811 free(tmp);
6812 if (!err && param->nlabels != nvals) {
6813 gretl_errmsg_sprintf("%s: found %d values but %d value-labels",
6814 name, nvals, param->nlabels);
6815 err = E_DATA;
6816 }
6817 }
6818 }
6819
6820 return err;
6821 }
6822
trash_param_info(char * name,fn_param * param)6823 static void trash_param_info (char *name, fn_param *param)
6824 {
6825 free(name);
6826 free(param->descrip);
6827 param->descrip = NULL;
6828 if (param->nlabels > 0) {
6829 strings_array_free(param->labels, param->nlabels);
6830 param->labels = NULL;
6831 param->nlabels = 0;
6832 }
6833 }
6834
parse_function_param(char * s,fn_param * param,int i)6835 static int parse_function_param (char *s, fn_param *param, int i)
6836 {
6837 GretlType type = GRETL_TYPE_NONE;
6838 char tstr[22] = {0};
6839 char *name;
6840 int len, nvals = 0;
6841 int const_flag = 0;
6842 int err = 0;
6843
6844 #if FNPARSE_DEBUG
6845 fprintf(stderr, "parse_function_param: s = '%s'\n", s);
6846 #endif
6847
6848 while (isspace(*s)) s++;
6849
6850 /* pick up the "const" flag if present */
6851 if (!strncmp(s, "const ", 6)) {
6852 const_flag = 1;
6853 s += 6;
6854 while (isspace(*s)) s++;
6855 }
6856
6857 /* get parameter type, required */
6858 len = gretl_namechar_spn(s);
6859 if (len > 21) {
6860 err = E_PARSE;
6861 } else {
6862 strncat(tstr, s, len);
6863 s += len;
6864 while (isspace(*s)) s++;
6865 if (*s == '*') {
6866 strcat(tstr, " *");
6867 s++;
6868 }
6869 if (*tstr == '\0') {
6870 gretl_errmsg_set(_("Expected a type identifier"));
6871 err = E_PARSE;
6872 } else {
6873 type = gretl_type_from_string(tstr);
6874 if (type == 0) {
6875 gretl_errmsg_sprintf(_("Unrecognized data type '%s'"), tstr);
6876 err = E_PARSE;
6877 } else if (!ok_function_arg_type(type)) {
6878 gretl_errmsg_sprintf(_("%s: invalid parameter type"), tstr);
6879 err = E_INVARG;
6880 }
6881 }
6882 }
6883
6884 if (err) {
6885 return err;
6886 }
6887
6888 /* get the required parameter name */
6889 while (isspace(*s)) s++;
6890 len = gretl_namechar_spn(s);
6891 if (len == 0) {
6892 gretl_errmsg_sprintf(_("parameter %d: name is missing"), i + 1);
6893 err = E_PARSE;
6894 } else {
6895 name = gretl_strndup(s, len);
6896 if (name == NULL) {
6897 err = E_ALLOC;
6898 } else if (gretl_reserved_word(name)) {
6899 free(name);
6900 err = E_DATA;
6901 }
6902 }
6903
6904 if (err) {
6905 return err;
6906 }
6907
6908 param->type = type;
6909 if (const_flag) {
6910 maybe_set_param_const(param);
6911 }
6912
6913 s += len;
6914 s += strspn(s, " ");
6915
6916 /* now scan for various optional extras: first we may have
6917 a [min:max:default] specification (scalars only), or a
6918 [null] spec to allow no argument for "pointer"-type
6919 parameters (broadly interpreted)
6920 */
6921
6922 if (*s == '[') {
6923 if (gretl_scalar_type(type)) {
6924 err = read_min_max_deflt(&s, param, name, &nvals);
6925 } else if (arg_may_be_optional(type)) {
6926 err = read_param_option(&s, param);
6927 } else {
6928 gretl_errmsg_sprintf("'%s': error scanning default value",
6929 name);
6930 err = E_PARSE;
6931 }
6932 s += strspn(s, " ");
6933 }
6934
6935 /* then we may have a double-quoted descriptive string
6936 for the parameter */
6937
6938 if (!err && *s == '"') {
6939 err = read_param_descrip(&s, param);
6940 s += strspn(s, " ");
6941 }
6942
6943 /* and finally we may have a set of value-labels enclosed
6944 in braces, but this is valid only if we have been able
6945 to determine a definite number of admissible values
6946 for the parameter
6947 */
6948
6949 if (!err && *s == '{') {
6950 if (nvals == 0) {
6951 err = E_PARSE;
6952 } else {
6953 err = read_param_labels(&s, param, name, nvals);
6954 }
6955 s += strspn(s, " ");
6956 }
6957
6958 if (!err && *s != '\0') {
6959 /* got trailing unparseable stuff */
6960 err = E_PARSE;
6961 }
6962
6963 if (!err) {
6964 param->name = name;
6965 } else {
6966 trash_param_info(name, param);
6967 }
6968
6969 #if FNPARSE_DEBUG
6970 if (!err) {
6971 fprintf(stderr, " param[%d] = '%s', ptype = %d (%s)\n",
6972 i, name, type, gretl_type_get_name(type));
6973 fprintf(stderr, " min=%g, max=%g, deflt=%g\n",
6974 param->min, param->max, param->deflt);
6975 if (param->descrip != NULL) {
6976 fprintf(stderr, " comment = '%s'\n", param->descrip);
6977 }
6978 if (param->nlabels > 0) {
6979 fprintf(stderr, " value labels: %d\n", param->nlabels);
6980 }
6981 }
6982 #endif
6983
6984 return err;
6985 }
6986
arg_tail_strip(char * s)6987 static void arg_tail_strip (char *s)
6988 {
6989 int i, n = strlen(s);
6990
6991 for (i=n-1; i>=0; i--) {
6992 if (isspace(s[i]) || s[i] == ')') {
6993 s[i] = '\0';
6994 } else {
6995 break;
6996 }
6997 }
6998 }
6999
parse_function_parameters(const char * str,fn_param ** pparams,int * pnp,const char * fname,PRN * prn)7000 static int parse_function_parameters (const char *str,
7001 fn_param **pparams,
7002 int *pnp,
7003 const char *fname,
7004 PRN *prn)
7005 {
7006 fn_param *params = NULL;
7007 char *p, *s;
7008 int i, j, np = 0;
7009 int err = 0;
7010
7011 s = gretl_strdup(str);
7012 if (s == NULL) {
7013 return E_ALLOC;
7014 }
7015
7016 if (!strcmp(s, ")")) {
7017 /* we got a void function "foo()" */
7018 free(s);
7019 return 0;
7020 }
7021
7022 /* strip trailing ')' and space */
7023 arg_tail_strip(s);
7024 np = comma_count(s) + 1;
7025 if (np == 1 && !strcmp(s, "void")) {
7026 free(s);
7027 return 0;
7028 }
7029
7030 #if FNPARSE_DEBUG
7031 fprintf(stderr, "function %s: looking for %d parameters\n",
7032 fname, np);
7033 #endif
7034
7035 params = allocate_params(np);
7036 if (params == NULL) {
7037 err = E_ALLOC;
7038 }
7039
7040 if (!err) {
7041 int quoted = 0;
7042 int braced = 0;
7043
7044 p = s;
7045 while (*p) {
7046 if (!quoted) {
7047 if (*p == '{') {
7048 braced++;
7049 } else if (*p == '}') {
7050 braced--;
7051 }
7052 }
7053 if (*p == '"') {
7054 quoted = !quoted;
7055 } else if (!quoted && !braced && *p == ',') {
7056 *p = '\0';
7057 }
7058 p++;
7059 }
7060 p = s;
7061 if (braced != 0) {
7062 err = E_PARSE;
7063 }
7064 for (i=0; i<np && !err; i++) {
7065 err = parse_function_param(p, ¶ms[i], i);
7066 p += strlen(p) + 1;
7067 }
7068 }
7069
7070 free(s);
7071
7072 for (i=0; i<np && !err; i++) {
7073 for (j=i+1; j<np && !err; j++) {
7074 if (!strcmp(params[i].name, params[j].name)) {
7075 gretl_errmsg_sprintf(_("%s: duplicated parameter name '%s'"),
7076 fname, params[i].name);
7077 err = E_DATA;
7078 }
7079 }
7080 }
7081
7082 if (err) {
7083 free_params_array(params, np);
7084 } else {
7085 *pparams = params;
7086 *pnp = np;
7087 }
7088
7089 return err;
7090 }
7091
get_two_words(const char * s,char * w1,char * w2,int * err)7092 static int get_two_words (const char *s, char *w1, char *w2,
7093 int *err)
7094 {
7095 int nf = 0;
7096
7097 if (strncmp(s, "function ", 9)) {
7098 *err = E_PARSE;
7099 } else {
7100 int n;
7101
7102 *w1 = *w2 = '\0';
7103
7104 s += 9;
7105 s += strspn(s, " ");
7106
7107 /* @w1 should be a return type, except in the case
7108 of "function foo delete"
7109 */
7110 n = strcspn(s, " ");
7111
7112 if (n == 0 || n >= FN_NAMELEN) {
7113 *err = E_PARSE;
7114 } else {
7115 strncat(w1, s, n);
7116 nf++;
7117 s += n;
7118 s += strspn(s, " ");
7119 n = strcspn(s, " (");
7120 }
7121
7122 /* @w2 should generally be the function name */
7123 if (n > 0 && n < FN_NAMELEN) {
7124 strncat(w2, s, n);
7125 nf++;
7126 } else if (n >= FN_NAMELEN) {
7127 gretl_errmsg_set(_("Identifier exceeds the maximum of 31 characters"));
7128 *err = E_PARSE;
7129 }
7130 }
7131
7132 return nf;
7133 }
7134
7135 /**
7136 * gretl_start_compiling_function:
7137 * @line: command line.
7138 * @prn: printing struct for feedback.
7139 *
7140 * Responds to a statement of the form "function ...". In most
7141 * cases, embarks on compilation of a function, but this
7142 * also handles the construction "function foo delete".
7143 *
7144 * Returns: 0 on success, non-zero on error.
7145 */
7146
gretl_start_compiling_function(const char * line,const DATASET * dset,PRN * prn)7147 int gretl_start_compiling_function (const char *line,
7148 const DATASET *dset,
7149 PRN *prn)
7150 {
7151 ufunc *fun = NULL;
7152 fn_param *params = NULL;
7153 int nf, n_params = 0;
7154 int rettype = 0;
7155 char s1[FN_NAMELEN];
7156 char s2[FN_NAMELEN];
7157 char *p = NULL, *name = NULL;
7158 int err = 0;
7159
7160 if (gretl_function_depth() > 0) {
7161 return E_FNEST;
7162 }
7163
7164 nf = get_two_words(line, s1, s2, &err);
7165
7166 if (err) {
7167 return err;
7168 } else if (nf < 2) {
7169 gretl_errmsg_set("A function definition must have a return type and name");
7170 return E_PARSE;
7171 }
7172
7173 if (!strcmp(s2, "clear") || !strcmp(s2, "delete")) {
7174 return maybe_delete_function(s1, prn);
7175 }
7176
7177 /* If we didn't get a special such as "function foo delete",
7178 then @s1 should contain the return type and @s2 the
7179 name.
7180 */
7181
7182 name = s2;
7183 rettype = return_type_from_string(s1, &err);
7184
7185 if (!err) {
7186 /* note: this handles a name collision */
7187 err = check_func_name(name, &fun, dset, prn);
7188 }
7189
7190 if (!err) {
7191 /* now for the args bit */
7192 p = strchr(line, '(');
7193 if (p == NULL || strchr(p, ')') == NULL) {
7194 err = E_PARSE;
7195 } else {
7196 p++; /* skip the left paren */
7197 }
7198 }
7199
7200 if (!err) {
7201 err = parse_function_parameters(p, ¶ms, &n_params,
7202 name, prn);
7203 }
7204
7205 if (err) {
7206 pprintf(prn, "> %s\n", line);
7207 }
7208
7209 if (!err && fun == NULL) {
7210 fun = add_ufunc(name);
7211 if (fun == NULL) {
7212 free_params_array(params, n_params);
7213 err = E_ALLOC;
7214 }
7215 }
7216
7217 #if GLOBAL_TRACE
7218 fprintf(stderr, "started compiling function %s (err = %d)\n",
7219 fname, err);
7220 #endif
7221
7222 if (!err) {
7223 strcpy(fun->name, name);
7224 fun->params = params;
7225 fun->n_params = n_params;
7226 fun->rettype = rettype;
7227 current_fdef = fun;
7228 set_compiling_on();
7229 } else {
7230 current_fdef = NULL;
7231 }
7232
7233 return err;
7234 }
7235
7236 #define NEEDS_IF(c) (c == ELSE || c == ELIF || c == ENDIF)
7237
python_check(const char * line)7238 static void python_check (const char *line)
7239 {
7240 char s1[8], s2[16];
7241
7242 if (sscanf(line, "%7s %15s", s1, s2) == 2) {
7243 if (!strcmp(s1, "foreign") && strstr(s2, "ytho")) {
7244 compiling_python = 1;
7245 } else if (!strcmp(s1, "end") && !strcmp(s2, "foreign")) {
7246 compiling_python = 0;
7247 }
7248 }
7249 }
7250
7251 /**
7252 * gretl_function_append_line:
7253 * @s: pointer to execution state.
7254 *
7255 * Continuation of definition of user-function.
7256 *
7257 * Returns: 0 on success, non-zero on error.
7258 */
7259
gretl_function_append_line(ExecState * s)7260 int gretl_function_append_line (ExecState *s)
7261 {
7262 static int ifdepth;
7263 CMD *cmd = s->cmd;
7264 char *line = s->line;
7265 char *origline = NULL;
7266 ufunc *fun = current_fdef;
7267 int blank = 0;
7268 int ignore = 0;
7269 int err = 0;
7270
7271 if (fun == NULL) {
7272 fprintf(stderr, "gretl_function_append_line: fun is NULL\n");
7273 return 1;
7274 }
7275
7276 #if FNPARSE_DEBUG
7277 fprintf(stderr, "gretl_function_append_line: '%s' (idx = %d)\n",
7278 line, fun->line_idx);
7279 #endif
7280
7281 /* note: avoid losing comment lines */
7282 origline = gretl_strdup(line);
7283 blank = string_is_blank(line);
7284
7285 /* below: append line to function, carrying out some
7286 basic structural checks as we go
7287 */
7288 if (!blank) {
7289 err = get_command_index(s, FUNC);
7290 if (!err) {
7291 if (cmd->ci == QUIT) {
7292 gretl_errmsg_sprintf(_("%s: \"quit\" cannot be used in a function"),
7293 fun->name);
7294 err = E_PARSE;
7295 cmd->ci = 0;
7296 } else if (cmd->flags & CMD_ENDFUN) {
7297 if (fun->n_lines == 0) {
7298 gretl_errmsg_sprintf("%s: empty function", fun->name);
7299 err = 1;
7300 }
7301 set_compiling_off();
7302 } else if (cmd->ci == SET) {
7303 if (!(fun->flags & UFUN_USES_SET)) {
7304 fun->flags |= UFUN_USES_SET;
7305 }
7306 } else if (cmd->ci == FUNC) {
7307 err = E_FNEST;
7308 } else if (cmd->ci == IF) {
7309 ifdepth++;
7310 } else if (NEEDS_IF(cmd->ci) && ifdepth == 0) {
7311 gretl_errmsg_sprintf("%s: unbalanced if/else/endif", fun->name);
7312 err = E_PARSE;
7313 } else if (cmd->ci == ENDIF) {
7314 ifdepth--;
7315 } else if (cmd->ci < 0) {
7316 ignore = 1;
7317 }
7318 }
7319 }
7320
7321 if (err) {
7322 set_compiling_off();
7323 }
7324
7325 if (compiling) {
7326 /* actually add the line? */
7327 int i = fun->n_lines;
7328
7329 err = push_function_line(fun, origline, 1);
7330 if (!err) {
7331 if (!blank) {
7332 origline = NULL; /* successfully donated */
7333 }
7334 if (ignore) {
7335 fun->lines[i].ignore = 1;
7336 } else if (!blank) {
7337 python_check(line);
7338 }
7339 }
7340 } else {
7341 /* finished compilation */
7342 if (!err && ifdepth != 0) {
7343 gretl_errmsg_sprintf("%s: unbalanced if/else/endif", fun->name);
7344 err = E_PARSE;
7345 }
7346 #if GLOBAL_TRACE
7347 fprintf(stderr, "finished compiling function %s\n", fun->name);
7348 #endif
7349 /* reset static var */
7350 ifdepth = 0;
7351 }
7352
7353 free(origline);
7354 cmd->flags &= ~CMD_ENDFUN;
7355
7356 if (err) {
7357 ufunc_unload(fun);
7358 }
7359
7360 return err;
7361 }
7362
7363 /* next block: handling function arguments */
7364
7365 /* Given a list of variables supplied as an argument to a function,
7366 copy the list under the name assigned by the function and
7367 make the variables referenced in that list accessible within
7368 the function. We also handle the case where the given arg
7369 was not a real list, but we can make a list out of it for the
7370 purposes of the function.
7371 */
7372
7373 /* Missing or "null" arg -> gives an empty list, rather
7374 than no list. This is traditional behavior though it's
7375 (now) inconsistent with what happens with other types
7376 of argument.
7377 */
7378
add_empty_list(fncall * call,fn_param * fp,DATASET * dset)7379 static int add_empty_list (fncall *call, fn_param *fp,
7380 DATASET *dset)
7381 {
7382 int err = 0;
7383
7384 if (dset == NULL || dset->n == 0) {
7385 err = E_NODATA;
7386 } else {
7387 int tmp[] = {0};
7388
7389 copy_list_as_arg(fp->name, tmp, &err);
7390 }
7391
7392 return err;
7393 }
7394
localize_list_members(fncall * call,int * list,const char * lname,DATASET * dset)7395 static void localize_list_members (fncall *call, int *list,
7396 const char *lname,
7397 DATASET *dset)
7398 {
7399 int i, vi, level = fn_executing + 1;
7400
7401 for (i=1; i<=list[0]; i++) {
7402 vi = list[i];
7403 if (vi > 0 && vi < dset->v) {
7404 if (!in_gretl_list(call->listvars, vi)) {
7405 gretl_list_append_term(&call->listvars, vi);
7406 }
7407 series_set_stack_level(dset, vi, level);
7408 }
7409 }
7410 }
7411
localize_list(fncall * call,fn_arg * arg,fn_param * fp,DATASET * dset)7412 static int localize_list (fncall *call, fn_arg *arg,
7413 fn_param *fp, DATASET *dset)
7414 {
7415 int *list = NULL;
7416 int err = 0;
7417
7418 if (arg->type == GRETL_TYPE_LIST) {
7419 /* actual list arg -> copy to function level */
7420 list = arg->val.list;
7421 err = copy_as_arg(fp->name, GRETL_TYPE_LIST, list);
7422 call->lists = g_list_prepend(call->lists, fp->name);
7423 } else if (arg->type == GRETL_TYPE_USERIES) {
7424 /* series arg -> becomes a singleton list */
7425 int tmp[] = {1, arg->val.idnum};
7426
7427 list = copy_list_as_arg(fp->name, tmp, &err);
7428 arg->upname = NULL;
7429 } else {
7430 /* "can't happen" */
7431 err = E_DATA;
7432 }
7433
7434 if (!err && list == NULL) {
7435 err = E_ALLOC;
7436 }
7437
7438 if (!err) {
7439 localize_list_members(call, list, fp->name, dset);
7440 }
7441
7442 #if UDEBUG
7443 fprintf(stderr, "localize_list (%s): returning %d\n",
7444 fp->name, err);
7445 #endif
7446
7447 return err;
7448 }
7449
7450 /* For the series with index number @ID, find the name of
7451 the list parameter of the current function call under
7452 which this series was made accessible to the function.
7453 We call this only if we know already that series @ID
7454 was in fact passed to the function via a list.
7455 */
7456
series_get_list_parent(int ID)7457 const char *series_get_list_parent (int ID)
7458 {
7459 fncall *call = current_function_call();
7460 const char *ret = NULL;
7461
7462 if (call != NULL && call->lists != NULL) {
7463 GList *L = call->lists;
7464 int *list;
7465
7466 while (L != NULL) {
7467 list = get_list_by_name(L->data);
7468 if (list != NULL && in_gretl_list(list, ID)) {
7469 ret = L->data;
7470 break;
7471 }
7472 L = L->next;
7473 }
7474 }
7475
7476 return ret;
7477 }
7478
localize_bundled_lists(fncall * call,fn_arg * arg,fn_param * fp,DATASET * dset)7479 static int localize_bundled_lists (fncall *call, fn_arg *arg,
7480 fn_param *fp, DATASET *dset)
7481 {
7482 gretl_bundle *b = arg->val.b;
7483 GList *ll = gretl_bundle_get_lists(b);
7484 int err = 0;
7485
7486 if (ll != NULL) {
7487 GList *lli = g_list_first(ll);
7488
7489 while (lli != NULL) {
7490 localize_list_members(call, lli->data, NULL, dset);
7491 lli = g_list_next(lli);
7492 }
7493 g_list_free(ll);
7494 }
7495
7496 return err;
7497 }
7498
arg_get_data(fn_arg * arg,GretlType type)7499 static void *arg_get_data (fn_arg *arg, GretlType type)
7500 {
7501 void *data = NULL;
7502
7503 if (type == 0) {
7504 type = arg->type;
7505 }
7506
7507 if (type == GRETL_TYPE_MATRIX) {
7508 data = arg->val.m;
7509 } else if (type == GRETL_TYPE_BUNDLE) {
7510 data = arg->val.b;
7511 } else if (type == GRETL_TYPE_STRING) {
7512 data = arg->val.str;
7513 } else if (gretl_is_array_type(type)) {
7514 data = arg->val.a;
7515 }
7516
7517 return data;
7518 }
7519
7520 /* handle the case where the GUI passed an anonymous
7521 object in "pointerized" form */
7522
localize_object_as_shell(fn_arg * arg,fn_param * fp)7523 static int localize_object_as_shell (fn_arg *arg,
7524 fn_param *fp)
7525 {
7526 GretlType type = gretl_type_get_plain_type(arg->type);
7527 void *data = arg_get_data(arg, type);
7528
7529 return arg_add_as_shell(fp->name, type, data);
7530 }
7531
localize_const_object(fncall * call,int i,fn_param * fp)7532 static int localize_const_object (fncall *call, int i, fn_param *fp)
7533 {
7534 fn_arg *arg = &call->args[i];
7535 void *data = arg_get_data(arg, 0);
7536 int err = 0;
7537
7538 if (data == NULL) {
7539 err = E_DATA;
7540 } else if (arg->uvar == NULL) {
7541 /* the const argument is an anonymous object */
7542 err = arg_add_as_shell(fp->name, arg->type, data);
7543 } else {
7544 /* a named object: in the simplest case we just
7545 adjust the level and name of the object for
7546 the duration of the function call, but note
7547 that we can do this only once for any given
7548 object.
7549 */
7550 user_var *thisvar = arg->uvar;
7551 int j, done = 0;
7552
7553 for (j=0; j<i; j++) {
7554 if (call->args[j].uvar == thisvar) {
7555 /* we've already localized this one! */
7556 err = arg_add_as_shell(fp->name, arg->type, data);
7557 done = 1;
7558 break;
7559 }
7560 }
7561 if (!done) {
7562 user_var_adjust_level(thisvar, 1);
7563 user_var_set_name(thisvar, fp->name);
7564 arg->shifted = 1;
7565 }
7566 }
7567
7568 return err;
7569 }
7570
localize_series_ref(fncall * call,fn_arg * arg,fn_param * fp,DATASET * dset)7571 static int localize_series_ref (fncall *call, fn_arg *arg,
7572 fn_param *fp, DATASET *dset)
7573 {
7574 int v = arg->val.idnum;
7575
7576 series_increment_stack_level(dset, v);
7577 strcpy(dset->varname[v], fp->name);
7578
7579 if (!in_gretl_list(call->ptrvars, v)) {
7580 gretl_list_append_term(&call->ptrvars, v);
7581 }
7582
7583 return 0;
7584 }
7585
argval_get_int(fn_param * param,double x,int * err)7586 static int argval_get_int (fn_param *param, double x, int *err)
7587 {
7588 int ret = gretl_int_from_double(x, err);
7589
7590 if (*err) {
7591 gretl_errmsg_sprintf(_("%s: expected an integer but found %g"),
7592 param->name, x);
7593 }
7594
7595 return ret;
7596 }
7597
real_add_scalar_arg(fn_param * param,double x)7598 static int real_add_scalar_arg (fn_param *param, double x)
7599 {
7600 int err = 0;
7601
7602 if (na(x)) {
7603 /* always allow NA for scalar args (?) */
7604 err = copy_as_arg(param->name, GRETL_TYPE_DOUBLE, &x);
7605 } else {
7606 if (param->type == GRETL_TYPE_BOOL) {
7607 if (x != 0.0) {
7608 x = 1.0;
7609 }
7610 } else if (param->type == GRETL_TYPE_INT ||
7611 param->type == GRETL_TYPE_OBS) {
7612 x = argval_get_int(param, x, &err);
7613 }
7614
7615 if (!err) {
7616 if ((!na(param->min) && x < param->min) ||
7617 (!na(param->max) && x > param->max)) {
7618 gretl_errmsg_sprintf(_("%s: argument value %g is out of bounds"),
7619 param->name, x);
7620 err = E_DATA;
7621 } else {
7622 err = copy_as_arg(param->name, GRETL_TYPE_DOUBLE, &x);
7623 }
7624 }
7625 }
7626
7627 return err;
7628 }
7629
7630 /* Scalar function arguments only: if the arg is not supplied, use the
7631 default that is found in the function specification, if any.
7632 */
7633
add_scalar_arg_default(fn_param * param)7634 static int add_scalar_arg_default (fn_param *param)
7635 {
7636 if (default_unset(param)) {
7637 /* should be impossible here, but... */
7638 return E_DATA;
7639 } else {
7640 return real_add_scalar_arg(param, param->deflt);
7641 }
7642 }
7643
7644 /* Handle the case of a scalar parameter for which a 1 x 1 matrix
7645 was given as argument.
7646 */
7647
do_matrix_scalar_cast(fn_arg * arg,fn_param * param)7648 static int do_matrix_scalar_cast (fn_arg *arg, fn_param *param)
7649 {
7650 gretl_matrix *m = arg->val.m;
7651
7652 return real_add_scalar_arg(param, m->val[0]);
7653 }
7654
7655 /* Handle the case of a matrix parameter for which a scalar
7656 was given as argument.
7657 */
7658
do_scalar_matrix_cast(fn_arg * arg,fn_param * param)7659 static int do_scalar_matrix_cast (fn_arg *arg, fn_param *param)
7660 {
7661 gretl_matrix *m = gretl_matrix_alloc(1, 1);
7662 int err = 0;
7663
7664 if (m == NULL) {
7665 err = E_ALLOC;
7666 } else {
7667 m->val[0] = arg->val.x;
7668 err = copy_as_arg(param->name, GRETL_TYPE_MATRIX, m);
7669 gretl_matrix_free(m);
7670 }
7671
7672 return err;
7673 }
7674
fncall_finalize_listvars(fncall * call)7675 static void fncall_finalize_listvars (fncall *call)
7676 {
7677 int i, v;
7678
7679 for (i=call->listvars[0]; i>0; i--) {
7680 v = call->listvars[i];
7681 if (in_gretl_list(call->ptrvars, v)) {
7682 gretl_list_delete_at_pos(call->listvars, i);
7683 }
7684 }
7685
7686 if (call->listvars[0] == 0) {
7687 free(call->listvars);
7688 call->listvars = NULL;
7689 }
7690 }
7691
duplicated_pointer_arg_check(fncall * call)7692 static int duplicated_pointer_arg_check (fncall *call)
7693 {
7694 fn_arg *ai, *aj;
7695 int i, j, err = 0;
7696
7697 /* Note: a caller cannot be allowed to supply a given
7698 variable in pointer form for more than one argument
7699 slot in a function call (although ordinary arguments
7700 may be repeated).
7701 */
7702
7703 for (i=0; i<call->argc && !err; i++) {
7704 ai = &call->args[i];
7705 if (gretl_ref_type(ai->type)) {
7706 for (j=i+1; j<call->argc && !err; j++) {
7707 aj = &call->args[j];
7708 if (gretl_ref_type(aj->type) &&
7709 ai->upname != NULL && /* FIXME? */
7710 !strcmp(ai->upname, aj->upname)) {
7711 gretl_errmsg_set(_("Duplicated pointer argument: not allowed"));
7712 err = E_DATA;
7713 }
7714 }
7715 }
7716 }
7717
7718 return err;
7719 }
7720
process_series_arg(fncall * call,fn_param * fp,fn_arg * arg,DATASET * dset)7721 static int process_series_arg (fncall *call, fn_param *fp,
7722 fn_arg *arg, DATASET *dset)
7723 {
7724 if (arg->type == GRETL_TYPE_USERIES) {
7725 /* an existing named series */
7726 if (fp->immut) {
7727 /* we can pass it by reference */
7728 return localize_series_ref(call, arg, fp, dset);
7729 } else {
7730 /* pass it by value */
7731 return dataset_copy_series_as(dset, arg->val.idnum, fp->name);
7732 }
7733 } else if (arg->val.px != NULL) {
7734 /* an on-the-fly series */
7735 return dataset_add_series_as(dset, arg->val.px, fp->name);
7736 } else {
7737 return E_DATA;
7738 }
7739 }
7740
7741 /* for matrix, bundle, array, string */
7742
process_object_arg(fncall * call,int i,fn_param * fp)7743 static int process_object_arg (fncall *call, int i, fn_param *fp)
7744 {
7745 fn_arg *arg = &call->args[i];
7746
7747 if (fp->immut) {
7748 /* we can pass it by reference */
7749 return localize_const_object(call, i, fp);
7750 } else {
7751 /* pass it by value */
7752 return copy_as_arg(fp->name, arg->type,
7753 arg_get_data(arg, 0));
7754 }
7755 }
7756
7757 /* for *matrix, *bundle, *array, *string */
7758
process_object_ref_arg(fn_arg * arg,fn_param * fp)7759 static int process_object_ref_arg (fn_arg *arg, fn_param *fp)
7760 {
7761 if (arg->upname != NULL) {
7762 return user_var_localize(arg->upname, fp->name, fp->type);
7763 } else {
7764 return localize_object_as_shell(arg, fp);
7765 }
7766 }
7767
7768 /* Note that if we reach here we've already successfully
7769 negotiated check_function_args(): now we're actually
7770 making the argument objects (if any) available within
7771 the function.
7772 */
7773
allocate_function_args(fncall * call,DATASET * dset)7774 static int allocate_function_args (fncall *call, DATASET *dset)
7775 {
7776 ufunc *fun = call->fun;
7777 fn_arg *arg;
7778 fn_param *fp;
7779 int i, err;
7780
7781 err = duplicated_pointer_arg_check(call);
7782
7783 for (i=0; i<call->argc && !err; i++) {
7784 arg = &call->args[i];
7785 fp = &fun->params[i];
7786
7787 #if UDEBUG
7788 fprintf(stderr, "arg[%d], param type %s (%s), arg type %s (%s)\n",
7789 i, gretl_type_get_name(fp->type), fp->name,
7790 gretl_type_get_name(arg->type), arg->upname);
7791 #endif
7792 #if STRICT_CONST
7793 /* extra conditions needed to avoid "const poisoning" */
7794 if (!fp->immut && arg->upname != NULL &&
7795 fp->type != GRETL_TYPE_LIST &&
7796 !gretl_is_scalar_type(fp->type)) {
7797 fp->immut = object_is_const(arg->upname, -1);
7798 }
7799 #else
7800 if (!fp->immut && arg->upname != NULL) {
7801 fp->immut = object_is_const(arg->upname, -1);
7802 }
7803 #endif
7804
7805 if (arg->type == GRETL_TYPE_NONE) {
7806 if (gretl_scalar_type(fp->type)) {
7807 err = add_scalar_arg_default(fp);
7808 } else if (fp->type == GRETL_TYPE_LIST) {
7809 err = add_empty_list(call, fp, dset);
7810 }
7811 continue;
7812 }
7813
7814 if (fp->type == GRETL_TYPE_NUMERIC) {
7815 /* param supports overloading */
7816 if (gretl_scalar_type(arg->type)) {
7817 err = real_add_scalar_arg(fp, arg->val.x);
7818 } else if (gretl_is_series_type(arg->type)) {
7819 process_series_arg(call, fp, arg, dset);
7820 } else if (arg->type == GRETL_TYPE_MATRIX) {
7821 err = process_object_arg(call, i, fp);
7822 }
7823 continue;
7824 }
7825
7826 if (gretl_scalar_type(fp->type)) {
7827 if (arg->type == GRETL_TYPE_MATRIX) {
7828 err = do_matrix_scalar_cast(arg, fp);
7829 } else {
7830 err = real_add_scalar_arg(fp, arg->val.x);
7831 }
7832 } else if (fp->type == GRETL_TYPE_SERIES) {
7833 err = process_series_arg(call, fp, arg, dset);
7834 } else if (fp->type == GRETL_TYPE_MATRIX &&
7835 arg->type == GRETL_TYPE_DOUBLE) {
7836 err = do_scalar_matrix_cast(arg, fp);
7837 } else if (fp->type == GRETL_TYPE_MATRIX ||
7838 fp->type == GRETL_TYPE_BUNDLE ||
7839 fp->type == GRETL_TYPE_STRING ||
7840 gretl_array_type(fp->type)) {
7841 err = process_object_arg(call, i, fp);
7842 } else if (fp->type == GRETL_TYPE_LIST) {
7843 err = localize_list(call, arg, fp, dset);
7844 } else if (fp->type == GRETL_TYPE_SERIES_REF) {
7845 err = localize_series_ref(call, arg, fp, dset);
7846 } else if (gretl_ref_type(fp->type)) {
7847 err = process_object_ref_arg(arg, fp);
7848 }
7849 if (!err && (fp->type == GRETL_TYPE_BUNDLE ||
7850 fp->type == GRETL_TYPE_BUNDLE_REF)) {
7851 err = localize_bundled_lists(call, arg, fp, dset);
7852 }
7853 }
7854
7855 /* now for any trailing parameters without matching arguments */
7856
7857 for (i=call->argc; i<fun->n_params && !err; i++) {
7858 fp = &fun->params[i];
7859 if (gretl_scalar_type(fp->type)) {
7860 err = add_scalar_arg_default(fp);
7861 } else if (fp->type == GRETL_TYPE_LIST) {
7862 err = add_empty_list(call, fp, dset);
7863 }
7864 }
7865
7866 if (call->listvars != NULL) {
7867 if (err) {
7868 free(call->listvars);
7869 call->listvars = NULL;
7870 } else {
7871 fncall_finalize_listvars(call);
7872 }
7873 }
7874
7875 if (!err) {
7876 set_listargs_from_call(call, dset);
7877 }
7878
7879 #if UDEBUG
7880 fprintf(stderr, "allocate_function args: returning %d\n", err);
7881 #endif
7882
7883 return err;
7884 }
7885
7886 /**
7887 * check_function_needs:
7888 * @dset: pointer to dataset info.
7889 * @dreq: function data requirements flag.
7890 * @minver: function minimum program version requirement.
7891 *
7892 * Checks whether the requirements in @dreq and @minver
7893 * are jointly satisfied by the current dataset and gretl
7894 * version.
7895 *
7896 * Returns: 0 if all is OK; E_DATA if the current dataset
7897 * (or lack thereof) does not satisfy @dreq; 1 otherwise.
7898 */
7899
check_function_needs(const DATASET * dset,DataReq dreq,int minver)7900 int check_function_needs (const DATASET *dset, DataReq dreq,
7901 int minver)
7902 {
7903 static int thisver = 0;
7904
7905 if (thisver == 0) {
7906 thisver = gretl_version_number(GRETL_VERSION);
7907 }
7908
7909 if (minver > thisver) {
7910 char vstr[8];
7911
7912 gretl_version_string(vstr, minver);
7913 gretl_errmsg_sprintf("This function needs gretl version %s", vstr);
7914 return 1;
7915 }
7916
7917 if ((dset == NULL || dset->v == 0) && dreq != FN_NODATA_OK) {
7918 gretl_errmsg_set("This function needs a dataset in place");
7919 return E_DATA;
7920 }
7921
7922 if (dreq == FN_NEEDS_TS && !dataset_is_time_series(dset)) {
7923 gretl_errmsg_set("This function needs time-series data");
7924 return E_DATA;
7925 }
7926
7927 if (dreq == FN_NEEDS_PANEL && !dataset_is_panel(dset)) {
7928 gretl_errmsg_set("This function needs panel data");
7929 return E_DATA;
7930 }
7931
7932 if (dreq == FN_NEEDS_QM &&
7933 (!dataset_is_time_series(dset) ||
7934 (dset->pd != 4 && dset->pd != 12))) {
7935 gretl_errmsg_set("This function needs quarterly or monthly data");
7936 return E_DATA;
7937 }
7938
7939 return 0;
7940 }
7941
7942 /**
7943 * package_version_ok:
7944 * @minver: function package minimum program version requirement.
7945 * @reqstr: location to write required version string (should be
7946 * at least 8 bytes), or NULL.
7947 *
7948 * Returns: 1 if the running version of gretl satisfies the
7949 * minimum version requirement in @minver; otherwise returns 0,
7950 * in which case the string representation of @minver is written
7951 * @reqstr if this is non-NULL.
7952 */
7953
package_version_ok(int minver,char * reqstr)7954 int package_version_ok (int minver, char *reqstr)
7955 {
7956 static int thisver = 0;
7957 int ret = 0;
7958
7959 if (thisver == 0) {
7960 thisver = gretl_version_number(GRETL_VERSION);
7961 }
7962
7963 ret = thisver >= minver;
7964
7965 if (!ret && reqstr != NULL) {
7966 gretl_version_string(reqstr, minver);
7967 }
7968
7969 return ret;
7970 }
7971
maybe_check_function_needs(const DATASET * dset,const ufunc * fun)7972 static int maybe_check_function_needs (const DATASET *dset,
7973 const ufunc *fun)
7974 {
7975 if (fun->pkg == NULL || fun->pkg->prechecked) {
7976 return 0;
7977 } else {
7978 return check_function_needs(dset, fun->pkg->dreq,
7979 fun->pkg->minver);
7980 }
7981 }
7982
7983 /* next block: handling function return values */
7984
handle_scalar_return(fncall * call,void * ptr,int rtype)7985 static int handle_scalar_return (fncall *call, void *ptr, int rtype)
7986 {
7987 static double xret;
7988 const char *vname = call->retname;
7989 int err = 0;
7990
7991 if (gretl_is_scalar(vname)) {
7992 xret = gretl_scalar_get_value(vname, NULL);
7993 } else {
7994 gretl_matrix *m = get_matrix_by_name(vname);
7995
7996 if (gretl_matrix_is_scalar(m)) {
7997 xret = m->val[0];
7998 } else {
7999 gretl_errmsg_sprintf("Function %s did not provide the specified return value\n"
8000 "(expected %s)", call->fun->name, gretl_type_get_name(rtype));
8001 err = E_TYPES;
8002 xret = NADBL;
8003 }
8004 }
8005
8006 *(double **) ptr = &xret;
8007
8008 return err;
8009 }
8010
handle_series_return(const char * vname,void * ptr,DATASET * dset,int copy,char ** label)8011 static int handle_series_return (const char *vname, void *ptr,
8012 DATASET *dset, int copy,
8013 char **label)
8014 {
8015 int v = series_index(dset, vname);
8016 double *x = NULL;
8017 int err = 0;
8018
8019 if (!copy && v == 0) {
8020 copy = 1;
8021 }
8022
8023 if (v >= 0 && v < dset->v) {
8024 if (copy) {
8025 x = copyvec(dset->Z[v], dset->n);
8026 if (x == NULL) {
8027 err = E_ALLOC;
8028 }
8029 } else {
8030 x = dset->Z[v];
8031 dset->Z[v] = NULL;
8032 }
8033 } else {
8034 err = E_UNKVAR;
8035 }
8036
8037 *(double **) ptr = x;
8038
8039 if (!err && label != NULL) {
8040 const char *vstr = series_get_label(dset, v);
8041
8042 if (vstr != NULL) {
8043 *label = gretl_strdup(vstr);
8044 } else {
8045 *label = gretl_strdup("");
8046 }
8047 }
8048
8049 return err;
8050 }
8051
handle_matrix_return(const char * name,void * ptr,int copy)8052 static int handle_matrix_return (const char *name, void *ptr,
8053 int copy)
8054 {
8055 gretl_matrix *ret = NULL;
8056 int err = 0;
8057
8058 if (copy) {
8059 gretl_matrix *m = get_matrix_by_name(name);
8060
8061 if (m != NULL) {
8062 ret = gretl_matrix_copy(m);
8063 if (ret == NULL) {
8064 err = E_ALLOC;
8065 }
8066 }
8067 } else {
8068 ret = steal_matrix_by_name(name);
8069 }
8070
8071 if (ret == NULL && !err) {
8072 err = E_UNKVAR;
8073 }
8074
8075 *(gretl_matrix **) ptr = ret;
8076
8077 return err;
8078 }
8079
fix_numeric_return_type(fncall * call,DATASET * dset)8080 static GretlType fix_numeric_return_type (fncall *call,
8081 DATASET *dset)
8082 {
8083 GretlType t = 0;
8084 user_var *uv;
8085
8086 uv = user_var_get_value_and_type(call->retname, &t);
8087 if (uv != NULL) {
8088 call->rtype = t;
8089 } else {
8090 int v = current_series_index(dset, call->retname);
8091
8092 if (v >= 0) {
8093 t = call->rtype = GRETL_TYPE_SERIES;
8094 }
8095 }
8096
8097 return t;
8098 }
8099
handle_bundle_return(fncall * call,void * ptr,int copy)8100 static int handle_bundle_return (fncall *call, void *ptr, int copy)
8101 {
8102 const char *name = call->retname;
8103 gretl_bundle *ret = NULL;
8104 int err = 0;
8105
8106 if (copy) {
8107 gretl_bundle *b = get_bundle_by_name(name);
8108
8109 if (b != NULL) {
8110 ret = gretl_bundle_copy(b, &err);
8111 }
8112 } else {
8113 ret = gretl_bundle_pull_from_stack(name, &err);
8114 }
8115
8116 if (ret != NULL && call->fun->pkg != NULL &&
8117 gretl_function_depth() == 1) {
8118 if (call->fun->pkg_role != UFUN_BUNDLE_FCAST) {
8119 gretl_bundle_set_creator(ret, call->fun->pkg->name);
8120 }
8121 }
8122
8123 *(gretl_bundle **) ptr = ret;
8124
8125 return err;
8126 }
8127
handle_array_return(fncall * call,void * ptr,int copy)8128 static int handle_array_return (fncall *call, void *ptr, int copy)
8129 {
8130 const char *name = call->retname;
8131 gretl_array *ret = NULL;
8132 int err = 0;
8133
8134 if (copy) {
8135 gretl_array *a = get_array_by_name(name);
8136
8137 if (a != NULL) {
8138 ret = gretl_array_copy(a, &err);
8139 }
8140 } else {
8141 ret = gretl_array_pull_from_stack(name, &err);
8142 }
8143
8144 *(gretl_array **) ptr = ret;
8145
8146 return err;
8147 }
8148
replace_caller_series(int targ,int src,DATASET * dset)8149 static void replace_caller_series (int targ, int src, DATASET *dset)
8150 {
8151 const char *vlabel = series_get_label(dset, src);
8152 int t;
8153
8154 /* replace data values */
8155 for (t=dset->t1; t<=dset->t2; t++) {
8156 dset->Z[targ][t] = dset->Z[src][t];
8157 }
8158
8159 /* replace variable info? */
8160 series_set_label(dset, targ, vlabel == NULL ? "" : vlabel);
8161 series_set_display_name(dset, targ, series_get_display_name(dset, src));
8162 }
8163
8164 /* Deal with a list, named @lname, that exists at the level of a
8165 function whose execution is now terminating. Note that this list
8166 may be the direct return value of the function (in which case @ret
8167 will be non-NULL), or it may have been passed to the function as an
8168 argument (in which case @arg will be non-NULL), or it may have been
8169 constructed on the fly.
8170
8171 If the list was given as a function argument we simply shunt all
8172 its members to the caller's stack level. But if it's the direct
8173 return value we need to overwrite any variables at caller level
8174 that have been redefined within the function. If any series have
8175 been redefined in that way we also need to adjust the list itself,
8176 replacing the ID numbers of local variables with the caller-level
8177 IDs -- all supposing the direct return value is being assigned by
8178 the caller.
8179
8180 If the list was a temporary construction (a list parameter was
8181 required, but a single series was given as argument), we just
8182 destroy it.
8183 */
8184
unlocalize_list(fncall * call,const char * lname,fn_arg * arg,void * ret,DATASET * dset)8185 static int unlocalize_list (fncall *call, const char *lname,
8186 fn_arg *arg, void *ret,
8187 DATASET *dset)
8188 {
8189 int *list = get_list_by_name(lname);
8190 int d = gretl_function_depth();
8191 int upd = d - 1;
8192 int i, vi;
8193
8194 #if UDEBUG
8195 fprintf(stderr, "\n*** unlocalize_list: '%s', function depth = %d\n", lname, d);
8196 printlist(list, lname);
8197 fprintf(stderr, " dset = %p, dset->v = %d\n", (void *) dset, dset->v);
8198 fprintf(stderr, " list is direct return value? %s\n", arg == NULL ? "yes" : "no");
8199 #endif
8200
8201 if (list == NULL) {
8202 return E_DATA;
8203 }
8204
8205 if (arg == NULL && ret == NULL) {
8206 ; /* no-op: we'll trash the list later */
8207 } else if (arg == NULL) {
8208 /* handle list as direct return value */
8209 int j, lev, overwrite;
8210 const char *vname;
8211
8212 for (i=1; i<=list[0]; i++) {
8213 overwrite = 0;
8214 vi = list[i];
8215 vname = dset->varname[vi];
8216 if (in_gretl_list(call->ptrvars, vi)) {
8217 /* 2021-06-28: detect a somewhat anomalous case */
8218 fprintf(stderr, "*** return list '%s' contains series %s, passed in "
8219 "pointer form ***\n", lname, vname);
8220 continue;
8221 }
8222 series_unset_flag(dset, vi, VAR_LISTARG);
8223 if (vi > 0 && vi < dset->v && series_get_stack_level(dset, vi) == d) {
8224 for (j=1; j<dset->v; j++) {
8225 lev = series_get_stack_level(dset, j);
8226 if (lev == upd && !strcmp(dset->varname[j], vname)) {
8227 overwrite = 1;
8228 break;
8229 }
8230 if (lev == d && j < vi && series_is_listarg(dset, j, NULL) &&
8231 !strcmp(dset->varname[j], vname)) {
8232 overwrite = 1;
8233 break;
8234 }
8235 }
8236 if (overwrite) {
8237 replace_caller_series(j, vi, dset);
8238 /* replace ID number in list */
8239 list[i] = j;
8240 } else {
8241 series_set_stack_level(dset, vi, upd);
8242 }
8243 }
8244 #if UDEBUG
8245 fprintf(stderr, " list-member var %d, '%s': ", vi, vname);
8246 if (overwrite) {
8247 fprintf(stderr, "found match in caller, overwrote var %d\n", j);
8248 } else {
8249 fprintf(stderr, "no match in caller\n");
8250 }
8251 #endif
8252 }
8253 } else {
8254 /* list was given as argument to function */
8255 for (i=1; i<=list[0]; i++) {
8256 vi = list[i];
8257 if (vi == LISTSEP) {
8258 continue;
8259 }
8260 if (series_is_listarg(dset, vi, NULL)) {
8261 series_unset_flag(dset, vi, VAR_LISTARG);
8262 series_set_stack_level(dset, vi, upd);
8263 }
8264 }
8265 if (arg->type != GRETL_TYPE_LIST) {
8266 /* the list was constructed on the fly */
8267 user_var_delete_by_name(lname, NULL);
8268 }
8269 }
8270
8271 return 0;
8272 }
8273
handle_string_return(const char * sname,void * ptr)8274 static int handle_string_return (const char *sname, void *ptr)
8275 {
8276 const char *s = get_string_by_name(sname);
8277 char *ret = NULL;
8278 int err = 0;
8279
8280 if (s == NULL) {
8281 err = E_DATA;
8282 } else {
8283 ret = gretl_strdup(s);
8284 if (ret == NULL) {
8285 err = E_ALLOC;
8286 }
8287 }
8288
8289 *(char **) ptr = ret;
8290
8291 return err;
8292 }
8293
check_sub_object_return(fn_arg * arg,fn_param * fp)8294 static int check_sub_object_return (fn_arg *arg, fn_param *fp)
8295 {
8296 GretlType type = gretl_type_get_plain_type(arg->type);
8297 void *orig = arg_get_data(arg, type);
8298 void *curr = user_var_get_value_by_name(fp->name);
8299 int err = 0;
8300
8301 if (curr == NULL) {
8302 fprintf(stderr, "sub_object return: value has disappeared!\n");
8303 err = E_DATA;
8304 } else if (curr != orig) {
8305 /* reattachment is needed */
8306 GretlType uptype = user_var_get_type(arg->uvar);
8307 void *updata = user_var_get_value(arg->uvar);
8308
8309 if (uptype == GRETL_TYPE_ARRAY) {
8310 gretl_array *a = updata;
8311 int i, n = gretl_array_get_length(a);
8312 int found = 0;
8313
8314 for (i=0; i<n; i++) {
8315 if (gretl_array_get_data(a, i) == orig) {
8316 gretl_array_set_data(a, i, curr);
8317 found = 1;
8318 }
8319 }
8320 if (!found) {
8321 err = E_DATA;
8322 }
8323 } else if (uptype == GRETL_TYPE_BUNDLE) {
8324 fprintf(stderr, "sub_object return: uptype = bundle, not handled\n");
8325 err = E_DATA;
8326 } else {
8327 /* no other types handled */
8328 err = E_TYPES;
8329 }
8330 }
8331
8332 return err;
8333 }
8334
is_pointer_arg(fncall * call,int rtype)8335 static int is_pointer_arg (fncall *call, int rtype)
8336 {
8337 ufunc *u = call->fun;
8338
8339 if (call->retname != NULL) {
8340 fn_param *fp;
8341 int i;
8342
8343 for (i=0; i<call->argc; i++) {
8344 fp = &u->params[i];
8345 if ((fp->type == gretl_type_get_ref_type(rtype) ||
8346 (fp->flags & FP_CONST)) &&
8347 strcmp(fp->name, call->retname) == 0) {
8348 return 1;
8349 }
8350 }
8351 }
8352
8353 return 0;
8354 }
8355
push_series_to_caller(ufunc * u,fn_arg * arg,DATASET * dset)8356 static void push_series_to_caller (ufunc *u, fn_arg *arg, DATASET *dset)
8357 {
8358 int v = arg->val.idnum;
8359
8360 if (arg->upname == NULL) {
8361 fprintf(stderr, "ERROR in push_series_to_caller: arg->upname is NULL\n");
8362 return;
8363 }
8364
8365 series_decrement_stack_level(dset, v);
8366 if (series_get_stack_level(dset, v) < 0) {
8367 fprintf(stderr, "@@@ After decrement in %s, stack level=%d for %s @@@\n",
8368 u->name, series_get_stack_level(dset, v), arg->upname);
8369 /*_set_stack_level(dset, v, 0); */
8370 }
8371 strcpy(dset->varname[v], arg->upname);
8372 }
8373
push_object_to_caller(fn_arg * arg)8374 static void push_object_to_caller (fn_arg *arg)
8375 {
8376 user_var_adjust_level(arg->uvar, -1);
8377 user_var_set_name(arg->uvar, arg->upname);
8378 }
8379
8380 #define null_return(t) (t == GRETL_TYPE_VOID || t == GRETL_TYPE_NONE)
8381
8382 #define needs_dataset(t) (t == GRETL_TYPE_SERIES || \
8383 t == GRETL_TYPE_LIST || \
8384 t == GRETL_TYPE_SERIES_REF || \
8385 t == GRETL_TYPE_LISTS || \
8386 t == GRETL_TYPE_LISTS_REF)
8387
8388 static int
function_assign_returns(fncall * call,int rtype,DATASET * dset,void * ret,char ** label,PRN * prn,int * perr)8389 function_assign_returns (fncall *call, int rtype,
8390 DATASET *dset, void *ret,
8391 char **label, PRN *prn,
8392 int *perr)
8393 {
8394 ufunc *u = call->fun;
8395 int i, err = 0;
8396
8397 #if UDEBUG
8398 fprintf(stderr, "function_assign_returns: rtype = %s, call->retname = %s\n",
8399 gretl_type_get_name(rtype), call->retname);
8400 #endif
8401
8402 if (*perr == 0 && !null_return(rtype) && call->retname == NULL) {
8403 /* missing return value */
8404 gretl_errmsg_sprintf("Function %s did not provide the specified return value\n"
8405 "(expected %s)", u->name, gretl_type_get_name(rtype));
8406 *perr = err = E_UNKVAR;
8407 } else if (*perr == 0 && needs_dataset(rtype) && dset == NULL) {
8408 /* "can't happen" */
8409 *perr = err = E_DATA;
8410 }
8411
8412 if (*perr == 0) {
8413 /* first we work on the value directly returned by the
8414 function (but only if there's no error)
8415 */
8416 int copy = is_pointer_arg(call, rtype);
8417
8418 if (rtype == GRETL_TYPE_NUMERIC) {
8419 rtype = fix_numeric_return_type(call, dset);
8420 }
8421
8422 if (rtype == GRETL_TYPE_DOUBLE) {
8423 err = handle_scalar_return(call, ret, rtype);
8424 } else if (rtype == GRETL_TYPE_SERIES) {
8425 err = handle_series_return(call->retname, ret, dset, copy, label);
8426 } else if (rtype == GRETL_TYPE_MATRIX) {
8427 err = handle_matrix_return(call->retname, ret, copy);
8428 } else if (rtype == GRETL_TYPE_LIST) {
8429 /* note: in this case the job is finished in
8430 stop_fncall(); here we just adjust the info on the
8431 listed variables so they don't get deleted
8432 */
8433 err = unlocalize_list(call, call->retname, NULL, ret, dset);
8434 } else if (rtype == GRETL_TYPE_BUNDLE) {
8435 err = handle_bundle_return(call, ret, copy);
8436 } else if (gretl_array_type(rtype)) {
8437 err = handle_array_return(call, ret, copy);
8438 } else if (rtype == GRETL_TYPE_STRING) {
8439 err = handle_string_return(call->retname, ret);
8440 }
8441
8442 if (err == E_UNKVAR) {
8443 pprintf(prn, "Function %s did not provide the specified return value\n",
8444 u->name);
8445 }
8446
8447 *perr = err;
8448 }
8449
8450 /* "Indirect return" values and other pointerized args:
8451 these should be handled even if the function bombed.
8452 */
8453
8454 for (i=0; i<call->argc; i++) {
8455 fn_arg *arg = &call->args[i];
8456 fn_param *fp = &u->params[i];
8457 int ierr = 0;
8458
8459 if (needs_dataset(fp->type) && dset == NULL) {
8460 ierr = E_DATA;
8461 } else if (gretl_ref_type(fp->type)) {
8462 if (arg->type == GRETL_TYPE_SERIES_REF) {
8463 push_series_to_caller(u, arg, dset);
8464 } else if (arg->upname != NULL) {
8465 push_object_to_caller(arg);
8466 } else if (arg->uvar != NULL) {
8467 ierr = check_sub_object_return(arg, fp);
8468 } else {
8469 ; /* pure "shell" object: no-op */
8470 }
8471 } else if (arg->type == GRETL_TYPE_USERIES &&
8472 fp->type == GRETL_TYPE_SERIES && fp->immut) {
8473 push_series_to_caller(u, arg, dset);
8474 } else if ((fp->type == GRETL_TYPE_MATRIX ||
8475 fp->type == GRETL_TYPE_BUNDLE ||
8476 fp->type == GRETL_TYPE_STRING ||
8477 fp->type == GRETL_TYPE_NUMERIC ||
8478 gretl_array_type(fp->type))) {
8479 if (arg->shifted) {
8480 /* non-pointerized const object argument,
8481 which we renamed and shifted
8482 */
8483 push_object_to_caller(arg);
8484 }
8485 } else if (fp->type == GRETL_TYPE_LIST) {
8486 unlocalize_list(call, fp->name, arg, NULL, dset);
8487 }
8488 if (ierr) {
8489 *perr = err = ierr;
8490 }
8491 }
8492
8493 #if UDEBUG
8494 fprintf(stderr, "function_assign_returns: returning %d\n", err);
8495 #endif
8496
8497 return err;
8498 }
8499
8500 /* make a record of the sample information at the time a function is
8501 called */
8502
record_obs_info(obsinfo * oi,DATASET * dset)8503 static void record_obs_info (obsinfo *oi, DATASET *dset)
8504 {
8505 oi->changed = 0;
8506 oi->added = 0;
8507
8508 if (dset != NULL) {
8509 oi->structure = dset->structure;
8510 oi->pd = dset->pd;
8511 oi->t1 = dset->t1;
8512 oi->t2 = dset->t2;
8513 strcpy(oi->stobs, dset->stobs);
8514 }
8515 }
8516
8517 /* on function exit, restore the sample information that was in force
8518 on entry */
8519
restore_obs_info(obsinfo * oi,DATASET * dset)8520 static int restore_obs_info (obsinfo *oi, DATASET *dset)
8521 {
8522 gretlopt opt = OPT_NONE;
8523
8524 if (oi->structure == CROSS_SECTION) {
8525 opt = OPT_X;
8526 } else if (oi->structure == TIME_SERIES) {
8527 opt = OPT_T;
8528 } else if (oi->structure == STACKED_TIME_SERIES) {
8529 opt = OPT_S;
8530 } else if (oi->structure == SPECIAL_TIME_SERIES) {
8531 opt = OPT_N;
8532 }
8533
8534 return simple_set_obs(dset, oi->pd, oi->stobs, opt);
8535 }
8536
8537 #if MINIMAL_SETVARS
8538
push_verbosity(fncall * call)8539 static void push_verbosity (fncall *call)
8540 {
8541 if (gretl_messages_on()) {
8542 call->flags |= FC_PREV_MSGS;
8543 }
8544 if (gretl_echo_on()) {
8545 call->flags |= FC_PREV_ECHO;
8546 }
8547 }
8548
pop_verbosity(fncall * call)8549 static void pop_verbosity (fncall *call)
8550 {
8551 set_gretl_messages(call->flags & FC_PREV_MSGS);
8552 set_gretl_echo(call->flags & FC_PREV_ECHO);
8553 }
8554
8555 #endif /* MINIMAL_SETVARS */
8556
8557 /* do the basic housekeeping that is required when a function exits:
8558 destroy local variables, restore previous sample info, etc.
8559 */
8560
stop_fncall(fncall * call,int rtype,void * ret,DATASET * dset,PRN * prn,int redir_level)8561 static int stop_fncall (fncall *call, int rtype, void *ret,
8562 DATASET *dset, PRN *prn, int redir_level)
8563 {
8564 int i, d = gretl_function_depth();
8565 int delv, anyerr = 0;
8566 int err = 0;
8567
8568 #if FN_DEBUG
8569 fprintf(stderr, "stop_fncall: terminating call to "
8570 "function '%s' at depth %d, dset->v = %d\n",
8571 call->fun->name, d, (dset != NULL)? dset->v : 0);
8572 #endif
8573
8574 /* below: delete series local to the function, taking care not to
8575 delete any that have been "promoted" to caller level via their
8576 inclusion in a returned list; also catch any "listarg" series
8577 that are no longer attached to a list
8578 */
8579
8580 if (dset != NULL) {
8581 for (i=call->orig_v, delv=0; i<dset->v; i++) {
8582 if (series_get_stack_level(dset, i) == d) {
8583 delv++;
8584 }
8585 }
8586 if (delv > 0) {
8587 if (delv == dset->v - call->orig_v) {
8588 /* deleting all added series */
8589 anyerr = dataset_drop_last_variables(dset, delv);
8590 if (anyerr && !err) {
8591 err = anyerr;
8592 }
8593 } else {
8594 for (i=dset->v-1; i>=call->orig_v; i--) {
8595 if (series_get_stack_level(dset, i) == d) {
8596 anyerr = dataset_drop_variable(i, dset);
8597 if (anyerr && !err) {
8598 err = anyerr;
8599 }
8600 }
8601 }
8602 }
8603 }
8604 if (call->listvars != NULL) {
8605 int vi;
8606
8607 for (i=1; i<=call->listvars[0]; i++) {
8608 vi = call->listvars[i];
8609 series_unset_flag(dset, vi, VAR_LISTARG);
8610 series_set_stack_level(dset, vi, d - 1);
8611 }
8612 }
8613 }
8614
8615 /* direct list return: write the possibly revised list to the
8616 return pointer. Note that we can't do this earlier, because
8617 the ID numbers of the variables in the return list may be
8618 changed due to the deletion of function-local variables.
8619 */
8620
8621 if (!err && rtype == GRETL_TYPE_LIST && ret != NULL) {
8622 int *lret = gretl_list_copy(get_list_by_name(call->retname));
8623
8624 if (lret != NULL) {
8625 *(int **) ret = lret;
8626 } else {
8627 err = E_ALLOC;
8628 }
8629 }
8630
8631 /* now we're ready to trash function-local vars */
8632 anyerr = destroy_user_vars_at_level(d);
8633
8634 if (anyerr && !err) {
8635 err = anyerr;
8636 }
8637
8638 /* if any anonymous equations system was defined: clean up */
8639 delete_anonymous_equation_system(d);
8640
8641 #if MINIMAL_SETVARS
8642 if (call->fun->flags & UFUN_USES_SET) {
8643 pop_program_state();
8644 } else {
8645 pop_verbosity(call);
8646 }
8647 #else
8648 pop_program_state();
8649 #endif
8650
8651 if (dset != NULL && call->obs.changed) {
8652 restore_obs_info(&call->obs, dset);
8653 }
8654
8655 set_executing_off(call, dset, prn);
8656
8657 if (print_redirection_level(prn) > redir_level) {
8658 gretl_errmsg_set("Incorrect use of 'outfile' in function");
8659 err = 1;
8660 }
8661
8662 return err;
8663 }
8664
8665 /* reset any saved uservar addresses in context of saved loops */
8666
reset_saved_loops(ufunc * u)8667 static void reset_saved_loops (ufunc *u)
8668 {
8669 int i;
8670
8671 for (i=0; i<u->n_lines; i++) {
8672 if (u->lines[i].loop != NULL) {
8673 # if GLOBAL_TRACE
8674 fprintf(stderr, "at exit from %s, reset_saved_loop %p\n",
8675 u->name, (void *) u->lines[i].loop);
8676 # endif
8677 loop_reset_uvars(u->lines[i].loop);
8678 }
8679 }
8680 }
8681
set_pkgdir(fnpkg * pkg)8682 static void set_pkgdir (fnpkg *pkg)
8683 {
8684 const char *p = strrslash(pkg->fname);
8685
8686 if (p != NULL) {
8687 char *pkgdir = gretl_strndup(pkg->fname, p - pkg->fname);
8688
8689 gretl_insert_builtin_string("pkgdir", pkgdir);
8690 free(pkgdir);
8691 }
8692 }
8693
start_fncall(fncall * call,DATASET * dset,PRN * prn)8694 static int start_fncall (fncall *call, DATASET *dset, PRN *prn)
8695 {
8696 GList *tmp = callstack;
8697 fncall *prevcall;
8698
8699 while (tmp != NULL) {
8700 prevcall = tmp->data;
8701 if (prevcall->fun == call->fun) {
8702 set_call_recursing(call);
8703 break;
8704 }
8705 tmp = tmp->next;
8706 }
8707
8708 set_previous_depth(fn_executing);
8709 fn_executing++;
8710
8711 #if MINIMAL_SETVARS
8712 if (call->fun->flags & UFUN_USES_SET) {
8713 push_program_state();
8714 } else {
8715 push_verbosity(call);
8716 }
8717 #else
8718 push_program_state();
8719 #endif
8720
8721 callstack = g_list_append(callstack, call);
8722
8723 #if EXEC_DEBUG
8724 fprintf(stderr, "start_fncall: added call to %s, depth now %d\n",
8725 call->fun->name, g_list_length(callstack));
8726 #endif
8727
8728 switch_uservar_hash(fn_executing);
8729
8730 record_obs_info(&call->obs, dset);
8731
8732 if (gretl_debugging_on() || call->fun->debug) {
8733 set_gretl_echo(1);
8734 set_gretl_messages(1);
8735 pputs(prn, "*** ");
8736 bufspace(gretl_function_depth(), prn);
8737 pprintf(prn, "executing function %s\n", call->fun->name);
8738 } else {
8739 set_gretl_echo(0);
8740 set_gretl_messages(0);
8741 }
8742
8743 if (fn_executing == 1 && call->fun->pkg != NULL) {
8744 set_pkgdir(call->fun->pkg);
8745 }
8746
8747 return 0;
8748 }
8749
func_exec_callback(ExecState * s,void * ptr,GretlObjType type)8750 static int func_exec_callback (ExecState *s, void *ptr,
8751 GretlObjType type)
8752 {
8753 if (s->cmd->ci == FLUSH || is_plotting_command(s->cmd)) {
8754 /* we permit "reach-back" into the GUI for these */
8755 EXEC_CALLBACK gc = get_gui_callback();
8756
8757 if (gc != NULL) {
8758 gc(s, NULL, 0);
8759 }
8760 }
8761
8762 return 0;
8763 }
8764
arg_get_double_val(fn_arg * arg)8765 static double arg_get_double_val (fn_arg *arg)
8766 {
8767 if (gretl_scalar_type(arg->type)) {
8768 return arg->val.x;
8769 } else if (arg->type == GRETL_TYPE_MATRIX) {
8770 return arg->val.m->val[0];
8771 } else {
8772 return NADBL;
8773 }
8774 }
8775
check_function_args(fncall * call,PRN * prn)8776 static int check_function_args (fncall *call, PRN *prn)
8777 {
8778 ufunc *u = call->fun;
8779 fn_arg *arg;
8780 fn_param *fp;
8781 double x;
8782 int i, err = 0;
8783
8784 for (i=0; i<u->n_params; i++) {
8785 /* initialize "immutability" flags */
8786 fp = &u->params[i];
8787 fp->immut = fp->flags & FP_CONST;
8788 }
8789
8790 for (i=0; i<call->argc && !err; i++) {
8791 int scalar_check = 1;
8792
8793 arg = &call->args[i];
8794 fp = &u->params[i];
8795
8796 if ((fp->flags & FP_OPTIONAL) && arg->type == GRETL_TYPE_NONE) {
8797 ; /* this is OK */
8798 } else if (gretl_scalar_type(fp->type) && arg->type == GRETL_TYPE_DOUBLE) {
8799 ; /* OK: types match */
8800 } else if (fp->type == GRETL_TYPE_SERIES && arg->type == GRETL_TYPE_USERIES) {
8801 ; /* OK: types match */
8802 } else if (gretl_scalar_type(fp->type) &&
8803 arg->type == GRETL_TYPE_MATRIX &&
8804 gretl_matrix_is_scalar(arg->val.m)) {
8805 ; /* OK: either types match or we can convert */
8806 } else if (fp->type == GRETL_TYPE_MATRIX && arg->type == GRETL_TYPE_DOUBLE) {
8807 ; /* OK, we can convert */
8808 } else if (fp->type == GRETL_TYPE_LIST && arg->type == GRETL_TYPE_USERIES) {
8809 ; /* OK, we'll handle it (create singleton list) */
8810 } else if (fp->type == GRETL_TYPE_LIST && arg->type == GRETL_TYPE_NONE) {
8811 ; /* OK (special: "null" was passed as argument) */
8812 } else if (gretl_scalar_type(fp->type) && arg->type == GRETL_TYPE_NONE &&
8813 !no_scalar_default(fp)) {
8814 scalar_check = 0; /* OK: arg missing but we have a default value */
8815 } else if (fp->type == GRETL_TYPE_NUMERIC && NUMERIC_TYPE(arg->type)) {
8816 ; /* OK, for overloaded param */
8817 } else if (fp->type != arg->type) {
8818 pprintf(prn, _("%s: argument %d is of the wrong type (is %s, should be %s)\n"),
8819 u->name, i + 1, gretl_type_get_name(arg->type),
8820 gretl_type_get_name(fp->type));
8821 err = E_TYPES;
8822 }
8823
8824 if (!err && scalar_check && fp->type == GRETL_TYPE_DOUBLE) {
8825 /* check for out-of-bounds scalar value */
8826 x = arg_get_double_val(arg);
8827 if ((!na(fp->min) && x < fp->min) ||
8828 (!na(fp->max) && x > fp->max)) {
8829 pprintf(prn, _("%s, argument %d: value %g is out of bounds\n"),
8830 u->name, i + 1, x);
8831 err = E_INVARG;
8832 }
8833 }
8834 }
8835
8836 for (i=call->argc; i<u->n_params && !err; i++) {
8837 /* do we have defaults for any empty args? */
8838 fp = &u->params[i];
8839 if (!(fp->flags & FP_OPTIONAL) && no_scalar_default(fp)) {
8840 pprintf(prn, _("%s: not enough arguments\n"), u->name);
8841 err = E_ARGS;
8842 }
8843 }
8844
8845 #if UDEBUG
8846 fprintf(stderr, "CHECK_FUNCTION_ARGS: err = %d\n", err);
8847 #endif
8848
8849 return err;
8850 }
8851
8852 /**
8853 * user_function_set_debug:
8854 * @name: the name of the function.
8855 * @debug: boolean, if 1 then start debugging function, if
8856 * 0 then stop debugging.
8857 *
8858 * Enables or disables debugging for a user-defined function.
8859 *
8860 * Returns: 0 on success, non-zero if no function is specified
8861 * or if the function is not found.
8862 */
8863
user_function_set_debug(const char * name,int debug)8864 int user_function_set_debug (const char *name, int debug)
8865 {
8866 ufunc *fun;
8867
8868 if (name == NULL || *name == '\0') {
8869 return E_ARGS;
8870 }
8871
8872 fun = get_user_function_by_name(name);
8873
8874 if (fun == NULL) {
8875 return E_UNKVAR;
8876 } else {
8877 fun->debug = debug;
8878 return 0;
8879 }
8880 }
8881
8882 #define debug_cont(c) (c->ci == FUNDEBUG && (c->opt & OPT_C))
8883 #define debug_next(c) (c->ci == FUNDEBUG && (c->opt & OPT_N))
8884
8885 #define set_debug_cont(c) (c->ci = FUNDEBUG, c->opt = OPT_C)
8886 #define set_debug_next(c) (c->ci = FUNDEBUG, c->opt = OPT_N)
8887
8888 /* loop for stepping through function commands; returns
8889 1 if we're debugging, otherwise 0
8890 */
8891
debug_command_loop(ExecState * state,DATASET * dset,DEBUG_READLINE get_line,DEBUG_OUTPUT put_func,int * errp)8892 static int debug_command_loop (ExecState *state,
8893 DATASET *dset,
8894 DEBUG_READLINE get_line,
8895 DEBUG_OUTPUT put_func,
8896 int *errp)
8897 {
8898 int brk = 0, err = 0;
8899
8900 state->flags |= DEBUG_EXEC;
8901
8902 while (!brk) {
8903 #if DDEBUG
8904 fprintf(stderr, "--- debug_command_loop calling get_line\n");
8905 #endif
8906 *errp = (*get_line)(state);
8907 if (*errp) {
8908 /* the debugger failed: get out right away */
8909 state->flags &= ~DEBUG_EXEC;
8910 return 0;
8911 }
8912
8913 err = parse_command_line(state, dset, NULL);
8914 if (err) {
8915 if (!strcmp(state->line, "c")) {
8916 /* short for 'continue' */
8917 set_debug_cont(state->cmd);
8918 err = 0;
8919 } else if (!strcmp(state->line, "n")) {
8920 /* short for 'next' */
8921 set_debug_next(state->cmd);
8922 err = 0;
8923 }
8924 }
8925
8926 if (err || debug_cont(state->cmd) || debug_next(state->cmd)) {
8927 brk = 1;
8928 } else {
8929 /* execute interpolated command */
8930 err = gretl_cmd_exec(state, dset);
8931 if (put_func != NULL) {
8932 #if DDEBUG
8933 fprintf(stderr, "--- debug_command_loop calling put_func\n");
8934 #endif
8935 (*put_func)(state);
8936 }
8937 }
8938 }
8939
8940 if (!debug_next(state->cmd)) {
8941 state->flags &= ~DEBUG_EXEC;
8942 }
8943
8944 return 1 + debug_next(state->cmd);
8945 }
8946
get_funcerr_message(ExecState * state)8947 static const char *get_funcerr_message (ExecState *state)
8948 {
8949 const char *p = state->cmd->param;
8950
8951 if (p != NULL && strlen(p) == gretl_namechar_spn(p)) {
8952 const char *s = get_string_by_name(p);
8953
8954 if (s != NULL) {
8955 return s;
8956 }
8957 } else if (p == NULL) {
8958 return "none";
8959 }
8960
8961 return p;
8962 }
8963
set_func_error_message(int err,ufunc * u,ExecState * state,const char * line,int lineno)8964 static void set_func_error_message (int err, ufunc *u,
8965 ExecState *state,
8966 const char *line,
8967 int lineno)
8968 {
8969 if (err == E_FUNCERR) {
8970 /* let the function writer set the message? */
8971 const char *msg = get_funcerr_message(state);
8972
8973 if (msg != NULL && strcmp(msg, "none")) {
8974 gretl_errmsg_sprintf(_("Error message from %s():\n %s"),
8975 u->name, msg);
8976 return;
8977 }
8978 }
8979
8980 if (err == E_STOP) {
8981 ; /* no-op */
8982 } else {
8983 /* we'll handle this here */
8984 const char *msg = gretl_errmsg_get();
8985 int showline = 1;
8986
8987 if (*msg == '\0') {
8988 msg = errmsg_get_with_default(err);
8989 gretl_errmsg_set(msg);
8990 }
8991
8992 if (*line == '\0' || strncmp(line, "funcerr(", 8) == 0 ||
8993 strncmp(line, "errorif(", 8) == 0) {
8994 showline = 0;
8995 }
8996
8997 if (lineno < 0) {
8998 /* indicates that we don't have a real line number
8999 available (the error occurred inside a loop)
9000 */
9001 if (showline && err != E_FNEST) {
9002 gretl_errmsg_sprintf("*** error within loop in function %s\n> %s",
9003 u->name, line);
9004 } else {
9005 gretl_errmsg_sprintf("*** error within loop in function %s\n",
9006 u->name, lineno);
9007 }
9008 } else {
9009 if (showline && err != E_FNEST) {
9010 gretl_errmsg_sprintf("*** error in function %s, line %d\n> %s",
9011 u->name, lineno, line);
9012 } else {
9013 gretl_errmsg_sprintf("*** error in function %s, line %d\n",
9014 u->name, lineno);
9015 }
9016 }
9017
9018 if (gretl_function_depth() > 1) {
9019 GList *tmp = g_list_last(callstack);
9020
9021 if (tmp != NULL) {
9022 tmp = g_list_previous(tmp);
9023 if (tmp != NULL) {
9024 fncall *call = tmp->data;
9025
9026 gretl_errmsg_sprintf(" called by function %s", call->fun->name);
9027 }
9028 }
9029 }
9030 }
9031 }
9032
determine_numeric_type(char * formula,DATASET * dset,PRN * prn)9033 static int determine_numeric_type (char *formula, DATASET *dset,
9034 PRN *prn)
9035 {
9036 GretlType out_t;
9037 int err;
9038
9039 err = generate(formula, dset, GRETL_TYPE_ANY, OPT_P, prn);
9040 if (!err) {
9041 out_t = genr_get_last_output_type();
9042 if (!NUMERIC_TYPE(out_t)) {
9043 err = E_TYPES;
9044 }
9045 }
9046
9047 return err;
9048 }
9049
handle_return_statement(fncall * call,ExecState * state,DATASET * dset,int lineno)9050 static int handle_return_statement (fncall *call,
9051 ExecState *state,
9052 DATASET *dset,
9053 int lineno)
9054 {
9055 const char *s = state->line + 6; /* skip "return" */
9056 ufunc *fun = call->fun;
9057 int err = 0;
9058
9059 s += strspn(s, " ");
9060
9061 #if EXEC_DEBUG
9062 fprintf(stderr, "%s: return: s = '%s'\n", fun->name, s);
9063 #endif
9064
9065 if (fun->rettype == GRETL_TYPE_VOID) {
9066 if (*s == '\0') {
9067 ; /* plain "return" from void function: OK */
9068 } else if (lineno < 0) {
9069 gretl_errmsg_sprintf("%s: non-null return value '%s' is not valid",
9070 fun->name, s);
9071 err = E_TYPES;
9072 } else {
9073 gretl_errmsg_sprintf("%s, line %d: non-null return value '%s' is not valid",
9074 fun->name, lineno, s);
9075 err = E_TYPES;
9076 }
9077 return err; /* handled */
9078 }
9079
9080 if (*s == '\0') {
9081 if (lineno < 0) {
9082 gretl_errmsg_sprintf("%s: return value is missing", fun->name);
9083 } else {
9084 gretl_errmsg_sprintf("%s, line %d: return value is missing",
9085 fun->name, lineno);
9086 }
9087 err = E_TYPES;
9088 } else {
9089 int len = gretl_namechar_spn(s);
9090
9091 if (len == strlen(s)) {
9092 /* returning a named variable */
9093 call->retname = gretl_strndup(s, len);
9094 } else {
9095 char formula[MAXLINE];
9096
9097 sprintf(formula, "$retval=%s", s);
9098 if (fun->rettype == GRETL_TYPE_NUMERIC) {
9099 err = determine_numeric_type(formula, dset, state->prn);
9100 } else {
9101 err = generate(formula, dset, fun->rettype, OPT_P, state->prn);
9102 }
9103 if (err) {
9104 set_func_error_message(err, fun, state, s, lineno);
9105 } else {
9106 call->retname = gretl_strdup("$retval");
9107 }
9108 }
9109 }
9110
9111 if (!err && call->retname == NULL) {
9112 err = E_ALLOC;
9113 }
9114
9115 return err;
9116 }
9117
do_debugging(ExecState * s)9118 static int do_debugging (ExecState *s)
9119 {
9120 return s->cmd->ci > 0 && !s->cmd->context &&
9121 !gretl_compiling_loop();
9122 }
9123
9124 #define CDEBUG 1
9125
9126 /* Construct bundle of arguments to send to C function;
9127 load plugin; send arguments; and try to retrieve
9128 return value, if any.
9129 */
9130
handle_plugin_call(fncall * call,DATASET * dset,void * retval,PRN * prn)9131 static int handle_plugin_call (fncall *call,
9132 DATASET *dset,
9133 void *retval,
9134 PRN *prn)
9135 {
9136 ufunc *u = call->fun;
9137 int (*cfunc) (gretl_bundle *, PRN *);
9138 void *handle;
9139 gretl_bundle *argb;
9140 int i, err = 0;
9141
9142 #if CDEBUG
9143 fprintf(stderr, "handle_plugin_call: function '%s'\n", u->name);
9144 #endif
9145
9146 if (u->pkg == NULL) {
9147 return E_DATA;
9148 }
9149
9150 cfunc = get_packaged_C_function(u->pkg->name, u->name, &handle);
9151
9152 if (cfunc == NULL) {
9153 return E_FOPEN;
9154 }
9155
9156 /* bundle to serve as wrapper for arguments */
9157 argb = gretl_bundle_new();
9158
9159 if (argb == NULL) {
9160 close_plugin(handle);
9161 return E_ALLOC;
9162 }
9163
9164 for (i=0; i<call->argc && !err; i++) {
9165 fn_param *fp = &u->params[i];
9166 fn_arg *arg = &call->args[i];
9167 const char *key = fp->name;
9168
9169 if (!type_can_be_bundled(fp->type)) {
9170 fprintf(stderr, "type %d: cannot be bundled\n", fp->type);
9171 err = E_TYPES;
9172 break;
9173 }
9174
9175 if (gretl_scalar_type(fp->type)) {
9176 double x;
9177
9178 if (arg->type == GRETL_TYPE_NONE) {
9179 x = fp->deflt;
9180 } else if (arg->type == GRETL_TYPE_MATRIX) {
9181 x = arg->val.m->val[0];
9182 } else {
9183 x = arg->val.x;
9184 }
9185 if (fp->type == GRETL_TYPE_INT || fp->type == GRETL_TYPE_OBS) {
9186 x = (int) x;
9187 } else if (fp->type == GRETL_TYPE_BOOL) {
9188 x = (x != 0.0);
9189 }
9190 err = gretl_bundle_set_data(argb, key, &x, GRETL_TYPE_DOUBLE, 0);
9191 } else if (fp->type == GRETL_TYPE_MATRIX) {
9192 gretl_matrix *m = arg->val.m;
9193
9194 err = gretl_bundle_set_data(argb, key, m, fp->type, 0);
9195 } else if (fp->type == GRETL_TYPE_SERIES) {
9196 int size = sample_size(dset);
9197 double *px;
9198
9199 if (arg->type == GRETL_TYPE_USERIES) {
9200 px = dset->Z[arg->val.idnum];
9201 } else {
9202 px = arg->val.px;
9203 }
9204 err = gretl_bundle_set_data(argb, key, px + dset->t1,
9205 GRETL_TYPE_SERIES, size);
9206 } else if (fp->type == GRETL_TYPE_BUNDLE) {
9207 gretl_bundle *b = arg->val.b;
9208
9209 err = gretl_bundle_set_data(argb, key, b,
9210 GRETL_TYPE_BUNDLE, 0);
9211 } else {
9212 /* FIXME strings and maybe other types */
9213 err = E_TYPES;
9214 }
9215 #if CDEBUG
9216 fprintf(stderr, "arg[%d] (\"%s\") type = %d, err = %d\n",
9217 i, key, fp->type, err);
9218 #endif
9219 }
9220
9221 if (!err) {
9222 /* call the plugin function */
9223 err = (*cfunc) (argb, prn);
9224 }
9225
9226 close_plugin(handle);
9227
9228 if (!err && u->rettype != GRETL_TYPE_VOID && retval != NULL) {
9229 GretlType type;
9230 int size;
9231 void *ptr;
9232
9233 ptr = gretl_bundle_steal_data(argb, "retval", &type, &size, &err);
9234
9235 if (!err) {
9236 #if CDEBUG
9237 fprintf(stderr, "%s: stole return value of type %d\n",
9238 u->name, type);
9239 #endif
9240 if (type != u->rettype) {
9241 fprintf(stderr, "handle_plugin_call: type doesn't match u->rettype\n");
9242 err = E_TYPES;
9243 }
9244 }
9245 if (!err) {
9246 if (type == GRETL_TYPE_DOUBLE) {
9247 double *px = ptr;
9248
9249 *(double *) retval = *px;
9250 free(ptr);
9251 } else if (type == GRETL_TYPE_MATRIX) {
9252 *(gretl_matrix **) retval = ptr;
9253 } else if (type == GRETL_TYPE_BUNDLE) {
9254 *(gretl_bundle **) retval = ptr;
9255 } else if (gretl_array_type(type)) {
9256 *(gretl_array **) retval = ptr;
9257 }
9258 }
9259 }
9260
9261 /* free the arguments wrapper */
9262 gretl_bundle_destroy(argb);
9263
9264 return err;
9265 }
9266
current_function_size(void)9267 int current_function_size (void)
9268 {
9269 ufunc *u = currently_called_function();
9270
9271 return (u != NULL)? u->n_lines : 0;
9272 }
9273
attach_loop_to_function(void * ptr)9274 int attach_loop_to_function (void *ptr)
9275 {
9276 fncall *call = current_function_call();
9277 ufunc *u = NULL;
9278 int err = 0;
9279
9280 if (call != NULL && !is_recursing(call)) {
9281 u = call->fun;
9282 }
9283
9284 if (u == NULL) {
9285 return E_DATA;
9286 } else {
9287 if (u->lines[u->line_idx].loop != NULL) {
9288 /* there should not already be a loop attached */
9289 err = E_DATA;
9290 } else {
9291 /* OK, attach it */
9292 u->lines[u->line_idx].loop = ptr;
9293 #if LSDEBUG || GLOBAL_TRACE
9294 fprintf(stderr, "attaching loop at %p to function %s, line %d\n",
9295 ptr, u->name, u->line_idx);
9296 #endif
9297 }
9298 }
9299
9300 return err;
9301 }
9302
detach_loop_from_function(void * ptr)9303 int detach_loop_from_function (void *ptr)
9304 {
9305 fncall *call = current_function_call();
9306 ufunc *u = NULL;
9307 int err = 0;
9308
9309 if (call != NULL) {
9310 u = call->fun;
9311 }
9312
9313 if (u == NULL) {
9314 return E_DATA;
9315 } else {
9316 int i;
9317
9318 for (i=0; i<u->n_lines; i++) {
9319 if (u->lines[i].loop == ptr) {
9320 #if LSDEBUG || GLOBAL_TRACE
9321 fprintf(stderr, "detaching loop at %p from function %s\n",
9322 ptr, u->name);
9323 #endif
9324 u->lines[i].loop = NULL;
9325 break;
9326 }
9327 }
9328 }
9329
9330 return err;
9331 }
9332
9333 static gchar *return_line;
9334
9335 /* to be called when a "return" statement occurs within a
9336 loop that's being called by a function
9337 */
9338
set_function_should_return(const char * line)9339 int set_function_should_return (const char *line)
9340 {
9341 if (gretl_function_depth() > 0) {
9342 g_free(return_line);
9343 return_line = g_strdup(line);
9344 return 0;
9345 } else {
9346 gretl_errmsg_set("return: can only be used in a function");
9347 return E_PARSE;
9348 }
9349 }
9350
get_return_line(ExecState * state)9351 static int get_return_line (ExecState *state)
9352 {
9353 if (return_line == NULL) {
9354 return 0;
9355 } else {
9356 strcpy(state->line, return_line);
9357 g_free(return_line);
9358 return_line = NULL;
9359 return 1;
9360 }
9361 }
9362
gretl_function_exec(fncall * call,int rtype,DATASET * dset,void * ret,char ** descrip,PRN * prn)9363 int gretl_function_exec (fncall *call, int rtype, DATASET *dset,
9364 void *ret, char **descrip, PRN *prn)
9365 {
9366 DEBUG_READLINE get_line = NULL;
9367 DEBUG_OUTPUT put_func = NULL;
9368 ufunc *u = call->fun;
9369 ExecState state;
9370 MODEL *model = NULL;
9371 char line[MAXLINE];
9372 CMD cmd;
9373 int orig_n = 0;
9374 int orig_t1 = 0;
9375 int orig_t2 = 0;
9376 int indent0 = 0, started = 0;
9377 int redir_level = 0;
9378 int retline = -1;
9379 int debugging = u->debug;
9380 int loopstart = 0;
9381 int i, err = 0;
9382
9383 #if EXEC_DEBUG || GLOBAL_TRACE
9384 fprintf(stderr, "gretl_function_exec: starting %s\n", u->name);
9385 #endif
9386
9387 err = maybe_check_function_needs(dset, u);
9388 if (err) {
9389 maybe_destroy_fncall(call);
9390 return err;
9391 }
9392
9393 #if EXEC_DEBUG
9394 fprintf(stderr, "gretl_function_exec: argc = %d\n", call->argc);
9395 fprintf(stderr, "u->n_params = %d\n", u->n_params);
9396 #endif
9397
9398 if (dset != NULL) {
9399 call->orig_v = dset->v;
9400 orig_n = dset->n;
9401 orig_t1 = dset->t1;
9402 orig_t2 = dset->t2;
9403 } else {
9404 call->orig_v = 0;
9405 }
9406
9407 if (!function_is_plugin(u)) {
9408 /* precaution */
9409 function_state_init(&cmd, &state, &indent0);
9410 }
9411
9412 err = check_function_args(call, prn);
9413
9414 if (function_is_plugin(u)) {
9415 if (!err) {
9416 err = handle_plugin_call(call, dset, ret, prn);
9417 }
9418 maybe_destroy_fncall(call);
9419 return err;
9420 }
9421
9422 if (!err) {
9423 err = allocate_function_args(call, dset);
9424 }
9425
9426 if (err) {
9427 /* get out before allocating further storage */
9428 maybe_destroy_fncall(call);
9429 return err;
9430 }
9431
9432 model = allocate_working_model();
9433 if (model == NULL) {
9434 err = E_ALLOC;
9435 }
9436
9437 if (!err) {
9438 err = gretl_cmd_init(&cmd);
9439 }
9440
9441 if (!err) {
9442 *line = '\0';
9443 gretl_exec_state_init(&state, FUNCTION_EXEC, line, &cmd,
9444 model, prn);
9445 if (dset != NULL) {
9446 if (dset->submask != NULL) {
9447 state.submask = copy_dataset_submask(dset, &err);
9448 }
9449 state.padded = dset->padmask != NULL;
9450 }
9451 state.callback = func_exec_callback;
9452 }
9453
9454 if (!err) {
9455 err = start_fncall(call, dset, prn);
9456 if (!err) {
9457 started = 1;
9458 redir_level = print_redirection_level(prn);
9459 }
9460 }
9461
9462 #if EXEC_DEBUG
9463 fprintf(stderr, "start_fncall: err = %d\n", err);
9464 #endif
9465
9466 if (debugging) {
9467 get_line = get_debug_read_func();
9468 put_func = get_debug_output_func();
9469 if (get_line != NULL) {
9470 debugging = 2;
9471 }
9472 }
9473
9474 /* get function lines in sequence and check, parse, execute */
9475
9476 for (i=0; i<u->n_lines && !err; i++) {
9477 int lineno = u->lines[i].idx;
9478
9479 strcpy(line, u->lines[i].s);
9480
9481 if (debugging) {
9482 pprintf(prn, "%s> %s\n", u->name, line);
9483 } else if (gretl_echo_on()) {
9484 pprintf(prn, "? %s\n", line);
9485 }
9486
9487 if (u->lines[i].ignore) {
9488 continue;
9489 }
9490
9491 if (u->lines[i].loop != NULL && !is_recursing(call)) {
9492 #if LSDEBUG
9493 fprintf(stderr, "%s: got loop %p on line %d (%s)\n", u->name,
9494 (void *) u->lines[i].loop, i, line);
9495 #endif
9496 if (!gretl_if_state_false()) {
9497 /* not blocked, so execute the loop code */
9498 err = gretl_loop_exec(&state, dset, u->lines[i].loop);
9499 if (err) {
9500 set_func_error_message(err, u, &state, state.line, -1);
9501 break;
9502 } else if (get_return_line(&state)) {
9503 /* a "return" statement was encountered in the loop */
9504 err = handle_return_statement(call, &state, dset, -1);
9505 break;
9506 }
9507 }
9508 /* skip to the matching 'endloop' */
9509 i = u->lines[i].next_idx;
9510 continue;
9511 } else {
9512 err = maybe_exec_line(&state, dset, &loopstart);
9513 if (loopstart) {
9514 u->line_idx = i;
9515 loopstart = 0;
9516 }
9517 }
9518
9519 if (!err && !gretl_compiling_loop() && state.cmd->ci == FUNCRET) {
9520 err = handle_return_statement(call, &state, dset, lineno);
9521 if (i < u->n_lines - 1) {
9522 retline = i;
9523 }
9524 break;
9525 }
9526
9527 if (debugging > 1 && do_debugging(&state)) {
9528 if (put_func != NULL) {
9529 pprintf(prn, "-- debugging %s, line %d --\n", u->name, lineno);
9530 (*put_func)(&state);
9531 } else {
9532 pprintf(prn, "-- debugging %s, line %d --\n", u->name, lineno);
9533 }
9534 debugging = debug_command_loop(&state, dset,
9535 get_line, put_func,
9536 &err);
9537 }
9538
9539 if (err) {
9540 set_func_error_message(err, u, &state, line, lineno);
9541 break;
9542 }
9543
9544 if (state.cmd->ci == SETOBS) {
9545 /* set flag for reverting on exit */
9546 call->obs.changed = 1;
9547 }
9548
9549 if (gretl_execute_loop()) {
9550 /* mark the ending point of an (outer) loop */
9551 u->lines[u->line_idx].next_idx = i;
9552 err = gretl_loop_exec(&state, dset, NULL);
9553 if (err) {
9554 /* note that @lineno will point at the end of a loop here */
9555 set_func_error_message(err, u, &state, state.line, -1);
9556 }
9557 if (get_return_line(&state)) {
9558 /* a "return" statement was encountered in the loop */
9559 err = handle_return_statement(call, &state, dset, -1);
9560 break;
9561 }
9562 }
9563 }
9564
9565 #if EXEC_DEBUG
9566 fprintf(stderr, "gretl_function_exec: %s: finished main exec, "
9567 "err = %d, dset->v = %d\n", u->name, err,
9568 (dset != NULL)? dset->v : 0);
9569 #endif
9570
9571 if (dset != NULL) {
9572 /* restore the sample that was in place on entry */
9573 if (complex_subsampled()) {
9574 if (state.submask == NULL) {
9575 /* we were not sub-sampled on entry */
9576 restore_full_sample(dset, NULL);
9577 } else if (submask_cmp(state.submask, dset->submask)) {
9578 /* we were sub-sampled differently on entry */
9579 gretlopt opt = state.padded ? OPT_B : OPT_NONE;
9580
9581 restore_full_sample(dset, NULL);
9582 restrict_sample_from_mask(state.submask, dset, opt);
9583 }
9584 } else if (dset->n > orig_n) {
9585 /* some observations were added inside the function; note
9586 that this is not allowed if the dataset is subsampled
9587 on entry
9588 */
9589 dataset_drop_observations(dset, dset->n - orig_n);
9590 }
9591 dset->t1 = orig_t1;
9592 dset->t2 = orig_t2;
9593 }
9594
9595 if (err) {
9596 if (gretl_function_depth() == 1) {
9597 gretl_if_state_clear();
9598 } else {
9599 gretl_if_state_reset(indent0);
9600 }
9601 } else if (retline >= 0) {
9602 /* we returned prior to the end of the function */
9603 gretl_if_state_reset(indent0);
9604 } else {
9605 err = gretl_if_state_check(indent0);
9606 }
9607
9608 function_assign_returns(call, rtype, dset, ret,
9609 descrip, prn, &err);
9610
9611 if (!err && !is_recursing(call)) {
9612 reset_saved_loops(call->fun);
9613 }
9614
9615 gretl_exec_state_clear(&state);
9616
9617 if (started) {
9618 int stoperr = stop_fncall(call, rtype, ret, dset, prn,
9619 redir_level);
9620
9621 if (stoperr && !err) {
9622 err = stoperr;
9623 }
9624 } else {
9625 maybe_destroy_fncall(call);
9626 }
9627
9628 #if EXEC_DEBUG || GLOBAL_TRACE
9629 fprintf(stderr, "gretl_function_exec (%s) finished: err = %d\n",
9630 u->name, err);
9631 #endif
9632
9633 return err;
9634 }
9635
9636 /* look up name of supplied argument based on name of variable
9637 inside function */
9638
gretl_func_get_arg_name(const char * argvar,int * err)9639 char *gretl_func_get_arg_name (const char *argvar, int *err)
9640 {
9641 fncall *call = current_function_call();
9642 char *ret = NULL;
9643
9644 *err = E_DATA;
9645
9646 if (call != NULL) {
9647 ufunc *u = call->fun;
9648 int i, n = call->argc;
9649
9650 for (i=0; i<n; i++) {
9651 if (!strcmp(argvar, u->params[i].name)) {
9652 *err = 0;
9653 if (call->args[i].upname != NULL) {
9654 ret = gretl_strdup(call->args[i].upname);
9655 } else {
9656 ret = gretl_strdup("");
9657 }
9658 if (ret == NULL) {
9659 *err = E_ALLOC;
9660 }
9661 break;
9662 }
9663 }
9664 }
9665
9666 return ret;
9667 }
9668
9669 /**
9670 * object_is_const:
9671 * @name: name of object.
9672 * @vnum: ID number (specific to objects of type series).
9673 *
9674 * Checks whether the named object currently has 'const' status,
9675 * by virtue of its being made available as a const argument
9676 * to a user-defined function. Note that @name is the name by
9677 * which the object is known within the function, which will
9678 * likely differ from its name in the caller.
9679 *
9680 * Returns: non-zero if the object is const, 0 if it is not.
9681 */
9682
object_is_const(const char * name,int vnum)9683 int object_is_const (const char *name, int vnum)
9684 {
9685 fncall *call = current_function_call();
9686 int ret = 0;
9687
9688 if (call != NULL) {
9689 if (name != NULL) {
9690 fn_param *params = call->fun->params;
9691 int i;
9692
9693 for (i=0; i<call->fun->n_params; i++) {
9694 if (!strcmp(name, params[i].name)) {
9695 ret = params[i].immut;
9696 break;
9697 }
9698 }
9699 }
9700 if (!ret && vnum > 0 && vnum < call->orig_v) {
9701 /* We're looking at a series that is not local to
9702 the called function, but not yet identified as
9703 read-only. It probably _should_ be read-only
9704 unless it was given in pointer form.
9705 Note: this check added 2018-10-18.
9706 */
9707 #if 0 /* debugging */
9708 fprintf(stderr, "*** object_is_const: name '%s', vnum %d, call->orig_v %d\n",
9709 name, vnum, call->orig_v);
9710 #endif
9711 if (!in_gretl_list(call->ptrvars, vnum)) {
9712 ret = 1;
9713 }
9714 }
9715 }
9716
9717 return ret;
9718 }
9719
9720 /**
9721 * object_is_function_arg:
9722 * @name: name of object (e.g. matrix).
9723 *
9724 * Checks whether the named object has been made available
9725 * as a function argument.
9726 *
9727 * Returns: 1 if the object has arg status, 0 otherwise.
9728 */
9729
object_is_function_arg(const char * name)9730 int object_is_function_arg (const char *name)
9731 {
9732 fncall *call = current_function_call();
9733
9734 if (call != NULL) {
9735 fn_param *params = call->fun->params;
9736 int i;
9737
9738 for (i=0; i<call->fun->n_params; i++) {
9739 if (!strcmp(name, params[i].name)) {
9740 return 1;
9741 }
9742 }
9743 }
9744
9745 return 0;
9746 }
9747
9748 static int allow_full_data;
9749
allow_full_data_access(int s)9750 void allow_full_data_access (int s)
9751 {
9752 allow_full_data = (s != 0);
9753 }
9754
9755 /**
9756 * sample_range_get_extrema:
9757 * @dset: dataset info.
9758 * @t1: location to receive earliest possible starting
9759 * observation, or NULL.
9760 * @t2: location to receive latest possible ending observation,
9761 * or NULL.
9762 *
9763 * Fills out @t1 and/or @t2, making allowance for the possibility
9764 * that we're currently executing a function, on entry to
9765 * which the sample range was restricted: within the function,
9766 * we are not allowed to overstep the bounds set on entry.
9767 */
9768
sample_range_get_extrema(const DATASET * dset,int * t1,int * t2)9769 void sample_range_get_extrema (const DATASET *dset, int *t1, int *t2)
9770 {
9771 int tvals[2] = {0, dset->n - 1};
9772
9773 if (!allow_full_data) {
9774 fncall *call = current_function_call();
9775
9776 if (call != NULL) {
9777 tvals[0] = call->obs.t1;
9778 tvals[1] = call->obs.t2 + call->obs.added;
9779 }
9780 }
9781
9782 if (t1 != NULL) {
9783 *t1 = tvals[0];
9784 }
9785 if (t2 != NULL) {
9786 *t2 = tvals[1];
9787 }
9788 }
9789
extend_function_sample_range(int addobs)9790 void extend_function_sample_range (int addobs)
9791 {
9792 fncall *call = current_function_call();
9793
9794 if (call != NULL) {
9795 call->obs.added += addobs;
9796 }
9797 }
9798
9799 /**
9800 * series_is_accessible_in_function:
9801 * @ID: series ID number (0 = constant).
9802 *
9803 * Returns: 1 if the series with ID number @ID is accessible
9804 * by number at the current level of function execution,
9805 * otherwise 0.
9806 */
9807
series_is_accessible_in_function(int ID,const DATASET * dset)9808 int series_is_accessible_in_function (int ID, const DATASET *dset)
9809 {
9810 /* This is harder to get right than one might think, and
9811 for now (as of 2018-10-18) we will not attempt to
9812 screen access to series in this way. However, we do
9813 strive to ensure that series are treated as read-only
9814 when they ought to be. See geneval.c for (potential)
9815 uses of this check, currently def'd out.
9816 */
9817 #if 1
9818 return 1; /* allow all */
9819 #else
9820 fncall *fc = current_function_call();
9821 int ret = 1;
9822
9823 if (fc != NULL) {
9824 /* assume not accessible without contrary evidence */
9825 ret = 0;
9826 if (ID == 0 || ID == LISTSEP) {
9827 /* the constant, always OK; also LISTSEP */
9828 ret = 1;
9829 } else if (ID >= fc->orig_v) {
9830 /* the series post-dates the start of execution */
9831 ret = 1;
9832 } else if (in_gretl_list(fc->listvars, ID)) {
9833 /* series was given in a list argument */
9834 ret = 1;
9835 } else if (in_gretl_list(fc->ptrvars, ID)) {
9836 /* series was given in "pointer" form */
9837 ret = 1;
9838 }
9839 }
9840
9841 if (ret == 0) {
9842 gretl_errmsg_sprintf("Series %d (%s) is not accessible",
9843 ID, dset->varname[ID]);
9844 }
9845
9846 return ret;
9847 #endif
9848 }
9849
9850 /**
9851 * gretl_functions_cleanup:
9852 *
9853 * For internal use: frees all resources associated with
9854 * user-defined functions and function packages.
9855 */
9856
gretl_functions_cleanup(void)9857 void gretl_functions_cleanup (void)
9858 {
9859 int i;
9860
9861 for (i=0; i<n_ufuns; i++) {
9862 ufunc_free(ufuns[i]);
9863 }
9864
9865 free(ufuns);
9866 ufuns = NULL;
9867 n_ufuns = 0;
9868
9869 for (i=0; i<n_pkgs; i++) {
9870 function_package_free(pkgs[i]);
9871 }
9872
9873 free(pkgs);
9874 pkgs = NULL;
9875 n_pkgs = 0;
9876 }
9877
9878 /* generate help output for a packaged function, either for
9879 display on the console, or with markup for display in a
9880 GtkTextView window in the GUI (opt & OPT_M)
9881 */
9882
real_user_function_help(ufunc * fun,gretlopt opt,PRN * prn)9883 static void real_user_function_help (ufunc *fun, gretlopt opt, PRN *prn)
9884 {
9885 fnpkg *pkg = fun->pkg;
9886 int markup = (opt & OPT_M);
9887 int i;
9888
9889 if (markup) {
9890 pprintf(prn, "<@itl=\"Function\">: %s\n", fun->name);
9891 } else {
9892 pprintf(prn, "Function: %s\n", fun->name);
9893 }
9894
9895 if (pkg != NULL) {
9896 if (markup) {
9897 pprintf(prn, "<@itl=\"Package\">: %s %s (%s)\n", pkg->name, pkg->version,
9898 pkg->date);
9899 pprintf(prn, "<@itl=\"Author\">: %s\n", pkg->author? pkg->author : "unknown");
9900 if (pkg->email != NULL && *pkg->email != '\0') {
9901 pprintf(prn, "<@itl=\"Email\">: %s\n", pkg->email);
9902 }
9903 } else {
9904 pprintf(prn, "Package: %s %s (%s)\n", pkg->name, pkg->version,
9905 pkg->date);
9906 pprintf(prn, "Author: %s\n", pkg->author? pkg->author : "unknown");
9907 if (pkg->email != NULL && *pkg->email != '\0') {
9908 pprintf(prn, "Email: %s\n", pkg->email);
9909 }
9910 }
9911 pputc(prn, '\n');
9912 }
9913
9914 if ((opt & OPT_G) && pkg != NULL && pkg->gui_help != NULL) {
9915 /* GUI-specific help is preferred, and is available */
9916 if (markup) {
9917 pputs(prn, "<@itl=\"Help text\">:\n\n");
9918 pputs(prn, "<mono>\n");
9919 } else {
9920 pputs(prn, "Help text:\n");
9921 }
9922 pputs(prn, pkg->gui_help);
9923 if (markup) {
9924 pputs(prn, "\n</mono>");
9925 }
9926 pputs(prn, "\n\n");
9927 return;
9928 }
9929
9930 if (markup) {
9931 pputs(prn, "<@itl=\"Parameters\">: ");
9932 } else {
9933 pputs(prn, "Parameters: ");
9934 }
9935
9936 if (fun->n_params > 0) {
9937 pputc(prn, '\n');
9938 for (i=0; i<fun->n_params; i++) {
9939 pprintf(prn, " %s (%s",
9940 fun->params[i].name, gretl_type_get_name(fun->params[i].type));
9941 if (fun->params[i].descrip != NULL) {
9942 pprintf(prn, ": %s)\n", fun->params[i].descrip);
9943 } else {
9944 pputs(prn, ")\n");
9945 }
9946 }
9947 pputc(prn, '\n');
9948 } else {
9949 pputs(prn, "none\n\n");
9950 }
9951
9952 if (markup) {
9953 pputs(prn, "<@itl=\"Return value\">: ");
9954 } else {
9955 pputs(prn, "Return value: ");
9956 }
9957
9958 if (fun->rettype != GRETL_TYPE_NONE && fun->rettype != GRETL_TYPE_VOID) {
9959 pprintf(prn, "%s\n\n", gretl_type_get_name(fun->rettype));
9960 } else {
9961 pputs(prn, "none\n\n");
9962 }
9963
9964 if (pkg != NULL && pkg->help != NULL) {
9965 if (is_pdf_ref(pkg->help)) {
9966 gchar *pdfname = g_strdup(pkg->fname);
9967 gchar *p = strrchr(pdfname, '.');
9968
9969 *p = '\0';
9970 strcat(p, ".pdf");
9971 if (markup) {
9972 pprintf(prn, "<@itl=\"Documentation\">: <@adb=\"%s\">\n\n", pdfname);
9973 } else {
9974 pprintf(prn, "See %s\n\n", pdfname);
9975 }
9976 g_free(pdfname);
9977 } else {
9978 if (markup) {
9979 pputs(prn, "<@itl=\"Help text\">:\n\n");
9980 pputs(prn, "<mono>\n");
9981 } else {
9982 pputs(prn, "Help text:\n");
9983 }
9984 pputs(prn, pkg->help);
9985 if (markup) {
9986 pputs(prn, "\n</mono>");
9987 }
9988 pputs(prn, "\n\n");
9989 }
9990 }
9991
9992 if (pkg != NULL && pkg->sample != NULL) {
9993 if (markup) {
9994 pputs(prn, "<@itl=\"Sample script\">:\n\n");
9995 pputs(prn, "<code>\n");
9996 } else {
9997 pputs(prn, "Sample script:\n\n");
9998 }
9999 pputs(prn, pkg->sample);
10000 if (markup) {
10001 pputs(prn, "\n</code>\n");
10002 } else {
10003 pprintf(prn, "\n\n");
10004 }
10005 }
10006 }
10007
10008 /**
10009 * user_function_help:
10010 * @fnname: name of function.
10011 * @opt: may include OPT_M for adding markup, OPT_G
10012 * for preferring GUI-specific help, if available.
10013 * @prn: printing struct.
10014 *
10015 * Looks for a function named @fnname and prints
10016 * as much help information as possible.
10017 *
10018 * Returns: 0 on success, non-zero if the function is not
10019 * found.
10020 */
10021
user_function_help(const char * fnname,gretlopt opt,PRN * prn)10022 int user_function_help (const char *fnname, gretlopt opt, PRN *prn)
10023 {
10024 ufunc *fun = get_user_function_by_name(fnname);
10025 int err = 0;
10026
10027 if (fun == NULL) {
10028 pprintf(prn, _("\"%s\" is not defined.\n"), fnname);
10029 err = 1;
10030 } else {
10031 real_user_function_help(fun, opt, prn);
10032 }
10033
10034 return err;
10035 }
10036
10037 /**
10038 * function_package_has_PDF_doc:
10039 * @pkg: function-package pointer.
10040 * @pdfname: location to receive basename of PDF file,
10041 * if applicable (or NULL if this is not wanted).
10042 *
10043 * Checks whether @pkg is documented in the form of a PDF file.
10044 *
10045 * Returns: 1 if so (in which case the name of that file is
10046 * returned via @pdfname), 0 otherwise.
10047 */
10048
function_package_has_PDF_doc(fnpkg * pkg,char ** pdfname)10049 int function_package_has_PDF_doc (fnpkg *pkg, char **pdfname)
10050 {
10051 int ret = 0;
10052
10053 if (pkg->help != NULL && !strncmp(pkg->help, "pdfdoc", 6)) {
10054 ret = 1;
10055 if (pdfname != NULL) {
10056 *pdfname = switch_ext_new(pkg->fname, "pdf");
10057 if (*pdfname == NULL) {
10058 ret = 0;
10059 }
10060 }
10061 }
10062
10063 return ret;
10064 }
10065
10066 /**
10067 * function_package_has_gui_help:
10068 * @pkg: function-package pointer.
10069 *
10070 * Checks whether @pkg has GUI-specific help text.
10071 *
10072 * Returns: 1 if so, 0 otherwise.
10073 */
10074
function_package_has_gui_help(fnpkg * pkg)10075 int function_package_has_gui_help (fnpkg *pkg)
10076 {
10077 return pkg->gui_help != NULL && !string_is_blank(pkg->gui_help);
10078 }
10079
function_package_set_editor(fnpkg * pkg,void * editor)10080 void function_package_set_editor (fnpkg *pkg, void *editor)
10081 {
10082 if (pkg != NULL) {
10083 pkg->editor = editor;
10084 }
10085 }
10086
function_package_get_editor(fnpkg * pkg)10087 void *function_package_get_editor (fnpkg *pkg)
10088 {
10089 return pkg == NULL ? NULL : pkg->editor;
10090 }
10091
10092 /**
10093 * delete_function_package:
10094 * @gfnname: full path to gfn file.
10095 *
10096 * Deletes @gfnname, taking care of deleting its enclosing
10097 * specific subdirectory and all of its contents if applicable.
10098 *
10099 * Returns: 0 on success, non-zero code on error.
10100 */
10101
delete_function_package(const char * gfnname)10102 int delete_function_package (const char *gfnname)
10103 {
10104 char *p = strrslash(gfnname);
10105 gchar *pkgname = NULL;
10106 gchar *pkgdir = NULL;
10107 gchar *pkgsub = NULL;
10108 int err = 0;
10109
10110 if (p != NULL) {
10111 pkgname = g_strdup(p + 1);
10112 p = strrchr(pkgname, '.');
10113 if (p != NULL) {
10114 *p = '\0';
10115 }
10116 pkgdir = g_strdup(gfnname);
10117 p = strrslash(pkgdir);
10118 *p = '\0';
10119 p = strrslash(pkgdir);
10120 if (p != NULL) {
10121 pkgsub = g_strdup(p + 1);
10122 }
10123 }
10124
10125 if (pkgname != NULL && pkgdir != NULL && pkgsub != NULL &&
10126 !strcmp(pkgname, pkgsub)) {
10127 err = gretl_deltree(pkgdir);
10128 } else {
10129 /* should not happen! */
10130 err = gretl_remove(gfnname);
10131 }
10132
10133 g_free(pkgname);
10134 g_free(pkgdir);
10135 g_free(pkgsub);
10136
10137 return err;
10138 }
10139
10140 /**
10141 * uninstall_function_package:
10142 * @package: name of package (with or without .gfn extension).
10143 * @opt: may include OPT_P to "purge" the package.
10144 * @prn: gretl printer.
10145 *
10146 * Returns: 0 on success, non-zero code on error.
10147 */
10148
uninstall_function_package(const char * package,gretlopt opt,PRN * prn)10149 int uninstall_function_package (const char *package, gretlopt opt,
10150 PRN *prn)
10151 {
10152 gchar *gfnname = NULL;
10153 gchar *pkgname = NULL;
10154 char *p, fname[MAXLEN];
10155 int err;
10156
10157 if (has_suffix(package, ".gfn")) {
10158 gfnname = g_strdup(package);
10159 pkgname = g_strdup(package);
10160 p = strrchr(pkgname, '.');
10161 *p = '\0';
10162 } else {
10163 gfnname = g_strdup_printf("%s.gfn", package);
10164 pkgname = g_strdup(package);
10165 }
10166
10167 *fname = '\0';
10168 err = get_full_filename(gfnname, fname, OPT_I);
10169
10170 if (!err && !gretl_file_exists(fname)) {
10171 gretl_errmsg_sprintf("Couldn't find %s", gfnname);
10172 err = E_FOPEN;
10173 }
10174
10175 if (!err) {
10176 function_package_unload_full_by_filename(fname);
10177 if (opt & OPT_P) {
10178 err = delete_function_package(fname);
10179 }
10180 }
10181
10182 if (!err && gretl_messages_on()) {
10183 if (opt & OPT_P) {
10184 pprintf(prn, _("Removed %s\n"), pkgname);
10185 } else {
10186 pprintf(prn, _("Unloaded %s\n"), pkgname);
10187 }
10188 }
10189
10190 g_free(gfnname);
10191 g_free(pkgname);
10192
10193 return err;
10194 }
10195