1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
4 * Copyright (C) 1998-2021 The R Core Team
5 * Copyright (C) 2002-2005 The R Foundation
6 *
7 * This program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 2 of the License, or
10 * (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, a copy is available at
19 * https://www.R-project.org/Licenses/
20 */
21
22 #ifdef HAVE_CONFIG_H
23 #include <config.h>
24 #endif
25
26 #include <math.h> /* avoid redefinition of extern in Defn.h */
27 #include <float.h>
28 #include <ctype.h>
29 #include <stdlib.h>
30 #include <string.h>
31
32 #define __MAIN__
33 #define R_USE_SIGNALS 1
34 #include "Defn.h"
35 #include <Internal.h>
36 #include "Rinterface.h"
37 #include "IOStuff.h"
38 #include "Fileio.h"
39 #include "Parse.h"
40 #include "Startup.h"
41
42 #include <locale.h>
43 #include <R_ext/Print.h>
44
45 #ifdef ENABLE_NLS
nl_Rdummy(void)46 void attribute_hidden nl_Rdummy(void)
47 {
48 /* force this in as packages use it */
49 dgettext("R", "dummy - do not translate");
50 }
51 #endif
52
53
54 /* The 'real' main() program is in Rmain.c on Unix-alikes, and
55 src/gnuwin/front-ends/graphappmain.c on Windows, unless of course
56 R is embedded */
57
58 /* Global Variables: For convenience, all interpeter global symbols
59 * ================ are declared in Defn.h as extern -- and defined here.
60 *
61 * NOTE: This is done by using some preprocessor trickery. If __MAIN__
62 * is defined as above, there is a sneaky
63 * #define extern
64 * so that the same code produces both declarations and definitions.
65 *
66 * This does not include user interface symbols which are included
67 * in separate platform dependent modules.
68 */
69
70 void Rf_callToplevelHandlers(SEXP expr, SEXP value, Rboolean succeeded,
71 Rboolean visible);
72
73 static int ParseBrowser(SEXP, SEXP);
74
75
76 /* Read-Eval-Print Loop [ =: REPL = repl ] with input from a file */
77
R_ReplFile(FILE * fp,SEXP rho)78 static void R_ReplFile(FILE *fp, SEXP rho)
79 {
80 ParseStatus status;
81 int count=0;
82 int savestack;
83 RCNTXT cntxt;
84
85 R_InitSrcRefState(&cntxt);
86 savestack = R_PPStackTop;
87 for(;;) {
88 R_PPStackTop = savestack;
89 R_CurrentExpr = R_Parse1File(fp, 1, &status);
90 switch (status) {
91 case PARSE_NULL:
92 break;
93 case PARSE_OK:
94 R_Visible = FALSE;
95 R_EvalDepth = 0;
96 resetTimeLimits();
97 count++;
98 PROTECT(R_CurrentExpr);
99 R_CurrentExpr = eval(R_CurrentExpr, rho);
100 SET_SYMVALUE(R_LastvalueSymbol, R_CurrentExpr);
101 UNPROTECT(1);
102 if (R_Visible)
103 PrintValueEnv(R_CurrentExpr, rho);
104 if( R_CollectWarnings )
105 PrintWarnings();
106 break;
107 case PARSE_ERROR:
108 R_FinalizeSrcRefState();
109 parseError(R_NilValue, R_ParseError);
110 break;
111 case PARSE_EOF:
112 endcontext(&cntxt);
113 R_FinalizeSrcRefState();
114 return;
115 break;
116 case PARSE_INCOMPLETE:
117 /* can't happen: just here to quieten -Wall */
118 break;
119 }
120 }
121 }
122
123 /* Read-Eval-Print loop with interactive input */
124 static int prompt_type;
125 static char BrowsePrompt[20];
126
R_PromptString(int browselevel,int type)127 static const char *R_PromptString(int browselevel, int type)
128 {
129 if (R_NoEcho) {
130 BrowsePrompt[0] = '\0';
131 return BrowsePrompt;
132 }
133 else {
134 if(type == 1) {
135 if(browselevel) {
136 snprintf(BrowsePrompt, 20, "Browse[%d]> ", browselevel);
137 return BrowsePrompt;
138 }
139 return CHAR(STRING_ELT(GetOption1(install("prompt")), 0));
140 }
141 else {
142 return CHAR(STRING_ELT(GetOption1(install("continue")), 0));
143 }
144 }
145 }
146
147 /*
148 This is a reorganization of the REPL (Read-Eval-Print Loop) to separate
149 the loop from the actions of the body. The motivation is to make the iteration
150 code (Rf_ReplIteration) available as a separately callable routine
151 to avoid cutting and pasting it when one wants a single iteration
152 of the loop. This is needed as we allow different implementations
153 of event loops. Currently (summer 2002), we have a package in
154 preparation that uses Rf_ReplIteration within either the
155 Tcl or Gtk event loop and allows either (or both) loops to
156 be used as a replacement for R's loop and take over the event
157 handling for the R process.
158
159 The modifications here are intended to leave the semantics of the REPL
160 unchanged, just separate into routines. So the variables that maintain
161 the state across iterations of the loop are organized into a structure
162 and passed to Rf_ReplIteration() from Rf_ReplConsole().
163 */
164
165
166 /**
167 (local) Structure for maintaining and exchanging the state between
168 Rf_ReplConsole and its worker routine Rf_ReplIteration which is the
169 implementation of the body of the REPL.
170
171 In the future, we may need to make this accessible to packages
172 and so put it into one of the public R header files.
173 */
174 typedef struct {
175 ParseStatus status;
176 int prompt_type;
177 int browselevel;
178 unsigned char buf[CONSOLE_BUFFER_SIZE+1];
179 unsigned char *bufp;
180 } R_ReplState;
181
182
183 /**
184 This is the body of the REPL.
185 It attempts to parse the first line or expression of its input,
186 and optionally request input from the user if none is available.
187 If the input can be parsed correctly,
188 i) the resulting expression is evaluated,
189 ii) the result assigned to .Last.Value,
190 iii) top-level task handlers are invoked.
191
192 If the input cannot be parsed, i.e. there is a syntax error,
193 it is incomplete, or we encounter an end-of-file, then we
194 change the prompt accordingly.
195
196 The "cursor" for the input buffer is moved to the next starting
197 point, i.e. the end of the first line or after the first ;.
198 */
199 int
Rf_ReplIteration(SEXP rho,int savestack,int browselevel,R_ReplState * state)200 Rf_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state)
201 {
202 int c, browsevalue;
203 SEXP value, thisExpr;
204 Rboolean wasDisplayed = FALSE;
205
206 /* clear warnings that might have accumulated during a jump to top level */
207 if (R_CollectWarnings)
208 PrintWarnings();
209
210 if(!*state->bufp) {
211 R_Busy(0);
212 if (R_ReadConsole(R_PromptString(browselevel, state->prompt_type),
213 state->buf, CONSOLE_BUFFER_SIZE, 1) == 0)
214 return(-1);
215 state->bufp = state->buf;
216 }
217 #ifdef SHELL_ESCAPE /* not default */
218 if (*state->bufp == '!') {
219 R_system(&(state->buf[1]));
220 state->buf[0] = '\0';
221 return(0);
222 }
223 #endif /* SHELL_ESCAPE */
224 while((c = *state->bufp++)) {
225 R_IoBufferPutc(c, &R_ConsoleIob);
226 if(c == ';' || c == '\n') break;
227 }
228
229 R_PPStackTop = savestack;
230 R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &state->status);
231
232 switch(state->status) {
233
234 case PARSE_NULL:
235
236 /* The intention here is to break on CR but not on other
237 null statements: see PR#9063 */
238 if (browselevel && !R_DisableNLinBrowser
239 && !strcmp((char *) state->buf, "\n")) return -1;
240 R_IoBufferWriteReset(&R_ConsoleIob);
241 state->prompt_type = 1;
242 return 1;
243
244 case PARSE_OK:
245
246 R_IoBufferReadReset(&R_ConsoleIob);
247 R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &state->status);
248 if (browselevel) {
249 browsevalue = ParseBrowser(R_CurrentExpr, rho);
250 if(browsevalue == 1) return -1;
251 if(browsevalue == 2) {
252 R_IoBufferWriteReset(&R_ConsoleIob);
253 return 0;
254 }
255 /* PR#15770 We don't want to step into expressions entered at the debug prompt.
256 The 'S' will be changed back to 's' after the next eval. */
257 if (R_BrowserLastCommand == 's') R_BrowserLastCommand = 'S';
258 }
259 R_Visible = FALSE;
260 R_EvalDepth = 0;
261 resetTimeLimits();
262 PROTECT(thisExpr = R_CurrentExpr);
263 R_Busy(1);
264 PROTECT(value = eval(thisExpr, rho));
265 SET_SYMVALUE(R_LastvalueSymbol, value);
266 if (NO_REFERENCES(value))
267 INCREMENT_REFCNT(value);
268 wasDisplayed = R_Visible;
269 if (R_Visible)
270 PrintValueEnv(value, rho);
271 if (R_CollectWarnings)
272 PrintWarnings();
273 Rf_callToplevelHandlers(thisExpr, value, TRUE, wasDisplayed);
274 R_CurrentExpr = value; /* Necessary? Doubt it. */
275 UNPROTECT(2); /* thisExpr, value */
276 if (R_BrowserLastCommand == 'S') R_BrowserLastCommand = 's';
277 R_IoBufferWriteReset(&R_ConsoleIob);
278 state->prompt_type = 1;
279 return(1);
280
281 case PARSE_ERROR:
282
283 state->prompt_type = 1;
284 parseError(R_NilValue, 0);
285 R_IoBufferWriteReset(&R_ConsoleIob);
286 return(1);
287
288 case PARSE_INCOMPLETE:
289
290 R_IoBufferReadReset(&R_ConsoleIob);
291 state->prompt_type = 2;
292 return(2);
293
294 case PARSE_EOF:
295
296 return(-1);
297 break;
298 }
299
300 return(0);
301 }
302
R_ReplConsole(SEXP rho,int savestack,int browselevel)303 static void R_ReplConsole(SEXP rho, int savestack, int browselevel)
304 {
305 int status;
306 R_ReplState state = { PARSE_NULL, 1, 0, "", NULL};
307
308 R_IoBufferWriteReset(&R_ConsoleIob);
309 state.buf[0] = '\0';
310 state.buf[CONSOLE_BUFFER_SIZE] = '\0';
311 /* stopgap measure if line > CONSOLE_BUFFER_SIZE chars */
312 state.bufp = state.buf;
313 if(R_Verbose)
314 REprintf(" >R_ReplConsole(): before \"for(;;)\" {main.c}\n");
315 for(;;) {
316 status = Rf_ReplIteration(rho, savestack, browselevel, &state);
317 if(status < 0) {
318 if (state.status == PARSE_INCOMPLETE)
319 error(_("unexpected end of input"));
320 return;
321 }
322 }
323 }
324
325
326 static unsigned char DLLbuf[CONSOLE_BUFFER_SIZE+1], *DLLbufp;
327
check_session_exit()328 static void check_session_exit()
329 {
330 if (! R_Interactive) {
331 /* This funtion will be called again after a LONGJMP if an
332 error is signaled from one of the functions called. The
333 'exiting' variable identifies this and results in
334 R_Suicide. */
335 static Rboolean exiting = FALSE;
336 if (exiting)
337 R_Suicide(_("error during cleanup\n"));
338 else {
339 exiting = TRUE;
340 if (GetOption1(install("error")) != R_NilValue) {
341 exiting = FALSE;
342 return;
343 }
344 REprintf(_("Execution halted\n"));
345 R_CleanUp(SA_NOSAVE, 1, 0); /* quit, no save, no .Last, status=1 */
346 }
347
348 }
349 }
350
R_ReplDLLinit(void)351 void R_ReplDLLinit(void)
352 {
353 if (SETJMP(R_Toplevel.cjmpbuf))
354 check_session_exit();
355 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
356 R_IoBufferWriteReset(&R_ConsoleIob);
357 prompt_type = 1;
358 DLLbuf[0] = DLLbuf[CONSOLE_BUFFER_SIZE] = '\0';
359 DLLbufp = DLLbuf;
360 }
361
362 /* FIXME: this should be re-written to use Rf_ReplIteration
363 since it gets out of sync with it over time */
R_ReplDLLdo1(void)364 int R_ReplDLLdo1(void)
365 {
366 int c;
367 ParseStatus status;
368 SEXP rho = R_GlobalEnv, lastExpr;
369 Rboolean wasDisplayed = FALSE;
370
371 if(!*DLLbufp) {
372 R_Busy(0);
373 if (R_ReadConsole(R_PromptString(0, prompt_type), DLLbuf,
374 CONSOLE_BUFFER_SIZE, 1) == 0)
375 return -1;
376 DLLbufp = DLLbuf;
377 }
378 while((c = *DLLbufp++)) {
379 R_IoBufferPutc(c, &R_ConsoleIob);
380 if(c == ';' || c == '\n') break;
381 }
382 R_PPStackTop = 0;
383 R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &status);
384
385 switch(status) {
386 case PARSE_NULL:
387 R_IoBufferWriteReset(&R_ConsoleIob);
388 prompt_type = 1;
389 break;
390 case PARSE_OK:
391 R_IoBufferReadReset(&R_ConsoleIob);
392 R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &status);
393 R_Visible = FALSE;
394 R_EvalDepth = 0;
395 resetTimeLimits();
396 PROTECT(R_CurrentExpr);
397 R_Busy(1);
398 lastExpr = R_CurrentExpr;
399 R_CurrentExpr = eval(R_CurrentExpr, rho);
400 SET_SYMVALUE(R_LastvalueSymbol, R_CurrentExpr);
401 wasDisplayed = R_Visible;
402 if (R_Visible)
403 PrintValueEnv(R_CurrentExpr, rho);
404 if (R_CollectWarnings)
405 PrintWarnings();
406 Rf_callToplevelHandlers(lastExpr, R_CurrentExpr, TRUE, wasDisplayed);
407 UNPROTECT(1);
408 R_IoBufferWriteReset(&R_ConsoleIob);
409 R_Busy(0);
410 prompt_type = 1;
411 break;
412 case PARSE_ERROR:
413 parseError(R_NilValue, 0);
414 R_IoBufferWriteReset(&R_ConsoleIob);
415 prompt_type = 1;
416 break;
417 case PARSE_INCOMPLETE:
418 R_IoBufferReadReset(&R_ConsoleIob);
419 prompt_type = 2;
420 break;
421 case PARSE_EOF:
422 return -1;
423 break;
424 }
425 return prompt_type;
426 }
427
428 /* Main Loop: It is assumed that at this point that operating system */
429 /* specific tasks (dialog window creation etc) have been performed. */
430 /* We can now print a greeting, run the .First function and then enter */
431 /* the read-eval-print loop. */
432
handleInterrupt(int dummy)433 static void handleInterrupt(int dummy)
434 {
435 R_interrupts_pending = 1;
436 signal(SIGINT, handleInterrupt);
437 }
438
439 /* this flag is set if R internal code is using send() and does not
440 want to trigger an error on SIGPIPE (e.g., the httpd code).
441 [It is safer and more portable than other methods of handling
442 broken pipes on send().]
443 */
444
445 #ifndef Win32
446 // controlled by the internal http server in the internet module
447 int R_ignore_SIGPIPE = 0;
448
handlePipe(int dummy)449 static void handlePipe(int dummy)
450 {
451 signal(SIGPIPE, handlePipe);
452 if (!R_ignore_SIGPIPE) error("ignoring SIGPIPE signal");
453 }
454 #endif
455
456
457 #ifdef Win32
458 static int num_caught = 0;
459
win32_segv(int signum)460 static void win32_segv(int signum)
461 {
462 /* NB: stack overflow is not an access violation on Win32 */
463 { /* A simple customized print of the traceback */
464 SEXP trace, p, q;
465 int line = 1, i;
466 PROTECT(trace = R_GetTraceback(0));
467 if(trace != R_NilValue) {
468 REprintf("\nTraceback:\n");
469 for(p = trace; p != R_NilValue; p = CDR(p), line++) {
470 q = CAR(p); /* a character vector */
471 REprintf("%2d: ", line);
472 for(i = 0; i < LENGTH(q); i++)
473 REprintf("%s", CHAR(STRING_ELT(q, i)));
474 REprintf("\n");
475 }
476 UNPROTECT(1);
477 }
478 }
479 num_caught++;
480 if(num_caught < 10) signal(signum, win32_segv);
481 if(signum == SIGILL)
482 error("caught access violation - continue with care");
483 else
484 error("caught access violation - continue with care");
485 }
486 #endif
487
488 #if defined(HAVE_SIGALTSTACK) && defined(HAVE_SIGACTION) && defined(HAVE_WORKING_SIGACTION) && defined(HAVE_SIGEMPTYSET)
489
490 /* NB: this really isn't safe, but suffices for experimentation for now.
491 In due course just set a flag and do this after the return. OTOH,
492 if we do want to bail out with a core dump, need to do that here.
493
494 2005-12-17 BDR */
495
496 static unsigned char ConsoleBuf[CONSOLE_BUFFER_SIZE];
497
sigactionSegv(int signum,siginfo_t * ip,void * context)498 static void sigactionSegv(int signum, siginfo_t *ip, void *context)
499 {
500 char *s;
501
502 /* First check for stack overflow if we know the stack position.
503 We assume anything within 16Mb beyond the stack end is a stack overflow.
504 */
505 if(signum == SIGSEGV && (ip != (siginfo_t *)0) &&
506 (intptr_t) R_CStackStart != -1) {
507 uintptr_t addr = (uintptr_t) ip->si_addr;
508 intptr_t diff = (R_CStackDir > 0) ? R_CStackStart - addr:
509 addr - R_CStackStart;
510 uintptr_t upper = 0x1000000; /* 16Mb */
511 if((intptr_t) R_CStackLimit != -1) upper += R_CStackLimit;
512 if(diff > 0 && diff < upper) {
513 REprintf(_("Error: segfault from C stack overflow\n"));
514 #if defined(linux) || defined(__linux__) || defined(__sun) || defined(sun)
515 sigset_t ss;
516 sigaddset(&ss, signum);
517 sigprocmask(SIG_UNBLOCK, &ss, NULL);
518 #endif
519 jump_to_toplevel();
520 }
521 }
522
523 /* need to take off stack checking as stack base has changed */
524 R_CStackLimit = (uintptr_t)-1;
525
526 /* Do not translate these messages */
527 REprintf("\n *** caught %s ***\n",
528 signum == SIGILL ? "illegal operation" :
529 signum == SIGBUS ? "bus error" : "segfault");
530 if(ip != (siginfo_t *)0) {
531 if(signum == SIGILL) {
532
533 switch(ip->si_code) {
534 #ifdef ILL_ILLOPC
535 case ILL_ILLOPC:
536 s = "illegal opcode";
537 break;
538 #endif
539 #ifdef ILL_ILLOPN
540 case ILL_ILLOPN:
541 s = "illegal operand";
542 break;
543 #endif
544 #ifdef ILL_ILLADR
545 case ILL_ILLADR:
546 s = "illegal addressing mode";
547 break;
548 #endif
549 #ifdef ILL_ILLTRP
550 case ILL_ILLTRP:
551 s = "illegal trap";
552 break;
553 #endif
554 #ifdef ILL_COPROC
555 case ILL_COPROC:
556 s = "coprocessor error";
557 break;
558 #endif
559 default:
560 s = "unknown";
561 break;
562 }
563 } else if(signum == SIGBUS)
564 switch(ip->si_code) {
565 #ifdef BUS_ADRALN
566 case BUS_ADRALN:
567 s = "invalid alignment";
568 break;
569 #endif
570 #ifdef BUS_ADRERR /* not on macOS, apparently */
571 case BUS_ADRERR:
572 s = "non-existent physical address";
573 break;
574 #endif
575 #ifdef BUS_OBJERR /* not on macOS, apparently */
576 case BUS_OBJERR:
577 s = "object specific hardware error";
578 break;
579 #endif
580 default:
581 s = "unknown";
582 break;
583 }
584 else
585 switch(ip->si_code) {
586 #ifdef SEGV_MAPERR
587 case SEGV_MAPERR:
588 s = "memory not mapped";
589 break;
590 #endif
591 #ifdef SEGV_ACCERR
592 case SEGV_ACCERR:
593 s = "invalid permissions";
594 break;
595 #endif
596 default:
597 s = "unknown";
598 break;
599 }
600 REprintf("address %p, cause '%s'\n", ip->si_addr, s);
601 }
602 { /* A simple customized print of the traceback */
603 SEXP trace, p, q;
604 int line = 1, i;
605 PROTECT(trace = R_GetTraceback(0));
606 if(trace != R_NilValue) {
607 REprintf("\nTraceback:\n");
608 for(p = trace; p != R_NilValue; p = CDR(p), line++) {
609 q = CAR(p); /* a character vector */
610 REprintf("%2d: ", line);
611 for(i = 0; i < LENGTH(q); i++)
612 REprintf("%s", CHAR(STRING_ELT(q, i)));
613 REprintf("\n");
614 }
615 UNPROTECT(1);
616 }
617 }
618 if(R_Interactive) {
619 REprintf("\nPossible actions:\n1: %s\n2: %s\n3: %s\n4: %s\n",
620 "abort (with core dump, if enabled)",
621 "normal R exit",
622 "exit R without saving workspace",
623 "exit R saving workspace");
624 while(1) {
625 if(R_ReadConsole("Selection: ", ConsoleBuf, CONSOLE_BUFFER_SIZE,
626 0) > 0) {
627 if(ConsoleBuf[0] == '1') break;
628 if(ConsoleBuf[0] == '2') R_CleanUp(SA_DEFAULT, 0, 1);
629 if(ConsoleBuf[0] == '3') R_CleanUp(SA_NOSAVE, 70, 0);
630 if(ConsoleBuf[0] == '4') R_CleanUp(SA_SAVE, 71, 0);
631 }
632 }
633 REprintf("R is aborting now ...\n");
634 }
635 else // non-interactively :
636 REprintf("An irrecoverable exception occurred. R is aborting now ...\n");
637 R_CleanTempDir();
638 /* now do normal behaviour, e.g. core dump */
639 signal(signum, SIG_DFL);
640 raise(signum);
641 }
642
643 #ifndef SIGSTKSZ
644 # define SIGSTKSZ 8192 /* just a guess */
645 #endif
646
647 #ifdef HAVE_STACK_T
648 static stack_t sigstk;
649 #else
650 static struct sigaltstack sigstk;
651 #endif
652 static void *signal_stack;
653
654 #define R_USAGE 100000 /* Just a guess */
init_signal_handlers(void)655 static void init_signal_handlers(void)
656 {
657 /* Do not set the (since 2005 experimantal) SEGV handler
658 UI if R_NO_SEGV_HANDLER env var is non-empty.
659 This is needed to debug crashes in the handler
660 (which happen as they involve the console interface). */
661 const char *val = getenv("R_NO_SEGV_HANDLER");
662 if (!val || !*val) {
663 /* <FIXME> may need to reinstall this if we do recover. */
664 struct sigaction sa;
665 signal_stack = malloc(SIGSTKSZ + R_USAGE);
666 if (signal_stack != NULL) {
667 sigstk.ss_sp = signal_stack;
668 sigstk.ss_size = SIGSTKSZ + R_USAGE;
669 sigstk.ss_flags = 0;
670 if(sigaltstack(&sigstk, NULL) < 0)
671 warning("failed to set alternate signal stack");
672 } else
673 warning("failed to allocate alternate signal stack");
674 sa.sa_sigaction = sigactionSegv;
675 sigemptyset(&sa.sa_mask);
676 sa.sa_flags = SA_ONSTACK | SA_SIGINFO;
677 sigaction(SIGSEGV, &sa, NULL);
678 sigaction(SIGILL, &sa, NULL);
679 #ifdef SIGBUS
680 sigaction(SIGBUS, &sa, NULL);
681 #endif
682 }
683
684 signal(SIGINT, handleInterrupt);
685 signal(SIGUSR1, onsigusr1);
686 signal(SIGUSR2, onsigusr2);
687 signal(SIGPIPE, handlePipe);
688 }
689
690 #else /* not sigaltstack and sigaction and sigemptyset*/
init_signal_handlers(void)691 static void init_signal_handlers(void)
692 {
693 signal(SIGINT, handleInterrupt);
694 signal(SIGUSR1, onsigusr1);
695 signal(SIGUSR2, onsigusr2);
696 #ifndef Win32
697 signal(SIGPIPE, handlePipe);
698 #else
699 signal(SIGSEGV, win32_segv);
700 signal(SIGILL, win32_segv);
701 #endif
702 }
703 #endif
704
705
R_LoadProfile(FILE * fparg,SEXP env)706 static void R_LoadProfile(FILE *fparg, SEXP env)
707 {
708 FILE * volatile fp = fparg; /* is this needed? */
709 if (fp != NULL) {
710 if (SETJMP(R_Toplevel.cjmpbuf))
711 check_session_exit();
712 else {
713 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
714 R_ReplFile(fp, env);
715 }
716 fclose(fp);
717 }
718 }
719
720
721 int R_SignalHandlers = 1; /* Exposed in R_interface.h */
722
723 const char* get_workspace_name(); /* from startup.c */
724
BindDomain(char * R_Home)725 void attribute_hidden BindDomain(char *R_Home)
726 {
727 #ifdef ENABLE_NLS
728 char localedir[PATH_MAX+20];
729 setlocale(LC_MESSAGES,"");
730 textdomain(PACKAGE);
731 char *p = getenv("R_TRANSLATIONS");
732 if (p) snprintf(localedir, PATH_MAX+20, "%s", p);
733 else snprintf(localedir, PATH_MAX+20, "%s/library/translations", R_Home);
734 bindtextdomain(PACKAGE, localedir); // PACKAGE = DOMAIN = "R"
735 bindtextdomain("R-base", localedir);
736 # ifdef _WIN32
737 bindtextdomain("RGui", localedir);
738 # endif
739 #endif
740 }
741
742 /* #define DEBUG_STACK_DETECTION */
743 /* Not to be enabled in production use: the debugging code is more fragile
744 than the detection itself. */
745
746 #ifdef DEBUG_STACK_DETECTION
almostFillStack()747 static uintptr_t almostFillStack() {
748 volatile uintptr_t dummy;
749
750 dummy = (uintptr_t) &dummy;
751 if (R_CStackStart - R_CStackDir * R_CStackLimit + R_CStackDir * 1024 < R_CStackDir * dummy)
752 return almostFillStack();
753 else
754 return dummy;
755 }
756 #endif
757
setup_Rmainloop(void)758 void setup_Rmainloop(void)
759 {
760 volatile int doneit;
761 volatile SEXP baseEnv;
762 SEXP cmd;
763 char deferred_warnings[11][250];
764 volatile int ndeferred_warnings = 0;
765
766 #ifdef DEBUG_STACK_DETECTION
767 /* testing stack base and size detection */
768 printf("stack limit %ld, start %lx dir %d \n",
769 (unsigned long) R_CStackLimit,
770 (unsigned long) R_CStackStart,
771 R_CStackDir);
772 uintptr_t firstb = R_CStackStart - R_CStackDir;
773 printf("first accessible byte %lx\n", (unsigned long) firstb);
774 if (R_CStackLimit != (uintptr_t)(-1)) {
775 uintptr_t lastb = R_CStackStart - R_CStackDir * R_CStackLimit;
776 printf("last accessible byte %lx\n", (unsigned long) lastb);
777 }
778 printf("accessing first byte...\n");
779 volatile char dummy = *(char *)firstb;
780 if (R_CStackLimit != (uintptr_t)(-1)) {
781 /* have to access all bytes in order to map stack, e.g. on Linux
782 just reading does not seem to always do the job, so better
783 first almost fill up the stack using recursive function calls
784 */
785 printf("almost filling up stack...\n");
786 printf("filled stack up to %lx\n", almostFillStack());
787 printf("accessing all bytes...\n");
788 for(uintptr_t o = 0; o < R_CStackLimit; o++)
789 /* with exact bounds, o==-1 and o==R_CStackLimit will segfault */
790 /* +dummy to silence -Wunused-but-set-variable */
791 dummy = *((char *)firstb - R_CStackDir * o) + dummy;
792 }
793 #endif
794
795 /* In case this is a silly limit: 2^32 -3 has been seen and
796 * casting to intptr_r relies on this being smaller than 2^31 on a
797 * 32-bit platform. */
798 if(R_CStackLimit > 100000000U)
799 R_CStackLimit = (uintptr_t)-1;
800 /* make sure we have enough head room to handle errors */
801 if(R_CStackLimit != -1)
802 R_CStackLimit = (uintptr_t)(0.95 * R_CStackLimit);
803
804 InitConnections(); /* needed to get any output at all */
805
806 /* Initialize the interpreter's internal structures. */
807
808 #ifdef HAVE_LOCALE_H
809 #ifdef Win32
810 {
811 char allbuf[1000]; /* Windows' locales can be very long */
812 char *p, *lcall;
813
814 p = getenv("LC_ALL");
815 if(p) {
816 strncpy(allbuf, p, sizeof(allbuf));
817 allbuf[1000 - 1] = '\0';
818 lcall = allbuf;
819 } else
820 lcall = NULL;
821
822 /* We'd like to use warning, but need to defer.
823 Also cannot translate. */
824
825 p = lcall ? lcall : getenv("LC_COLLATE");
826 if(!setlocale(LC_COLLATE, p ? p : ""))
827 snprintf(deferred_warnings[ndeferred_warnings++], 250,
828 "Setting LC_COLLATE=%.200s failed\n", p);
829
830 p = lcall ? lcall : getenv("LC_CTYPE");
831 if(!setlocale(LC_CTYPE, p ? p : ""))
832 snprintf(deferred_warnings[ndeferred_warnings++], 250,
833 "Setting LC_CTYPE=%.200s failed\n", p);
834
835 p = lcall ? lcall : getenv("LC_MONETARY");
836 if(!setlocale(LC_MONETARY, p ? p : ""))
837 snprintf(deferred_warnings[ndeferred_warnings++], 250,
838 "Setting LC_MONETARY=%.200s failed\n", p);
839
840 p = lcall ? lcall : getenv("LC_TIME");
841 if(!setlocale(LC_TIME, p ? p : ""))
842 snprintf(deferred_warnings[ndeferred_warnings++], 250,
843 "Setting LC_TIME=%.200s failed\n", p);
844
845 /* We set R_ARCH here: Unix does it in the shell front-end */
846 char Rarch[30];
847 strcpy(Rarch, "R_ARCH=/");
848 strcat(Rarch, R_ARCH);
849 putenv(Rarch);
850 }
851 #else /* not Win32 */
852 if(!setlocale(LC_CTYPE, ""))
853 snprintf(deferred_warnings[ndeferred_warnings++], 250,
854 "Setting LC_CTYPE failed, using \"C\"\n");
855 if(!setlocale(LC_COLLATE, ""))
856 snprintf(deferred_warnings[ndeferred_warnings++], 250,
857 "Setting LC_COLLATE failed, using \"C\"\n");
858 if(!setlocale(LC_TIME, ""))
859 snprintf(deferred_warnings[ndeferred_warnings++], 250,
860 "Setting LC_TIME failed, using \"C\"\n");
861 #ifdef ENABLE_NLS
862 if(!setlocale(LC_MESSAGES, ""))
863 snprintf(deferred_warnings[ndeferred_warnings++], 250,
864 "Setting LC_MESSAGES failed, using \"C\"\n");
865 #endif
866 /* NB: we do not set LC_NUMERIC */
867 #ifdef LC_MONETARY
868 if(!setlocale(LC_MONETARY, ""))
869 snprintf(deferred_warnings[ndeferred_warnings++], 250,
870 "Setting LC_MONETARY failed, using \"C\"\n");
871 #endif
872 #ifdef LC_PAPER
873 if(!setlocale(LC_PAPER, ""))
874 snprintf(deferred_warnings[ndeferred_warnings++], 250,
875 "Setting LC_PAPER failed, using \"C\"\n");
876 #endif
877 #ifdef LC_MEASUREMENT
878 if(!setlocale(LC_MEASUREMENT, ""))
879 snprintf(deferred_warnings[ndeferred_warnings++], 250,
880 "Setting LC_MEASUREMENT failed, using \"C\"\n");
881 #endif
882 #endif /* not Win32 */
883 #endif
884
885 /* make sure srand is called before R_tmpnam, PR#14381 */
886 srand(TimeToSeed());
887
888 InitArithmetic();
889 InitTempDir(); /* must be before InitEd */
890 InitMemory();
891 InitStringHash(); /* must be before InitNames */
892 InitBaseEnv();
893 InitNames(); /* must be after InitBaseEnv to use R_EmptyEnv */
894 InitParser(); /* must be after InitMemory, InitNames */
895 InitGlobalEnv();
896 InitDynload();
897 InitOptions();
898 InitEd();
899 InitGraphics();
900 InitTypeTables(); /* must be before InitS3DefaultTypes */
901 InitS3DefaultTypes();
902 PrintDefaults();
903
904 R_Is_Running = 1;
905 R_check_locale();
906
907 /* Initialize the global context for error handling. */
908 /* This provides a target for any non-local gotos */
909 /* which occur during error handling */
910
911 R_Toplevel.nextcontext = NULL;
912 R_Toplevel.callflag = CTXT_TOPLEVEL;
913 R_Toplevel.cstacktop = 0;
914 R_Toplevel.gcenabled = R_GCEnabled;
915 R_Toplevel.promargs = R_NilValue;
916 R_Toplevel.callfun = R_NilValue;
917 R_Toplevel.call = R_NilValue;
918 R_Toplevel.cloenv = R_BaseEnv;
919 R_Toplevel.sysparent = R_BaseEnv;
920 R_Toplevel.conexit = R_NilValue;
921 R_Toplevel.vmax = NULL;
922 R_Toplevel.nodestack = R_BCNodeStackTop;
923 R_Toplevel.bcprottop = R_BCProtTop;
924 R_Toplevel.cend = NULL;
925 R_Toplevel.cenddata = NULL;
926 R_Toplevel.intsusp = FALSE;
927 R_Toplevel.handlerstack = R_HandlerStack;
928 R_Toplevel.restartstack = R_RestartStack;
929 R_Toplevel.srcref = R_NilValue;
930 R_Toplevel.prstack = NULL;
931 R_Toplevel.returnValue = NULL;
932 R_Toplevel.evaldepth = 0;
933 R_Toplevel.browserfinish = 0;
934 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
935 R_ExitContext = NULL;
936
937 R_Warnings = R_NilValue;
938
939 /* This is the same as R_BaseEnv, but this marks the environment
940 of functions as the namespace and not the package. */
941 baseEnv = R_BaseNamespace;
942
943 /* Set up some global variables */
944 Init_R_Variables(baseEnv);
945
946 /* On initial entry we open the base language package and begin by
947 running the repl on it.
948 If there is an error we pass on to the repl.
949 Perhaps it makes more sense to quit gracefully?
950 */
951
952 #ifdef RMIN_ONLY
953 /* This is intended to support a minimal build for experimentation. */
954 if (R_SignalHandlers) init_signal_handlers();
955 #else
956 FILE *fp = R_OpenLibraryFile("base");
957 if (fp == NULL)
958 R_Suicide(_("unable to open the base package\n"));
959
960 doneit = 0;
961 if (SETJMP(R_Toplevel.cjmpbuf))
962 check_session_exit();
963 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
964 if (R_SignalHandlers) init_signal_handlers();
965 if (!doneit) {
966 doneit = 1;
967 R_ReplFile(fp, baseEnv);
968 }
969 fclose(fp);
970 #endif
971
972 /* This is where we source the system-wide, the site's and the
973 user's profile (in that order). If there is an error, we
974 drop through to further processing.
975 */
976 R_IoBufferInit(&R_ConsoleIob);
977 R_LoadProfile(R_OpenSysInitFile(), baseEnv);
978 /* These are the same bindings, so only lock them once */
979 R_LockEnvironment(R_BaseNamespace, TRUE);
980 R_LockEnvironment(R_BaseEnv, FALSE);
981 /* At least temporarily unlock some bindings used in graphics */
982 R_unLockBinding(R_DeviceSymbol, R_BaseEnv);
983 R_unLockBinding(R_DevicesSymbol, R_BaseEnv);
984 R_unLockBinding(install(".Library.site"), R_BaseEnv);
985 R_unLockBinding(install(".First"), R_BaseEnv);
986 R_unLockBinding(install(".Last"), R_BaseEnv);
987
988 /* require(methods) if it is in the default packages */
989 doneit = 0;
990 if (SETJMP(R_Toplevel.cjmpbuf))
991 check_session_exit();
992 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
993 if (!doneit) {
994 doneit = 1;
995 PROTECT(cmd = install(".OptRequireMethods"));
996 R_CurrentExpr = findVar(cmd, R_GlobalEnv);
997 if (R_CurrentExpr != R_UnboundValue &&
998 TYPEOF(R_CurrentExpr) == CLOSXP) {
999 PROTECT(R_CurrentExpr = lang1(cmd));
1000 R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
1001 UNPROTECT(1);
1002 }
1003 UNPROTECT(1);
1004 }
1005
1006 if (strcmp(R_GUIType, "Tk") == 0) {
1007 char buf[PATH_MAX];
1008
1009 snprintf(buf, PATH_MAX, "%s/library/tcltk/exec/Tk-frontend.R", R_Home);
1010 R_LoadProfile(R_fopen(buf, "r"), R_GlobalEnv);
1011 }
1012
1013 /* Print a platform and version dependent greeting and a pointer to
1014 * the copyleft.
1015 */
1016 if(!R_Quiet) PrintGreeting();
1017
1018 R_LoadProfile(R_OpenSiteFile(), baseEnv);
1019 R_LockBinding(install(".Library.site"), R_BaseEnv);
1020 R_LockBinding(install(".First"), R_BaseEnv);
1021 R_LockBinding(install(".Last"), R_BaseEnv);
1022 R_LoadProfile(R_OpenInitFile(), R_GlobalEnv);
1023
1024 /* This is where we try to load a user's saved data.
1025 The right thing to do here is very platform dependent.
1026 E.g. under Unix we look in a special hidden file and on the Mac
1027 we look in any documents which might have been double clicked on
1028 or dropped on the application.
1029 */
1030 doneit = 0;
1031 if (SETJMP(R_Toplevel.cjmpbuf))
1032 check_session_exit();
1033 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1034 if (!doneit) {
1035 doneit = 1;
1036 R_InitialData();
1037 }
1038 else {
1039 if (SETJMP(R_Toplevel.cjmpbuf))
1040 check_session_exit();
1041 else {
1042 warning(_("unable to restore saved data in %s\n"), get_workspace_name());
1043 }
1044 }
1045
1046 /* Initial Loading is done.
1047 At this point we try to invoke the .First Function.
1048 If there is an error we continue. */
1049
1050 doneit = 0;
1051 if (SETJMP(R_Toplevel.cjmpbuf))
1052 check_session_exit();
1053 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1054 if (!doneit) {
1055 doneit = 1;
1056 PROTECT(cmd = install(".First"));
1057 R_CurrentExpr = findVar(cmd, R_GlobalEnv);
1058 if (R_CurrentExpr != R_UnboundValue &&
1059 TYPEOF(R_CurrentExpr) == CLOSXP) {
1060 PROTECT(R_CurrentExpr = lang1(cmd));
1061 R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
1062 UNPROTECT(1);
1063 }
1064 UNPROTECT(1);
1065 }
1066 /* Try to invoke the .First.sys function, which loads the default packages.
1067 If there is an error we continue. */
1068
1069 doneit = 0;
1070 if (SETJMP(R_Toplevel.cjmpbuf))
1071 check_session_exit();
1072 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1073 if (!doneit) {
1074 doneit = 1;
1075 PROTECT(cmd = install(".First.sys"));
1076 R_CurrentExpr = findVar(cmd, baseEnv);
1077 if (R_CurrentExpr != R_UnboundValue &&
1078 TYPEOF(R_CurrentExpr) == CLOSXP) {
1079 PROTECT(R_CurrentExpr = lang1(cmd));
1080 R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
1081 UNPROTECT(1);
1082 }
1083 UNPROTECT(1);
1084 }
1085 {
1086 int i;
1087 for(i = 0 ; i < ndeferred_warnings; i++)
1088 warning(deferred_warnings[i]);
1089 }
1090 if (R_CollectWarnings) {
1091 REprintf(_("During startup - "));
1092 PrintWarnings();
1093 }
1094 if(R_Verbose)
1095 REprintf(" ending setup_Rmainloop(): R_Interactive = %d {main.c}\n",
1096 R_Interactive);
1097
1098 /* trying to do this earlier seems to run into bootstrapping issues. */
1099 doneit = 0;
1100 if (SETJMP(R_Toplevel.cjmpbuf))
1101 check_session_exit();
1102 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1103 if (!doneit) {
1104 doneit = 1;
1105 R_init_jit_enabled();
1106 } else
1107 R_Suicide(_("unable to initialize the JIT\n"));
1108 R_Is_Running = 2;
1109 }
1110
1111 extern SA_TYPE SaveAction; /* from src/main/startup.c */
1112
end_Rmainloop(void)1113 static void end_Rmainloop(void)
1114 {
1115 /* refrain from printing trailing '\n' in no-echo mode */
1116 if (!R_NoEcho)
1117 Rprintf("\n");
1118 /* run the .Last function. If it gives an error, will drop back to main
1119 loop. */
1120 R_CleanUp(SA_DEFAULT, 0, 1);
1121 }
1122
run_Rmainloop(void)1123 void run_Rmainloop(void)
1124 {
1125 /* Here is the real R read-eval-loop. */
1126 /* We handle the console until end-of-file. */
1127 if (SETJMP(R_Toplevel.cjmpbuf))
1128 check_session_exit();
1129 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1130 R_ReplConsole(R_GlobalEnv, 0, 0);
1131 end_Rmainloop(); /* must go here */
1132 }
1133
mainloop(void)1134 void mainloop(void)
1135 {
1136 setup_Rmainloop();
1137 run_Rmainloop();
1138 }
1139
1140 /*this functionality now appears in 3
1141 places-jump_to_toplevel/profile/here */
1142
printwhere(void)1143 void attribute_hidden printwhere(void)
1144 {
1145 RCNTXT *cptr;
1146 int lct = 1;
1147
1148 for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
1149 if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN)) &&
1150 (TYPEOF(cptr->call) == LANGSXP)) {
1151 Rprintf("where %d", lct++);
1152 SEXP sref;
1153 if (cptr->srcref == R_InBCInterpreter)
1154 sref = R_findBCInterpreterSrcref(cptr);
1155 else
1156 sref = cptr->srcref;
1157 SrcrefPrompt("", sref);
1158 PrintValue(cptr->call);
1159 }
1160 }
1161 Rprintf("\n");
1162 }
1163
printBrowserHelp(void)1164 static void printBrowserHelp(void)
1165 {
1166 Rprintf("n next\n");
1167 Rprintf("s step into\n");
1168 Rprintf("f finish\n");
1169 Rprintf("c or cont continue\n");
1170 Rprintf("Q quit\n");
1171 Rprintf("where show stack\n");
1172 Rprintf("help show help\n");
1173 Rprintf("<expr> evaluate expression\n");
1174 }
1175
ParseBrowser(SEXP CExpr,SEXP rho)1176 static int ParseBrowser(SEXP CExpr, SEXP rho)
1177 {
1178 int rval = 0;
1179 if (isSymbol(CExpr)) {
1180 const char *expr = CHAR(PRINTNAME(CExpr));
1181 if (!strcmp(expr, "c") || !strcmp(expr, "cont")) {
1182 rval = 1;
1183 SET_RDEBUG(rho, 0);
1184 } else if (!strcmp(expr, "f")) {
1185 rval = 1;
1186 RCNTXT *cntxt = R_GlobalContext;
1187 while (cntxt != R_ToplevelContext
1188 && !(cntxt->callflag & (CTXT_RETURN | CTXT_LOOP))) {
1189 cntxt = cntxt->nextcontext;
1190 }
1191 cntxt->browserfinish = 1;
1192 SET_RDEBUG(rho, 1);
1193 R_BrowserLastCommand = 'f';
1194 } else if (!strcmp(expr, "help")) {
1195 rval = 2;
1196 printBrowserHelp();
1197 } else if (!strcmp(expr, "n")) {
1198 rval = 1;
1199 SET_RDEBUG(rho, 1);
1200 R_BrowserLastCommand = 'n';
1201 } else if (!strcmp(expr, "Q")) {
1202
1203 /* this is really dynamic state that should be managed as such */
1204 SET_RDEBUG(rho, 0); /*PR#1721*/
1205
1206 jump_to_toplevel();
1207 } else if (!strcmp(expr, "s")) {
1208 rval = 1;
1209 SET_RDEBUG(rho, 1);
1210 R_BrowserLastCommand = 's';
1211 } else if (!strcmp(expr, "where")) {
1212 rval = 2;
1213 printwhere();
1214 /* SET_RDEBUG(rho, 1); */
1215 } else if (!strcmp(expr, "r")) {
1216 SEXP hooksym = install(".tryResumeInterrupt");
1217 if (SYMVALUE(hooksym) != R_UnboundValue) {
1218 SEXP hcall;
1219 R_Busy(1);
1220 PROTECT(hcall = LCONS(hooksym, R_NilValue));
1221 eval(hcall, R_GlobalEnv);
1222 UNPROTECT(1);
1223 }
1224 }
1225 }
1226
1227 return rval;
1228 }
1229
1230 /* There's another copy of this in eval.c */
PrintCall(SEXP call,SEXP rho)1231 static void PrintCall(SEXP call, SEXP rho)
1232 {
1233 int old_bl = R_BrowseLines,
1234 blines = asInteger(GetOption1(install("deparse.max.lines")));
1235 if(blines != NA_INTEGER && blines > 0)
1236 R_BrowseLines = blines;
1237
1238 R_PrintData pars;
1239 PrintInit(&pars, rho);
1240 PrintValueRec(call, &pars);
1241
1242 R_BrowseLines = old_bl;
1243 }
1244
1245 /* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
1246 * ------- but also called from ./eval.c */
do_browser(SEXP call,SEXP op,SEXP args,SEXP rho)1247 SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
1248 {
1249 RCNTXT *saveToplevelContext;
1250 RCNTXT *saveGlobalContext;
1251 RCNTXT thiscontext, returncontext, *cptr;
1252 int savestack, browselevel;
1253 SEXP ap, topExp, argList;
1254
1255 /* Cannot call checkArity(op, args), because "op" may be a closure */
1256 /* or a primitive other than "browser". */
1257
1258 /* argument matching */
1259 PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
1260 SET_TAG(ap, install("text"));
1261 SET_TAG(CDR(ap), install("condition"));
1262 SET_TAG(CDDR(ap), install("expr"));
1263 SET_TAG(CDDDR(ap), install("skipCalls"));
1264 argList = matchArgs_RC(ap, args, call);
1265 UNPROTECT(1);
1266 PROTECT(argList);
1267 /* substitute defaults */
1268 if(CAR(argList) == R_MissingArg)
1269 SETCAR(argList, mkString(""));
1270 if(CADR(argList) == R_MissingArg)
1271 SETCAR(CDR(argList), R_NilValue);
1272 if(CADDR(argList) == R_MissingArg)
1273 SETCAR(CDDR(argList), ScalarLogical(1));
1274 if(CADDDR(argList) == R_MissingArg)
1275 SETCAR(CDDDR(argList), ScalarInteger(0));
1276
1277 /* return if 'expr' is not TRUE */
1278 if( !asLogical(CADDR(argList)) ) {
1279 UNPROTECT(1);
1280 return R_NilValue;
1281 }
1282
1283 /* Save the evaluator state information */
1284 /* so that it can be restored on exit. */
1285
1286 browselevel = countContexts(CTXT_BROWSER, 1);
1287 savestack = R_PPStackTop;
1288 PROTECT(topExp = R_CurrentExpr);
1289 saveToplevelContext = R_ToplevelContext;
1290 saveGlobalContext = R_GlobalContext;
1291
1292 if (!RDEBUG(rho)) {
1293 int skipCalls = asInteger(CADDDR(argList));
1294 cptr = R_GlobalContext;
1295 while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--)
1296 && cptr->callflag )
1297 cptr = cptr->nextcontext;
1298 Rprintf("Called from: ");
1299 if( cptr != R_ToplevelContext ) {
1300 PrintCall(cptr->call, rho);
1301 SET_RDEBUG(cptr->cloenv, 1);
1302 } else
1303 Rprintf("top level \n");
1304
1305 R_BrowseLines = 0;
1306 }
1307
1308 R_ReturnedValue = R_NilValue;
1309
1310 /* Here we establish two contexts. The first */
1311 /* of these provides a target for return */
1312 /* statements which a user might type at the */
1313 /* browser prompt. The (optional) second one */
1314 /* acts as a target for error returns. */
1315
1316 begincontext(&returncontext, CTXT_BROWSER, call, rho,
1317 R_BaseEnv, argList, R_NilValue);
1318 if (!SETJMP(returncontext.cjmpbuf)) {
1319 begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
1320 R_BaseEnv, R_NilValue, R_NilValue);
1321 if (SETJMP(thiscontext.cjmpbuf)) {
1322 SET_RESTART_BIT_ON(thiscontext.callflag);
1323 R_ReturnedValue = R_NilValue;
1324 R_Visible = FALSE;
1325 }
1326 R_GlobalContext = &thiscontext;
1327 R_InsertRestartHandlers(&thiscontext, "browser");
1328 R_ReplConsole(rho, savestack, browselevel+1);
1329 endcontext(&thiscontext);
1330 }
1331 endcontext(&returncontext);
1332
1333 /* Reset the interpreter state. */
1334
1335 R_CurrentExpr = topExp;
1336 UNPROTECT(1);
1337 R_PPStackTop = savestack;
1338 UNPROTECT(1);
1339 R_CurrentExpr = topExp;
1340 R_ToplevelContext = saveToplevelContext;
1341 R_GlobalContext = saveGlobalContext;
1342 return R_ReturnedValue;
1343 }
1344
R_dot_Last(void)1345 void R_dot_Last(void)
1346 {
1347 SEXP cmd;
1348
1349 /* Run the .Last function. */
1350 /* Errors here should kick us back into the repl. */
1351
1352 R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
1353 PROTECT(cmd = install(".Last"));
1354 R_CurrentExpr = findVar(cmd, R_GlobalEnv);
1355 if (R_CurrentExpr != R_UnboundValue && TYPEOF(R_CurrentExpr) == CLOSXP) {
1356 PROTECT(R_CurrentExpr = lang1(cmd));
1357 R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
1358 UNPROTECT(1);
1359 }
1360 UNPROTECT(1);
1361 PROTECT(cmd = install(".Last.sys"));
1362 R_CurrentExpr = findVar(cmd, R_BaseNamespace);
1363 if (R_CurrentExpr != R_UnboundValue && TYPEOF(R_CurrentExpr) == CLOSXP) {
1364 PROTECT(R_CurrentExpr = lang1(cmd));
1365 R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
1366 UNPROTECT(1);
1367 }
1368 UNPROTECT(1);
1369 }
1370
do_quit(SEXP call,SEXP op,SEXP args,SEXP rho)1371 SEXP attribute_hidden do_quit(SEXP call, SEXP op, SEXP args, SEXP rho)
1372 {
1373 const char *tmp;
1374 SA_TYPE ask=SA_DEFAULT;
1375 int status, runLast;
1376
1377 checkArity(op, args);
1378 /* if there are any browser contexts active don't quit */
1379 if(countContexts(CTXT_BROWSER, 1)) {
1380 warning(_("cannot quit from browser"));
1381 return R_NilValue;
1382 }
1383 if( !isString(CAR(args)) )
1384 error(_("one of \"yes\", \"no\", \"ask\" or \"default\" expected."));
1385 tmp = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
1386 if( !strcmp(tmp, "ask") ) {
1387 ask = SA_SAVEASK;
1388 if(!R_Interactive)
1389 warning(_("save=\"ask\" in non-interactive use: command-line default will be used"));
1390 } else if( !strcmp(tmp, "no") )
1391 ask = SA_NOSAVE;
1392 else if( !strcmp(tmp, "yes") )
1393 ask = SA_SAVE;
1394 else if( !strcmp(tmp, "default") )
1395 ask = SA_DEFAULT;
1396 else
1397 error(_("unrecognized value of 'save'"));
1398 status = asInteger(CADR(args));
1399 if (status == NA_INTEGER) {
1400 warning(_("invalid 'status', 0 assumed"));
1401 status = 0;
1402 }
1403 runLast = asLogical(CADDR(args));
1404 if (runLast == NA_LOGICAL) {
1405 warning(_("invalid 'runLast', FALSE assumed"));
1406 runLast = 0;
1407 }
1408 /* run the .Last function. If it gives an error, will drop back to main
1409 loop. */
1410 R_CleanUp(ask, status, runLast);
1411 exit(0);
1412 /*NOTREACHED*/
1413 }
1414
1415
1416 #include <R_ext/Callbacks.h>
1417
1418 static R_ToplevelCallbackEl *Rf_ToplevelTaskHandlers = NULL;
1419
1420 /**
1421 This is the C-level entry point for registering a handler
1422 that is to be called when each top-level task completes.
1423
1424 Perhaps we need names to make removing them handlers easier
1425 since they could be more identified by an invariant (rather than
1426 position).
1427 */
1428 R_ToplevelCallbackEl *
Rf_addTaskCallback(R_ToplevelCallback cb,void * data,void (* finalizer)(void *),const char * name,int * pos)1429 Rf_addTaskCallback(R_ToplevelCallback cb, void *data,
1430 void (*finalizer)(void *), const char *name, int *pos)
1431 {
1432 int which;
1433 R_ToplevelCallbackEl *el;
1434 el = (R_ToplevelCallbackEl *) malloc(sizeof(R_ToplevelCallbackEl));
1435 if(!el)
1436 error(_("cannot allocate space for toplevel callback element"));
1437
1438 el->data = data;
1439 el->cb = cb;
1440 el->next = NULL;
1441 el->finalizer = finalizer;
1442
1443 if(Rf_ToplevelTaskHandlers == NULL) {
1444 Rf_ToplevelTaskHandlers = el;
1445 which = 0;
1446 } else {
1447 R_ToplevelCallbackEl *tmp;
1448 tmp = Rf_ToplevelTaskHandlers;
1449 which = 1;
1450 while(tmp->next) {
1451 which++;
1452 tmp = tmp->next;
1453 }
1454 tmp->next = el;
1455 }
1456
1457 if(!name) {
1458 char buf[20];
1459 snprintf(buf, 20, "%d", which+1);
1460 el->name = Rstrdup(buf);
1461 } else
1462 el->name = Rstrdup(name);
1463
1464 if(pos)
1465 *pos = which;
1466
1467 return(el);
1468 }
1469
1470 Rboolean
Rf_removeTaskCallbackByName(const char * name)1471 Rf_removeTaskCallbackByName(const char *name)
1472 {
1473 R_ToplevelCallbackEl *el = Rf_ToplevelTaskHandlers, *prev = NULL;
1474 Rboolean status = TRUE;
1475
1476 if(!Rf_ToplevelTaskHandlers) {
1477 return(FALSE); /* error("there are no task callbacks registered"); */
1478 }
1479
1480 while(el) {
1481 if(strcmp(el->name, name) == 0) {
1482 if(prev == NULL) {
1483 Rf_ToplevelTaskHandlers = el->next;
1484 } else {
1485 prev->next = el->next;
1486 }
1487 break;
1488 }
1489 prev = el;
1490 el = el->next;
1491 }
1492 if(el) {
1493 if(el->finalizer)
1494 el->finalizer(el->data);
1495 free(el->name);
1496 free(el);
1497 } else {
1498 status = FALSE;
1499 }
1500 return(status);
1501 }
1502
1503 /**
1504 Remove the top-level task handler/callback identified by
1505 its position in the list of callbacks.
1506 */
1507 Rboolean
Rf_removeTaskCallbackByIndex(int id)1508 Rf_removeTaskCallbackByIndex(int id)
1509 {
1510 R_ToplevelCallbackEl *el = Rf_ToplevelTaskHandlers, *tmp = NULL;
1511 Rboolean status = TRUE;
1512
1513 if(id < 0)
1514 error(_("negative index passed to R_removeTaskCallbackByIndex"));
1515
1516 if(Rf_ToplevelTaskHandlers) {
1517 if(id == 0) {
1518 tmp = Rf_ToplevelTaskHandlers;
1519 Rf_ToplevelTaskHandlers = Rf_ToplevelTaskHandlers->next;
1520 } else {
1521 int i = 0;
1522 while(el && i < (id-1)) {
1523 el = el->next;
1524 i++;
1525 }
1526
1527 if(i == (id -1) && el) {
1528 tmp = el->next;
1529 el->next = (tmp ? tmp->next : NULL);
1530 }
1531 }
1532 }
1533 if(tmp) {
1534 if(tmp->finalizer)
1535 tmp->finalizer(tmp->data);
1536 free(tmp->name);
1537 free(tmp);
1538 } else {
1539 status = FALSE;
1540 }
1541
1542 return(status);
1543 }
1544
1545
1546 /**
1547 R-level entry point to remove an entry from the
1548 list of top-level callbacks. 'which' should be an
1549 integer and give us the 0-based index of the element
1550 to be removed from the list.
1551
1552 @see Rf_RemoveToplevelCallbackByIndex(int)
1553 */
1554 SEXP
R_removeTaskCallback(SEXP which)1555 R_removeTaskCallback(SEXP which)
1556 {
1557 int id;
1558 Rboolean val;
1559
1560 if(TYPEOF(which) == STRSXP) {
1561 if (LENGTH(which) == 0)
1562 val = FALSE;
1563 else
1564 val = Rf_removeTaskCallbackByName(CHAR(STRING_ELT(which, 0)));
1565 } else {
1566 id = asInteger(which);
1567 if (id != NA_INTEGER) val = Rf_removeTaskCallbackByIndex(id - 1);
1568 else val = FALSE;
1569 }
1570 return ScalarLogical(val);
1571 }
1572
1573 SEXP
R_getTaskCallbackNames(void)1574 R_getTaskCallbackNames(void)
1575 {
1576 SEXP ans;
1577 R_ToplevelCallbackEl *el;
1578 int n = 0;
1579
1580 el = Rf_ToplevelTaskHandlers;
1581 while(el) {
1582 n++;
1583 el = el->next;
1584 }
1585 PROTECT(ans = allocVector(STRSXP, n));
1586 n = 0;
1587 el = Rf_ToplevelTaskHandlers;
1588 while(el) {
1589 SET_STRING_ELT(ans, n, mkChar(el->name));
1590 n++;
1591 el = el->next;
1592 }
1593 UNPROTECT(1);
1594 return(ans);
1595 }
1596
1597 /**
1598 Invokes each of the different handlers giving the
1599 top-level expression that was just evaluated,
1600 the resulting value from the evaluation, and
1601 whether the task succeeded. The last may be useful
1602 if a handler is also called as part of the error handling.
1603 We also have information about whether the result was printed or not.
1604 We currently do not pass this to the handler.
1605 */
1606
1607 /* Flag to ensure that the top-level handlers aren't called recursively.
1608 Simple state to indicate that they are currently being run. */
1609 static Rboolean Rf_RunningToplevelHandlers = FALSE;
1610
1611 /* This is not used in R and in no header */
1612 void
Rf_callToplevelHandlers(SEXP expr,SEXP value,Rboolean succeeded,Rboolean visible)1613 Rf_callToplevelHandlers(SEXP expr, SEXP value, Rboolean succeeded,
1614 Rboolean visible)
1615 {
1616 R_ToplevelCallbackEl *h, *prev = NULL;
1617 Rboolean again;
1618
1619 if(Rf_RunningToplevelHandlers == TRUE)
1620 return;
1621
1622 h = Rf_ToplevelTaskHandlers;
1623 Rf_RunningToplevelHandlers = TRUE;
1624 while(h) {
1625 again = (h->cb)(expr, value, succeeded, visible, h->data);
1626 if(R_CollectWarnings) {
1627 REprintf(_("warning messages from top-level task callback '%s'\n"),
1628 h->name);
1629 PrintWarnings();
1630 }
1631 if(again) {
1632 prev = h;
1633 h = h->next;
1634 } else {
1635 R_ToplevelCallbackEl *tmp;
1636 tmp = h;
1637 if(prev)
1638 prev->next = h->next;
1639 h = h->next;
1640 if(tmp == Rf_ToplevelTaskHandlers)
1641 Rf_ToplevelTaskHandlers = h;
1642 if(tmp->finalizer)
1643 tmp->finalizer(tmp->data);
1644 free(tmp);
1645 }
1646 }
1647
1648 Rf_RunningToplevelHandlers = FALSE;
1649 }
1650
1651
defineVarInc(SEXP sym,SEXP val,SEXP rho)1652 static void defineVarInc(SEXP sym, SEXP val, SEXP rho)
1653 {
1654 defineVar(sym, val, rho);
1655 INCREMENT_NAMED(val); /* in case this is used in a NAMED build */
1656 }
1657
1658 Rboolean
R_taskCallbackRoutine(SEXP expr,SEXP value,Rboolean succeeded,Rboolean visible,void * userData)1659 R_taskCallbackRoutine(SEXP expr, SEXP value, Rboolean succeeded,
1660 Rboolean visible, void *userData)
1661 {
1662 /* install some symbols */
1663 static SEXP R_cbSym = NULL;
1664 static SEXP R_exprSym = NULL;
1665 static SEXP R_valueSym = NULL;
1666 static SEXP R_succeededSym = NULL;
1667 static SEXP R_visibleSym = NULL;
1668 static SEXP R_dataSym = NULL;
1669 if (R_cbSym == NULL) {
1670 R_cbSym = install("cb");
1671 R_exprSym = install("expr");
1672 R_valueSym = install("value");
1673 R_succeededSym = install("succeeded");
1674 R_visibleSym = install("visible");
1675 R_dataSym = install("data");
1676 }
1677
1678 SEXP f = (SEXP) userData;
1679 SEXP e, val, cur, rho;
1680 int errorOccurred;
1681 Rboolean again, useData = LOGICAL(VECTOR_ELT(f, 2))[0];
1682
1683 /* create an environment with bindings for the function and arguments */
1684 PROTECT(rho = NewEnvironment(R_NilValue, R_NilValue, R_GlobalEnv));
1685 defineVarInc(R_cbSym, VECTOR_ELT(f, 0), rho);
1686 defineVarInc(R_exprSym, expr, rho);
1687 defineVarInc(R_valueSym, value, rho);
1688 defineVarInc(R_succeededSym, ScalarLogical(succeeded), rho);
1689 defineVarInc(R_visibleSym, ScalarLogical(visible), rho);
1690 if(useData)
1691 defineVarInc(R_dataSym, VECTOR_ELT(f, 1), rho);
1692
1693 /* create the call; these could be saved and re-used */
1694 PROTECT(e = allocVector(LANGSXP, 5 + useData));
1695 SETCAR(e, R_cbSym); cur = CDR(e);
1696 SETCAR(cur, R_exprSym); cur = CDR(cur);
1697 SETCAR(cur, R_valueSym); cur = CDR(cur);
1698 SETCAR(cur, R_succeededSym); cur = CDR(cur);
1699 SETCAR(cur, R_visibleSym); cur = CDR(cur);
1700 if(useData)
1701 SETCAR(cur, R_dataSym);
1702
1703 val = R_tryEval(e, rho, &errorOccurred);
1704 PROTECT(val);
1705
1706 /* clear the environment to reduce reference counts */
1707 defineVar(R_cbSym, R_NilValue, rho);
1708 defineVar(R_exprSym, R_NilValue, rho);
1709 defineVar(R_valueSym, R_NilValue, rho);
1710 defineVar(R_succeededSym, R_NilValue, rho);
1711 defineVar(R_visibleSym, R_NilValue, rho);
1712 if(useData)
1713 defineVar(R_dataSym, R_NilValue, rho);
1714
1715 if(!errorOccurred) {
1716 if(TYPEOF(val) != LGLSXP) {
1717 /* It would be nice to identify the function. */
1718 warning(_("top-level task callback did not return a logical value"));
1719 }
1720 again = asLogical(val);
1721 } else {
1722 /* warning("error occurred in top-level task callback\n"); */
1723 again = FALSE;
1724 }
1725
1726 UNPROTECT(3); /* rho, e, val */
1727
1728 return(again);
1729 }
1730
1731 SEXP
R_addTaskCallback(SEXP f,SEXP data,SEXP useData,SEXP name)1732 R_addTaskCallback(SEXP f, SEXP data, SEXP useData, SEXP name)
1733 {
1734 SEXP internalData;
1735 SEXP index;
1736 R_ToplevelCallbackEl *el;
1737 const char *tmpName = NULL;
1738
1739 internalData = allocVector(VECSXP, 3);
1740 R_PreserveObject(internalData);
1741 SET_VECTOR_ELT(internalData, 0, f);
1742 SET_VECTOR_ELT(internalData, 1, data);
1743 SET_VECTOR_ELT(internalData, 2, useData);
1744
1745 if(length(name))
1746 tmpName = CHAR(STRING_ELT(name, 0));
1747
1748 PROTECT(index = allocVector(INTSXP, 1));
1749 el = Rf_addTaskCallback(R_taskCallbackRoutine, internalData,
1750 (void (*)(void*)) R_ReleaseObject, tmpName,
1751 INTEGER(index));
1752
1753 if(length(name) == 0) {
1754 PROTECT(name = mkString(el->name));
1755 setAttrib(index, R_NamesSymbol, name);
1756 UNPROTECT(1);
1757 } else {
1758 setAttrib(index, R_NamesSymbol, name);
1759 }
1760
1761 UNPROTECT(1);
1762 return(index);
1763 }
1764
1765 #undef __MAIN__
1766
1767 #ifndef Win32
1768 /* this is here solely to pull in xxxpr.o */
1769 # include <R_ext/RS.h>
1770 # if defined FC_LEN_T
1771 # include <stddef.h>
1772 void F77_SYMBOL(rwarnc)(char *msg, int *nchar, FC_LEN_T msg_len);
dummy54321(void)1773 void attribute_hidden dummy54321(void)
1774 {
1775 int nc = 5;
1776 F77_CALL(rwarnc)("dummy", &nc, (FC_LEN_T) 5);
1777 }
1778 # else
1779 void F77_SYMBOL(rwarnc)(char *msg, int *nchar);
dummy54321(void)1780 void attribute_hidden dummy54321(void)
1781 {
1782 int nc = 5;
1783 F77_CALL(rwarnc)("dummy", &nc);
1784 }
1785 # endif
1786 #endif
1787