-
Notifications
You must be signed in to change notification settings - Fork 313
/
main.c
1778 lines (1581 loc) · 48.4 KB
/
main.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 1998-2021 The R Core Team
* Copyright (C) 2002-2005 The R Foundation
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* https://www.R-project.org/Licenses/
*/
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <math.h> /* avoid redefinition of extern in Defn.h */
#include <float.h>
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
#define __MAIN__
#define R_USE_SIGNALS 1
#include "Defn.h"
#include <Internal.h>
#include "Rinterface.h"
#include "IOStuff.h"
#include "Fileio.h"
#include "Parse.h"
#include "Startup.h"
#include <locale.h>
#include <R_ext/Print.h>
#ifdef ENABLE_NLS
void attribute_hidden nl_Rdummy(void)
{
/* force this in as packages use it */
dgettext("R", "dummy - do not translate");
}
#endif
/* The 'real' main() program is in Rmain.c on Unix-alikes, and
src/gnuwin/front-ends/graphappmain.c on Windows, unless of course
R is embedded */
/* Global Variables: For convenience, all interpeter global symbols
* ================ are declared in Defn.h as extern -- and defined here.
*
* NOTE: This is done by using some preprocessor trickery. If __MAIN__
* is defined as above, there is a sneaky
* #define extern
* so that the same code produces both declarations and definitions.
*
* This does not include user interface symbols which are included
* in separate platform dependent modules.
*/
void Rf_callToplevelHandlers(SEXP expr, SEXP value, Rboolean succeeded,
Rboolean visible);
static int ParseBrowser(SEXP, SEXP);
/* Read-Eval-Print Loop [ =: REPL = repl ] with input from a file */
static void R_ReplFile(FILE *fp, SEXP rho)
{
ParseStatus status;
int count=0;
int savestack;
RCNTXT cntxt;
R_InitSrcRefState(&cntxt);
savestack = R_PPStackTop;
for(;;) {
R_PPStackTop = savestack;
R_CurrentExpr = R_Parse1File(fp, 1, &status);
switch (status) {
case PARSE_NULL:
break;
case PARSE_OK:
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
count++;
PROTECT(R_CurrentExpr);
R_CurrentExpr = eval(R_CurrentExpr, rho);
SET_SYMVALUE(R_LastvalueSymbol, R_CurrentExpr);
UNPROTECT(1);
if (R_Visible)
PrintValueEnv(R_CurrentExpr, rho);
if( R_CollectWarnings )
PrintWarnings();
break;
case PARSE_ERROR:
R_FinalizeSrcRefState();
parseError(R_NilValue, R_ParseError);
break;
case PARSE_EOF:
endcontext(&cntxt);
R_FinalizeSrcRefState();
return;
break;
case PARSE_INCOMPLETE:
/* can't happen: just here to quieten -Wall */
break;
}
}
}
/* Read-Eval-Print loop with interactive input */
static int prompt_type;
static char BrowsePrompt[20];
static const char *R_PromptString(int browselevel, int type)
{
if (R_NoEcho) {
BrowsePrompt[0] = '\0';
return BrowsePrompt;
}
else {
if(type == 1) {
if(browselevel) {
snprintf(BrowsePrompt, 20, "Browse[%d]> ", browselevel);
return BrowsePrompt;
}
return CHAR(STRING_ELT(GetOption1(install("prompt")), 0));
}
else {
return CHAR(STRING_ELT(GetOption1(install("continue")), 0));
}
}
}
/*
This is a reorganization of the REPL (Read-Eval-Print Loop) to separate
the loop from the actions of the body. The motivation is to make the iteration
code (Rf_ReplIteration) available as a separately callable routine
to avoid cutting and pasting it when one wants a single iteration
of the loop. This is needed as we allow different implementations
of event loops. Currently (summer 2002), we have a package in
preparation that uses Rf_ReplIteration within either the
Tcl or Gtk event loop and allows either (or both) loops to
be used as a replacement for R's loop and take over the event
handling for the R process.
The modifications here are intended to leave the semantics of the REPL
unchanged, just separate into routines. So the variables that maintain
the state across iterations of the loop are organized into a structure
and passed to Rf_ReplIteration() from Rf_ReplConsole().
*/
/**
(local) Structure for maintaining and exchanging the state between
Rf_ReplConsole and its worker routine Rf_ReplIteration which is the
implementation of the body of the REPL.
In the future, we may need to make this accessible to packages
and so put it into one of the public R header files.
*/
typedef struct {
ParseStatus status;
int prompt_type;
int browselevel;
unsigned char buf[CONSOLE_BUFFER_SIZE+1];
unsigned char *bufp;
} R_ReplState;
/**
This is the body of the REPL.
It attempts to parse the first line or expression of its input,
and optionally request input from the user if none is available.
If the input can be parsed correctly,
i) the resulting expression is evaluated,
ii) the result assigned to .Last.Value,
iii) top-level task handlers are invoked.
If the input cannot be parsed, i.e. there is a syntax error,
it is incomplete, or we encounter an end-of-file, then we
change the prompt accordingly.
The "cursor" for the input buffer is moved to the next starting
point, i.e. the end of the first line or after the first ;.
*/
int
Rf_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state)
{
int c, browsevalue;
SEXP value, thisExpr;
Rboolean wasDisplayed = FALSE;
/* clear warnings that might have accumulated during a jump to top level */
if (R_CollectWarnings)
PrintWarnings();
if(!*state->bufp) {
R_Busy(0);
if (R_ReadConsole(R_PromptString(browselevel, state->prompt_type),
state->buf, CONSOLE_BUFFER_SIZE, 1) == 0)
return(-1);
state->bufp = state->buf;
}
#ifdef SHELL_ESCAPE /* not default */
if (*state->bufp == '!') {
R_system(&(state->buf[1]));
state->buf[0] = '\0';
return(0);
}
#endif /* SHELL_ESCAPE */
while((c = *state->bufp++)) {
R_IoBufferPutc(c, &R_ConsoleIob);
if(c == ';' || c == '\n') break;
}
R_PPStackTop = savestack;
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &state->status);
switch(state->status) {
case PARSE_NULL:
/* The intention here is to break on CR but not on other
null statements: see PR#9063 */
if (browselevel && !R_DisableNLinBrowser
&& !strcmp((char *) state->buf, "\n")) return -1;
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return 1;
case PARSE_OK:
R_IoBufferReadReset(&R_ConsoleIob);
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &state->status);
if (browselevel) {
browsevalue = ParseBrowser(R_CurrentExpr, rho);
if(browsevalue == 1) return -1;
if(browsevalue == 2) {
R_IoBufferWriteReset(&R_ConsoleIob);
return 0;
}
/* PR#15770 We don't want to step into expressions entered at the debug prompt.
The 'S' will be changed back to 's' after the next eval. */
if (R_BrowserLastCommand == 's') R_BrowserLastCommand = 'S';
}
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
PROTECT(thisExpr = R_CurrentExpr);
R_Busy(1);
PROTECT(value = eval(thisExpr, rho));
SET_SYMVALUE(R_LastvalueSymbol, value);
if (NO_REFERENCES(value))
INCREMENT_REFCNT(value);
wasDisplayed = R_Visible;
if (R_Visible)
PrintValueEnv(value, rho);
if (R_CollectWarnings)
PrintWarnings();
Rf_callToplevelHandlers(thisExpr, value, TRUE, wasDisplayed);
R_CurrentExpr = value; /* Necessary? Doubt it. */
UNPROTECT(2); /* thisExpr, value */
if (R_BrowserLastCommand == 'S') R_BrowserLastCommand = 's';
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return(1);
case PARSE_ERROR:
state->prompt_type = 1;
parseError(R_NilValue, 0);
R_IoBufferWriteReset(&R_ConsoleIob);
return(1);
case PARSE_INCOMPLETE:
R_IoBufferReadReset(&R_ConsoleIob);
state->prompt_type = 2;
return(2);
case PARSE_EOF:
return(-1);
break;
}
return(0);
}
static void R_ReplConsole(SEXP rho, int savestack, int browselevel)
{
int status;
R_ReplState state = { PARSE_NULL, 1, 0, "", NULL};
R_IoBufferWriteReset(&R_ConsoleIob);
state.buf[0] = '\0';
state.buf[CONSOLE_BUFFER_SIZE] = '\0';
/* stopgap measure if line > CONSOLE_BUFFER_SIZE chars */
state.bufp = state.buf;
if(R_Verbose)
REprintf(" >R_ReplConsole(): before \"for(;;)\" {main.c}\n");
for(;;) {
status = Rf_ReplIteration(rho, savestack, browselevel, &state);
if(status < 0) {
if (state.status == PARSE_INCOMPLETE)
error(_("unexpected end of input"));
return;
}
}
}
static unsigned char DLLbuf[CONSOLE_BUFFER_SIZE+1], *DLLbufp;
static void check_session_exit()
{
if (! R_Interactive) {
/* This funtion will be called again after a LONGJMP if an
error is signaled from one of the functions called. The
'exiting' variable identifies this and results in
R_Suicide. */
static Rboolean exiting = FALSE;
if (exiting)
R_Suicide(_("error during cleanup\n"));
else {
exiting = TRUE;
if (GetOption1(install("error")) != R_NilValue) {
exiting = FALSE;
return;
}
REprintf(_("Execution halted\n"));
R_CleanUp(SA_NOSAVE, 1, 0); /* quit, no save, no .Last, status=1 */
}
}
}
void R_ReplDLLinit(void)
{
if (SETJMP(R_Toplevel.cjmpbuf))
check_session_exit();
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
R_IoBufferWriteReset(&R_ConsoleIob);
prompt_type = 1;
DLLbuf[0] = DLLbuf[CONSOLE_BUFFER_SIZE] = '\0';
DLLbufp = DLLbuf;
}
/* FIXME: this should be re-written to use Rf_ReplIteration
since it gets out of sync with it over time */
int R_ReplDLLdo1(void)
{
int c;
ParseStatus status;
SEXP rho = R_GlobalEnv, lastExpr;
Rboolean wasDisplayed = FALSE;
if(!*DLLbufp) {
R_Busy(0);
if (R_ReadConsole(R_PromptString(0, prompt_type), DLLbuf,
CONSOLE_BUFFER_SIZE, 1) == 0)
return -1;
DLLbufp = DLLbuf;
}
while((c = *DLLbufp++)) {
R_IoBufferPutc(c, &R_ConsoleIob);
if(c == ';' || c == '\n') break;
}
R_PPStackTop = 0;
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &status);
switch(status) {
case PARSE_NULL:
R_IoBufferWriteReset(&R_ConsoleIob);
prompt_type = 1;
break;
case PARSE_OK:
R_IoBufferReadReset(&R_ConsoleIob);
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &status);
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
PROTECT(R_CurrentExpr);
R_Busy(1);
lastExpr = R_CurrentExpr;
R_CurrentExpr = eval(R_CurrentExpr, rho);
SET_SYMVALUE(R_LastvalueSymbol, R_CurrentExpr);
wasDisplayed = R_Visible;
if (R_Visible)
PrintValueEnv(R_CurrentExpr, rho);
if (R_CollectWarnings)
PrintWarnings();
Rf_callToplevelHandlers(lastExpr, R_CurrentExpr, TRUE, wasDisplayed);
UNPROTECT(1);
R_IoBufferWriteReset(&R_ConsoleIob);
R_Busy(0);
prompt_type = 1;
break;
case PARSE_ERROR:
parseError(R_NilValue, 0);
R_IoBufferWriteReset(&R_ConsoleIob);
prompt_type = 1;
break;
case PARSE_INCOMPLETE:
R_IoBufferReadReset(&R_ConsoleIob);
prompt_type = 2;
break;
case PARSE_EOF:
return -1;
break;
}
return prompt_type;
}
/* Main Loop: It is assumed that at this point that operating system */
/* specific tasks (dialog window creation etc) have been performed. */
/* We can now print a greeting, run the .First function and then enter */
/* the read-eval-print loop. */
static RETSIGTYPE handleInterrupt(int dummy)
{
R_interrupts_pending = 1;
signal(SIGINT, handleInterrupt);
}
/* this flag is set if R internal code is using send() and does not
want to trigger an error on SIGPIPE (e.g., the httpd code).
[It is safer and more portable than other methods of handling
broken pipes on send().]
*/
#ifndef Win32
// controlled by the internal http server in the internet module
int R_ignore_SIGPIPE = 0;
static RETSIGTYPE handlePipe(int dummy)
{
signal(SIGPIPE, handlePipe);
if (!R_ignore_SIGPIPE) error("ignoring SIGPIPE signal");
}
#endif
#ifdef Win32
static int num_caught = 0;
static void win32_segv(int signum)
{
/* NB: stack overflow is not an access violation on Win32 */
{ /* A simple customized print of the traceback */
SEXP trace, p, q;
int line = 1, i;
PROTECT(trace = R_GetTraceback(0));
if(trace != R_NilValue) {
REprintf("\nTraceback:\n");
for(p = trace; p != R_NilValue; p = CDR(p), line++) {
q = CAR(p); /* a character vector */
REprintf("%2d: ", line);
for(i = 0; i < LENGTH(q); i++)
REprintf("%s", CHAR(STRING_ELT(q, i)));
REprintf("\n");
}
UNPROTECT(1);
}
}
num_caught++;
if(num_caught < 10) signal(signum, win32_segv);
if(signum == SIGILL)
error("caught access violation - continue with care");
else
error("caught access violation - continue with care");
}
#endif
#if defined(HAVE_SIGALTSTACK) && defined(HAVE_SIGACTION) && defined(HAVE_WORKING_SIGACTION) && defined(HAVE_SIGEMPTYSET)
/* NB: this really isn't safe, but suffices for experimentation for now.
In due course just set a flag and do this after the return. OTOH,
if we do want to bail out with a core dump, need to do that here.
2005-12-17 BDR */
static unsigned char ConsoleBuf[CONSOLE_BUFFER_SIZE];
static void sigactionSegv(int signum, siginfo_t *ip, void *context)
{
char *s;
/* First check for stack overflow if we know the stack position.
We assume anything within 16Mb beyond the stack end is a stack overflow.
*/
if(signum == SIGSEGV && (ip != (siginfo_t *)0) &&
(intptr_t) R_CStackStart != -1) {
uintptr_t addr = (uintptr_t) ip->si_addr;
intptr_t diff = (R_CStackDir > 0) ? R_CStackStart - addr:
addr - R_CStackStart;
uintptr_t upper = 0x1000000; /* 16Mb */
if((intptr_t) R_CStackLimit != -1) upper += R_CStackLimit;
if(diff > 0 && diff < upper) {
REprintf(_("Error: segfault from C stack overflow\n"));
#if defined(linux) || defined(__linux__) || defined(__sun) || defined(sun)
sigset_t ss;
sigaddset(&ss, signum);
sigprocmask(SIG_UNBLOCK, &ss, NULL);
#endif
jump_to_toplevel();
}
}
/* need to take off stack checking as stack base has changed */
R_CStackLimit = (uintptr_t)-1;
/* Do not translate these messages */
REprintf("\n *** caught %s ***\n",
signum == SIGILL ? "illegal operation" :
signum == SIGBUS ? "bus error" : "segfault");
if(ip != (siginfo_t *)0) {
if(signum == SIGILL) {
switch(ip->si_code) {
#ifdef ILL_ILLOPC
case ILL_ILLOPC:
s = "illegal opcode";
break;
#endif
#ifdef ILL_ILLOPN
case ILL_ILLOPN:
s = "illegal operand";
break;
#endif
#ifdef ILL_ILLADR
case ILL_ILLADR:
s = "illegal addressing mode";
break;
#endif
#ifdef ILL_ILLTRP
case ILL_ILLTRP:
s = "illegal trap";
break;
#endif
#ifdef ILL_COPROC
case ILL_COPROC:
s = "coprocessor error";
break;
#endif
default:
s = "unknown";
break;
}
} else if(signum == SIGBUS)
switch(ip->si_code) {
#ifdef BUS_ADRALN
case BUS_ADRALN:
s = "invalid alignment";
break;
#endif
#ifdef BUS_ADRERR /* not on macOS, apparently */
case BUS_ADRERR:
s = "non-existent physical address";
break;
#endif
#ifdef BUS_OBJERR /* not on macOS, apparently */
case BUS_OBJERR:
s = "object specific hardware error";
break;
#endif
default:
s = "unknown";
break;
}
else
switch(ip->si_code) {
#ifdef SEGV_MAPERR
case SEGV_MAPERR:
s = "memory not mapped";
break;
#endif
#ifdef SEGV_ACCERR
case SEGV_ACCERR:
s = "invalid permissions";
break;
#endif
default:
s = "unknown";
break;
}
REprintf("address %p, cause '%s'\n", ip->si_addr, s);
}
{ /* A simple customized print of the traceback */
SEXP trace, p, q;
int line = 1, i;
PROTECT(trace = R_GetTraceback(0));
if(trace != R_NilValue) {
REprintf("\nTraceback:\n");
for(p = trace; p != R_NilValue; p = CDR(p), line++) {
q = CAR(p); /* a character vector */
REprintf("%2d: ", line);
for(i = 0; i < LENGTH(q); i++)
REprintf("%s", CHAR(STRING_ELT(q, i)));
REprintf("\n");
}
UNPROTECT(1);
}
}
if(R_Interactive) {
REprintf("\nPossible actions:\n1: %s\n2: %s\n3: %s\n4: %s\n",
"abort (with core dump, if enabled)",
"normal R exit",
"exit R without saving workspace",
"exit R saving workspace");
while(1) {
if(R_ReadConsole("Selection: ", ConsoleBuf, CONSOLE_BUFFER_SIZE,
0) > 0) {
if(ConsoleBuf[0] == '1') break;
if(ConsoleBuf[0] == '2') R_CleanUp(SA_DEFAULT, 0, 1);
if(ConsoleBuf[0] == '3') R_CleanUp(SA_NOSAVE, 70, 0);
if(ConsoleBuf[0] == '4') R_CleanUp(SA_SAVE, 71, 0);
}
}
REprintf("R is aborting now ...\n");
}
else // non-interactively :
REprintf("An irrecoverable exception occurred. R is aborting now ...\n");
R_CleanTempDir();
/* now do normal behaviour, e.g. core dump */
signal(signum, SIG_DFL);
raise(signum);
}
#ifndef SIGSTKSZ
# define SIGSTKSZ 8192 /* just a guess */
#endif
#ifdef HAVE_STACK_T
static stack_t sigstk;
#else
static struct sigaltstack sigstk;
#endif
static void *signal_stack;
#define R_USAGE 100000 /* Just a guess */
static void init_signal_handlers(void)
{
/* <FIXME> may need to reinstall this if we do recover. */
struct sigaction sa;
signal_stack = malloc(SIGSTKSZ + R_USAGE);
if (signal_stack != NULL) {
sigstk.ss_sp = signal_stack;
sigstk.ss_size = SIGSTKSZ + R_USAGE;
sigstk.ss_flags = 0;
if(sigaltstack(&sigstk, NULL) < 0)
warning("failed to set alternate signal stack");
} else
warning("failed to allocate alternate signal stack");
sa.sa_sigaction = sigactionSegv;
sigemptyset(&sa.sa_mask);
sa.sa_flags = SA_ONSTACK | SA_SIGINFO;
sigaction(SIGSEGV, &sa, NULL);
sigaction(SIGILL, &sa, NULL);
#ifdef SIGBUS
sigaction(SIGBUS, &sa, NULL);
#endif
signal(SIGINT, handleInterrupt);
signal(SIGUSR1, onsigusr1);
signal(SIGUSR2, onsigusr2);
signal(SIGPIPE, handlePipe);
}
#else /* not sigaltstack and sigaction and sigemptyset*/
static void init_signal_handlers(void)
{
signal(SIGINT, handleInterrupt);
signal(SIGUSR1, onsigusr1);
signal(SIGUSR2, onsigusr2);
#ifndef Win32
signal(SIGPIPE, handlePipe);
#else
signal(SIGSEGV, win32_segv);
signal(SIGILL, win32_segv);
#endif
}
#endif
static void R_LoadProfile(FILE *fparg, SEXP env)
{
FILE * volatile fp = fparg; /* is this needed? */
if (fp != NULL) {
if (SETJMP(R_Toplevel.cjmpbuf))
check_session_exit();
else {
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
R_ReplFile(fp, env);
}
fclose(fp);
}
}
int R_SignalHandlers = 1; /* Exposed in R_interface.h */
const char* get_workspace_name(); /* from startup.c */
void attribute_hidden BindDomain(char *R_Home)
{
#ifdef ENABLE_NLS
char localedir[PATH_MAX+20];
setlocale(LC_MESSAGES,"");
textdomain(PACKAGE);
char *p = getenv("R_TRANSLATIONS");
if (p) snprintf(localedir, PATH_MAX+20, "%s", p);
else snprintf(localedir, PATH_MAX+20, "%s/library/translations", R_Home);
bindtextdomain(PACKAGE, localedir); // PACKAGE = DOMAIN = "R"
bindtextdomain("R-base", localedir);
# ifdef _WIN32
bindtextdomain("RGui", localedir);
# endif
#endif
}
/* #define DEBUG_STACK_DETECTION */
/* Not to be enabled in production use: the debugging code is more fragile
than the detection itself. */
#ifdef DEBUG_STACK_DETECTION
static uintptr_t almostFillStack() {
volatile uintptr_t dummy;
dummy = (uintptr_t) &dummy;
if (R_CStackStart - R_CStackDir * R_CStackLimit + R_CStackDir * 1024 < R_CStackDir * dummy)
return almostFillStack();
else
return dummy;
}
#endif
void setup_Rmainloop(void)
{
volatile int doneit;
volatile SEXP baseNSenv;
SEXP cmd;
char deferred_warnings[11][250];
volatile int ndeferred_warnings = 0;
#ifdef DEBUG_STACK_DETECTION
/* testing stack base and size detection */
printf("stack limit %ld, start %lx dir %d \n",
(unsigned long) R_CStackLimit,
(unsigned long) R_CStackStart,
R_CStackDir);
uintptr_t firstb = R_CStackStart - R_CStackDir;
printf("first accessible byte %lx\n", (unsigned long) firstb);
if (R_CStackLimit != (uintptr_t)(-1)) {
uintptr_t lastb = R_CStackStart - R_CStackDir * R_CStackLimit;
printf("last accessible byte %lx\n", (unsigned long) lastb);
}
printf("accessing first byte...\n");
volatile char dummy = *(char *)firstb;
if (R_CStackLimit != (uintptr_t)(-1)) {
/* have to access all bytes in order to map stack, e.g. on Linux
just reading does not seem to always do the job, so better
first almost fill up the stack using recursive function calls
*/
printf("almost filling up stack...\n");
printf("filled stack up to %lx\n", almostFillStack());
printf("accessing all bytes...\n");
for(uintptr_t o = 0; o < R_CStackLimit; o++)
/* with exact bounds, o==-1 and o==R_CStackLimit will segfault */
/* +dummy to silence -Wunused-but-set-variable */
dummy = *((char *)firstb - R_CStackDir * o) + dummy;
}
#endif
/* In case this is a silly limit: 2^32 -3 has been seen and
* casting to intptr_r relies on this being smaller than 2^31 on a
* 32-bit platform. */
if(R_CStackLimit > 100000000U)
R_CStackLimit = (uintptr_t)-1;
/* make sure we have enough head room to handle errors */
if(R_CStackLimit != -1)
R_CStackLimit = (uintptr_t)(0.95 * R_CStackLimit);
InitConnections(); /* needed to get any output at all */
/* Initialize the interpreter's internal structures. */
#ifdef HAVE_LOCALE_H
#ifdef Win32
{
char allbuf[1000]; /* Windows' locales can be very long */
char *p, *lcall;
p = getenv("LC_ALL");
if(p) {
strncpy(allbuf, p, sizeof(allbuf));
allbuf[1000 - 1] = '\0';
lcall = allbuf;
} else
lcall = NULL;
/* We'd like to use warning, but need to defer.
Also cannot translate. */
p = lcall ? lcall : getenv("LC_COLLATE");
if(!setlocale(LC_COLLATE, p ? p : ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE=%.200s failed\n", p);
p = lcall ? lcall : getenv("LC_CTYPE");
if(!setlocale(LC_CTYPE, p ? p : ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE=%.200s failed\n", p);
p = lcall ? lcall : getenv("LC_MONETARY");
if(!setlocale(LC_MONETARY, p ? p : ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY=%.200s failed\n", p);
p = lcall ? lcall : getenv("LC_TIME");
if(!setlocale(LC_TIME, p ? p : ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME=%.200s failed\n", p);
/* We set R_ARCH here: Unix does it in the shell front-end */
char Rarch[30];
strcpy(Rarch, "R_ARCH=/");
strcat(Rarch, R_ARCH);
putenv(Rarch);
}
#else /* not Win32 */
if(!setlocale(LC_CTYPE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE failed, using \"C\"\n");
if(!setlocale(LC_COLLATE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE failed, using \"C\"\n");
if(!setlocale(LC_TIME, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME failed, using \"C\"\n");
#ifdef ENABLE_NLS
if(!setlocale(LC_MESSAGES, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MESSAGES failed, using \"C\"\n");
#endif
/* NB: we do not set LC_NUMERIC */
#ifdef LC_MONETARY
if(!setlocale(LC_MONETARY, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY failed, using \"C\"\n");
#endif
#ifdef LC_PAPER
if(!setlocale(LC_PAPER, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_PAPER failed, using \"C\"\n");
#endif
#ifdef LC_MEASUREMENT
if(!setlocale(LC_MEASUREMENT, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MEASUREMENT failed, using \"C\"\n");
#endif
#endif /* not Win32 */
#endif
/* make sure srand is called before R_tmpnam, PR#14381 */
srand(TimeToSeed());
InitArithmetic();
InitTempDir(); /* must be before InitEd */
InitMemory();
InitStringHash(); /* must be before InitNames */
InitBaseEnv();
InitNames(); /* must be after InitBaseEnv to use R_EmptyEnv */
InitParser(); /* must be after InitMemory, InitNames */
InitGlobalEnv();
InitDynload();
InitOptions();
InitEd();
InitGraphics();
InitTypeTables(); /* must be before InitS3DefaultTypes */
InitS3DefaultTypes();
PrintDefaults();
R_Is_Running = 1;
R_check_locale();
/* Initialize the global context for error handling. */
/* This provides a target for any non-local gotos */
/* which occur during error handling */
R_Toplevel.nextcontext = NULL;
R_Toplevel.callflag = CTXT_TOPLEVEL;
R_Toplevel.cstacktop = 0;
R_Toplevel.gcenabled = R_GCEnabled;
R_Toplevel.promargs = R_NilValue;
R_Toplevel.callfun = R_NilValue;
R_Toplevel.call = R_NilValue;
R_Toplevel.cloenv = R_BaseEnv;
R_Toplevel.sysparent = R_BaseEnv;
R_Toplevel.conexit = R_NilValue;
R_Toplevel.vmax = NULL;
R_Toplevel.nodestack = R_BCNodeStackTop;
R_Toplevel.bcprottop = R_BCProtTop;
R_Toplevel.cend = NULL;
R_Toplevel.cenddata = NULL;
R_Toplevel.intsusp = FALSE;
R_Toplevel.handlerstack = R_HandlerStack;
R_Toplevel.restartstack = R_RestartStack;
R_Toplevel.srcref = R_NilValue;
R_Toplevel.prstack = NULL;
R_Toplevel.returnValue = NULL;
R_Toplevel.evaldepth = 0;
R_Toplevel.browserfinish = 0;
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
R_ExitContext = NULL;
R_Warnings = R_NilValue;
/* This is the same as R_BaseEnv, but this marks the environment
of functions as the namespace and not the package. */
baseNSenv = R_BaseNamespace;
/* Set up some global variables */
Init_R_Variables(baseNSenv);
/* On initial entry we open the base language package and begin by
running the repl on it.
If there is an error we pass on to the repl.
Perhaps it makes more sense to quit gracefully?
*/
#ifdef RMIN_ONLY
/* This is intended to support a minimal build for experimentation. */
if (R_SignalHandlers) init_signal_handlers();
#else
FILE *fp = R_OpenLibraryFile("base");
if (fp == NULL)
R_Suicide(_("unable to open the base package\n"));
doneit = 0;
if (SETJMP(R_Toplevel.cjmpbuf))
check_session_exit();
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (R_SignalHandlers) init_signal_handlers();
if (!doneit) {
doneit = 1;
R_ReplFile(fp, baseNSenv);
}
fclose(fp);
#endif
/* This is where we source the system-wide, the site's and the
user's profile (in that order). If there is an error, we
drop through to further processing.
*/
R_IoBufferInit(&R_ConsoleIob);
R_LoadProfile(R_OpenSysInitFile(), baseNSenv);
/* These are the same bindings, so only lock them once */
R_LockEnvironment(R_BaseNamespace, TRUE);
R_LockEnvironment(R_BaseEnv, FALSE);
/* At least temporarily unlock some bindings used in graphics */
R_unLockBinding(R_DeviceSymbol, R_BaseEnv);
R_unLockBinding(R_DevicesSymbol, R_BaseEnv);
/* require(methods) if it is in the default packages */
doneit = 0;
if (SETJMP(R_Toplevel.cjmpbuf))
check_session_exit();
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".OptRequireMethods"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
if (strcmp(R_GUIType, "Tk") == 0) {
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, "%s/library/tcltk/exec/Tk-frontend.R", R_Home);
R_LoadProfile(R_fopen(buf, "r"), R_GlobalEnv);
}