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 #include "libgretl.h"
21 #include "libset.h"
22 #include "gretl_mt.h"
23 #include "gretl_func.h"
24 #include "gretl_foreign.h"
25 #include "matrix_extra.h"
26 #include "gretl_typemap.h"
27 #include "uservar.h"
28
29 #include <unistd.h>
30
31 #ifdef HAVE_MPI
32 # include "gretl_mpi.h"
33 # include "gretl_xml.h"
34 # ifdef G_OS_WIN32
35 # define MPI_PIPES 1 /* somewhat experimental */
36 # else
37 # define MPI_PIPES 1 /* somewhat experimental */
38 # endif
39 #endif
40
41 #if defined(MPI_PIPES) && !defined(G_OS_WIN32)
42 # define UNIX_MPI_IO 1
43 #endif
44
45 #ifdef USE_RLIB
46 # include <Rinternals.h> /* for SEXP and friends */
47 #endif
48
49 #ifdef G_OS_WIN32
50 # include "gretl_win32.h"
51 #else
52 # include <signal.h>
53 #endif
54
55 #define FDEBUG 0
56
57 static char **foreign_lines;
58 static int foreign_started;
59 static int foreign_n_lines;
60 static int foreign_lang;
61
62 /* foreign_opt may include OPT_D to send data, OPT_Q to operate
63 quietly (don't display output from foreign program)
64 */
65 static gretlopt foreign_opt;
66
67 /* dotdir filenames for R */
68 static gchar *gretl_Rprofile;
69 static gchar *gretl_Rsetup;
70 static gchar *gretl_Rsrc;
71 static gchar *gretl_Rout;
72 static gchar *gretl_Rmsg;
73
74 #ifdef HAVE_MPI
75 static gchar *gretl_mpi_script;
76 #endif
77
78 struct fmap {
79 int lang;
80 const char *scriptname;
81 const char *iofile;
82 gchar *scriptpath;
83 };
84
85 static void write_R_io_file (FILE *fp, const char *ddir);
86
87 static struct fmap foreign_map[] = {
88 { LANG_OX, "gretltmp.ox", "gretl_io.ox", NULL },
89 { LANG_OCTAVE, "gretltmp.m", "gretl_io.m", NULL },
90 { LANG_STATA, "gretltmp.do", "gretl_export.ado", NULL },
91 { LANG_PYTHON, "gretltmp.py", "gretl_io.py", NULL },
92 { LANG_JULIA, "gretltmp.jl", "gretl_io.jl", NULL }
93 };
94
get_io_filename(int lang)95 static const char *get_io_filename (int lang)
96 {
97 int i, n = G_N_ELEMENTS(foreign_map);
98
99 for (i=0; i<n; i++) {
100 if (foreign_map[i].lang == lang) {
101 return foreign_map[i].iofile;
102 }
103 }
104
105 return NULL;
106 }
107
get_foreign_scriptpath(int lang)108 static gchar *get_foreign_scriptpath (int lang)
109 {
110 int i, n = G_N_ELEMENTS(foreign_map);
111
112 for (i=0; i<n; i++) {
113 if (foreign_map[i].lang == lang) {
114 if (foreign_map[i].scriptpath == NULL) {
115 foreign_map[i].scriptpath =
116 gretl_make_dotpath(foreign_map[i].scriptname);
117 }
118 return foreign_map[i].scriptpath;
119 }
120 }
121
122 return NULL;
123 }
124
delete_foreign_script(int lang)125 static void delete_foreign_script (int lang)
126 {
127 int i, n = G_N_ELEMENTS(foreign_map);
128
129 for (i=0; i<n; i++) {
130 if (foreign_map[i].lang == lang) {
131 if (foreign_map[i].scriptpath != NULL) {
132 gretl_remove(foreign_map[i].scriptpath);
133 }
134 break;
135 }
136 }
137 }
138
foreign_destroy(void)139 void foreign_destroy (void)
140 {
141 if (foreign_lines != NULL) {
142 strings_array_free(foreign_lines, foreign_n_lines);
143 foreign_lines = NULL;
144 }
145 foreign_started = 0;
146 foreign_n_lines = 0;
147 foreign_opt = OPT_NONE;
148 }
149
150 /* Get the user's "dotdir" in a form suitable for writing
151 into files to be read by third-party programs. On
152 Windows, such programs will presumably expect the
153 directory name to be in the locale encoding. In most
154 cases (but Stata?) they will also want forward slashes.
155
156 On platforms other than Windows we just pass a copy of
157 dotdir as is.
158 */
159
get_export_dotdir(void)160 static const gchar *get_export_dotdir (void)
161 {
162 static gchar *fdot;
163
164 if (fdot == NULL) {
165 fdot = g_strdup(gretl_dotdir());
166 #ifdef G_OS_WIN32
167 /* recode to locale if necessary */
168 if (utf8_encoded(fdot)) {
169 gsize bytes;
170 gchar *locdot;
171
172 locdot = g_locale_from_utf8(fdot, -1, NULL, &bytes, NULL);
173 if (locdot != NULL) {
174 g_free(fdot);
175 fdot = locdot;
176 }
177 }
178
179 /* ensure forward slashes? is stata OK with this? */
180 if (1) {
181 char *s = fdot;
182
183 while (*s) {
184 if (*s == '\\') {
185 *s = '/';
186 }
187 s++;
188 }
189 }
190 #endif
191 }
192
193 return fdot;
194 }
195
set_foreign_lang(const char * lang,PRN * prn)196 static int set_foreign_lang (const char *lang, PRN *prn)
197 {
198 int err = 0;
199
200 if (g_ascii_strcasecmp(lang, "R") == 0) {
201 foreign_lang = LANG_R;
202 } else if (g_ascii_strcasecmp(lang, "ox") == 0) {
203 foreign_lang = LANG_OX;
204 } else if (g_ascii_strcasecmp(lang, "octave") == 0) {
205 foreign_lang = LANG_OCTAVE;
206 } else if (g_ascii_strcasecmp(lang, "stata") == 0) {
207 foreign_lang = LANG_STATA;
208 } else if (g_ascii_strcasecmp(lang, "python") == 0) {
209 foreign_lang = LANG_PYTHON;
210 } else if (g_ascii_strcasecmp(lang, "julia") == 0) {
211 foreign_lang = LANG_JULIA;
212 } else if (g_ascii_strcasecmp(lang, "mpi") == 0) {
213 #ifdef HAVE_MPI
214 if (gretl_mpi_initialized()) {
215 gretl_errmsg_set(_("MPI is already initialized"));
216 err = E_EXTERNAL;
217 } else {
218 foreign_lang = LANG_MPI;
219 }
220 #else
221 gretl_errmsg_set(_("MPI is not supported in this gretl build"));
222 err = E_NOTIMP;
223 #endif
224 } else {
225 pprintf(prn, "%s: unknown language\n", lang);
226 err = E_DATA;
227 }
228
229 return err;
230 }
231
232 #ifdef HAVE_MPI
233
234 enum {
235 MPI_OPENMPI,
236 MPI_MPICH,
237 MPI_MSMPI
238 };
239
240 # ifdef G_OS_WIN32
241 static int mpi_variant = MPI_MSMPI;
242 # else
243 static int mpi_variant = MPI_OPENMPI;
244 # endif
245
set_mpi_variant(const char * pref)246 void set_mpi_variant (const char *pref)
247 {
248 if (!strcmp(pref, "OpenMPI")) {
249 mpi_variant = MPI_OPENMPI;
250 } else if (!strcmp(pref, "MPICH")) {
251 mpi_variant = MPI_MPICH;
252 } else if (strcmp(pref, "MS-MPI")) {
253 mpi_variant = MPI_MSMPI;
254 }
255 }
256
gretl_max_mpi_processes(void)257 int gretl_max_mpi_processes (void)
258 {
259 const char *hostfile = gretl_mpi_hosts();
260 int procmax = gretl_n_processors();
261
262 if (hostfile != NULL && *hostfile != '\0') {
263 FILE *fp = gretl_fopen(hostfile, "r");
264
265 if (fp != NULL) {
266 const char *fmt;
267 char line[256], host[128];
268 int nf, slots, allslots = 0;
269 int err = 0;
270
271 if (mpi_variant == MPI_MSMPI) {
272 fmt = "%127s %d";
273 } else if (mpi_variant == MPI_MPICH) {
274 fmt = "%127[^:]:%d";
275 } else {
276 fmt = "%127s slots=%d";
277 }
278
279 while (fgets(line, sizeof line, fp) && !err) {
280 if (*line != '#' && !string_is_blank(line)) {
281 nf = sscanf(line, fmt, host, &slots);
282 if (nf == 2) {
283 allslots += slots;
284 } else {
285 err = E_DATA;
286 }
287 }
288 }
289
290 if (!err && allslots > 0) {
291 procmax = allslots;
292 }
293
294 fclose(fp);
295 }
296 }
297
298 return procmax;
299 }
300
check_for_mpiexec(void)301 int check_for_mpiexec (void)
302 {
303 const char *prog = gretl_mpiexec();
304
305 return check_for_program(prog);
306 }
307
get_mpi_scriptname(void)308 static const gchar *get_mpi_scriptname (void)
309 {
310 if (gretl_mpi_script == NULL) {
311 gretl_mpi_script = gretl_make_dotpath("gretltmp-mpi.inp");
312 }
313
314 return gretl_mpi_script;
315 }
316
317 /* The following should probably be redundant on Linux but may
318 be needed for the OS X package, where the gretl bin
319 directory may not be in PATH, and in general will be needed
320 on Windows.
321 */
322
gretl_mpi_binary(void)323 static gchar *gretl_mpi_binary (void)
324 {
325 gchar *ret;
326
327 #ifdef WIN32
328 ret = g_strdup_printf("%sgretlmpi", gretl_bindir());
329 #else
330 gchar *tmp = g_strdup(gretl_home());
331 gchar *p = strstr(tmp, "/share/gretl");
332
333 if (p != NULL) {
334 *p = '\0';
335 ret = g_strdup_printf("%s/bin/gretlmpi", tmp);
336 } else {
337 ret = g_strdup("gretlmpi");
338 }
339
340 g_free(tmp);
341 #endif
342
343 return ret;
344 }
345
346 # ifdef UNIX_MPI_IO
347
348 /* This approach works on Linux */
349
350 struct iodata {
351 int fd;
352 char buf[4096];
353 int len;
354 int finished;
355 int got_all;
356 int *err;
357 PRN *prn;
358 };
359
mpi_childwatch(GPid pid,gint status,gpointer p)360 static void mpi_childwatch (GPid pid, gint status, gpointer p)
361 {
362 struct iodata *io = p;
363
364 #if GLIB_MINOR_VERSION >= 34
365 GError *gerr = NULL;
366
367 if (!g_spawn_check_exit_status(status, &gerr)) {
368 pprintf(io->prn, "gretlmpi: %s\n", gerr->message);
369 *(io->err) = E_EXTERNAL;
370 io->got_all = 1;
371 }
372 #endif
373 g_spawn_close_pid(pid);
374 io->finished = 1;
375 }
376
relay_mpi_output(struct iodata * io)377 static void relay_mpi_output (struct iodata *io)
378 {
379 int got;
380
381 memset(io->buf, 0, io->len);
382 got = read(io->fd, io->buf, io->len - 1);
383
384 if (got > 0) {
385 char *s = strstr(io->buf, "__GRETLMPI_EXIT__");
386
387 if (s != NULL) {
388 io->got_all = 1;
389 *s = '\0';
390 }
391 pputs(io->prn, io->buf);
392 gretl_flush(io->prn);
393 }
394 }
395
run_mpi_with_pipes(char ** argv,struct iodata * io,gretlopt opt,PRN * prn)396 static int run_mpi_with_pipes (char **argv, struct iodata *io,
397 gretlopt opt, PRN *prn)
398 {
399 gint sout;
400 GError *gerr = NULL;
401 GPid child_pid;
402 int err = 0;
403
404 g_spawn_async_with_pipes(gretl_workdir(),
405 argv,
406 NULL, /* envp */
407 G_SPAWN_SEARCH_PATH |
408 G_SPAWN_DO_NOT_REAP_CHILD,
409 NULL, /* child_setup */
410 NULL, /* data for child_setup */
411 &child_pid,
412 NULL, /* stdin */
413 &sout,
414 NULL,
415 &gerr);
416
417 if (gerr != NULL) {
418 pprintf(prn, "%s\n", gerr->message);
419 g_error_free(gerr);
420 err = 1;
421 } else {
422 io->fd = sout;
423 io->len = sizeof io->buf;
424 io->buf[0] = '\0';
425 io->err = &err;
426 io->prn = prn;
427 io->finished = 0;
428 io->got_all = 0;
429
430 g_child_watch_add(child_pid, mpi_childwatch, io);
431
432 while (!io->finished && !io->got_all) {
433 relay_mpi_output(io);
434 if (!io->got_all) {
435 g_usleep(100000); /* 0.10 seconds */
436 }
437 g_main_context_iteration(NULL, FALSE);
438 }
439 while (!err && !io->got_all) {
440 relay_mpi_output(io);
441 }
442 close(sout);
443 }
444
445 return err;
446 }
447
448 # endif /* UNIX_MPI_IO */
449
450 #else /* no MPI support */
451
gretl_max_mpi_processes(void)452 int gretl_max_mpi_processes (void)
453 {
454 return 0;
455 }
456
457 #endif /* HAVE_MPI or not */
458
459 /* special: print to @prn Stata's batch logfile */
460
do_stata_printout(PRN * prn)461 static void do_stata_printout (PRN *prn)
462 {
463 gchar *buf = NULL;
464
465 /* we need to be located in the directory in which
466 gretltmp.log is written at this point */
467 gretl_chdir(gretl_workdir());
468
469 if (g_file_get_contents("gretltmp.log", &buf, NULL, NULL)) {
470 pputs(prn, buf);
471 g_free(buf);
472 pputc(prn, '\n');
473 }
474
475 gretl_remove("gretltmp.log");
476 }
477
make_gretl_R_names(void)478 static void make_gretl_R_names (void)
479 {
480 static int done;
481
482 if (!done) {
483 const char *ddir = get_export_dotdir();
484
485 gretl_Rprofile = g_strdup_printf("%sgretl.Rprofile", ddir);
486 gretl_Rsetup = g_strdup_printf("%sgretl.Rsetup", ddir);
487 gretl_Rsrc = g_strdup_printf("%sRsrc", ddir);
488 gretl_Rout = g_strdup_printf("%sR.out", ddir);
489 gretl_Rmsg = g_strdup_printf("%sR.msg", ddir);
490 done = 1;
491 }
492 }
493
494 #ifdef G_OS_WIN32 /* Windows specific */
495
win32_get_rscript_path(void)496 static char *win32_get_rscript_path (void)
497 {
498 const char *rbin = gretl_rbin_path();
499 char *p, *rscript;
500 int err = 0;
501
502 rscript = calloc(strlen(rbin) + 16, 1);
503 strcpy(rscript, rbin);
504 p = strrchr(rscript, 'R');
505
506 if (p != NULL) {
507 *p = '\0';
508 strcat(p, "Rscript.exe");
509 err = gretl_stat(rscript, NULL);
510 } else {
511 err = 1;
512 }
513
514 if (err) {
515 free(rscript);
516 rscript = NULL;
517 }
518
519 return rscript;
520 }
521
522 /* FIXME Windows console? */
523
win32_put_R_output_line(const char * line,PRN * prn)524 static void win32_put_R_output_line (const char *line, PRN *prn)
525 {
526 if (gretl_in_gui_mode() && !g_utf8_validate(line, -1, NULL)) {
527 gsize bytes;
528
529 gchar *lconv = g_locale_to_utf8(line, -1, NULL,
530 &bytes, NULL);
531 if (lconv != NULL) {
532 pputs(prn, lconv);
533 g_free(lconv);
534 } else {
535 pputs(prn, "line could not be converted to UTF-8\n");
536 }
537 } else {
538 pputs(prn, line);
539 }
540 }
541
win32_lib_run_R_sync(gretlopt opt,PRN * prn)542 static int win32_lib_run_R_sync (gretlopt opt, PRN *prn)
543 {
544 char *rscript = win32_get_rscript_path();
545 gchar *cmd;
546 int err = 0;
547
548 /* ensure that we don't get stale output */
549 gretl_remove(gretl_Rout);
550 gretl_remove(gretl_Rmsg);
551
552 /* Note that here we're calling R with gretl_Rprofile
553 as an argument, as opposed to getting R to source
554 it via the environment, since the latter seemed not
555 to be working on Windows.
556 */
557
558 if (rscript != NULL) {
559 cmd = g_strdup_printf("\"%s\" --vanilla \"%s\"", rscript,
560 gretl_Rprofile);
561 free(rscript);
562 } else {
563 cmd = g_strdup_printf("\"%s\" CMD BATCH --no-save --no-init-file "
564 "--no-restore-data --slave \"%s\"",
565 gretl_rbin_path(), gretl_Rprofile);
566 }
567
568 err = win_run_sync(cmd, NULL);
569
570 #if FDEBUG
571 fprintf(stderr, "lib_run_R_sync: err = %d\n cmd='%s'\n", err, cmd);
572 #endif
573
574 if (!(opt & OPT_Q)) {
575 const gchar *outname;
576 FILE *fp;
577
578 outname = err ? gretl_Rmsg : gretl_Rout;
579 fp = gretl_fopen(outname, "r");
580
581 if (fp != NULL) {
582 char line[1024];
583
584 while (fgets(line, sizeof line, fp)) {
585 win32_put_R_output_line(line, prn);
586 }
587 fclose(fp);
588 gretl_remove(outname);
589 }
590 }
591
592 g_free(cmd);
593
594 return err;
595 }
596
win32_lib_run_other_sync(gretlopt opt,PRN * prn)597 static int win32_lib_run_other_sync (gretlopt opt, PRN *prn)
598 {
599 const char *exe;
600 const char *fname;
601 gchar *cmd = NULL;
602 int err;
603
604 fname = get_foreign_scriptpath(foreign_lang);
605
606 if (foreign_lang == LANG_OX) {
607 exe = gretl_oxl_path();
608 cmd = g_strdup_printf("\"%s\" \"%s\"", exe, fname);
609 } else if (foreign_lang == LANG_OCTAVE) {
610 exe = gretl_octave_path();
611 cmd = g_strdup_printf("\"%s\" --silent -H \"%s\"", exe, fname);
612 } else if (foreign_lang == LANG_STATA) {
613 exe = gretl_stata_path();
614 cmd = g_strdup_printf("\"%s\" /q /e do \"%s\"", exe, fname);
615 } else if (foreign_lang == LANG_PYTHON) {
616 exe = gretl_python_path();
617 cmd = g_strdup_printf("\"%s\" \"%s\"", exe, fname);
618 } else if (foreign_lang == LANG_JULIA) {
619 exe = gretl_julia_path();
620 if (opt & OPT_N) {
621 cmd = g_strdup_printf("\"%s\" --compile=no \"%s\"", exe, fname);;
622 } else {
623 cmd = g_strdup_printf("\"%s\" \"%s\"", exe, fname);
624 }
625 } else {
626 return 1;
627 }
628
629 if (foreign_lang == LANG_OCTAVE) {
630 /* try to suppress octave history mechanism */
631 gretl_setenv("OCTAVE_HISTFILE", "c:\\nul");
632 }
633
634 err = gretl_win32_pipe_output(cmd, gretl_workdir(), OPT_NONE, prn);
635
636 if (!err && foreign_lang == LANG_STATA && !(opt & OPT_Q)) {
637 /* output will be in log file, not stdout */
638 do_stata_printout(prn);
639 }
640
641 g_free(cmd);
642
643 return err;
644 }
645
646 # ifdef HAVE_MPI
647
648 /* Windows: for now we'll not attempt to support anything
649 other than "native" MS-MPI
650 */
651
win32_lib_run_mpi_sync(gretlopt opt,PRN * prn)652 static int win32_lib_run_mpi_sync (gretlopt opt, PRN *prn)
653 {
654 const char *hostfile = gretl_mpi_hosts();
655 int np = 0;
656 int err = 0;
657
658 if (*hostfile == '\0') {
659 hostfile = getenv("GRETL_MPI_HOSTS");
660 }
661
662 if (opt & OPT_N) {
663 /* handle the number-of-processes option */
664 np = get_optval_int(MPI, OPT_N, &err);
665 if (!err && (np <= 0 || np > 9999999)) {
666 err = E_DATA;
667 }
668 }
669
670 if (!err) {
671 const char *mpiexec = gretl_mpiexec();
672 gchar *mpiprog = gretl_mpi_binary();
673 gchar *hostbit, *npbit, *rngbit, *qopt;
674 gchar *cmd = NULL;
675
676 if (!(opt & OPT_L) && hostfile != NULL && *hostfile != '\0') {
677 /* note: OPT_L corresponds to --local, meaning that we
678 should not use a hosts file even if one is present
679 */
680 hostbit = g_strdup_printf(" /machinefile \"%s\"", hostfile);
681 } else {
682 hostbit = g_strdup("");
683 if (np == 0) {
684 /* no hosts file: supply a default np value */
685 if (libset_get_bool(MPI_USE_SMT)) {
686 /* use max number of processes */
687 np = gretl_n_processors();
688 } else {
689 /* don't use hyper-threads */
690 np = gretl_n_physical_cores();
691 }
692 }
693 }
694
695 if (np > 0) {
696 npbit = g_strdup_printf(" /np %d", np);
697 } else {
698 npbit = g_strdup("");
699 }
700
701 if (opt & OPT_S) {
702 rngbit = g_strdup(" --single-rng");
703 } else {
704 rngbit = g_strdup("");
705 }
706
707 if (opt & OPT_Q) {
708 qopt = g_strdup(" --quiet");
709 } else {
710 qopt = g_strdup("");
711 }
712
713 cmd = g_strdup_printf("%s%s%s \"%s\"%s%s \"%s\"",
714 mpiexec, hostbit, npbit, mpiprog, rngbit,
715 qopt, get_mpi_scriptname());
716
717 if (opt & OPT_V) {
718 pputs(prn, "gretl mpi command:\n ");
719 pputs(prn, cmd);
720 pputc(prn, '\n');
721 }
722
723 #ifdef MPI_PIPES
724 err = gretl_win32_pipe_output(cmd, gretl_workdir(), OPT_R, prn);
725 #else
726 err = gretl_win32_pipe_output(cmd, gretl_workdir(), OPT_NONE, prn);
727 #endif
728
729 g_free(mpiprog);
730 g_free(hostbit);
731 g_free(npbit);
732 g_free(rngbit);
733 g_free(cmd);
734 }
735
736 return err;
737 }
738
739 # endif /* HAVE_MPI (&& G_OS_WIN32) */
740
741 #endif /* G_OS_WIN32 */
742
lib_run_prog_sync(char ** argv,gretlopt opt,int lang,PRN * prn)743 static int lib_run_prog_sync (char **argv, gretlopt opt,
744 int lang, PRN *prn)
745 {
746 gchar *sout = NULL;
747 gchar *errout = NULL;
748 gint status = 0;
749 GError *gerr = NULL;
750 int err = 0;
751
752 g_spawn_sync(gretl_workdir(), argv,
753 NULL, G_SPAWN_SEARCH_PATH,
754 NULL, NULL, &sout, &errout,
755 &status, &gerr);
756
757 if (gerr != NULL) {
758 pprintf(prn, "%s\n", gerr->message);
759 g_error_free(gerr);
760 err = 1;
761 } else if (status != 0) {
762 pprintf(prn, "%s exited with status %d\n", argv[0], status);
763 if (sout != NULL && *sout != '\0') {
764 pputs(prn, "stdout:\n");
765 pputs(prn, sout);
766 pputc(prn, '\n');
767 }
768 if (errout != NULL && *errout != '\0') {
769 pputs(prn, "\nstderr:\n");
770 pputs(prn, errout);
771 pputc(prn, '\n');
772 }
773 err = 1;
774 } else if (sout != NULL) {
775 if (lang == LANG_MPI || !(opt & OPT_Q)) {
776 /* with OPT_Q, don't print non-error output,
777 unless we're running MPI
778 */
779 if (foreign_lang == LANG_STATA) {
780 do_stata_printout(prn);
781 } else if (*sout != '\0') {
782 pputs(prn, sout);
783 pputc(prn, '\n');
784 }
785 }
786 if (opt & OPT_V) {
787 /* also print stderr output, if any */
788 if (errout != NULL && *errout != '\0') {
789 pputs(prn, "\nstderr:\n");
790 pputs(prn, errout);
791 pputc(prn, '\n');
792 }
793 }
794 } else {
795 pprintf(prn, "%s: %s\n", argv[0], "Got no output");
796 err = 1;
797 }
798
799 g_free(sout);
800 g_free(errout);
801
802 return err;
803 }
804
805 #ifndef G_OS_WIN32 /* non-Windows code follows */
806
lib_run_R_sync(gretlopt opt,PRN * prn)807 static int lib_run_R_sync (gretlopt opt, PRN *prn)
808 {
809 char *argv[] = {
810 "R",
811 "--no-save",
812 "--no-init-file",
813 "--no-restore-data",
814 "--slave",
815 NULL
816 };
817
818 return lib_run_prog_sync(argv, opt, LANG_R, prn);
819 }
820
lib_run_other_sync(gretlopt opt,PRN * prn)821 static int lib_run_other_sync (gretlopt opt, PRN *prn)
822 {
823 char *scriptpath;
824 char *argv[6];
825 int err;
826
827 scriptpath = (char *) get_foreign_scriptpath(foreign_lang);
828
829 if (foreign_lang == LANG_OX) {
830 argv[0] = (char *) gretl_oxl_path();
831 argv[1] = scriptpath;
832 argv[2] = NULL;
833 } else if (foreign_lang == LANG_OCTAVE) {
834 argv[0] = (char *) gretl_octave_path();
835 argv[1] = "--silent";
836 argv[2] = "-H";
837 argv[3] = scriptpath;
838 argv[4] = NULL;
839 } else if (foreign_lang == LANG_PYTHON) {
840 argv[0] = (char *) gretl_python_path();
841 argv[1] = scriptpath;
842 argv[2] = NULL;
843 } else if (foreign_lang == LANG_JULIA) {
844 argv[0] = (char *) gretl_julia_path();
845 if (opt & OPT_N) {
846 argv[1] = "--compile=no";
847 argv[2] = scriptpath;
848 argv[3] = NULL;
849 } else {
850 argv[1] = scriptpath;
851 argv[2] = NULL;
852 }
853 } else if (foreign_lang == LANG_STATA) {
854 argv[0] = (char *) gretl_stata_path();
855 argv[1] = "-q";
856 argv[2] = "-b";
857 argv[3] = "do";
858 argv[4] = scriptpath;
859 argv[5] = NULL;
860 }
861
862 if (foreign_lang == LANG_OCTAVE) {
863 /* suppress history mechanism */
864 gretl_setenv("OCTAVE_HISTFILE", "/dev/null");
865 }
866
867 err = lib_run_prog_sync(argv, opt, foreign_lang, prn);
868
869 return err;
870 }
871
872 #ifdef HAVE_MPI
873
print_mpi_command(char ** argv,PRN * prn)874 static void print_mpi_command (char **argv, PRN *prn)
875 {
876 int i;
877
878 pputs(prn, "gretl mpi command:\n ");
879 for (i=0; argv[i] != NULL; i++) {
880 pprintf(prn, "%s ", argv[i]);
881 }
882 pputc(prn, '\n');
883 }
884
885 #define MPI_VGRIND 0 /* debugging via valgrind */
886
lib_run_mpi_sync(gretlopt opt,void * ptr,PRN * prn)887 static int lib_run_mpi_sync (gretlopt opt, void *ptr, PRN *prn)
888 {
889 const char *hostfile = gretl_mpi_hosts();
890 char np = 0;
891 int err = 0;
892
893 if (*hostfile == '\0') {
894 hostfile = getenv("GRETL_MPI_HOSTS");
895 }
896
897 if (opt & OPT_N) {
898 /* handle the number-of-processes option */
899 int opt_np = get_optval_int(MPI, OPT_N, &err);
900
901 if (!err && (opt_np <= 0 || opt_np > 9999999)) {
902 err = E_DATA;
903 }
904 if (!err) {
905 np = opt_np;
906 }
907 }
908
909 if (!err) {
910 const char *mpiexec = gretl_mpiexec();
911 gchar *mpiprog = gretl_mpi_binary();
912 const char *hostsopt = NULL;
913 char *argv[12] = {0};
914 char npnum[8] = {0};
915 int nproc, i = 0;
916
917 nproc = gretl_n_processors();
918
919 if (!(opt & OPT_L) && hostfile != NULL && *hostfile != '\0') {
920 if (mpi_variant == MPI_MPICH) {
921 hostsopt = "-machinefile";
922 } else if (mpi_variant == MPI_MSMPI) {
923 hostsopt = "/machinefile";
924 } else {
925 hostsopt = "--hostfile";
926 }
927 } else if (np == 0) {
928 /* no user spec, so supply a default np value */
929 if (libset_get_bool(MPI_USE_SMT)) {
930 /* use max number of processes */
931 np = nproc;
932 } else {
933 /* don't use hyper-threads */
934 np = gretl_n_physical_cores();
935 }
936 }
937
938 argv[i++] = (char *) mpiexec;
939 if (hostsopt != NULL) {
940 argv[i++] = (char *) hostsopt;
941 argv[i++] = (char *) hostfile;
942 }
943 if (np > 0) {
944 sprintf(npnum, "%d", np);
945 argv[i++] = (mpi_variant == MPI_MSMPI)? "/np" : "-np";
946 argv[i++] = npnum;
947 if (mpi_variant == MPI_OPENMPI && np > nproc/2) {
948 argv[i++] = "--oversubscribe";
949 }
950 }
951 #if MPI_VGRIND
952 argv[i++] = "valgrind";
953 #endif
954 argv[i++] = mpiprog;
955 if (opt & OPT_S) {
956 argv[i++] = "--single-rng";
957 }
958 if (opt & OPT_Q) {
959 argv[i++] = "--quiet";
960 }
961 argv[i++] = (char *) get_mpi_scriptname();
962 argv[i] = NULL;
963
964 if (opt & OPT_V) {
965 print_mpi_command(argv, prn);
966 }
967
968 #ifdef MPI_PIPES
969 err = run_mpi_with_pipes(argv, ptr, opt, prn);
970 #else
971 err = lib_run_prog_sync(argv, opt, LANG_MPI, prn);
972 #endif
973 g_free(mpiprog);
974 }
975
976 return err;
977 }
978
979 #endif /* HAVE_MPI */
980
981 #endif /* end non-Windows block */
982
983 /* end experimental move */
984
write_open_dotfile(const char * fname)985 static FILE *write_open_dotfile (const char *fname)
986 {
987 gchar *path = gretl_make_dotpath(fname);
988 FILE *fp;
989
990 fp = gretl_fopen(path, "w");
991 g_free(path);
992
993 return fp;
994 }
995
dotfile_exists(const char * fname)996 static int dotfile_exists (const char *fname)
997 {
998 gchar *path = gretl_make_dotpath(fname);
999 struct stat buf = {0};
1000 int ret = 0;
1001
1002 if (gretl_stat(path, &buf) == 0 && buf.st_size > 32) {
1003 ret = 1;
1004 }
1005
1006 g_free(path);
1007
1008 return ret;
1009 }
1010
write_ox_io_file(FILE * fp,const char * ddir)1011 static void write_ox_io_file (FILE *fp, const char *ddir)
1012 {
1013 fputs("gretl_dotdir ()\n{\n", fp);
1014 fprintf(fp, " return \"%s\";\n", ddir);
1015 fputs("}\n\n", fp);
1016
1017 fputs("gretl_export_nodot (const X, const str)\n{\n", fp);
1018 fputs(" decl fp = fopen(str, \"w\");\n", fp);
1019 fputs(" fprint(fp, \"%d \", rows(X), \"%d\", columns(X));\n", fp);
1020 fputs(" fprint(fp, \"%.15g\", X);\n", fp);
1021 fputs(" fclose(fp);\n}\n\n", fp);
1022
1023 fputs("gretl_export (const X, const str)\n{\n", fp);
1024 fputs(" decl dname = gretl_dotdir();\n", fp);
1025 fputs(" decl fp = fopen(dname ~ str, \"w\");\n", fp);
1026 fputs(" fprint(fp, \"%d \", rows(X), \"%d\", columns(X));\n", fp);
1027 fputs(" fprint(fp, \"%.15g\", X);\n", fp);
1028 fputs(" fclose(fp);\n}\n\n", fp);
1029
1030 fputs("gretl_loadmat (const str)\n{\n", fp);
1031 fputs(" decl dname = gretl_dotdir();\n", fp);
1032 fputs(" decl X = loadmat(dname ~ str);\n", fp);
1033 fputs(" return X;\n}\n", fp);
1034 }
1035
write_octave_io_file(FILE * fp,const char * ddir)1036 static void write_octave_io_file (FILE *fp, const char *ddir)
1037 {
1038 fputs("# not a 'function file' as such\n1;\n\n", fp);
1039 fputs("function dotdir = gretl_dotdir()\n", fp);
1040 fprintf(fp, " dotdir = \"%s\";\n", ddir);
1041 fputs("endfunction\n\n", fp);
1042
1043 fputs("function gretl_export(X, fname, autodot=1)\n", fp);
1044 fputs(" if (autodot && !is_absolute_filename(fname))\n", fp);
1045 fputs(" dname = gretl_dotdir();\n", fp);
1046 fputs(" fd = fopen(strcat(dname, fname), \"w\");\n", fp);
1047 fputs(" else\n", fp);
1048 fputs(" fd = fopen(fname, \"w\");\n", fp);
1049 fputs(" endif\n", fp);
1050 fputs(" ext = fname(end-3:end);\n", fp);
1051 fputs(" if (strcmp(ext, '.bin'))\n", fp);
1052 fputs(" if (iscomplex(X))\n", fp);
1053 fputs(" fwrite(fd, 'gretl_binar_cmatrix', \"uchar\");\n", fp);
1054 fputs(" fwrite(fd, 2*rows(X), \"int32\", 0, \"l\");\n", fp);
1055 fputs(" fwrite(fd, columns(X), \"int32\", 0, \"l\");\n", fp);
1056 fputs(" A = real(X);\n", fp);
1057 fputs(" B = imag(X);\n", fp);
1058 fputs(" N = rows(X) * columns(X);\n", fp);
1059 fputs(" for i = 1:N\n", fp);
1060 fputs(" fwrite(fd, A(i), \"double\", 0, \"l\");\n", fp);
1061 fputs(" fwrite(fd, B(i), \"double\", 0, \"l\");\n", fp);
1062 fputs(" endfor\n", fp);
1063 fputs(" else\n", fp);
1064 fputs(" fwrite(fd, 'gretl_binary_matrix', \"uchar\");\n", fp);
1065 fputs(" fwrite(fd, rows(X), \"int32\", 0, \"l\");\n", fp);
1066 fputs(" fwrite(fd, columns(X), \"int32\", 0, \"l\");\n", fp);
1067 fputs(" fwrite(fd, X, \"double\", 0, \"l\");\n", fp);
1068 fputs(" endif\n", fp);
1069 fputs(" else\n", fp);
1070 fputs(" fprintf(fd, \"%d %d\\n\", size(X));\n", fp);
1071 fputs(" c = columns(X);\n", fp);
1072 fputs(" fs = strcat(strrep(sprintf(\"%d \", ones(1, c)), "
1073 "\"1\", \"%.15g\"), \"\\n\");", fp);
1074 fputc('\n', fp);
1075 fputs(" fprintf(fd, fs, X');\n", fp);
1076 fputs(" endif\n", fp);
1077 fputs(" fclose(fd);\n", fp);
1078 fputs("endfunction\n\n", fp);
1079
1080 fputs("function A = gretl_loadmat(fname, autodot=1)\n", fp);
1081 fputs(" if (autodot && !is_absolute_filename(fname))\n", fp);
1082 fputs(" dname = gretl_dotdir();\n", fp);
1083 fputs(" fd = fopen(strcat(dname, fname), \"r\");\n", fp);
1084 fputs(" else\n", fp);
1085 fputs(" fd = fopen(fname, \"r\");\n", fp);
1086 fputs(" endif\n", fp);
1087 fputs(" ext = fname(end-3:end);\n", fp);
1088 fputs(" if (strcmp(ext, '.bin'))\n", fp);
1089 fputs(" hdr = fread(fd, 19, \"uchar\")';\n", fp);
1090 fputs(" if sum(hdr == 'gretl_binary_matrix') == 19\n", fp);
1091 fputs(" cmplx = 0;\n", fp);
1092 fputs(" elseif sum(hdr == 'gretl_binar_cmatrix') == 19\n", fp);
1093 fputs(" cmplx = 1;\n", fp);
1094 fputs(" else\n", fp);
1095 fputs(" error(\"not a valid gretl binary matrix\");\n", fp);
1096 fputs(" endif\n", fp);
1097 fputs(" r = fread(fd, 1, \"int32\", 0, \"l\");\n", fp);
1098 fputs(" c = fread(fd, 1, \"int32\", 0, \"l\");\n", fp);
1099 fputs(" A = fread(fd, [r, c], \"double\", 0, \"l\");\n", fp);
1100 fputs(" if cmplx == 1;\n", fp);
1101 fputs(" Re = A(1:2:end,:);\n", fp);
1102 fputs(" Im = A(2:2:end,:);\n", fp);
1103 fputs(" A = complex(Re, Im);\n", fp);
1104 fputs(" endif\n", fp);
1105 fputs(" else\n", fp);
1106 fputs(" [r,c] = fscanf(fd, \"%d %d\", \"C\");\n", fp);
1107 fputs(" A = reshape(fscanf(fd, \"%g\", r*c),c,r)';\n", fp);
1108 fputs(" endif\n", fp);
1109 fputs(" fclose(fd);\n", fp);
1110 fputs("endfunction\n\n", fp);
1111 }
1112
write_python_io_file(FILE * fp,const char * ddir)1113 static void write_python_io_file (FILE *fp, const char *ddir)
1114 {
1115 fprintf(fp, "gretl_dotdir = \"%s\"\n\n", ddir);
1116 fputs("import os\n", fp);
1117 /* export matrix for reading by gretl */
1118 fputs("\ndef gretl_export(X, fname, autodot=1):\n", fp);
1119 fputs(" binwrite = 0\n", fp);
1120 fputs(" if fname[-4:] == '.bin':\n", fp);
1121 fputs(" binwrite = 1\n", fp);
1122 fputs(" from numpy import asmatrix, asarray, iscomplexobj, real, imag\n", fp);
1123 fputs(" from struct import pack\n", fp);
1124 fputs(" else:\n", fp);
1125 fputs(" from numpy import asmatrix, savetxt\n", fp);
1126 fputs(" M = asmatrix(X)\n", fp);
1127 fputs(" r, c = M.shape\n", fp);
1128 fputs(" if autodot and not os.path.isabs(fname):\n", fp);
1129 fputs(" fname = gretl_dotdir + fname\n", fp);
1130 fputs(" if binwrite:\n", fp);
1131 fputs(" from sys import byteorder\n", fp);
1132 fputs(" cmplx = iscomplexobj(X)\n", fp);
1133 fputs(" f = open(fname, 'wb')\n", fp);
1134 fputs(" if cmplx:\n", fp);
1135 fputs(" f.write(b'gretl_binar_cmatrix')\n", fp);
1136 fputs(" f.write(pack('<i', 2*r))\n", fp);
1137 fputs(" else:\n", fp);
1138 fputs(" f.write(b'gretl_binary_matrix')\n", fp);
1139 fputs(" f.write(pack('<i', r))\n", fp);
1140 fputs(" f.write(pack('<i', c))\n", fp);
1141 fputs(" if cmplx:\n", fp);
1142 fputs(" for j in range(0, c):\n", fp);
1143 fputs(" for i in range(0, r):\n", fp);
1144 fputs(" f.write(pack('<d', real(M[i,j])))\n", fp);
1145 fputs(" f.write(pack('<d', imag(M[i,j])))\n", fp);
1146 fputs(" elif byteorder == 'big':\n", fp);
1147 fputs(" for j in range(0, c):\n", fp);
1148 fputs(" for i in range(0, r):\n", fp);
1149 fputs(" f.write(pack('<d', M[i,j]))\n", fp);
1150 fputs(" else:\n", fp);
1151 fputs(" A = asarray(X, dtype=float)\n", fp);
1152 fputs(" f.write(A.tobytes('F'))\n", fp);
1153 fputs(" f.close()\n", fp);
1154 fputs(" else:\n", fp);
1155 fputs(" ghead = repr(r) + ' ' + repr(c)\n", fp);
1156 fputs(" savetxt(fname, M, header=ghead, comments='')\n", fp);
1157
1158 /* import matrix from gretl */
1159 fputs("\ndef gretl_loadmat(fname, autodot=1):\n", fp);
1160 fputs(" if autodot and not os.path.isabs(fname):\n", fp);
1161 fputs(" fname = gretl_dotdir + fname\n", fp);
1162 fputs(" if fname[-4:] == '.bin':\n", fp);
1163 fputs(" from numpy import ndarray, asmatrix\n", fp);
1164 fputs(" from struct import unpack\n", fp);
1165 fputs(" f = open(fname, 'rb')\n", fp);
1166 fputs(" buf = f.read(19)\n", fp);
1167 fputs(" if buf == b'gretl_binary_matrix':\n", fp);
1168 fputs(" cmplx = 0\n", fp);
1169 fputs(" elif buf == b'gretl_binar_cmatrix':\n", fp);
1170 fputs(" cmplx = 1\n", fp);
1171 fputs(" else:\n", fp);
1172 fputs(" raise ValueError('Not a gretl binary matrix')\n", fp);
1173 fputs(" r = unpack('<i', f.read(4))[0]\n", fp);
1174 fputs(" c = unpack('<i', f.read(4))[0]\n", fp);
1175 fputs(" M = ndarray(shape=(r,c), dtype=float, order='F')\n", fp);
1176 fputs(" for j in range(0, c):\n", fp);
1177 fputs(" for i in range(0, r):\n", fp);
1178 fputs(" M[i,j] = unpack('<d', f.read(8))[0]\n", fp);
1179 fputs(" f.close()\n", fp);
1180 fputs(" if cmplx == 1:\n", fp);
1181 fputs(" M.dtype = complex\n", fp);
1182 fputs(" M = asmatrix(M)\n", fp);
1183 fputs(" else:\n", fp);
1184 fputs(" from numpy import loadtxt\n", fp);
1185 fputs(" M = loadtxt(fname, skiprows=1)\n", fp);
1186 fputs(" return M\n\n", fp);
1187 }
1188
write_julia_io_file(FILE * fp,const char * ddir)1189 static void write_julia_io_file (FILE *fp, const char *ddir)
1190 {
1191 fprintf(fp, "gretl_dotdir = \"%s\"\n\n", ddir);
1192 fputs("using Printf\n", fp);
1193 fputs("using DelimitedFiles\n\n", fp);
1194 fputs("function gretl_export(M, fname, autodot=1)\n", fp);
1195 fputs(" if VERSION < v\"1.0\"\n", fp);
1196 fputs(" error(\"gretl_export requires Julia >= 1.0\")\n", fp);
1197 fputs(" end\n", fp);
1198 fputs(" r,c = size(M)\n", fp);
1199 fputs(" if autodot != 0 && !isabspath(fname)\n", fp);
1200 fputs(" fname = gretl_dotdir * fname\n", fp);
1201 fputs(" end\n", fp);
1202 fputs(" f = open(fname, \"w\")\n", fp);
1203 fputs(" n = lastindex(fname)\n", fp);
1204 fputs(" if fname[n-3:n] == \".bin\"\n", fp);
1205 fputs(" # binary mode\n", fp);
1206 fputs(" local cmplx::Bool\n", fp);
1207 fputs(" if typeof(M) == Array{Complex{Float64},2}\n", fp);
1208 fputs(" cmplx = 1\n", fp);
1209 fputs(" rr = 2*r\n", fp);
1210 fputs(" write(f, b\"gretl_binar_cmatrix\")\n", fp);
1211 fputs(" else\n", fp);
1212 fputs(" cmplx = 0\n", fp);
1213 fputs(" rr = r\n", fp);
1214 fputs(" write(f, b\"gretl_binary_matrix\")\n", fp);
1215 fputs(" end\n", fp);
1216 fputs(" write(f, htol(Int32(rr)))\n", fp);
1217 fputs(" write(f, htol(Int32(c)))\n", fp);
1218 fputs(" for j=1:c\n", fp);
1219 fputs(" for i=1:r\n", fp);
1220 fputs(" if cmplx\n", fp);
1221 fputs(" write(f, htol(Float64(real(M[i,j]))))\n", fp);
1222 fputs(" write(f, htol(Float64(imag(M[i,j]))))\n", fp);
1223 fputs(" else\n", fp);
1224 fputs(" write(f, htol(Float64(M[i,j])))\n", fp);
1225 fputs(" end\n", fp);
1226 fputs(" end\n", fp);
1227 fputs(" end\n", fp);
1228 fputs(" else\n", fp);
1229 fputs(" # text mode\n", fp);
1230 fputs(" @printf(f, \"%d\\t%d\\n\", r, c)\n", fp);
1231 fputs(" for i = 1:r\n", fp);
1232 fputs(" for j = 1:c\n", fp);
1233 fputs(" @printf(f, \"%.18e \", M[i,j])\n", fp);
1234 fputs(" end\n", fp);
1235 fputs(" @printf(f, \"\\n\")\n", fp);
1236 fputs(" end\n", fp);
1237 fputs(" end\n", fp);
1238 fputs(" close(f)\n", fp);
1239 fputs("end\n\n", fp);
1240
1241 fputs("function gretl_loadmat(fname, autodot=1)\n", fp);
1242 fputs(" if VERSION < v\"1.0\"\n", fp);
1243 fputs(" error(\"gretl_loadmat requires Julia >= 1.0\")\n", fp);
1244 fputs(" end\n", fp);
1245 fputs(" if autodot != 0 && !isabspath(fname)\n", fp);
1246 fputs(" fname = gretl_dotdir * fname\n", fp);
1247 fputs(" end\n", fp);
1248 fputs(" n = lastindex(fname)\n", fp);
1249 fputs(" if fname[n-3:n] == \".bin\"\n", fp);
1250 fputs(" # binary mode\n", fp);
1251 fputs(" local cmplx::Bool\n", fp);
1252 fputs(" f = open(fname, \"r\")\n", fp);
1253 fputs(" hdr = read(f, 19)\n", fp);
1254 fputs(" if hdr == b\"gretl_binary_matrix\"\n", fp);
1255 fputs(" cmplx = 0\n", fp);
1256 fputs(" elseif hdr == b\"gretl_binar_cmatrix\"\n", fp);
1257 fputs(" cmplx = 1\n", fp);
1258 fputs(" else\n", fp);
1259 fputs(" error(\"Not a gretl binary matrix\")\n", fp);
1260 fputs(" end\n", fp);
1261 fputs(" r = ltoh(read(f, Int32))\n", fp);
1262 fputs(" c = ltoh(read(f, Int32))\n", fp);
1263 fputs(" if cmplx\n", fp);
1264 fputs(" r::Int64 = floor(r/2)\n", fp);
1265 fputs(" M = Array{Complex{Float64}, 2}(undef, r, c)\n", fp);
1266 fputs(" for j=1:c\n", fp);
1267 fputs(" for i=1:r\n", fp);
1268 fputs(" x = ltoh(read(f, Float64))\n", fp);
1269 fputs(" y = ltoh(read(f, Float64))\n", fp);
1270 fputs(" M[i,j] = x + y*im\n", fp);
1271 fputs(" end\n", fp);
1272 fputs(" end\n", fp);
1273 fputs(" else\n", fp);
1274 fputs(" M = Array{Float64, 2}(undef, r, c)\n", fp);
1275 fputs(" for j=1:c\n", fp);
1276 fputs(" for i=1:r\n", fp);
1277 fputs(" M[i,j] = ltoh(read(f, Float64))\n", fp);
1278 fputs(" end\n", fp);
1279 fputs(" end\n", fp);
1280 fputs(" end\n", fp);
1281 fputs(" close(f)\n", fp);
1282 fputs(" else\n", fp);
1283 fputs(" # text mode\n", fp);
1284 fputs(" M = readdlm(fname, skipstart=1)\n", fp);
1285 fputs(" end\n", fp);
1286 fputs(" M\n", fp);
1287 fputs("end\n\n", fp);
1288 }
1289
write_stata_io_file(FILE * fp,const char * ddir)1290 static void write_stata_io_file (FILE *fp, const char *ddir)
1291 {
1292 fputs("program define gretl_export\n", fp);
1293 /* not sure about req'd version, but see mat2txt.ado */
1294 fputs("version 8.2\n", fp);
1295 fputs("local matrix `1'\n", fp);
1296 fputs("local fname `2'\n", fp);
1297 fputs("tempname myfile\n", fp);
1298 fprintf(fp, "file open `myfile' using \"%s`fname'\", "
1299 "write text replace\n", ddir);
1300 fputs("local nrows = rowsof(`matrix')\n", fp);
1301 fputs("local ncols = colsof(`matrix')\n", fp);
1302 fputs("file write `myfile' %8.0g (`nrows') %8.0g (`ncols') _n\n", fp);
1303 fputs("forvalues r=1/`nrows' {\n", fp);
1304 fputs(" forvalues c=1/`ncols' {\n", fp);
1305 fputs(" file write `myfile' %15.0e (`matrix'[`r',`c']) _n\n", fp);
1306 fputs(" }\n", fp);
1307 fputs("}\n", fp);
1308 fputs("file close `myfile'\n", fp);
1309 fputs("end\n", fp);
1310 }
1311
ensure_foreign_io_file(int lang,const char * fname)1312 static int ensure_foreign_io_file (int lang, const char *fname)
1313 {
1314 FILE *fp = NULL;
1315 int err = 0;
1316
1317 if (fname != NULL) {
1318 fp = gretl_fopen(fname, "wb");
1319 } else {
1320 const char *iofile = get_io_filename(lang);
1321
1322 if (iofile == NULL) {
1323 return E_DATA;
1324 }
1325 if (dotfile_exists(iofile)) {
1326 /* already present */
1327 return 0;
1328 } else {
1329 fp = write_open_dotfile(iofile);
1330 }
1331 }
1332
1333 if (fp == NULL) {
1334 err = E_FOPEN;
1335 } else {
1336 const char *ddir = get_export_dotdir();
1337
1338 if (lang == LANG_PYTHON) {
1339 write_python_io_file(fp, ddir);
1340 } else if (lang == LANG_OCTAVE) {
1341 write_octave_io_file(fp, ddir);
1342 } else if (lang == LANG_JULIA) {
1343 write_julia_io_file(fp, ddir);
1344 } else if (lang == LANG_OX) {
1345 write_ox_io_file(fp, ddir);
1346 } else if (lang == LANG_STATA) {
1347 write_stata_io_file(fp, ddir);
1348 } else if (lang == LANG_R) {
1349 /* used only under --io-funcs */
1350 write_R_io_file(fp, ddir);
1351 }
1352
1353 fclose(fp);
1354 }
1355
1356 return err;
1357 }
1358
add_gretl_include(int lang,gretlopt opt,FILE * fp)1359 static void add_gretl_include (int lang, gretlopt opt, FILE *fp)
1360 {
1361 const char *ddir = get_export_dotdir();
1362
1363 if (lang == LANG_PYTHON) {
1364 fputs("from gretl_io import gretl_dotdir, gretl_loadmat, "
1365 "gretl_export\n", fp);
1366 return;
1367 }
1368
1369 #ifdef G_OS_WIN32
1370 if (lang == LANG_STATA) {
1371 /* or leave path with backslashes? */
1372 fprintf(fp, "quietly adopath + \"%s\"\n", ddir);
1373 return;
1374 }
1375 #endif
1376
1377 if (lang == LANG_OX) {
1378 if (strchr(ddir, ' ')) {
1379 fprintf(fp, "#include \"%sgretl_io.ox\"\n", ddir);
1380 } else {
1381 fprintf(fp, "#include <%sgretl_io.ox>\n", ddir);
1382 }
1383 } else if (lang == LANG_OCTAVE) {
1384 fprintf(fp, "source(\"%sgretl_io.m\")\n", ddir);
1385 } else if (lang == LANG_JULIA) {
1386 fprintf(fp, "include(\"%sgretl_io.jl\")\n", ddir);
1387 } else if (lang == LANG_STATA) {
1388 if (opt & OPT_Q) {
1389 fputs("set output error\n", fp);
1390 }
1391 fprintf(fp, "quietly adopath + \"%s\"\n", ddir);
1392 }
1393 }
1394
get_foreign_indent(void)1395 static int get_foreign_indent (void)
1396 {
1397 const char *s;
1398 int i, n, ret = 100;
1399
1400 for (i=0; i<foreign_n_lines; i++) {
1401 n = 0;
1402 s = foreign_lines[i];
1403 while (*s == ' ' || *s == '\t') {
1404 n++;
1405 s++;
1406 }
1407 if (n < ret) {
1408 ret = n;
1409 }
1410 }
1411
1412 return ret;
1413 }
1414
put_foreign_lines(FILE * fp)1415 static void put_foreign_lines (FILE *fp)
1416 {
1417 int i, n = get_foreign_indent();
1418
1419 for (i=0; i<foreign_n_lines; i++) {
1420 fprintf(fp, "%s\n", foreign_lines[i] + n);
1421 if (foreign_lang == LANG_OX) {
1422 if (strstr(foreign_lines[i], "oxstd.h")) {
1423 add_gretl_include(LANG_OX, 0, fp);
1424 }
1425 } else if (foreign_lang == LANG_OCTAVE) {
1426 if (strstr(foreign_lines[i], "dynare ") &&
1427 !strstr(foreign_lines[i], "noclearall")) {
1428 add_gretl_include(LANG_OCTAVE, 0, fp);
1429 }
1430 }
1431 }
1432 }
1433
put_foreign_buffer(const char * buf,FILE * fp)1434 static void put_foreign_buffer (const char *buf, FILE *fp)
1435 {
1436 char line[1024];
1437
1438 bufgets_init(buf);
1439
1440 while (bufgets(line, sizeof line, buf)) {
1441 fputs(line, fp);
1442 if (foreign_lang == LANG_OX) {
1443 if (strstr(line, "oxstd.h")) {
1444 add_gretl_include(LANG_OX, 0, fp);
1445 }
1446 } else if (foreign_lang == LANG_OCTAVE) {
1447 if (strstr(line, "dynare ") &&
1448 !strstr(line, "noclearall")) {
1449 add_gretl_include(LANG_OCTAVE, 0, fp);
1450 }
1451 }
1452 }
1453
1454 bufgets_finalize(buf);
1455 }
1456
no_data_check(const DATASET * dset)1457 static int no_data_check (const DATASET *dset)
1458 {
1459 if (dset == NULL || dset->n == 0 || dset->v == 0) {
1460 return E_NODATA;
1461 } else {
1462 return 0;
1463 }
1464 }
1465
get_send_data_list(int ci,const DATASET * dset,int * err)1466 static int *get_send_data_list (int ci, const DATASET *dset,
1467 int *err)
1468 {
1469 const char *dname = get_optval_string(ci, OPT_D);
1470 static int list1[2] = {1, 0};
1471 int *list = NULL;
1472
1473 if (dname != NULL) {
1474 list = get_list_by_name(dname);
1475 if (list != NULL) {
1476 int i;
1477
1478 for (i=1; i<=list[0] && !*err; i++) {
1479 if (list[i] < 0 || list[i] >= dset->v) {
1480 *err = E_DATA;
1481 }
1482 }
1483 } else {
1484 int vi = current_series_index(dset, dname);
1485
1486 if (vi >= 0) {
1487 list1[1] = vi;
1488 list = list1;
1489 } else {
1490 gretl_errmsg_sprintf(_("'%s': no such list"), dname);
1491 *err = E_DATA;
1492 }
1493 }
1494 }
1495
1496 return list;
1497 }
1498
1499 #ifdef HAVE_MPI
1500
mpi_send_data_setup(const DATASET * dset,FILE * fp)1501 static int mpi_send_data_setup (const DATASET *dset, FILE *fp)
1502 {
1503 int *list = NULL;
1504 size_t datasize;
1505 int nvars;
1506 gchar *fname;
1507 int err;
1508
1509 err = no_data_check(dset);
1510 if (err) {
1511 return err;
1512 }
1513
1514 list = get_send_data_list(MPI, dset, &err);
1515 if (err) {
1516 return err;
1517 }
1518
1519 if (list != NULL) {
1520 nvars = list[0];
1521 } else {
1522 nvars = dset->v;
1523 }
1524
1525 datasize = dset->n * nvars;
1526
1527 if (datasize > 10000) {
1528 /* write "big" data as binary? */
1529 fname = gretl_make_dotpath("mpi-data.gdtb");
1530 } else {
1531 fname = gretl_make_dotpath("mpi-data.gdt");
1532 }
1533
1534 err = gretl_write_gdt(fname, list, dset, OPT_NONE, 0);
1535
1536 if (!err) {
1537 /* here we're writing into the file to be run
1538 by gretlmpi */
1539 fprintf(fp, "open \"%s\" --quiet\n", fname);
1540 }
1541
1542 g_free(fname);
1543
1544 return err;
1545 }
1546
mpi_send_funcs_setup(FILE * fp)1547 static int mpi_send_funcs_setup (FILE *fp)
1548 {
1549 gchar *fname;
1550 int err;
1551
1552 fname = gretl_make_dotpath("mpi-funcs-tmp.xml");
1553 err = write_loaded_functions_file(fname, 1);
1554
1555 if (!err) {
1556 fprintf(fp, "include \"%s\"\n", fname);
1557 }
1558
1559 g_free(fname);
1560
1561 return err;
1562 }
1563
write_gretl_mpi_script(gretlopt opt,const DATASET * dset)1564 static int write_gretl_mpi_script (gretlopt opt, const DATASET *dset)
1565 {
1566 const gchar *fname = get_mpi_scriptname();
1567 FILE *fp = gretl_fopen(fname, "w");
1568 int err = 0;
1569
1570 if (fp == NULL) {
1571 return E_FOPEN;
1572 }
1573
1574 if (opt & OPT_D) {
1575 /* honor the --send-data option */
1576 err = mpi_send_data_setup(dset, fp);
1577 }
1578
1579 if (opt & OPT_F) {
1580 /* honor the --send-functions option */
1581 if (n_user_functions() > 0) {
1582 err = mpi_send_funcs_setup(fp);
1583 }
1584 }
1585
1586 #ifdef _OPENMP
1587 if (!err) {
1588 if (opt & OPT_T) {
1589 /* respect the --omp-threads option */
1590 int nt = get_optval_int(MPI, OPT_T, &err);
1591
1592 if (nt == -1) {
1593 ; /* unlimited/auto */
1594 } else {
1595 if (!err && (nt <= 0 || nt > 9999999)) {
1596 err = E_DATA;
1597 }
1598 if (!err) {
1599 fprintf(fp, "set omp_num_threads %d\n", nt);
1600 }
1601 }
1602 } else {
1603 /* by default, don't use OMP threading */
1604 fputs("set omp_num_threads 1\n", fp);
1605 }
1606 }
1607 #endif
1608
1609 if (!err) {
1610 /* put out the stored 'foreign' lines */
1611 put_foreign_lines(fp);
1612 #ifdef MPI_PIPES
1613 /* plus an easily recognized trailer */
1614 fputs("flush\n", fp);
1615 fputs("mpibarrier()\n", fp);
1616 fputs("if $mpirank == 0\n", fp);
1617 fputs(" print \"__GRETLMPI_EXIT__\"\n", fp);
1618 fputs("endif\n", fp);
1619 #endif
1620 }
1621
1622 fclose(fp);
1623
1624 return err;
1625 }
1626
1627 #endif /* HAVE_MPI */
1628
write_data_for_stata(const DATASET * dset,FILE * fp)1629 static int write_data_for_stata (const DATASET *dset,
1630 FILE *fp)
1631 {
1632 int *list = NULL;
1633 char save_na[8];
1634 int err;
1635
1636 err = no_data_check(dset);
1637 if (err) {
1638 return err;
1639 }
1640
1641 list = get_send_data_list(FOREIGN, dset, &err);
1642
1643 if (!err) {
1644 gchar *sdata;
1645
1646 *save_na = '\0';
1647 strncat(save_na, get_csv_na_write_string(), 7);
1648 set_csv_na_write_string(".");
1649 sdata = gretl_make_dotpath("stata.csv");
1650 err = write_data(sdata, list, dset, OPT_C, NULL);
1651 set_csv_na_write_string(save_na);
1652 g_free(sdata);
1653 }
1654
1655 if (err) {
1656 gretl_errmsg_sprintf("write_data_for_stata: failed with err = %d\n", err);
1657 } else {
1658 fputs("* load data from gretl\n", fp);
1659 fprintf(fp, "insheet using \"%sstata.csv\"\n", get_export_dotdir());
1660 }
1661
1662 return err;
1663 }
1664
1665 /* write out current dataset as an octave matrix, and, if this succeeds,
1666 write appropriate octave commands to @fp to source the data
1667 */
1668
write_data_for_octave(const DATASET * dset,FILE * fp)1669 static int write_data_for_octave (const DATASET *dset,
1670 FILE *fp)
1671 {
1672 int *list = NULL;
1673 int err;
1674
1675 err = no_data_check(dset);
1676 if (err) {
1677 return err;
1678 }
1679
1680 list = get_send_data_list(FOREIGN, dset, &err);
1681
1682 if (!err) {
1683 gchar *mdata = gretl_make_dotpath("mdata.tmp");
1684
1685 err = write_data(mdata, list, dset, OPT_M, NULL);
1686 g_free(mdata);
1687 }
1688
1689 if (err) {
1690 gretl_errmsg_sprintf("write_data_for_octave: failed with err = %d\n", err);
1691 } else {
1692 fputs("% load data from gretl\n", fp);
1693 fprintf(fp, "load '%smdata.tmp'\n", get_export_dotdir());
1694 }
1695
1696 return err;
1697 }
1698
put_dynare_script(const char * buf,FILE * fp)1699 static int put_dynare_script (const char *buf, FILE *fp)
1700 {
1701 gchar *dpath = gretl_make_dotpath("gretltmp.mod");
1702 FILE *fd;
1703 int err = 0;
1704
1705 fd = gretl_fopen(dpath, "w");
1706
1707 if (fd == NULL) {
1708 err = E_FOPEN;
1709 } else {
1710 fputs(buf, fd);
1711 fclose(fd);
1712 fputs("dynare gretltmp.mod noclearall\n", fp);
1713 }
1714
1715 g_free(dpath);
1716
1717 return err;
1718 }
1719
1720 /**
1721 * write_gretl_foreign_script:
1722 * @buf: text buffer containing foreign code: Ox, Octave, Stata,
1723 * Python or Julia; R is handled separately.
1724 * @lang: language identifier.
1725 * @opt: should contain %OPT_G for use from GUI.
1726 * @dset: pointer to dataset (or %NULL if no data are to be passed).
1727 * @pfname: location to receive name of file written, or %NULL.
1728 *
1729 * Writes the content of @buf into a file in the gretl user's
1730 * "dotdir".
1731 *
1732 * Returns: 0 on success, non-zero on error.
1733 */
1734
write_gretl_foreign_script(const char * buf,int lang,gretlopt opt,const DATASET * dset,const char ** pfname)1735 int write_gretl_foreign_script (const char *buf, int lang,
1736 gretlopt opt, const DATASET *dset,
1737 const char **pfname)
1738 {
1739 const gchar *fname = get_foreign_scriptpath(lang);
1740 FILE *fp = gretl_fopen(fname, "w");
1741 int err = 0;
1742
1743 ensure_foreign_io_file(lang, NULL);
1744
1745 if (fp == NULL) {
1746 err = E_FOPEN;
1747 } else {
1748 /* source the I-O functions? */
1749 if (lang != LANG_OX) {
1750 /* this comes later for Ox */
1751 add_gretl_include(lang, opt, fp);
1752 }
1753 if (dset != NULL && (opt & OPT_D)) {
1754 /* --send-data */
1755 if (lang == LANG_OCTAVE) {
1756 err = write_data_for_octave(dset, fp);
1757 } else if (lang == LANG_STATA) {
1758 err = write_data_for_stata(dset, fp);
1759 }
1760 }
1761 if (!err && buf != NULL) {
1762 /* pass on the material supplied in the @buf argument */
1763 if (lang == LANG_OCTAVE && (opt & OPT_Y)) {
1764 /* handle a dynare .mod file */
1765 err = put_dynare_script(buf, fp);
1766 } else {
1767 /* regular script */
1768 put_foreign_buffer(buf, fp);
1769 }
1770 } else if (!err) {
1771 /* put out the stored 'foreign' lines */
1772 put_foreign_lines(fp);
1773 }
1774 if (!err && pfname != NULL) {
1775 *pfname = fname;
1776 }
1777 }
1778
1779 if (fp != NULL) {
1780 fclose(fp);
1781 }
1782
1783 return err;
1784 }
1785
make_coded_vec(int * list,const DATASET * dset)1786 static gretl_matrix *make_coded_vec (int *list,
1787 const DATASET *dset)
1788 {
1789 gretl_matrix *coded = NULL;
1790 int free_list = 0;
1791 int i, nc = 0;
1792
1793 if (list == NULL) {
1794 list = full_var_list(dset, NULL);
1795 free_list = 1;
1796 }
1797
1798 if (list != NULL) {
1799 for (i=1; i<=list[0]; i++) {
1800 if (series_is_coded(dset, list[i])) {
1801 nc++;
1802 }
1803 }
1804 }
1805
1806 if (nc > 0) {
1807 coded = gretl_matrix_alloc(1, nc);
1808 if (coded != NULL) {
1809 int j = 0;
1810
1811 for (i=1; i<=list[0]; i++) {
1812 if (series_is_coded(dset, list[i])) {
1813 coded->val[j++] = i;
1814 }
1815 }
1816 }
1817 }
1818
1819 if (free_list) {
1820 free(list);
1821 }
1822
1823 return coded;
1824 }
1825
1826 /* write out current dataset in R format, and, if this succeeds,
1827 write appropriate R commands to @fp to source the data
1828 */
1829
write_data_for_R(const DATASET * dset,gretlopt opt,FILE * fp)1830 static int write_data_for_R (const DATASET *dset,
1831 gretlopt opt,
1832 FILE *fp)
1833 {
1834 gretl_matrix *coded = NULL;
1835 int *list = NULL;
1836 int ts, err;
1837
1838 err = no_data_check(dset);
1839 if (err) {
1840 return err;
1841 }
1842
1843 /* FIXME: can R's "ts" handle daily data, weekly data, etc.? */
1844 ts = annual_data(dset) || quarterly_or_monthly(dset);
1845
1846 list = get_send_data_list(FOREIGN, dset, &err);
1847
1848 if (!err) {
1849 gchar *Rdata = gretl_make_dotpath("Rdata.tmp");
1850
1851 coded = make_coded_vec(list, dset);
1852 err = write_data(Rdata, list, dset, OPT_R, NULL);
1853 g_free(Rdata);
1854 }
1855
1856 if (err) {
1857 gretl_errmsg_sprintf("write_data_for_R: failed with err = %d\n", err);
1858 gretl_matrix_free(coded);
1859 return err;
1860 }
1861
1862 if (coded != NULL) {
1863 gchar *tmp = gretl_make_dotpath("Rcoded.mat");
1864 int write_err;
1865
1866 /* ensure we don't load a stale file */
1867 gretl_remove(tmp);
1868 g_free(tmp);
1869 write_err = gretl_matrix_write_to_file(coded, "Rcoded.mat", 1);
1870 if (write_err) {
1871 gretl_matrix_free(coded);
1872 coded = NULL;
1873 }
1874 }
1875
1876 fputs("# load data from gretl\n", fp);
1877 fprintf(fp, "gretldata <- read.table(\"%sRdata.tmp\", header=TRUE)\n",
1878 get_export_dotdir());
1879
1880 if (ts) {
1881 char *p, datestr[OBSLEN];
1882 int subper = 1;
1883
1884 ntolabel(datestr, dset->t1, dset);
1885 p = strchr(datestr, ':');
1886 if (p != NULL) {
1887 subper = atoi(p + 1);
1888 }
1889
1890 if (opt & OPT_F) {
1891 /* treat as data frame (but set columns as "ts") */
1892 fputs("if (length(class(gretldata)) > 1) {m <- ncol(x)} else {m <- 1}\n", fp);
1893 fputs("for (i in 1:m) {\n", fp);
1894 fprintf(fp, " gretldata[,i] <- ts(gretldata[,i], start=c(%d, %d), "
1895 "frequency=%d)\n", atoi(datestr), subper, dset->pd);
1896 fputs("}\n", fp);
1897 fputs("attach(gretldata)\n", fp);
1898 } else {
1899 /* convert to "mts" (multiple time series object) */
1900 fprintf(fp, "gretldata <- ts(gretldata, start=c(%d, %d), frequency = %d)\n",
1901 atoi(datestr), subper, dset->pd);
1902 }
1903 } else {
1904 fputs("attach(gretldata)\n", fp);
1905 }
1906
1907 if (coded != NULL) {
1908 fputs("Coded <- gretl.loadmat(\"Rcoded.mat\")\n", fp);
1909 fputs("for (i in Coded) {gretldata[,i] <- as.factor(gretldata[,i])}\n", fp);
1910 }
1911
1912 gretl_matrix_free(coded);
1913
1914 if (opt & OPT_I) {
1915 /* let the (interactive) user see that this worked */
1916 if (ts) {
1917 fputs("gretlmsg <- \"current data loaded as ts object \\\"gretldata\\\"\\n\"\n", fp);
1918 } else {
1919 fputs("gretlmsg <- \"current data loaded as data frame \\\"gretldata\\\"\\n\"\n", fp);
1920 }
1921 fputs("cat(gretlmsg)\n", fp);
1922 }
1923
1924 return err;
1925 }
1926
1927 /* define an R function for passing data back to gretl */
1928
write_R_io_file(FILE * fp,const char * ddir)1929 static void write_R_io_file (FILE *fp, const char *ddir)
1930 {
1931 const char *export_body =
1932 " objname <- as.character(substitute(x))\n"
1933 " if (missing(sx)) {\n"
1934 " sx <- objname\n"
1935 " }\n"
1936 " if (is.ts(x)) {\n"
1937 " fname <- paste(prefix, sx, \".csv\", sep=\"\")\n"
1938 " dfx <- data.frame(x)\n"
1939 " if (ncol(dfx) == 1) {\n"
1940 " colnames(dfx) <- sx;\n"
1941 " }\n"
1942 " write.csv(dfx, file=fname, row.names=F)\n"
1943 " gretlmsg <- paste(\"wrote CSV data\", fname, \"\\n\")\n"
1944 " } else if (is.data.frame(x)) {\n"
1945 " fname <- paste(prefix, sx, \".csv\", sep=\"\")\n"
1946 " write.csv(x, file=fname, row.names=F)\n"
1947 " gretlmsg <- paste(\"wrote CSV data\", fname, \"\\n\")\n"
1948 " } else if (is.matrix(x)) {\n"
1949 " fname <- paste(prefix, sx, \".mat\", sep=\"\")\n"
1950 " write(dim(x), fname)\n"
1951 " write(format(t(x), digits=15), file=fname, ncolumns=ncol(x), append=TRUE)\n"
1952 " gretlmsg <- paste(\"wrote matrix\", fname, \"\\n\")\n"
1953 " } else {\n"
1954 " gretlmsg <- paste(\"gretl.export: don't know how to write object\", objname, "
1955 " \"(try as.matrix?)\\n\")\n"
1956 " }\n"
1957 " if (!quiet) {\n"
1958 " cat(gretlmsg)\n"
1959 " }\n"
1960 "}\n";
1961
1962 fprintf(fp, "gretl.dotdir <- \"%s\"\n", ddir);
1963
1964 #if 0
1965 fputs("is_abspath <- function(path) {\n", fp);
1966 fputs("grepl(\"^(/|[A-Za-z]:|\\\\\\\\|~)\", path)\n");
1967 fputs("}\n", fp);
1968 #endif
1969
1970 fputs("gretl.export <- function(x, sx, quiet=0) {\n", fp);
1971 fprintf(fp, " prefix <- \"%s\"\n", ddir);
1972 fputs(export_body, fp);
1973
1974 fputs("gretl.loadmat <- function(mname) {\n", fp);
1975 fprintf(fp, " prefix <- \"%s\"\n", ddir);
1976 fputs(" fname <- paste(prefix, mname, sep=\"\")\n", fp);
1977 fputs(" m <- as.matrix(read.table(fname, skip=1))\n", fp);
1978 fputs(" return(m)\n", fp);
1979 fputs("}\n", fp);
1980 }
1981
1982 /* basic content which can either go into gretl.Rsetup or into
1983 Rsrc for sourcing */
1984
put_R_setup_content(FILE * fp)1985 static void put_R_setup_content (FILE *fp)
1986 {
1987 fputs("vnum <- as.double(R.version$major) + (as.double(R.version$minor) / 10.0)\n",
1988 fp);
1989 fputs("if (vnum > 2.41) library(utils)\n", fp);
1990 fputs("library(stats)\n", fp);
1991 fputs("if (vnum <= 1.89) library(ts)\n", fp);
1992 write_R_io_file(fp, get_export_dotdir());
1993 }
1994
1995 /* Set up a gretl-specific R profile, and put notice of its existence
1996 into the environment. Used when exec'ing the R binary (only) */
1997
write_gretl_R_profile(gretlopt opt)1998 static int write_gretl_R_profile (gretlopt opt)
1999 {
2000 FILE *f1, *f2;
2001 int err = 0;
2002
2003 #if FDEBUG
2004 fprintf(stderr, "writing R profile: interactive = %d\n",
2005 (opt & OPT_I)? 1 : 0);
2006 #endif
2007
2008 /* On Windows we'll not use the environment-variable
2009 mechanism unless we're in interactive (async) mode
2010 */
2011
2012 #ifdef G_OS_WIN32
2013 if (opt & OPT_I) {
2014 err = gretl_setenv("R_PROFILE", gretl_Rprofile);
2015 if (err) {
2016 return err;
2017 }
2018 }
2019 #else
2020 err = gretl_setenv("R_PROFILE", gretl_Rprofile);
2021 if (err) {
2022 return err;
2023 }
2024 #endif
2025
2026 f1 = gretl_fopen(gretl_Rprofile, "w");
2027 f2 = gretl_fopen(gretl_Rsetup, "w");
2028
2029 if (f1 == NULL || f2 == NULL) {
2030 err = E_FOPEN;
2031 } else {
2032 fprintf(f1, "source(\"%s\")\n", gretl_Rsetup);
2033 fprintf(f1, "source(\"%s\", %s = TRUE)\n",
2034 gretl_Rsrc, (opt & OPT_V)? "echo" : "print.eval");
2035 fclose(f1);
2036 put_R_setup_content(f2);
2037 fclose(f2);
2038 }
2039
2040 #if FDEBUG
2041 fprintf(stderr, "writing R profile: returning %d\n", err);
2042 #endif
2043
2044 return err;
2045 }
2046
2047 /* Write an R command file to be sourced by R. @buf may contain R
2048 commands assembled via the GUI; if it is NULL the current "foreign"
2049 block (if any) is used as input.
2050
2051 @opt may contain the following:
2052
2053 OPT_I: indicates that we're in the context of an interactive R
2054 session.
2055
2056 OPT_D: indicates that the current gretl dataset should be sent
2057 to R.
2058
2059 OPT_G: we're being called via the gretl GUI.
2060
2061 OPT_L: indicates that the source file is intended for use
2062 via the R shared library.
2063 */
2064
write_R_source_file(const char * buf,const DATASET * dset,gretlopt opt)2065 static int write_R_source_file (const char *buf,
2066 const DATASET *dset,
2067 gretlopt opt)
2068 {
2069 FILE *fp = gretl_fopen(gretl_Rsrc, "w");
2070 int err = 0;
2071
2072 #if FDEBUG
2073 fprintf(stderr, "write R source file: interactive %d, library %d\n",
2074 (opt & OPT_I)? 1 : 0, (opt & OPT_L)? 1 : 0);
2075 #endif
2076
2077 if (fp == NULL) {
2078 err = E_FOPEN;
2079 } else {
2080 int sunk = 0;
2081
2082 #ifdef G_OS_WIN32
2083 if (!(opt & OPT_I) && !(opt & OPT_L)) {
2084 /* Windows, non-interactive, not using Rlib */
2085 fprintf(fp, "sink(\"%s\", type=\"output\")\n", gretl_Rout);
2086 fputs("if (sink.number(\"message\") == 2) {\n", fp);
2087 fprintf(fp, " errout <- file(\"%s\", open=\"wt\")\n", gretl_Rmsg);
2088 fputs(" sink(errout, type=\"message\")\n", fp);
2089 fputs("}\n", fp);
2090 sunk = 1;
2091 }
2092 #endif
2093
2094 if (opt & OPT_L) {
2095 /* we're using the R shared library */
2096 static int setup_done;
2097
2098 if (!setup_done) {
2099 #if FDEBUG
2100 fprintf(stderr, "Rlib: writing 'setup' material\n");
2101 #endif
2102 put_R_setup_content(fp);
2103 setup_done = 1;
2104 }
2105 fprintf(fp, "sink(\"%s\", type=\"output\")\n", gretl_Rout);
2106 if (!(opt & OPT_I)) {
2107 fputs("if (sink.number(\"message\") == 2) {\n", fp);
2108 fprintf(fp, " errout <- file(\"%s\", open=\"wt\")\n", gretl_Rmsg);
2109 fputs(" sink(errout, type=\"message\")\n", fp);
2110 fputs("}\n", fp);
2111 }
2112 sunk = 1;
2113 }
2114
2115 if (opt & OPT_D) {
2116 /* --send-data */
2117 err = write_data_for_R(dset, opt, fp);
2118 if (err) {
2119 fclose(fp);
2120 return err;
2121 }
2122 }
2123
2124 if (buf != NULL) {
2125 /* pass on the script supplied in @buf */
2126 fputs("# load script from gretl\n", fp);
2127 fputs(buf, fp);
2128 } else if (!(opt & OPT_G)) {
2129 /* non-GUI */
2130 put_foreign_lines(fp);
2131 }
2132
2133 if (sunk) {
2134 fputs("sink()\n", fp);
2135 }
2136
2137 fclose(fp);
2138 }
2139
2140 #if FDEBUG
2141 fprintf(stderr, "write R source file: returning %d\n", err);
2142 #endif
2143
2144 return err;
2145 }
2146
2147 /* Write files to be read by R: profile to be read on startup, and
2148 command source file. This is called when we're exec'ing the R
2149 binary. OPT_G in @opt indicates that this function is being called
2150 from the GUI program; @buf may contain R commands taken from a GUI
2151 window, or may be NULL.
2152 */
2153
write_gretl_R_files(const char * buf,const DATASET * dset,gretlopt opt)2154 int write_gretl_R_files (const char *buf,
2155 const DATASET *dset,
2156 gretlopt opt)
2157 {
2158 int err = 0;
2159
2160 #if FDEBUG
2161 fprintf(stderr, "write_gretl_R_files: starting\n");
2162 #endif
2163
2164 make_gretl_R_names();
2165
2166 /* write a temporary R profile so R knows what to do */
2167 err = write_gretl_R_profile(opt);
2168 if (err) {
2169 fprintf(stderr, "error writing gretl.Rprofile\n");
2170 }
2171
2172 if (!err) {
2173 /* write commands and/or data to file, to be sourced in R */
2174 err = write_R_source_file(buf, dset, opt);
2175 if (err) {
2176 fprintf(stderr, "error writing gretl's Rsrc\n");
2177 }
2178 }
2179
2180 #if FDEBUG
2181 fprintf(stderr, "write_gretl_R_files: returning %d\n", err);
2182 #endif
2183
2184 return err;
2185 }
2186
delete_gretl_R_files(void)2187 void delete_gretl_R_files (void)
2188 {
2189 #if FDEBUG
2190 fprintf(stderr, "deleting gretl R files...\n");
2191 #endif
2192
2193 if (gretl_Rprofile != NULL) {
2194 gretl_remove(gretl_Rprofile);
2195 }
2196 if (gretl_Rsrc != NULL) {
2197 gretl_remove(gretl_Rsrc);
2198 }
2199 }
2200
2201 #ifdef HAVE_MPI
2202
delete_mpi_script(void)2203 static void delete_mpi_script (void)
2204 {
2205 if (gretl_mpi_script != NULL) {
2206 gretl_remove(gretl_mpi_script);
2207 }
2208 }
2209
2210 #endif
2211
2212 /* The following code block is used if we're implementing
2213 gretl's R support by dlopening the R shared library
2214 (as opposed to executing the R binary).
2215 */
2216
2217 #ifdef USE_RLIB
2218
2219 static void *Rhandle; /* handle to the R library */
2220 static int Rlib_err; /* initialization error record */
2221 static int Rinit; /* are we initialized or not? */
2222
2223 static SEXP current_arg;
2224 static SEXP current_call;
2225
2226 /* pointers to, and renamed versions of, the R global variables
2227 we'll need */
2228
2229 SEXP *PR_GlobalEnv;
2230 SEXP *PR_NilValue;
2231 SEXP *PR_UnboundValue;
2232 SEXP *PR_NamesSymbol;
2233
2234 SEXP VR_GlobalEnv;
2235 SEXP VR_NilValue;
2236 SEXP VR_UnboundValue;
2237 SEXP VR_NamesSymbol;
2238
2239 /* renamed, pointerized versions of the R functions we need */
2240
2241 static double *(*R_REAL) (SEXP);
2242 static int *(*R_INT) (SEXP);
2243 static const char *(*R_STRING) (SEXP);
2244 static SEXP *(*R_STRING_PTR) (SEXP);
2245 static SEXP (*R_STRING_ELT) (SEXP, int);
2246
2247 static SEXP (*R_CDR) (SEXP);
2248 static SEXP (*R_allocList) (int);
2249 static SEXP (*R_allocMatrix) (SEXPTYPE, int, int);
2250 static SEXP (*R_allocVector) (SEXPTYPE, R_len_t);
2251 static SEXP (*R_findFun) (SEXP, SEXP);
2252 static SEXP (*R_findVar) (SEXP, SEXP);
2253 static SEXP (*R_SETCAR) (SEXP, SEXP);
2254 static SEXP (*R_protect) (SEXP);
2255 static SEXP (*R_ScalarReal) (double);
2256 static SEXP (*R_catch) (SEXP, SEXP, int *);
2257 static SEXP (*R_install) (const char *);
2258 static SEXP (*R_mkString) (const char *);
2259 static SEXP (*R_mkChar) (const char *);
2260 static SEXP (*R_mkNamed) (SEXPTYPE, const char **);
2261 static SEXP (*R_GetRowNames) (SEXP);
2262 static SEXP (*R_getAttrib) (SEXP, SEXP);
2263
2264 static Rboolean (*R_isMatrix) (SEXP);
2265 static Rboolean (*R_isVector) (SEXP);
2266 static Rboolean (*R_isLogical) (SEXP);
2267 static Rboolean (*R_isInteger) (SEXP);
2268 static Rboolean (*R_isReal) (SEXP);
2269 static Rboolean (*R_isString) (SEXP);
2270
2271 static int (*R_initEmbeddedR) (int, char **);
2272 static int (*R_ncols) (SEXP);
2273 static int (*R_nrows) (SEXP);
2274 static int (*R_TYPEOF) (SEXP);
2275 static int *(*R_LOGICAL) (SEXP);
2276
2277 static void (*R_endEmbeddedR) (int);
2278 static void (*R_unprotect) (int);
2279 static void (*R_PrintValue) (SEXP);
2280 static void (*R_SET_TYPEOF) (SEXP, int);
2281 static void (*R_SET_TAG) (SEXP, SEXP);
2282
2283 static SEXP (*R_VECTOR_ELT) (SEXP, int);
2284 static void (*R_SET_VECTOR_ELT) (SEXP, int, SEXP);
2285
2286 #ifdef WIN32
2287 static char *(*R_get_HOME) (void);
2288 #endif
2289
2290 /* utility function to cumulate errors from dlsym */
2291
dlget(void * handle,const char * name,int * err)2292 static void *dlget (void *handle, const char *name, int *err)
2293 {
2294 void *p = gretl_dlsym(handle, name);
2295
2296 if (p == NULL) {
2297 fprintf(stderr, "dlget: couldn't find '%s'\n", name);
2298 *err += 1;
2299 }
2300
2301 return p;
2302 }
2303
2304 /* dlopen the R library and grab all the symbols we need:
2305 several function pointers and a few global variables
2306 */
2307
load_R_symbols(void)2308 static int load_R_symbols (void)
2309 {
2310 const char *libpath = gretl_rlib_path();
2311 int err = 0;
2312
2313 #if FDEBUG
2314 fprintf(stderr, "Loading libR symbols from '%s'\n", libpath);
2315 #endif
2316
2317 Rhandle = gretl_dlopen(libpath, 1);
2318 if (Rhandle == NULL) {
2319 err = E_EXTERNAL;
2320 goto bailout;
2321 }
2322
2323 R_CDR = dlget(Rhandle, "CDR", &err);
2324 R_REAL = dlget(Rhandle, "REAL", &err);
2325 R_INT = dlget(Rhandle, "INTEGER", &err);
2326 R_STRING = dlget(Rhandle, "R_CHAR", &err);
2327 R_STRING_PTR = dlget(Rhandle, "STRING_PTR", &err);
2328 R_STRING_ELT = dlget(Rhandle, "STRING_ELT", &err);
2329 R_allocList = dlget(Rhandle, "Rf_allocList", &err);
2330 R_allocMatrix = dlget(Rhandle, "Rf_allocMatrix", &err);
2331 R_allocVector = dlget(Rhandle, "Rf_allocVector", &err);
2332 R_endEmbeddedR = dlget(Rhandle, "Rf_endEmbeddedR", &err);
2333 R_findFun = dlget(Rhandle, "Rf_findFun", &err);
2334 R_findVar = dlget(Rhandle, "Rf_findVar", &err);
2335 R_initEmbeddedR = dlget(Rhandle, "Rf_initEmbeddedR", &err);
2336 R_install = dlget(Rhandle, "Rf_install", &err);
2337 R_isMatrix = dlget(Rhandle, "Rf_isMatrix", &err);
2338 R_isVector = dlget(Rhandle, "Rf_isVector", &err);
2339 R_isLogical = dlget(Rhandle, "Rf_isLogical", &err);
2340 R_isInteger = dlget(Rhandle, "Rf_isInteger", &err);
2341 R_isReal = dlget(Rhandle, "Rf_isReal", &err);
2342 R_isString = dlget(Rhandle, "Rf_isString", &err);
2343 R_mkString = dlget(Rhandle, "Rf_mkString", &err);
2344 R_mkChar = dlget(Rhandle, "Rf_mkChar", &err);
2345 R_mkNamed = dlget(Rhandle, "Rf_mkNamed", &err);
2346 R_ncols = dlget(Rhandle, "Rf_ncols", &err);
2347 R_nrows = dlget(Rhandle, "Rf_nrows", &err);
2348 R_GetRowNames = dlget(Rhandle, "Rf_GetRowNames", &err);
2349 R_getAttrib = dlget(Rhandle, "Rf_getAttrib", &err);
2350 R_PrintValue = dlget(Rhandle, "Rf_PrintValue", &err);
2351 R_protect = dlget(Rhandle, "Rf_protect", &err);
2352 R_ScalarReal = dlget(Rhandle, "Rf_ScalarReal", &err);
2353 R_unprotect = dlget(Rhandle, "Rf_unprotect", &err);
2354 R_catch = dlget(Rhandle, "R_tryEval", &err);
2355 R_SETCAR = dlget(Rhandle, "SETCAR", &err);
2356 R_SET_TYPEOF = dlget(Rhandle, "SET_TYPEOF", &err);
2357 R_TYPEOF = dlget(Rhandle, "TYPEOF", &err);
2358 R_SET_TAG = dlget(Rhandle, "SET_TAG", &err);
2359 R_LOGICAL = dlget(Rhandle, "LOGICAL", &err);
2360 R_VECTOR_ELT = dlget(Rhandle, "VECTOR_ELT", &err);
2361 R_SET_VECTOR_ELT = dlget(Rhandle, "SET_VECTOR_ELT", &err);
2362
2363 #ifdef WIN32
2364 R_get_HOME = dlget(Rhandle, "get_R_HOME", &err);
2365 #endif
2366
2367 if (!err) {
2368 PR_GlobalEnv = (SEXP *) dlget(Rhandle, "R_GlobalEnv", &err);
2369 PR_NilValue = (SEXP *) dlget(Rhandle, "R_NilValue", &err);
2370 PR_UnboundValue = (SEXP *) dlget(Rhandle, "R_UnboundValue", &err);
2371 PR_NamesSymbol = (SEXP *) dlget(Rhandle, "R_NamesSymbol", &err);
2372 }
2373
2374 if (err) {
2375 close_plugin(Rhandle);
2376 Rhandle = NULL;
2377 err = E_EXTERNAL;
2378 }
2379
2380 bailout:
2381
2382 #if FDEBUG || defined(WIN32)
2383 fprintf(stderr, "load_R_symbols: returning %d\n", err);
2384 #endif
2385
2386 return err;
2387 }
2388
gretl_R_cleanup(void)2389 void gretl_R_cleanup (void)
2390 {
2391 #if FDEBUG
2392 fprintf(stderr, "gretl_R_cleanup: Rinit = %d\n", Rinit);
2393 #endif
2394
2395 if (Rinit) {
2396 R_endEmbeddedR(0);
2397 close_plugin(Rhandle);
2398 Rhandle = NULL;
2399 }
2400 }
2401
2402 /* called from gretl_paths.c on revising the Rlib path:
2403 allow for the possibility that the path was wrong but is
2404 now OK
2405 */
2406
gretl_R_reset_error(void)2407 void gretl_R_reset_error (void)
2408 {
2409 Rlib_err = 0;
2410 }
2411
2412 #ifdef WIN32
2413
2414 /* try to ensure that the directory holding the R
2415 DLL is in PATH
2416 */
2417
set_path_for_Rlib(const char * Rhome)2418 static void set_path_for_Rlib (const char *Rhome)
2419 {
2420 #ifdef _WIN64
2421 const char *arch = "x64";
2422 #else
2423 const char *arch = "i386";
2424 #endif
2425 char *oldpath = getenv("PATH");
2426 gchar *Rpath;
2427
2428 Rpath = g_strdup_printf("%s\\bin\\%s", Rhome, arch);
2429
2430 if (oldpath != NULL && strstr(oldpath, Rpath) != NULL) {
2431 ; /* nothing to be done */
2432 } else if (oldpath == NULL) {
2433 /* very unlikely, but... */
2434 gretl_setenv("PATH", Rpath);
2435 } else {
2436 gchar *modpath;
2437
2438 fprintf(stderr, "Adding '%s' to PATH\n", Rpath);
2439 modpath = g_strdup_printf("%s;%s", oldpath, Rpath);
2440 gretl_setenv("PATH", modpath);
2441 g_free(modpath);
2442 }
2443
2444 g_free(Rpath);
2445 }
2446
2447 #else /* !WIN32 */
2448
2449 /* non-Windows: attempt to remedy the absence of the
2450 R_HOME environment variable. We try to infer the
2451 required directory from take the path to libR.so and
2452 push it into the environment.
2453 */
2454
try_set_R_home(void)2455 static void try_set_R_home (void)
2456 {
2457 const char *libpath = gretl_rlib_path();
2458 char *s, *tmp;
2459
2460 tmp = gretl_strdup(libpath);
2461 s = strstr(tmp, "/lib/libR");
2462 if (s != NULL) {
2463 *s = '\0';
2464 gretl_setenv("R_HOME", tmp);
2465 }
2466 free(tmp);
2467 }
2468
2469 #endif /* WIN32 or not */
2470
2471 /* Initialize the R library for use with gretl. Note that we only
2472 need do this once per gretl session. We need to check that the
2473 environment is set to R's liking first, otherwise initialization
2474 will fail -- and will abort gretl too!
2475 */
2476
gretl_Rlib_init(void)2477 static int gretl_Rlib_init (void)
2478 {
2479 char *Rhome;
2480 int err = 0;
2481
2482 #if FDEBUG
2483 fprintf(stderr, "gretl_Rlib_init: starting\n");
2484 #endif
2485
2486 #ifndef WIN32
2487 Rhome = getenv("R_HOME");
2488 if (Rhome == NULL) {
2489 try_set_R_home();
2490 }
2491 #endif
2492
2493 err = load_R_symbols();
2494 if (err) {
2495 fprintf(stderr, "gretl_Rlib_init: failed to load R functions\n");
2496 goto bailout;
2497 }
2498
2499 #ifdef WIN32
2500 Rhome = R_get_HOME();
2501 fprintf(stderr, "R_get_HOME() gave '%s'\n", Rhome);
2502 if (Rhome == NULL) {
2503 fprintf(stderr, "To use Rlib, the variable R_HOME must be set\n");
2504 err = E_EXTERNAL;
2505 goto bailout;
2506 } else {
2507 set_path_for_Rlib(Rhome);
2508 }
2509 #endif
2510
2511 /* ensure common filenames are in place */
2512 make_gretl_R_names();
2513
2514 /* and ensure that gretl.Rprofile doesn't get in the way */
2515 gretl_remove(gretl_Rprofile);
2516
2517 if (!err) {
2518 char *argv[] = {
2519 "gretl",
2520 "--no-save",
2521 "--silent",
2522 };
2523 int ok, argc = 3;
2524
2525 #if FDEBUG
2526 fprintf(stderr, "calling R_initEmbeddedR\n");
2527 #endif
2528 ok = R_initEmbeddedR(argc, argv);
2529 if (ok) {
2530 VR_GlobalEnv = *PR_GlobalEnv;
2531 VR_NilValue = *PR_NilValue;
2532 VR_UnboundValue = *PR_UnboundValue;
2533 VR_NamesSymbol = *PR_NamesSymbol;
2534 Rinit = 1;
2535 } else {
2536 close_plugin(Rhandle);
2537 Rhandle = NULL;
2538 err = Rlib_err = E_EXTERNAL;
2539 }
2540 }
2541
2542 bailout:
2543
2544 #if FDEBUG
2545 fprintf(stderr, "gretl_Rlib_init: returning %d\n", err);
2546 #endif
2547
2548 return err;
2549 }
2550
2551 /* run R's source() function on an R command file written by
2552 gretl, shared library version */
2553
lib_run_Rlib_sync(gretlopt opt,PRN * prn)2554 static int lib_run_Rlib_sync (gretlopt opt, PRN *prn)
2555 {
2556 int err = 0;
2557
2558 #if FDEBUG
2559 fprintf(stderr, "lib_run_Rlib_sync: starting\n");
2560 #endif
2561
2562 if (!Rinit) {
2563 err = gretl_Rlib_init();
2564 }
2565
2566 if (!err) {
2567 SEXP expr, p;
2568
2569 /* make echo/print.eval argument */
2570 R_protect(p = R_allocVector(LGLSXP, 1));
2571 R_LOGICAL(p)[0] = TRUE;
2572
2573 /* expression source(f, print.eval=p) */
2574 R_protect(expr = R_allocVector(LANGSXP, 3));
2575 R_SETCAR(expr, R_install("source"));
2576 R_SETCAR(R_CDR(expr), R_mkString(gretl_Rsrc));
2577 R_SETCAR(R_CDR(R_CDR(expr)), p);
2578 R_SET_TAG(R_CDR(R_CDR(expr)),
2579 R_install((opt & OPT_V)? "echo" : "print.eval"));
2580
2581 R_catch(expr, NULL, &err);
2582 R_unprotect(2);
2583 }
2584
2585 if (prn != NULL) {
2586 const gchar *outname;
2587 FILE *fp;
2588
2589 outname = (err)? gretl_Rmsg : gretl_Rout;
2590 fp = gretl_fopen(outname, "r");
2591
2592 if (fp != NULL) {
2593 char line[512];
2594
2595 while (fgets(line, sizeof line, fp)) {
2596 #ifdef G_OS_WIN32
2597 win32_put_R_output_line(line, prn);
2598 #else
2599 pputs(prn, line);
2600 #endif
2601 }
2602 fclose(fp);
2603 gretl_remove(outname);
2604 }
2605 }
2606
2607 #if FDEBUG
2608 fprintf(stderr, "lib_run_Rlib_sync: returning %d\n", err);
2609 #endif
2610
2611 return (err)? E_EXTERNAL : 0;
2612 }
2613
find_R_function(const char * name)2614 static SEXP find_R_function (const char *name)
2615 {
2616 SEXP fun;
2617 SEXPTYPE t;
2618
2619 fun = R_findVar(R_install(name), VR_GlobalEnv);
2620 t = R_TYPEOF(fun);
2621
2622 if (t == PROMSXP) {
2623 /* eval promise if need be */
2624 int err = 1;
2625
2626 fun = R_catch(fun, VR_GlobalEnv, &err);
2627 if (!err) {
2628 t = R_TYPEOF(fun);
2629 }
2630 }
2631
2632 if (t != CLOSXP && t != BUILTINSXP && t != SPECIALSXP) {
2633 return VR_UnboundValue;
2634 }
2635
2636 return fun;
2637 }
2638
2639 /* Check if we should be using the R shared library for executing the
2640 code in a "foreign" block. This is disabled if the user has
2641 done "set R_lib off", and can be prohibited by the environment
2642 variable GRETL_NO_RLIB. It may also be blocked if we already tried
2643 and failed to initialize the library for gretl's use. (The
2644 fallback will be to call the R binary.)
2645 */
2646
gretl_use_Rlib(void)2647 static int gretl_use_Rlib (void)
2648 {
2649 int ret = 0;
2650
2651 #if FDEBUG
2652 fprintf(stderr, "gretl_use_Rlib: starting\n");
2653 #endif
2654
2655 if (!Rlib_err && libset_get_bool(R_LIB) && !getenv("GRETL_NO_RLIB")) {
2656 /* use of library is not blocked */
2657 if (Rinit) {
2658 /* already opened, fine */
2659 ret = 1;
2660 } else {
2661 /* try opening library */
2662 Rlib_err = gretl_Rlib_init();
2663 ret = !Rlib_err;
2664 }
2665 }
2666
2667 #if FDEBUG
2668 fprintf(stderr, "gretl_use_Rlib: using %s\n", (ret)? "library" : "executable");
2669 #endif
2670
2671 return ret;
2672 }
2673
2674 /* Used in "genr", to see if @name denotes an R function,
2675 either built-in or possibly user-defined. The lookup
2676 is conditional on the user's doing "set R_functions on".
2677 */
2678
get_R_function_by_name(const char * name)2679 int get_R_function_by_name (const char *name)
2680 {
2681 int ret = 0;
2682
2683 if (libset_get_bool(R_FUNCTIONS) && gretl_use_Rlib()) {
2684 SEXP fun = find_R_function(name);
2685
2686 ret = (fun == VR_UnboundValue)? 0 : 1;
2687 }
2688
2689 return ret;
2690 }
2691
2692 /* R_function_add... : these functions are used to convert
2693 from gretl types to R constructs for passing to R
2694 functions. Theye are called (indirectly) from geneval.c
2695 */
2696
R_function_add_scalar(double x)2697 static int R_function_add_scalar (double x)
2698 {
2699 R_SETCAR(current_arg, R_ScalarReal(x));
2700 return 0;
2701 }
2702
R_function_add_string(const char * s)2703 static int R_function_add_string (const char *s)
2704 {
2705 R_SETCAR(current_arg, R_mkString(s));
2706 return 0;
2707 }
2708
R_function_add_vector(const double * x,int t1,int t2)2709 static int R_function_add_vector (const double *x, int t1, int t2)
2710 {
2711 SEXP res = R_allocVector(REALSXP, t2 - t1 + 1);
2712 int i;
2713
2714 if (res == NULL) {
2715 return E_ALLOC;
2716 }
2717
2718 for (i=t1; i<=t2; i++) {
2719 R_REAL(res)[i-t1] = x[i];
2720 }
2721
2722 R_SETCAR(current_arg, res);
2723
2724 return 0;
2725 }
2726
R_function_add_factor(const DATASET * dset,int v)2727 static int R_function_add_factor (const DATASET *dset, int v)
2728 {
2729 SEXP res = R_allocVector(STRSXP, dset->t2 - dset->t1 + 1);
2730 const char *si;
2731 int i;
2732
2733 if (res == NULL) {
2734 return E_ALLOC;
2735 }
2736
2737 for (i=dset->t1; i<=dset->t2; i++) {
2738 si = series_get_string_for_obs(dset, v, i);
2739 if (si == NULL) {
2740 R_STRING_PTR(res)[i-dset->t1] = R_mkChar("");
2741 } else {
2742 R_STRING_PTR(res)[i-dset->t1] = R_mkChar(si);
2743 }
2744 }
2745
2746 R_SETCAR(current_arg, res);
2747
2748 return 0;
2749 }
2750
make_R_array(gretl_array * a,int * err)2751 static SEXP make_R_array (gretl_array *a, int *err)
2752 {
2753 GretlType t = gretl_array_get_type(a);
2754 int n = gretl_array_get_length(a);
2755 const char *si;
2756 SEXP as;
2757 int i;
2758
2759 if (t != GRETL_TYPE_STRINGS) {
2760 gretl_errmsg_set("Only strings arrays are accepted as R-function arguments");
2761 *err = E_TYPES;
2762 return NULL;
2763 }
2764
2765 as = R_allocVector(STRSXP, n);
2766 if (as == NULL) {
2767 *err = E_ALLOC;
2768 } else {
2769 for (i=0; i<n; i++) {
2770 si = gretl_array_get_data(a, i);
2771 R_STRING_PTR(as)[i] = R_mkChar(si);
2772 }
2773 }
2774
2775 return as;
2776 }
2777
make_R_matrix(const gretl_matrix * m,int * err)2778 static SEXP make_R_matrix (const gretl_matrix *m, int *err)
2779 {
2780 int nr = gretl_matrix_rows(m);
2781 int nc = gretl_matrix_cols(m);
2782 SEXP ms;
2783 int i, j;
2784
2785 ms = R_allocMatrix(REALSXP, nr, nc);
2786 if (ms == NULL) {
2787 *err = E_ALLOC;
2788 } else {
2789 for (i=0; i<nr; i++) {
2790 for (j=0; j<nc; j++) {
2791 R_REAL(ms)[i + j * nr] = gretl_matrix_get(m, i, j);
2792 }
2793 }
2794 }
2795
2796 return ms;
2797 }
2798
make_R_bundle(gretl_bundle * b,int * err)2799 static SEXP make_R_bundle (gretl_bundle *b, int *err)
2800 {
2801 GretlType type;
2802 int size;
2803 void *ptr;
2804 char **keys;
2805 SEXP res;
2806 int i, n;
2807
2808 if (gretl_bundle_get_n_members(b) == 0) {
2809 const char *nokeys[] = { "" };
2810
2811 return R_mkNamed(VECSXP, nokeys);
2812 }
2813
2814 keys = gretl_bundle_get_keys_raw(b, &n);
2815 if (keys == NULL) {
2816 *err = E_DATA;
2817 return NULL;
2818 }
2819
2820 keys[n] = ""; /* the termination wanted by R */
2821 res = R_mkNamed(VECSXP, (const char **) keys);
2822
2823 for (i=0; i<n && !*err; i++) {
2824 ptr = gretl_bundle_get_data(b, keys[i], &type, &size, err);
2825 if (*err) {
2826 break;
2827 }
2828 if (type == GRETL_TYPE_DOUBLE) {
2829 double x = *(double *) ptr;
2830
2831 R_SET_VECTOR_ELT(res, i, R_ScalarReal(x));
2832 } else if (type == GRETL_TYPE_STRING) {
2833 R_SET_VECTOR_ELT(res, i, R_mkString(ptr));
2834 } else if (type == GRETL_TYPE_MATRIX) {
2835 SEXP ms = make_R_matrix(ptr, err);
2836
2837 if (!*err) {
2838 R_SET_VECTOR_ELT(res, i, ms);
2839 }
2840 } else if (type == GRETL_TYPE_ARRAY) {
2841 SEXP as = make_R_array(ptr, err);
2842
2843 if (!*err) {
2844 R_SET_VECTOR_ELT(res, i, as);
2845 }
2846 } else if (type == GRETL_TYPE_BUNDLE) {
2847 SEXP bs = make_R_bundle(ptr, err);
2848
2849 if (!*err) {
2850 R_SET_VECTOR_ELT(res, i, bs);
2851 }
2852 } else {
2853 gretl_errmsg_sprintf("%s: not handled\n",
2854 gretl_type_get_name(type));
2855 *err = E_TYPES;
2856 }
2857 }
2858
2859 keys[n] = NULL;
2860 strings_array_free(keys, n);
2861
2862 return res;
2863 }
2864
R_function_add_object(void * ptr,GretlType t)2865 static int R_function_add_object (void *ptr, GretlType t)
2866 {
2867 SEXP res = NULL;
2868 int err = 0;
2869
2870 if (t == GRETL_TYPE_MATRIX) {
2871 res = make_R_matrix(ptr, &err);
2872 } else if (t == GRETL_TYPE_ARRAY) {
2873 res = make_R_array(ptr, &err);
2874 } else if (t == GRETL_TYPE_BUNDLE) {
2875 res = make_R_bundle(ptr, &err);
2876 } else {
2877 gretl_errmsg_sprintf("%s: not handled as R-function argument\n",
2878 gretl_type_get_name(t));
2879 err = E_TYPES;
2880 }
2881
2882 if (!err) {
2883 R_SETCAR(current_arg, res);
2884 }
2885
2886 return err;
2887 }
2888
2889 /* public because called from geneval.c */
2890
gretl_R_function_add_arg(void * ptr,GretlType type)2891 int gretl_R_function_add_arg (void *ptr, GretlType type)
2892 {
2893 int err;
2894
2895 current_arg = R_CDR(current_arg);
2896
2897 if (type == GRETL_TYPE_DOUBLE) {
2898 double x = *(double *) ptr;
2899
2900 err = R_function_add_scalar(x);
2901 } else if (type == GRETL_TYPE_STRING) {
2902 const char *s = ptr;
2903
2904 err = R_function_add_string(s);
2905 } else {
2906 /* matrix, array, bundle */
2907 err = R_function_add_object(ptr, type);
2908 }
2909
2910 return err;
2911 }
2912
2913 /* public because called from geneval.c */
2914
gretl_R_function_add_series(double * x,const DATASET * dset,int v)2915 int gretl_R_function_add_series (double *x, const DATASET *dset, int v)
2916 {
2917 int err;
2918
2919 current_arg = R_CDR(current_arg);
2920
2921 if (v > 0 && is_string_valued(dset, v)) {
2922 err = R_function_add_factor(dset, v);
2923 } else {
2924 err = R_function_add_vector(x, dset->t1, dset->t2);
2925 }
2926
2927 return err;
2928 }
2929
2930 /* called from geneval.c only, and should be pre-checked */
2931
gretl_R_get_call(const char * name,int argc)2932 int gretl_R_get_call (const char *name, int argc)
2933 {
2934 SEXP call, e;
2935
2936 call = R_findFun(R_install(name), VR_GlobalEnv);
2937
2938 if (call == VR_NilValue) {
2939 fprintf(stderr, "gretl_R_get_call: no definition for function %s\n",
2940 name);
2941 R_unprotect(1); /* is this OK? */
2942 return E_EXTERNAL;
2943 }
2944
2945 R_protect(e = R_allocList(argc + 1));
2946 R_SET_TYPEOF(e, LANGSXP);
2947 R_SETCAR(e, R_install(name));
2948 current_call = current_arg = e;
2949
2950 return 0;
2951 }
2952
numeric_ok(SEXP s)2953 static int numeric_ok (SEXP s)
2954 {
2955 return R_isReal(s) || R_isInteger(s) || R_isLogical(s);
2956 }
2957
2958 #define R_NULL(p) (p == NULL || (SEXP) p == VR_NilValue)
2959
2960 static GretlType R_type_to_gretl_type (SEXP s, const char *name, int *err);
2961 static void *object_from_R (SEXP res, const char *name, GretlType type,
2962 int *err);
2963
matrix_from_R(SEXP s,const char * name,int * err)2964 static gretl_matrix *matrix_from_R (SEXP s, const char *name,
2965 int *err)
2966 {
2967 gretl_matrix *m = NULL;
2968 int nr = R_nrows(s);
2969 int nc = R_ncols(s);
2970
2971 if (nr >= 0 && nc >= 0) {
2972 m = gretl_matrix_alloc(nr, nc);
2973 if (m == NULL) {
2974 *err = E_ALLOC;
2975 }
2976 } else {
2977 gretl_errmsg_sprintf("%s: invalid matrix dimensions, %d x %d",
2978 name, nr, nc);
2979 *err = E_DATA;
2980 }
2981
2982 if (m != NULL && nr > 0 && nc > 0) {
2983 int i, j;
2984
2985 for (i=0; i<nr; i++) {
2986 for (j=0; j<nc; j++) {
2987 if (R_isReal(s)) {
2988 gretl_matrix_set(m, i, j, R_REAL(s)[i + j * nr]);
2989 } else {
2990 gretl_matrix_set(m, i, j, R_INT(s)[i + j * nr]);
2991 }
2992 }
2993 }
2994 }
2995
2996 return m;
2997 }
2998
2999 /* at present only arrays of strings are handled */
3000
array_from_R(SEXP res,const char * name,int * err)3001 static gretl_array *array_from_R (SEXP res, const char *name,
3002 int *err)
3003 {
3004 gretl_array *a = NULL;
3005 int nr = R_nrows(res);
3006
3007 if (nr >= 0) {
3008 a = gretl_array_new(GRETL_TYPE_STRINGS, nr, err);
3009 } else {
3010 gretl_errmsg_sprintf("%s: invalid array length %d",
3011 name, nr);
3012 *err = E_DATA;
3013 }
3014 if (a != NULL && nr > 0) {
3015 const char *s;
3016 int i;
3017
3018 for (i=0; i<nr && !*err; i++) {
3019 s = R_STRING(R_STRING_PTR(res)[i]);
3020 *err = gretl_array_set_string(a, i, (char *) s, 1);
3021 }
3022 }
3023
3024 return a;
3025 }
3026
vector_can_be_bundle(SEXP s,const char * name)3027 static int vector_can_be_bundle (SEXP s, const char *name)
3028 {
3029 SEXP si, names;
3030 const char *key;
3031 GretlType gtype;
3032 int i, k;
3033 int err = 0;
3034
3035 if (R_TYPEOF(s) != VECSXP) {
3036 gretl_errmsg_sprintf("%s: not generic vector, can't make into bundle", name);
3037 return 0;
3038 }
3039
3040 k = R_nrows(s);
3041 if (k == 0) {
3042 /* empty bundle, should be OK */
3043 return 1;
3044 }
3045
3046 names = R_getAttrib(s, VR_NamesSymbol);
3047 if (R_NULL(names)) {
3048 gretl_errmsg_sprintf("%s: R list has no tags, can't make into bundle", name);
3049 return 0;
3050 }
3051
3052 for (i=0; i<k && !err; i++) {
3053 si = R_VECTOR_ELT(s, i);
3054 key = R_STRING(R_STRING_ELT(names, i));
3055 if (R_NULL(key)) {
3056 err = E_TYPES;
3057 break;
3058 }
3059 #if 0
3060 int rt = R_TYPEOF(si);
3061 fprintf(stderr, "element %d, R-type %d, key '%s'\n", i, rt, key);
3062 #endif
3063 gtype = R_type_to_gretl_type(si, key, &err);
3064 if (!err && gtype == GRETL_TYPE_NONE) {
3065 err = E_TYPES;
3066 }
3067 }
3068
3069 return err == 0;
3070 }
3071
bundle_from_R(SEXP s,int * err)3072 static gretl_bundle *bundle_from_R (SEXP s, int *err)
3073 {
3074 int i, k = R_nrows(s);
3075 SEXP si, names = R_getAttrib(s, VR_NamesSymbol);
3076 const char *key;
3077 GretlType type;
3078 void *ptr;
3079 gretl_bundle *b;
3080
3081 b = gretl_bundle_new();
3082 if (b == NULL) {
3083 *err = E_ALLOC;
3084 return NULL;
3085 }
3086
3087 for (i=0; i<k && !*err; i++) {
3088 si = R_VECTOR_ELT(s, i);
3089 key = R_STRING(R_STRING_ELT(names, i));
3090 type = R_type_to_gretl_type(si, key, err);
3091 if (!*err) {
3092 ptr = object_from_R(si, key, type, err);
3093 }
3094 if (!*err) {
3095 *err = gretl_bundle_set_data(b, key, ptr, type, 0);
3096 }
3097 }
3098
3099 if (*err) {
3100 gretl_bundle_destroy(b);
3101 b = NULL;
3102 }
3103
3104 return b;
3105 }
3106
object_from_R(SEXP res,const char * name,GretlType type,int * err)3107 static void *object_from_R (SEXP res, const char *name,
3108 GretlType type, int *err)
3109 {
3110 if (type == GRETL_TYPE_MATRIX) {
3111 return matrix_from_R(res, name, err);
3112 } else if (gretl_scalar_type(type)) {
3113 return R_REAL(res);
3114 } else if (type == GRETL_TYPE_STRING) {
3115 SEXP *rsp = R_STRING_PTR(res);
3116
3117 return (void *) R_STRING(*rsp);
3118 } else if (type == GRETL_TYPE_ARRAY) {
3119 return array_from_R(res, name, err);
3120 } else if (type == GRETL_TYPE_BUNDLE) {
3121 return bundle_from_R(res, err);
3122 } else if (type != GRETL_TYPE_NONE) {
3123 *err = E_TYPES;
3124 }
3125
3126 return NULL;
3127 }
3128
R_type_to_gretl_type(SEXP s,const char * name,int * err)3129 static GretlType R_type_to_gretl_type (SEXP s, const char *name, int *err)
3130 {
3131 GretlType t = GRETL_TYPE_NONE;
3132
3133 if (R_isMatrix(s)) {
3134 if (numeric_ok(s)) {
3135 t = GRETL_TYPE_MATRIX;
3136 } else {
3137 gretl_errmsg_sprintf("%s: got 'matrix' result, but not numeric", name);
3138 *err = E_TYPES;
3139 }
3140 } else if (R_isVector(s)) {
3141 if (numeric_ok(s)) {
3142 t = GRETL_TYPE_MATRIX;
3143 } else if (R_isString(s)) {
3144 if (R_nrows(s) == 1) {
3145 t = GRETL_TYPE_STRING;
3146 } else {
3147 t = GRETL_TYPE_ARRAY;
3148 }
3149 } else if (vector_can_be_bundle(s, name)) {
3150 t = GRETL_TYPE_BUNDLE;
3151 } else {
3152 *err = E_TYPES;
3153 }
3154 } else if (R_isLogical(s)) {
3155 t = GRETL_TYPE_BOOL;
3156 } else if (R_isInteger(s)) {
3157 t = GRETL_TYPE_INT;
3158 } else if (R_isReal(s)) {
3159 t = GRETL_TYPE_DOUBLE;
3160 } else if (R_isString(s)) {
3161 t = GRETL_TYPE_STRING;
3162 }
3163
3164 return t;
3165 }
3166
3167 /* execute an R function and try to convert the value returned
3168 into a gretl type
3169 */
3170
gretl_R_function_exec(const char * name,int * rtype,void ** ret)3171 int gretl_R_function_exec (const char *name, int *rtype, void **ret)
3172 {
3173 void *data = NULL;
3174 SEXP res;
3175 int err = 0;
3176
3177 if (gretl_messages_on()) {
3178 R_PrintValue(current_call);
3179 }
3180
3181 res = R_catch(current_call, VR_GlobalEnv, &err);
3182 if (err) {
3183 fprintf(stderr, "gretl_R_function_exec: R_catch failed on %s\n", name);
3184 return E_EXTERNAL;
3185 }
3186
3187 *rtype = R_type_to_gretl_type(res, name, &err);
3188
3189 #if FDEBUG
3190 printf("R return value: got type %d (%s)\n", *rtype,
3191 gretl_type_get_name(*rtype));
3192 printf("Calling R_PrintValue() on @res\n");
3193 R_PrintValue(res);
3194 #endif
3195
3196 if (err) {
3197 return err;
3198 }
3199
3200 data = object_from_R(res, name, *rtype, &err);
3201
3202 if (!err) {
3203 if (gretl_scalar_type(*rtype)) {
3204 double *dret = *ret;
3205
3206 *dret = *(double *) data;
3207 } else if (*rtype == GRETL_TYPE_STRING) {
3208 *ret = gretl_strdup(data);
3209 } else {
3210 /* matrix, array, bundle */
3211 *ret = data;
3212 }
3213 R_unprotect(1);
3214 }
3215
3216 return err;
3217 }
3218
run_R_lib(const char * buf,const DATASET * dset,gretlopt opt,PRN * prn)3219 static int run_R_lib (const char *buf,
3220 const DATASET *dset,
3221 gretlopt opt,
3222 PRN *prn)
3223 {
3224 int err;
3225
3226 #if FDEBUG
3227 fprintf(stderr, "run_R_lib\n");
3228 #endif
3229
3230 /* we don't want gretl.Rprofile in the way */
3231 gretl_remove(gretl_Rprofile);
3232
3233 /* by passing OPT_L below we indicate that we're
3234 using the library */
3235 err = write_R_source_file(buf, dset, opt | OPT_L);
3236 if (!err) {
3237 err = lib_run_Rlib_sync(opt, prn);
3238 }
3239
3240 return err;
3241 }
3242
3243 #endif /* USE_RLIB */
3244
3245 /**
3246 * foreign_start:
3247 * @ci: either FOREIGN or MPI.
3248 * @param: string specifying language, for FOREIGN.
3249 * @opt: may include %OPT_V for verbose operation.
3250 * @prn: struct for printing output.
3251 *
3252 * Starts a new "foreign" block if no such block is
3253 * currently defined.
3254 *
3255 * Returns: 0 on success, non-zero on error.
3256 */
3257
foreign_start(int ci,const char * param,gretlopt opt,PRN * prn)3258 int foreign_start (int ci, const char *param, gretlopt opt,
3259 PRN *prn)
3260 {
3261 int err = 0;
3262
3263 if (foreign_started) {
3264 gretl_errmsg_sprintf("%s: a block is already started",
3265 gretl_command_word(ci));
3266 return E_DATA;
3267 }
3268
3269 foreign_opt = OPT_NONE;
3270
3271 if (ci == FOREIGN) {
3272 if (param == NULL || *param == '\0') {
3273 err = E_ARGS;
3274 } else {
3275 char lang[16];
3276
3277 if (sscanf(param, "language=%15s", lang) == 1) {
3278 err = set_foreign_lang(lang, prn);
3279 } else {
3280 err = E_PARSE;
3281 }
3282 }
3283 } else if (ci == MPI) {
3284 err = set_foreign_lang("mpi", prn);
3285 }
3286
3287 if (!err) {
3288 foreign_started = 1;
3289 foreign_opt = opt;
3290 }
3291
3292 return err;
3293 }
3294
3295 /**
3296 * foreign_append:
3297 * @line: line to append.
3298 * @context: either FOREIGN or MPI.
3299 *
3300 * Appends @line to an internally stored block of "foreign"
3301 * or MPI commands, if such a block is currently defined.
3302 *
3303 * Returns: 0 on success, non-zero on error.
3304 */
3305
foreign_append(const char * line,int context)3306 int foreign_append (const char *line, int context)
3307 {
3308 int err = 0;
3309
3310 #if 0
3311 fprintf(stderr, "foreign_append: '%s'\n", line);
3312 #endif
3313
3314 if (!foreign_started) {
3315 gretl_errmsg_sprintf("%s: no block is in progress",
3316 gretl_command_word(context));
3317 err = E_DATA;
3318 } else if (!string_is_blank(line)) {
3319 err = strings_array_add(&foreign_lines, &foreign_n_lines, line);
3320 if (err) {
3321 foreign_destroy();
3322 }
3323 }
3324
3325 return err;
3326 }
3327
3328 /* write profile (perhaps) and Rsrc files */
3329
run_R_binary(const char * buf,const DATASET * dset,gretlopt opt,PRN * prn)3330 static int run_R_binary (const char *buf,
3331 const DATASET *dset,
3332 gretlopt opt,
3333 PRN *prn)
3334 {
3335 int err = write_gretl_R_files(buf, dset, opt);
3336
3337 if (err) {
3338 delete_gretl_R_files();
3339 } else {
3340 #ifdef G_OS_WIN32
3341 err = win32_lib_run_R_sync(opt, prn);
3342 #else
3343 err = lib_run_R_sync(opt, prn);
3344 #endif
3345 }
3346
3347 return err;
3348 }
3349
write_foreign_io_file(int lang,PRN * prn)3350 static int write_foreign_io_file (int lang, PRN *prn)
3351 {
3352 const char *fname;
3353 int err = 0;
3354
3355 fname = get_optval_string(FOREIGN, OPT_I);
3356 if (fname == NULL) {
3357 err = E_ARGS;
3358 } else {
3359 fname = gretl_maybe_switch_dir(fname);
3360 err = ensure_foreign_io_file(lang, fname);
3361 if (!err && gretl_messages_on()) {
3362 pprintf(prn, "Wrote '%s'\n", fname);
3363 }
3364 }
3365
3366 return err;
3367 }
3368
3369 #ifdef HAVE_MPI
3370
try_for_mpi_errmsg(PRN * prn)3371 static void try_for_mpi_errmsg (PRN *prn)
3372 {
3373 gchar *tmp = gretl_make_dotpath("mpi.fail");
3374 gchar *msg = NULL;
3375
3376 g_file_get_contents(tmp, &msg, NULL, NULL);
3377 if (msg != NULL) {
3378 pputs(prn, msg);
3379 g_free(msg);
3380 }
3381 gretl_remove(tmp);
3382 g_free(tmp);
3383 }
3384
3385 #endif
3386
3387 /**
3388 * foreign_execute:
3389 * @dset: dataset struct.
3390 * @opt: may include %OPT_V for verbose operation
3391 * @prn: struct for printing output.
3392 *
3393 * Executes a block of commands previously established via
3394 * calls to foreign_append_line().
3395 *
3396 * Returns: 0 on success, non-zero on error.
3397 */
3398
foreign_execute(const DATASET * dset,gretlopt opt,PRN * prn)3399 int foreign_execute (const DATASET *dset,
3400 gretlopt opt, PRN *prn)
3401 {
3402 #ifdef UNIX_MPI_IO
3403 static struct iodata io;
3404 void *ptr = &io;
3405 #else
3406 void *ptr = NULL;
3407 #endif
3408 int i, err = 0;
3409
3410 if (opt & OPT_I) {
3411 /* just write IO file */
3412 return write_foreign_io_file(foreign_lang, prn);
3413 }
3414
3415 if (foreign_lang == LANG_R) {
3416 make_gretl_R_names();
3417 }
3418
3419 if (opt & OPT_V) {
3420 /* verbose: echo the stored commands */
3421 for (i=0; i<foreign_n_lines; i++) {
3422 pprintf(prn, "> %s\n", foreign_lines[i]);
3423 }
3424 }
3425
3426 foreign_opt |= opt;
3427
3428 #ifdef HAVE_MPI
3429 if (foreign_lang == LANG_MPI) {
3430 err = write_gretl_mpi_script(foreign_opt, dset);
3431 if (err) {
3432 delete_mpi_script();
3433 } else {
3434 # ifdef G_OS_WIN32
3435 err = win32_lib_run_mpi_sync(foreign_opt, prn);
3436 # else
3437 err = lib_run_mpi_sync(foreign_opt, ptr, prn);
3438 # endif
3439 if (err) {
3440 try_for_mpi_errmsg(prn);
3441 }
3442 }
3443 foreign_destroy();
3444 return err; /* handled */
3445 }
3446 #endif /* HAVE_MPI */
3447
3448 if (foreign_lang == LANG_R) {
3449 #ifdef USE_RLIB
3450 if (gretl_use_Rlib()) {
3451 err = run_R_lib(NULL, dset, foreign_opt, prn);
3452 } else {
3453 err = run_R_binary(NULL, dset, foreign_opt, prn);
3454 }
3455 #else
3456 err = run_R_binary(NULL, dset, foreign_opt, prn);
3457 #endif
3458 foreign_destroy();
3459 return err; /* handled */
3460 }
3461
3462 err = write_gretl_foreign_script(NULL, foreign_lang,
3463 foreign_opt, dset, NULL);
3464
3465 if (err) {
3466 delete_foreign_script(foreign_lang);
3467 } else {
3468 #ifdef G_OS_WIN32
3469 err = win32_lib_run_other_sync(foreign_opt, prn);
3470 #else
3471 err = lib_run_other_sync(foreign_opt, prn);
3472 #endif
3473 }
3474
3475 foreign_destroy();
3476
3477 return err;
3478 }
3479
3480 /**
3481 * execute_R_buffer:
3482 * @buf: buffer containing commands.
3483 * @dset: dataset struct.
3484 * @opt: may include %OPT_D to send data from gretl.
3485 * @prn: struct for printing output.
3486 *
3487 * This is used only for MS Windows, working around
3488 * breakage in previously coded non-interactive calls to R
3489 * executable(s).
3490 *
3491 * Returns: 0 on success, non-zero on error.
3492 */
3493
execute_R_buffer(const char * buf,const DATASET * dset,gretlopt opt,PRN * prn)3494 int execute_R_buffer (const char *buf,
3495 const DATASET *dset,
3496 gretlopt opt,
3497 PRN *prn)
3498 {
3499 int err = 0;
3500
3501 make_gretl_R_names();
3502
3503 #ifdef USE_RLIB
3504 if (gretl_use_Rlib()) {
3505 err = run_R_lib(buf, dset, opt, prn);
3506 } else {
3507 err = run_R_binary(buf, dset, opt, prn);
3508 }
3509 #else
3510 err = run_R_binary(buf, dset, opt, prn);
3511 #endif
3512
3513
3514 return err;
3515 }
3516