1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1998--2021 The R Core Team.
4 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21
22 #ifdef HAVE_CONFIG_H
23 # include <config.h>
24 #endif
25
26 #define R_USE_SIGNALS 1
27 #include <Defn.h>
28 #include <Internal.h>
29 #include <Rinterface.h>
30 #include <Fileio.h>
31 #include <R_ext/Print.h>
32
33
34 static SEXP bcEval(SEXP, SEXP, Rboolean);
35
36 /* BC_PROFILING needs to be enabled at build time. It is not enabled
37 by default as enabling it disables the more efficient threaded code
38 implementation of the byte code interpreter. */
39 #ifdef BC_PROFILING
40 static Rboolean bc_profiling = FALSE;
41 #endif
42
43 static int R_Profiling = 0;
44
45 #ifdef R_PROFILING
46
47 /* BDR 2000-07-15
48 Profiling is now controlled by the R function Rprof(), and should
49 have negligible cost when not enabled.
50 */
51
52 /* A simple mechanism for profiling R code. When R_PROFILING is
53 enabled, eval will write out the call stack every PROFSAMPLE
54 microseconds using the SIGPROF handler triggered by timer signals
55 from the ITIMER_PROF timer. Since this is the same timer used by C
56 profiling, the two cannot be used together. Output is written to
57 the file PROFOUTNAME. This is a plain text file. The first line
58 of the file contains the value of PROFSAMPLE. The remaining lines
59 each give the call stack found at a sampling point with the inner
60 most function first.
61
62 To enable profiling, recompile eval.c with R_PROFILING defined. It
63 would be possible to selectively turn profiling on and off from R
64 and to specify the file name from R as well, but for now I won't
65 bother.
66
67 The stack is traced by walking back along the context stack, just
68 like the traceback creation in jump_to_toplevel. One drawback of
69 this approach is that it does not show BUILTIN's since they don't
70 get a context. With recent changes to pos.to.env it seems possible
71 to insert a context around BUILTIN calls to that they show up in
72 the trace. Since there is a cost in establishing these contexts,
73 they are only inserted when profiling is enabled. [BDR: we have since
74 also added contexts for the BUILTIN calls to foreign code.]
75
76 One possible advantage of not tracing BUILTIN's is that then
77 profiling adds no cost when the timer is turned off. This would be
78 useful if we want to allow profiling to be turned on and off from
79 within R.
80
81 One thing that makes interpreting profiling output tricky is lazy
82 evaluation. When an expression f(g(x)) is profiled, lazy
83 evaluation will cause g to be called inside the call to f, so it
84 will appear as if g is called by f.
85
86 L. T. */
87
88 #ifdef Win32
89 # define WIN32_LEAN_AND_MEAN 1
90 # include <windows.h> /* for CreateEvent, SetEvent */
91 # include <process.h> /* for _beginthread, _endthread */
92 #else
93 # ifdef HAVE_SYS_TIME_H
94 # include <sys/time.h>
95 # endif
96 # include <signal.h>
97 #endif /* not Win32 */
98
99 static FILE *R_ProfileOutfile = NULL;
100 static int R_Mem_Profiling=0;
101 static int R_GC_Profiling = 0; /* indicates GC profiling */
102 static int R_Line_Profiling = 0; /* indicates line profiling, and also counts the filenames seen (+1) */
103 static char **R_Srcfiles; /* an array of pointers into the filename buffer */
104 static size_t R_Srcfile_bufcount; /* how big is the array above? */
105 static SEXP R_Srcfiles_buffer = NULL; /* a big RAWSXP to use as a buffer for filenames and pointers to them */
106 static int R_Profiling_Error; /* record errors here */
107 static int R_Filter_Callframes = 0; /* whether to record only the trailing branch of call trees */
108
109 #ifdef Win32
110 HANDLE MainThread;
111 HANDLE ProfileEvent;
112 #endif /* Win32 */
113
114 /* Careful here! These functions are called asynchronously, maybe in the middle of GC,
115 so don't do any allocations */
116
117 /* This does a linear search through the previously recorded filenames. If
118 this one is new, we try to add it. FIXME: if there are eventually
119 too many files for an efficient linear search, do hashing. */
120
getFilenum(const char * filename)121 static int getFilenum(const char* filename) {
122 int fnum;
123
124 for (fnum = 0; fnum < R_Line_Profiling-1
125 && strcmp(filename, R_Srcfiles[fnum]); fnum++);
126
127 if (fnum == R_Line_Profiling-1) {
128 size_t len = strlen(filename);
129 if (fnum >= R_Srcfile_bufcount) { /* too many files */
130 R_Profiling_Error = 1;
131 return 0;
132 }
133 if (R_Srcfiles[fnum] - (char*)RAW(R_Srcfiles_buffer) + len + 1 > length(R_Srcfiles_buffer)) {
134 /* out of space in the buffer */
135 R_Profiling_Error = 2;
136 return 0;
137 }
138 strcpy(R_Srcfiles[fnum], filename);
139 R_Srcfiles[fnum+1] = R_Srcfiles[fnum] + len + 1;
140 *(R_Srcfiles[fnum+1]) = '\0';
141 R_Line_Profiling++;
142 }
143
144 return fnum + 1;
145 }
146
147 /* These, together with sprintf/strcat, are not safe -- we should be
148 using snprintf and such and computing needed sizes, but these
149 settings are better than what we had. LT */
150
151 #define PROFBUFSIZ 10500
152 #define PROFITEMMAX 500
153 #define PROFLINEMAX (PROFBUFSIZ - PROFITEMMAX)
154
155 /* It would also be better to flush the buffer when it gets full,
156 even if the line isn't complete. But this isn't possible if we rely
157 on writing all line profiling files first. With these sizes
158 hitting the limit is fairly unlikely, but if we do then the output
159 file is wrong. Maybe writing an overflow marker of some sort would
160 be better. LT */
161
lineprof(char * buf,SEXP srcref)162 static void lineprof(char* buf, SEXP srcref)
163 {
164 size_t len;
165 if (srcref && !isNull(srcref) && (len = strlen(buf)) < PROFLINEMAX) {
166 int fnum, line = asInteger(srcref);
167 SEXP srcfile = getAttrib(srcref, R_SrcfileSymbol);
168 const char *filename;
169
170 if (!srcfile || TYPEOF(srcfile) != ENVSXP) return;
171 srcfile = findVar(install("filename"), srcfile);
172 if (TYPEOF(srcfile) != STRSXP || !length(srcfile)) return;
173 filename = CHAR(STRING_ELT(srcfile, 0));
174
175 if ((fnum = getFilenum(filename)))
176 snprintf(buf+len, PROFBUFSIZ - len, "%d#%d ", fnum, line);
177 }
178 }
179
180 #if !defined(Win32) && defined(HAVE_PTHREAD)
181 // <signal.h> is needed for pthread_kill on most platforms (and by POSIX
182 // but apparently not FreeBSD): it is included above.
183 # include <pthread.h>
184 static pthread_t R_profiled_thread;
185 #endif
186
findProfContext(RCNTXT * cptr)187 static RCNTXT * findProfContext(RCNTXT *cptr)
188 {
189 if (! R_Filter_Callframes)
190 return cptr->nextcontext;
191
192 if (cptr == R_ToplevelContext)
193 return NULL;
194
195 /* Find parent context, same algorithm as in `parent.frame()`. */
196 RCNTXT * parent = R_findParentContext(cptr, 1);
197
198 /* If we're in a frame called by `eval()`, find the evaluation
199 environment higher up the stack, if any. */
200 if (parent && parent->callfun == INTERNAL(R_EvalSymbol))
201 parent = R_findExecContext(parent->nextcontext, cptr->sysparent);
202
203 if (parent)
204 return parent;
205
206 /* Base case, this interrupts the iteration over context frames */
207 if (cptr->nextcontext == R_ToplevelContext)
208 return NULL;
209
210 /* There is no parent frame and we haven't reached the top level
211 context. Find the very first context on the stack which should
212 always be included in the profiles. */
213 while (cptr->nextcontext != R_ToplevelContext)
214 cptr = cptr->nextcontext;
215 return cptr;
216 }
217
doprof(int sig)218 static void doprof(int sig) /* sig is ignored in Windows */
219 {
220 char buf[PROFBUFSIZ];
221 size_t bigv, smallv, nodes;
222 size_t len;
223 int prevnum = R_Line_Profiling;
224
225 buf[0] = '\0';
226
227 #ifdef Win32
228 SuspendThread(MainThread);
229 #elif defined(HAVE_PTHREAD)
230 if (! pthread_equal(pthread_self(), R_profiled_thread)) {
231 pthread_kill(R_profiled_thread, sig);
232 return;
233 }
234 #endif /* Win32 */
235
236 if (R_Mem_Profiling){
237 get_current_mem(&smallv, &bigv, &nodes);
238 if((len = strlen(buf)) < PROFLINEMAX)
239 snprintf(buf+len, PROFBUFSIZ - len,
240 ":%lu:%lu:%lu:%lu:",
241 (unsigned long) smallv, (unsigned long) bigv,
242 (unsigned long) nodes, get_duplicate_counter());
243 reset_duplicate_counter();
244 }
245
246 if (R_GC_Profiling && R_gc_running())
247 strcat(buf, "\"<GC>\" ");
248
249 if (R_Line_Profiling)
250 lineprof(buf, R_getCurrentSrcref());
251
252 for (RCNTXT *cptr = R_GlobalContext;
253 cptr != NULL;
254 cptr = findProfContext(cptr)) {
255 if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
256 && TYPEOF(cptr->call) == LANGSXP) {
257 SEXP fun = CAR(cptr->call);
258 if(strlen(buf) < PROFLINEMAX) {
259 strcat(buf, "\"");
260
261 char itembuf[PROFITEMMAX];
262
263 if (TYPEOF(fun) == SYMSXP) {
264 snprintf(itembuf, PROFITEMMAX-1, "%s", CHAR(PRINTNAME(fun)));
265
266 } else if ((CAR(fun) == R_DoubleColonSymbol ||
267 CAR(fun) == R_TripleColonSymbol ||
268 CAR(fun) == R_DollarSymbol) &&
269 TYPEOF(CADR(fun)) == SYMSXP &&
270 TYPEOF(CADDR(fun)) == SYMSXP) {
271 /* Function accessed via ::, :::, or $. Both args must be
272 symbols. It is possible to use strings with these
273 functions, as in "base"::"list", but that's a very rare
274 case so we won't bother handling it. */
275 snprintf(itembuf, PROFITEMMAX-1, "%s%s%s",
276 CHAR(PRINTNAME(CADR(fun))),
277 CHAR(PRINTNAME(CAR(fun))),
278 CHAR(PRINTNAME(CADDR(fun))));
279
280 } else if (CAR(fun) == R_Bracket2Symbol &&
281 TYPEOF(CADR(fun)) == SYMSXP &&
282 ((TYPEOF(CADDR(fun)) == SYMSXP ||
283 TYPEOF(CADDR(fun)) == STRSXP ||
284 TYPEOF(CADDR(fun)) == INTSXP ||
285 TYPEOF(CADDR(fun)) == REALSXP) &&
286 length(CADDR(fun)) > 0)) {
287 /* Function accessed via [[. The first arg must be a symbol
288 and the second can be a symbol, string, integer, or
289 real. */
290 SEXP arg1 = CADR(fun);
291 SEXP arg2 = CADDR(fun);
292 char arg2buf[PROFITEMMAX-5];
293
294 if (TYPEOF(arg2) == SYMSXP) {
295 snprintf(arg2buf, PROFITEMMAX-6, "%s", CHAR(PRINTNAME(arg2)));
296
297 } else if (TYPEOF(arg2) == STRSXP) {
298 snprintf(arg2buf, PROFITEMMAX-6, "\"%s\"", CHAR(STRING_ELT(arg2, 0)));
299
300 } else if (TYPEOF(arg2) == INTSXP) {
301 snprintf(arg2buf, PROFITEMMAX-6, "%d", INTEGER(arg2)[0]);
302
303 } else if (TYPEOF(arg2) == REALSXP) {
304 snprintf(arg2buf, PROFITEMMAX-6, "%.0f", REAL(arg2)[0]);
305
306 } else {
307 /* Shouldn't get here, but just in case. */
308 arg2buf[0] = '\0';
309 }
310
311 snprintf(itembuf, PROFITEMMAX-1, "%s[[%s]]",
312 CHAR(PRINTNAME(arg1)),
313 arg2buf);
314
315 } else {
316 sprintf(itembuf, "<Anonymous>");
317 }
318
319 strcat(buf, itembuf);
320 strcat(buf, "\" ");
321 if (R_Line_Profiling) {
322 if (cptr->srcref == R_InBCInterpreter)
323 lineprof(buf,
324 R_findBCInterpreterSrcref(cptr));
325 else
326 lineprof(buf, cptr->srcref);
327 }
328 }
329 }
330 }
331
332 /* I believe it would be slightly safer to place this _after_ the
333 next two bits, along with the signal() call. LT */
334 #ifdef Win32
335 ResumeThread(MainThread);
336 #endif /* Win32 */
337
338 for (int i = prevnum; i < R_Line_Profiling; i++)
339 fprintf(R_ProfileOutfile, "#File %d: %s\n", i, R_Srcfiles[i-1]);
340
341 if(strlen(buf))
342 fprintf(R_ProfileOutfile, "%s\n", buf);
343
344 #ifndef Win32
345 signal(SIGPROF, doprof);
346 #endif /* not Win32 */
347
348 }
349
350 #ifdef Win32
351 /* Profiling thread main function */
ProfileThread(void * pwait)352 static void __cdecl ProfileThread(void *pwait)
353 {
354 int wait = *((int *)pwait);
355
356 SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_HIGHEST);
357 while(WaitForSingleObject(ProfileEvent, wait) != WAIT_OBJECT_0) {
358 doprof(0);
359 }
360 }
361 #else /* not Win32 */
doprof_null(int sig)362 static void doprof_null(int sig)
363 {
364 signal(SIGPROF, doprof_null);
365 }
366 #endif /* not Win32 */
367
368
R_EndProfiling(void)369 static void R_EndProfiling(void)
370 {
371 #ifdef Win32
372 SetEvent(ProfileEvent);
373 CloseHandle(MainThread);
374 #else /* not Win32 */
375 struct itimerval itv;
376
377 itv.it_interval.tv_sec = 0;
378 itv.it_interval.tv_usec = 0;
379 itv.it_value.tv_sec = 0;
380 itv.it_value.tv_usec = 0;
381 setitimer(ITIMER_PROF, &itv, NULL);
382 signal(SIGPROF, doprof_null);
383
384 #endif /* not Win32 */
385 if(R_ProfileOutfile) fclose(R_ProfileOutfile);
386 R_ProfileOutfile = NULL;
387 R_Profiling = 0;
388 if (R_Srcfiles_buffer) {
389 R_ReleaseObject(R_Srcfiles_buffer);
390 R_Srcfiles_buffer = NULL;
391 }
392 if (R_Profiling_Error)
393 warning(_("source files skipped by Rprof; please increase '%s'"),
394 R_Profiling_Error == 1 ? "numfiles" : "bufsize");
395 }
396
R_InitProfiling(SEXP filename,int append,double dinterval,int mem_profiling,int gc_profiling,int line_profiling,int filter_callframes,int numfiles,int bufsize)397 static void R_InitProfiling(SEXP filename, int append, double dinterval,
398 int mem_profiling, int gc_profiling,
399 int line_profiling, int filter_callframes,
400 int numfiles, int bufsize)
401 {
402 #ifndef Win32
403 struct itimerval itv;
404 #else
405 int wait;
406 HANDLE Proc = GetCurrentProcess();
407 #endif
408 int interval;
409
410 interval = (int)(1e6 * dinterval + 0.5);
411 if(R_ProfileOutfile != NULL) R_EndProfiling();
412 R_ProfileOutfile = RC_fopen(filename, append ? "a" : "w", TRUE);
413 if (R_ProfileOutfile == NULL)
414 error(_("Rprof: cannot open profile file '%s'"),
415 translateChar(filename));
416 if(mem_profiling)
417 fprintf(R_ProfileOutfile, "memory profiling: ");
418 if(gc_profiling)
419 fprintf(R_ProfileOutfile, "GC profiling: ");
420 if(line_profiling)
421 fprintf(R_ProfileOutfile, "line profiling: ");
422 fprintf(R_ProfileOutfile, "sample.interval=%d\n", interval);
423
424 R_Mem_Profiling=mem_profiling;
425 if (mem_profiling)
426 reset_duplicate_counter();
427
428 R_Profiling_Error = 0;
429 R_Line_Profiling = line_profiling;
430 R_GC_Profiling = gc_profiling;
431 R_Filter_Callframes = filter_callframes;
432
433 if (line_profiling) {
434 /* Allocate a big RAW vector to use as a buffer. The first len1 bytes are an array of pointers
435 to strings; the actual strings are stored in the second len2 bytes. */
436 R_Srcfile_bufcount = numfiles;
437 size_t len1 = R_Srcfile_bufcount*sizeof(char *), len2 = bufsize;
438 R_PreserveObject( R_Srcfiles_buffer = Rf_allocVector(RAWSXP, len1 + len2) );
439 // memset(RAW(R_Srcfiles_buffer), 0, len1+len2);
440 R_Srcfiles = (char **) RAW(R_Srcfiles_buffer);
441 R_Srcfiles[0] = (char *)RAW(R_Srcfiles_buffer) + len1;
442 *(R_Srcfiles[0]) = '\0';
443 }
444
445 #ifdef Win32
446 /* need to duplicate to make a real handle */
447 DuplicateHandle(Proc, GetCurrentThread(), Proc, &MainThread,
448 0, FALSE, DUPLICATE_SAME_ACCESS);
449 wait = interval/1000;
450 if(!(ProfileEvent = CreateEvent(NULL, FALSE, FALSE, NULL)) ||
451 (_beginthread(ProfileThread, 0, &wait) == -1))
452 R_Suicide("unable to create profiling thread");
453 Sleep(wait/2); /* suspend this thread to ensure that the other one starts */
454 #else /* not Win32 */
455 #ifdef HAVE_PTHREAD
456 R_profiled_thread = pthread_self();
457 #else
458 error("profiling requires 'pthread' support");
459 #endif
460
461 signal(SIGPROF, doprof);
462
463 itv.it_interval.tv_sec = interval / 1000000;
464 itv.it_interval.tv_usec =
465 (suseconds_t)(interval - itv.it_interval.tv_sec * 10000000);
466 itv.it_value.tv_sec = interval / 1000000;
467 itv.it_value.tv_usec =
468 (suseconds_t)(interval - itv.it_value.tv_sec * 1000000);
469 if (setitimer(ITIMER_PROF, &itv, NULL) == -1)
470 R_Suicide("setting profile timer failed");
471 #endif /* not Win32 */
472 R_Profiling = 1;
473 }
474
do_Rprof(SEXP args)475 SEXP do_Rprof(SEXP args)
476 {
477 SEXP filename;
478 int append_mode, mem_profiling, gc_profiling, line_profiling,
479 filter_callframes;
480 double dinterval;
481 int numfiles, bufsize;
482
483 #ifdef BC_PROFILING
484 if (bc_profiling) {
485 warning("cannot use R profiling while byte code profiling");
486 return R_NilValue;
487 }
488 #endif
489 if (!isString(filename = CAR(args)) || (LENGTH(filename)) != 1)
490 error(_("invalid '%s' argument"), "filename");
491 args = CDR(args);
492 append_mode = asLogical(CAR(args)); args = CDR(args);
493 dinterval = asReal(CAR(args)); args = CDR(args);
494 mem_profiling = asLogical(CAR(args)); args = CDR(args);
495 gc_profiling = asLogical(CAR(args)); args = CDR(args);
496 line_profiling = asLogical(CAR(args)); args = CDR(args);
497 filter_callframes = asLogical(CAR(args)); args = CDR(args);
498 numfiles = asInteger(CAR(args)); args = CDR(args);
499 if (numfiles < 0)
500 error(_("invalid '%s' argument"), "numfiles");
501 bufsize = asInteger(CAR(args));
502 if (bufsize < 0)
503 error(_("invalid '%s' argument"), "bufsize");
504
505 filename = STRING_ELT(filename, 0);
506 if (LENGTH(filename))
507 R_InitProfiling(filename, append_mode, dinterval, mem_profiling,
508 gc_profiling, line_profiling, filter_callframes,
509 numfiles, bufsize);
510 else
511 R_EndProfiling();
512 return R_NilValue;
513 }
514 #else /* not R_PROFILING */
do_Rprof(SEXP args)515 SEXP do_Rprof(SEXP args)
516 {
517 error(_("R profiling is not available on this system"));
518 return R_NilValue; /* -Wall */
519 }
520 #endif /* not R_PROFILING */
521
522 /* NEEDED: A fixup is needed in browser, because it can trap errors,
523 * and currently does not reset the limit to the right value. */
524
check_stack_balance(SEXP op,int save)525 void attribute_hidden check_stack_balance(SEXP op, int save)
526 {
527 if(save == R_PPStackTop) return;
528 REprintf("Warning: stack imbalance in '%s', %d then %d\n",
529 PRIMNAME(op), save, R_PPStackTop);
530 }
531
532
forcePromise(SEXP e)533 static SEXP forcePromise(SEXP e)
534 {
535 if (PRVALUE(e) == R_UnboundValue) {
536 RPRSTACK prstack;
537 SEXP val;
538 if(PRSEEN(e)) {
539 if (PRSEEN(e) == 1)
540 errorcall(R_GlobalContext->call,
541 _("promise already under evaluation: recursive default argument reference or earlier problems?"));
542 else {
543 /* set PRSEEN to 1 to avoid infinite recursion */
544 SET_PRSEEN(e, 1);
545 warningcall(R_GlobalContext->call,
546 _("restarting interrupted promise evaluation"));
547 }
548 }
549 /* Mark the promise as under evaluation and push it on a stack
550 that can be used to unmark pending promises if a jump out
551 of the evaluation occurs. */
552 SET_PRSEEN(e, 1);
553 prstack.promise = e;
554 prstack.next = R_PendingPromises;
555 R_PendingPromises = &prstack;
556
557 val = eval(PRCODE(e), PRENV(e));
558
559 /* Pop the stack, unmark the promise and set its value field.
560 Also set the environment to R_NilValue to allow GC to
561 reclaim the promise environment; this is also useful for
562 fancy games with delayedAssign() */
563 R_PendingPromises = prstack.next;
564 SET_PRSEEN(e, 0);
565 SET_PRVALUE(e, val);
566 ENSURE_NAMEDMAX(val);
567 SET_PRENV(e, R_NilValue);
568 }
569 return PRVALUE(e);
570 }
571
572
573 /*
574 * Protecting the Stack During Possibly Mutating Operations
575 *
576 * Values below R_BCProtTop should be protected during a mutating
577 * operation by incrementing their link counts. Actual incrementing is
578 * deferred until a call to INCLNK_stack_commit, which should happen
579 * before a mutation that might affect stack values. (applydefine() in
580 * the AST interpreter, STARTASSIGN/STARTASSIGN2 and INCLNK/INCLNKSTK
581 * in the byte code interpreter. Deferring until needed avoids the
582 * cost of incrementing and decrementing for code written in a
583 * functional style.
584 */
585
586 static R_bcstack_t *R_BCProtCommitted;
587
INCLNK_stack(R_bcstack_t * top)588 static R_INLINE void INCLNK_stack(R_bcstack_t *top)
589 {
590 R_BCProtTop = top;
591 }
592
INCLNK_stack_commit()593 static R_INLINE void INCLNK_stack_commit()
594 {
595 if (R_BCProtCommitted < R_BCProtTop) {
596 R_bcstack_t *base = R_BCProtCommitted;
597 R_bcstack_t *top = R_BCProtTop;
598 for (R_bcstack_t *p = base; p < top; p++) {
599 if (p->tag == RAWMEM_TAG || p->tag == CACHESZ_TAG)
600 p += p->u.ival;
601 else if (p->tag == 0)
602 INCREMENT_LINKS(p->u.sxpval);
603 }
604 R_BCProtCommitted = R_BCProtTop;
605 }
606 }
607
DECLNK_stack(R_bcstack_t * base)608 static R_INLINE void DECLNK_stack(R_bcstack_t *base)
609 {
610 if (base < R_BCProtCommitted) {
611 R_bcstack_t *top = R_BCProtCommitted;
612 for (R_bcstack_t *p = base; p < top; p++) {
613 if (p->tag == RAWMEM_TAG || p->tag == CACHESZ_TAG)
614 p += p->u.ival;
615 else if (p->tag == 0)
616 DECREMENT_LINKS(p->u.sxpval);
617 }
618 R_BCProtCommitted = base;
619 }
620 R_BCProtTop = base;
621 }
622
R_BCProtReset(R_bcstack_t * ptop)623 void attribute_hidden R_BCProtReset(R_bcstack_t *ptop)
624 {
625 DECLNK_stack(ptop);
626 }
627
628 #define INCREMENT_BCSTACK_LINKS() \
629 R_bcstack_t *ibcl_oldptop = R_BCProtTop; \
630 do { \
631 if (R_BCNodeStackTop > R_BCProtTop) \
632 INCLNK_stack(R_BCNodeStackTop); \
633 } while (0)
634
635 #define DECREMENT_BCSTACK_LINKS() do { \
636 if (R_BCProtTop > ibcl_oldptop) \
637 DECLNK_stack(ibcl_oldptop); \
638 } while (0)
639
640 /* Return value of "e" evaluated in "rho". */
641
642 /* some places, e.g. deparse2buff, call this with a promise and rho = NULL */
eval(SEXP e,SEXP rho)643 SEXP eval(SEXP e, SEXP rho)
644 {
645 SEXP op, tmp;
646 static int evalcount = 0;
647
648 R_Visible = TRUE;
649
650 /* this is needed even for self-evaluating objects or something like
651 'while (TRUE) NULL' will not be interruptable */
652 if (++evalcount > 1000) { /* was 100 before 2.8.0 */
653 R_CheckUserInterrupt();
654 #ifndef IMMEDIATE_FINALIZERS
655 /* finalizers are run here since this should only be called at
656 points where running arbitrary code should be safe */
657 R_RunPendingFinalizers();
658 #endif
659 evalcount = 0 ;
660 }
661
662 /* handle self-evaluating objects with minimal overhead */
663 switch (TYPEOF(e)) {
664 case NILSXP:
665 case LISTSXP:
666 case LGLSXP:
667 case INTSXP:
668 case REALSXP:
669 case STRSXP:
670 case CPLXSXP:
671 case RAWSXP:
672 case S4SXP:
673 case SPECIALSXP:
674 case BUILTINSXP:
675 case ENVSXP:
676 case CLOSXP:
677 case VECSXP:
678 case EXTPTRSXP:
679 case WEAKREFSXP:
680 case EXPRSXP:
681 /* Make sure constants in expressions are NAMED before being
682 used as values. Setting NAMED to NAMEDMAX makes sure weird calls
683 to replacement functions won't modify constants in
684 expressions. */
685 ENSURE_NAMEDMAX(e);
686 return e;
687 default: break;
688 }
689
690 int bcintactivesave = R_BCIntActive;
691 R_BCIntActive = 0;
692
693 if (!rho)
694 error("'rho' cannot be C NULL: detected in C-level eval");
695 if (!isEnvironment(rho))
696 error("'rho' must be an environment not %s: detected in C-level eval",
697 type2char(TYPEOF(rho)));
698
699 /* Save the current srcref context. */
700
701 SEXP srcrefsave = R_Srcref;
702
703 /* The use of depthsave below is necessary because of the
704 possibility of non-local returns from evaluation. Without this
705 an "expression too complex error" is quite likely. */
706
707 int depthsave = R_EvalDepth++;
708
709 /* We need to explicit set a NULL call here to circumvent attempts
710 to deparse the call in the error-handler */
711 if (R_EvalDepth > R_Expressions) {
712 R_Expressions = R_Expressions_keep + 500;
713 errorcall(R_NilValue,
714 _("evaluation nested too deeply: infinite recursion / options(expressions=)?"));
715 }
716 R_CheckStack();
717
718 tmp = R_NilValue; /* -Wall */
719 #ifdef Win32
720 /* This is an inlined version of Rwin_fpreset (src/gnuwin/extra.c)
721 and resets the precision, rounding and exception modes of a ix86
722 fpu.
723 */
724 __asm__ ( "fninit" );
725 #endif
726
727 switch (TYPEOF(e)) {
728 case BCODESXP:
729 tmp = bcEval(e, rho, TRUE);
730 break;
731 case SYMSXP:
732 if (e == R_DotsSymbol)
733 error(_("'...' used in an incorrect context"));
734 if( DDVAL(e) )
735 tmp = ddfindVar(e,rho);
736 else
737 tmp = findVar(e, rho);
738 if (tmp == R_UnboundValue)
739 error(_("object '%s' not found"), EncodeChar(PRINTNAME(e)));
740 /* if ..d is missing then ddfindVar will signal */
741 else if (tmp == R_MissingArg && !DDVAL(e) ) {
742 const char *n = CHAR(PRINTNAME(e));
743 if(*n) error(_("argument \"%s\" is missing, with no default"),
744 CHAR(PRINTNAME(e)));
745 else error(_("argument is missing, with no default"));
746 }
747 else if (TYPEOF(tmp) == PROMSXP) {
748 if (PRVALUE(tmp) == R_UnboundValue) {
749 /* not sure the PROTECT is needed here but keep it to
750 be on the safe side. */
751 PROTECT(tmp);
752 tmp = forcePromise(tmp);
753 UNPROTECT(1);
754 }
755 else tmp = PRVALUE(tmp);
756 ENSURE_NAMEDMAX(tmp);
757 }
758 else ENSURE_NAMED(tmp); /* needed for .Last.value - LT */
759 break;
760 case PROMSXP:
761 if (PRVALUE(e) == R_UnboundValue)
762 /* We could just unconditionally use the return value from
763 forcePromise; the test avoids the function call if the
764 promise is already evaluated. */
765 forcePromise(e);
766 tmp = PRVALUE(e);
767 /* This does _not_ change the value of NAMED on the value tmp,
768 in contrast to the handling of promises bound to symbols in
769 the SYMSXP case above. The reason is that one (typically
770 the only) place promises appear in source code is as
771 wrappers for the RHS value in replacement function calls for
772 complex assignment expression created in applydefine(). If
773 the RHS value is freshly created it will have NAMED = 0 and
774 we want it to stay that way or a BUILTIN or SPECIAL
775 replacement function might have to duplicate the value
776 before inserting it to avoid creating cycles. (Closure
777 replacement functions will get the value via the SYMSXP case
778 from evaluating their 'value' argument so the value will
779 end up getting duplicated if NAMED > 1.) LT */
780 break;
781 case LANGSXP:
782 if (TYPEOF(CAR(e)) == SYMSXP) {
783 /* This will throw an error if the function is not found */
784 SEXP ecall = e;
785
786 /* This picks the correct/better error expression for
787 replacement calls running in the AST interpreter. */
788 if (R_GlobalContext != NULL &&
789 (R_GlobalContext->callflag == CTXT_CCODE))
790 ecall = R_GlobalContext->call;
791 PROTECT(op = findFun3(CAR(e), rho, ecall));
792 } else
793 PROTECT(op = eval(CAR(e), rho));
794
795 if(RTRACE(op) && R_current_trace_state()) {
796 Rprintf("trace: ");
797 PrintValue(e);
798 }
799 if (TYPEOF(op) == SPECIALSXP) {
800 int save = R_PPStackTop, flag = PRIMPRINT(op);
801 const void *vmax = vmaxget();
802 PROTECT(e);
803 R_Visible = flag != 1;
804 tmp = PRIMFUN(op) (e, op, CDR(e), rho);
805 #ifdef CHECK_VISIBILITY
806 if(flag < 2 && R_Visible == flag) {
807 char *nm = PRIMNAME(op);
808 if(strcmp(nm, "for")
809 && strcmp(nm, "repeat") && strcmp(nm, "while")
810 && strcmp(nm, "[[<-") && strcmp(nm, "on.exit"))
811 printf("vis: special %s\n", nm);
812 }
813 #endif
814 if (flag < 2) R_Visible = flag != 1;
815 UNPROTECT(1);
816 check_stack_balance(op, save);
817 vmaxset(vmax);
818 }
819 else if (TYPEOF(op) == BUILTINSXP) {
820 int save = R_PPStackTop, flag = PRIMPRINT(op);
821 const void *vmax = vmaxget();
822 RCNTXT cntxt;
823 PROTECT(tmp = evalList(CDR(e), rho, e, 0));
824 if (flag < 2) R_Visible = flag != 1;
825 /* We used to insert a context only if profiling,
826 but helps for tracebacks on .C etc. */
827 if (R_Profiling || (PPINFO(op).kind == PP_FOREIGN)) {
828 SEXP oldref = R_Srcref;
829 begincontext(&cntxt, CTXT_BUILTIN, e,
830 R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue);
831 R_Srcref = NULL;
832 tmp = PRIMFUN(op) (e, op, tmp, rho);
833 R_Srcref = oldref;
834 endcontext(&cntxt);
835 } else {
836 tmp = PRIMFUN(op) (e, op, tmp, rho);
837 }
838 #ifdef CHECK_VISIBILITY
839 if(flag < 2 && R_Visible == flag) {
840 char *nm = PRIMNAME(op);
841 printf("vis: builtin %s\n", nm);
842 }
843 #endif
844 if (flag < 2) R_Visible = flag != 1;
845 UNPROTECT(1);
846 check_stack_balance(op, save);
847 vmaxset(vmax);
848 }
849 else if (TYPEOF(op) == CLOSXP) {
850 SEXP pargs = promiseArgs(CDR(e), rho);
851 PROTECT(pargs);
852 tmp = applyClosure(e, op, pargs, rho, R_NilValue);
853 #ifdef ADJUST_ENVIR_REFCNTS
854 unpromiseArgs(pargs);
855 #endif
856 UNPROTECT(1);
857 }
858 else
859 error(_("attempt to apply non-function"));
860 UNPROTECT(1);
861 break;
862 case DOTSXP:
863 error(_("'...' used in an incorrect context"));
864 default:
865 UNIMPLEMENTED_TYPE("eval", e);
866 }
867 R_EvalDepth = depthsave;
868 R_Srcref = srcrefsave;
869 R_BCIntActive = bcintactivesave;
870 return (tmp);
871 }
872
873 attribute_hidden
SrcrefPrompt(const char * prefix,SEXP srcref)874 void SrcrefPrompt(const char * prefix, SEXP srcref)
875 {
876 /* If we have a valid srcref, use it */
877 if (srcref && srcref != R_NilValue) {
878 if (TYPEOF(srcref) == VECSXP) srcref = VECTOR_ELT(srcref, 0);
879 SEXP srcfile = getAttrib(srcref, R_SrcfileSymbol);
880 if (TYPEOF(srcfile) == ENVSXP) {
881 SEXP filename = findVar(install("filename"), srcfile);
882 if (isString(filename) && length(filename)) {
883 Rprintf(_("%s at %s#%d: "), prefix,
884 CHAR(STRING_ELT(filename, 0)),
885 asInteger(srcref));
886 return;
887 }
888 }
889 }
890 /* default: */
891 Rprintf("%s: ", prefix);
892 }
893
894 /* JIT support */
895 typedef unsigned long R_exprhash_t;
896
hash(unsigned char * str,int n,R_exprhash_t hash)897 static R_exprhash_t hash(unsigned char *str, int n, R_exprhash_t hash)
898 {
899 // djb2 from http://www.cse.yorku.ca/~oz/hash.html
900 // (modified for n-byte lengths)
901
902 int i;
903
904 for(i = 0; i < n; i++)
905 hash = ((hash << 5) + hash) + str[i]; /* hash * 33 + c */
906
907 return hash;
908 }
909
910 #define HASH(x, h) hash((unsigned char *) &x, sizeof(x), h)
911
hashexpr1(SEXP e,R_exprhash_t h)912 static R_exprhash_t hashexpr1(SEXP e, R_exprhash_t h)
913 {
914 #define SKIP_NONSCALAR if (len != 1) break /* non-scalars hashed by address */
915 int len = length(e);
916 int type = TYPEOF(e);
917 h = HASH(type, h);
918 h = HASH(len, h);
919
920 switch(type) {
921 case LANGSXP:
922 case LISTSXP:
923 /**** safer to only follow while CDR is LANGSXP/LISTSXP */
924 for (; e != R_NilValue; e = CDR(e))
925 h = hashexpr1(CAR(e), h);
926 return h;
927 case LGLSXP:
928 SKIP_NONSCALAR;
929 for (int i = 0; i < len; i++) {
930 int ival = LOGICAL(e)[i];
931 h = HASH(ival, h);
932 }
933 return h;
934 case INTSXP:
935 SKIP_NONSCALAR;
936 for (int i = 0; i < len; i++) {
937 int ival = INTEGER(e)[i];
938 h = HASH(ival, h);
939 }
940 return h;
941 case REALSXP:
942 SKIP_NONSCALAR;
943 for (int i = 0; i < len; i++) {
944 double dval = REAL(e)[i];
945 h = HASH(dval, h);
946 }
947 return h;
948 case STRSXP:
949 SKIP_NONSCALAR;
950 for (int i = 0; i < len; i++) {
951 SEXP cval = STRING_ELT(e, i);
952 h = hash((unsigned char *) CHAR(cval), LENGTH(cval), h);
953 }
954 return h;
955 }
956
957 return HASH(e, h);
958 #undef SKIP_NONSCALAR
959 }
960
961 static R_INLINE SEXP getSrcref(SEXP srcrefs, int ind);
hashsrcref(SEXP e,R_exprhash_t h)962 static R_exprhash_t hashsrcref(SEXP e, R_exprhash_t h)
963 {
964 if (TYPEOF(e) == INTSXP && LENGTH(e) >= 6) {
965 for(int i = 0; i < 6; i++) {
966 int ival = INTEGER(e)[i];
967 h = HASH(ival, h);
968 }
969 /* FIXME: update this when deep-comparison of srcref is available */
970 SEXP srcfile = getAttrib(e, R_SrcfileSymbol);
971 h = HASH(srcfile, h);
972 }
973 return h;
974 }
975 #undef HASH
976
hashexpr(SEXP e)977 static R_exprhash_t hashexpr(SEXP e)
978 {
979 return hashexpr1(e, 5381);
980 }
981
hashfun(SEXP f)982 static R_exprhash_t hashfun(SEXP f)
983 {
984 R_exprhash_t h = hashexpr(BODY(f));
985 if (getAttrib(BODY(f), R_SrcrefSymbol) == R_NilValue)
986 h = hashsrcref(getAttrib(f, R_SrcrefSymbol), h);
987 return h;
988 }
989
loadCompilerNamespace(void)990 static void loadCompilerNamespace(void)
991 {
992 SEXP fun, arg, expr;
993
994 PROTECT(fun = install("getNamespace"));
995 PROTECT(arg = mkString("compiler"));
996 PROTECT(expr = lang2(fun, arg));
997 eval(expr, R_GlobalEnv);
998 UNPROTECT(3);
999 }
1000
checkCompilerOptions(int jitEnabled)1001 static void checkCompilerOptions(int jitEnabled)
1002 {
1003 int old_visible = R_Visible;
1004 SEXP packsym, funsym, call, fcall, arg;
1005
1006 packsym = install("compiler");
1007 funsym = install("checkCompilerOptions");
1008
1009 PROTECT(arg = ScalarInteger(jitEnabled));
1010 PROTECT(fcall = lang3(R_TripleColonSymbol, packsym, funsym));
1011 PROTECT(call = lang2(fcall, arg));
1012 eval(call, R_GlobalEnv);
1013 UNPROTECT(3);
1014 R_Visible = old_visible;
1015 }
1016
1017 static SEXP R_IfSymbol = NULL;
1018 static SEXP R_ForSymbol = NULL;
1019 static SEXP R_WhileSymbol = NULL;
1020 static SEXP R_RepeatSymbol = NULL;
1021
1022 #define JIT_CACHE_SIZE 1024
1023 static SEXP JIT_cache = NULL;
1024 static R_exprhash_t JIT_cache_hashes[JIT_CACHE_SIZE];
1025
1026 /**** allow MIN_JIT_SCORE, or both, to be changed by environment variables? */
1027 static int MIN_JIT_SCORE = 50;
1028 #define LOOP_JIT_SCORE MIN_JIT_SCORE
1029
1030 static struct { unsigned long count, envcount, bdcount; } jit_info = {0, 0, 0};
1031
R_init_jit_enabled(void)1032 void attribute_hidden R_init_jit_enabled(void)
1033 {
1034 /* Need to force the lazy loading promise to avoid recursive
1035 promise evaluation when JIT is enabled. Might be better to do
1036 this in baseloader.R. */
1037 eval(install(".ArgsEnv"), R_BaseEnv);
1038
1039 int val = 3; /* turn JIT on by default */
1040 char *enable = getenv("R_ENABLE_JIT");
1041 if (enable != NULL)
1042 val = atoi(enable);
1043 if (val) {
1044 loadCompilerNamespace();
1045 checkCompilerOptions(val);
1046 }
1047 R_jit_enabled = val;
1048
1049 if (R_compile_pkgs <= 0) {
1050 char *compile = getenv("_R_COMPILE_PKGS_");
1051 if (compile != NULL) {
1052 int val = atoi(compile);
1053 if (val > 0)
1054 R_compile_pkgs = TRUE;
1055 else
1056 R_compile_pkgs = FALSE;
1057 }
1058 }
1059
1060 if (R_disable_bytecode <= 0) {
1061 char *disable = getenv("R_DISABLE_BYTECODE");
1062 if (disable != NULL) {
1063 int val = atoi(disable);
1064 if (val > 0)
1065 R_disable_bytecode = TRUE;
1066 else
1067 R_disable_bytecode = FALSE;
1068 }
1069 }
1070
1071 /* -1 ... duplicate constants on LDCONST and PUSHCONSTARG, no checking
1072 0 ... no checking (no duplication for >= 0) [DEFAULT]
1073 1 ... check at error, session exit and reclamation
1074 2 ... check also at full GC
1075 3 ... check also at partial GC
1076 4 ... check also at .Call
1077 5 ... (very) verbose report on modified constants
1078 */
1079 if (R_check_constants <= 1) {
1080 char *check = getenv("R_CHECK_CONSTANTS");
1081 if (check != NULL)
1082 R_check_constants = atoi(check);
1083 }
1084
1085 /* initialize JIT variables */
1086 R_IfSymbol = install("if");
1087 R_ForSymbol = install("for");
1088 R_WhileSymbol = install("while");
1089 R_RepeatSymbol = install("repeat");
1090
1091 R_PreserveObject(JIT_cache = allocVector(VECSXP, JIT_CACHE_SIZE));
1092 }
1093
JIT_score(SEXP e)1094 static int JIT_score(SEXP e)
1095 {
1096 if (TYPEOF(e) == LANGSXP) {
1097 SEXP fun = CAR(e);
1098 if (fun == R_IfSymbol) {
1099 int cons = JIT_score(CADR(e));
1100 int alt = JIT_score(CADDR(e));
1101 return cons > alt ? cons : alt;
1102 }
1103 else if (fun == R_ForSymbol ||
1104 fun == R_WhileSymbol ||
1105 fun == R_RepeatSymbol)
1106 return LOOP_JIT_SCORE;
1107 else {
1108 int score = 1;
1109 for (SEXP args = CDR(e); args != R_NilValue; args = CDR(args))
1110 score += JIT_score(CAR(args));
1111 return score;
1112 }
1113 }
1114 else return 1;
1115 }
1116
1117 #define STRATEGY_NO_SMALL 0
1118 #define STRATEGY_TOP_SMALL_MAYBE 1
1119 #define STRATEGY_ALL_SMALL_MAYBE 2
1120 #define STRATEGY_NO_SCORE 3
1121 #define STRATEGY_NO_CACHE 4
1122 /* max strategy index is hardcoded in R_CheckJIT */
1123
1124 /*
1125 NO_CACHE
1126 functions are compiled 1st time seen
1127 code is never cached
1128
1129 NO_SCORE
1130 functions are compiled 1st time seen
1131 code is cached
1132 in case of conflict function may be marked NOJIT
1133
1134 ALL_SMALL_MAYBE
1135 functions with small score are compiled 2nd time seen
1136 function with high score are compiled
1137 1st time seen if top-level, 2nd time seen otherwise
1138
1139 TOP_SMALL_MAYBE
1140 functions with small score compiled
1141 2nd time seen if top-level, never otherwise
1142 functions with high score compiled
1143 1st time seen if top-level, 2nd time seen otherwise
1144 */
1145
1146 static int jit_strategy = -1;
1147
R_CheckJIT(SEXP fun)1148 static R_INLINE Rboolean R_CheckJIT(SEXP fun)
1149 {
1150 /* to help with testing */
1151 if (jit_strategy < 0) {
1152 int dflt = R_jit_enabled == 1 ?
1153 STRATEGY_NO_SMALL : STRATEGY_TOP_SMALL_MAYBE;
1154 int val = dflt;
1155 char *valstr = getenv("R_JIT_STRATEGY");
1156 if (valstr != NULL)
1157 val = atoi(valstr);
1158 if (val < 0 || val > 4)
1159 jit_strategy = dflt;
1160 else
1161 jit_strategy = val;
1162
1163 valstr = getenv("R_MIN_JIT_SCORE");
1164 if (valstr != NULL)
1165 MIN_JIT_SCORE = atoi(valstr);
1166 }
1167
1168 SEXP body = BODY(fun);
1169
1170 if (R_jit_enabled > 0 && TYPEOF(body) != BCODESXP &&
1171 ! R_disable_bytecode && ! NOJIT(fun)) {
1172
1173 if (MAYBEJIT(fun)) {
1174 /* function marked as MAYBEJIT the first time now seen
1175 twice, so go ahead and compile */
1176 UNSET_MAYBEJIT(fun);
1177 return TRUE;
1178 }
1179
1180 if (jit_strategy == STRATEGY_NO_SCORE ||
1181 jit_strategy == STRATEGY_NO_CACHE)
1182 return TRUE;
1183
1184 int score = JIT_score(body);
1185 if (jit_strategy == STRATEGY_ALL_SMALL_MAYBE)
1186 if (score < MIN_JIT_SCORE) { SET_MAYBEJIT(fun); return FALSE; }
1187
1188 if (CLOENV(fun) == R_GlobalEnv) {
1189 /* top level functions are only compiled if score is high enough */
1190 if (score < MIN_JIT_SCORE) {
1191 if (jit_strategy == STRATEGY_TOP_SMALL_MAYBE)
1192 SET_MAYBEJIT(fun);
1193 else
1194 SET_NOJIT(fun);
1195 return FALSE;
1196 }
1197 else return TRUE;
1198 }
1199 else {
1200 /* only compile non-top-level function if score is high
1201 enough and seen twice */
1202 if (score < MIN_JIT_SCORE) {
1203 SET_NOJIT(fun);
1204 return FALSE;
1205 }
1206 else {
1207 SET_MAYBEJIT(fun);
1208 return FALSE;
1209 }
1210 }
1211 }
1212 return FALSE;
1213 }
1214
1215 #ifdef DEBUG_JIT
1216 # define PRINT_JIT_INFO \
1217 REprintf("JIT cache hits: %ld; env: %ld; body %ld\n", \
1218 jit_info.count, jit_info.envcount, jit_info.bdcount)
1219 #else
1220 # define PRINT_JIT_INFO do { } while(0)
1221 #endif
1222
1223
1224 /* FIXME: this should not depend on internals from envir.c but does for now. */
1225 /* copied from envir.c for now */
1226 #define IS_USER_DATABASE(rho) (OBJECT((rho)) && inherits((rho), "UserDefinedDatabase"))
1227 #define IS_STANDARD_UNHASHED_FRAME(e) (! IS_USER_DATABASE(e) && HASHTAB(e) == R_NilValue)
1228 #define IS_STANDARD_HASHED_FRAME(e) (! IS_USER_DATABASE(e) && HASHTAB(e) != R_NilValue)
1229
1230 /* This makes a snapshot of the local variables in cmpenv and creates
1231 a new environment with the same top level environment and bindings
1232 with value R_NilValue for the local variables. This guards against
1233 the cmpenv changing after being entered in the cache, and also
1234 allows large values that might be bound to local variables in
1235 cmpenv to be reclaimed (also, some package tests, e.g. in shiny, test
1236 when things get reclaimed). Standard local frames are processed directly,
1237 hashed frames are processed via lsInternal3, which involves extra
1238 allocations, but should be used rarely. If a local environment is
1239 of unsupported type, topenv is returned as a valid conservative
1240 answer.
1241
1242 Since we compute the local variables at compile
1243 time we should record them in the byte code object and use the
1244 recorded value. */
cmpenv_enter_frame(SEXP frame,SEXP newenv)1245 static R_INLINE void cmpenv_enter_frame(SEXP frame, SEXP newenv)
1246 {
1247 for (; frame != R_NilValue; frame = CDR(frame))
1248 defineVar(TAG(frame), R_NilValue, newenv);
1249 }
1250
make_cached_cmpenv(SEXP fun)1251 static R_INLINE SEXP make_cached_cmpenv(SEXP fun)
1252 {
1253 SEXP frmls = FORMALS(fun);
1254 SEXP cmpenv = CLOENV(fun);
1255 SEXP top = topenv(R_NilValue, cmpenv);
1256 if (cmpenv == top && frmls == R_NilValue)
1257 return cmpenv;
1258 else {
1259 SEXP newenv = PROTECT(NewEnvironment(R_NilValue, R_NilValue, top));
1260 for (; frmls != R_NilValue; frmls = CDR(frmls))
1261 defineVar(TAG(frmls), R_NilValue, newenv);
1262 for (SEXP env = cmpenv; env != top; env = CDR(env)) {
1263 if (IS_STANDARD_UNHASHED_FRAME(env))
1264 cmpenv_enter_frame(FRAME(env), newenv);
1265 else if (IS_STANDARD_HASHED_FRAME(env)) {
1266 SEXP h = HASHTAB(env);
1267 int n = length(h);
1268 for (int i = 0; i < n; i++)
1269 cmpenv_enter_frame(VECTOR_ELT(h, i), newenv);
1270 } else {
1271 UNPROTECT(1); /* newenv */
1272 return top;
1273 }
1274 /* topenv is a safe conservative answer; if a closure
1275 defines anything, its environment will not match, and
1276 it will never be compiled */
1277 /* FIXME: would it be safe to simply ignore elements of
1278 of these environments? */
1279 }
1280 UNPROTECT(1); /* newenv */
1281 return newenv;
1282 }
1283 }
1284
1285 /* Cache entries are CONS cells with the body in CAR, the environment
1286 in CDR, and the Srcref in the TAG. */
set_jit_cache_entry(R_exprhash_t hash,SEXP val)1287 static R_INLINE void set_jit_cache_entry(R_exprhash_t hash, SEXP val)
1288 {
1289 int hashidx = hash % JIT_CACHE_SIZE;
1290
1291 PROTECT(val);
1292 SEXP entry = CONS(BODY(val), make_cached_cmpenv(val));
1293 SET_VECTOR_ELT(JIT_cache, hashidx, entry);
1294 SET_TAG(entry, getAttrib(val, R_SrcrefSymbol));
1295 UNPROTECT(1); /* val */
1296
1297 JIT_cache_hashes[hashidx] = hash;
1298 }
1299
jit_cache_code(SEXP entry)1300 static R_INLINE SEXP jit_cache_code(SEXP entry)
1301 {
1302 return CAR(entry);
1303 }
1304
jit_cache_env(SEXP entry)1305 static R_INLINE SEXP jit_cache_env(SEXP entry)
1306 {
1307 return CDR(entry);
1308 }
1309
jit_cache_srcref(SEXP entry)1310 static R_INLINE SEXP jit_cache_srcref(SEXP entry)
1311 {
1312 return TAG(entry);
1313 }
1314
1315 /* forward declaration */
1316 static SEXP bytecodeExpr(SEXP);
1317
jit_cache_expr(SEXP entry)1318 static R_INLINE SEXP jit_cache_expr(SEXP entry)
1319 {
1320 return bytecodeExpr(jit_cache_code(entry));
1321 }
1322
get_jit_cache_entry(R_exprhash_t hash)1323 static R_INLINE SEXP get_jit_cache_entry(R_exprhash_t hash)
1324 {
1325 int hashidx = hash % JIT_CACHE_SIZE;
1326 if (JIT_cache_hashes[hashidx] == hash) {
1327 SEXP entry = VECTOR_ELT(JIT_cache, hashidx);
1328 if (TYPEOF(jit_cache_code(entry)) == BCODESXP)
1329 return entry;
1330 else
1331 /* function has been de-compiled; clear the cache entry */
1332 SET_VECTOR_ELT(JIT_cache, hashidx, R_NilValue);
1333 }
1334 return R_NilValue;
1335 }
1336
jit_expr_match(SEXP expr,SEXP body)1337 static R_INLINE Rboolean jit_expr_match(SEXP expr, SEXP body)
1338 {
1339 /*** is 16 right here??? does this need to be faster??? */
1340 return R_compute_identical(expr, body, 16);
1341 }
1342
cmpenv_topenv(SEXP cmpenv)1343 static R_INLINE SEXP cmpenv_topenv(SEXP cmpenv)
1344 {
1345 return topenv(R_NilValue, cmpenv);
1346 }
1347
cmpenv_exists_local(SEXP sym,SEXP cmpenv,SEXP top)1348 static R_INLINE Rboolean cmpenv_exists_local(SEXP sym, SEXP cmpenv, SEXP top)
1349 {
1350 if (cmpenv != top)
1351 for (SEXP frame = FRAME(cmpenv);
1352 frame != R_NilValue;
1353 frame = CDR(frame))
1354 if (TAG(frame) == sym)
1355 return TRUE;
1356 return FALSE;
1357 }
1358
jit_env_match(SEXP cmpenv,SEXP fun)1359 static R_INLINE Rboolean jit_env_match(SEXP cmpenv, SEXP fun)
1360 {
1361 /* Can code compiled for environment cmpenv be used as compiled
1362 code for environment env? These tests rely on the assumption
1363 that compilation is only affected by what variables are bound,
1364 not their values. So as long as both cmpenv and env have the
1365 same top level environment and all local bindings present in
1366 the formals and environment of fun are also present in cmpenv
1367 the code for cmpenv can be reused, though it might be less
1368 efficient if a binding in cmpenv prevents an optimization that
1369 would be possible in env. */
1370
1371 SEXP env = CLOENV(fun);
1372 SEXP top = topenv(R_NilValue, env);
1373
1374 if (top == cmpenv_topenv(cmpenv)) {
1375 for (SEXP frmls = FORMALS(fun); frmls != R_NilValue; frmls = CDR(frmls))
1376 if (! cmpenv_exists_local(TAG(frmls), cmpenv, top))
1377 return FALSE;
1378 for (; env != top; env = ENCLOS(env)) {
1379 if (IS_STANDARD_UNHASHED_FRAME(env)) {
1380 /* To keep things simple, for a match this code
1381 requires that the local frames be standard unhashed
1382 frames. */
1383 for (SEXP frame = FRAME(env);
1384 frame != R_NilValue;
1385 frame = CDR(frame))
1386 if (! cmpenv_exists_local(TAG(frame), cmpenv, top))
1387 return FALSE;
1388 }
1389 else return FALSE;
1390 }
1391 return TRUE;
1392 }
1393 else return FALSE;
1394 }
1395
jit_srcref_match(SEXP cmpsrcref,SEXP srcref)1396 static R_INLINE Rboolean jit_srcref_match(SEXP cmpsrcref, SEXP srcref)
1397 {
1398 return R_compute_identical(cmpsrcref, srcref, 0);
1399 }
1400
R_cmpfun1(SEXP fun)1401 SEXP attribute_hidden R_cmpfun1(SEXP fun)
1402 {
1403 int old_visible = R_Visible;
1404 SEXP packsym, funsym, call, fcall, val;
1405
1406 packsym = install("compiler");
1407 funsym = install("tryCmpfun");
1408
1409 PROTECT(fcall = lang3(R_TripleColonSymbol, packsym, funsym));
1410 PROTECT(call = lang2(fcall, fun));
1411 PROTECT(val = eval(call, R_GlobalEnv));
1412 if (TYPEOF(BODY(val)) != BCODESXP)
1413 /* Compilation may have failed because R alocator could not malloc
1414 memory to extend the R heap, so we run GC to release some pages.
1415 This problem has been observed while byte-compiling packages on
1416 installation: serialization uses malloc to allocate buffers and
1417 fails when the compiler makes R allocator exhaust malloc memory.
1418 A more general solution might be to run the GC conditionally inside
1419 error handling. */
1420 R_gc();
1421 UNPROTECT(3); /* fcall, call, val */
1422
1423 R_Visible = old_visible;
1424 return val;
1425 }
1426
1427 /* fun is modified in-place when compiled */
R_cmpfun(SEXP fun)1428 static void R_cmpfun(SEXP fun)
1429 {
1430 R_exprhash_t hash = 0;
1431 if (jit_strategy != STRATEGY_NO_CACHE) {
1432 hash = hashfun(fun);
1433 SEXP entry = get_jit_cache_entry(hash);
1434
1435 if (entry != R_NilValue) {
1436 jit_info.count++;
1437 if (jit_env_match(jit_cache_env(entry), fun)) {
1438 jit_info.envcount++;
1439 if (jit_expr_match(jit_cache_expr(entry), BODY(fun))) {
1440 jit_info.bdcount++;
1441 /* if function body has a srcref, all srcrefs compiled
1442 in that function only depend on the body srcref;
1443 but, otherwise the srcrefs compiled in are taken
1444 from the function (op) */
1445 if (getAttrib(BODY(fun), R_SrcrefSymbol) != R_NilValue ||
1446 jit_srcref_match(jit_cache_srcref(entry),
1447 getAttrib(fun, R_SrcrefSymbol))) {
1448 PRINT_JIT_INFO;
1449 SET_BODY(fun, jit_cache_code(entry));
1450 /**** reset the cache here?*/
1451 return;
1452 }
1453 }
1454 /* The functions probably differ only in source references
1455 (for functions with bodies that have no source references
1456 we know for sure, for other functions we speculate).
1457 Therefore, we allow re-compilation and re-caching. This
1458 situation may be caused e.g. by re-sourcing the same source
1459 file or re-pasting the same definitions for a function in
1460 interactive R session. Note srcref information includes
1461 environments (srcfile), which are now compared by address,
1462 so it may be we actually have logically identical source
1463 references, anyway. */
1464 /* FIXME: revisit this when deep comparison of environments
1465 (and srcrefs) is available */
1466 } else {
1467 SET_NOJIT(fun);
1468 /**** also mark the cache entry as NOJIT, or as need to see
1469 many times? */
1470 return;
1471 }
1472 }
1473 PRINT_JIT_INFO;
1474 }
1475
1476 SEXP val = R_cmpfun1(fun);
1477
1478 if (TYPEOF(BODY(val)) != BCODESXP)
1479 SET_NOJIT(fun);
1480 else {
1481 if (jit_strategy != STRATEGY_NO_CACHE)
1482 set_jit_cache_entry(hash, val); /* val is protected by callee */
1483 SET_BODY(fun, BODY(val));
1484 }
1485 }
1486
R_compileExpr(SEXP expr,SEXP rho)1487 static SEXP R_compileExpr(SEXP expr, SEXP rho)
1488 {
1489 int old_visible = R_Visible;
1490 SEXP packsym, funsym, quotesym;
1491 SEXP qexpr, call, fcall, val;
1492
1493 packsym = install("compiler");
1494 funsym = install("tryCompile");
1495 quotesym = install("quote");
1496
1497 PROTECT(fcall = lang3(R_TripleColonSymbol, packsym, funsym));
1498 PROTECT(qexpr = lang2(quotesym, expr));
1499 /* compile(e, env, options, srcref) */
1500 PROTECT(call = lang5(fcall, qexpr, rho, R_NilValue, R_getCurrentSrcref()));
1501 val = eval(call, R_GlobalEnv);
1502 UNPROTECT(3);
1503 R_Visible = old_visible;
1504 return val;
1505 }
1506
R_compileAndExecute(SEXP call,SEXP rho)1507 static Rboolean R_compileAndExecute(SEXP call, SEXP rho)
1508 {
1509 int old_enabled = R_jit_enabled;
1510 SEXP code;
1511 Rboolean ans = FALSE;
1512
1513 R_jit_enabled = 0;
1514 PROTECT(call);
1515 PROTECT(rho);
1516 PROTECT(code = R_compileExpr(call, rho));
1517 R_jit_enabled = old_enabled;
1518
1519 if (TYPEOF(code) == BCODESXP) {
1520 bcEval(code, rho, TRUE);
1521 ans = TRUE;
1522 }
1523
1524 UNPROTECT(3);
1525 return ans;
1526 }
1527
do_enablejit(SEXP call,SEXP op,SEXP args,SEXP rho)1528 SEXP attribute_hidden do_enablejit(SEXP call, SEXP op, SEXP args, SEXP rho)
1529 {
1530 int old = R_jit_enabled, new;
1531 checkArity(op, args);
1532 new = asInteger(CAR(args));
1533 if (new >= 0) {
1534 if (new > 0)
1535 loadCompilerNamespace();
1536 checkCompilerOptions(new);
1537 R_jit_enabled = new;
1538 }
1539 /* negative 'new' just returns 'old' */
1540 return ScalarInteger(old);
1541 }
1542
do_compilepkgs(SEXP call,SEXP op,SEXP args,SEXP rho)1543 SEXP attribute_hidden do_compilepkgs(SEXP call, SEXP op, SEXP args, SEXP rho)
1544 {
1545 int old = R_compile_pkgs, new;
1546 checkArity(op, args);
1547 new = asLogical(CAR(args));
1548 if (new != NA_LOGICAL && new)
1549 loadCompilerNamespace();
1550 R_compile_pkgs = new;
1551 return ScalarLogical(old);
1552 }
1553
1554 /* this function gets the srcref attribute from a statement block,
1555 and confirms it's in the expected format */
1556
getBlockSrcrefs(SEXP call)1557 static R_INLINE SEXP getBlockSrcrefs(SEXP call)
1558 {
1559 SEXP srcrefs = getAttrib(call, R_SrcrefSymbol);
1560 if (TYPEOF(srcrefs) == VECSXP) return srcrefs;
1561 return R_NilValue;
1562 }
1563
1564 /* this function extracts one srcref, and confirms the format */
1565 /* It assumes srcrefs has already been validated to be a VECSXP or NULL */
1566
getSrcref(SEXP srcrefs,int ind)1567 static R_INLINE SEXP getSrcref(SEXP srcrefs, int ind)
1568 {
1569 SEXP result;
1570 if (!isNull(srcrefs)
1571 && length(srcrefs) > ind
1572 && !isNull(result = VECTOR_ELT(srcrefs, ind))
1573 && TYPEOF(result) == INTSXP
1574 && length(result) >= 6)
1575 return result;
1576 else
1577 return R_NilValue;
1578 }
1579
1580 #ifdef ADJUST_ENVIR_REFCNTS
R_isReplaceSymbol(SEXP fun)1581 static R_INLINE Rboolean R_isReplaceSymbol(SEXP fun)
1582 {
1583 /* fun is a replacement function name if it contains '<-'
1584 anywhere. For internally dispatched replacement functions this
1585 may occur in the middle; in other cases it will be at the
1586 end. */
1587 if (TYPEOF(fun) == SYMSXP &&
1588 strstr(CHAR(PRINTNAME(fun)), "<-"))
1589 return TRUE;
1590 else return FALSE;
1591 }
1592 #endif
1593
1594 /* There's another copy of this in main.c */
PrintCall(SEXP call,SEXP rho)1595 static void PrintCall(SEXP call, SEXP rho)
1596 {
1597 int old_bl = R_BrowseLines,
1598 blines = asInteger(GetOption1(install("deparse.max.lines")));
1599 if(blines != NA_INTEGER && blines > 0)
1600 R_BrowseLines = blines;
1601
1602 R_PrintData pars;
1603 PrintInit(&pars, rho);
1604 PrintValueRec(call, &pars);
1605
1606 R_BrowseLines = old_bl;
1607 }
1608
1609 #ifdef ADJUST_ENVIR_REFCNTS
1610 /* After executing a closure call the environment created for the call
1611 may no longer be reachable. If this is the case, then its bindings
1612 can be cleared to reduce the reference counts on the binding
1613 values.
1614
1615 The environment will no longer be reachable if it is not being
1616 returned as the value of the closure and has no references. It will
1617 also no longer be reachable be the case if all references to it are
1618 internal cycles through its bindings. A full check for internal
1619 cycles would be too expensive, but the two most important cases can
1620 be checked at reasonable cost:
1621
1622 - a promise with no other references, most likely from an
1623 unevaluated argument default expression;
1624
1625 - a closure with no further references and not returned as the
1626 value, most likely a local helper function.
1627
1628 The promises created for a closure call can also be cleared one the
1629 call is complete and the promises are no longer reachable. This
1630 drops reference counts on the values and the environments.
1631 */
1632
countCycleRefs(SEXP rho,SEXP val)1633 static int countCycleRefs(SEXP rho, SEXP val)
1634 {
1635 /* check for simple cycles */
1636 int crefs = 0;
1637 for (SEXP b = FRAME(rho);
1638 b != R_NilValue && REFCNT(b) == 1;
1639 b = CDR(b)) {
1640 if (BNDCELL_TAG(b)) continue;
1641 SEXP v = CAR(b);
1642 if (val != v) {
1643 switch(TYPEOF(v)) {
1644 case PROMSXP:
1645 if (REFCNT(v) == 1 && PRENV(v) == rho)
1646 crefs++;
1647 break;
1648 case CLOSXP:
1649 if (REFCNT(v) == 1 && CLOENV(v) == rho)
1650 crefs++;
1651 break;
1652 case ENVSXP: /* is this worth bothering with? */
1653 if (v == rho)
1654 crefs++;
1655 break;
1656 }
1657 }
1658 }
1659 return crefs;
1660 }
1661
clearPromise(SEXP p)1662 static R_INLINE void clearPromise(SEXP p)
1663 {
1664 SET_PRVALUE(p, R_UnboundValue);
1665 SET_PRENV(p, R_NilValue);
1666 SET_PRCODE(p, R_NilValue); /* for calls with literal values */
1667 }
1668
cleanupEnvDots(SEXP d)1669 static R_INLINE void cleanupEnvDots(SEXP d)
1670 {
1671 for (; d != R_NilValue && REFCNT(d) == 1; d = CDR(d)) {
1672 SEXP v = CAR(d);
1673 if (REFCNT(v) == 1 && TYPEOF(v) == PROMSXP)
1674 clearPromise(v);
1675 SETCAR(d, R_NilValue);
1676 }
1677 }
1678
cleanupEnvVector(SEXP v)1679 static R_INLINE void cleanupEnvVector(SEXP v)
1680 {
1681 /* This is mainly for handling results of list(...) stored as a
1682 local variable. It would be cheaper to just use
1683 DECREMENT_REFCNT. It might also make sense to max out at len =
1684 10 or so, and to avoid ALTREP objects. */
1685
1686 /* FIXME: Disabled for now since a BUILTIN that saves its (NR)
1687 list can cause problems. .External.graphics does this for
1688 recording. Probably the best option is to not have the args go
1689 down as NR. Most of these are fixed now, but this stilll seems
1690 to wake things up, so hold off for now. */
1691 return;
1692
1693 // avoid ODS compiler warning.
1694 #ifdef FALSE
1695 R_xlen_t len = XLENGTH(v);
1696 for (R_xlen_t i = 0; i < len; i++)
1697 SET_VECTOR_ELT(v, i, R_NilValue);
1698 #endif
1699 }
1700
R_CleanupEnvir(SEXP rho,SEXP val)1701 static R_INLINE void R_CleanupEnvir(SEXP rho, SEXP val)
1702 {
1703 if (val != rho) {
1704 /* release the bindings and promises in rho if rho is no
1705 longer accessible from R */
1706 int refs = REFCNT(rho);
1707 if (refs > 0)
1708 refs -= countCycleRefs(rho, val);
1709 if (refs == 0) {
1710 for (SEXP b = FRAME(rho);
1711 b != R_NilValue && REFCNT(b) == 1;
1712 b = CDR(b)) {
1713 if (BNDCELL_TAG(b)) continue;
1714 SEXP v = CAR(b);
1715 if (REFCNT(v) == 1 && v != val) {
1716 switch(TYPEOF(v)) {
1717 case PROMSXP:
1718 clearPromise(v);
1719 break;
1720 case DOTSXP:
1721 cleanupEnvDots(v);
1722 break;
1723 case VECSXP: /* mainly for list(...) */
1724 cleanupEnvVector(v);
1725 break;
1726 }
1727 }
1728 SETCAR(b, R_NilValue);
1729 }
1730 SET_ENCLOS(rho, R_EmptyEnv);
1731 }
1732 }
1733 }
1734
unpromiseArgs(SEXP pargs)1735 void attribute_hidden unpromiseArgs(SEXP pargs)
1736 {
1737 /* This assumes pargs will no longer be references. We could
1738 double check the refcounts on pargs as a sanity check. */
1739 for (; pargs != R_NilValue; pargs = CDR(pargs)) {
1740 SEXP v = CAR(pargs);
1741 if (TYPEOF(v) == PROMSXP && REFCNT(v) == 1)
1742 clearPromise(v);
1743 SETCAR(pargs, R_NilValue);
1744 }
1745 }
1746 #else
unpromiseArgs(SEXP pargs)1747 void attribute_hidden unpromiseArgs(SEXP pargs) { }
1748 #endif
1749
1750 /* Note: GCC will not inline execClosure because it calls setjmp */
1751 static R_INLINE SEXP R_execClosure(SEXP call, SEXP newrho, SEXP sysparent,
1752 SEXP rho, SEXP arglist, SEXP op);
1753
1754 /* Apply SEXP op of type CLOSXP to actuals */
applyClosure(SEXP call,SEXP op,SEXP arglist,SEXP rho,SEXP suppliedvars)1755 SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedvars)
1756 {
1757 SEXP formals, actuals, savedrho, newrho;
1758 SEXP f, a;
1759
1760 /* formals = list of formal parameters */
1761 /* actuals = values to be bound to formals */
1762 /* arglist = the tagged list of arguments */
1763
1764 /* protection against rho = NULL */
1765 // these are deliberately not translated
1766 if (!rho)
1767 errorcall(call,
1768 "'rho' cannot be C NULL: detected in C-level applyClosure");
1769 if (!isEnvironment(rho))
1770 errorcall(call, "'rho' must be an environment not %s: detected in C-level applyClosure",
1771 type2char(TYPEOF(rho)));
1772
1773 formals = FORMALS(op);
1774 savedrho = CLOENV(op);
1775
1776 /* Build a list which matches the actual (unevaluated) arguments
1777 to the formal paramters. Build a new environment which
1778 contains the matched pairs. matchArgs_RC is used since the
1779 result becomes part of the environment frame and so needs
1780 reference couting enabled. */
1781
1782 actuals = matchArgs_RC(formals, arglist, call);
1783 PROTECT(newrho = NewEnvironment(formals, actuals, savedrho));
1784
1785 /* Use the default code for unbound formals. FIXME: It looks like
1786 this code should preceed the building of the environment so that
1787 this will also go into the hash table. */
1788
1789 /* This piece of code is destructively modifying the actuals list,
1790 which is now also the list of bindings in the frame of newrho.
1791 This is one place where internal structure of environment
1792 bindings leaks out of envir.c. It should be rewritten
1793 eventually so as not to break encapsulation of the internal
1794 environment layout. We can live with it for now since it only
1795 happens immediately after the environment creation. LT */
1796
1797 f = formals;
1798 a = actuals;
1799 while (f != R_NilValue) {
1800 if (CAR(a) == R_MissingArg && CAR(f) != R_MissingArg) {
1801 SETCAR(a, mkPROMISE(CAR(f), newrho));
1802 SET_MISSING(a, 2);
1803 }
1804 f = CDR(f);
1805 a = CDR(a);
1806 }
1807
1808 /* Fix up any extras that were supplied by usemethod. */
1809
1810 if (suppliedvars != R_NilValue)
1811 addMissingVarsToNewEnv(newrho, suppliedvars);
1812
1813 if (R_envHasNoSpecialSymbols(newrho))
1814 SET_NO_SPECIAL_SYMBOLS(newrho);
1815
1816 #ifdef ADJUST_ENVIR_REFCNTS
1817 Rboolean is_getter_call =
1818 (CADR(call) == R_TmpvalSymbol && ! R_isReplaceSymbol(CAR(call)));
1819 #endif
1820
1821 /* If we have a generic function we need to use the sysparent of
1822 the generic as the sysparent of the method because the method
1823 is a straight substitution of the generic. */
1824
1825 SEXP val = R_execClosure(call, newrho,
1826 (R_GlobalContext->callflag == CTXT_GENERIC) ?
1827 R_GlobalContext->sysparent : rho,
1828 rho, arglist, op);
1829 #ifdef ADJUST_ENVIR_REFCNTS
1830 R_CleanupEnvir(newrho, val);
1831 if (is_getter_call && MAYBE_REFERENCED(val))
1832 val = shallow_duplicate(val);
1833 #endif
1834
1835 UNPROTECT(1); /* newrho */
1836 return val;
1837 }
1838
R_execClosure(SEXP call,SEXP newrho,SEXP sysparent,SEXP rho,SEXP arglist,SEXP op)1839 static R_INLINE SEXP R_execClosure(SEXP call, SEXP newrho, SEXP sysparent,
1840 SEXP rho, SEXP arglist, SEXP op)
1841 {
1842 volatile SEXP body;
1843 RCNTXT cntxt;
1844 Rboolean dbg = FALSE;
1845
1846 begincontext(&cntxt, CTXT_RETURN, call, newrho, sysparent, arglist, op);
1847
1848 body = BODY(op);
1849 if (R_CheckJIT(op)) {
1850 int old_enabled = R_jit_enabled;
1851 R_jit_enabled = 0;
1852 R_cmpfun(op);
1853 body = BODY(op);
1854 R_jit_enabled = old_enabled;
1855 }
1856
1857 /* Get the srcref record from the closure object. The old srcref was
1858 saved in cntxt. */
1859
1860 R_Srcref = getAttrib(op, R_SrcrefSymbol);
1861
1862 /* Debugging */
1863
1864 if ((RDEBUG(op) && R_current_debug_state()) || RSTEP(op)
1865 || (RDEBUG(rho) && R_BrowserLastCommand == 's')) {
1866
1867 dbg = TRUE;
1868 SET_RSTEP(op, 0);
1869 SET_RDEBUG(newrho, 1);
1870 cntxt.browserfinish = 0; /* Don't want to inherit the "f" */
1871 /* switch to interpreted version when debugging compiled code */
1872 if (TYPEOF(body) == BCODESXP)
1873 body = bytecodeExpr(body);
1874 Rprintf("debugging in: ");
1875 PrintCall(call, rho);
1876 SrcrefPrompt("debug", R_Srcref);
1877 PrintValue(body);
1878 do_browser(call, op, R_NilValue, newrho);
1879 }
1880
1881 /* Set a longjmp target which will catch any explicit returns
1882 from the function body. */
1883
1884 if ((SETJMP(cntxt.cjmpbuf))) {
1885 if (!cntxt.jumptarget) {
1886 /* ignores intermediate jumps for on.exits */
1887 if (R_ReturnedValue == R_RestartToken) {
1888 cntxt.callflag = CTXT_RETURN; /* turn restart off */
1889 R_ReturnedValue = R_NilValue; /* remove restart token */
1890 cntxt.returnValue = eval(body, newrho);
1891 } else
1892 cntxt.returnValue = R_ReturnedValue;
1893 }
1894 else
1895 cntxt.returnValue = NULL; /* undefined */
1896 }
1897 else
1898 /* make it available to on.exit and implicitly protect */
1899 cntxt.returnValue = eval(body, newrho);
1900
1901 R_Srcref = cntxt.srcref;
1902 endcontext(&cntxt);
1903
1904 if (dbg) {
1905 Rprintf("exiting from: ");
1906 PrintCall(call, rho);
1907 }
1908
1909 /* clear R_ReturnedValue to allow GC to reclaim old value */
1910 R_ReturnedValue = R_NilValue;
1911
1912 return cntxt.returnValue;
1913 }
1914
R_forceAndCall(SEXP e,int n,SEXP rho)1915 SEXP R_forceAndCall(SEXP e, int n, SEXP rho)
1916 {
1917 SEXP fun, tmp;
1918 if (TYPEOF(CAR(e)) == SYMSXP)
1919 /* This will throw an error if the function is not found */
1920 PROTECT(fun = findFun(CAR(e), rho));
1921 else
1922 PROTECT(fun = eval(CAR(e), rho));
1923
1924 if (TYPEOF(fun) == SPECIALSXP) {
1925 int flag = PRIMPRINT(fun);
1926 PROTECT(e);
1927 R_Visible = flag != 1;
1928 tmp = PRIMFUN(fun) (e, fun, CDR(e), rho);
1929 if (flag < 2) R_Visible = flag != 1;
1930 UNPROTECT(1);
1931 }
1932 else if (TYPEOF(fun) == BUILTINSXP) {
1933 int flag = PRIMPRINT(fun);
1934 PROTECT(tmp = evalList(CDR(e), rho, e, 0));
1935 if (flag < 2) R_Visible = flag != 1;
1936 /* We used to insert a context only if profiling,
1937 but helps for tracebacks on .C etc. */
1938 if (R_Profiling || (PPINFO(fun).kind == PP_FOREIGN)) {
1939 RCNTXT cntxt;
1940 SEXP oldref = R_Srcref;
1941 begincontext(&cntxt, CTXT_BUILTIN, e,
1942 R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue);
1943 R_Srcref = NULL;
1944 tmp = PRIMFUN(fun) (e, fun, tmp, rho);
1945 R_Srcref = oldref;
1946 endcontext(&cntxt);
1947 } else {
1948 tmp = PRIMFUN(fun) (e, fun, tmp, rho);
1949 }
1950 if (flag < 2) R_Visible = flag != 1;
1951 UNPROTECT(1);
1952 }
1953 else if (TYPEOF(fun) == CLOSXP) {
1954 PROTECT(tmp = promiseArgs(CDR(e), rho));
1955 SEXP a;
1956 int i;
1957 for (a = tmp, i = 0; i < n && a != R_NilValue; a = CDR(a), i++) {
1958 SEXP p = CAR(a);
1959 if (TYPEOF(p) == PROMSXP)
1960 eval(p, rho);
1961 else if (p == R_MissingArg)
1962 errorcall(e, _("argument %d is empty"), i + 1);
1963 else error("something weird happened");
1964 }
1965 SEXP pargs = tmp;
1966 tmp = applyClosure(e, fun, pargs, rho, R_NilValue);
1967 #ifdef ADJUST_ENVIR_REFCNTS
1968 unpromiseArgs(pargs);
1969 #endif
1970 UNPROTECT(1);
1971 }
1972 else {
1973 tmp = R_NilValue; /* -Wall */
1974 error(_("attempt to apply non-function"));
1975 }
1976
1977 UNPROTECT(1);
1978 return tmp;
1979 }
1980
do_forceAndCall(SEXP call,SEXP op,SEXP args,SEXP rho)1981 SEXP attribute_hidden do_forceAndCall(SEXP call, SEXP op, SEXP args, SEXP rho)
1982 {
1983 int n = asInteger(eval(CADR(call), rho));
1984 SEXP e = CDDR(call);
1985
1986 /* this would not be needed if CDDR(call) was a LANGSXP */
1987 PROTECT(e = LCONS(CAR(e), CDR(e)));
1988 SEXP val = R_forceAndCall(e, n, rho);
1989 UNPROTECT(1);
1990 return val;
1991 }
1992
1993 /* **** FIXME: Temporary code to execute S4 methods in a way that
1994 **** preserves lexical scope. */
1995
1996 /* called from methods_list_dispatch.c */
R_execMethod(SEXP op,SEXP rho)1997 SEXP R_execMethod(SEXP op, SEXP rho)
1998 {
1999 SEXP call, arglist, callerenv, newrho, next, val;
2000 RCNTXT *cptr;
2001
2002 /* create a new environment frame enclosed by the lexical
2003 environment of the method */
2004 PROTECT(newrho = Rf_NewEnvironment(R_NilValue, R_NilValue, CLOENV(op)));
2005
2006 /* copy the bindings for the formal environment from the top frame
2007 of the internal environment of the generic call to the new
2008 frame. need to make sure missingness information is preserved
2009 and the environments for any default expression promises are
2010 set to the new environment. should move this to envir.c where
2011 it can be done more efficiently. */
2012 for (next = FORMALS(op); next != R_NilValue; next = CDR(next)) {
2013 SEXP symbol = TAG(next);
2014 R_varloc_t loc;
2015 int missing;
2016 loc = R_findVarLocInFrame(rho,symbol);
2017 if(R_VARLOC_IS_NULL(loc))
2018 error(_("could not find symbol \"%s\" in environment of the generic function"),
2019 CHAR(PRINTNAME(symbol)));
2020 missing = R_GetVarLocMISSING(loc);
2021 val = R_GetVarLocValue(loc);
2022 SET_FRAME(newrho, CONS(val, FRAME(newrho)));
2023 SET_TAG(FRAME(newrho), symbol);
2024 if (missing) {
2025 SET_MISSING(FRAME(newrho), missing);
2026 if (TYPEOF(val) == PROMSXP && PRENV(val) == rho) {
2027 SEXP deflt;
2028 SET_PRENV(val, newrho);
2029 /* find the symbol in the method, copy its expression
2030 * to the promise */
2031 for(deflt = CAR(op); deflt != R_NilValue; deflt = CDR(deflt)) {
2032 if(TAG(deflt) == symbol)
2033 break;
2034 }
2035 if(deflt == R_NilValue)
2036 error(_("symbol \"%s\" not in environment of method"),
2037 CHAR(PRINTNAME(symbol)));
2038 SET_PRCODE(val, CAR(deflt));
2039 }
2040 }
2041 #ifdef SWITCH_TO_REFCNT
2042 /* re-promise to get referenve counts for references from rho
2043 and newrho right. */
2044 if (TYPEOF(val) == PROMSXP)
2045 SETCAR(FRAME(newrho), mkPROMISE(val, rho));
2046 #endif
2047 }
2048
2049 /* copy the bindings of the special dispatch variables in the top
2050 frame of the generic call to the new frame */
2051 defineVar(R_dot_defined, findVarInFrame(rho, R_dot_defined), newrho);
2052 defineVar(R_dot_Method, findVarInFrame(rho, R_dot_Method), newrho);
2053 defineVar(R_dot_target, findVarInFrame(rho, R_dot_target), newrho);
2054
2055 /* copy the bindings for .Generic and .Methods. We know (I think)
2056 that they are in the second frame, so we could use that. */
2057 defineVar(R_dot_Generic, findVar(R_dot_Generic, rho), newrho);
2058 defineVar(R_dot_Methods, findVar(R_dot_Methods, rho), newrho);
2059
2060 /* Find the calling context. Should be R_GlobalContext unless
2061 profiling has inserted a CTXT_BUILTIN frame. */
2062 cptr = R_GlobalContext;
2063 if (cptr->callflag & CTXT_BUILTIN)
2064 cptr = cptr->nextcontext;
2065
2066 /* The calling environment should either be the environment of the
2067 generic, rho, or the environment of the caller of the generic,
2068 the current sysparent. */
2069 callerenv = cptr->sysparent; /* or rho? */
2070
2071 /* get the rest of the stuff we need from the current context,
2072 execute the method, and return the result */
2073 call = cptr->call;
2074 arglist = cptr->promargs;
2075 val = R_execClosure(call, newrho, callerenv, callerenv, arglist, op);
2076 #ifdef ADJUST_ENVIR_REFCNTS
2077 R_CleanupEnvir(newrho, val);
2078 #endif
2079 UNPROTECT(1);
2080 return val;
2081 }
2082
EnsureLocal(SEXP symbol,SEXP rho,R_varloc_t * ploc)2083 static SEXP EnsureLocal(SEXP symbol, SEXP rho, R_varloc_t *ploc)
2084 {
2085 SEXP vl;
2086
2087 if ((vl = findVarInFrame3(rho, symbol, TRUE)) != R_UnboundValue) {
2088 vl = eval(symbol, rho); /* for promises */
2089 if(MAYBE_SHARED(vl)) {
2090 /* Using R_shallow_duplicate_attr may defer duplicating
2091 data until it it is needed. If the data are duplicated,
2092 then the wrapper can be discarded at the end of the
2093 assignment process in try_assign_unwrap(). */
2094 PROTECT(vl);
2095 PROTECT(vl = R_shallow_duplicate_attr(vl));
2096 defineVar(symbol, vl, rho);
2097 INCREMENT_NAMED(vl);
2098 UNPROTECT(2);
2099 }
2100 PROTECT(vl); /* R_findVarLocInFrame allocates for user databases */
2101 *ploc = R_findVarLocInFrame(rho, symbol);
2102 UNPROTECT(1);
2103 return vl;
2104 }
2105
2106 vl = eval(symbol, ENCLOS(rho));
2107 if (vl == R_UnboundValue)
2108 error(_("object '%s' not found"), EncodeChar(PRINTNAME(symbol)));
2109
2110 PROTECT(vl = shallow_duplicate(vl));
2111 defineVar(symbol, vl, rho);
2112 *ploc = R_findVarLocInFrame(rho, symbol);
2113 INCREMENT_NAMED(vl);
2114 UNPROTECT(1);
2115 return vl;
2116 }
2117
2118
2119 /* Note: If val is a language object it must be protected */
2120 /* to prevent evaluation. As an example consider */
2121 /* e <- quote(f(x=1,y=2); names(e) <- c("","a","b") */
2122
2123 static SEXP R_valueSym = NULL; /* initialized in R_initAssignSymbols below */
2124
replaceCall(SEXP fun,SEXP val,SEXP args,SEXP rhs)2125 static SEXP replaceCall(SEXP fun, SEXP val, SEXP args, SEXP rhs)
2126 {
2127 SEXP tmp, ptmp;
2128 PROTECT(fun);
2129 PROTECT(args);
2130 PROTECT(rhs);
2131 PROTECT(val);
2132 ptmp = tmp = allocList(length(args)+3);
2133 UNPROTECT(4);
2134 SETCAR(ptmp, fun); ptmp = CDR(ptmp);
2135 SETCAR(ptmp, val); ptmp = CDR(ptmp);
2136 while(args != R_NilValue) {
2137 SETCAR(ptmp, CAR(args));
2138 SET_TAG(ptmp, TAG(args));
2139 ptmp = CDR(ptmp);
2140 args = CDR(args);
2141 }
2142 SETCAR(ptmp, rhs);
2143 SET_TAG(ptmp, R_valueSym);
2144 SET_TYPEOF(tmp, LANGSXP);
2145 MARK_ASSIGNMENT_CALL(tmp);
2146 return tmp;
2147 }
2148
2149
2150 /* rho is only needed for _R_CHECK_LENGTH_1_CONDITION_=package:name and for
2151 detecting the current package in related diagnostic messages; it should
2152 be removed when length >1 condition is turned into an error
2153 */
asLogicalNoNA(SEXP s,SEXP call,SEXP rho)2154 static R_INLINE Rboolean asLogicalNoNA(SEXP s, SEXP call, SEXP rho)
2155 {
2156 Rboolean cond = NA_LOGICAL;
2157
2158 /* handle most common special case directly */
2159 if (IS_SCALAR(s, LGLSXP)) {
2160 cond = SCALAR_LVAL(s);
2161 if (cond != NA_LOGICAL)
2162 return cond;
2163 }
2164 else if (IS_SCALAR(s, INTSXP)) {
2165 int val = SCALAR_IVAL(s);
2166 if (val != NA_INTEGER)
2167 return val != 0;
2168 }
2169
2170 int len = length(s);
2171 if (len > 1) {
2172 /* PROTECT(s) needed as per PR#15990. call gets protected by
2173 warningcall(). Now "s" is protected by caller and also
2174 R_BadValueInRCode disables GC. */
2175 R_BadValueInRCode(s, call, rho,
2176 "the condition has length > 1",
2177 _("the condition has length > 1"),
2178 _("the condition has length > 1 and only the first element will be used"),
2179 "_R_CHECK_LENGTH_1_CONDITION_",
2180 TRUE /* by default issue warning */);
2181 }
2182 if (len > 0) {
2183 /* inline common cases for efficiency */
2184 switch(TYPEOF(s)) {
2185 case LGLSXP:
2186 cond = LOGICAL(s)[0];
2187 break;
2188 case INTSXP:
2189 cond = INTEGER(s)[0]; /* relies on NA_INTEGER == NA_LOGICAL */
2190 break;
2191 default:
2192 cond = asLogical(s);
2193 }
2194 }
2195
2196 if (cond == NA_LOGICAL) {
2197 char *msg = len ? (isLogical(s) ?
2198 _("missing value where TRUE/FALSE needed") :
2199 _("argument is not interpretable as logical")) :
2200 _("argument is of length zero");
2201 errorcall(call, msg);
2202 }
2203 return cond;
2204 }
2205
2206
2207 #define BodyHasBraces(body) \
2208 ((isLanguage(body) && CAR(body) == R_BraceSymbol) ? 1 : 0)
2209
2210 /* Allocate space for the loop variable value the first time through
2211 (when v == R_NilValue) and when the value may have been assigned to
2212 another variable. This should be safe and avoid allocation in many
2213 cases. */
2214 #define ALLOC_LOOP_VAR(v, val_type, vpi) do { \
2215 if (v == R_NilValue || MAYBE_SHARED(v) || \
2216 ATTRIB(v) != R_NilValue || (v) != CAR(cell)) { \
2217 REPROTECT(v = allocVector(val_type, 1), vpi); \
2218 INCREMENT_NAMED(v); \
2219 } \
2220 } while(0)
2221
do_if(SEXP call,SEXP op,SEXP args,SEXP rho)2222 SEXP attribute_hidden do_if(SEXP call, SEXP op, SEXP args, SEXP rho)
2223 {
2224 SEXP Cond, Stmt=R_NilValue;
2225 int vis=0;
2226
2227 PROTECT(Cond = eval(CAR(args), rho));
2228 if (asLogicalNoNA(Cond, call, rho))
2229 Stmt = CAR(CDR(args));
2230 else {
2231 if (length(args) > 2)
2232 Stmt = CAR(CDR(CDR(args)));
2233 else
2234 vis = 1;
2235 }
2236 if( !vis && RDEBUG(rho) && !BodyHasBraces(Stmt) && !R_GlobalContext->browserfinish) {
2237 SrcrefPrompt("debug", R_Srcref);
2238 PrintValue(Stmt);
2239 do_browser(call, op, R_NilValue, rho);
2240 }
2241 UNPROTECT(1);
2242 if( vis ) {
2243 R_Visible = FALSE; /* case of no 'else' so return invisible NULL */
2244 return Stmt;
2245 }
2246 return (eval(Stmt, rho));
2247 }
2248
2249 #define IS_USER_DATABASE(rho) \
2250 (OBJECT((rho)) && inherits((rho), "UserDefinedDatabase"))
2251
GET_BINDING_CELL(SEXP symbol,SEXP rho)2252 static R_INLINE SEXP GET_BINDING_CELL(SEXP symbol, SEXP rho)
2253 {
2254 if (rho == R_BaseEnv || rho == R_BaseNamespace || IS_USER_DATABASE(rho))
2255 return R_NilValue;
2256 else {
2257 R_varloc_t loc = R_findVarLocInFrame(rho, symbol);
2258 return (! R_VARLOC_IS_NULL(loc) && ! IS_ACTIVE_BINDING(loc.cell)) ?
2259 loc.cell : R_NilValue;
2260 }
2261 }
2262
SET_BINDING_VALUE(SEXP loc,SEXP value)2263 static R_INLINE Rboolean SET_BINDING_VALUE(SEXP loc, SEXP value) {
2264 /* This depends on the current implementation of bindings */
2265 if (loc != R_NilValue &&
2266 ! BINDING_IS_LOCKED(loc) && ! IS_ACTIVE_BINDING(loc)) {
2267 if (BNDCELL_TAG(loc) || CAR(loc) != value) {
2268 SET_BNDCELL(loc, value);
2269 if (MISSING(loc))
2270 SET_MISSING(loc, 0);
2271 }
2272 return TRUE;
2273 }
2274 else
2275 return FALSE;
2276 }
2277
do_for(SEXP call,SEXP op,SEXP args,SEXP rho)2278 SEXP attribute_hidden do_for(SEXP call, SEXP op, SEXP args, SEXP rho)
2279 {
2280 /* Need to declare volatile variables whose values are relied on
2281 after for_next or for_break longjmps and might change between
2282 the setjmp and longjmp calls. Theoretically this does not
2283 include n and bgn, but gcc -O2 -Wclobbered warns about these so
2284 to be safe we declare them volatile as well. */
2285 volatile R_xlen_t i = 0, n;
2286 volatile int bgn;
2287 volatile SEXP v, val, cell;
2288 int dbg, val_type;
2289 SEXP sym, body;
2290 RCNTXT cntxt;
2291 PROTECT_INDEX vpi;
2292
2293 checkArity(op, args);
2294 sym = CAR(args);
2295 val = CADR(args);
2296 body = CADDR(args);
2297
2298 if ( !isSymbol(sym) ) errorcall(call, _("non-symbol loop variable"));
2299
2300 dbg = RDEBUG(rho);
2301 if (R_jit_enabled > 2 && !dbg && !R_disable_bytecode
2302 && rho == R_GlobalEnv
2303 && isUnmodifiedSpecSym(CAR(call), rho)
2304 && R_compileAndExecute(call, rho))
2305 return R_NilValue;
2306
2307 PROTECT(args);
2308 PROTECT(rho);
2309 PROTECT(val = eval(val, rho));
2310
2311 /* deal with the case where we are iterating over a factor
2312 we need to coerce to character - then iterate */
2313
2314 if ( inherits(val, "factor") ) {
2315 SEXP tmp = asCharacterFactor(val);
2316 UNPROTECT(1); /* val from above */
2317 PROTECT(val = tmp);
2318 }
2319
2320 if (isList(val) || isNull(val))
2321 n = length(val);
2322 else
2323 n = XLENGTH(val);
2324
2325 val_type = TYPEOF(val);
2326
2327 defineVar(sym, R_NilValue, rho);
2328 PROTECT(cell = GET_BINDING_CELL(sym, rho));
2329 bgn = BodyHasBraces(body);
2330
2331 /* bump up links count of sequence to avoid modification by loop code */
2332 INCREMENT_LINKS(val);
2333
2334 PROTECT_WITH_INDEX(v = R_NilValue, &vpi);
2335
2336 begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue,
2337 R_NilValue);
2338 switch (SETJMP(cntxt.cjmpbuf)) {
2339 case CTXT_BREAK: goto for_break;
2340 case CTXT_NEXT: goto for_next;
2341 }
2342
2343 for (i = 0; i < n; i++) {
2344
2345 switch (val_type) {
2346
2347 case EXPRSXP:
2348 case VECSXP:
2349 /* make sure loop variable is not modified via other vars */
2350 ENSURE_NAMEDMAX(VECTOR_ELT(val, i));
2351 /* defineVar is used here and below rather than setVar in
2352 case the loop code removes the variable. */
2353 defineVar(sym, VECTOR_ELT(val, i), rho);
2354 break;
2355
2356 case LISTSXP:
2357 /* make sure loop variable is not modified via other vars */
2358 ENSURE_NAMEDMAX(CAR(val));
2359 defineVar(sym, CAR(val), rho);
2360 val = CDR(val);
2361 break;
2362
2363 default:
2364
2365 switch (val_type) {
2366 case LGLSXP:
2367 ALLOC_LOOP_VAR(v, val_type, vpi);
2368 SET_SCALAR_LVAL(v, LOGICAL_ELT(val, i));
2369 break;
2370 case INTSXP:
2371 ALLOC_LOOP_VAR(v, val_type, vpi);
2372 SET_SCALAR_IVAL(v, INTEGER_ELT(val, i));
2373 break;
2374 case REALSXP:
2375 ALLOC_LOOP_VAR(v, val_type, vpi);
2376 SET_SCALAR_DVAL(v, REAL_ELT(val, i));
2377 break;
2378 case CPLXSXP:
2379 ALLOC_LOOP_VAR(v, val_type, vpi);
2380 SET_SCALAR_CVAL(v, COMPLEX_ELT(val, i));
2381 break;
2382 case STRSXP:
2383 ALLOC_LOOP_VAR(v, val_type, vpi);
2384 SET_STRING_ELT(v, 0, STRING_ELT(val, i));
2385 break;
2386 case RAWSXP:
2387 ALLOC_LOOP_VAR(v, val_type, vpi);
2388 SET_SCALAR_BVAL(v, RAW(val)[i]);
2389 break;
2390 default:
2391 errorcall(call, _("invalid for() loop sequence"));
2392 }
2393 if (CAR(cell) == R_UnboundValue || ! SET_BINDING_VALUE(cell, v))
2394 defineVar(sym, v, rho);
2395 }
2396 if (!bgn && RDEBUG(rho) && !R_GlobalContext->browserfinish) {
2397 SrcrefPrompt("debug", R_Srcref);
2398 PrintValue(body);
2399 do_browser(call, op, R_NilValue, rho);
2400 }
2401 eval(body, rho);
2402
2403 for_next:
2404 ; /* needed for strict ISO C compliance, according to gcc 2.95.2 */
2405 }
2406 for_break:
2407 endcontext(&cntxt);
2408 DECREMENT_LINKS(val);
2409 UNPROTECT(5);
2410 SET_RDEBUG(rho, dbg);
2411 return R_NilValue;
2412 }
2413
2414
do_while(SEXP call,SEXP op,SEXP args,SEXP rho)2415 SEXP attribute_hidden do_while(SEXP call, SEXP op, SEXP args, SEXP rho)
2416 {
2417 int dbg;
2418 volatile int bgn;
2419 volatile SEXP body;
2420 RCNTXT cntxt;
2421
2422 checkArity(op, args);
2423
2424 dbg = RDEBUG(rho);
2425 if (R_jit_enabled > 2 && !dbg && !R_disable_bytecode
2426 && rho == R_GlobalEnv
2427 && isUnmodifiedSpecSym(CAR(call), rho)
2428 && R_compileAndExecute(call, rho))
2429 return R_NilValue;
2430
2431 body = CADR(args);
2432 bgn = BodyHasBraces(body);
2433
2434 begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue,
2435 R_NilValue);
2436 if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) {
2437 for(;;) {
2438 SEXP cond = PROTECT(eval(CAR(args), rho));
2439 int condl = asLogicalNoNA(cond, call, rho);
2440 UNPROTECT(1);
2441 if (!condl) break;
2442 if (RDEBUG(rho) && !bgn && !R_GlobalContext->browserfinish) {
2443 SrcrefPrompt("debug", R_Srcref);
2444 PrintValue(body);
2445 do_browser(call, op, R_NilValue, rho);
2446 }
2447 eval(body, rho);
2448 if (RDEBUG(rho) && !R_GlobalContext->browserfinish) {
2449 SrcrefPrompt("debug", R_Srcref);
2450 Rprintf("(while) ");
2451 PrintValue(CAR(args));
2452 do_browser(call, op, R_NilValue, rho);
2453 }
2454 }
2455 }
2456 endcontext(&cntxt);
2457 SET_RDEBUG(rho, dbg);
2458 return R_NilValue;
2459 }
2460
2461
do_repeat(SEXP call,SEXP op,SEXP args,SEXP rho)2462 SEXP attribute_hidden do_repeat(SEXP call, SEXP op, SEXP args, SEXP rho)
2463 {
2464 int dbg;
2465 volatile SEXP body;
2466 RCNTXT cntxt;
2467
2468 checkArity(op, args);
2469
2470 dbg = RDEBUG(rho);
2471 if (R_jit_enabled > 2 && !dbg && !R_disable_bytecode
2472 && rho == R_GlobalEnv
2473 && isUnmodifiedSpecSym(CAR(call), rho)
2474 && R_compileAndExecute(call, rho))
2475 return R_NilValue;
2476
2477 body = CAR(args);
2478
2479 begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue,
2480 R_NilValue);
2481 if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) {
2482 for (;;) {
2483 eval(body, rho);
2484 }
2485 }
2486 endcontext(&cntxt);
2487 SET_RDEBUG(rho, dbg);
2488 return R_NilValue;
2489 }
2490
2491
do_break(SEXP call,SEXP op,SEXP args,SEXP rho)2492 SEXP attribute_hidden NORET do_break(SEXP call, SEXP op, SEXP args, SEXP rho)
2493 {
2494 checkArity(op, args);
2495 findcontext(PRIMVAL(op), rho, R_NilValue);
2496 }
2497
2498
do_paren(SEXP call,SEXP op,SEXP args,SEXP rho)2499 SEXP attribute_hidden do_paren(SEXP call, SEXP op, SEXP args, SEXP rho)
2500 {
2501 checkArity(op, args);
2502 return CAR(args);
2503 }
2504
do_begin(SEXP call,SEXP op,SEXP args,SEXP rho)2505 SEXP attribute_hidden do_begin(SEXP call, SEXP op, SEXP args, SEXP rho)
2506 {
2507 SEXP s = R_NilValue;
2508 if (args != R_NilValue) {
2509 SEXP srcrefs = getBlockSrcrefs(call);
2510 PROTECT(srcrefs);
2511 int i = 1;
2512 while (args != R_NilValue) {
2513 PROTECT(R_Srcref = getSrcref(srcrefs, i++));
2514 if (RDEBUG(rho) && !R_GlobalContext->browserfinish) {
2515 SrcrefPrompt("debug", R_Srcref);
2516 PrintValue(CAR(args));
2517 do_browser(call, op, R_NilValue, rho);
2518 }
2519 s = eval(CAR(args), rho);
2520 UNPROTECT(1);
2521 args = CDR(args);
2522 }
2523 R_Srcref = R_NilValue;
2524 UNPROTECT(1); /* srcrefs */
2525 }
2526 return s;
2527 }
2528
2529
do_return(SEXP call,SEXP op,SEXP args,SEXP rho)2530 SEXP attribute_hidden NORET do_return(SEXP call, SEXP op, SEXP args, SEXP rho)
2531 {
2532 SEXP v;
2533
2534 if (args == R_NilValue) /* zero arguments provided */
2535 v = R_NilValue;
2536 else if (CDR(args) == R_NilValue) /* one argument */
2537 v = eval(CAR(args), rho);
2538 else {
2539 v = R_NilValue; /* to avoid compiler warnings */
2540 errorcall(call, _("multi-argument returns are not permitted"));
2541 }
2542
2543 findcontext(CTXT_BROWSER | CTXT_FUNCTION, rho, v);
2544 }
2545
2546 /* Declared with a variable number of args in names.c */
do_function(SEXP call,SEXP op,SEXP args,SEXP rho)2547 SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
2548 {
2549 SEXP rval, srcref;
2550
2551 if (TYPEOF(op) == PROMSXP) {
2552 op = forcePromise(op);
2553 ENSURE_NAMEDMAX(op);
2554 }
2555 if (length(args) < 2) WrongArgCount("function");
2556 CheckFormals(CAR(args));
2557 rval = mkCLOSXP(CAR(args), CADR(args), rho);
2558 srcref = CADDR(args);
2559 if (!isNull(srcref)) setAttrib(rval, R_SrcrefSymbol, srcref);
2560 return rval;
2561 }
2562
2563
2564 /*
2565 * Assignments for complex LVAL specifications. This is the stuff that
2566 * nightmares are made of ... Note that "evalseq" preprocesses the LHS
2567 * of an assignment. Given an expression, it builds a list of partial
2568 * values for the exression. For example, the assignment x$a[3] <- 10
2569 * with LHS x$a[3] yields the (improper) list:
2570 *
2571 * (eval(x$a[3]) eval(x$a) eval(x) . x)
2572 *
2573 * (Note the terminating symbol). The partial evaluations are carried
2574 * out efficiently using previously computed components.
2575 */
2576
2577 /*
2578 For complex superassignment x[y==z]<<-w
2579 we want x required to be nonlocal, y,z, and w permitted to be local or
2580 nonlocal.
2581 */
2582
evalseq(SEXP expr,SEXP rho,int forcelocal,R_varloc_t tmploc,R_varloc_t * ploc)2583 static SEXP evalseq(SEXP expr, SEXP rho, int forcelocal, R_varloc_t tmploc,
2584 R_varloc_t *ploc)
2585 {
2586 SEXP val, nval, nexpr;
2587 if (isNull(expr))
2588 error(_("invalid (NULL) left side of assignment"));
2589 if (isSymbol(expr)) { /* now we are down to the target symbol */
2590 PROTECT(expr);
2591 if(forcelocal) {
2592 nval = EnsureLocal(expr, rho, ploc);
2593 }
2594 else {
2595 nval = eval(expr, ENCLOS(rho));
2596 PROTECT(nval); /* R_findVarLoc allocates for user databases */
2597 *ploc = R_findVarLoc(expr, ENCLOS(rho));
2598 UNPROTECT(1);
2599 }
2600 int maybe_in_assign = ploc->cell ?
2601 ASSIGNMENT_PENDING(ploc->cell) : FALSE;
2602 if (ploc->cell)
2603 SET_ASSIGNMENT_PENDING(ploc->cell, TRUE);
2604 if (maybe_in_assign || MAYBE_SHARED(nval))
2605 nval = shallow_duplicate(nval);
2606 UNPROTECT(1);
2607 return CONS_NR(nval, expr);
2608 }
2609 else if (isLanguage(expr)) {
2610 PROTECT(expr);
2611 PROTECT(val = evalseq(CADR(expr), rho, forcelocal, tmploc, ploc));
2612 R_SetVarLocValue(tmploc, CAR(val));
2613 PROTECT(nexpr = LCONS(R_GetVarLocSymbol(tmploc), CDDR(expr)));
2614 PROTECT(nexpr = LCONS(CAR(expr), nexpr));
2615 nval = eval(nexpr, rho);
2616 /* duplicate nval if it might be shared _or_ if the container,
2617 CAR(val), has become possibly shared by going through a
2618 closure. This is taken to indicate that the corresponding
2619 replacement function might be a closure and will need to
2620 see an unmodified LHS value. This heuristic fails if the
2621 accessor function called here is not a closure but the
2622 replacement function is. */
2623 if (MAYBE_REFERENCED(nval) &&
2624 (MAYBE_SHARED(nval) || MAYBE_SHARED(CAR(val))))
2625 nval = shallow_duplicate(nval);
2626 UNPROTECT(4);
2627 return CONS_NR(nval, val);
2628 }
2629 else error(_("target of assignment expands to non-language object"));
2630 return R_NilValue; /*NOTREACHED*/
2631 }
2632
2633 /* Main entry point for complex assignments */
2634 /* We have checked to see that CAR(args) is a LANGSXP */
2635
2636 static const char * const asym[] = {":=", "<-", "<<-", "="};
2637 #define NUM_ASYM (sizeof(asym) / sizeof(char *))
2638 static SEXP asymSymbol[NUM_ASYM];
2639
2640 static SEXP R_ReplaceFunsTable = NULL;
2641 static SEXP R_SubsetSym = NULL;
2642 static SEXP R_SubassignSym = NULL;
2643 static SEXP R_Subset2Sym = NULL;
2644 static SEXP R_Subassign2Sym = NULL;
2645 static SEXP R_DollarGetsSymbol = NULL;
2646 static SEXP R_AssignSym = NULL;
2647
R_initAssignSymbols(void)2648 void attribute_hidden R_initAssignSymbols(void)
2649 {
2650 for (int i = 0; i < NUM_ASYM; i++)
2651 asymSymbol[i] = install(asym[i]);
2652
2653 R_ReplaceFunsTable = R_NewHashedEnv(R_EmptyEnv, ScalarInteger(1099));
2654 R_PreserveObject(R_ReplaceFunsTable);
2655
2656 R_SubsetSym = install("[");
2657 R_SubassignSym = install("[<-");
2658 R_Subset2Sym = install("[[");
2659 R_Subassign2Sym = install("[[<-");
2660 R_DollarGetsSymbol = install("$<-");
2661 R_valueSym = install("value");
2662 R_AssignSym = install("<-");
2663 }
2664
lookupAssignFcnSymbol(SEXP fun)2665 static R_INLINE SEXP lookupAssignFcnSymbol(SEXP fun)
2666 {
2667 return findVarInFrame(R_ReplaceFunsTable, fun);
2668 }
2669
enterAssignFcnSymbol(SEXP fun,SEXP val)2670 static void enterAssignFcnSymbol(SEXP fun, SEXP val)
2671 {
2672 defineVar(fun, val, R_ReplaceFunsTable);
2673 }
2674
tmp_cleanup(void * data)2675 static void tmp_cleanup(void *data)
2676 {
2677 unbindVar(R_TmpvalSymbol, (SEXP) data);
2678 }
2679
2680 /* This macro stores the current assignment target in the saved
2681 binding location. It duplicates if necessary to make sure
2682 replacement functions are always called with a target with NAMED ==
2683 1. The SET_CAR is intended to protect against possible GC in
2684 R_SetVarLocValue; this might occur it the binding is an active
2685 binding. */
2686 #define SET_TEMPVARLOC_FROM_CAR(loc, lhs) do { \
2687 SEXP __lhs__ = (lhs); \
2688 SEXP __v__ = CAR(__lhs__); \
2689 if (MAYBE_SHARED(__v__)) { \
2690 __v__ = shallow_duplicate(__v__); \
2691 ENSURE_NAMED(__v__); \
2692 SETCAR(__lhs__, __v__); \
2693 } \
2694 R_SetVarLocValue(loc, __v__); \
2695 } while(0)
2696
2697 /* This macro makes sure the RHS NAMED value is 0 or NAMEDMAX. This is
2698 necessary to make sure the RHS value returned by the assignment
2699 expression is correct when the RHS value is part of the LHS
2700 object. */
2701 #define FIXUP_RHS_NAMED(r) do { \
2702 SEXP __rhs__ = (r); \
2703 if (NAMED(__rhs__)) \
2704 ENSURE_NAMEDMAX(__rhs__); \
2705 } while (0)
2706
2707 #define ASSIGNBUFSIZ 32
installAssignFcnSymbol(SEXP fun)2708 static SEXP installAssignFcnSymbol(SEXP fun)
2709 {
2710 char buf[ASSIGNBUFSIZ];
2711
2712 /* install the symbol */
2713 if(strlen(CHAR(PRINTNAME(fun))) + 3 > ASSIGNBUFSIZ)
2714 error(_("overlong name in '%s'"), EncodeChar(PRINTNAME(fun)));
2715 sprintf(buf, "%s<-", CHAR(PRINTNAME(fun)));
2716 SEXP val = install(buf);
2717
2718 enterAssignFcnSymbol(fun, val);
2719 return val;
2720 }
2721
getAssignFcnSymbol(SEXP fun)2722 static R_INLINE SEXP getAssignFcnSymbol(SEXP fun)
2723 {
2724 /* handle [<-, [[<-, and $<- efficiently */
2725 if (fun == R_SubsetSym)
2726 return R_SubassignSym;
2727 else if (fun == R_Subset2Sym)
2728 return R_Subassign2Sym;
2729 else if (fun == R_DollarSymbol)
2730 return R_DollarGetsSymbol;
2731
2732 /* look up in the replacement functions table */
2733 SEXP val = lookupAssignFcnSymbol(fun);
2734 if (val != R_UnboundValue)
2735 return val;
2736
2737 /* instal symbol, entern in table, and return */
2738 return installAssignFcnSymbol(fun);
2739 }
2740
mkRHSPROMISE(SEXP expr,SEXP rhs)2741 static R_INLINE SEXP mkRHSPROMISE(SEXP expr, SEXP rhs)
2742 {
2743 return R_mkEVPROMISE_NR(expr, rhs);
2744 }
2745
2746 static SEXP GET_BINDING_CELL(SEXP, SEXP);
2747 static SEXP BINDING_VALUE(SEXP);
2748
2749 static R_INLINE SEXP
try_assign_unwrap(SEXP value,SEXP sym,SEXP rho,SEXP cell)2750 try_assign_unwrap(SEXP value, SEXP sym, SEXP rho, SEXP cell)
2751 {
2752 /* If EnsureLocal() has introduced a wrapper for the LHS object in
2753 a complex assignment and the data has been duplicated, then it
2754 may be possible to remove the wrapper before assigning the
2755 final value to a its symbol. */
2756 if (! MAYBE_REFERENCED(value))
2757 /* Typical case for NAMED; can also happen for REFCNT. */
2758 return R_tryUnwrap(value);
2759 #ifdef SWITCH_TO_REFCNT
2760 else {
2761 /* Typical case for REFCNT; might not be safe to unwrap for NAMED. */
2762 if (! MAYBE_SHARED(value)) {
2763 if (cell == NULL) /* for AST; byte code has the binding */
2764 cell = GET_BINDING_CELL(sym, rho);
2765 /* Ruling out active bindigns may not be necessary at this
2766 point, but just to be safe ... */
2767 if (! IS_ACTIVE_BINDING(cell) &&
2768 value == BINDING_VALUE(cell))
2769 return R_tryUnwrap(value);
2770 }
2771 }
2772 #endif
2773 return value;
2774 }
2775
applydefine(SEXP call,SEXP op,SEXP args,SEXP rho)2776 static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
2777 {
2778 SEXP expr, lhs, rhs, saverhs, tmp, afun, rhsprom;
2779 R_varloc_t tmploc;
2780 RCNTXT cntxt;
2781 int nprot;
2782
2783 expr = CAR(args);
2784
2785 /* It's important that the rhs get evaluated first because
2786 assignment is right associative i.e. a <- b <- c is parsed as
2787 a <- (b <- c). */
2788
2789 INCREMENT_BCSTACK_LINKS();
2790 INCLNK_stack_commit();
2791
2792 PROTECT(saverhs = rhs = eval(CADR(args), rho));
2793 #ifdef SWITCH_TO_REFCNT
2794 int refrhs = MAYBE_REFERENCED(saverhs);
2795 if (refrhs) INCREMENT_REFCNT(saverhs);
2796 #endif
2797
2798 /* FIXME: We need to ensure that this works for hashed
2799 environments. This code only works for unhashed ones. the
2800 syntax error here is a deliberate marker so I don't forget that
2801 this needs to be done. The code used in "missing" will help
2802 here. */
2803
2804 /* FIXME: This strategy will not work when we are working in the
2805 data frame defined by the system hash table. The structure there
2806 is different. Should we special case here? */
2807
2808 /* We need a temporary variable to hold the intermediate values
2809 in the computation. For efficiency reasons we record the
2810 location where this variable is stored. We need to protect
2811 the location in case the biding is removed from its
2812 environment by user code or an assignment within the
2813 assignment arguments */
2814
2815 /* There are two issues with the approach here:
2816
2817 A complex assignment within a complex assignment, like
2818 f(x, y[] <- 1) <- 3, can cause the value temporary
2819 variable for the outer assignment to be overwritten and
2820 then removed by the inner one. This could be addressed by
2821 using multiple temporaries or using a promise for this
2822 variable as is done for the RHS. Printing of the
2823 replacement function call in error messages might then need
2824 to be adjusted.
2825
2826 With assignments of the form f(g(x, z), y) <- w the value
2827 of 'z' will be computed twice, once for a call to g(x, z)
2828 and once for the call to the replacement function g<-. It
2829 might be possible to address this by using promises.
2830 Using more temporaries would not work as it would mess up
2831 replacement functions that use substitute and/or
2832 nonstandard evaluation (and there are packages that do
2833 that -- igraph is one).
2834
2835 LT */
2836
2837 FIXUP_RHS_NAMED(rhs);
2838
2839 if (rho == R_BaseNamespace)
2840 errorcall(call, _("cannot do complex assignments in base namespace"));
2841 if (rho == R_BaseEnv)
2842 errorcall(call, _("cannot do complex assignments in base environment"));
2843 defineVar(R_TmpvalSymbol, R_NilValue, rho);
2844 tmploc = R_findVarLocInFrame(rho, R_TmpvalSymbol);
2845 PROTECT(tmploc.cell);
2846 DISABLE_REFCNT(tmploc.cell);
2847 DECREMENT_REFCNT(CDR(tmploc.cell));
2848
2849 /* Now set up a context to remove it when we are done, even in the
2850 * case of an error. This all helps error() provide a better call.
2851 */
2852 begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
2853 R_NilValue, R_NilValue);
2854 cntxt.cend = &tmp_cleanup;
2855 cntxt.cenddata = rho;
2856
2857 /* Do a partial evaluation down through the LHS. */
2858 R_varloc_t lhsloc;
2859 lhs = evalseq(CADR(expr), rho,
2860 PRIMVAL(op)==1 || PRIMVAL(op)==3, tmploc, &lhsloc);
2861 if (lhsloc.cell == NULL)
2862 lhsloc.cell = R_NilValue;
2863 PROTECT(lhsloc.cell);
2864
2865 PROTECT(lhs);
2866 PROTECT(rhsprom = mkRHSPROMISE(CADR(args), rhs));
2867
2868 while (isLanguage(CADR(expr))) {
2869 nprot = 1; /* the PROTECT of rhs below from this iteration */
2870 if (TYPEOF(CAR(expr)) == SYMSXP)
2871 tmp = getAssignFcnSymbol(CAR(expr));
2872 else {
2873 /* check for and handle assignments of the form
2874 foo::bar(x) <- y or foo:::bar(x) <- y */
2875 tmp = R_NilValue; /* avoid uninitialized variable warnings */
2876 if (TYPEOF(CAR(expr)) == LANGSXP &&
2877 (CAR(CAR(expr)) == R_DoubleColonSymbol ||
2878 CAR(CAR(expr)) == R_TripleColonSymbol) &&
2879 length(CAR(expr)) == 3 && TYPEOF(CADDR(CAR(expr))) == SYMSXP) {
2880 tmp = getAssignFcnSymbol(CADDR(CAR(expr)));
2881 PROTECT(tmp = lang3(CAAR(expr), CADR(CAR(expr)), tmp));
2882 nprot++;
2883 }
2884 else
2885 error(_("invalid function in complex assignment"));
2886 }
2887 SET_TEMPVARLOC_FROM_CAR(tmploc, lhs);
2888 PROTECT(rhs = replaceCall(tmp, R_TmpvalSymbol, CDDR(expr), rhsprom));
2889 rhs = eval(rhs, rho);
2890 SET_PRVALUE(rhsprom, rhs);
2891 SET_PRCODE(rhsprom, rhs); /* not good but is what we have been doing */
2892 UNPROTECT(nprot);
2893 lhs = CDR(lhs);
2894 expr = CADR(expr);
2895 }
2896 nprot = 6; /* the commont case */
2897 if (TYPEOF(CAR(expr)) == SYMSXP)
2898 afun = getAssignFcnSymbol(CAR(expr));
2899 else {
2900 /* check for and handle assignments of the form
2901 foo::bar(x) <- y or foo:::bar(x) <- y */
2902 afun = R_NilValue; /* avoid uninitialized variable warnings */
2903 if (TYPEOF(CAR(expr)) == LANGSXP &&
2904 (CAR(CAR(expr)) == R_DoubleColonSymbol ||
2905 CAR(CAR(expr)) == R_TripleColonSymbol) &&
2906 length(CAR(expr)) == 3 && TYPEOF(CADDR(CAR(expr))) == SYMSXP) {
2907 afun = getAssignFcnSymbol(CADDR(CAR(expr)));
2908 PROTECT(afun = lang3(CAAR(expr), CADR(CAR(expr)), afun));
2909 nprot++;
2910 }
2911 else
2912 error(_("invalid function in complex assignment"));
2913 }
2914 SET_TEMPVARLOC_FROM_CAR(tmploc, lhs);
2915 SEXP lhsSym = CDR(lhs);
2916
2917 PROTECT(expr = replaceCall(afun, R_TmpvalSymbol, CDDR(expr), rhsprom));
2918 SEXP value = eval(expr, rho);
2919
2920 SET_ASSIGNMENT_PENDING(lhsloc.cell, FALSE);
2921 if (PRIMVAL(op) == 2) /* <<- */
2922 setVar(lhsSym, value, ENCLOS(rho));
2923 else { /* <-, = */
2924 if (ALTREP(value)) {
2925 PROTECT(value);
2926 value = try_assign_unwrap(value, lhsSym, rho, NULL);
2927 UNPROTECT(1);
2928 }
2929 defineVar(lhsSym, value, rho);
2930 }
2931 INCREMENT_NAMED(value);
2932 R_Visible = FALSE;
2933
2934 endcontext(&cntxt); /* which does not run the remove */
2935 UNPROTECT(nprot);
2936 unbindVar(R_TmpvalSymbol, rho);
2937 #ifdef OLD_RHS_NAMED
2938 /* we do not duplicate the value, so to be conservative mark the
2939 value as NAMED = NAMEDMAX */
2940 ENSURE_NAMEDMAX(saverhs);
2941 #else
2942 INCREMENT_NAMED(saverhs);
2943 #endif
2944 #ifdef SWITCH_TO_REFCNT
2945 if (refrhs) DECREMENT_REFCNT(saverhs);
2946 #endif
2947
2948 DECREMENT_BCSTACK_LINKS();
2949
2950 return saverhs;
2951 }
2952
2953 /* Assignment in its various forms */
2954
do_set(SEXP call,SEXP op,SEXP args,SEXP rho)2955 SEXP attribute_hidden do_set(SEXP call, SEXP op, SEXP args, SEXP rho)
2956 {
2957 SEXP lhs, rhs;
2958
2959 if (args == R_NilValue ||
2960 CDR(args) == R_NilValue ||
2961 CDDR(args) != R_NilValue)
2962 WrongArgCount(asym[PRIMVAL(op)]);
2963
2964 lhs = CAR(args);
2965
2966 switch (TYPEOF(lhs)) {
2967 case STRSXP:
2968 lhs = installTrChar(STRING_ELT(lhs, 0));
2969 /* fall through */
2970 case SYMSXP:
2971 rhs = eval(CADR(args), rho);
2972 INCREMENT_NAMED(rhs);
2973 if (PRIMVAL(op) == 2) /* <<- */
2974 setVar(lhs, rhs, ENCLOS(rho));
2975 else /* <-, = */
2976 defineVar(lhs, rhs, rho);
2977 R_Visible = FALSE;
2978 return rhs;
2979 case LANGSXP:
2980 R_Visible = FALSE;
2981 return applydefine(call, op, args, rho);
2982 default:
2983 errorcall(call, _("invalid (do_set) left-hand side to assignment"));
2984 }
2985
2986 return R_NilValue;/*NOTREACHED*/
2987 }
2988
2989
2990 /* Evaluate each expression in "el" in the environment "rho". This is
2991 a naturally recursive algorithm, but we use the iterative form below
2992 because it is does not cause growth of the pointer protection stack,
2993 and because it is a little more efficient.
2994 */
2995
2996 #define COPY_TAG(to, from) do { \
2997 SEXP __tag__ = TAG(from); \
2998 if (__tag__ != R_NilValue) SET_TAG(to, __tag__); \
2999 } while (0)
3000
3001 /* Used in eval and applyMethod (object.c) for builtin primitives,
3002 do_internal (names.c) for builtin .Internals
3003 and in evalArgs.
3004
3005 'n' is the number of arguments already evaluated and hence not
3006 passed to evalArgs and hence to here.
3007 */
evalList(SEXP el,SEXP rho,SEXP call,int n)3008 SEXP attribute_hidden evalList(SEXP el, SEXP rho, SEXP call, int n)
3009 {
3010 SEXP head, tail, ev, h, val;
3011
3012 head = R_NilValue;
3013 tail = R_NilValue; /* to prevent uninitialized variable warnings */
3014
3015 while (el != R_NilValue) {
3016 n++;
3017
3018 if (CAR(el) == R_DotsSymbol) {
3019 /* If we have a ... symbol, we look to see what it is bound to.
3020 * If its binding is Null (i.e. zero length)
3021 * we just ignore it and return the cdr with all its expressions evaluated;
3022 * if it is bound to a ... list of promises,
3023 * we force all the promises and then splice
3024 * the list of resulting values into the return value.
3025 * Anything else bound to a ... symbol is an error
3026 */
3027 PROTECT(h = findVar(CAR(el), rho));
3028 if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
3029 while (h != R_NilValue) {
3030 val = eval(CAR(h), rho);
3031 INCREMENT_LINKS(val);
3032 ev = CONS_NR(val, R_NilValue);
3033 if (head == R_NilValue) {
3034 UNPROTECT(1); /* h */
3035 PROTECT(head = ev);
3036 PROTECT(h); /* put current h on top of protect stack */
3037 }
3038 else
3039 SETCDR(tail, ev);
3040 COPY_TAG(ev, h);
3041 tail = ev;
3042 h = CDR(h);
3043 }
3044 }
3045 else if (h != R_MissingArg)
3046 error(_("'...' used in an incorrect context"));
3047 UNPROTECT(1); /* h */
3048 } else if (CAR(el) == R_MissingArg) {
3049 /* It was an empty element: most likely get here from evalArgs
3050 which may have been called on part of the args. */
3051 errorcall(call, _("argument %d is empty"), n);
3052 #ifdef CHECK_IS_MISSING_IN_evalList
3053 /* Radford Newl drops this R_isMissing check in pqR in
3054 03-zap-isMissing (but it seems to creep in again later
3055 with helper thread stuff?) as it takes quite a bit of
3056 time (essentially the equivalent of evaluating the
3057 symbol, but maybe not as efficiently as eval) and only
3058 serves to change the error message, not always for the
3059 better. Also, the byte code interpreter does not do
3060 this, so dropping this makes compiled and interreted
3061 cod emore consistent. */
3062 } else if (isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)) {
3063 /* It was missing */
3064 errorcall_cpy(call,
3065 _("'%s' is missing"),
3066 EncodeChar(PRINTNAME(CAR(el))));
3067 #endif
3068 } else {
3069 val = eval(CAR(el), rho);
3070 INCREMENT_LINKS(val);
3071 ev = CONS_NR(val, R_NilValue);
3072 if (head == R_NilValue)
3073 PROTECT(head = ev);
3074 else
3075 SETCDR(tail, ev);
3076 COPY_TAG(ev, el);
3077 tail = ev;
3078 }
3079 el = CDR(el);
3080 }
3081
3082 for(el = head; el != R_NilValue; el = CDR(el))
3083 DECREMENT_LINKS(CAR(el));
3084
3085 if (head != R_NilValue)
3086 UNPROTECT(1);
3087
3088 return head;
3089
3090 } /* evalList() */
3091
3092
3093 /* A slight variation of evaluating each expression in "el" in "rho". */
3094
3095 /* used in evalArgs, arithmetic.c, seq.c */
evalListKeepMissing(SEXP el,SEXP rho)3096 SEXP attribute_hidden evalListKeepMissing(SEXP el, SEXP rho)
3097 {
3098 SEXP head, tail, ev, h, val;
3099
3100 head = R_NilValue;
3101 tail = R_NilValue; /* to prevent uninitialized variable warnings */
3102
3103 while (el != R_NilValue) {
3104
3105 /* If we have a ... symbol, we look to see what it is bound to.
3106 * If its binding is Null (i.e. zero length)
3107 * we just ignore it and return the cdr with all its expressions evaluated;
3108 * if it is bound to a ... list of promises,
3109 * we force all the promises and then splice
3110 * the list of resulting values into the return value.
3111 * Anything else bound to a ... symbol is an error
3112 */
3113 if (CAR(el) == R_DotsSymbol) {
3114 PROTECT(h = findVar(CAR(el), rho));
3115 if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
3116 while (h != R_NilValue) {
3117 if (CAR(h) == R_MissingArg)
3118 val = R_MissingArg;
3119 else
3120 val = eval(CAR(h), rho);
3121 INCREMENT_LINKS(val);
3122 ev = CONS_NR(val, R_NilValue);
3123 if (head == R_NilValue) {
3124 UNPROTECT(1); /* h */
3125 PROTECT(head = ev);
3126 PROTECT(h);
3127 } else
3128 SETCDR(tail, ev);
3129 COPY_TAG(ev, h);
3130 tail = ev;
3131 h = CDR(h);
3132 }
3133 }
3134 else if(h != R_MissingArg)
3135 error(_("'...' used in an incorrect context"));
3136 UNPROTECT(1); /* h */
3137 }
3138 else {
3139 if (CAR(el) == R_MissingArg ||
3140 (isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)))
3141 val = R_MissingArg;
3142 else
3143 val = eval(CAR(el), rho);
3144 INCREMENT_LINKS(val);
3145 ev = CONS_NR(val, R_NilValue);
3146 if (head==R_NilValue)
3147 PROTECT(head = ev);
3148 else
3149 SETCDR(tail, ev);
3150 COPY_TAG(ev, el);
3151 tail = ev;
3152 }
3153 el = CDR(el);
3154 }
3155
3156 for(el = head; el != R_NilValue; el = CDR(el))
3157 DECREMENT_LINKS(CAR(el));
3158
3159 if (head!=R_NilValue)
3160 UNPROTECT(1);
3161
3162 return head;
3163 }
3164
3165
3166 /* Create a promise to evaluate each argument. Although this is most */
3167 /* naturally attacked with a recursive algorithm, we use the iterative */
3168 /* form below because it is does not cause growth of the pointer */
3169 /* protection stack, and because it is a little more efficient. */
3170
promiseArgs(SEXP el,SEXP rho)3171 SEXP attribute_hidden promiseArgs(SEXP el, SEXP rho)
3172 {
3173 SEXP ans, h, tail;
3174
3175 PROTECT(ans = tail = CONS(R_NilValue, R_NilValue));
3176
3177 while(el != R_NilValue) {
3178
3179 /* If we have a ... symbol, we look to see what it is bound to.
3180 * If its binding is Null (i.e. zero length)
3181 * we just ignore it and return the cdr with all its
3182 * expressions promised; if it is bound to a ... list
3183 * of promises, we repromise all the promises and then splice
3184 * the list of resulting values into the return value.
3185 * Anything else bound to a ... symbol is an error
3186 */
3187
3188 /* double promises are needed to make sure a function argument
3189 passed via ... is marked as referenced in the caller and
3190 the callee */
3191
3192 if (CAR(el) == R_DotsSymbol) {
3193 PROTECT(h = findVar(CAR(el), rho));
3194 if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
3195 while (h != R_NilValue) {
3196 if (CAR(h) == R_MissingArg)
3197 SETCDR(tail, CONS(CAR(h), R_NilValue));
3198 else
3199 SETCDR(tail, CONS(mkPROMISE(CAR(h), rho), R_NilValue));
3200 tail = CDR(tail);
3201 COPY_TAG(tail, h);
3202 h = CDR(h);
3203 }
3204 }
3205 else if (h != R_MissingArg)
3206 error(_("'...' used in an incorrect context"));
3207 UNPROTECT(1); /* h */
3208 }
3209 else if (CAR(el) == R_MissingArg) {
3210 SETCDR(tail, CONS(R_MissingArg, R_NilValue));
3211 tail = CDR(tail);
3212 COPY_TAG(tail, el);
3213 }
3214 else {
3215 SETCDR(tail, CONS(mkPROMISE(CAR(el), rho), R_NilValue));
3216 tail = CDR(tail);
3217 COPY_TAG(tail, el);
3218 }
3219 el = CDR(el);
3220 }
3221 UNPROTECT(1);
3222 ans = CDR(ans);
3223 DECREMENT_REFCNT(ans);
3224 return ans;
3225 }
3226
3227
3228 /* Check that each formal is a symbol */
3229
3230 /* used in coerce.c */
CheckFormals(SEXP ls)3231 void attribute_hidden CheckFormals(SEXP ls)
3232 {
3233 if (isList(ls)) {
3234 for (; ls != R_NilValue; ls = CDR(ls))
3235 if (TYPEOF(TAG(ls)) != SYMSXP)
3236 goto err;
3237 return;
3238 }
3239 err:
3240 error(_("invalid formal argument list for \"function\""));
3241 }
3242
3243
VectorToPairListNamed(SEXP x)3244 static SEXP VectorToPairListNamed(SEXP x)
3245 {
3246 SEXP xptr, xnew, xnames;
3247 int i, len = 0, named;
3248 const void *vmax = vmaxget();
3249
3250 PROTECT(x);
3251 PROTECT(xnames = getAttrib(x, R_NamesSymbol)); /* isn't this protected via x? */
3252 named = (xnames != R_NilValue);
3253 if(named)
3254 for (i = 0; i < length(x); i++)
3255 if (CHAR(STRING_ELT(xnames, i))[0] != '\0') len++;
3256
3257 if(len) {
3258 PROTECT(xnew = allocList(len));
3259 xptr = xnew;
3260 for (i = 0; i < length(x); i++) {
3261 if (CHAR(STRING_ELT(xnames, i))[0] != '\0') {
3262 SETCAR(xptr, VECTOR_ELT(x, i));
3263 SET_TAG(xptr, installTrChar(STRING_ELT(xnames, i)));
3264 xptr = CDR(xptr);
3265 }
3266 }
3267 UNPROTECT(1);
3268 } else xnew = allocList(0);
3269 UNPROTECT(2);
3270 vmaxset(vmax);
3271 return xnew;
3272 }
3273
3274 #define simple_as_environment(arg) (IS_S4_OBJECT(arg) && (TYPEOF(arg) == S4SXP) ? R_getS4DataSlot(arg, ENVSXP) : R_NilValue)
3275
3276 /* "eval": Evaluate the first argument
3277 in the environment specified by the second argument. */
3278
do_eval(SEXP call,SEXP op,SEXP args,SEXP rho)3279 SEXP attribute_hidden do_eval(SEXP call, SEXP op, SEXP args, SEXP rho)
3280 {
3281 SEXP encl, x;
3282 volatile SEXP expr, env, tmp;
3283
3284 int frame;
3285 RCNTXT cntxt;
3286
3287 checkArity(op, args);
3288 expr = CAR(args);
3289 env = CADR(args);
3290 encl = CADDR(args);
3291 SEXPTYPE tEncl = TYPEOF(encl);
3292 if (isNull(encl)) {
3293 /* This is supposed to be defunct, but has been kept here
3294 (and documented as such) */
3295 encl = R_BaseEnv;
3296 } else if ( !isEnvironment(encl) &&
3297 !isEnvironment((encl = simple_as_environment(encl))) ) {
3298 error(_("invalid '%s' argument of type '%s'"),
3299 "enclos", type2char(tEncl));
3300 }
3301 if(IS_S4_OBJECT(env) && (TYPEOF(env) == S4SXP))
3302 env = R_getS4DataSlot(env, ANYSXP); /* usually an ENVSXP */
3303 switch(TYPEOF(env)) {
3304 case NILSXP:
3305 env = encl; /* so eval(expr, NULL, encl) works */
3306 /* falls through */
3307 case ENVSXP:
3308 PROTECT(env); /* so we can unprotect 2 at the end */
3309 break;
3310 case LISTSXP:
3311 /* This usage requires all the pairlist to be named */
3312 env = NewEnvironment(R_NilValue, duplicate(CADR(args)), encl);
3313 PROTECT(env);
3314 break;
3315 case VECSXP:
3316 /* PR#14035 */
3317 x = VectorToPairListNamed(CADR(args));
3318 for (SEXP xptr = x ; xptr != R_NilValue ; xptr = CDR(xptr))
3319 ENSURE_NAMEDMAX(CAR(xptr));
3320 env = NewEnvironment(R_NilValue, x, encl);
3321 PROTECT(env);
3322 break;
3323 case INTSXP:
3324 case REALSXP:
3325 if (length(env) != 1)
3326 error(_("numeric 'envir' arg not of length one"));
3327 frame = asInteger(env);
3328 if (frame == NA_INTEGER)
3329 error(_("invalid '%s' argument of type '%s'"),
3330 "envir", type2char(TYPEOF(env)));
3331 PROTECT(env = R_sysframe(frame, R_GlobalContext));
3332 break;
3333 default:
3334 error(_("invalid '%s' argument of type '%s'"),
3335 "envir", type2char(TYPEOF(env)));
3336 }
3337
3338 /* isLanguage include NILSXP, and that does not need to be
3339 evaluated
3340 if (isLanguage(expr) || isSymbol(expr) || isByteCode(expr)) { */
3341 if (TYPEOF(expr) == LANGSXP || TYPEOF(expr) == SYMSXP || isByteCode(expr)) {
3342 PROTECT(expr);
3343 begincontext(&cntxt, CTXT_RETURN, R_GlobalContext->call,
3344 env, rho, args, op);
3345 if (!SETJMP(cntxt.cjmpbuf))
3346 expr = eval(expr, env);
3347 else {
3348 expr = R_ReturnedValue;
3349 if (expr == R_RestartToken) {
3350 cntxt.callflag = CTXT_RETURN; /* turn restart off */
3351 error(_("restarts not supported in 'eval'"));
3352 }
3353 }
3354 UNPROTECT(1);
3355 PROTECT(expr);
3356 endcontext(&cntxt);
3357 UNPROTECT(1);
3358 }
3359 else if (TYPEOF(expr) == EXPRSXP) {
3360 SEXP srcrefs = getBlockSrcrefs(expr);
3361 PROTECT(expr);
3362 tmp = R_NilValue;
3363 begincontext(&cntxt, CTXT_RETURN, R_GlobalContext->call,
3364 env, rho, args, op);
3365 if (!SETJMP(cntxt.cjmpbuf)) {
3366 int n = LENGTH(expr);
3367 for(int i = 0 ; i < n ; i++) {
3368 R_Srcref = getSrcref(srcrefs, i);
3369 tmp = eval(VECTOR_ELT(expr, i), env);
3370 }
3371 } else {
3372 tmp = R_ReturnedValue;
3373 if (tmp == R_RestartToken) {
3374 cntxt.callflag = CTXT_RETURN; /* turn restart off */
3375 error(_("restarts not supported in 'eval'"));
3376 }
3377 }
3378 UNPROTECT(1);
3379 PROTECT(tmp);
3380 endcontext(&cntxt);
3381 UNPROTECT(1);
3382 expr = tmp;
3383 }
3384 else if( TYPEOF(expr) == PROMSXP ) {
3385 expr = eval(expr, rho);
3386 } /* else expr is returned unchanged */
3387 UNPROTECT(1);
3388 return expr;
3389 }
3390
3391 /* This is a special .Internal */
do_withVisible(SEXP call,SEXP op,SEXP args,SEXP rho)3392 SEXP attribute_hidden do_withVisible(SEXP call, SEXP op, SEXP args, SEXP rho)
3393 {
3394 SEXP x, nm, ret;
3395
3396 checkArity(op, args);
3397 x = CAR(args);
3398 x = eval(x, rho);
3399 PROTECT(x);
3400 PROTECT(ret = allocVector(VECSXP, 2));
3401 PROTECT(nm = allocVector(STRSXP, 2));
3402 SET_STRING_ELT(nm, 0, mkChar("value"));
3403 SET_STRING_ELT(nm, 1, mkChar("visible"));
3404 SET_VECTOR_ELT(ret, 0, x);
3405 SET_VECTOR_ELT(ret, 1, ScalarLogical(R_Visible));
3406 setAttrib(ret, R_NamesSymbol, nm);
3407 UNPROTECT(3);
3408 return ret;
3409 }
3410
3411 /* This is a special .Internal */
do_recall(SEXP call,SEXP op,SEXP args,SEXP rho)3412 SEXP attribute_hidden do_recall(SEXP call, SEXP op, SEXP args, SEXP rho)
3413 {
3414 RCNTXT *cptr;
3415 SEXP s, ans ;
3416 cptr = R_GlobalContext;
3417 /* get the args supplied */
3418 while (cptr != NULL) {
3419 if (cptr->callflag == CTXT_RETURN && cptr->cloenv == rho)
3420 break;
3421 cptr = cptr->nextcontext;
3422 }
3423 if (cptr != NULL) {
3424 args = cptr->promargs;
3425 }
3426 /* get the env recall was called from */
3427 s = R_GlobalContext->sysparent;
3428 while (cptr != NULL) {
3429 if (cptr->callflag == CTXT_RETURN && cptr->cloenv == s)
3430 break;
3431 cptr = cptr->nextcontext;
3432 }
3433 if (cptr == NULL)
3434 error(_("'Recall' called from outside a closure"));
3435
3436 /* If the function has been recorded in the context, use it
3437 otherwise search for it by name or evaluate the expression
3438 originally used to get it.
3439 */
3440 if (cptr->callfun != R_NilValue)
3441 PROTECT(s = cptr->callfun);
3442 else if( TYPEOF(CAR(cptr->call)) == SYMSXP)
3443 PROTECT(s = findFun(CAR(cptr->call), cptr->sysparent));
3444 else
3445 PROTECT(s = eval(CAR(cptr->call), cptr->sysparent));
3446 if (TYPEOF(s) != CLOSXP)
3447 error(_("'Recall' called from outside a closure"));
3448 ans = applyClosure(cptr->call, s, args, cptr->sysparent, R_NilValue);
3449 UNPROTECT(1);
3450 return ans;
3451 }
3452
3453
evalArgs(SEXP el,SEXP rho,int dropmissing,SEXP call,int n)3454 static SEXP evalArgs(SEXP el, SEXP rho, int dropmissing, SEXP call, int n)
3455 {
3456 if(dropmissing) return evalList(el, rho, call, n);
3457 else return evalListKeepMissing(el, rho);
3458 }
3459
3460
3461 /* A version of DispatchOrEval that checks for possible S4 methods for
3462 * any argument, not just the first. Used in the code for `c()` in do_c()
3463 * and previously used in the code for `[` in do_subset.
3464 * Differs in that all arguments are evaluated
3465 * immediately, rather than after the call to R_possible_dispatch.
3466 */
3467 attribute_hidden
DispatchAnyOrEval(SEXP call,SEXP op,const char * generic,SEXP args,SEXP rho,SEXP * ans,int dropmissing,int argsevald)3468 int DispatchAnyOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
3469 SEXP rho, SEXP *ans, int dropmissing, int argsevald)
3470 {
3471 if(R_has_methods(op)) {
3472 SEXP argValue, el, value;
3473 /* Rboolean hasS4 = FALSE; */
3474 int nprotect = 0, dispatch;
3475 if(!argsevald) {
3476 PROTECT(argValue = evalArgs(args, rho, dropmissing, call, 0));
3477 nprotect++;
3478 argsevald = TRUE;
3479 }
3480 else argValue = args;
3481 for(el = argValue; el != R_NilValue; el = CDR(el)) {
3482 if(IS_S4_OBJECT(CAR(el))) {
3483 value = R_possible_dispatch(call, op, argValue, rho, TRUE);
3484 if(value) {
3485 *ans = value;
3486 UNPROTECT(nprotect);
3487 return 1;
3488 }
3489 else break;
3490 }
3491 }
3492 /* else, use the regular DispatchOrEval, but now with evaluated args */
3493 dispatch = DispatchOrEval(call, op, generic, argValue, rho, ans, dropmissing, argsevald);
3494 UNPROTECT(nprotect);
3495 return dispatch;
3496 }
3497 return DispatchOrEval(call, op, generic, args, rho, ans, dropmissing, argsevald);
3498 }
3499
3500
3501 /* DispatchOrEval is used in internal functions which dispatch to
3502 * object methods (e.g. "[" or "[["). The code either builds promises
3503 * and dispatches to the appropriate method, or it evaluates the
3504 * (unevaluated) arguments it comes in with and returns them so that
3505 * the generic built-in C code can continue.
3506
3507 * To call this an ugly hack would be to insult all existing ugly hacks
3508 * at large in the world.
3509 */
3510 attribute_hidden
DispatchOrEval(SEXP call,SEXP op,const char * generic,SEXP args,SEXP rho,SEXP * ans,int dropmissing,int argsevald)3511 int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
3512 SEXP rho, SEXP *ans, int dropmissing, int argsevald)
3513 {
3514 /* DispatchOrEval is called very frequently, most often in cases where
3515 no dispatching is needed and the isObject or the string-based
3516 pre-test fail. To avoid degrading performance it is therefore
3517 necessary to avoid creating promises in these cases. The pre-test
3518 does require that we look at the first argument, so that needs to
3519 be evaluated. The complicating factor is that the first argument
3520 might come in with a "..." and that there might be other arguments
3521 in the "..." as well. LT */
3522
3523 SEXP x = R_NilValue;
3524 int dots = FALSE, nprotect = 0;;
3525
3526 if( argsevald )
3527 {PROTECT(x = CAR(args)); nprotect++;}
3528 else {
3529 /* Find the object to dispatch on, dropping any leading
3530 ... arguments with missing or empty values. If there are no
3531 arguments, R_NilValue is used. */
3532 for (; args != R_NilValue; args = CDR(args)) {
3533 if (CAR(args) == R_DotsSymbol) {
3534 SEXP h = findVar(R_DotsSymbol, rho);
3535 if (TYPEOF(h) == DOTSXP) {
3536 #ifdef DODO
3537 /**** any self-evaluating value should be OK; this
3538 is used in byte compiled code. LT */
3539 /* just a consistency check */
3540 if (TYPEOF(CAR(h)) != PROMSXP)
3541 error(_("value in '...' is not a promise"));
3542 #endif
3543 dots = TRUE;
3544 x = eval(CAR(h), rho);
3545 break;
3546 }
3547 else if (h != R_NilValue && h != R_MissingArg)
3548 error(_("'...' used in an incorrect context"));
3549 }
3550 else {
3551 dots = FALSE;
3552 x = eval(CAR(args), rho);
3553 break;
3554 }
3555 }
3556 PROTECT(x); nprotect++;
3557 }
3558 /* try to dispatch on the object */
3559 if( isObject(x) ) {
3560 char *pt;
3561 /* Try for formal method. */
3562 if(IS_S4_OBJECT(x) && R_has_methods(op)) {
3563 SEXP value, argValue;
3564 /* create a promise to pass down to applyClosure */
3565 if(!argsevald) {
3566 argValue = promiseArgs(args, rho);
3567 SET_PRVALUE(CAR(argValue), x);
3568 } else argValue = args;
3569 PROTECT(argValue); nprotect++;
3570 /* This means S4 dispatch */
3571 value = R_possible_dispatch(call, op, argValue, rho, TRUE);
3572 if(value) {
3573 *ans = value;
3574 UNPROTECT(nprotect);
3575 return 1;
3576 }
3577 else {
3578 /* go on, with the evaluated args. Not guaranteed to have
3579 the same semantics as if the arguments were not
3580 evaluated, in special cases (e.g., arg values that are
3581 LANGSXP).
3582 The use of the promiseArgs is supposed to prevent
3583 multiple evaluation after the call to possible_dispatch.
3584 */
3585 if (dots)
3586 PROTECT(argValue = evalArgs(argValue, rho, dropmissing,
3587 call, 0));
3588 else {
3589 PROTECT(argValue = CONS_NR(x, evalArgs(CDR(argValue), rho,
3590 dropmissing, call, 1)));
3591 SET_TAG(argValue, CreateTag(TAG(args)));
3592 }
3593 nprotect++;
3594 args = argValue;
3595 argsevald = 1;
3596 }
3597 }
3598 if (TYPEOF(CAR(call)) == SYMSXP)
3599 pt = Rf_strrchr(CHAR(PRINTNAME(CAR(call))), '.');
3600 else
3601 pt = NULL;
3602
3603 if (pt == NULL || strcmp(pt,".default")) {
3604 RCNTXT cntxt;
3605 SEXP pargs, rho1;
3606 PROTECT(pargs = promiseArgs(args, rho)); nprotect++;
3607 /* The context set up here is needed because of the way
3608 usemethod() is written. DispatchGroup() repeats some
3609 internal usemethod() code and avoids the need for a
3610 context; perhaps the usemethod() code should be
3611 refactored so the contexts around the usemethod() calls
3612 in this file can be removed.
3613
3614 Using rho for current and calling environment can be
3615 confusing for things like sys.parent() calls captured
3616 in promises (Gabor G had an example of this). Also,
3617 since the context is established without a SETJMP using
3618 an R-accessible environment allows a segfault to be
3619 triggered (by something very obscure, but still).
3620 Hence here and in the other usemethod() uses below a
3621 new environment rho1 is created and used. LT */
3622 PROTECT(rho1 = NewEnvironment(R_NilValue, R_NilValue, rho)); nprotect++;
3623 SET_PRVALUE(CAR(pargs), x);
3624 begincontext(&cntxt, CTXT_RETURN, call, rho1, rho, pargs, op);
3625 if(usemethod(generic, x, call, pargs, rho1, rho, R_BaseEnv, ans))
3626 {
3627 endcontext(&cntxt);
3628 UNPROTECT(nprotect);
3629 #ifdef ADJUST_ENVIR_REFCNTS
3630 R_CleanupEnvir(rho1, *ans);
3631 unpromiseArgs(pargs);
3632 #endif
3633 return 1;
3634 }
3635 endcontext(&cntxt);
3636 #ifdef ADJUST_ENVIR_REFCNTS
3637 R_CleanupEnvir(rho1, R_NilValue);
3638 unpromiseArgs(pargs);
3639 #endif
3640 }
3641 }
3642 if(!argsevald) {
3643 if (dots)
3644 /* The first call argument was ... and may contain more than the
3645 object, so it needs to be evaluated here. The object should be
3646 in a promise, so evaluating it again should be no problem. */
3647 *ans = evalArgs(args, rho, dropmissing, call, 0);
3648 else {
3649 INCREMENT_LINKS(x);
3650 PROTECT(*ans = CONS_NR(x, evalArgs(CDR(args), rho, dropmissing, call, 1)));
3651 DECREMENT_LINKS(x);
3652 SET_TAG(*ans, CreateTag(TAG(args)));
3653 UNPROTECT(1);
3654 }
3655 }
3656 else *ans = args;
3657 UNPROTECT(nprotect);
3658 return 0;
3659 }
3660
updateObjFromS4Slot(SEXP objSlot,const char * className)3661 static R_INLINE void updateObjFromS4Slot(SEXP objSlot, const char *className) {
3662 SEXP obj = CAR(objSlot);
3663
3664 if(IS_S4_OBJECT(obj) && isBasicClass(className)) {
3665 /* This and the similar test below implement the strategy
3666 for S3 methods selected for S4 objects. See ?Methods */
3667 if(NAMED(obj)) ENSURE_NAMEDMAX(obj);
3668 obj = R_getS4DataSlot(obj, S4SXP); /* the .S3Class obj. or NULL*/
3669 if(obj != R_NilValue) /* use the S3Part as the inherited object */
3670 SETCAR(objSlot, obj);
3671 }
3672 }
3673
3674 /* gr needs to be protected on return from this function */
findmethod(SEXP Class,const char * group,const char * generic,SEXP * sxp,SEXP * gr,SEXP * meth,int * which,SEXP objSlot,SEXP rho)3675 static void findmethod(SEXP Class, const char *group, const char *generic,
3676 SEXP *sxp, SEXP *gr, SEXP *meth, int *which,
3677 SEXP objSlot, SEXP rho)
3678 {
3679 int len, whichclass;
3680 const void *vmax = vmaxget();
3681
3682 len = length(Class);
3683
3684 /* Need to interleave looking for group and generic methods
3685 e.g. if class(x) is c("foo", "bar)" then x > 3 should invoke
3686 "Ops.foo" rather than ">.bar"
3687 */
3688 for (whichclass = 0 ; whichclass < len ; whichclass++) {
3689 const char *ss = translateChar(STRING_ELT(Class, whichclass));
3690 *meth = installS3Signature(generic, ss);
3691 *sxp = R_LookupMethod(*meth, rho, rho, R_BaseEnv);
3692 if (isFunction(*sxp)) {
3693 *gr = R_BlankScalarString;
3694 if (whichclass > 0) updateObjFromS4Slot(objSlot, ss);
3695 break;
3696 }
3697 *meth = installS3Signature(group, ss);
3698 *sxp = R_LookupMethod(*meth, rho, rho, R_BaseEnv);
3699 if (isFunction(*sxp)) {
3700 *gr = mkString(group);
3701 if (whichclass > 0) updateObjFromS4Slot(objSlot, ss);
3702 break;
3703 }
3704 }
3705 vmaxset(vmax);
3706 *which = whichclass;
3707 }
3708
classForGroupDispatch(SEXP obj)3709 static SEXP classForGroupDispatch(SEXP obj) {
3710
3711 return IS_S4_OBJECT(obj) ? R_data_class2(obj)
3712 : getAttrib(obj, R_ClassSymbol);
3713 }
3714
3715 attribute_hidden
DispatchGroup(const char * group,SEXP call,SEXP op,SEXP args,SEXP rho,SEXP * ans)3716 int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
3717 SEXP *ans)
3718 {
3719 /* pre-test to avoid string computations when there is nothing to
3720 dispatch on because either there is only one argument and it
3721 isn't an object or there are two or more arguments but neither
3722 of the first two is an object -- both of these cases would be
3723 rejected by the code following the string examination code
3724 below */
3725 if (args != R_NilValue && ! isObject(CAR(args)) &&
3726 (CDR(args) == R_NilValue || ! isObject(CADR(args))))
3727 return 0;
3728
3729 SEXP s;
3730 Rboolean isOps = strcmp(group, "Ops") == 0;
3731
3732 /* try for formal method */
3733 if(length(args) == 1 && !IS_S4_OBJECT(CAR(args))) {
3734 // no S4
3735 } else if(length(args) == 2 && !IS_S4_OBJECT(CAR(args)) && !IS_S4_OBJECT(CADR(args))) {
3736 // no S4
3737 } else { // try to use S4 :
3738 /* Remove argument names to ensure positional matching */
3739 if(isOps)
3740 for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
3741 SEXP value;
3742 if(R_has_methods(op) &&
3743 (value = R_possible_dispatch(call, op, args, rho, FALSE))) {
3744 *ans = value;
3745 return 1;
3746 }
3747 /* else go on to look for S3 methods */
3748 }
3749
3750 /* check whether we are processing the default method */
3751 if ( isSymbol(CAR(call)) ) {
3752 const char *cstr = strchr(CHAR(PRINTNAME(CAR(call))), '.');
3753 if (cstr && !strcmp(cstr + 1, "default"))
3754 return 0;
3755 }
3756
3757 int nargs = isOps ? length(args) : 1;
3758
3759 if( nargs == 1 && !isObject(CAR(args)) )
3760 return 0;
3761
3762 char *generic = PRIMNAME(op);
3763 SEXP lclass = PROTECT(classForGroupDispatch(CAR(args))), rclass;
3764 if( nargs == 2 )
3765 rclass = classForGroupDispatch(CADR(args));
3766 else
3767 rclass = R_NilValue;
3768 PROTECT(rclass);
3769
3770 SEXP lmeth = R_NilValue, lsxp = R_NilValue, lgr = R_NilValue,
3771 rmeth = R_NilValue, rsxp = R_NilValue, rgr = R_NilValue;
3772 int lwhich, rwhich;
3773 findmethod(lclass, group, generic,
3774 &lsxp, &lgr, &lmeth, &lwhich, args, rho);
3775 PROTECT(lgr);
3776
3777 if( nargs == 2 )
3778 findmethod(rclass, group, generic, &rsxp, &rgr, &rmeth,
3779 &rwhich, CDR(args), rho);
3780 else
3781 rwhich = 0;
3782 PROTECT(rgr);
3783
3784 if( !isFunction(lsxp) && !isFunction(rsxp) ) {
3785 UNPROTECT(4);
3786 return 0; /* no generic or group method so use default */
3787 }
3788
3789 if( lsxp != rsxp ) {
3790 if ( isFunction(lsxp) && isFunction(rsxp) ) {
3791 /* special-case some methods involving difftime */
3792 const char *lname = CHAR(PRINTNAME(lmeth)),
3793 *rname = CHAR(PRINTNAME(rmeth));
3794 if( streql(rname, "Ops.difftime") &&
3795 (streql(lname, "+.POSIXt") || streql(lname, "-.POSIXt") ||
3796 streql(lname, "+.Date") || streql(lname, "-.Date")) )
3797 rsxp = R_NilValue;
3798 else if (streql(lname, "Ops.difftime") &&
3799 (streql(rname, "+.POSIXt") || streql(rname, "+.Date")) )
3800 lsxp = R_NilValue;
3801
3802 /* Strict comparison, the docs requires methods to be "the same":
3803 16 to take environments into account
3804 1+2 for bitwise comparison of numbers
3805 4 for the same order of attributes
3806 bytecode ignored (can change at runtime)
3807 srcref ignored (as per default)
3808 */
3809 else if (!R_compute_identical(lsxp, rsxp, 16 + 1 + 2 + 4)) {
3810 warning(_("Incompatible methods (\"%s\", \"%s\") for \"%s\""),
3811 lname, rname, generic);
3812 UNPROTECT(4);
3813 return 0;
3814 }
3815 }
3816 /* if the right hand side is the one */
3817 if( !isFunction(lsxp) ) { /* copy over the righthand stuff */
3818 lsxp = rsxp;
3819 lmeth = rmeth;
3820 lgr = rgr;
3821 lclass = rclass;
3822 lwhich = rwhich;
3823 }
3824 }
3825
3826 /* we either have a group method or a class method */
3827
3828 const void *vmax = vmaxget();
3829 s = args;
3830 const char *dispatchClassName = translateChar(STRING_ELT(lclass, lwhich));
3831
3832 SEXP t, m = PROTECT(allocVector(STRSXP,nargs));
3833 for (int i = 0 ; i < nargs ; i++) {
3834 t = classForGroupDispatch(CAR(s));
3835 if (isString(t) && (stringPositionTr(t, dispatchClassName) >= 0))
3836 SET_STRING_ELT(m, i, PRINTNAME(lmeth));
3837 else
3838 SET_STRING_ELT(m, i, R_BlankString);
3839 s = CDR(s);
3840 }
3841 vmaxset(vmax);
3842
3843 SEXP newvars = PROTECT(createS3Vars(
3844 PROTECT(mkString(generic)),
3845 lgr,
3846 PROTECT(stringSuffix(lclass, lwhich)),
3847 m,
3848 rho,
3849 R_BaseEnv
3850 ));
3851
3852 PROTECT(t = LCONS(lmeth, CDR(call)));
3853
3854 /* the arguments have been evaluated; since we are passing them */
3855 /* out to a closure we need to wrap them in promises so that */
3856 /* they get duplicated and things like missing/substitute work. */
3857
3858 PROTECT(s = promiseArgs(CDR(call), rho));
3859 if (length(s) != length(args))
3860 error(_("dispatch error in group dispatch"));
3861 for (m = s ; m != R_NilValue ; m = CDR(m), args = CDR(args) ) {
3862 SET_PRVALUE(CAR(m), CAR(args));
3863 /* ensure positional matching for operators */
3864 if(isOps) SET_TAG(m, R_NilValue);
3865 }
3866
3867 *ans = applyClosure(t, lsxp, s, rho, newvars);
3868 #ifdef ADJUST_ENVIR_REFCNTS
3869 unpromiseArgs(s);
3870 #endif
3871 UNPROTECT(10);
3872 return 1;
3873 }
3874
3875 /* start of bytecode section */
3876 static int R_bcVersion = 12;
3877 static int R_bcMinVersion = 9;
3878
3879 static SEXP R_AddSym = NULL;
3880 static SEXP R_SubSym = NULL;
3881 static SEXP R_MulSym = NULL;
3882 static SEXP R_DivSym = NULL;
3883 static SEXP R_ExptSym = NULL;
3884 static SEXP R_SqrtSym = NULL;
3885 static SEXP R_ExpSym = NULL;
3886 static SEXP R_EqSym = NULL;
3887 static SEXP R_NeSym = NULL;
3888 static SEXP R_LtSym = NULL;
3889 static SEXP R_LeSym = NULL;
3890 static SEXP R_GeSym = NULL;
3891 static SEXP R_GtSym = NULL;
3892 static SEXP R_AndSym = NULL;
3893 static SEXP R_OrSym = NULL;
3894 static SEXP R_NotSym = NULL;
3895 static SEXP R_CSym = NULL;
3896 static SEXP R_LogSym = NULL;
3897 static SEXP R_DotInternalSym = NULL;
3898 static SEXP R_DotExternalSym = NULL;
3899 static SEXP R_DotExternal2Sym = NULL;
3900 static SEXP R_DotExternalgraphicsSym = NULL;
3901 static SEXP R_DotCallSym = NULL;
3902 static SEXP R_DotCallgraphicsSym = NULL;
3903 static SEXP R_DotFortranSym = NULL;
3904 static SEXP R_DotCSym = NULL;
3905
3906 /* R_ConstantsRegistry allows runtime detection of modification of compiler
3907 constants. It is a linked list of weak references. Each weak reference
3908 refers to a byte-code object (BCODESXPs) as key and to a deep copy of the
3909 object's constants as value. The head of the list has a nil payload
3910 instead of a weak reference, stays in the list forever, and is a GC root.*/
3911 static SEXP R_ConstantsRegistry = NULL;
3912
3913 #if defined(__GNUC__) && ! defined(BC_PROFILING) && (! defined(NO_THREADED_CODE))
3914 # define THREADED_CODE
3915 #endif
3916
3917 attribute_hidden
R_initialize_bcode(void)3918 void R_initialize_bcode(void)
3919 {
3920 R_AddSym = install("+");
3921 R_SubSym = install("-");
3922 R_MulSym = install("*");
3923 R_DivSym = install("/");
3924 R_ExptSym = install("^");
3925 R_SqrtSym = install("sqrt");
3926 R_ExpSym = install("exp");
3927 R_EqSym = install("==");
3928 R_NeSym = install("!=");
3929 R_LtSym = install("<");
3930 R_LeSym = install("<=");
3931 R_GeSym = install(">=");
3932 R_GtSym = install(">");
3933 R_AndSym = install("&");
3934 R_OrSym = install("|");
3935 R_NotSym = install("!");
3936 R_CSym = install("c");
3937 R_LogSym = install("log");
3938 R_DotInternalSym = install(".Internal");
3939 R_DotExternalSym = install(".External");
3940 R_DotExternal2Sym = install(".External2");
3941 R_DotExternalgraphicsSym = install(".External.graphics");
3942 R_DotCallSym = install(".Call");
3943 R_DotCallgraphicsSym = install(".Call.graphics");
3944 R_DotFortranSym = install(".Fortran");
3945 R_DotCSym = install(".C");
3946
3947 #ifdef THREADED_CODE
3948 bcEval(NULL, NULL, FALSE);
3949 #endif
3950
3951 /* the first constants record always stays in place for protection */
3952 R_ConstantsRegistry = allocVector(VECSXP, 2);
3953 R_PreserveObject(R_ConstantsRegistry);
3954 SET_VECTOR_ELT(R_ConstantsRegistry, 0, R_NilValue);
3955 SET_VECTOR_ELT(R_ConstantsRegistry, 1, R_NilValue);
3956
3957 R_BCProtCommitted = R_BCNodeStackBase;
3958 }
3959
3960 enum {
3961 BCMISMATCH_OP,
3962 RETURN_OP,
3963 GOTO_OP,
3964 BRIFNOT_OP,
3965 POP_OP,
3966 DUP_OP,
3967 PRINTVALUE_OP,
3968 STARTLOOPCNTXT_OP,
3969 ENDLOOPCNTXT_OP,
3970 DOLOOPNEXT_OP,
3971 DOLOOPBREAK_OP,
3972 STARTFOR_OP,
3973 STEPFOR_OP,
3974 ENDFOR_OP,
3975 SETLOOPVAL_OP,
3976 INVISIBLE_OP,
3977 LDCONST_OP,
3978 LDNULL_OP,
3979 LDTRUE_OP,
3980 LDFALSE_OP,
3981 GETVAR_OP,
3982 DDVAL_OP,
3983 SETVAR_OP,
3984 GETFUN_OP,
3985 GETGLOBFUN_OP,
3986 GETSYMFUN_OP,
3987 GETBUILTIN_OP,
3988 GETINTLBUILTIN_OP,
3989 CHECKFUN_OP,
3990 MAKEPROM_OP,
3991 DOMISSING_OP,
3992 SETTAG_OP,
3993 DODOTS_OP,
3994 PUSHARG_OP,
3995 PUSHCONSTARG_OP,
3996 PUSHNULLARG_OP,
3997 PUSHTRUEARG_OP,
3998 PUSHFALSEARG_OP,
3999 CALL_OP,
4000 CALLBUILTIN_OP,
4001 CALLSPECIAL_OP,
4002 MAKECLOSURE_OP,
4003 UMINUS_OP,
4004 UPLUS_OP,
4005 ADD_OP,
4006 SUB_OP,
4007 MUL_OP,
4008 DIV_OP,
4009 EXPT_OP,
4010 SQRT_OP,
4011 EXP_OP,
4012 EQ_OP,
4013 NE_OP,
4014 LT_OP,
4015 LE_OP,
4016 GE_OP,
4017 GT_OP,
4018 AND_OP,
4019 OR_OP,
4020 NOT_OP,
4021 DOTSERR_OP,
4022 STARTASSIGN_OP,
4023 ENDASSIGN_OP,
4024 STARTSUBSET_OP,
4025 DFLTSUBSET_OP,
4026 STARTSUBASSIGN_OP,
4027 DFLTSUBASSIGN_OP,
4028 STARTC_OP,
4029 DFLTC_OP,
4030 STARTSUBSET2_OP,
4031 DFLTSUBSET2_OP,
4032 STARTSUBASSIGN2_OP,
4033 DFLTSUBASSIGN2_OP,
4034 DOLLAR_OP,
4035 DOLLARGETS_OP,
4036 ISNULL_OP,
4037 ISLOGICAL_OP,
4038 ISINTEGER_OP,
4039 ISDOUBLE_OP,
4040 ISCOMPLEX_OP,
4041 ISCHARACTER_OP,
4042 ISSYMBOL_OP,
4043 ISOBJECT_OP,
4044 ISNUMERIC_OP,
4045 VECSUBSET_OP,
4046 MATSUBSET_OP,
4047 VECSUBASSIGN_OP,
4048 MATSUBASSIGN_OP,
4049 AND1ST_OP,
4050 AND2ND_OP,
4051 OR1ST_OP,
4052 OR2ND_OP,
4053 GETVAR_MISSOK_OP,
4054 DDVAL_MISSOK_OP,
4055 VISIBLE_OP,
4056 SETVAR2_OP,
4057 STARTASSIGN2_OP,
4058 ENDASSIGN2_OP,
4059 SETTER_CALL_OP,
4060 GETTER_CALL_OP,
4061 SWAP_OP,
4062 DUP2ND_OP,
4063 SWITCH_OP,
4064 RETURNJMP_OP,
4065 STARTSUBSET_N_OP,
4066 STARTSUBASSIGN_N_OP,
4067 VECSUBSET2_OP,
4068 MATSUBSET2_OP,
4069 VECSUBASSIGN2_OP,
4070 MATSUBASSIGN2_OP,
4071 STARTSUBSET2_N_OP,
4072 STARTSUBASSIGN2_N_OP,
4073 SUBSET_N_OP,
4074 SUBSET2_N_OP,
4075 SUBASSIGN_N_OP,
4076 SUBASSIGN2_N_OP,
4077 LOG_OP,
4078 LOGBASE_OP,
4079 MATH1_OP,
4080 DOTCALL_OP,
4081 COLON_OP,
4082 SEQALONG_OP,
4083 SEQLEN_OP,
4084 BASEGUARD_OP,
4085 INCLNK_OP,
4086 DECLNK_OP,
4087 DECLNK_N_OP,
4088 INCLNKSTK_OP,
4089 DECLNKSTK_OP,
4090 OPCOUNT
4091 };
4092
4093
4094 SEXP R_unary(SEXP, SEXP, SEXP);
4095 SEXP R_binary(SEXP, SEXP, SEXP, SEXP);
4096 SEXP do_math1(SEXP, SEXP, SEXP, SEXP);
4097 SEXP do_relop_dflt(SEXP, SEXP, SEXP, SEXP);
4098 SEXP do_logic(SEXP, SEXP, SEXP, SEXP);
4099 SEXP do_subset_dflt(SEXP, SEXP, SEXP, SEXP);
4100 SEXP do_subassign_dflt(SEXP, SEXP, SEXP, SEXP);
4101 SEXP do_c_dflt(SEXP, SEXP, SEXP, SEXP);
4102 SEXP do_subset2_dflt(SEXP, SEXP, SEXP, SEXP);
4103 SEXP do_subassign2_dflt(SEXP, SEXP, SEXP, SEXP);
4104
seq_int(int n1,int n2)4105 static SEXP seq_int(int n1, int n2)
4106 {
4107 #define USE_ALTREP_COMPACT_INTRANGE
4108 #ifdef USE_ALTREP_COMPACT_INTRANGE
4109 return R_compact_intrange(n1, n2);
4110 #else
4111 int n = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;
4112 SEXP ans = allocVector(INTSXP, n);
4113 int *data = INTEGER(ans);
4114 if (n1 <= n2)
4115 for (int i = 0; i < n; i++)
4116 data[i] = n1 + i;
4117 else
4118 for (int i = 0; i < n; i++)
4119 data[i] = n1 - i;
4120 return ans;
4121 #endif
4122 }
4123
4124 #define COMPACT_INTSEQ
4125 #ifdef COMPACT_INTSEQ
4126 # define INTSEQSXP 9999
4127 #endif
4128 /* tag for boxed stack entries to be ignored by stack protection */
4129 #define NLNKSXP 9996
4130
4131 #define GETSTACK_FLAGS(n) (R_BCNodeStackTop[n].flags)
4132 #define SETSTACK_FLAGS(n, v) (R_BCNodeStackTop[n].flags = (v))
4133
GETSTACK_PTR_TAG(R_bcstack_t * s)4134 static R_INLINE SEXP GETSTACK_PTR_TAG(R_bcstack_t *s)
4135 {
4136 /* no error checking since only called with tag != 0 */
4137 SEXP value;
4138 switch (s->tag) {
4139 case REALSXP:
4140 value = ScalarReal(s->u.dval);
4141 break;
4142 case INTSXP:
4143 value = ScalarInteger(s->u.ival);
4144 break;
4145 case LGLSXP:
4146 value = ScalarLogical(s->u.ival);
4147 break;
4148 #ifdef COMPACT_INTSEQ
4149 case INTSEQSXP:
4150 {
4151 int *seqinfo = INTEGER(s->u.sxpval);
4152 value = seq_int(seqinfo[0], seqinfo[1]);
4153 }
4154 break;
4155 #endif
4156 default: /* not reached */
4157 value = NULL;
4158 }
4159 s->tag = 0;
4160 s->u.sxpval = value;
4161 return value;
4162 }
4163 #define GETSTACK_PTR(s) ((s)->tag ? GETSTACK_PTR_TAG(s) : (s)->u.sxpval)
4164
4165 #define GETSTACK_SXPVAL_PTR(s) ((s)->u.sxpval)
4166
4167 #define GETSTACK_IVAL_PTR(s) ((s)->u.ival)
4168
4169 #define SETSTACK_NLNK_PTR(s, v) do { \
4170 R_bcstack_t *__s__ = (s); \
4171 SEXP __v__ = (v); \
4172 __s__->tag = NLNKSXP; \
4173 __s__->u.sxpval = __v__; \
4174 } while (0)
4175 #define SETSTACK_NLNK(i, v) SETSTACK_NLNK_PTR(R_BCNodeStackTop + (i), v)
4176
4177 #ifdef TESTING_WRITE_BARRIER
4178 # define CHECK_SET_BELOW_PROT(s) \
4179 if ((s) < R_BCProtTop) error("changing stack value below R_BCProt pointer")
4180 #else
4181 # define CHECK_SET_BELOW_PROT(s) do { } while (0)
4182 #endif
4183
4184 #define SETSTACK_PTR(s, v) do { \
4185 CHECK_SET_BELOW_PROT(s); \
4186 SEXP __v__ = (v); \
4187 (s)->tag = 0; \
4188 (s)->u.sxpval = __v__; \
4189 } while (0)
4190
4191 #define SETSTACK_REAL_PTR(s, v) do { \
4192 double __v__ = (v); \
4193 (s)->tag = REALSXP; \
4194 (s)->u.dval = __v__; \
4195 } while (0)
4196
4197 #define SETSTACK_INTEGER_PTR(s, v) do { \
4198 int __v__ = (v); \
4199 (s)->tag = INTSXP; \
4200 (s)->u.ival = __v__; \
4201 } while (0)
4202
4203 #define SETSTACK_LOGICAL_PTR(s, v) do { \
4204 int __v__ = (v); \
4205 (s)->tag = LGLSXP; \
4206 if (__v__ == NA_LOGICAL) \
4207 (s)->u.ival = NA_LOGICAL; \
4208 else \
4209 (s)->u.ival = __v__ ? TRUE : FALSE; \
4210 } while (0)
4211
4212 #define IS_STACKVAL_BOXED(idx) (R_BCNodeStackTop[idx].tag == 0)
4213
4214 #ifdef COMPACT_INTSEQ
4215 #define SETSTACK_INTSEQ(idx, rn1, rn2) do { \
4216 SEXP info = allocVector(INTSXP, 2); \
4217 INTEGER(info)[0] = (int) rn1; \
4218 INTEGER(info)[1] = (int) rn2; \
4219 R_BCNodeStackTop[idx].u.sxpval = info; \
4220 R_BCNodeStackTop[idx].tag = INTSEQSXP; \
4221 } while (0)
4222 #else
4223 #define SETSTACK_INTSEQ(idx, rn1, rn2) \
4224 SETSTACK(idx, seq_int((int) rn1, (int) rn2))
4225 #endif
4226
4227 #define GETSTACK_SXPVAL(i) GETSTACK_SXPVAL_PTR(R_BCNodeStackTop + (i))
4228
4229 #define GETSTACK(i) GETSTACK_PTR(R_BCNodeStackTop + (i))
4230
4231 #define SETSTACK(i, v) SETSTACK_PTR(R_BCNodeStackTop + (i), v)
4232
4233 #define SETSTACK_REAL(i, v) SETSTACK_REAL_PTR(R_BCNodeStackTop + (i), v)
4234
4235 #define SETSTACK_INTEGER(i, v) SETSTACK_INTEGER_PTR(R_BCNodeStackTop + (i), v)
4236
4237 #define SETSTACK_LOGICAL(i, v) SETSTACK_LOGICAL_PTR(R_BCNodeStackTop + (i), v)
4238
4239
4240 /* bcStackScalar() checks whether the object in the specified stack
4241 location is an immediate scalar or a boxed simple real, integer, or
4242 logical scalar (i.e. length one and no attributes). For immediate
4243 values the stack pointer is returned; for others the supplied stack
4244 structure pointer is returned after filling its fields
4245 appropriately. */
bcStackScalar(R_bcstack_t * s,R_bcstack_t * v)4246 static R_INLINE R_bcstack_t *bcStackScalar(R_bcstack_t *s, R_bcstack_t *v)
4247 {
4248 switch (s->tag) {
4249 case REALSXP:
4250 case INTSXP:
4251 case LGLSXP: return s;
4252 }
4253
4254 SEXP x = GETSTACK_SXPVAL_PTR(s);
4255 if (IS_SIMPLE_SCALAR(x, REALSXP)) {
4256 v->tag = REALSXP;
4257 v->u.dval = SCALAR_DVAL(x);
4258 return v;
4259 }
4260 else if (IS_SIMPLE_SCALAR(x, INTSXP)) {
4261 v->tag = INTSXP;
4262 v->u.ival = SCALAR_IVAL(x);
4263 return v;
4264 }
4265 else if (IS_SIMPLE_SCALAR(x, LGLSXP)) {
4266 v->tag = LGLSXP;
4267 v->u.ival = SCALAR_LVAL(x);
4268 return v;
4269 }
4270 else {
4271 v->tag = 0;
4272 v->u.sxpval = NULL;
4273 return v;
4274 }
4275 }
4276
4277 #define INTEGER_TO_LOGICAL(x) \
4278 ((x) == NA_INTEGER ? NA_LOGICAL : (x) ? TRUE : FALSE)
4279 #define INTEGER_TO_REAL(x) ((x) == NA_INTEGER ? NA_REAL : (x))
4280 #define LOGICAL_TO_REAL(x) ((x) == NA_LOGICAL ? NA_REAL : (x))
4281
bcStackScalarReal(R_bcstack_t * s,R_bcstack_t * v)4282 static R_INLINE R_bcstack_t *bcStackScalarReal(R_bcstack_t *s, R_bcstack_t *v)
4283 {
4284 v = bcStackScalar(s, v);
4285 if (v->tag == INTSXP) {
4286 v->tag = REALSXP;
4287 v->u.dval = INTEGER_TO_REAL(v->u.ival);
4288 }
4289 return v;
4290 }
4291
4292 #define DO_FAST_RELOP2(op,a,b) do { \
4293 SKIP_OP(); \
4294 SETSTACK_LOGICAL(-2, ((a) op (b)) ? TRUE : FALSE); \
4295 R_BCNodeStackTop--; \
4296 R_Visible = TRUE; \
4297 NEXT(); \
4298 } while (0)
4299
4300 #define INCLNK_STACK_PTR(s) do { \
4301 if ((s)->tag == 0) \
4302 INCREMENT_LINKS((s)->u.sxpval); \
4303 } while (0)
4304
4305 #define DECLNK_STACK_PTR(s) do { \
4306 if ((s)->tag == 0) \
4307 DECREMENT_LINKS((s)->u.sxpval); \
4308 } while (0)
4309
4310 /* drop eventually */
4311 #define OLDBC_INCREMENT_LINKS(s) do { \
4312 if (old_byte_code) INCREMENT_LINKS(s); \
4313 } while (0)
4314 #define OLDBC_DECLNK_STACK_PTR(s) do { \
4315 if (old_byte_code) DECLNK_STACK_PTR(s); \
4316 } while (0)
4317
4318 #define FastRelop2(op,opval,opsym) do { \
4319 R_bcstack_t vvx, vvy; \
4320 R_bcstack_t *vx = bcStackScalar(R_BCNodeStackTop - 2, &vvx); \
4321 R_bcstack_t *vy = bcStackScalar(R_BCNodeStackTop - 1, &vvy); \
4322 if (vx->tag == REALSXP && ! ISNAN(vx->u.dval)) { \
4323 if (vy->tag == REALSXP && ! ISNAN(vy->u.dval)) \
4324 DO_FAST_RELOP2(op, vx->u.dval, vy->u.dval); \
4325 else if (vy->tag == INTSXP && vy->u.ival != NA_INTEGER) \
4326 DO_FAST_RELOP2(op, vx->u.dval, vy->u.ival); \
4327 } \
4328 else if (vx->tag == INTSXP && vx->u.ival != NA_INTEGER) { \
4329 if (vy->tag == REALSXP && ! ISNAN(vy->u.dval)) \
4330 DO_FAST_RELOP2(op, vx->u.ival, vy->u.dval); \
4331 else if (vy->tag == INTSXP && vy->u.ival != NA_INTEGER) { \
4332 DO_FAST_RELOP2(op, vx->u.ival, vy->u.ival); \
4333 } \
4334 } \
4335 Relop2(opval, opsym); \
4336 } while (0)
4337
4338 /* not actually optimized yet; ignore op, opval for now */
4339 #define FastLogic2(op, opval, opsym) do { \
4340 Builtin2(do_logic, opsym, rho); \
4341 } while (0)
4342
getPrimitive(SEXP symbol,SEXPTYPE type)4343 static R_INLINE SEXP getPrimitive(SEXP symbol, SEXPTYPE type)
4344 {
4345 SEXP value = SYMVALUE(symbol);
4346 if (TYPEOF(value) == PROMSXP) {
4347 value = forcePromise(value);
4348 ENSURE_NAMEDMAX(value);
4349 }
4350 if (TYPEOF(value) != type) {
4351 /* probably means a package redefined the base function so
4352 try to get the real thing from the internal table of
4353 primitives */
4354 value = R_Primitive(CHAR(PRINTNAME(symbol)));
4355 if (TYPEOF(value) != type)
4356 /* if that doesn't work we signal an error */
4357 error(_("\"%s\" is not a %s function"),
4358 CHAR(PRINTNAME(symbol)),
4359 type == BUILTINSXP ? "BUILTIN" : "SPECIAL");
4360 }
4361 return value;
4362 }
4363
cmp_relop(SEXP call,int opval,SEXP opsym,SEXP x,SEXP y,SEXP rho)4364 static SEXP cmp_relop(SEXP call, int opval, SEXP opsym, SEXP x, SEXP y,
4365 SEXP rho)
4366 {
4367 SEXP op = getPrimitive(opsym, BUILTINSXP);
4368 if (isObject(x) || isObject(y)) {
4369 SEXP args, ans;
4370 args = CONS_NR(x, CONS_NR(y, R_NilValue));
4371 PROTECT(args);
4372 if (DispatchGroup("Ops", call, op, args, rho, &ans)) {
4373 UNPROTECT(1);
4374 return ans;
4375 }
4376 UNPROTECT(1);
4377 }
4378 return do_relop_dflt(call, op, x, y);
4379 }
4380
cmp_arith1(SEXP call,SEXP opsym,SEXP x,SEXP rho)4381 static SEXP cmp_arith1(SEXP call, SEXP opsym, SEXP x, SEXP rho)
4382 {
4383 SEXP op = getPrimitive(opsym, BUILTINSXP);
4384 if (isObject(x)) {
4385 SEXP args, ans;
4386 args = CONS_NR(x, R_NilValue);
4387 PROTECT(args);
4388 if (DispatchGroup("Ops", call, op, args, rho, &ans)) {
4389 UNPROTECT(1);
4390 return ans;
4391 }
4392 UNPROTECT(1);
4393 }
4394 return R_unary(call, op, x);
4395 }
4396
cmp_arith2(SEXP call,int opval,SEXP opsym,SEXP x,SEXP y,SEXP rho)4397 static SEXP cmp_arith2(SEXP call, int opval, SEXP opsym, SEXP x, SEXP y,
4398 SEXP rho)
4399 {
4400 SEXP op = getPrimitive(opsym, BUILTINSXP);
4401 if (isObject(x) || isObject(y)) {
4402 SEXP args, ans;
4403 args = CONS_NR(x, CONS_NR(y, R_NilValue));
4404 PROTECT(args);
4405 if (DispatchGroup("Ops", call, op, args, rho, &ans)) {
4406 UNPROTECT(1);
4407 return ans;
4408 }
4409 UNPROTECT(1);
4410 }
4411 return R_binary(call, op, x, y);
4412 }
4413
4414 #define Builtin1(do_fun,which,rho) do { \
4415 SEXP call = VECTOR_ELT(constants, GETOP()); \
4416 SETSTACK(-1, CONS_NR(GETSTACK(-1), R_NilValue)); \
4417 SETSTACK(-1, do_fun(call, getPrimitive(which, BUILTINSXP), \
4418 GETSTACK(-1), rho)); \
4419 R_Visible = TRUE; \
4420 NEXT(); \
4421 } while(0)
4422
4423 #define Builtin2(do_fun,which,rho) do { \
4424 SEXP stack1 = GETSTACK(-1); \
4425 SEXP stack2 = GETSTACK(-2); \
4426 SEXP call = VECTOR_ELT(constants, GETOP()); \
4427 SEXP tmp = CONS_NR(stack1, R_NilValue); \
4428 SETSTACK(-2, CONS_NR(stack2, tmp)); \
4429 R_BCNodeStackTop--; \
4430 SETSTACK(-1, do_fun(call, getPrimitive(which, BUILTINSXP), \
4431 GETSTACK(-1), rho)); \
4432 R_Visible = TRUE; \
4433 NEXT(); \
4434 } while(0)
4435
4436 #define NewBuiltin2(do_fun,opval,opsym,rho) do { \
4437 SEXP call = VECTOR_ELT(constants, GETOP()); \
4438 SEXP x = GETSTACK(-2); \
4439 SEXP y = GETSTACK(-1); \
4440 SETSTACK(-2, do_fun(call, opval, opsym, x, y,rho)); \
4441 R_BCNodeStackTop--; \
4442 R_Visible = TRUE; \
4443 NEXT(); \
4444 } while(0)
4445
4446 #define Arith1(opsym) do { \
4447 SEXP call = VECTOR_ELT(constants, GETOP()); \
4448 SEXP x = GETSTACK(-1); \
4449 SETSTACK(-1, cmp_arith1(call, opsym, x, rho)); \
4450 R_Visible = TRUE; \
4451 NEXT(); \
4452 } while(0)
4453
4454
4455 #define Arith2(opval,opsym) NewBuiltin2(cmp_arith2,opval,opsym,rho)
4456 #define Relop2(opval,opsym) NewBuiltin2(cmp_relop,opval,opsym,rho)
4457
4458 #define R_MSG_NA _("NaNs produced")
4459 #define CMP_ISNAN ISNAN
4460 //On Linux this is quite a bit faster; not on macOS El Capitan:
4461 //#define CMP_ISNAN(x) ((x) != (x))
4462 #define FastMath1(fun, sym) do { \
4463 R_bcstack_t vvx; \
4464 R_bcstack_t *vx = bcStackScalar(R_BCNodeStackTop - 1, &vvx); \
4465 if (vx->tag == REALSXP) { \
4466 double dval = fun(vx->u.dval); \
4467 if (CMP_ISNAN(dval)) { \
4468 SEXP call = VECTOR_ELT(constants, GETOP()); \
4469 if (ISNAN(vx->u.dval)) dval = vx->u.dval; \
4470 else warningcall(call, R_MSG_NA); \
4471 } \
4472 else SKIP_OP(); \
4473 SETSTACK_REAL(-1, dval); \
4474 R_Visible = TRUE; \
4475 NEXT(); \
4476 } \
4477 else if (vx->tag == INTSXP && vx->u.ival != NA_INTEGER) { \
4478 SKIP_OP(); \
4479 SETSTACK_REAL(-1, fun(vx->u.ival)); \
4480 R_Visible = TRUE; \
4481 NEXT(); \
4482 } \
4483 Builtin1(do_math1,sym,rho); \
4484 } while (0)
4485
4486 #define DO_FAST_BINOP(fun,a,b) do { \
4487 SKIP_OP(); \
4488 SETSTACK_REAL(-2, fun(a, b)); \
4489 R_BCNodeStackTop--; \
4490 R_Visible = TRUE; \
4491 NEXT(); \
4492 } while (0)
4493
4494 #define DO_FAST_BINOP_INT(fun, a, b) do { \
4495 double dval = fun((double) (a), (double) (b)); \
4496 if (dval <= INT_MAX && dval >= INT_MIN + 1) { \
4497 SKIP_OP(); \
4498 SETSTACK_INTEGER(-2, (int) dval); \
4499 R_BCNodeStackTop--; \
4500 R_Visible = TRUE; \
4501 NEXT(); \
4502 } \
4503 } while(0)
4504
4505 #define FastUnary(op, opsym) do { \
4506 R_bcstack_t vvx; \
4507 R_bcstack_t *vx = bcStackScalar(R_BCNodeStackTop - 1, &vvx); \
4508 if (vx->tag == REALSXP) { \
4509 SKIP_OP(); \
4510 SETSTACK_REAL(-1, op vx->u.dval); \
4511 R_Visible = TRUE; \
4512 NEXT(); \
4513 } \
4514 else if (vx->tag == INTSXP && vx->u.ival != NA_INTEGER) { \
4515 SKIP_OP(); \
4516 SETSTACK_INTEGER(-1, op vx->u.ival); \
4517 R_Visible = TRUE; \
4518 NEXT(); \
4519 } \
4520 Arith1(opsym); \
4521 } while (0)
4522
4523 #define FastBinary(op,opval,opsym) do { \
4524 { \
4525 R_bcstack_t *sx = R_BCNodeStackTop - 2; \
4526 R_bcstack_t *sy = R_BCNodeStackTop - 1; \
4527 if (sx->tag == REALSXP && sy->tag == REALSXP) \
4528 DO_FAST_BINOP(op, sx->u.dval, sy->u.dval); \
4529 } \
4530 R_bcstack_t vvx, vvy; \
4531 R_bcstack_t *vx = bcStackScalar(R_BCNodeStackTop - 2, &vvx); \
4532 R_bcstack_t *vy = bcStackScalar(R_BCNodeStackTop - 1, &vvy); \
4533 if (vx->tag == REALSXP) { \
4534 if (vy->tag == REALSXP) \
4535 DO_FAST_BINOP(op, vx->u.dval, vy->u.dval); \
4536 else if (vy->tag == INTSXP && vy->u.ival != NA_INTEGER) \
4537 DO_FAST_BINOP(op, vx->u.dval, vy->u.ival); \
4538 } \
4539 else if (vx->tag == INTSXP && vx->u.ival != NA_INTEGER) { \
4540 int ix = vx->u.ival; \
4541 if (vy->tag == REALSXP) \
4542 DO_FAST_BINOP(op, ix, vy->u.dval); \
4543 else if (vy->tag == INTSXP && vy->u.ival != NA_INTEGER) { \
4544 int iy = vy->u.ival; \
4545 if (opval == DIVOP || opval == POWOP) \
4546 DO_FAST_BINOP(op, (double) ix, (double) iy); \
4547 else \
4548 DO_FAST_BINOP_INT(op, ix, iy); \
4549 } \
4550 } \
4551 Arith2(opval, opsym); \
4552 } while (0)
4553
4554 #define R_ADD(x, y) ((x) + (y))
4555 #define R_SUB(x, y) ((x) - (y))
4556 #define R_MUL(x, y) ((x) * (y))
4557 #define R_DIV(x, y) ((x) / (y))
4558
4559 #include "arithmetic.h"
4560
4561 /* The current (as of r67808) Windows toolchain compiles explicit sqrt
4562 calls in a way that returns a different NaN than NA_real_ when
4563 called with NA_real_. Not sure this is a bug in the Windows
4564 toolchain or in our expectations, but these defines attempt to work
4565 around this. */
4566 #if (defined(_WIN32) || defined(_WIN64)) && defined(__GNUC__) && \
4567 __GNUC__ <= 4
4568 # define R_sqrt(x) (ISNAN(x) ? x : sqrt(x))
4569 #else
4570 # define R_sqrt sqrt
4571 #endif
4572
4573 #define DO_LOG() do { \
4574 R_bcstack_t vvx; \
4575 R_bcstack_t *vx = bcStackScalarReal(R_BCNodeStackTop - 1, &vvx); \
4576 if (vx->tag == REALSXP) { \
4577 double dval = R_log(vx->u.dval); \
4578 if (CMP_ISNAN(dval)) { \
4579 SEXP call = VECTOR_ELT(constants, GETOP()); \
4580 if (ISNAN(vx->u.dval)) dval = vx->u.dval; \
4581 else warningcall(call, R_MSG_NA); \
4582 } \
4583 else SKIP_OP(); \
4584 SETSTACK_REAL(-1, dval); \
4585 R_Visible = TRUE; \
4586 NEXT(); \
4587 } \
4588 SEXP call = VECTOR_ELT(constants, GETOP()); \
4589 SEXP args = CONS_NR(GETSTACK(-1), R_NilValue); \
4590 SETSTACK(-1, args); /* to protect */ \
4591 SEXP op = getPrimitive(R_LogSym, SPECIALSXP); \
4592 SETSTACK(-1, do_log_builtin(call, op, args, rho)); \
4593 R_Visible = TRUE; \
4594 NEXT(); \
4595 } while (0)
4596
4597 #define DO_LOGBASE() do { \
4598 R_bcstack_t vvx, vvy; \
4599 R_bcstack_t *vx = bcStackScalarReal(R_BCNodeStackTop - 2, &vvx); \
4600 R_bcstack_t *vy = bcStackScalarReal(R_BCNodeStackTop - 1, &vvy); \
4601 if (vx->tag == REALSXP && vy->tag == REALSXP) { \
4602 double dval = logbase(vx->u.dval, vy->u.dval); \
4603 if (ISNAN(dval)) { \
4604 SEXP call = VECTOR_ELT(constants, GETOP()); \
4605 if (ISNAN(vx->u.dval)) dval = vx->u.dval; \
4606 else if (ISNAN(vy->u.dval)) dval = vy->u.dval; \
4607 else warningcall(call, R_MSG_NA); \
4608 } \
4609 else SKIP_OP(); \
4610 R_BCNodeStackTop--; \
4611 SETSTACK_REAL(-1, dval); \
4612 R_Visible = TRUE; \
4613 NEXT(); \
4614 } \
4615 SEXP call = VECTOR_ELT(constants, GETOP()); \
4616 SEXP tmp = GETSTACK(-2); \
4617 SEXP args = CONS_NR(tmp, CONS_NR(GETSTACK(-1), R_NilValue)); \
4618 R_BCNodeStackTop--; \
4619 SETSTACK(-1, args); /* to protect */ \
4620 SEXP op = getPrimitive(R_LogSym, SPECIALSXP); \
4621 SETSTACK(-1, do_log_builtin(call, op, args, rho)); \
4622 R_Visible = TRUE; \
4623 NEXT(); \
4624 } while (0)
4625
4626 #include <Rmath.h>
4627 /* Keep the order consistent with the order in the byte code compiler! */
4628 static struct { const char *name; SEXP sym; double (*fun)(double); }
4629 math1funs[] = {
4630 {"floor", NULL, floor},
4631 {"ceiling", NULL, ceil},
4632 {"sign", NULL, sign},
4633
4634 {"expm1", NULL, expm1},
4635 {"log1p", NULL, log1p},
4636
4637 {"cos", NULL, cos},
4638 {"sin", NULL, sin},
4639 {"tan", NULL, tan},
4640 {"acos", NULL, acos},
4641 {"asin", NULL, asin},
4642 {"atan", NULL, atan},
4643
4644 {"cosh", NULL, cosh},
4645 {"sinh", NULL, sinh},
4646 {"tanh", NULL, tanh},
4647 {"acosh", NULL, acosh},
4648 {"asinh", NULL, asinh},
4649 {"atanh", NULL, atanh},
4650
4651 {"lgamma", NULL, lgammafn},
4652 {"gamma", NULL, gammafn},
4653 {"digamma", NULL, digamma},
4654 {"trigamma", NULL, trigamma},
4655
4656 {"cospi", NULL, cospi},
4657 {"sinpi", NULL, sinpi},
4658 #ifndef HAVE_TANPI
4659 {"tanpi", NULL, tanpi}
4660 #else
4661 {"tanpi", NULL, Rtanpi}
4662 #endif
4663 };
4664
getMath1Fun(int i,SEXP call)4665 static R_INLINE double (*getMath1Fun(int i, SEXP call))(double) {
4666 if (math1funs[i].sym == NULL)
4667 math1funs[i].sym = install(math1funs[i].name);
4668 if (CAR(call) != math1funs[i].sym)
4669 error("math1 compiler/interpreter mismatch");
4670 return math1funs[i].fun;
4671 }
4672
4673 #define DO_MATH1() do { \
4674 SEXP call = VECTOR_ELT(constants, GETOP()); \
4675 double (*fun)(double) = getMath1Fun(GETOP(), call); \
4676 R_bcstack_t vvx; \
4677 R_bcstack_t *vx = bcStackScalarReal(R_BCNodeStackTop - 1, &vvx); \
4678 if (vx->tag == REALSXP) { \
4679 double dval = fun(vx->u.dval); \
4680 if (ISNAN(dval)) { \
4681 if (ISNAN(vx->u.dval)) dval = vx->u.dval; \
4682 else warningcall(call, R_MSG_NA); \
4683 } \
4684 SETSTACK_REAL(-1, dval); \
4685 R_Visible = TRUE; \
4686 NEXT(); \
4687 } \
4688 SEXP args = CONS_NR(GETSTACK(-1), R_NilValue); \
4689 SEXP sym = CAR(call); \
4690 SETSTACK(-1, args); /* to protect */ \
4691 SEXP op = getPrimitive(sym, BUILTINSXP); \
4692 SETSTACK(-1, do_math1(call, op, args, rho)); \
4693 R_Visible = TRUE; \
4694 NEXT(); \
4695 } while (0)
4696
4697 #include <Rdynpriv.h>
4698
4699 #define DOTCALL_MAX 16
4700 #define DO_DOTCALL() do { \
4701 SEXP call = VECTOR_ELT(constants, GETOP()); \
4702 int nargs = GETOP(); \
4703 DL_FUNC ofun = R_dotCallFn(GETSTACK(- nargs - 1), call, nargs); \
4704 if (ofun && nargs <= DOTCALL_MAX) { \
4705 SEXP cargs[DOTCALL_MAX]; \
4706 for (int i = 0; i < nargs; i++) \
4707 cargs[i] = GETSTACK(i - nargs); \
4708 void *vmax = vmaxget(); \
4709 SEXP val = R_doDotCall(ofun, nargs, cargs, call); \
4710 vmaxset(vmax); \
4711 R_BCNodeStackTop -= nargs; \
4712 SETSTACK(-1, val); \
4713 R_Visible = TRUE; \
4714 NEXT(); \
4715 } \
4716 SEXP args = R_NilValue; \
4717 BCNPUSH(args); /* allocate space for protecting args */ \
4718 while (nargs-- >= 0) { \
4719 args = CONS_NR(GETSTACK(-2), args); \
4720 SETSTACK(-2, args); /* to protect */ \
4721 BCNPOP_IGNORE_VALUE(); \
4722 } \
4723 SEXP sym = CAR(call); \
4724 SEXP op = getPrimitive(sym, BUILTINSXP); \
4725 SETSTACK(-1, do_dotcall(call, op, args, rho)); \
4726 R_Visible = TRUE; \
4727 NEXT(); \
4728 } while (0)
4729
4730 #define DO_COLON() do { \
4731 R_bcstack_t vvx, vvy; \
4732 R_bcstack_t *vx = bcStackScalarReal(R_BCNodeStackTop - 2, &vvx); \
4733 R_bcstack_t *vy = bcStackScalarReal(R_BCNodeStackTop - 1, &vvy); \
4734 if (vx->tag == REALSXP && vy->tag == REALSXP) { \
4735 double rn1 = vx->u.dval; \
4736 double rn2 = vy->u.dval; \
4737 if (R_FINITE(rn1) && R_FINITE(rn2) && \
4738 INT_MIN <= rn1 && INT_MAX >= rn1 && \
4739 INT_MIN <= rn2 && INT_MAX >= rn2 && \
4740 rn1 == (int) rn1 && rn2 == (int) rn2) { \
4741 SKIP_OP(); /* skip 'call' index */ \
4742 R_BCNodeStackTop--; \
4743 SETSTACK_INTSEQ(-1, rn1, rn2); \
4744 R_Visible = TRUE; \
4745 NEXT(); \
4746 } \
4747 } \
4748 Builtin2(do_colon, R_ColonSymbol, rho); \
4749 } while (0)
4750
4751 #define DO_SEQ_ALONG() do { \
4752 SEXP x = GETSTACK(-1); \
4753 if (! OBJECT(x)) { \
4754 R_xlen_t len = xlength(x); \
4755 if (len >= 1 && len <= INT_MAX) { \
4756 SKIP_OP(); /* skip 'call' index */ \
4757 SETSTACK_INTSEQ(-1, 1, len); \
4758 R_Visible = TRUE; \
4759 NEXT(); \
4760 } \
4761 } \
4762 Builtin1(do_seq_along, install("seq_along"), rho); \
4763 } while (0)
4764
4765 #define DO_SEQ_LEN() do { \
4766 R_bcstack_t vvx; \
4767 R_bcstack_t *vx = bcStackScalarReal(R_BCNodeStackTop - 1, &vvx); \
4768 if (vx->tag == REALSXP) { \
4769 double rlen = vx->u.dval; \
4770 if (1 <= rlen && INT_MAX >= rlen && \
4771 rlen == (int) rlen) { \
4772 SKIP_OP(); /* skip 'call' index */ \
4773 SETSTACK_INTSEQ(-1, 1, rlen); \
4774 R_Visible = TRUE; \
4775 NEXT(); \
4776 } \
4777 } \
4778 Builtin1(do_seq_len, install("seq_len"), rho); \
4779 } while (0)
4780
getForLoopSeq(int offset,Rboolean * iscompact)4781 static R_INLINE SEXP getForLoopSeq(int offset, Rboolean *iscompact)
4782 {
4783 #ifdef COMPACT_INTSEQ
4784 R_bcstack_t *s = R_BCNodeStackTop + offset;
4785 if (s->tag == INTSEQSXP) {
4786 *iscompact = TRUE;
4787 return s->u.sxpval;
4788 }
4789 #endif
4790 *iscompact = FALSE;
4791 return GETSTACK(offset);
4792 }
4793
4794 #define BCNPUSH(v) do { \
4795 SEXP __value__ = (v); \
4796 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4797 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4798 SETSTACK(0, __value__); \
4799 R_BCNodeStackTop = __ntop__; \
4800 } while (0)
4801
4802 #define BCNPUSH_NLNK(v) do { \
4803 BCNPUSH(R_NilValue); \
4804 SETSTACK_NLNK(-1, v); \
4805 } while (0)
4806
4807 #define BCNPUSH_REAL(v) do { \
4808 double __value__ = (v); \
4809 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4810 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4811 __ntop__[-1].u.dval = __value__; \
4812 __ntop__[-1].tag = REALSXP; \
4813 R_BCNodeStackTop = __ntop__; \
4814 } while (0)
4815
4816 #define BCNPUSH_INTEGER(v) do { \
4817 int __value__ = (v); \
4818 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4819 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4820 __ntop__[-1].u.ival = __value__; \
4821 __ntop__[-1].tag = INTSXP; \
4822 R_BCNodeStackTop = __ntop__; \
4823 } while (0)
4824
4825 #define BCNPUSH_LOGICAL(v) do { \
4826 int __value__ = (v); \
4827 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4828 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4829 __ntop__[-1].u.ival = __value__; \
4830 __ntop__[-1].tag = LGLSXP; \
4831 R_BCNodeStackTop = __ntop__; \
4832 } while (0)
4833
4834 #define BCNDUP() do { \
4835 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4836 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4837 __ntop__[-1] = __ntop__[-2]; \
4838 R_BCNodeStackTop = __ntop__; \
4839 } while(0)
4840
4841 #define BCNDUP2ND() do { \
4842 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4843 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4844 __ntop__[-1] = __ntop__[-3]; \
4845 R_BCNodeStackTop = __ntop__; \
4846 } while(0)
4847
4848 #define BCNDUP3RD() do { \
4849 R_bcstack_t *__ntop__ = R_BCNodeStackTop + 1; \
4850 if (__ntop__ > R_BCNodeStackEnd) nodeStackOverflow(); \
4851 __ntop__[-1] = __ntop__[-4]; \
4852 R_BCNodeStackTop = __ntop__; \
4853 } while(0)
4854
4855 #define BCNPOP() (R_BCNodeStackTop--, GETSTACK(0))
4856 #define BCNPOP_IGNORE_VALUE() R_BCNodeStackTop--
4857
4858 #define BCNSTACKCHECK(n) do { \
4859 if (R_BCNodeStackTop + (n) > R_BCNodeStackEnd) nodeStackOverflow(); \
4860 } while (0)
4861
4862 #define BCIPUSHPTR(v) do { \
4863 void *__value__ = (v); \
4864 IStackval *__ntop__ = R_BCIntStackTop + 1; \
4865 if (__ntop__ > R_BCIntStackEnd) intStackOverflow(); \
4866 *__ntop__[-1].p = __value__; \
4867 R_BCIntStackTop = __ntop__; \
4868 } while (0)
4869
4870 #define BCIPUSHINT(v) do { \
4871 int __value__ = (v); \
4872 IStackval *__ntop__ = R_BCIntStackTop + 1; \
4873 if (__ntop__ > R_BCIntStackEnd) intStackOverflow(); \
4874 __ntop__[-1].i = __value__; \
4875 R_BCIntStackTop = __ntop__; \
4876 } while (0)
4877
4878 #define BCIPOPPTR() ((--R_BCIntStackTop)->p)
4879 #define BCIPOPINT() ((--R_BCIntStackTop)->i)
4880
4881 #define BCCONSTS(e) BCODE_CONSTS(e)
4882
nodeStackOverflow()4883 static void NORET nodeStackOverflow()
4884 {
4885 error(_("node stack overflow"));
4886 }
4887
4888 /* Allocate consecutive space of nelems node stack elements */
BCNALLOC(int nelems)4889 static R_INLINE void* BCNALLOC(int nelems) {
4890 void *ans;
4891
4892 BCNSTACKCHECK(nelems + 1);
4893 R_BCNodeStackTop->tag = RAWMEM_TAG;
4894 R_BCNodeStackTop->u.ival = nelems;
4895 R_BCNodeStackTop++;
4896 ans = R_BCNodeStackTop;
4897 R_BCNodeStackTop += nelems;
4898 return ans;
4899 }
4900
4901 /* Allocate R context on the node stack */
4902 #define RCNTXT_ELEMS ((sizeof(RCNTXT) + sizeof(R_bcstack_t) - 1) \
4903 / sizeof(R_bcstack_t))
4904
4905 #define BCNALLOC_CNTXT() (RCNTXT *)BCNALLOC(RCNTXT_ELEMS)
4906
BCNPOP_AND_END_CNTXT()4907 static R_INLINE void BCNPOP_AND_END_CNTXT() {
4908 RCNTXT* cntxt = (RCNTXT *)(R_BCNodeStackTop - RCNTXT_ELEMS);
4909 endcontext(cntxt);
4910 R_BCNodeStackTop -= RCNTXT_ELEMS + 1;
4911 }
4912
bytecodeExpr(SEXP e)4913 static SEXP bytecodeExpr(SEXP e)
4914 {
4915 if (isByteCode(e)) {
4916 if (LENGTH(BCCONSTS(e)) > 0)
4917 return VECTOR_ELT(BCCONSTS(e), 0);
4918 else return R_NilValue;
4919 }
4920 else return e;
4921 }
4922
R_BytecodeExpr(SEXP e)4923 SEXP R_BytecodeExpr(SEXP e)
4924 {
4925 return bytecodeExpr(e);
4926 }
4927
R_PromiseExpr(SEXP p)4928 SEXP R_PromiseExpr(SEXP p)
4929 {
4930 return bytecodeExpr(PRCODE(p));
4931 }
4932
R_ClosureExpr(SEXP p)4933 SEXP R_ClosureExpr(SEXP p)
4934 {
4935 return bytecodeExpr(BODY(p));
4936 }
4937
4938 #ifdef THREADED_CODE
4939 typedef union { void *v; int i; } BCODE;
4940
4941 /* Declare opinfo volatile to prevent gcc 6 from making a local copy
4942 in bcEval stack frames and thus increasing stack usage
4943 dramatically */
4944 volatile
4945 static struct { void *addr; int argc; char *instname; } opinfo[OPCOUNT];
4946
4947 #define OP(name,n) \
4948 case name##_OP: opinfo[name##_OP].addr = (__extension__ &&op_##name); \
4949 opinfo[name##_OP].argc = (n); \
4950 opinfo[name##_OP].instname = #name; \
4951 goto loop; \
4952 op_##name
4953
4954 #define BEGIN_MACHINE NEXT(); init: { loop: switch(which++)
4955 #define LASTOP } retvalue = R_NilValue; goto done
4956 #define INITIALIZE_MACHINE() if (body == NULL) goto init
4957
4958 #define NEXT() (__extension__ ({currentpc = pc; goto *(*pc++).v;}))
4959 #define GETOP() (*pc++).i
4960 #define SKIP_OP() (pc++)
4961
4962 #define BCCODE(e) (BCODE *) INTEGER(BCODE_CODE(e))
4963 #else
4964 typedef int BCODE;
4965
4966 #define OP(name,argc) case name##_OP
4967
4968 #ifdef BC_PROFILING
4969 #define BEGIN_MACHINE loop: currentpc = pc; current_opcode = *pc; switch(*pc++)
4970 #else
4971 #define BEGIN_MACHINE loop: currentpc = pc; switch(*pc++)
4972 #endif
4973 #define LASTOP default: error(_("bad opcode"))
4974 #define INITIALIZE_MACHINE()
4975
4976 #define NEXT() goto loop
4977 #define GETOP() *pc++
4978 #define SKIP_OP() (pc++)
4979
4980 #define BCCODE(e) INTEGER(BCODE_CODE(e))
4981 #endif
4982
4983 /**** is there a way to avoid the locked check here? */
4984 /**** always boxing on lock is one option */
4985 #define BNDCELL_TAG_WR(v) (BINDING_IS_LOCKED(v) ? 0 : BNDCELL_TAG(v))
4986
4987 #define BNDCELL_WRITABLE(v) \
4988 (v != R_NilValue && ! BINDING_IS_LOCKED(v) && ! IS_ACTIVE_BINDING(v))
4989 #define BNDCELL_UNBOUND(v) (BNDCELL_TAG(v) == 0 && CAR0(v) == R_UnboundValue)
4990
NEW_BNDCELL_DVAL(SEXP cell,double dval)4991 static R_INLINE void NEW_BNDCELL_DVAL(SEXP cell, double dval)
4992 {
4993 INIT_BNDCELL(cell, REALSXP);
4994 SET_BNDCELL_DVAL(cell, dval);
4995 }
4996
NEW_BNDCELL_IVAL(SEXP cell,int ival)4997 static R_INLINE void NEW_BNDCELL_IVAL(SEXP cell, int ival)
4998 {
4999 INIT_BNDCELL(cell, INTSXP);
5000 SET_BNDCELL_IVAL(cell, ival);
5001 }
5002
NEW_BNDCELL_LVAL(SEXP cell,int lval)5003 static R_INLINE void NEW_BNDCELL_LVAL(SEXP cell, int lval)
5004 {
5005 INIT_BNDCELL(cell, LGLSXP);
5006 SET_BNDCELL_LVAL(cell, lval);
5007 }
5008
BINDING_VALUE(SEXP loc)5009 static R_INLINE SEXP BINDING_VALUE(SEXP loc)
5010 {
5011 if (BNDCELL_TAG(loc)) {
5012 R_expand_binding_value(loc);
5013 return CAR0(loc);
5014 }
5015 else if (loc != R_NilValue && ! IS_ACTIVE_BINDING(loc))
5016 return CAR0(loc);
5017 else
5018 return R_UnboundValue;
5019 }
5020
5021 #define BINDING_SYMBOL(loc) TAG(loc)
5022
5023 /* Defining USE_BINDING_CACHE enables a cache for GETVAR, SETVAR, and
5024 others to more efficiently locate bindings in the top frame of the
5025 current environment. The index into of the symbol in the constant
5026 table is used as the cache index. Two options can be used to chose
5027 among implementation strategies:
5028
5029 If CACHE_ON_STACK is defined the cache is allocated on the
5030 byte code stack. Otherwise it is allocated on the heap as a
5031 VECSXP. The stack-based approach is more efficient, but runs
5032 the risk of running out of stack space.
5033
5034 If CACHE_MAX is defined, then a cache of at most that size is
5035 used. The value must be a power of 2 so a modulus computation x
5036 % CACHE_MAX can be done as x & (CACHE_MAX - 1). More than 90%
5037 of the closures in base have constant pools with fewer than 128
5038 entries when compiled, to that is a good value to use. But
5039 increasing to 256 handles some benchmark scripts a bit better.
5040
5041 On average about 1/3 of constant pool entries are symbols, so this
5042 approach wastes some space. This could be avoided by grouping the
5043 symbols at the beginning of the constant pool and recording the
5044 number.
5045
5046 Bindings recorded may become invalid if user code removes a
5047 variable. The code in envir.c has been modified to insert
5048 R_unboundValue as the value of a binding when it is removed, and
5049 code using cached bindings checks for this.
5050
5051 It would be nice if we could also cache bindings for variables
5052 found in enclosing environments. These would become invalid if a
5053 new variable is defined in an intervening frame. Some mechanism for
5054 invalidating the cache would be needed. This is certainly possible,
5055 but finding an efficient mechanism does not seem to be easy. LT */
5056
5057 #define USE_BINDING_CACHE
5058 # ifdef USE_BINDING_CACHE
5059 /* CACHE_MAX must be a power of 2 for modulus using & CACHE_MASK to work*/
5060 # define CACHE_MAX 256
5061 # ifdef CACHE_MAX
5062 # define CACHE_MASK (CACHE_MAX - 1)
5063 # define CACHEIDX(i) ((i) & CACHE_MASK)
5064 # else
5065 # define CACHEIDX(i) (i)
5066 # endif
5067
5068 # define CACHE_ON_STACK
5069 # ifdef CACHE_ON_STACK
5070 typedef R_bcstack_t * R_binding_cache_t;
5071 # define VCACHE(i) GETSTACK_SXPVAL_PTR(vcache + (i))
5072 # define GET_CACHED_BINDING_CELL(vcache, sidx) \
5073 (vcache ? VCACHE(CACHEIDX(sidx)) : R_NilValue)
5074 # define GET_SMALLCACHE_BINDING_CELL(vcache, sidx) VCACHE(sidx)
5075
5076 # define SET_CACHED_BINDING(vcache, sidx, cell) \
5077 do { if (vcache) VCACHE(CACHEIDX(sidx)) = (cell); } while (0)
5078 # else
5079 typedef SEXP R_binding_cache_t;
5080 # define GET_CACHED_BINDING_CELL(vcache, sidx) \
5081 (vcache ? VECTOR_ELT(vcache, CACHEIDX(sidx)) : R_NilValue)
5082 # define GET_SMALLCACHE_BINDING_CELL(vcache, sidx) \
5083 (vcache ? VECTOR_ELT(vcache, sidx) : R_NilValue)
5084
5085 # define SET_CACHED_BINDING(vcache, sidx, cell) \
5086 do { if (vcache) SET_VECTOR_ELT(vcache, CACHEIDX(sidx), cell); } while (0)
5087 # endif
5088 #else
5089 typedef void *R_binding_cache_t;
5090 # define GET_CACHED_BINDING_CELL(vcache, sidx) R_NilValue
5091 # define GET_SMALLCACHE_BINDING_CELL(vcache, sidx) R_NilValue
5092
5093 # define SET_CACHED_BINDING(vcache, sidx, cell)
5094 #endif
5095
GET_BINDING_CELL_CACHE(SEXP symbol,SEXP rho,R_binding_cache_t vcache,int idx)5096 static R_INLINE SEXP GET_BINDING_CELL_CACHE(SEXP symbol, SEXP rho,
5097 R_binding_cache_t vcache, int idx)
5098 {
5099 SEXP cell = GET_CACHED_BINDING_CELL(vcache, idx);
5100 /* The value returned by GET_CACHED_BINDING_CELL is either a
5101 binding cell or R_NilValue. TAG(R_NilValue) is R_NilValue, and
5102 that will not equal symbol. So a separate test for cell !=
5103 R_NilValue is not needed. */
5104 if (TAG(cell) == symbol && ! BNDCELL_UNBOUND(cell))
5105 return cell;
5106 else {
5107 SEXP ncell = GET_BINDING_CELL(symbol, rho);
5108 if (ncell != R_NilValue)
5109 SET_CACHED_BINDING(vcache, idx, ncell);
5110 else if (cell != R_NilValue && BNDCELL_UNBOUND(cell))
5111 SET_CACHED_BINDING(vcache, idx, R_NilValue);
5112 return ncell;
5113 }
5114 }
5115
MISSING_ARGUMENT_ERROR(SEXP symbol)5116 static void NORET MISSING_ARGUMENT_ERROR(SEXP symbol)
5117 {
5118 const char *n = CHAR(PRINTNAME(symbol));
5119 if(*n) error(_("argument \"%s\" is missing, with no default"), n);
5120 else error(_("argument is missing, with no default"));
5121 }
5122
5123 #define MAYBE_MISSING_ARGUMENT_ERROR(symbol, keepmiss) \
5124 do { if (! keepmiss) MISSING_ARGUMENT_ERROR(symbol); } while (0)
5125
UNBOUND_VARIABLE_ERROR(SEXP symbol)5126 static void NORET UNBOUND_VARIABLE_ERROR(SEXP symbol)
5127 {
5128 error(_("object '%s' not found"), EncodeChar(PRINTNAME(symbol)));
5129 }
5130
FORCE_PROMISE(SEXP value,SEXP symbol,SEXP rho,Rboolean keepmiss)5131 static R_INLINE SEXP FORCE_PROMISE(SEXP value, SEXP symbol, SEXP rho,
5132 Rboolean keepmiss)
5133 {
5134 if (PRVALUE(value) == R_UnboundValue) {
5135 /**** R_isMissing is inefficient */
5136 if (keepmiss && R_isMissing(symbol, rho))
5137 value = R_MissingArg;
5138 else value = forcePromise(value);
5139 }
5140 else value = PRVALUE(value);
5141 ENSURE_NAMEDMAX(value);
5142 return value;
5143 }
5144
FIND_VAR_NO_CACHE(SEXP symbol,SEXP rho,SEXP cell)5145 static R_INLINE SEXP FIND_VAR_NO_CACHE(SEXP symbol, SEXP rho, SEXP cell)
5146 {
5147 R_varloc_t loc = R_findVarLoc(symbol, rho);
5148 if (loc.cell && IS_ACTIVE_BINDING(loc.cell)) {
5149 SEXP value = R_GetVarLocValue(loc);
5150 return value;
5151 }
5152 else return R_GetVarLocValue(loc);
5153 }
5154
getvar(SEXP symbol,SEXP rho,Rboolean dd,Rboolean keepmiss,R_binding_cache_t vcache,int sidx)5155 static R_INLINE SEXP getvar(SEXP symbol, SEXP rho,
5156 Rboolean dd, Rboolean keepmiss,
5157 R_binding_cache_t vcache, int sidx)
5158 {
5159 SEXP value;
5160 if (dd)
5161 value = ddfindVar(symbol, rho);
5162 else if (vcache != NULL) {
5163 SEXP cell = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
5164 value = BINDING_VALUE(cell);
5165 if (value == R_UnboundValue)
5166 value = FIND_VAR_NO_CACHE(symbol, rho, cell);
5167 }
5168 else
5169 value = findVar(symbol, rho);
5170
5171 if (value == R_UnboundValue)
5172 UNBOUND_VARIABLE_ERROR(symbol);
5173 else if (value == R_MissingArg)
5174 MAYBE_MISSING_ARGUMENT_ERROR(symbol, keepmiss);
5175 else if (TYPEOF(value) == PROMSXP) {
5176 SEXP pv = PRVALUE(value);
5177 if (pv == R_UnboundValue) {
5178 PROTECT(value);
5179 value = FORCE_PROMISE(value, symbol, rho, keepmiss);
5180 UNPROTECT(1);
5181 }
5182 else {
5183 ENSURE_NAMEDMAX(pv);
5184 value = pv;
5185 }
5186 } else ENSURE_NAMED(value); /* needed for .Last.value - LT */
5187 return value;
5188 }
5189
5190 #define INLINE_GETVAR
5191 #ifdef INLINE_GETVAR
5192 /* Try to handle the most common case as efficiently as possible. If
5193 smallcache is true then a modulus operation on the index is not
5194 needed, nor is a check that a non-null value corresponds to the
5195 requested symbol. The symbol from the constant pool is also usually
5196 not needed. Active bindings will have functions as their values.
5197 Skipping SYMSXP values rules out R_MissingArg and R_UnboundValue as
5198 these are implemented s symbols. It also rules other symbols, but
5199 as those are rare they are handled by the getvar() call. */
5200 #define DO_GETVAR(dd,keepmiss) do { \
5201 int sidx = GETOP(); \
5202 R_Visible = TRUE; \
5203 if (!dd && smallcache) { \
5204 SEXP cell = GET_SMALLCACHE_BINDING_CELL(vcache, sidx); \
5205 /* handle immediate binings */ \
5206 switch (BNDCELL_TAG(cell)) { \
5207 case REALSXP: BCNPUSH_REAL(BNDCELL_DVAL(cell)); NEXT(); \
5208 case INTSXP: BCNPUSH_INTEGER(BNDCELL_IVAL(cell)); NEXT(); \
5209 case LGLSXP: BCNPUSH_LOGICAL(BNDCELL_LVAL(cell)); NEXT(); \
5210 } \
5211 SEXP value = CAR(cell); \
5212 int type = TYPEOF(value); \
5213 /* extract value of forced promises */ \
5214 if (type == PROMSXP) { \
5215 SEXP pv = PRVALUE(value); \
5216 if (pv != R_UnboundValue) { \
5217 value = pv; \
5218 type = TYPEOF(value); \
5219 } \
5220 } \
5221 /* try fast handling of some types; for these the */ \
5222 /* cell won't be R_NilValue or an active binding */ \
5223 switch(type) { \
5224 case REALSXP: \
5225 case INTSXP: \
5226 case LGLSXP: \
5227 case CPLXSXP: \
5228 case STRSXP: \
5229 case VECSXP: \
5230 case RAWSXP: \
5231 BCNPUSH(value); \
5232 NEXT(); \
5233 case SYMSXP: \
5234 case PROMSXP: \
5235 break; \
5236 default: \
5237 if (cell != R_NilValue && ! IS_ACTIVE_BINDING(cell)) { \
5238 BCNPUSH(value); \
5239 NEXT(); \
5240 } \
5241 } \
5242 } \
5243 SEXP symbol = VECTOR_ELT(constants, sidx); \
5244 BCNPUSH(getvar(symbol, rho, dd, keepmiss, vcache, sidx)); \
5245 NEXT(); \
5246 } while (0)
5247 #else
5248 #define DO_GETVAR(dd,keepmiss) do { \
5249 int sidx = GETOP(); \
5250 SEXP symbol = VECTOR_ELT(constants, sidx); \
5251 R_Visible = TRUE; \
5252 BCNPUSH(getvar(symbol, rho, dd, keepmiss, vcache, sidx)); \
5253 NEXT(); \
5254 } while (0)
5255 #endif
5256
5257 /* call frame accessors */
5258 #define CALL_FRAME_FUN() GETSTACK(-3)
5259 #define CALL_FRAME_ARGS() GETSTACK(-2)
5260 #define CALL_FRAME_FTYPE() TYPEOF(CALL_FRAME_FUN())
5261 #define CALL_FRAME_SIZE() (3)
5262
BUILTIN_CALL_FRAME_ARGS()5263 static R_INLINE SEXP BUILTIN_CALL_FRAME_ARGS()
5264 {
5265 SEXP args = CALL_FRAME_ARGS();
5266 for (SEXP a = args; a != R_NilValue; a = CDR(a))
5267 DECREMENT_LINKS(CAR(a));
5268 return args;
5269 }
5270
CLOSURE_CALL_FRAME_ARGS()5271 static R_INLINE SEXP CLOSURE_CALL_FRAME_ARGS()
5272 {
5273 SEXP args = CALL_FRAME_ARGS();
5274 /* it would be better not to build this arglist with CONS_NR in
5275 the first place */
5276 for (SEXP a = args; a != R_NilValue; a = CDR(a)) {
5277 DECREMENT_LINKS(CAR(a));
5278 if (! TRACKREFS(a)) {
5279 ENABLE_REFCNT(a);
5280 INCREMENT_REFCNT(CAR(a));
5281 INCREMENT_REFCNT(CDR(a));
5282 }
5283 }
5284 return args;
5285 }
5286
5287 #define GETSTACK_BELOW_CALL_FRAME(n) GETSTACK((n) - CALL_FRAME_SIZE())
5288 #define SETSTACK_BELOW_CALL_FRAME(n, v) SETSTACK((n) - CALL_FRAME_SIZE(), v)
5289
5290 /* create room for accumulating the arguments. */
5291 #define INIT_CALL_FRAME_ARGS() do { \
5292 BCNSTACKCHECK(2); \
5293 SETSTACK(0, R_NilValue); \
5294 SETSTACK(1, R_NilValue); \
5295 R_BCNodeStackTop += 2; \
5296 } while (0)
5297
5298 /* push the function and create room for accumulating the arguments. */
5299 #define INIT_CALL_FRAME(fun) do { \
5300 BCNPUSH(fun); \
5301 INIT_CALL_FRAME_ARGS(); \
5302 } while (0)
5303
5304 /* remove the call frame from the stack and push the return value */
5305 #define POP_CALL_FRAME(value) POP_CALL_FRAME_PLUS(0, value)
5306
5307 #define POP_CALL_FRAME_PLUS(n, value) do { \
5308 R_BCNodeStackTop -= (2 + (n)); \
5309 SETSTACK(-1, value); \
5310 } while (0)
5311
5312 /* push an argument to existing call frame */
5313 /* a call frame always uses boxed stack values, so GETSTACK will not allocate */
5314 #define PUSHCALLARG(v) do { \
5315 SEXP __cell__ = CONS_NR(v, R_NilValue); \
5316 if (GETSTACK(-2) == R_NilValue) SETSTACK(-2, __cell__); \
5317 else SETCDR(GETSTACK(-1), __cell__); \
5318 SETSTACK(-1, __cell__); \
5319 INCREMENT_LINKS(CAR(__cell__)); \
5320 } while (0)
5321
5322 /* place a tag on the most recently pushed call argument */
5323 #define SETCALLARG_TAG(t) do { \
5324 SEXP __tag__ = (t); \
5325 if (__tag__ != R_NilValue) { \
5326 SEXP __cell__ = GETSTACK(-1); \
5327 if (__cell__ != R_NilValue) \
5328 SET_TAG(__cell__, CreateTag(__tag__)); \
5329 } \
5330 } while (0)
5331
5332 /* same, but tag is known to be a symbol */
5333 #define SETCALLARG_TAG_SYMBOL(t) do { \
5334 SEXP __cell__ = GETSTACK(-1); \
5335 if (__cell__ != R_NilValue) \
5336 SET_TAG(__cell__, t); \
5337 } while (0)
5338
tryDispatch(char * generic,SEXP call,SEXP x,SEXP rho,SEXP * pv)5339 static int tryDispatch(char *generic, SEXP call, SEXP x, SEXP rho, SEXP *pv)
5340 {
5341 RCNTXT cntxt;
5342 SEXP pargs, rho1;
5343 int dispatched = FALSE;
5344 SEXP op = SYMVALUE(install(generic)); /**** avoid this */
5345
5346 PROTECT(pargs = promiseArgs(CDR(call), rho));
5347 SET_PRVALUE(CAR(pargs), x);
5348
5349 /**** Minimal hack to try to handle the S4 case. If we do the check
5350 and do not dispatch then some arguments beyond the first might
5351 have been evaluated; these will then be evaluated again by the
5352 compiled argument code. */
5353 if (IS_S4_OBJECT(x) && R_has_methods(op)) {
5354 SEXP val = R_possible_dispatch(call, op, pargs, rho, TRUE);
5355 if (val) {
5356 *pv = val;
5357 UNPROTECT(1);
5358 return TRUE;
5359 }
5360 }
5361
5362 /* See comment at first usemethod() call in this file. LT */
5363 PROTECT(rho1 = NewEnvironment(R_NilValue, R_NilValue, rho));
5364 begincontext(&cntxt, CTXT_RETURN, call, rho1, rho, pargs, op);
5365 if (usemethod(generic, x, call, pargs, rho1, rho, R_BaseEnv, pv))
5366 dispatched = TRUE;
5367 endcontext(&cntxt);
5368 UNPROTECT(2);
5369 #ifdef ADJUST_ENVIR_REFCNTS
5370 R_CleanupEnvir(rho1, dispatched ? *pv : R_NilValue);
5371 unpromiseArgs(pargs);
5372 #else
5373 if (! dispatched) DECREMENT_REFCNT(x);
5374 #endif
5375 return dispatched;
5376 }
5377
tryAssignDispatch(char * generic,SEXP call,SEXP lhs,SEXP rhs,SEXP rho,SEXP * pv)5378 static int tryAssignDispatch(char *generic, SEXP call, SEXP lhs, SEXP rhs,
5379 SEXP rho, SEXP *pv)
5380 {
5381 int result;
5382 SEXP ncall, last, prom;
5383
5384 PROTECT(ncall = duplicate(call));
5385 last = ncall;
5386 while (CDR(last) != R_NilValue)
5387 last = CDR(last);
5388 prom = mkRHSPROMISE(CAR(last), rhs);
5389 SETCAR(last, prom);
5390 result = tryDispatch(generic, ncall, lhs, rho, pv);
5391 UNPROTECT(1);
5392 return result;
5393 }
5394
5395 #define DO_STARTDISPATCH(generic) do { \
5396 SEXP call = VECTOR_ELT(constants, GETOP()); \
5397 int label = GETOP(); \
5398 SEXP value = GETSTACK(-1); \
5399 if (isObject(value) && tryDispatch(generic, call, value, rho, &value)) {\
5400 SETSTACK(-1, value); \
5401 BC_CHECK_SIGINT(); \
5402 pc = codebase + label; \
5403 } \
5404 else { \
5405 SEXP tag = TAG(CDR(call)); \
5406 BCNPUSH(call); \
5407 INIT_CALL_FRAME(R_NilValue); \
5408 PUSHCALLARG(value); \
5409 SETCALLARG_TAG(tag); \
5410 } \
5411 NEXT(); \
5412 } while (0)
5413
5414 #define DO_DFLTDISPATCH(fun, symbol) do { \
5415 SEXP call = GETSTACK_BELOW_CALL_FRAME(-1); \
5416 SEXP args = BUILTIN_CALL_FRAME_ARGS(); \
5417 SEXP value = fun(call, symbol, args, rho); \
5418 POP_CALL_FRAME_PLUS(2, value); \
5419 R_Visible = TRUE; \
5420 NEXT(); \
5421 } while (0)
5422
5423 #define DO_START_ASSIGN_DISPATCH(generic) do { \
5424 SEXP call = VECTOR_ELT(constants, GETOP()); \
5425 int label = GETOP(); \
5426 SEXP lhs = GETSTACK(-2); \
5427 SEXP rhs = GETSTACK(-1); \
5428 MARK_ASSIGNMENT_CALL(call); \
5429 if (MAYBE_SHARED(lhs)) { \
5430 lhs = shallow_duplicate(lhs); \
5431 SETSTACK(-2, lhs); \
5432 ENSURE_NAMED(lhs); \
5433 } \
5434 SEXP value = NULL; \
5435 if (isObject(lhs) && \
5436 tryAssignDispatch(generic, call, lhs, rhs, rho, &value)) { \
5437 R_BCNodeStackTop--; \
5438 SETSTACK(-1, value); \
5439 BC_CHECK_SIGINT(); \
5440 pc = codebase + label; \
5441 } \
5442 else { \
5443 SEXP tag = TAG(CDR(call)); \
5444 BCNPUSH(call); \
5445 INIT_CALL_FRAME(R_NilValue); \
5446 PUSHCALLARG(lhs); \
5447 SETCALLARG_TAG(tag); \
5448 } \
5449 NEXT(); \
5450 } while (0)
5451
5452 #define DO_DFLT_ASSIGN_DISPATCH(fun, symbol) do { \
5453 SEXP rhs = GETSTACK_BELOW_CALL_FRAME(-2); \
5454 SEXP call = GETSTACK_BELOW_CALL_FRAME(-1); \
5455 SEXP args = BUILTIN_CALL_FRAME_ARGS(); \
5456 MARK_ASSIGNMENT_CALL(call); \
5457 PUSHCALLARG(rhs); \
5458 SEXP value = fun(call, symbol, args, rho); \
5459 POP_CALL_FRAME_PLUS(3, value); \
5460 NEXT(); \
5461 } while (0)
5462
5463 #define DO_STARTDISPATCH_N(generic) do { \
5464 int callidx = GETOP(); \
5465 SEXP value = GETSTACK(-1); \
5466 if (isObject(value)) { \
5467 SEXP call = VECTOR_ELT(constants, callidx); \
5468 if (tryDispatch(generic, call, value, rho, &value)) { \
5469 SETSTACK(-1, value); \
5470 BC_CHECK_SIGINT(); \
5471 int label = GETOP(); \
5472 pc = codebase + label; \
5473 NEXT(); \
5474 } \
5475 } \
5476 SKIP_OP(); \
5477 OLDBC_INCREMENT_LINKS(value); \
5478 NEXT(); \
5479 } while (0)
5480
5481 #define DO_START_ASSIGN_DISPATCH_N(generic) do { \
5482 int callidx = GETOP(); \
5483 int label = GETOP(); \
5484 SEXP lhs = GETSTACK(-2); \
5485 if (isObject(lhs)) { \
5486 SEXP call = VECTOR_ELT(constants, callidx); \
5487 MARK_ASSIGNMENT_CALL(call); \
5488 SEXP rhs = GETSTACK(-1); \
5489 if (MAYBE_SHARED(lhs)) { \
5490 lhs = shallow_duplicate(lhs); \
5491 SETSTACK(-2, lhs); \
5492 ENSURE_NAMED(lhs); \
5493 } \
5494 SEXP value = NULL; \
5495 if (tryAssignDispatch(generic, call, lhs, rhs, rho, &value)) { \
5496 R_BCNodeStackTop--; \
5497 SETSTACK(-1, value); \
5498 BC_CHECK_SIGINT(); \
5499 pc = codebase + label; \
5500 NEXT(); \
5501 } \
5502 } \
5503 OLDBC_INCREMENT_LINKS(lhs); \
5504 NEXT(); \
5505 } while (0)
5506
5507 #define DO_ISTEST(fun) do { \
5508 SETSTACK(-1, fun(GETSTACK(-1)) ? R_TrueValue : R_FalseValue); \
5509 R_Visible = TRUE; \
5510 NEXT(); \
5511 } while(0)
5512 #define DO_ISTYPE(type) do { \
5513 SETSTACK(-1, TYPEOF(GETSTACK(-1)) == type ? R_TrueValue : R_FalseValue); \
5514 R_Visible = TRUE; \
5515 NEXT(); \
5516 } while (0)
5517 #define isNumericOnly(x) (isNumeric(x) && ! isLogical(x))
5518
5519 #ifdef BC_PROFILING
5520 #define NO_CURRENT_OPCODE -1
5521 static int current_opcode = NO_CURRENT_OPCODE;
5522 static int opcode_counts[OPCOUNT];
5523 #endif
5524
bc_check_sigint()5525 static void bc_check_sigint()
5526 {
5527 R_CheckUserInterrupt();
5528 #ifndef IMMEDIATE_FINALIZERS
5529 /* finalizers are run here since this should only be called at
5530 points where running arbitrary code should be safe */
5531 R_RunPendingFinalizers();
5532 #endif
5533 }
5534
5535 #define BC_COUNT_DELTA 1023
5536 #define BC_CHECK_SIGINT() do { \
5537 if (++evalcount > BC_COUNT_DELTA) { \
5538 bc_check_sigint(); \
5539 evalcount = 0; \
5540 } \
5541 } while (0)
5542
5543 /* use loop index for faster check */
5544 #define BC_LOOP_COUNT_MASK 1023
5545 #define BC_CHECK_SIGINT_LOOP(i) do { \
5546 if ((i & BC_LOOP_COUNT_MASK) == 0) { \
5547 bc_check_sigint(); \
5548 evalcount = 0; \
5549 } \
5550 } while (0)
5551
bcStackIndex(R_bcstack_t * s)5552 static R_INLINE R_xlen_t bcStackIndex(R_bcstack_t *s)
5553 {
5554 switch(s->tag) {
5555 case INTSXP:
5556 if (s->u.ival != NA_INTEGER)
5557 return s->u.ival;
5558 else return -1;
5559 case REALSXP:
5560 {
5561 double val = s->u.dval;
5562 if (! ISNAN(val) && val <= R_XLEN_T_MAX && val > 0)
5563 return (R_xlen_t) s->u.dval;
5564 else return -1;
5565 }
5566 case LGLSXP: return -1;
5567 default: break;
5568 }
5569
5570 SEXP idx = GETSTACK_SXPVAL_PTR(s);
5571 if (IS_SCALAR(idx, INTSXP)) {
5572 int ival = SCALAR_IVAL(idx);
5573 if (ival != NA_INTEGER)
5574 return ival;
5575 else return -1;
5576 }
5577 else if (IS_SCALAR(idx, REALSXP)) {
5578 double val = SCALAR_DVAL(idx);
5579 if (! ISNAN(val) && val <= R_XLEN_T_MAX && val > 0)
5580 return (R_xlen_t) val;
5581 else return -1;
5582 }
5583 else return -1;
5584 }
5585
mkVector1(SEXP s)5586 static R_INLINE SEXP mkVector1(SEXP s)
5587 {
5588 SEXP t = allocVector(VECSXP, 1);
5589 SET_VECTOR_ELT(t, 0, s);
5590 return t;
5591 }
5592
5593 #define DO_FAST_VECELT(sv, vec, i, subset2) do { \
5594 switch (TYPEOF(vec)) { \
5595 case REALSXP: \
5596 if (i < 0 || XLENGTH(vec) <= i) break; \
5597 SETSTACK_REAL_PTR(sv, REAL_ELT(vec, i)); \
5598 return; \
5599 case INTSXP: \
5600 if (i < 0 || XLENGTH(vec) <= i) break; \
5601 SETSTACK_INTEGER_PTR(sv, INTEGER_ELT(vec, i)); \
5602 return; \
5603 case LGLSXP: \
5604 if (i < 0 || XLENGTH(vec) <= i) break; \
5605 SETSTACK_LOGICAL_PTR(sv, LOGICAL_ELT(vec, i)); \
5606 return; \
5607 case CPLXSXP: \
5608 if (i < 0 || XLENGTH(vec) <= i) break; \
5609 SETSTACK_PTR(sv, ScalarComplex(COMPLEX_ELT(vec, i))); \
5610 return; \
5611 case RAWSXP: \
5612 if (i < 0 || XLENGTH(vec) <= i) break; \
5613 SETSTACK_PTR(sv, ScalarRaw(RAW(vec)[i])); \
5614 return; \
5615 case VECSXP: \
5616 if (i < 0 || XLENGTH(vec) <= i) break; \
5617 SEXP elt = VECTOR_ELT(vec, i); \
5618 RAISE_NAMED(elt, NAMED(vec)); \
5619 if (subset2) \
5620 SETSTACK_PTR(sv, elt); \
5621 else \
5622 SETSTACK_PTR(sv, mkVector1(elt)); \
5623 return; \
5624 } \
5625 } while (0)
5626
5627 #define FAST_VECELT_OK(vec) \
5628 (ATTRIB(vec) == R_NilValue || \
5629 (TAG(ATTRIB(vec)) == R_DimSymbol && \
5630 CDR(ATTRIB(vec)) == R_NilValue))
5631
VECSUBSET_PTR(SEXP vec,R_bcstack_t * si,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subset2)5632 static R_INLINE void VECSUBSET_PTR(SEXP vec, R_bcstack_t *si,
5633 R_bcstack_t *sv, SEXP rho,
5634 SEXP consts, int callidx,
5635 Rboolean subset2)
5636 {
5637 R_xlen_t i = bcStackIndex(si) - 1;
5638 if ((subset2 || FAST_VECELT_OK(vec)))
5639 DO_FAST_VECELT(sv, vec, i, subset2);
5640
5641 /* fall through to the standard default handler */
5642 SEXP idx, args, value;
5643 idx = GETSTACK_PTR(si);
5644 args = CONS_NR(idx, R_NilValue);
5645 args = CONS_NR(vec, args);
5646 PROTECT(args);
5647 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
5648 if (subset2)
5649 value = do_subset2_dflt(call, R_Subset2Sym, args, rho);
5650 else
5651 value = do_subset_dflt(call, R_SubsetSym, args, rho);
5652 UNPROTECT(1);
5653 SETSTACK_PTR(sv, value);
5654 }
5655
5656 #define DFVE_NEXT() do { \
5657 R_Visible = TRUE; \
5658 R_BCNodeStackTop--; \
5659 NEXT(); \
5660 } while (0)
5661
5662 #define DO_VECSUBSET(rho, sub2) do { \
5663 int callidx = GETOP(); \
5664 R_bcstack_t *sx = R_BCNodeStackTop - 2; \
5665 R_bcstack_t *si = R_BCNodeStackTop - 1; \
5666 OLDBC_DECLNK_STACK_PTR(sx); \
5667 SEXP vec = GETSTACK_PTR(sx); \
5668 if (si->tag == INTSXP && (sub2 || FAST_VECELT_OK(vec))) { \
5669 R_xlen_t i = si->u.ival; \
5670 switch (TYPEOF(vec)) { \
5671 case REALSXP: \
5672 if (i <= 0 || XLENGTH(vec) < i) break; \
5673 SETSTACK_REAL_PTR(sx, REAL_ELT(vec, i - 1)); \
5674 DFVE_NEXT(); \
5675 case INTSXP: \
5676 if (i <= 0 || XLENGTH(vec) < i) break; \
5677 SETSTACK_INTEGER_PTR(sx, INTEGER_ELT(vec, i - 1)); \
5678 DFVE_NEXT(); \
5679 case LGLSXP: \
5680 if (i <= 0 || XLENGTH(vec) < i) break; \
5681 SETSTACK_LOGICAL_PTR(sx, LOGICAL_ELT(vec, i - 1)); \
5682 DFVE_NEXT(); \
5683 } \
5684 } \
5685 VECSUBSET_PTR(vec, si, sx, rho, constants, callidx, sub2); \
5686 DFVE_NEXT(); \
5687 } while(0)
5688
getMatrixDim(SEXP mat)5689 static R_INLINE SEXP getMatrixDim(SEXP mat)
5690 {
5691 SEXP attr = ATTRIB(mat);
5692 /* look for the common case of 'dim' as the only attribute first */
5693 SEXP dim = TAG(attr) == R_DimSymbol ? CAR(attr) :
5694 getAttrib(mat, R_DimSymbol);
5695 if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2)
5696 return dim;
5697 else return R_NilValue;
5698 }
5699
getArrayDim(SEXP mat)5700 static R_INLINE SEXP getArrayDim(SEXP mat)
5701 {
5702 SEXP attr = ATTRIB(mat);
5703 /* look for the common case of 'dim' as the only attribute first */
5704 SEXP dim = TAG(attr) == R_DimSymbol ? CAR(attr) :
5705 getAttrib(mat, R_DimSymbol);
5706 if (TYPEOF(dim) == INTSXP && LENGTH(dim) > 0)
5707 return dim;
5708 else return R_NilValue;
5709 }
5710
colMajorStackIndex(SEXP dim,int rank,R_bcstack_t * si)5711 static R_INLINE R_xlen_t colMajorStackIndex(SEXP dim, int rank, R_bcstack_t *si)
5712 {
5713 if (rank != LENGTH(dim))
5714 return -1;
5715
5716 int *idim = INTEGER(dim);
5717
5718 R_xlen_t mul = idim[0];
5719 R_xlen_t idx = bcStackIndex(si);
5720
5721 if (idx < 1 || idx > idim[0])
5722 return -1;
5723
5724 R_xlen_t k = idx - 1;
5725 for (int i = 1; i < rank; i++) {
5726 idx = bcStackIndex(si + i);
5727 if (idx < 1 || idx > idim[i])
5728 return -1;
5729 k = k + mul * (idx - 1);
5730 mul = mul * idim[i];
5731 }
5732 return k;
5733 }
5734
MATSUBSET_PTR(R_bcstack_t * sx,R_bcstack_t * si,R_bcstack_t * sj,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subset2)5735 static R_INLINE void MATSUBSET_PTR(R_bcstack_t *sx,
5736 R_bcstack_t *si, R_bcstack_t *sj,
5737 R_bcstack_t *sv, SEXP rho,
5738 SEXP consts, int callidx,
5739 Rboolean subset2)
5740 {
5741 SEXP idx, jdx, args, value;
5742 SEXP mat = GETSTACK_PTR(sx);
5743
5744 if (subset2 || FAST_VECELT_OK(mat)) {
5745 SEXP dim = getMatrixDim(mat);
5746 if (dim != R_NilValue) {
5747 R_xlen_t i = bcStackIndex(si);
5748 R_xlen_t j = bcStackIndex(sj);
5749 R_xlen_t nrow = INTEGER(dim)[0];
5750 R_xlen_t ncol = INTEGER(dim)[1];
5751 if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
5752 R_xlen_t k = i - 1 + nrow * (j - 1);
5753 DO_FAST_VECELT(sv, mat, k, subset2);
5754 }
5755 }
5756 }
5757
5758 /* fall through to the standard default handler */
5759 idx = GETSTACK_PTR(si);
5760 jdx = GETSTACK_PTR(sj);
5761 args = CONS_NR(jdx, R_NilValue);
5762 args = CONS_NR(idx, args);
5763 args = CONS_NR(mat, args);
5764 PROTECT(args);
5765 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
5766 if (subset2)
5767 value = do_subset2_dflt(call, R_Subset2Sym, args, rho);
5768 else
5769 value = do_subset_dflt(call, R_SubsetSym, args, rho);
5770 UNPROTECT(1);
5771 SETSTACK_PTR(sv, value);
5772 }
5773
5774 #define DO_MATSUBSET(rho, sub2) do { \
5775 int callidx = GETOP(); \
5776 R_bcstack_t *sx = R_BCNodeStackTop - 3; \
5777 OLDBC_DECLNK_STACK_PTR(sx); \
5778 MATSUBSET_PTR(sx, R_BCNodeStackTop - 2, R_BCNodeStackTop - 1, \
5779 sx, rho, constants, callidx, sub2); \
5780 R_BCNodeStackTop -= 2; \
5781 R_Visible = TRUE; \
5782 } while (0)
5783
addStackArgsList(int n,R_bcstack_t * start,SEXP val)5784 static R_INLINE SEXP addStackArgsList(int n, R_bcstack_t *start, SEXP val)
5785 {
5786 R_bcstack_t *p = start + n - 1;
5787 BCNPUSH(val); /* to protect */
5788 for (int i = 0; i < n; i++, p--) {
5789 val = CONS_NR(GETSTACK_PTR(p), val);
5790 SETSTACK(-1, val); /* to protect */
5791 }
5792 BCNPOP_IGNORE_VALUE();
5793 return val;
5794 }
5795
getStackArgsList(int n,R_bcstack_t * start)5796 static R_INLINE SEXP getStackArgsList(int n, R_bcstack_t *start)
5797 {
5798 return addStackArgsList(n, start, R_NilValue);
5799 }
5800
SUBSET_N_PTR(R_bcstack_t * sx,int rank,R_bcstack_t * si,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subset2)5801 static R_INLINE void SUBSET_N_PTR(R_bcstack_t *sx, int rank,
5802 R_bcstack_t *si, R_bcstack_t *sv,
5803 SEXP rho, SEXP consts, int callidx,
5804 Rboolean subset2)
5805 {
5806 SEXP args, value;
5807 SEXP x = GETSTACK_PTR(sx);
5808
5809 if (subset2 || FAST_VECELT_OK(x)) {
5810 SEXP dim = getArrayDim(x);
5811 if (dim != R_NilValue) {
5812 R_xlen_t k = colMajorStackIndex(dim, rank, si);
5813 if (k >= 0)
5814 DO_FAST_VECELT(sv, x, k, subset2);
5815 }
5816 }
5817
5818 /* fall through to the standard default handler */
5819 PROTECT(args = CONS_NR(x, getStackArgsList(rank, si)));
5820 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
5821 if (subset2)
5822 value = do_subset2_dflt(call, R_Subset2Sym, args, rho);
5823 else
5824 value = do_subset_dflt(call, R_SubsetSym, args, rho);
5825 UNPROTECT(1);
5826 SETSTACK_PTR(sv, value);
5827 }
5828
5829 #define DO_SUBSET_N(rho, sub2) do { \
5830 int callidx = GETOP(); \
5831 int rank = GETOP(); \
5832 R_bcstack_t *sx = R_BCNodeStackTop - rank - 1; \
5833 OLDBC_DECLNK_STACK_PTR(sx); \
5834 SUBSET_N_PTR(sx, rank, R_BCNodeStackTop - rank, sx, rho, \
5835 constants, callidx, sub2); \
5836 R_BCNodeStackTop -= rank; \
5837 R_Visible = TRUE; \
5838 } while (0)
5839
setElementFromScalar(SEXP vec,R_xlen_t i,R_bcstack_t * srhs)5840 static R_INLINE Rboolean setElementFromScalar(SEXP vec, R_xlen_t i,
5841 R_bcstack_t *srhs)
5842 {
5843 if (i < 0) return FALSE;
5844
5845 R_bcstack_t vv;
5846 R_bcstack_t *v = bcStackScalar(srhs, &vv);
5847
5848 if (TYPEOF(vec) == REALSXP) {
5849 if (XLENGTH(vec) <= i) return FALSE;
5850 switch(v->tag) {
5851 case REALSXP: REAL(vec)[i] = v->u.dval; return TRUE;
5852 case INTSXP: REAL(vec)[i] = INTEGER_TO_REAL(v->u.ival); return TRUE;
5853 case LGLSXP: REAL(vec)[i] = LOGICAL_TO_REAL(v->u.ival); return TRUE;
5854 }
5855 }
5856 else if (v->tag == TYPEOF(vec)) {
5857 switch(v->tag) {
5858 case INTSXP:
5859 if (XLENGTH(vec) <= i) return FALSE;
5860 INTEGER(vec)[i] = v->u.ival;
5861 return TRUE;
5862 case LGLSXP:
5863 if (XLENGTH(vec) <= i) return FALSE;
5864 LOGICAL(vec)[i] = INTEGER_TO_LOGICAL(v->u.ival);
5865 return TRUE;
5866 }
5867 }
5868 return FALSE;
5869 }
5870
5871 #define DO_FAST_SETVECELT(sv, srhs, vec, i, subset2) do { \
5872 if (setElementFromScalar(vec, i, srhs)) { \
5873 SETSTACK_PTR(sv, vec); \
5874 SETTER_CLEAR_NAMED(vec); \
5875 return; \
5876 } \
5877 else if (subassign2 && TYPEOF(vec) == VECSXP && \
5878 i < XLENGTH(vec)) { \
5879 SEXP rhs = GETSTACK_PTR(srhs); \
5880 if (rhs != R_NilValue) { \
5881 if (MAYBE_REFERENCED(rhs) && VECTOR_ELT(vec, i) != rhs) \
5882 rhs = R_FixupRHS(vec, rhs); \
5883 SET_VECTOR_ELT(vec, i, rhs); \
5884 SETTER_CLEAR_NAMED(vec); \
5885 SETSTACK_PTR(sv, vec); \
5886 return; \
5887 } \
5888 } \
5889 } while (0)
5890
VECSUBASSIGN_PTR(SEXP vec,R_bcstack_t * srhs,R_bcstack_t * si,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subassign2)5891 static R_INLINE void VECSUBASSIGN_PTR(SEXP vec, R_bcstack_t *srhs,
5892 R_bcstack_t *si, R_bcstack_t *sv,
5893 SEXP rho, SEXP consts, int callidx,
5894 Rboolean subassign2)
5895 {
5896 SEXP idx, args, value;
5897
5898 R_xlen_t i = bcStackIndex(si) - 1;
5899 if (i >= 0)
5900 DO_FAST_SETVECELT(sv, srhs, vec, i, subset2);
5901
5902 /* fall through to the standard default handler */
5903 value = GETSTACK_PTR(srhs);
5904 idx = GETSTACK_PTR(si);
5905 args = CONS_NR(value, R_NilValue);
5906 SET_TAG(args, R_valueSym);
5907 args = CONS_NR(idx, args);
5908 args = CONS_NR(vec, args);
5909 PROTECT(args);
5910 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
5911 MARK_ASSIGNMENT_CALL(call);
5912 if (subassign2)
5913 vec = do_subassign2_dflt(call, R_Subassign2Sym, args, rho);
5914 else
5915 vec = do_subassign_dflt(call, R_SubassignSym, args, rho);
5916 UNPROTECT(1);
5917 SETSTACK_PTR(sv, vec);
5918 }
5919
5920 #define DFVA_NEXT(sx, vec) do { \
5921 SETSTACK_PTR(sx, vec); \
5922 SETTER_CLEAR_NAMED(vec); \
5923 R_BCNodeStackTop -= 2; \
5924 NEXT(); \
5925 } while (0)
5926
5927 #define DO_VECSUBASSIGN(rho, sub2) do { \
5928 int callidx = GETOP(); \
5929 R_bcstack_t *sx = R_BCNodeStackTop - 3; \
5930 R_bcstack_t *srhs = R_BCNodeStackTop - 2; \
5931 R_bcstack_t *si = R_BCNodeStackTop - 1; \
5932 OLDBC_DECLNK_STACK_PTR(sx); \
5933 SEXP vec = GETSTACK_PTR(sx); \
5934 if (MAYBE_SHARED(vec)) { \
5935 vec = shallow_duplicate(vec); \
5936 SETSTACK_PTR(sx, vec); \
5937 } \
5938 if (srhs->tag && si->tag == INTSXP && \
5939 srhs->tag == TYPEOF(vec)) { \
5940 R_xlen_t i = si->u.ival; \
5941 /* i >= 0 rules out NA_INTEGER */ \
5942 if (i > 0 && i <= XLENGTH(vec)) { \
5943 switch (TYPEOF(vec)) { \
5944 case REALSXP: \
5945 REAL(vec)[i - 1] = srhs->u.dval; \
5946 DFVA_NEXT(sx, vec); \
5947 case INTSXP: \
5948 INTEGER(vec)[i - 1] = srhs->u.ival; \
5949 DFVA_NEXT(sx, vec); \
5950 case LGLSXP: \
5951 LOGICAL(vec)[i - 1] = srhs->u.ival; \
5952 DFVA_NEXT(sx, vec); \
5953 } \
5954 } \
5955 } \
5956 VECSUBASSIGN_PTR(vec, srhs, si, sx, rho, constants, callidx, sub2); \
5957 R_BCNodeStackTop -= 2; \
5958 NEXT(); \
5959 } while (0)
5960
MATSUBASSIGN_PTR(R_bcstack_t * sx,R_bcstack_t * srhs,R_bcstack_t * si,R_bcstack_t * sj,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subassign2)5961 static R_INLINE void MATSUBASSIGN_PTR(R_bcstack_t *sx, R_bcstack_t *srhs,
5962 R_bcstack_t *si, R_bcstack_t *sj,
5963 R_bcstack_t *sv,
5964 SEXP rho, SEXP consts, int callidx,
5965 Rboolean subassign2)
5966 {
5967 SEXP dim, idx, jdx, args, value;
5968 SEXP mat = GETSTACK_PTR(sx);
5969
5970 if (MAYBE_SHARED(mat)) {
5971 mat = shallow_duplicate(mat);
5972 SETSTACK_PTR(sx, mat);
5973 }
5974
5975 dim = getMatrixDim(mat);
5976
5977 if (dim != R_NilValue) {
5978 R_xlen_t i = bcStackIndex(si);
5979 R_xlen_t j = bcStackIndex(sj);
5980 R_xlen_t nrow = INTEGER(dim)[0];
5981 R_xlen_t ncol = INTEGER(dim)[1];
5982 if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
5983 R_xlen_t k = i - 1 + nrow * (j - 1);
5984 DO_FAST_SETVECELT(sv, srhs, mat, k, subset2);
5985 }
5986 }
5987
5988 /* fall through to the standard default handler */
5989 value = GETSTACK_PTR(srhs);
5990 idx = GETSTACK_PTR(si);
5991 jdx = GETSTACK_PTR(sj);
5992 args = CONS_NR(value, R_NilValue);
5993 SET_TAG(args, R_valueSym);
5994 args = CONS_NR(jdx, args);
5995 args = CONS_NR(idx, args);
5996 args = CONS_NR(mat, args);
5997 PROTECT(args);
5998 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
5999 MARK_ASSIGNMENT_CALL(call);
6000 if (subassign2)
6001 mat = do_subassign2_dflt(call, R_Subassign2Sym, args, rho);
6002 else
6003 mat = do_subassign_dflt(call, R_SubassignSym, args, rho);
6004 UNPROTECT(1);
6005 SETSTACK_PTR(sv, mat);
6006 }
6007
6008 #define DO_MATSUBASSIGN(rho, sub2) do { \
6009 int callidx = GETOP(); \
6010 R_bcstack_t *sx = R_BCNodeStackTop - 4; \
6011 OLDBC_DECLNK_STACK_PTR(sx); \
6012 MATSUBASSIGN_PTR(sx, R_BCNodeStackTop - 3, \
6013 R_BCNodeStackTop - 2, R_BCNodeStackTop - 1, \
6014 sx, rho, constants, callidx, sub2); \
6015 R_BCNodeStackTop -= 3; \
6016 } while (0)
6017
SUBASSIGN_N_PTR(R_bcstack_t * sx,int rank,R_bcstack_t * srhs,R_bcstack_t * si,R_bcstack_t * sv,SEXP rho,SEXP consts,int callidx,Rboolean subassign2)6018 static R_INLINE void SUBASSIGN_N_PTR(R_bcstack_t *sx, int rank,
6019 R_bcstack_t *srhs,
6020 R_bcstack_t *si, R_bcstack_t *sv,
6021 SEXP rho, SEXP consts, int callidx,
6022 Rboolean subassign2)
6023 {
6024 SEXP dim, args, value;
6025 SEXP x = GETSTACK_PTR(sx);
6026
6027 if (MAYBE_SHARED(x)) {
6028 x = shallow_duplicate(x);
6029 SETSTACK_PTR(sx, x);
6030 }
6031
6032 dim = getArrayDim(x);
6033
6034 if (dim != R_NilValue) {
6035 R_xlen_t k = colMajorStackIndex(dim, rank, si);
6036 if (k >= 0)
6037 DO_FAST_SETVECELT(sv, srhs, x, k, subset2);
6038 }
6039
6040 /* fall through to the standard default handler */
6041 value = GETSTACK_PTR(srhs);
6042 args = CONS_NR(value, R_NilValue);
6043 SET_TAG(args, R_valueSym);
6044 PROTECT(args = CONS_NR(x, addStackArgsList(rank, si, args)));
6045 SEXP call = callidx < 0 ? consts : VECTOR_ELT(consts, callidx);
6046 MARK_ASSIGNMENT_CALL(call);
6047 if (subassign2)
6048 x = do_subassign2_dflt(call, R_Subassign2Sym, args, rho);
6049 else
6050 x = do_subassign_dflt(call, R_SubassignSym, args, rho);
6051 UNPROTECT(1);
6052 SETSTACK_PTR(sv, x);
6053 }
6054
6055 #define DO_SUBASSIGN_N(rho, sub2) do { \
6056 int callidx = GETOP(); \
6057 int rank = GETOP(); \
6058 R_bcstack_t *sx = R_BCNodeStackTop - rank - 2; \
6059 OLDBC_DECLNK_STACK_PTR(sx); \
6060 SUBASSIGN_N_PTR(sx, rank, R_BCNodeStackTop - rank - 1, \
6061 R_BCNodeStackTop - rank, sx, rho, \
6062 constants, callidx, sub2); \
6063 R_BCNodeStackTop -= rank + 1; \
6064 } while (0)
6065
6066 /* rho is only needed for _R_CHECK_LENGTH_1_LOGIC2_ */
6067 #define FIXUP_SCALAR_LOGICAL(rho, callidx, arg, op, warn_level) do { \
6068 if (R_BCNodeStackTop[-1].tag == LGLSXP) break; \
6069 SEXP val = GETSTACK(-1); \
6070 if (IS_SIMPLE_SCALAR(val, LGLSXP)) \
6071 SETSTACK(-1, ScalarLogical(SCALAR_LVAL(val))); \
6072 else { \
6073 if (!isNumber(val)) \
6074 errorcall(VECTOR_ELT(constants, callidx), \
6075 _("invalid %s type in 'x %s y'"), arg, op); \
6076 SETSTACK(-1, ScalarLogical(asLogical2( \
6077 val, /*checking*/ 1, \
6078 VECTOR_ELT(constants, callidx), \
6079 rho))); \
6080 } \
6081 } while(0)
6082
signalMissingArgError(SEXP args,SEXP call)6083 static void signalMissingArgError(SEXP args, SEXP call)
6084 {
6085 SEXP a, c;
6086 int n, k;
6087 for (a = args, n = 1; a != R_NilValue; a = CDR(a), n++)
6088 if (CAR(a) == R_MissingArg) {
6089 /* check for an empty argument in the call -- start from
6090 the beginning in case of ... arguments */
6091 if (call != R_NilValue) {
6092 for (k = 1, c = CDR(call); c != R_NilValue; c = CDR(c), k++)
6093 if (CAR(c) == R_MissingArg)
6094 errorcall(call, "argument %d is empty", k);
6095 }
6096 /* An error from evaluating a symbol will already have
6097 been signaled. The interpreter, in evalList, does
6098 _not_ signal an error for a call expression that
6099 produces an R_MissingArg value; for example
6100
6101 c(alist(a=)$a)
6102
6103 does not signal an error. If we decide we do want an
6104 error in this case we can modify evalList for the
6105 interpreter and here use the code below. */
6106 #ifdef NO_COMPUTED_MISSINGS
6107 /* otherwise signal a 'missing argument' error */
6108 errorcall(call, "argument %d is missing", n);
6109 #endif
6110 }
6111 }
6112
checkForMissings(SEXP args,SEXP call)6113 static R_INLINE void checkForMissings(SEXP args, SEXP call)
6114 {
6115 Rboolean found = FALSE;
6116 for (SEXP a = args; a != R_NilValue; a = CDR(a))
6117 if (CAR(a) == R_MissingArg) {
6118 found = TRUE;
6119 break;
6120 }
6121 if (found)
6122 signalMissingArgError(args, call);
6123 }
6124
6125 typedef struct {
6126 R_xlen_t idx, len;
6127 int type;
6128 /* Include the symbol in the loopinfo structure in case the
6129 binding cell is R_NilValue, e.g. for an active binding. Even if
6130 we eventually allow symbols to be garbage collected, the loop
6131 symbol is GC protected during the loop evaluation by its
6132 reference from the current byte code object. */
6133 SEXP symbol;
6134 } R_loopinfo_t;
6135
6136 #define FOR_LOOP_STATE_SIZE 5
6137 #define GET_FOR_LOOP_INFO() ((R_loopinfo_t *) RAW0(GETSTACK_SXPVAL(-2)))
6138 #define GET_FOR_LOOP_BINDING() GETSTACK_SXPVAL(-3)
6139 #define GET_FOR_LOOP_SEQ() GETSTACK_SXPVAL(-4)
6140 #define SET_FOR_LOOP_SEQ(v) SETSTACK(-4, v);
6141 #define SET_FOR_LOOP_BCPROT_OFFSET(v) SETSTACK_INTEGER(-5, v)
6142 #define GET_FOR_LOOP_BCPROT_OFFSET() GETSTACK_IVAL_PTR(R_BCNodeStackTop - 5)
6143 #define INSERT_FOR_LOOP_BCPROT_OFFSET() do { \
6144 /* insert space for the BCProt offset below the sequence */ \
6145 if (R_BCNodeStackTop >= R_BCNodeStackEnd) \
6146 nodeStackOverflow(); \
6147 R_BCNodeStackTop[0] = R_BCNodeStackTop[-1]; \
6148 SETSTACK_INTEGER(-1, 0); \
6149 R_BCNodeStackTop++; \
6150 } while (0)
6151
6152 #define GET_VEC_LOOP_VALUE(var) do { \
6153 (var) = GETSTACK_SXPVAL(-1); \
6154 if (BNDCELL_TAG(cell) || \
6155 (var) != CAR(cell) || MAYBE_SHARED(var) || \
6156 ATTRIB(var) != R_NilValue) { \
6157 (var) = allocVector(TYPEOF(seq), 1); \
6158 SETSTACK_NLNK(-1, var); \
6159 INCREMENT_NAMED(var); \
6160 } \
6161 } while (0)
6162
6163 /* This uses use loopinfo->symbol in case cell is R_NilValue, e.g. for
6164 an active binding. */
6165 #define SET_FOR_LOOP_VAR(value, cell, loopinfo, rho) do { \
6166 if (BNDCELL_UNBOUND(cell) || \
6167 ! SET_BINDING_VALUE(cell, value)) \
6168 defineVar(loopinfo->symbol, value, rho); \
6169 } while (0)
6170
6171 /* Loops that cannot have their SETJMPs optimized out are bracketed by
6172 STARTLOOPCNTXT and ENLOOPCNTXT instructions. The STARTLOOPCNTXT
6173 instruction stores the target offset for a 'break' and then the
6174 target offset for a 'next' on the stack. For a 'for' loop the loop
6175 state information is then pushed on the stack as well. The
6176 following functions retrieve the offsets. */
6177
LOOP_BREAK_OFFSET(int loop_state_size)6178 static R_INLINE int LOOP_BREAK_OFFSET(int loop_state_size)
6179 {
6180 return GETSTACK_IVAL_PTR(R_BCNodeStackTop - 2 - loop_state_size);
6181 }
6182
LOOP_NEXT_OFFSET(int loop_state_size)6183 static R_INLINE int LOOP_NEXT_OFFSET(int loop_state_size)
6184 {
6185 return GETSTACK_IVAL_PTR(R_BCNodeStackTop - 1 - loop_state_size);
6186 }
6187
6188 /* Check whether a call is to a base function; if not use AST interpeter */
6189 /***** need a faster guard check */
SymbolValue(SEXP sym)6190 static R_INLINE SEXP SymbolValue(SEXP sym)
6191 {
6192 if (IS_ACTIVE_BINDING(sym))
6193 return eval(sym, R_BaseEnv);
6194 else {
6195 SEXP value = SYMVALUE(sym);
6196 if (TYPEOF(value) == PROMSXP) {
6197 value = PRVALUE(value);
6198 if (value == R_UnboundValue)
6199 value = eval(sym, R_BaseEnv);
6200 }
6201 return value;
6202 }
6203 }
6204
6205 #define DO_BASEGUARD() do { \
6206 SEXP expr = VECTOR_ELT(constants, GETOP()); \
6207 int label = GETOP(); \
6208 SEXP sym = CAR(expr); \
6209 if (findFun(sym, rho) != SymbolValue(sym)) { \
6210 BCNPUSH(eval(expr, rho)); \
6211 pc = codebase + label; \
6212 } \
6213 } while (0)
6214
6215 /* The CALLBUILTIN instruction handles calls to both true BUILTINs and
6216 to .Internals of type BUILTIN. To handle profiling in a way that is
6217 consistent with this instruction needs to be able to distinguish a
6218 true BUILTIN from a .Internal. LT */
6219 #define IS_TRUE_BUILTIN(x) ((R_FunTab[PRIMOFFSET(x)].eval % 100 )/10 == 0)
6220
6221 /* rho only needed for _R_CHECK_LENGTH_1_CONDITION_=package:name */
GETSTACK_LOGICAL_NO_NA_PTR(R_bcstack_t * s,int callidx,SEXP constants,SEXP rho)6222 static R_INLINE Rboolean GETSTACK_LOGICAL_NO_NA_PTR(R_bcstack_t *s, int callidx,
6223 SEXP constants, SEXP rho)
6224 {
6225 if (s->tag == LGLSXP && s->u.ival != NA_LOGICAL)
6226 return s->u.ival;
6227
6228 SEXP value = GETSTACK_PTR(s);
6229 if (IS_SCALAR(value, LGLSXP)) {
6230 Rboolean lval = SCALAR_LVAL(value);
6231 if (lval != NA_LOGICAL)
6232 return lval;
6233 }
6234 SEXP call = VECTOR_ELT(constants, callidx);
6235 PROTECT(value);
6236 Rboolean ans = asLogicalNoNA(value, call, rho);
6237 UNPROTECT(1);
6238 return ans;
6239 }
6240
6241 #define GETSTACK_LOGICAL(n) GETSTACK_LOGICAL_PTR(R_BCNodeStackTop + (n))
GETSTACK_LOGICAL_PTR(R_bcstack_t * s)6242 static R_INLINE Rboolean GETSTACK_LOGICAL_PTR(R_bcstack_t *s)
6243 {
6244 if (s->tag == LGLSXP) return s->u.ival;
6245 SEXP value = GETSTACK_PTR(s);
6246 return SCALAR_LVAL(value);
6247 }
6248
6249 /* Find locations table in the constant pool */
findLocTable(SEXP constants,const char * tclass)6250 static SEXP findLocTable(SEXP constants, const char *tclass)
6251 {
6252 int i;
6253 /* location tables are at the end of the constant pool */
6254 for(i = LENGTH(constants) - 1; i >= 0 ; i--) {
6255 SEXP s = VECTOR_ELT(constants, i);
6256 /* could use exact check instead of inherits */
6257 if (TYPEOF(s) == INTSXP && inherits(s, tclass))
6258 return s;
6259 }
6260 return R_NilValue;
6261 }
6262
6263 /* Get a constant pool entry through locations table element */
getLocTableElt(ptrdiff_t relpc,SEXP table,SEXP constants)6264 static SEXP getLocTableElt(ptrdiff_t relpc, SEXP table, SEXP constants)
6265 {
6266 if (table == R_NilValue || relpc >= LENGTH(table) || relpc < 0)
6267 return R_NilValue;
6268
6269 int cidx = INTEGER(table)[relpc];
6270 if (cidx < 0 || cidx >= LENGTH(constants))
6271 return R_NilValue;
6272 return VECTOR_ELT(constants, cidx);
6273 }
6274
6275 /* Return the srcref/expression for the current instruction/operand
6276 being executed by the byte-code interpreter, or the one that was
6277 current when the supplied context was created. */
R_findBCInterpreterLocation(RCNTXT * cptr,const char * iname)6278 static SEXP R_findBCInterpreterLocation(RCNTXT *cptr, const char *iname)
6279 {
6280 SEXP body = cptr ? cptr->bcbody : R_BCbody;
6281 if (body == NULL)
6282 /* This has happened, but it is not clear how. */
6283 /* (R_Srcref == R_InBCInterpreter && R_BCbody == NULL) */
6284 return R_NilValue;
6285 SEXP constants = BCCONSTS(body);
6286 SEXP ltable = findLocTable(constants, iname);
6287 if (ltable == R_NilValue)
6288 /* location table not available */
6289 return R_NilValue;
6290
6291 BCODE *codebase = BCCODE(body);
6292 ptrdiff_t relpc = (*((BCODE **)(cptr ? cptr->bcpc : R_BCpc))) - codebase;
6293
6294 return getLocTableElt(relpc, ltable, constants);
6295 }
6296
R_findBCInterpreterSrcref(RCNTXT * cptr)6297 SEXP attribute_hidden R_findBCInterpreterSrcref(RCNTXT *cptr)
6298 {
6299 return R_findBCInterpreterLocation(cptr, "srcrefsIndex");
6300 }
6301
R_findBCInterpreterExpression()6302 static SEXP R_findBCInterpreterExpression()
6303 {
6304 return R_findBCInterpreterLocation(NULL, "expressionsIndex");
6305 }
6306
R_getCurrentSrcref()6307 SEXP attribute_hidden R_getCurrentSrcref()
6308 {
6309 if (R_Srcref != R_InBCInterpreter)
6310 return R_Srcref;
6311 else
6312 return R_findBCInterpreterSrcref(NULL);
6313 }
6314
maybeClosureWrapper(SEXP expr)6315 static Rboolean maybeClosureWrapper(SEXP expr)
6316 {
6317 if (TYPEOF(expr) != LANGSXP)
6318 return FALSE;
6319
6320 SEXP sym = CAR(expr);
6321
6322 if (!(sym == R_DotInternalSym || sym == R_DotExternalSym ||
6323 sym == R_DotExternal2Sym || sym == R_DotExternalgraphicsSym ||
6324 sym == R_DotCallSym || sym == R_DotFortranSym ||
6325 sym == R_DotCSym || sym == R_DotCallgraphicsSym))
6326
6327 return FALSE;
6328
6329 return CDR(expr) != R_NilValue && CADR(expr) != R_NilValue;
6330 }
6331
maybeAssignmentCall(SEXP expr)6332 static Rboolean maybeAssignmentCall(SEXP expr)
6333 {
6334 if (TYPEOF(expr) != LANGSXP)
6335 return FALSE;
6336
6337 if (TYPEOF(CAR(expr)) != SYMSXP)
6338 return FALSE;
6339 const char *name = CHAR(PRINTNAME(CAR(expr)));
6340 size_t slen = strlen(name);
6341 return slen > 2 && name[slen-2] == '<' && name[slen-1] == '-';
6342 }
6343
6344 /* Check if the given expression is a call to a name that is also
6345 a builtin or special (does not search the environment!). */
maybePrimitiveCall(SEXP expr)6346 static Rboolean maybePrimitiveCall(SEXP expr)
6347 {
6348 if (TYPEOF(expr) != LANGSXP)
6349 return FALSE;
6350
6351 if (TYPEOF(CAR(expr)) == SYMSXP) {
6352 SEXP value = SYMVALUE(CAR(expr));
6353 if (TYPEOF(value) == PROMSXP)
6354 value = PRVALUE(value);
6355 return TYPEOF(value) == BUILTINSXP || TYPEOF(value) == SPECIALSXP;
6356 }
6357 return FALSE;
6358 }
6359
6360 /* Inflate a (single-level) compiler-flattenned assignment call.
6361 For example,
6362 `[<-`(x, c(-1, 1), value = 2)
6363 becomes
6364 x[c(-1,1)] <- 2 */
inflateAssignmentCall(SEXP expr)6365 static SEXP inflateAssignmentCall(SEXP expr) {
6366 if (CDR(expr) == R_NilValue || CDDR(expr) == R_NilValue)
6367 return expr; /* need at least two arguments */
6368
6369 SEXP assignForm = CAR(expr);
6370 if (TYPEOF(assignForm) != SYMSXP)
6371 return expr;
6372 const char *name = CHAR(PRINTNAME(assignForm));
6373 size_t slen = strlen(name);
6374 if (slen <= 2 || name[slen - 2] != '<' || name[slen - 1] != '-')
6375 return expr;
6376
6377 /* not using strncpy as that produces warnings with gcc about bound
6378 depending on the length of the source argument */
6379 char nonAssignName[slen+1]; /* "names" for "names<-" */
6380 strcpy(nonAssignName, name);
6381 nonAssignName[slen - 2] = '\0';
6382 SEXP nonAssignForm = install(nonAssignName);
6383
6384 int nargs = length(expr) - 2;
6385 SEXP lhs = allocVector(LANGSXP, nargs + 1);
6386 SETCAR(lhs, nonAssignForm);
6387
6388 SEXP porig = CDR(expr);
6389 SEXP pnew = CDR(lhs);
6390
6391 /* copy args except the last - the "value" */
6392 while(CDR(porig) != R_NilValue) {
6393 SETCAR(pnew, CAR(porig));
6394 ENSURE_NAMEDMAX(CAR(porig));
6395 porig = CDR(porig);
6396 pnew = CDR(pnew);
6397 }
6398 SEXP rhs = CAR(porig);
6399 ENSURE_NAMEDMAX(rhs);
6400 if (TAG(porig) != R_valueSym)
6401 return expr;
6402 return lang3(R_AssignSym, lhs, rhs);
6403 }
6404
6405 /* Get the current expression being evaluated by the byte-code interpreter. */
R_getBCInterpreterExpression()6406 SEXP attribute_hidden R_getBCInterpreterExpression()
6407 {
6408 SEXP exp = R_findBCInterpreterExpression();
6409 if (TYPEOF(exp) == PROMSXP) {
6410 exp = forcePromise(exp);
6411 ENSURE_NAMEDMAX(exp);
6412 }
6413
6414 /* This tries to mimick the behavior of the AST interpreter to a
6415 reasonable level, based on relatively consistent expressions
6416 provided by the compiler in the constant pool. The AST
6417 interpreter behavior is rather inconsistent and should be fixed
6418 at some point. When this happens, the code below will have to
6419 be revisited, but the compiler code should mostly stay the
6420 same.
6421
6422 Currently this code attempts to bypass implementation of
6423 closure wrappers for internals and other foreign functions
6424 called via a directive, hide away primitives, but show
6425 assignment calls. This code ignores less usual problematic
6426 situations such as overriding of builtins or inlining of the
6427 wrappers by the compiler. Simple assignment calls are inflated
6428 (back) into the usual form like x[1] <- y. Expressions made of
6429 a single symbol are hidden away (note these are e.g. for
6430 missing function arguments). */
6431
6432 if (maybeAssignmentCall(exp)) {
6433 exp = inflateAssignmentCall(exp);
6434 } else if (TYPEOF(exp) == SYMSXP || maybeClosureWrapper(exp)
6435 || maybePrimitiveCall(exp)) {
6436
6437 RCNTXT *c = R_GlobalContext;
6438 while(c && c->callflag != CTXT_TOPLEVEL) {
6439 if (c->callflag & CTXT_FUNCTION) {
6440 exp = c->call;
6441 break;
6442 }
6443 c = c->nextcontext;
6444 }
6445 }
6446 return exp;
6447 }
6448
markSpecialArgs(SEXP args)6449 static SEXP markSpecialArgs(SEXP args)
6450 {
6451 SEXP arg;
6452 for(arg = args; arg != R_NilValue; arg = CDR(arg))
6453 MARK_NOT_MUTABLE(CAR(arg));
6454 return args;
6455 }
6456
R_BCVersionOK(SEXP s)6457 Rboolean attribute_hidden R_BCVersionOK(SEXP s)
6458 {
6459 if (TYPEOF(s) != BCODESXP)
6460 return FALSE;
6461
6462 BCODE *pc = BCCODE(s);
6463 int version = GETOP();
6464
6465 /* must be kept in sync with bcEval version check */
6466 return version < 2 ||
6467 (version >= R_bcMinVersion && version <= R_bcVersion);
6468 }
6469
bcEval(SEXP body,SEXP rho,Rboolean useCache)6470 static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
6471 {
6472 SEXP retvalue = R_NilValue, constants;
6473 BCODE *pc, *codebase;
6474 R_bcstack_t *oldntop = R_BCNodeStackTop;
6475 static int evalcount = 0;
6476 SEXP oldsrcref = R_Srcref;
6477 int oldbcintactive = R_BCIntActive;
6478 SEXP oldbcbody = R_BCbody;
6479 void *oldbcpc = R_BCpc;
6480 BCODE *currentpc = NULL;
6481
6482 #ifdef BC_PROFILING
6483 int old_current_opcode = current_opcode;
6484 #endif
6485 #ifdef THREADED_CODE
6486 int which = 0;
6487 #endif
6488
6489 BC_CHECK_SIGINT();
6490
6491 INITIALIZE_MACHINE();
6492 codebase = pc = BCCODE(body);
6493 constants = BCCONSTS(body);
6494
6495 /* allow bytecode to be disabled for testing */
6496 if (R_disable_bytecode)
6497 return eval(bytecodeExpr(body), rho);
6498
6499 /* check version */
6500 /* must be kept in sync with R_BCVersionOK */
6501 int old_byte_code = FALSE; /* drop eventually */
6502 {
6503 int version = GETOP();
6504 if (version < 12) old_byte_code = TRUE; /* drop eventually */
6505 if (version < R_bcMinVersion || version > R_bcVersion) {
6506 if (version >= 2) {
6507 #ifdef BC_VERSION_MISMATCH_WARNING
6508 static Rboolean warned = FALSE;
6509 if (! warned) {
6510 warned = TRUE;
6511 warning(_("bytecode version mismatch; using eval"));
6512 }
6513 #endif
6514 return eval(bytecodeExpr(body), rho);
6515 }
6516 else if (version < R_bcMinVersion)
6517 error(_("bytecode version is too old"));
6518 else error(_("bytecode version is too new"));
6519 }
6520 }
6521
6522 INCREMENT_BCSTACK_LINKS();
6523
6524 R_Srcref = R_InBCInterpreter;
6525 R_BCIntActive = 1;
6526 R_BCbody = body;
6527 R_BCpc = ¤tpc;
6528 R_binding_cache_t vcache = NULL;
6529 Rboolean smallcache = TRUE;
6530 #ifdef USE_BINDING_CACHE
6531 if (useCache) {
6532 R_len_t n = LENGTH(constants);
6533 # ifdef CACHE_MAX
6534 if (n > CACHE_MAX) {
6535 n = CACHE_MAX;
6536 smallcache = FALSE;
6537 }
6538 # endif
6539 # ifdef CACHE_ON_STACK
6540 /* initialize binding cache on the stack */
6541 if (R_BCNodeStackTop + n + 1 > R_BCNodeStackEnd)
6542 nodeStackOverflow();
6543 R_BCNodeStackTop->u.ival = n;
6544 R_BCNodeStackTop->tag = CACHESZ_TAG;
6545 R_BCNodeStackTop++;
6546 vcache = R_BCNodeStackTop;
6547 while (n > 0) {
6548 SETSTACK_NLNK(0, R_NilValue);
6549 R_BCNodeStackTop++;
6550 n--;
6551 }
6552 # else
6553 /* allocate binding cache and protect on stack */
6554 vcache = allocVector(VECSXP, n);
6555 BCNPUSH(vcache);
6556 # endif
6557 }
6558 else smallcache = FALSE;
6559 #endif
6560 R_BCProtTop = R_BCNodeStackTop;
6561
6562 BEGIN_MACHINE {
6563 OP(BCMISMATCH, 0): error(_("byte code version mismatch"));
6564 OP(RETURN, 0): retvalue = GETSTACK(-1); goto done;
6565 OP(GOTO, 1):
6566 {
6567 int label = GETOP();
6568 BC_CHECK_SIGINT();
6569 pc = codebase + label;
6570 NEXT();
6571 }
6572 OP(BRIFNOT, 2):
6573 {
6574 int callidx = GETOP();
6575 int label = GETOP();
6576 Rboolean cond = GETSTACK_LOGICAL_NO_NA_PTR(R_BCNodeStackTop - 1,
6577 callidx, constants, rho);
6578 BCNPOP_IGNORE_VALUE();
6579 if (! cond) {
6580 BC_CHECK_SIGINT(); /**** only on back branch?*/
6581 pc = codebase + label;
6582 }
6583 NEXT();
6584 }
6585 OP(POP, 0): BCNPOP_IGNORE_VALUE(); NEXT();
6586 OP(DUP, 0): BCNDUP(); NEXT();
6587 OP(PRINTVALUE, 0): PrintValue(BCNPOP()); NEXT();
6588 OP(STARTLOOPCNTXT, 2):
6589 {
6590 Rboolean is_for_loop = GETOP();
6591 R_bcstack_t *oldtop = R_BCNodeStackTop;
6592 RCNTXT *cntxt = BCNALLOC_CNTXT();
6593 BCNPUSH_INTEGER(GETOP()); /* pc offset for 'break' */
6594 BCNPUSH_INTEGER((int)(pc - codebase)); /* pc offset for 'next' */
6595 if (is_for_loop) {
6596 /* duplicate the for loop state data on the top of the stack */
6597 R_bcstack_t *loopdata = oldtop - FOR_LOOP_STATE_SIZE;
6598 BCNSTACKCHECK(FOR_LOOP_STATE_SIZE);
6599 for (int i = 0; i < FOR_LOOP_STATE_SIZE; i++)
6600 R_BCNodeStackTop[i] = loopdata[i];
6601 R_BCNodeStackTop += FOR_LOOP_STATE_SIZE;
6602 SET_FOR_LOOP_BCPROT_OFFSET((int)(R_BCProtTop - R_BCNodeStackBase));
6603 INCLNK_stack(R_BCNodeStackTop);
6604
6605 begincontext(cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv,
6606 R_NilValue, R_NilValue);
6607 switch (SETJMP(cntxt->cjmpbuf)) {
6608 case CTXT_BREAK:
6609 pc = codebase + LOOP_BREAK_OFFSET(FOR_LOOP_STATE_SIZE);
6610 break;
6611 case CTXT_NEXT:
6612 pc = codebase + LOOP_NEXT_OFFSET(FOR_LOOP_STATE_SIZE);
6613 break;
6614 }
6615 }
6616 else {
6617 begincontext(cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv,
6618 R_NilValue, R_NilValue);
6619 switch (SETJMP(cntxt->cjmpbuf)) {
6620 case CTXT_BREAK:
6621 pc = codebase + LOOP_BREAK_OFFSET(0);
6622 break;
6623 case CTXT_NEXT:
6624 pc = codebase + LOOP_NEXT_OFFSET(0);
6625 break;
6626 }
6627 }
6628 /* context, offsets on stack, to be popped by ENDLOOPCNTXT */
6629 NEXT();
6630 }
6631 OP(ENDLOOPCNTXT, 1):
6632 {
6633 Rboolean is_for_loop = GETOP();
6634 if (is_for_loop) {
6635 int offset = GET_FOR_LOOP_BCPROT_OFFSET();
6636 DECLNK_stack(R_BCNodeStackBase + offset);
6637
6638 /* remove the duplicated for loop state data */
6639 R_BCNodeStackTop -= FOR_LOOP_STATE_SIZE;
6640 }
6641 BCNPOP_IGNORE_VALUE(); /* 'next' target */
6642 BCNPOP_IGNORE_VALUE(); /* 'break' target */
6643 BCNPOP_AND_END_CNTXT();
6644 NEXT();
6645 }
6646 OP(DOLOOPNEXT, 0): findcontext(CTXT_NEXT, rho, R_NilValue);
6647 OP(DOLOOPBREAK, 0): findcontext(CTXT_BREAK, rho, R_NilValue);
6648 OP(STARTFOR, 3):
6649 {
6650 Rboolean iscompact = FALSE;
6651 SEXP seq = getForLoopSeq(-1, &iscompact);
6652 int callidx = GETOP();
6653 SEXP symbol = VECTOR_ELT(constants, GETOP());
6654 int label = GETOP();
6655
6656 INSERT_FOR_LOOP_BCPROT_OFFSET();
6657
6658 /* if we are iterating over a factor, coerce to character first */
6659 if (inherits(seq, "factor")) {
6660 seq = asCharacterFactor(seq);
6661 SETSTACK(-1, seq);
6662 }
6663
6664 defineVar(symbol, R_NilValue, rho);
6665 BCNPUSH(GET_BINDING_CELL(symbol, rho));
6666
6667 SEXP value = allocVector(RAWSXP, sizeof(R_loopinfo_t));
6668 R_loopinfo_t *loopinfo = (R_loopinfo_t *) RAW0(value);
6669 loopinfo->idx = -1;
6670 #ifdef COMPACT_INTSEQ
6671 if (iscompact) {
6672 int n1 = INTEGER(seq)[0];
6673 int n2 = INTEGER(seq)[1];
6674 loopinfo->len = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;
6675 }
6676 else
6677 #endif
6678 if (isVector(seq))
6679 loopinfo->len = XLENGTH(seq);
6680 else if (isList(seq) || isNull(seq))
6681 loopinfo->len = length(seq);
6682 else errorcall(VECTOR_ELT(constants, callidx),
6683 _("invalid for() loop sequence"));
6684 #ifdef COMPACT_INTSEQ
6685 loopinfo->type = iscompact ? INTSEQSXP : TYPEOF(seq);
6686 #else
6687 loopinfo->type = TYPEOF(seq);
6688 #endif
6689 loopinfo->symbol = symbol;
6690 BCNPUSH(value);
6691
6692 /* bump up links count of seq to avoid modification by loop code */
6693 INCREMENT_LINKS(seq);
6694
6695 /* place initial loop variable value object on stack */
6696 switch(TYPEOF(seq)) {
6697 case LGLSXP:
6698 case INTSXP:
6699 case REALSXP:
6700 case CPLXSXP:
6701 case STRSXP:
6702 case RAWSXP:
6703 value = allocVector(TYPEOF(seq), 1);
6704 INCREMENT_NAMED(value);
6705 BCNPUSH_NLNK(value);
6706 break;
6707 default: BCNPUSH(R_NilValue);
6708 }
6709 /* the seq, binding cell, and value on the stack are now boxed */
6710
6711 SET_FOR_LOOP_BCPROT_OFFSET((int)(R_BCProtTop - R_BCNodeStackBase));
6712 INCLNK_stack(R_BCNodeStackTop);
6713
6714 BC_CHECK_SIGINT();
6715 pc = codebase + label;
6716 NEXT();
6717 }
6718 OP(STEPFOR, 1):
6719 {
6720 int label = GETOP();
6721 R_loopinfo_t *loopinfo = GET_FOR_LOOP_INFO();
6722 R_xlen_t i = ++(loopinfo->idx);
6723 R_xlen_t n = loopinfo->len;
6724 if (i < n) {
6725 BC_CHECK_SIGINT_LOOP(i);
6726 pc = codebase + label;
6727 int type = loopinfo->type;
6728 SEXP seq = GET_FOR_LOOP_SEQ();
6729 SEXP cell = GET_FOR_LOOP_BINDING();
6730 SEXP value = NULL;
6731 switch (type) {
6732 case REALSXP:
6733 if (BNDCELL_TAG_WR(cell) == REALSXP) {
6734 SET_BNDCELL_DVAL(cell, REAL_ELT(seq, i));
6735 NEXT();
6736 }
6737 if (BNDCELL_WRITABLE(cell)) {
6738 NEW_BNDCELL_DVAL(cell, REAL_ELT(seq, i));
6739 NEXT();
6740 }
6741 GET_VEC_LOOP_VALUE(value);
6742 SET_SCALAR_DVAL(value, REAL_ELT(seq, i));
6743 SET_FOR_LOOP_VAR(value, cell, loopinfo, rho);
6744 NEXT();
6745 case INTSXP:
6746 if (BNDCELL_TAG_WR(cell) == INTSXP) {
6747 SET_BNDCELL_IVAL(cell, INTEGER_ELT(seq, i));
6748 NEXT();
6749 }
6750 if (BNDCELL_WRITABLE(cell)) {
6751 NEW_BNDCELL_IVAL(cell, INTEGER_ELT(seq, i));
6752 NEXT();
6753 }
6754 GET_VEC_LOOP_VALUE(value);
6755 SET_SCALAR_IVAL(value, INTEGER_ELT(seq, i));
6756 SET_FOR_LOOP_VAR(value, cell, loopinfo, rho);
6757 NEXT();
6758 #ifdef COMPACT_INTSEQ
6759 case INTSEQSXP:
6760 {
6761 int *info = INTEGER(seq);
6762 int n1 = info[0];
6763 int n2 = info[1];
6764 int ii = (int) i;
6765 int ival = n1 <= n2 ? n1 + ii : n1 - ii;
6766 if (BNDCELL_TAG_WR(cell) == INTSXP) {
6767 SET_BNDCELL_IVAL(cell, ival);
6768 NEXT();
6769 }
6770 if (BNDCELL_WRITABLE(cell)) {
6771 NEW_BNDCELL_IVAL(cell, ival);
6772 NEXT();
6773 }
6774 GET_VEC_LOOP_VALUE(value);
6775 SET_SCALAR_IVAL(value, ival);
6776 SET_FOR_LOOP_VAR(value, cell, loopinfo, rho);
6777 NEXT();
6778 }
6779 #endif
6780 case LGLSXP:
6781 if (BNDCELL_TAG_WR(cell) == LGLSXP) {
6782 SET_BNDCELL_LVAL(cell, LOGICAL_ELT(seq, i));
6783 NEXT();
6784 }
6785 if (BNDCELL_WRITABLE(cell)) {
6786 NEW_BNDCELL_LVAL(cell, LOGICAL_ELT(seq, i));
6787 NEXT();
6788 }
6789 GET_VEC_LOOP_VALUE(value);
6790 SET_SCALAR_LVAL(value, LOGICAL_ELT(seq, i));
6791 SET_FOR_LOOP_VAR(value, cell, loopinfo, rho);
6792 NEXT();
6793 case CPLXSXP:
6794 GET_VEC_LOOP_VALUE(value);
6795 SET_SCALAR_CVAL(value, COMPLEX_ELT(seq, i));
6796 break;
6797 case STRSXP:
6798 GET_VEC_LOOP_VALUE(value);
6799 SET_STRING_ELT(value, 0, STRING_ELT(seq, i));
6800 break;
6801 case RAWSXP:
6802 GET_VEC_LOOP_VALUE(value);
6803 SET_SCALAR_BVAL(value, RAW(seq)[i]);
6804 break;
6805 case EXPRSXP:
6806 case VECSXP:
6807 value = VECTOR_ELT(seq, i);
6808 ENSURE_NAMEDMAX(value);
6809 break;
6810 case LISTSXP:
6811 value = CAR(seq);
6812 SET_FOR_LOOP_SEQ(CDR(seq));
6813 ENSURE_NAMEDMAX(value);
6814 break;
6815 default:
6816 error(_("invalid sequence argument in for loop"));
6817 }
6818 SET_FOR_LOOP_VAR(value, cell, loopinfo, rho);
6819 }
6820 NEXT();
6821 }
6822 OP(ENDFOR, 0):
6823 {
6824 int offset = GET_FOR_LOOP_BCPROT_OFFSET();
6825 DECLNK_stack(R_BCNodeStackBase + offset);
6826 SEXP seq = GET_FOR_LOOP_SEQ();
6827 DECREMENT_LINKS(seq);
6828 R_BCNodeStackTop -= FOR_LOOP_STATE_SIZE - 1;
6829 SETSTACK(-1, R_NilValue);
6830 NEXT();
6831 }
6832 OP(SETLOOPVAL, 0):
6833 BCNPOP_IGNORE_VALUE(); SETSTACK(-1, R_NilValue); NEXT();
6834 OP(INVISIBLE,0): R_Visible = FALSE; NEXT();
6835 OP(LDCONST, 1):
6836 {
6837 R_Visible = TRUE;
6838 SEXP value = VECTOR_ELT(constants, GETOP());
6839 int type = TYPEOF(value);
6840 switch(type) {
6841 case REALSXP:
6842 if (IS_SIMPLE_SCALAR(value, REALSXP)) {
6843 BCNPUSH_REAL(REAL0(value)[0]);
6844 NEXT();
6845 }
6846 break;
6847 case INTSXP:
6848 if (IS_SIMPLE_SCALAR(value, INTSXP)) {
6849 BCNPUSH_INTEGER(INTEGER0(value)[0]);
6850 NEXT();
6851 }
6852 break;
6853 case LGLSXP:
6854 if (IS_SIMPLE_SCALAR(value, LGLSXP)) {
6855 BCNPUSH_LOGICAL(LOGICAL0(value)[0]);
6856 NEXT();
6857 }
6858 break;
6859 }
6860 if (R_check_constants < 0)
6861 value = duplicate(value);
6862 MARK_NOT_MUTABLE(value);
6863 BCNPUSH(value);
6864 NEXT();
6865 }
6866 OP(LDNULL, 0): R_Visible = TRUE; BCNPUSH(R_NilValue); NEXT();
6867 OP(LDTRUE, 0): R_Visible = TRUE; BCNPUSH_LOGICAL(TRUE); NEXT();
6868 OP(LDFALSE, 0): R_Visible = TRUE; BCNPUSH_LOGICAL(FALSE); NEXT();
6869 OP(GETVAR, 1): DO_GETVAR(FALSE, FALSE);
6870 OP(DDVAL, 1): DO_GETVAR(TRUE, FALSE);
6871 OP(SETVAR, 1):
6872 {
6873 int sidx = GETOP();
6874 SEXP loc;
6875 if (smallcache)
6876 loc = GET_SMALLCACHE_BINDING_CELL(vcache, sidx);
6877 else {
6878 SEXP symbol = VECTOR_ELT(constants, sidx);
6879 loc = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
6880 }
6881
6882 R_bcstack_t *s = R_BCNodeStackTop - 1;
6883 int tag = s->tag;
6884
6885 if (tag == BNDCELL_TAG_WR(loc))
6886 switch (tag) {
6887 case REALSXP: SET_BNDCELL_DVAL(loc, s->u.dval); NEXT();
6888 case INTSXP: SET_BNDCELL_IVAL(loc, s->u.ival); NEXT();
6889 case LGLSXP: SET_BNDCELL_LVAL(loc, s->u.ival); NEXT();
6890 }
6891 else if (BNDCELL_WRITABLE(loc))
6892 switch (tag) {
6893 case REALSXP: NEW_BNDCELL_DVAL(loc, s->u.dval); NEXT();
6894 case INTSXP: NEW_BNDCELL_IVAL(loc, s->u.ival); NEXT();
6895 case LGLSXP: NEW_BNDCELL_LVAL(loc, s->u.ival); NEXT();
6896 }
6897
6898 SEXP value = GETSTACK(-1);
6899 INCREMENT_NAMED(value);
6900 if (! SET_BINDING_VALUE(loc, value)) {
6901 SEXP symbol = VECTOR_ELT(constants, sidx);
6902 PROTECT(value);
6903 defineVar(symbol, value, rho);
6904 UNPROTECT(1);
6905 }
6906 NEXT();
6907 }
6908 OP(GETFUN, 1):
6909 {
6910 /* get the function */
6911 SEXP symbol = VECTOR_ELT(constants, GETOP());
6912 SEXP value = findFun(symbol, rho);
6913 INIT_CALL_FRAME(value);
6914 if(RTRACE(value)) {
6915 Rprintf("trace: ");
6916 PrintValue(symbol);
6917 }
6918 NEXT();
6919 }
6920 OP(GETGLOBFUN, 1):
6921 {
6922 /* get the function */
6923 SEXP symbol = VECTOR_ELT(constants, GETOP());
6924 SEXP value = findFun(symbol, R_GlobalEnv);
6925 INIT_CALL_FRAME(value);
6926 if(RTRACE(value)) {
6927 Rprintf("trace: ");
6928 PrintValue(symbol);
6929 }
6930 NEXT();
6931 }
6932 OP(GETSYMFUN, 1):
6933 {
6934 /* get the function */
6935 SEXP symbol = VECTOR_ELT(constants, GETOP());
6936 SEXP value = SYMVALUE(symbol);
6937 if (TYPEOF(value) == PROMSXP) {
6938 value = forcePromise(value);
6939 ENSURE_NAMEDMAX(value);
6940 }
6941 if(RTRACE(value)) {
6942 Rprintf("trace: ");
6943 PrintValue(symbol);
6944 }
6945 INIT_CALL_FRAME(value);
6946 NEXT();
6947 }
6948 OP(GETBUILTIN, 1):
6949 {
6950 /* get the function */
6951 SEXP symbol = VECTOR_ELT(constants, GETOP());
6952 SEXP value = getPrimitive(symbol, BUILTINSXP);
6953 //#define REPORT_OVERRIDEN_BUILTINS
6954 #ifdef REPORT_OVERRIDEN_BUILTINS
6955 if (value != findFun(symbol, rho)) {
6956 Rprintf("Possibly overridden builtin: %s\n", PRIMNAME(value));
6957 }
6958 #endif
6959 if (RTRACE(value)) {
6960 Rprintf("trace: ");
6961 PrintValue(symbol);
6962 }
6963 INIT_CALL_FRAME(value);
6964 NEXT();
6965 }
6966 OP(GETINTLBUILTIN, 1):
6967 {
6968 /* get the function */
6969 SEXP symbol = VECTOR_ELT(constants, GETOP());
6970 SEXP value = INTERNAL(symbol);
6971 if (TYPEOF(value) != BUILTINSXP)
6972 error(_("there is no .Internal function '%s'"),
6973 CHAR(PRINTNAME(symbol)));
6974 INIT_CALL_FRAME(value);
6975 NEXT();
6976 }
6977 OP(CHECKFUN, 0):
6978 {
6979 /* check then the value on the stack is a function */
6980 SEXP value = GETSTACK(-1);
6981 if (TYPEOF(value) != CLOSXP && TYPEOF(value) != BUILTINSXP &&
6982 TYPEOF(value) != SPECIALSXP)
6983 error(_("attempt to apply non-function"));
6984 INIT_CALL_FRAME_ARGS();
6985 NEXT();
6986 }
6987 OP(MAKEPROM, 1):
6988 {
6989 SEXP code = VECTOR_ELT(constants, GETOP());
6990 SEXPTYPE ftype = CALL_FRAME_FTYPE();
6991 if (ftype != SPECIALSXP) {
6992 SEXP value;
6993 if (ftype == BUILTINSXP) {
6994 if (TYPEOF(code) == BCODESXP)
6995 value = bcEval(code, rho, TRUE);
6996 else
6997 /* uncommon but possible, the compiler may decide not to compile
6998 an argument expression */
6999 value = eval(code, rho);
7000 } else
7001 value = mkPROMISE(code, rho);
7002 PUSHCALLARG(value);
7003 }
7004 NEXT();
7005 }
7006 OP(DOMISSING, 0):
7007 {
7008 SEXPTYPE ftype = CALL_FRAME_FTYPE();
7009 if (ftype != SPECIALSXP)
7010 PUSHCALLARG(R_MissingArg);
7011 NEXT();
7012 }
7013 OP(SETTAG, 1):
7014 {
7015 SEXPTYPE ftype = CALL_FRAME_FTYPE();
7016 int tagidx = GETOP();
7017 if (ftype != SPECIALSXP) {
7018 SEXP tag = VECTOR_ELT(constants, tagidx);
7019 SETCALLARG_TAG(tag);
7020 }
7021 NEXT();
7022 }
7023 OP(DODOTS, 0):
7024 {
7025 SEXPTYPE ftype = CALL_FRAME_FTYPE();
7026 if (ftype != SPECIALSXP) {
7027 SEXP h = findVar(R_DotsSymbol, rho);
7028 if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
7029 PROTECT(h);
7030 for (; h != R_NilValue; h = CDR(h)) {
7031 SEXP val;
7032 if (ftype == BUILTINSXP)
7033 val = eval(CAR(h), rho);
7034 else if (CAR(h) == R_MissingArg)
7035 val = CAR(h);
7036 else
7037 val = mkPROMISE(CAR(h), rho);
7038 PUSHCALLARG(val);
7039 SETCALLARG_TAG(TAG(h));
7040 }
7041 UNPROTECT(1); /* h */
7042 }
7043 else if (h != R_MissingArg)
7044 error(_("'...' used in an incorrect context"));
7045 }
7046 NEXT();
7047 }
7048 OP(PUSHARG, 0): PUSHCALLARG(BCNPOP()); NEXT();
7049 OP(PUSHCONSTARG, 1):
7050 {
7051 SEXP value = VECTOR_ELT(constants, GETOP());
7052 if (R_check_constants < 0)
7053 value = duplicate(value);
7054 MARK_NOT_MUTABLE(value);
7055 PUSHCALLARG(value);
7056 NEXT();
7057 }
7058 OP(PUSHNULLARG, 0): PUSHCALLARG(R_NilValue); NEXT();
7059 OP(PUSHTRUEARG, 0): PUSHCALLARG(R_TrueValue); NEXT();
7060 OP(PUSHFALSEARG, 0): PUSHCALLARG(R_FalseValue); NEXT();
7061 OP(CALL, 1):
7062 {
7063 SEXP fun = CALL_FRAME_FUN();
7064 SEXP call = VECTOR_ELT(constants, GETOP());
7065 SEXP args;
7066 SEXP value = NULL;
7067 int flag;
7068 switch (TYPEOF(fun)) {
7069 case BUILTINSXP:
7070 args = BUILTIN_CALL_FRAME_ARGS();
7071 checkForMissings(args, call);
7072 flag = PRIMPRINT(fun);
7073 R_Visible = flag != 1;
7074 value = PRIMFUN(fun) (call, fun, args, rho);
7075 if (flag < 2) R_Visible = flag != 1;
7076 break;
7077 case SPECIALSXP:
7078 flag = PRIMPRINT(fun);
7079 R_Visible = flag != 1;
7080 value = PRIMFUN(fun) (call, fun, markSpecialArgs(CDR(call)), rho);
7081 if (flag < 2) R_Visible = flag != 1;
7082 break;
7083 case CLOSXP:
7084 args = CLOSURE_CALL_FRAME_ARGS();
7085 value = applyClosure(call, fun, args, rho, R_NilValue);
7086 #ifdef ADJUST_ENVIR_REFCNTS
7087 unpromiseArgs(args);
7088 #endif
7089 break;
7090 default: error(_("bad function"));
7091 }
7092 POP_CALL_FRAME(value);
7093 NEXT();
7094 }
7095 OP(CALLBUILTIN, 1):
7096 {
7097 SEXP fun = CALL_FRAME_FUN();
7098 SEXP call = VECTOR_ELT(constants, GETOP());
7099 SEXP args = BUILTIN_CALL_FRAME_ARGS();
7100 int flag;
7101 const void *vmax = vmaxget();
7102 if (TYPEOF(fun) != BUILTINSXP)
7103 error(_("not a BUILTIN function"));
7104 flag = PRIMPRINT(fun);
7105 R_Visible = flag != 1;
7106 SEXP value;
7107 if (R_Profiling && IS_TRUE_BUILTIN(fun)) {
7108 RCNTXT cntxt;
7109 SEXP oldref = R_Srcref;
7110 begincontext(&cntxt, CTXT_BUILTIN, call,
7111 R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue);
7112 R_Srcref = NULL;
7113 value = PRIMFUN(fun) (call, fun, args, rho);
7114 R_Srcref = oldref;
7115 endcontext(&cntxt);
7116 } else {
7117 value = PRIMFUN(fun) (call, fun, args, rho);
7118 }
7119 if (flag < 2) R_Visible = flag != 1;
7120 vmaxset(vmax);
7121 POP_CALL_FRAME(value);
7122 NEXT();
7123 }
7124 OP(CALLSPECIAL, 1):
7125 {
7126 SEXP call = VECTOR_ELT(constants, GETOP());
7127 SEXP symbol = CAR(call);
7128 SEXP fun = getPrimitive(symbol, SPECIALSXP);
7129 int flag;
7130 const void *vmax = vmaxget();
7131 if (RTRACE(fun)) {
7132 Rprintf("trace: ");
7133 PrintValue(symbol);
7134 }
7135 flag = PRIMPRINT(fun);
7136 R_Visible = flag != 1;
7137 SEXP value = PRIMFUN(fun) (call, fun, markSpecialArgs(CDR(call)), rho);
7138 if (flag < 2) R_Visible = flag != 1;
7139 vmaxset(vmax);
7140 BCNPUSH(value);
7141 NEXT();
7142 }
7143 OP(MAKECLOSURE, 1):
7144 {
7145 SEXP fb = VECTOR_ELT(constants, GETOP());
7146 SEXP forms = VECTOR_ELT(fb, 0);
7147 SEXP body = VECTOR_ELT(fb, 1);
7148 SEXP value = mkCLOSXP(forms, body, rho);
7149 /* The LENGTH check below allows for byte code object created
7150 by older versions of the compiler that did not record a
7151 source attribute. */
7152 /* FIXME: bump bc version and don't check LENGTH? */
7153 if (LENGTH(fb) > 2) {
7154 SEXP srcref = VECTOR_ELT(fb, 2);
7155 if (!isNull(srcref)) setAttrib(value, R_SrcrefSymbol, srcref);
7156 }
7157 R_Visible = TRUE;
7158 BCNPUSH(value);
7159 NEXT();
7160 }
7161 OP(UMINUS, 1): FastUnary(-, R_SubSym);
7162 OP(UPLUS, 1): FastUnary(+, R_AddSym);
7163 OP(ADD, 1): FastBinary(R_ADD, PLUSOP, R_AddSym);
7164 OP(SUB, 1): FastBinary(R_SUB, MINUSOP, R_SubSym);
7165 OP(MUL, 1): FastBinary(R_MUL, TIMESOP, R_MulSym);
7166 OP(DIV, 1): FastBinary(R_DIV, DIVOP, R_DivSym);
7167 OP(EXPT, 1): FastBinary(R_POW, POWOP, R_ExptSym);
7168 OP(SQRT, 1): FastMath1(R_sqrt, R_SqrtSym);
7169 OP(EXP, 1): FastMath1(exp, R_ExpSym);
7170 OP(EQ, 1): FastRelop2(==, EQOP, R_EqSym);
7171 OP(NE, 1): FastRelop2(!=, NEOP, R_NeSym);
7172 OP(LT, 1): FastRelop2(<, LTOP, R_LtSym);
7173 OP(LE, 1): FastRelop2(<=, LEOP, R_LeSym);
7174 OP(GE, 1): FastRelop2(>=, GEOP, R_GeSym);
7175 OP(GT, 1): FastRelop2(>, GTOP, R_GtSym);
7176 OP(AND, 1): FastLogic2(&, ANDOP, R_AndSym);
7177 OP(OR, 1): FastLogic2(|, OROP, R_OrSym);
7178 OP(NOT, 1):
7179 {
7180 R_Visible = TRUE;
7181 R_bcstack_t *s = R_BCNodeStackTop - 1;
7182 if (s->tag == LGLSXP) {
7183 int ival = s->u.ival;
7184 if (ival != NA_LOGICAL)
7185 s->u.ival = ival ? FALSE : TRUE;
7186 SKIP_OP();
7187 NEXT();
7188 }
7189 Builtin1(do_logic, R_NotSym, rho);
7190 }
7191 OP(DOTSERR, 0): error(_("'...' used in an incorrect context"));
7192 OP(STARTASSIGN, 1):
7193 {
7194 INCLNK_stack_commit();
7195 if (IS_STACKVAL_BOXED(-1)) {
7196 SEXP saverhs = GETSTACK(-1);
7197 FIXUP_RHS_NAMED(saverhs);
7198 int refrhs = MAYBE_REFERENCED(saverhs);
7199 SETSTACK_FLAGS(-1, refrhs);
7200 if (refrhs) INCREMENT_REFCNT(saverhs);
7201 }
7202 int sidx = GETOP();
7203 SEXP symbol = VECTOR_ELT(constants, sidx);
7204 SEXP cell = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
7205 SEXP value = BINDING_VALUE(cell);
7206 R_varloc_t loc;
7207 if (value == R_UnboundValue ||
7208 TYPEOF(value) == PROMSXP) {
7209 value = EnsureLocal(symbol, rho, &loc);
7210 if (loc.cell == NULL)
7211 loc.cell = R_NilValue;
7212 }
7213 else loc.cell = cell;
7214
7215 int maybe_in_assign = ASSIGNMENT_PENDING(loc.cell);
7216 SET_ASSIGNMENT_PENDING(loc.cell, TRUE);
7217 BCNPUSH(loc.cell);
7218
7219 if (maybe_in_assign || MAYBE_SHARED(value))
7220 value = shallow_duplicate(value);
7221 BCNPUSH(value);
7222
7223 BCNDUP3RD();
7224 /* top four stack entries are now
7225 RHS value, LHS cell, LHS value, RHS value */
7226 NEXT();
7227 }
7228 OP(ENDASSIGN, 1):
7229 {
7230 SEXP lhscell = GETSTACK(-2);
7231 SET_ASSIGNMENT_PENDING(lhscell, FALSE);
7232
7233 int sidx = GETOP();
7234 SEXP symbol = VECTOR_ELT(constants, sidx);
7235 SEXP cell = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
7236 SEXP value = GETSTACK(-1); /* leave on stack for GC protection */
7237 if (ALTREP(value)) {
7238 SEXP v = try_assign_unwrap(value, symbol, rho, cell);
7239 if (v != value) {
7240 SETSTACK(-1, v);
7241 value = v;
7242 }
7243 }
7244 INCREMENT_NAMED(value);
7245 if (! SET_BINDING_VALUE(cell, value))
7246 defineVar(symbol, value, rho);
7247 R_BCNodeStackTop -= 2; /* now pop cell and LHS value off the stack */
7248 /* original right-hand side value is now on top of stack again */
7249 #ifdef OLD_RHS_NAMED
7250 /* we do not duplicate the right-hand side value, so to be
7251 conservative mark the value as NAMED = NAMEDMAX */
7252 ENSURE_NAMEDMAX(GETSTACK(-1));
7253 #else
7254 if (IS_STACKVAL_BOXED(-1)) {
7255 SEXP saverhs = GETSTACK(-1);
7256 INCREMENT_NAMED(saverhs);
7257 int refrhs = GETSTACK_FLAGS(-1);
7258 if (refrhs) DECREMENT_REFCNT(saverhs);
7259 }
7260 #endif
7261 NEXT();
7262 }
7263 OP(STARTSUBSET, 2): DO_STARTDISPATCH("[");
7264 OP(DFLTSUBSET, 0): DO_DFLTDISPATCH(do_subset_dflt, R_SubsetSym);
7265 OP(STARTSUBASSIGN, 2): DO_START_ASSIGN_DISPATCH("[<-");
7266 OP(DFLTSUBASSIGN, 0):
7267 DO_DFLT_ASSIGN_DISPATCH(do_subassign_dflt, R_SubassignSym);
7268 OP(STARTC, 2): DO_STARTDISPATCH("c"); /* no longe used */
7269 OP(DFLTC, 0): DO_DFLTDISPATCH(do_c_dflt, R_CSym); /* no longe used */
7270 OP(STARTSUBSET2, 2): DO_STARTDISPATCH("[[");
7271 OP(DFLTSUBSET2, 0): DO_DFLTDISPATCH(do_subset2_dflt, R_Subset2Sym);
7272 OP(STARTSUBASSIGN2, 2): DO_START_ASSIGN_DISPATCH("[[<-");
7273 OP(DFLTSUBASSIGN2, 0):
7274 DO_DFLT_ASSIGN_DISPATCH(do_subassign2_dflt, R_Subassign2Sym);
7275 OP(DOLLAR, 2):
7276 {
7277 int dispatched = FALSE;
7278 SEXP call = VECTOR_ELT(constants, GETOP());
7279 SEXP symbol = VECTOR_ELT(constants, GETOP());
7280 SEXP x = GETSTACK(-1);
7281 SEXP value = NULL;
7282 if (isObject(x)) {
7283 SEXP ncall;
7284 PROTECT(ncall = duplicate(call));
7285 /**** hack to avoid evaluating the symbol */
7286 SETCAR(CDDR(ncall), ScalarString(PRINTNAME(symbol)));
7287 dispatched = tryDispatch("$", ncall, x, rho, &value);
7288 UNPROTECT(1);
7289 }
7290 if (dispatched)
7291 SETSTACK(-1, value);
7292 else
7293 SETSTACK(-1, R_subset3_dflt(x, PRINTNAME(symbol), R_NilValue));
7294 R_Visible = TRUE;
7295 NEXT();
7296 }
7297 OP(DOLLARGETS, 2):
7298 {
7299 int dispatched = FALSE;
7300 SEXP call = VECTOR_ELT(constants, GETOP());
7301 SEXP symbol = VECTOR_ELT(constants, GETOP());
7302 SEXP x = GETSTACK(-2);
7303 SEXP rhs = GETSTACK(-1);
7304 MARK_ASSIGNMENT_CALL(call);
7305 if (MAYBE_SHARED(x)) {
7306 x = shallow_duplicate(x);
7307 SETSTACK(-2, x);
7308 ENSURE_NAMED(x);
7309 }
7310 SEXP value = NULL;
7311 if (isObject(x)) {
7312 SEXP ncall, prom;
7313 PROTECT(ncall = duplicate(call));
7314 /**** hack to avoid evaluating the symbol */
7315 SETCAR(CDDR(ncall), ScalarString(PRINTNAME(symbol)));
7316 prom = mkRHSPROMISE(CADDDR(ncall), rhs);
7317 SETCAR(CDDDR(ncall), prom);
7318 dispatched = tryDispatch("$<-", ncall, x, rho, &value);
7319 UNPROTECT(1);
7320 }
7321 if (! dispatched)
7322 value = R_subassign3_dflt(call, x, symbol, rhs);
7323 R_BCNodeStackTop--;
7324 SETSTACK(-1, value);
7325 NEXT();
7326 }
7327 OP(ISNULL, 0): DO_ISTEST(isNull);
7328 OP(ISLOGICAL, 0): DO_ISTYPE(LGLSXP);
7329 OP(ISINTEGER, 0): {
7330 SEXP arg = GETSTACK(-1);
7331 Rboolean test = (TYPEOF(arg) == INTSXP) && ! inherits(arg, "factor");
7332 SETSTACK(-1, test ? R_TrueValue : R_FalseValue);
7333 R_Visible = TRUE;
7334 NEXT();
7335 }
7336 OP(ISDOUBLE, 0): DO_ISTYPE(REALSXP);
7337 OP(ISCOMPLEX, 0): DO_ISTYPE(CPLXSXP);
7338 OP(ISCHARACTER, 0): DO_ISTYPE(STRSXP);
7339 OP(ISSYMBOL, 0): DO_ISTYPE(SYMSXP); /**** S4 thingy allowed now???*/
7340 OP(ISOBJECT, 0): DO_ISTEST(OBJECT);
7341 OP(ISNUMERIC, 0): DO_ISTEST(isNumericOnly);
7342 OP(VECSUBSET, 1): DO_VECSUBSET(rho, FALSE);
7343 OP(MATSUBSET, 1): DO_MATSUBSET(rho, FALSE); NEXT();
7344 OP(VECSUBASSIGN, 1): DO_VECSUBASSIGN(rho, FALSE);
7345 OP(MATSUBASSIGN, 1): DO_MATSUBASSIGN(rho, FALSE); NEXT();
7346 OP(AND1ST, 2): {
7347 int callidx = GETOP();
7348 int label = GETOP();
7349 FIXUP_SCALAR_LOGICAL(rho, callidx, "'x'", "&&", warn_lev);
7350 Rboolean val = GETSTACK_LOGICAL(-1);
7351 if (val == FALSE)
7352 pc = codebase + label;
7353 R_Visible = TRUE;
7354 NEXT();
7355 }
7356 OP(AND2ND, 1): {
7357 int callidx = GETOP();
7358 FIXUP_SCALAR_LOGICAL(rho, callidx, "'y'", "&&", warn_lev);
7359 Rboolean val = GETSTACK_LOGICAL(-1);
7360 /* The first argument is TRUE or NA. If the second argument is
7361 not TRUE then its value is the result. If the second
7362 argument is TRUE, then the first argument's value is the
7363 result. */
7364 if (val == FALSE || val == NA_LOGICAL)
7365 SETSTACK_LOGICAL(-2, val);
7366 R_BCNodeStackTop -= 1;
7367 R_Visible = TRUE;
7368 NEXT();
7369 }
7370 OP(OR1ST, 2): {
7371 int callidx = GETOP();
7372 int label = GETOP();
7373 FIXUP_SCALAR_LOGICAL(rho, callidx, "'x'", "||", warn_lev);
7374 Rboolean val = GETSTACK_LOGICAL(-1);
7375 if (val != NA_LOGICAL &&
7376 val != FALSE) /* is true */
7377 pc = codebase + label;
7378 R_Visible = TRUE;
7379 NEXT();
7380 }
7381 OP(OR2ND, 1): {
7382 int callidx = GETOP();
7383 FIXUP_SCALAR_LOGICAL(rho, callidx, "'y'", "||", warn_lev);
7384 Rboolean val = GETSTACK_LOGICAL(-1);
7385 /* The first argument is FALSE or NA. If the second argument is
7386 not FALSE then its value is the result. If the second
7387 argument is FALSE, then the first argument's value is the
7388 result. */
7389 if (val != FALSE)
7390 SETSTACK_LOGICAL(-2, val);
7391 R_BCNodeStackTop -= 1;
7392 R_Visible = TRUE;
7393 NEXT();
7394 }
7395 OP(GETVAR_MISSOK, 1): DO_GETVAR(FALSE, TRUE);
7396 OP(DDVAL_MISSOK, 1): DO_GETVAR(TRUE, TRUE);
7397 OP(VISIBLE, 0): R_Visible = TRUE; NEXT();
7398 OP(SETVAR2, 1):
7399 {
7400 SEXP symbol = VECTOR_ELT(constants, GETOP());
7401 SEXP value = GETSTACK(-1);
7402 INCREMENT_NAMED(value);
7403 setVar(symbol, value, ENCLOS(rho));
7404 NEXT();
7405 }
7406 OP(STARTASSIGN2, 1):
7407 {
7408 INCLNK_stack_commit();
7409 SEXP symbol = VECTOR_ELT(constants, GETOP());
7410 R_varloc_t loc = R_findVarLoc(symbol, rho);
7411
7412 if (loc.cell == NULL)
7413 loc.cell = R_NilValue;
7414 int maybe_in_assign = ASSIGNMENT_PENDING(loc.cell);
7415 SET_ASSIGNMENT_PENDING(loc.cell, TRUE);
7416 BCNPUSH(loc.cell);
7417
7418 SEXP value = getvar(symbol, ENCLOS(rho), FALSE, FALSE, NULL, 0);
7419 if (maybe_in_assign || MAYBE_SHARED(value))
7420 value = shallow_duplicate(value);
7421 BCNPUSH(value);
7422
7423 BCNDUP3RD();
7424 /* top four stack entries are now
7425 RHS value, LHS cell, LHS value, RHS value */
7426 if (IS_STACKVAL_BOXED(-1)) {
7427 FIXUP_RHS_NAMED(GETSTACK(-1));
7428 INCREMENT_REFCNT(GETSTACK(-1));
7429 }
7430 NEXT();
7431 }
7432 OP(ENDASSIGN2, 1):
7433 {
7434 SEXP lhscell = GETSTACK(-2);
7435 SET_ASSIGNMENT_PENDING(lhscell, FALSE);
7436
7437 SEXP symbol = VECTOR_ELT(constants, GETOP());
7438 SEXP value = GETSTACK(-1); /* leave on stack for GC protection */
7439 INCREMENT_NAMED(value);
7440 setVar(symbol, value, ENCLOS(rho));
7441 R_BCNodeStackTop -= 2; /* now pop cell and LHS value off the stack */
7442 /* original right-hand side value is now on top of stack again */
7443 #ifdef OLD_RHS_NAMED
7444 /* we do not duplicate the right-hand side value, so to be
7445 conservative mark the value as NAMED = NAMEDMAX */
7446 ENSURE_NAMEDMAX(GETSTACK(-1));
7447 #else
7448 INCREMENT_NAMED(GETSTACK(-1));
7449 #endif
7450 DECREMENT_REFCNT(GETSTACK(-1));
7451 NEXT();
7452 }
7453 OP(SETTER_CALL, 2):
7454 {
7455 SEXP lhs = GETSTACK_BELOW_CALL_FRAME(-2);
7456 SEXP rhs = GETSTACK_BELOW_CALL_FRAME(-1);
7457 SEXP fun = CALL_FRAME_FUN();
7458 SEXP call = VECTOR_ELT(constants, GETOP());
7459 SEXP vexpr = VECTOR_ELT(constants, GETOP());
7460 SEXP args, prom, last;
7461 MARK_ASSIGNMENT_CALL(call);
7462 if (MAYBE_SHARED(lhs)) {
7463 lhs = shallow_duplicate(lhs);
7464 SETSTACK_BELOW_CALL_FRAME(-2, lhs);
7465 ENSURE_NAMED(lhs);
7466 }
7467 SEXP value = NULL;
7468 switch (TYPEOF(fun)) {
7469 case BUILTINSXP:
7470 /* push RHS value onto arguments with 'value' tag */
7471 PUSHCALLARG(rhs);
7472 SETCALLARG_TAG_SYMBOL(R_valueSym);
7473 /* replace first argument with LHS value */
7474 args = BUILTIN_CALL_FRAME_ARGS();
7475 SETCAR(args, lhs);
7476 /* make the call */
7477 checkForMissings(args, call);
7478 value = PRIMFUN(fun) (call, fun, args, rho);
7479 break;
7480 case SPECIALSXP:
7481 /* duplicate arguments and protect */
7482 PROTECT(args = duplicate(CDR(call)));
7483 /* insert evaluated promise for LHS as first argument */
7484 /* promise won't be captured so don't track references */
7485 prom = R_mkEVPROMISE_NR(R_TmpvalSymbol, lhs);
7486 SETCAR(args, prom);
7487 /* insert evaluated promise for RHS as last argument */
7488 last = args;
7489 while (CDR(last) != R_NilValue)
7490 last = CDR(last);
7491 prom = mkRHSPROMISE(vexpr, rhs);
7492 SETCAR(last, prom);
7493 /* make the call */
7494 value = PRIMFUN(fun) (call, fun, args, rho);
7495 UNPROTECT(1);
7496 break;
7497 case CLOSXP:
7498 /* push evaluated promise for RHS onto arguments with 'value' tag */
7499 /* This need to use a standard EVPROMISE so the reference
7500 from the environment to the RHS value is counted. */
7501 prom = R_mkEVPROMISE(vexpr, rhs);
7502 PUSHCALLARG(prom);
7503 SETCALLARG_TAG_SYMBOL(R_valueSym);
7504 /* replace first argument with evaluated promise for LHS */
7505 /* promise might be captured, so track references */
7506 args = CLOSURE_CALL_FRAME_ARGS();
7507 prom = R_mkEVPROMISE(R_TmpvalSymbol, lhs);
7508 SETCAR(args, prom);
7509 /* make the call */
7510 value = applyClosure(call, fun, args, rho, R_NilValue);
7511 #ifdef ADJUST_ENVIR_REFCNTS
7512 unpromiseArgs(args);
7513 #endif
7514 break;
7515 default: error(_("bad function"));
7516 }
7517 POP_CALL_FRAME_PLUS(2, value);
7518 NEXT();
7519 }
7520 OP(GETTER_CALL, 1):
7521 {
7522 SEXP lhs = GETSTACK_BELOW_CALL_FRAME(-2);
7523 SEXP fun = CALL_FRAME_FUN();
7524 SEXP call = VECTOR_ELT(constants, GETOP());
7525 SEXP value = NULL;
7526 SEXP args, prom;
7527 switch (TYPEOF(fun)) {
7528 case BUILTINSXP:
7529 /* replace first argument with LHS value */
7530 args = BUILTIN_CALL_FRAME_ARGS();
7531 SETCAR(args, lhs);
7532 /* make the call */
7533 checkForMissings(args, call);
7534 value = PRIMFUN(fun) (call, fun, args, rho);
7535 break;
7536 case SPECIALSXP:
7537 /* duplicate arguments and put into stack for GC protection */
7538 args = duplicate(CDR(call));
7539 SETSTACK(-2, args);
7540 /* insert evaluated promise for LHS as first argument */
7541 /* promise won't be captured so don't track refrences */
7542 prom = R_mkEVPROMISE_NR(R_TmpvalSymbol, lhs);
7543 SETCAR(args, prom);
7544 /* make the call */
7545 value = PRIMFUN(fun) (call, fun, args, rho);
7546 break;
7547 case CLOSXP:
7548 /* replace first argument with evaluated promise for LHS */
7549 /* promise might be captured, so track references */
7550 args = CLOSURE_CALL_FRAME_ARGS();
7551 prom = R_mkEVPROMISE(R_TmpvalSymbol, lhs);
7552 SETCAR(args, prom);
7553 /* make the call */
7554 value = applyClosure(call, fun, args, rho, R_NilValue);
7555 #ifdef ADJUST_ENVIR_REFCNTS
7556 unpromiseArgs(args);
7557 #endif
7558 break;
7559 default: error(_("bad function"));
7560 }
7561 POP_CALL_FRAME(value);
7562 NEXT();
7563 }
7564 OP(SWAP, 0): {
7565 /* This instruction only occurs between accessor calls in
7566 complex assignments. [It should probably be renamed to
7567 reflect this.] It needs to make sure intermediate LHS
7568 values in complex assignments are not shared by duplicating
7569 the extracted value in tmp when necessary. Duplicating is
7570 necessary if the value might be shared _or_ if the
7571 container, which is in R_BCNodeStackTop[-3], has become
7572 possibly shared by going through a closure in the preceding
7573 accessor call. This is taken to indicate that the
7574 corresponding replacement function might be a closure and
7575 will need to see an unmodified LHS value. This heuristic
7576 fails if the accessor function called here is not a closure
7577 but the replacement function is. */
7578
7579 /* For the typed stack it might be OK just to force boxing at
7580 this point, but for now this code tries to avoid doing
7581 that. The macros make the code a little more reabable. */
7582 #define STACKVAL_MAYBE_REFERENCED(idx) \
7583 (IS_STACKVAL_BOXED(idx) && \
7584 MAYBE_REFERENCED(GETSTACK_SXPVAL_PTR(R_BCNodeStackTop + (idx))))
7585 #define STACKVAL_MAYBE_SHARED(idx) \
7586 (IS_STACKVAL_BOXED(idx) && \
7587 MAYBE_SHARED(GETSTACK_SXPVAL_PTR(R_BCNodeStackTop + (idx))))
7588
7589 if (STACKVAL_MAYBE_REFERENCED(-1) &&
7590 (STACKVAL_MAYBE_SHARED(-1) ||
7591 STACKVAL_MAYBE_SHARED(-3)))
7592 SETSTACK(-1, shallow_duplicate(GETSTACK(-1)));
7593
7594 R_bcstack_t tmp = R_BCNodeStackTop[-1];
7595 R_BCNodeStackTop[-1] = R_BCNodeStackTop[-2];
7596 R_BCNodeStackTop[-2] = tmp;
7597 NEXT();
7598 }
7599 OP(DUP2ND, 0): BCNDUP2ND(); NEXT();
7600 OP(SWITCH, 4): {
7601 SEXP call = VECTOR_ELT(constants, GETOP());
7602 SEXP names = VECTOR_ELT(constants, GETOP());
7603 SEXP coffsets = VECTOR_ELT(constants, GETOP());
7604 SEXP ioffsets = VECTOR_ELT(constants, GETOP());
7605 SEXP value = BCNPOP();
7606 if (!isVector(value) || length(value) != 1)
7607 errorcall(call, _("EXPR must be a length 1 vector"));
7608 if (isFactor(value))
7609 warningcall(call,
7610 _("EXPR is a \"factor\", treated as integer.\n"
7611 " Consider using '%s' instead."),
7612 "switch(as.character( * ), ...)");
7613 if (TYPEOF(value) == STRSXP) {
7614 int i, n, which;
7615 if (names == R_NilValue) {
7616 if (TYPEOF(ioffsets) != INTSXP)
7617 errorcall(call, _("bad numeric 'switch' offsets"));
7618 if (LENGTH(ioffsets) == 1) {
7619 pc = codebase + INTEGER(ioffsets)[0]; /* returns NULL */
7620 warningcall(call, _("'switch' with no alternatives"));
7621 }
7622 else
7623 errorcall(call, _("numeric EXPR required for 'switch' "
7624 "without named alternatives"));
7625 } else {
7626 if (TYPEOF(coffsets) != INTSXP)
7627 errorcall(call, _("bad character 'switch' offsets"));
7628 if (TYPEOF(names) != STRSXP || LENGTH(names) != LENGTH(coffsets))
7629 errorcall(call, "bad 'switch' names");
7630 n = LENGTH(names);
7631 which = n - 1;
7632 for (i = 0; i < n - 1; i++)
7633 if (pmatch(STRING_ELT(value, 0),
7634 STRING_ELT(names, i), 1 /* exact */)) {
7635 which = i;
7636 break;
7637 }
7638 pc = codebase + INTEGER(coffsets)[which];
7639 }
7640 }
7641 else {
7642 if (TYPEOF(ioffsets) != INTSXP)
7643 errorcall(call, "bad numeric 'switch' offsets");
7644 int which = asInteger(value);
7645 if (which != NA_INTEGER) which--;
7646 if (which < 0 || which >= LENGTH(ioffsets))
7647 which = LENGTH(ioffsets) - 1;
7648 if (LENGTH(ioffsets) == 1)
7649 warningcall(call, _("'switch' with no alternatives"));
7650 pc = codebase + INTEGER(ioffsets)[which];
7651 }
7652 NEXT();
7653 }
7654 OP(RETURNJMP, 0): {
7655 SEXP value = BCNPOP();
7656 findcontext(CTXT_BROWSER | CTXT_FUNCTION, rho, value);
7657 }
7658 OP(STARTSUBSET_N, 2): DO_STARTDISPATCH_N("[");
7659 OP(STARTSUBASSIGN_N, 2): DO_START_ASSIGN_DISPATCH_N("[<-");
7660 OP(VECSUBSET2, 1): DO_VECSUBSET(rho, TRUE);
7661 OP(MATSUBSET2, 1): DO_MATSUBSET(rho, TRUE); NEXT();
7662 OP(VECSUBASSIGN2, 1): DO_VECSUBASSIGN(rho, TRUE);
7663 OP(MATSUBASSIGN2, 1): DO_MATSUBASSIGN(rho, TRUE); NEXT();
7664 OP(STARTSUBSET2_N, 2): DO_STARTDISPATCH_N("[[");
7665 OP(STARTSUBASSIGN2_N, 2): DO_START_ASSIGN_DISPATCH_N("[[<-");
7666 OP(SUBSET_N, 2): DO_SUBSET_N(rho, FALSE); NEXT();
7667 OP(SUBSET2_N, 2): DO_SUBSET_N(rho, TRUE); NEXT();
7668 OP(SUBASSIGN_N, 2): DO_SUBASSIGN_N(rho, FALSE); NEXT();
7669 OP(SUBASSIGN2_N, 2): DO_SUBASSIGN_N(rho, TRUE); NEXT();
7670 OP(LOG, 1): DO_LOG(); NEXT();
7671 OP(LOGBASE, 1): DO_LOGBASE(); NEXT();
7672 OP(MATH1, 2): DO_MATH1(); NEXT();
7673 OP(DOTCALL, 2): DO_DOTCALL(); NEXT();
7674 OP(COLON, 1): DO_COLON(); NEXT();
7675 OP(SEQALONG, 1): DO_SEQ_ALONG(); NEXT();
7676 OP(SEQLEN, 1): DO_SEQ_LEN(); NEXT();
7677 OP(BASEGUARD, 2): DO_BASEGUARD(); NEXT();
7678 OP(INCLNK, 0):
7679 INCLNK_stack_commit(); /* needed for pre version 12 byte code */
7680 INCLNK_STACK_PTR(R_BCNodeStackTop - 1);
7681 NEXT();
7682 OP(DECLNK, 0):
7683 DECLNK_STACK_PTR(R_BCNodeStackTop - 2);
7684 NEXT();
7685 OP(DECLNK_N, 1):
7686 for (int n = GETOP(), i = 0; i < n; i++)
7687 DECLNK_STACK_PTR(R_BCNodeStackTop - 2 - i);
7688 NEXT();
7689 OP(INCLNKSTK, 0):
7690 {
7691 int offset = (int)(R_BCProtTop - R_BCNodeStackBase);
7692 INCLNK_stack(R_BCNodeStackTop);
7693 BCNPUSH_INTEGER(offset);
7694 NEXT();
7695 }
7696 OP(DECLNKSTK, 0):
7697 {
7698 int offset = GETSTACK_IVAL_PTR(R_BCNodeStackTop - 2);
7699 R_bcstack_t *ptop = R_BCNodeStackBase + offset;
7700 DECLNK_stack(ptop);
7701 R_BCNodeStackTop[-2] = R_BCNodeStackTop[-1];
7702 R_BCNodeStackTop--;
7703 NEXT();
7704 }
7705 LASTOP;
7706 }
7707
7708 done:
7709 R_BCIntActive = oldbcintactive;
7710 R_BCbody = oldbcbody;
7711 R_BCpc = oldbcpc;
7712 R_Srcref = oldsrcref;
7713 #ifdef BC_PROFILING
7714 current_opcode = old_current_opcode;
7715 #endif
7716 if (body) {
7717 R_BCNodeStackTop = R_BCProtTop;
7718 DECREMENT_BCSTACK_LINKS();
7719 }
7720 R_BCNodeStackTop = oldntop;
7721 return retvalue;
7722 }
7723
7724 #ifdef THREADED_CODE
R_bcEncode(SEXP bytes)7725 SEXP R_bcEncode(SEXP bytes)
7726 {
7727 SEXP code;
7728 BCODE *pc;
7729 int *ipc, i, n, m, v;
7730
7731 m = (sizeof(BCODE) + sizeof(int) - 1) / sizeof(int);
7732
7733 n = LENGTH(bytes);
7734 ipc = INTEGER(bytes);
7735
7736 v = ipc[0];
7737 if (v < R_bcMinVersion || v > R_bcVersion) {
7738 code = allocVector(INTSXP, m * 2);
7739 pc = (BCODE *) INTEGER(code);
7740 pc[0].i = v;
7741 pc[1].v = opinfo[BCMISMATCH_OP].addr;
7742 return code;
7743 }
7744 else {
7745 code = allocVector(INTSXP, m * n);
7746 memset(INTEGER(code), 0, m * n * sizeof(int));
7747 pc = (BCODE *) INTEGER(code);
7748
7749 for (i = 0; i < n; i++) pc[i].i = ipc[i];
7750
7751 /* install the current version number */
7752 pc[0].i = R_bcVersion;
7753
7754 /* Revert to version 2 to allow for some one compiling in a
7755 new R, loading/saving in an old one, and then trying to run
7756 in a new one. This has happened! Setting the version number
7757 back tells bcEval to drop back to eval. */
7758 if (n == 2 && ipc[1] == BCMISMATCH_OP)
7759 pc[0].i = 2;
7760
7761 for (i = 1; i < n;) {
7762 int op = pc[i].i;
7763 if (op < 0 || op >= OPCOUNT)
7764 error("unknown instruction code");
7765 pc[i].v = opinfo[op].addr;
7766 i += opinfo[op].argc + 1;
7767 }
7768
7769 return code;
7770 }
7771 }
7772
findOp(void * addr)7773 static int findOp(void *addr)
7774 {
7775 int i;
7776
7777 for (i = 0; i < OPCOUNT; i++)
7778 if (opinfo[i].addr == addr)
7779 return i;
7780 error(_("cannot find index for threaded code address"));
7781 return 0; /* not reached */
7782 }
7783
R_bcDecode(SEXP code)7784 SEXP R_bcDecode(SEXP code) {
7785 int n, i, j, *ipc;
7786 BCODE *pc;
7787 SEXP bytes;
7788
7789 int m = (sizeof(BCODE) + sizeof(int) - 1) / sizeof(int);
7790
7791 n = LENGTH(code) / m;
7792 pc = (BCODE *) INTEGER(code);
7793
7794 bytes = allocVector(INTSXP, n);
7795 ipc = INTEGER(bytes);
7796
7797 /* copy the version number */
7798 ipc[0] = pc[0].i;
7799
7800 for (i = 1; i < n;) {
7801 int op = findOp(pc[i].v);
7802 int argc = opinfo[op].argc;
7803 ipc[i] = op;
7804 i++;
7805 for (j = 0; j < argc; j++, i++)
7806 ipc[i] = pc[i].i;
7807 }
7808
7809 return bytes;
7810 }
7811 #else
R_bcEncode(SEXP x)7812 SEXP R_bcEncode(SEXP x) { return x; }
R_bcDecode(SEXP x)7813 SEXP R_bcDecode(SEXP x) { return duplicate(x); }
7814 #endif
7815
7816 /* Add BCODESXP bc into the constants registry, performing a deep copy of the
7817 bc's constants */
7818 #define CONST_CHECK_COUNT 1000
R_registerBC(SEXP bcBytes,SEXP bcode)7819 void attribute_hidden R_registerBC(SEXP bcBytes, SEXP bcode)
7820 {
7821 if (R_check_constants <= 0)
7822 return;
7823 if (TYPEOF(bcBytes) != INTSXP)
7824 error("registerBC requires integer vector as bcBytes");
7825 if (TYPEOF(bcode) != BCODESXP)
7826 error("registerBC requires BCODESXP object as bcode");
7827
7828 static int count = CONST_CHECK_COUNT;
7829 if (--count <= 0) {
7830 count = CONST_CHECK_COUNT;
7831 R_checkConstants(TRUE);
7832 }
7833
7834 /* The constants registry is a linked list of constant records. Each
7835 constant record is a generic vector, its first element is a pointer
7836 to the next constant record, the second element is a weak reference
7837 to the byte-code object, the third element is a reference to the whole
7838 constant pool, and the following elements are interleaved original and
7839 copied constants. A constant registry corresponds to a constant pool.
7840 When the weak reference gets cleared, the respective constant record
7841 can be removed from the list.
7842
7843 One could simply compare/duplicate the lists of all constants (the whole
7844 constant pools), but that turned out too expensive */
7845
7846 SEXP consts = BCCONSTS(bcode); /* all constants, VECSXP */
7847
7848 #define CHECK_ALL_CONSTANTS
7849 #ifndef CHECK_ALL_CONSTANTS
7850 int *ipc = INTEGER(bcBytes);
7851 int n = LENGTH(bcBytes);
7852 int i;
7853 int loadableConsts = 0;
7854
7855 /* add only constants loaded by certain instructions */
7856 for(i = 0; i < n; i += opinfo[ipc[i]].argc + 1)
7857 if (ipc[i] == LDCONST_OP || ipc[i] == PUSHCONSTARG_OP ||
7858 ipc[i] == CALLSPECIAL_OP)
7859 loadableConsts++;
7860
7861 SEXP constsRecord = PROTECT(allocVector(VECSXP, loadableConsts * 2 + 3));
7862 int crIdx = 3;
7863 for(i = 0; i < n; i += opinfo[ipc[i]].argc + 1)
7864 if (ipc[i] == LDCONST_OP || ipc[i] == PUSHCONSTARG_OP ||
7865 ipc[i] == CALLSPECIAL_OP) {
7866 SEXP corig = VECTOR_ELT(consts, ipc[i + 1]);
7867 SET_VECTOR_ELT(constsRecord, crIdx++, corig);
7868 SET_VECTOR_ELT(constsRecord, crIdx++, duplicate(corig));
7869 }
7870 #else
7871 /* add the whole constant pool */
7872 SEXP constsRecord = PROTECT(allocVector(VECSXP, 2 + 3));
7873 SET_VECTOR_ELT(constsRecord, 3, consts);
7874 /* the consts reference is in the record twice to make the code simpler */
7875 SET_VECTOR_ELT(constsRecord, 4, duplicate(consts));
7876 #endif
7877
7878 SEXP wref = R_MakeWeakRef(bcode, R_NilValue, R_NilValue, FALSE);
7879 SET_VECTOR_ELT(constsRecord, 0, VECTOR_ELT(R_ConstantsRegistry, 0));
7880 SET_VECTOR_ELT(constsRecord, 1, wref);
7881 SET_VECTOR_ELT(constsRecord, 2, consts);
7882 SET_VECTOR_ELT(R_ConstantsRegistry, 0, constsRecord);
7883 UNPROTECT(1); /* constsRecord */
7884 }
7885
7886 /* A potentially very verbose report for modified compiler constant. */
reportModifiedConstant(SEXP crec,SEXP orig,SEXP copy,int idx)7887 static void reportModifiedConstant(SEXP crec, SEXP orig, SEXP copy, int idx)
7888 {
7889 if (R_check_constants < 5)
7890 return;
7891
7892 SEXP consts = VECTOR_ELT(crec, 2);
7893 int n = LENGTH(consts);
7894 int i;
7895 if (idx == -1) {
7896 for(i = 0; i < n; i++)
7897 if (VECTOR_ELT(consts, i) == orig) {
7898 idx = i;
7899 break;
7900 }
7901 }
7902 int oldout = R_OutputCon; /* redirect standard to error output */
7903 R_OutputCon = 2;
7904 int oldcheck = R_check_constants; /* guard against recursive invocation */
7905 R_check_constants = 0;
7906 if (idx != 0) {
7907 REprintf("ERROR: the modified value of the constant is:\n");
7908 PrintValue(orig);
7909 REprintf("ERROR: the original value of the constant is:\n");
7910 PrintValue(copy);
7911 REprintf("ERROR: the modified constant is at index %d\n", idx);
7912 REprintf("ERROR: the modified constant is in this function body:\n");
7913 PrintValue(VECTOR_ELT(consts, 0));
7914 } else {
7915 REprintf("ERROR: the modified constant is function body:\n");
7916 PrintValue(orig);
7917 REprintf("ERROR: the body was originally:\n");
7918 PrintValue(copy);
7919 }
7920 findFunctionForBody(VECTOR_ELT(consts, 0));
7921 R_check_constants = oldcheck;
7922 R_OutputCon = oldout;
7923 }
7924
7925 /* Checks whether compiler constants linked from the given record
7926 were modified. */
checkConstantsInRecord(SEXP crec,Rboolean abortOnError)7927 static Rboolean checkConstantsInRecord(SEXP crec, Rboolean abortOnError)
7928 {
7929 int i;
7930 int n = LENGTH(crec);
7931 Rboolean constsOK = TRUE;
7932
7933 for (i = 3; i < n;) {
7934 SEXP corig = VECTOR_ELT(crec, i++);
7935 SEXP ccopy = VECTOR_ELT(crec, i++);
7936
7937 /* 39: not numerical comparison, not single NA, not attributes as
7938 set, do ignore byte-code, do ignore environments of closures,
7939 not ignore srcref
7940
7941 srcref is not ignored because ignoring it is expensive
7942 (it triggers duplication)
7943 */
7944 if (!R_compute_identical(corig, ccopy, 39)) {
7945
7946 #ifndef CHECK_ALL_CONSTANTS
7947 REprintf("ERROR: modification of compiler constant of type %s"
7948 ", length %d\n", CHAR(type2str(TYPEOF(ccopy))), length(ccopy));
7949 reportModifiedConstant(crec, corig, ccopy, -1);
7950 #else
7951 int nc = LENGTH(corig);
7952 /* some variables are volatile to prevent the compiler from
7953 optimizing them out, for easier debugging */
7954 volatile int ci;
7955 for(ci = 0; ci < nc; ci++) {
7956 volatile SEXP orig = VECTOR_ELT(corig, ci);
7957 volatile SEXP copy = VECTOR_ELT(ccopy, ci);
7958 if (!R_compute_identical(orig, copy, 39)) {
7959 REprintf("ERROR: modification of compiler constant"
7960 " of type %s, length %d\n",
7961 CHAR(type2str(TYPEOF(copy))), length(copy));
7962 reportModifiedConstant(crec, orig, copy, ci);
7963 }
7964 }
7965 #endif
7966 constsOK = FALSE;
7967 }
7968 }
7969
7970 if (!constsOK && abortOnError) {
7971 /* turn off constant checking to avoid infinite recursion through
7972 R_Suicide -> ... -> R_RunExitFinalizers -> R_checkConstants. */
7973 R_check_constants = 0;
7974 R_Suicide("compiler constants were modified!\n");
7975 }
7976
7977 return constsOK;
7978 }
7979
const_cleanup(void * data)7980 static void const_cleanup(void *data)
7981 {
7982 Rboolean *inProgress = (Rboolean *)data;
7983 *inProgress = FALSE;
7984 }
7985
7986 /* Checks if constants of any registered BCODESXP have been modified.
7987 Returns TRUE if the constants are ok, otherwise returns false or aborts.*/
R_checkConstants(Rboolean abortOnError)7988 Rboolean attribute_hidden R_checkConstants(Rboolean abortOnError)
7989 {
7990 if (R_check_constants <= 0 || R_ConstantsRegistry == NULL)
7991 return TRUE;
7992
7993 static Rboolean checkingInProgress = FALSE;
7994 RCNTXT cntxt;
7995
7996 if (checkingInProgress)
7997 /* recursive invocation is possible because of allocation
7998 in R_compute_identical */
7999 return TRUE;
8000
8001 /* set up context to recover checkingInProgress */
8002 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
8003 R_NilValue, R_NilValue);
8004 cntxt.cend = &const_cleanup;
8005 cntxt.cenddata = &checkingInProgress;
8006
8007 checkingInProgress = TRUE;
8008 SEXP prev_crec = R_ConstantsRegistry;
8009 SEXP crec = VECTOR_ELT(prev_crec, 0);
8010 Rboolean constsOK = TRUE;
8011 while(crec != R_NilValue) {
8012 SEXP wref = VECTOR_ELT(crec, 1);
8013 SEXP bc = R_WeakRefKey(wref);
8014 if (!checkConstantsInRecord(crec, abortOnError))
8015 constsOK = FALSE;
8016 if (bc == R_NilValue)
8017 /* remove no longer needed record from the registry */
8018 SET_VECTOR_ELT(prev_crec, 0, VECTOR_ELT(crec, 0));
8019 else
8020 prev_crec = crec;
8021 crec = VECTOR_ELT(crec, 0);
8022 }
8023 endcontext(&cntxt);
8024 checkingInProgress = FALSE;
8025 return constsOK;
8026 }
8027
do_mkcode(SEXP call,SEXP op,SEXP args,SEXP rho)8028 SEXP attribute_hidden do_mkcode(SEXP call, SEXP op, SEXP args, SEXP rho)
8029 {
8030 SEXP bytes, consts, ans;
8031
8032 checkArity(op, args);
8033 bytes = CAR(args);
8034 consts = CADR(args);
8035 ans = PROTECT(CONS(R_bcEncode(bytes), consts));
8036 SET_TYPEOF(ans, BCODESXP);
8037 R_registerBC(bytes, ans);
8038 UNPROTECT(1); /* ans */
8039 return ans;
8040 }
8041
do_bcclose(SEXP call,SEXP op,SEXP args,SEXP rho)8042 SEXP attribute_hidden do_bcclose(SEXP call, SEXP op, SEXP args, SEXP rho)
8043 {
8044 SEXP forms, body, env;
8045
8046 checkArity(op, args);
8047 forms = CAR(args);
8048 body = CADR(args);
8049 env = CADDR(args);
8050
8051 CheckFormals(forms);
8052
8053 if (! isByteCode(body))
8054 error(_("invalid body"));
8055
8056 if (isNull(env)) {
8057 error(_("use of NULL environment is defunct"));
8058 env = R_BaseEnv;
8059 } else
8060 if (!isEnvironment(env))
8061 error(_("invalid environment"));
8062
8063 return mkCLOSXP(forms, body, env);
8064 }
8065
do_is_builtin_internal(SEXP call,SEXP op,SEXP args,SEXP rho)8066 SEXP attribute_hidden do_is_builtin_internal(SEXP call, SEXP op, SEXP args, SEXP rho)
8067 {
8068 SEXP symbol, i;
8069
8070 checkArity(op, args);
8071 symbol = CAR(args);
8072
8073 if (!isSymbol(symbol))
8074 error(_("invalid symbol"));
8075
8076 if ((i = INTERNAL(symbol)) != R_NilValue && TYPEOF(i) == BUILTINSXP)
8077 return R_TrueValue;
8078 else
8079 return R_FalseValue;
8080 }
8081
disassemble(SEXP bc)8082 static SEXP disassemble(SEXP bc)
8083 {
8084 SEXP ans, dconsts;
8085 int i;
8086 SEXP code = BCODE_CODE(bc);
8087 SEXP consts = BCODE_CONSTS(bc);
8088 SEXP expr = BCODE_EXPR(bc);
8089 int nc = LENGTH(consts);
8090
8091 PROTECT(ans = allocVector(VECSXP, expr != R_NilValue ? 4 : 3));
8092 SET_VECTOR_ELT(ans, 0, install(".Code"));
8093 SET_VECTOR_ELT(ans, 1, R_bcDecode(code));
8094 SET_VECTOR_ELT(ans, 2, allocVector(VECSXP, nc));
8095 if (expr != R_NilValue)
8096 SET_VECTOR_ELT(ans, 3, duplicate(expr));
8097
8098 dconsts = VECTOR_ELT(ans, 2);
8099 for (i = 0; i < nc; i++) {
8100 SEXP c = VECTOR_ELT(consts, i);
8101 if (isByteCode(c))
8102 SET_VECTOR_ELT(dconsts, i, disassemble(c));
8103 else
8104 SET_VECTOR_ELT(dconsts, i, duplicate(c));
8105 }
8106
8107 UNPROTECT(1);
8108 return ans;
8109 }
8110
do_disassemble(SEXP call,SEXP op,SEXP args,SEXP rho)8111 SEXP attribute_hidden do_disassemble(SEXP call, SEXP op, SEXP args, SEXP rho)
8112 {
8113 SEXP code;
8114
8115 checkArity(op, args);
8116 code = CAR(args);
8117 if (! isByteCode(code))
8118 error(_("argument is not a byte code object"));
8119 return disassemble(code);
8120 }
8121
do_bcversion(SEXP call,SEXP op,SEXP args,SEXP rho)8122 SEXP attribute_hidden do_bcversion(SEXP call, SEXP op, SEXP args, SEXP rho)
8123 {
8124 checkArity(op, args);
8125 SEXP ans = allocVector(INTSXP, 1);
8126 INTEGER(ans)[0] = R_bcVersion;
8127 return ans;
8128 }
8129
8130 #ifdef UNUSED
8131 #define R_COMPILED_EXTENSION ".Rc"
8132
8133 /* neither of these functions call R_ExpandFileName -- the caller
8134 should do that if it wants to */
R_CompiledFileName(char * fname,char * buf,size_t bsize)8135 char *R_CompiledFileName(char *fname, char *buf, size_t bsize)
8136 {
8137 char *basename, *ext;
8138
8139 /* find the base name and the extension */
8140 basename = Rf_strrchr(fname, FILESEP[0]);
8141 if (basename == NULL) basename = fname;
8142 ext = Rf_strrchr(basename, '.');
8143
8144 if (ext != NULL && strcmp(ext, R_COMPILED_EXTENSION) == 0) {
8145 /* the supplied file name has the compiled file extension, so
8146 just copy it to the buffer and return the buffer pointer */
8147 if (snprintf(buf, bsize, "%s", fname) < 0)
8148 error("R_CompiledFileName: buffer too small");
8149 return buf;
8150 }
8151 else if (ext == NULL) {
8152 /* if the requested file has no extention, make a name that
8153 has the extenrion added on to the expanded name */
8154 if (snprintf(buf, bsize, "%s%s", fname, R_COMPILED_EXTENSION) < 0)
8155 error("R_CompiledFileName: buffer too small");
8156 return buf;
8157 }
8158 else {
8159 /* the supplied file already has an extension, so there is no
8160 corresponding compiled file name */
8161 return NULL;
8162 }
8163 }
8164
R_OpenCompiledFile(char * fname,char * buf,size_t bsize)8165 FILE *R_OpenCompiledFile(char *fname, char *buf, size_t bsize)
8166 {
8167 char *cname = R_CompiledFileName(fname, buf, bsize);
8168
8169 if (cname != NULL && R_FileExists(cname) &&
8170 (strcmp(fname, cname) == 0 ||
8171 ! R_FileExists(fname) ||
8172 R_FileMtime(cname) > R_FileMtime(fname)))
8173 /* the compiled file cname exists, and either fname does not
8174 exist, or it is the same as cname, or both exist and cname
8175 is newer */
8176 return R_fopen(buf, "rb");
8177 else return NULL;
8178 }
8179 #endif
8180
do_growconst(SEXP call,SEXP op,SEXP args,SEXP env)8181 SEXP attribute_hidden do_growconst(SEXP call, SEXP op, SEXP args, SEXP env)
8182 {
8183 SEXP constBuf, ans;
8184 int i, n;
8185
8186 checkArity(op, args);
8187 constBuf = CAR(args);
8188 if (TYPEOF(constBuf) != VECSXP)
8189 error(_("constant buffer must be a generic vector"));
8190
8191 n = LENGTH(constBuf);
8192 ans = allocVector(VECSXP, 2 * n);
8193 for (i = 0; i < n; i++)
8194 SET_VECTOR_ELT(ans, i, VECTOR_ELT(constBuf, i));
8195
8196 return ans;
8197 }
8198
do_putconst(SEXP call,SEXP op,SEXP args,SEXP env)8199 SEXP attribute_hidden do_putconst(SEXP call, SEXP op, SEXP args, SEXP env)
8200 {
8201 SEXP constBuf, x;
8202 int i, constCount;
8203
8204 checkArity(op, args);
8205
8206 constBuf = CAR(args);
8207 if (TYPEOF(constBuf) != VECSXP)
8208 error(_("constant buffer must be a generic vector"));
8209
8210 constCount = asInteger(CADR(args));
8211 if (constCount < 0 || constCount >= LENGTH(constBuf))
8212 error("bad constCount value");
8213
8214 x = CADDR(args);
8215
8216 /* check for a match and return index if one is found */
8217 for (i = 0; i < constCount; i++) {
8218 SEXP y = VECTOR_ELT(constBuf, i);
8219 /* 16 - take closure environments into account, this is necessary
8220 as closures (closure literals) can get into the AST when
8221 the AST is generated by a program (e.g. distr package)
8222 */
8223 if (x == y || R_compute_identical(x, y, 16))
8224 return ScalarInteger(i);
8225 }
8226
8227 /* otherwise insert the constant and return index */
8228 SET_VECTOR_ELT(constBuf, constCount, x);
8229 return ScalarInteger(constCount);
8230 }
8231
do_getconst(SEXP call,SEXP op,SEXP args,SEXP env)8232 SEXP attribute_hidden do_getconst(SEXP call, SEXP op, SEXP args, SEXP env)
8233 {
8234 SEXP constBuf, ans;
8235 int i, n;
8236
8237 checkArity(op, args);
8238 constBuf = CAR(args);
8239 n = asInteger(CADR(args));
8240
8241 if (TYPEOF(constBuf) != VECSXP)
8242 error(_("constant buffer must be a generic vector"));
8243 if (n < 0 || n > LENGTH(constBuf))
8244 error(_("bad constant count"));
8245
8246 ans = allocVector(VECSXP, n);
8247 for (i = 0; i < n; i++)
8248 SET_VECTOR_ELT(ans, i, VECTOR_ELT(constBuf, i));
8249
8250 return ans;
8251 }
8252
8253 #ifdef BC_PROFILING
do_bcprofcounts(SEXP call,SEXP op,SEXP args,SEXP env)8254 SEXP do_bcprofcounts(SEXP call, SEXP op, SEXP args, SEXP env)
8255 {
8256 SEXP val;
8257 int i;
8258
8259 checkArity(op, args);
8260 val = allocVector(INTSXP, OPCOUNT);
8261 for (i = 0; i < OPCOUNT; i++)
8262 INTEGER(val)[i] = opcode_counts[i];
8263 return val;
8264 }
8265
dobcprof(int sig)8266 static void dobcprof(int sig)
8267 {
8268 if (current_opcode >= 0 && current_opcode < OPCOUNT)
8269 opcode_counts[current_opcode]++;
8270 signal(SIGPROF, dobcprof);
8271 }
8272
do_bcprofstart(SEXP call,SEXP op,SEXP args,SEXP env)8273 SEXP do_bcprofstart(SEXP call, SEXP op, SEXP args, SEXP env)
8274 {
8275 struct itimerval itv;
8276 int interval;
8277 double dinterval = 0.02;
8278 int i;
8279
8280 checkArity(op, args);
8281 if (R_Profiling)
8282 error(_("profile timer in use"));
8283 if (bc_profiling)
8284 error(_("already byte code profiling"));
8285
8286 /* according to man setitimer, it waits until the next clock
8287 tick, usually 10ms, so avoid too small intervals here */
8288 interval = 1e6 * dinterval + 0.5;
8289
8290 /* initialize the profile data */
8291 current_opcode = NO_CURRENT_OPCODE;
8292 for (i = 0; i < OPCOUNT; i++)
8293 opcode_counts[i] = 0;
8294
8295 signal(SIGPROF, dobcprof);
8296
8297 itv.it_interval.tv_sec = interval / 1000000;
8298 itv.it_interval.tv_usec =
8299 (suseconds_t) (interval - itv.it_interval.tv_sec * 1000000);
8300 itv.it_value.tv_sec = interval / 1000000;
8301 itv.it_value.tv_usec =
8302 (suseconds_t) (interval - itv.it_value.tv_sec * 1000000);
8303 if (setitimer(ITIMER_PROF, &itv, NULL) == -1)
8304 error(_("setting profile timer failed"));
8305
8306 bc_profiling = TRUE;
8307
8308 return R_NilValue;
8309 }
8310
dobcprof_null(int sig)8311 static void dobcprof_null(int sig)
8312 {
8313 signal(SIGPROF, dobcprof_null);
8314 }
8315
do_bcprofstop(SEXP call,SEXP op,SEXP args,SEXP env)8316 SEXP do_bcprofstop(SEXP call, SEXP op, SEXP args, SEXP env)
8317 {
8318 struct itimerval itv;
8319
8320 checkArity(op, args);
8321 if (! bc_profiling)
8322 error(_("not byte code profiling"));
8323
8324 itv.it_interval.tv_sec = 0;
8325 itv.it_interval.tv_usec = 0;
8326 itv.it_value.tv_sec = 0;
8327 itv.it_value.tv_usec = 0;
8328 setitimer(ITIMER_PROF, &itv, NULL);
8329 signal(SIGPROF, dobcprof_null);
8330
8331 bc_profiling = FALSE;
8332
8333 return R_NilValue;
8334 }
8335 #else
do_bcprofcounts(SEXP call,SEXP op,SEXP args,SEXP env)8336 SEXP NORET do_bcprofcounts(SEXP call, SEXP op, SEXP args, SEXP env) {
8337 checkArity(op, args);
8338 error(_("byte code profiling is not supported in this build"));
8339 }
do_bcprofstart(SEXP call,SEXP op,SEXP args,SEXP env)8340 SEXP NORET do_bcprofstart(SEXP call, SEXP op, SEXP args, SEXP env) {
8341 checkArity(op, args);
8342 error(_("byte code profiling is not supported in this build"));
8343 }
do_bcprofstop(SEXP call,SEXP op,SEXP args,SEXP env)8344 SEXP NORET do_bcprofstop(SEXP call, SEXP op, SEXP args, SEXP env) {
8345 checkArity(op, args);
8346 error(_("byte code profiling is not supported in this build"));
8347 }
8348 #endif
8349
8350 /* end of byte code section */
8351
do_setnumthreads(SEXP call,SEXP op,SEXP args,SEXP rho)8352 SEXP attribute_hidden do_setnumthreads(SEXP call, SEXP op, SEXP args, SEXP rho)
8353 {
8354 int old = R_num_math_threads, new;
8355 checkArity(op, args);
8356 new = asInteger(CAR(args));
8357 if (new >= 0 && new <= R_max_num_math_threads)
8358 R_num_math_threads = new;
8359 return ScalarInteger(old);
8360 }
8361
do_setmaxnumthreads(SEXP call,SEXP op,SEXP args,SEXP rho)8362 SEXP attribute_hidden do_setmaxnumthreads(SEXP call, SEXP op, SEXP args, SEXP rho)
8363 {
8364 int old = R_max_num_math_threads, new;
8365 checkArity(op, args);
8366 new = asInteger(CAR(args));
8367 if (new >= 0) {
8368 R_max_num_math_threads = new;
8369 if (R_num_math_threads > R_max_num_math_threads)
8370 R_num_math_threads = R_max_num_math_threads;
8371 }
8372 return ScalarInteger(old);
8373 }
8374
do_returnValue(SEXP call,SEXP op,SEXP args,SEXP rho)8375 SEXP attribute_hidden do_returnValue(SEXP call, SEXP op, SEXP args, SEXP rho)
8376 {
8377 SEXP val;
8378 checkArity(op, args);
8379 if (R_ExitContext && (val = R_ExitContext->returnValue)){
8380 MARK_NOT_MUTABLE(val);
8381 return val;
8382 }
8383 return CAR(args); /* default */
8384 }
8385
8386 #include <Parse.h>
R_ParseEvalString(const char * str,SEXP env)8387 SEXP R_ParseEvalString(const char *str, SEXP env)
8388 {
8389 SEXP s = PROTECT(mkString(str));
8390
8391 ParseStatus status;
8392 SEXP ps = PROTECT(R_ParseVector(s, -1, &status, R_NilValue));
8393 if (status != PARSE_OK ||
8394 TYPEOF(ps) != EXPRSXP ||
8395 LENGTH(ps) != 1)
8396 error("parse error");
8397
8398 SEXP val = eval(VECTOR_ELT(ps, 0), env);
8399 UNPROTECT(2); /* s, ps */
8400 return val;
8401 }
8402