eval.c 187 KB
Newer Older
1
/*
2
 *  pqR : A pretty quick version of R
3
 *  Copyright (C) 2013, 2014, 2015, 2016, 2017 by Radford M. Neal
4 5
 *
 *  Based on R : A Computer Language for Statistical Data Analysis
Radford Neal's avatar
Radford Neal committed
6
 *  Copyright (C) 1995, 1996	Robert Gentleman and Ross Ihaka
7
 *  Copyright (C) 1998--2011	The R Core Team.
Radford Neal's avatar
Radford Neal committed
8
 *
9 10 11
 *  The changes in pqR from R-2.15.0 distributed by the R Core Team are
 *  documented in the NEWS and MODS files in the top-level source directory.
 *
Radford Neal's avatar
Radford Neal committed
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 */


#undef HASHING

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
Radford Neal's avatar
Radford Neal committed
33

34 35 36 37
#ifdef HAVE_ALLOCA_H
# include <alloca.h>
#endif

38
#define USE_FAST_PROTECT_MACROS
Radford Neal's avatar
Radford Neal committed
39
#define R_USE_SIGNALS 1
Radford Neal's avatar
Radford Neal committed
40 41 42 43
#include <Defn.h>
#include <Rinterface.h>
#include <Fileio.h>

44
#include "scalar-stack.h"
45 46
#include "arithmetic.h"

47 48
#include <helpers/helpers-app.h>

Radford Neal's avatar
Radford Neal committed
49

50
#define SCALAR_STACK_DEBUG 0
51 52


53 54
/* Inline version of findFun, meant to be fast when a special symbol is found 
   in the base environmet. */
55

56 57
static inline SEXP FINDFUN (SEXP symbol, SEXP rho)
{
Radford Neal's avatar
Radford Neal committed
58
    rho = SKIP_USING_SYMBITS (rho, symbol);
59 60 61 62 63

    if (rho == R_GlobalEnv && BASE_CACHE(symbol)) {
        SEXP res = SYMVALUE(symbol);
        if (TYPEOF(res) == PROMSXP)
            res = PRVALUE_PENDING_OK(res);
Radford Neal's avatar
Radford Neal committed
64 65
        if (isFunction(res))
            return res;
66 67 68 69
    }

    return findFun_nospecsym(symbol,rho);
}
70

71

Radford Neal's avatar
Radford Neal committed
72 73
#define ARGUSED(x) LEVELS(x)

Radford Neal's avatar
Radford Neal committed
74
static SEXP Rf_builtin_op_no_cntxt (SEXP op, SEXP e, SEXP rho, int variant);
Radford Neal's avatar
Radford Neal committed
75
static SEXP bcEval(SEXP, SEXP, Rboolean);
Radford Neal's avatar
Radford Neal committed
76 77 78 79 80 81

/*#define BC_PROFILING*/
#ifdef BC_PROFILING
static Rboolean bc_profiling = FALSE;
#endif

82
#define R_Profiling R_high_frequency_globals.Profiling
Radford Neal's avatar
Radford Neal committed
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291

#ifdef R_PROFILING

/* BDR 2000-07-15
   Profiling is now controlled by the R function Rprof(), and should
   have negligible cost when not enabled.
*/

/* A simple mechanism for profiling R code.  When R_PROFILING is
   enabled, eval will write out the call stack every PROFSAMPLE
   microseconds using the SIGPROF handler triggered by timer signals
   from the ITIMER_PROF timer.  Since this is the same timer used by C
   profiling, the two cannot be used together.  Output is written to
   the file PROFOUTNAME.  This is a plain text file.  The first line
   of the file contains the value of PROFSAMPLE.  The remaining lines
   each give the call stack found at a sampling point with the inner
   most function first.

   To enable profiling, recompile eval.c with R_PROFILING defined.  It
   would be possible to selectively turn profiling on and off from R
   and to specify the file name from R as well, but for now I won't
   bother.

   The stack is traced by walking back along the context stack, just
   like the traceback creation in jump_to_toplevel.  One drawback of
   this approach is that it does not show BUILTIN's since they don't
   get a context.  With recent changes to pos.to.env it seems possible
   to insert a context around BUILTIN calls to that they show up in
   the trace.  Since there is a cost in establishing these contexts,
   they are only inserted when profiling is enabled. [BDR: we have since
   also added contexts for the BUILTIN calls to foreign code.]

   One possible advantage of not tracing BUILTIN's is that then
   profiling adds no cost when the timer is turned off.  This would be
   useful if we want to allow profiling to be turned on and off from
   within R.

   One thing that makes interpreting profiling output tricky is lazy
   evaluation.  When an expression f(g(x)) is profiled, lazy
   evaluation will cause g to be called inside the call to f, so it
   will appear as if g is called by f.

   L. T.  */

#ifdef Win32
# define WIN32_LEAN_AND_MEAN 1
# include <windows.h>		/* for CreateEvent, SetEvent */
# include <process.h>		/* for _beginthread, _endthread */
#else
# ifdef HAVE_SYS_TIME_H
#  include <sys/time.h>
# endif
# include <signal.h>
#endif /* not Win32 */

static FILE *R_ProfileOutfile = NULL;
static int R_Mem_Profiling=0;
extern void get_current_mem(unsigned long *,unsigned long *,unsigned long *); /* in memory.c */
extern unsigned long get_duplicate_counter(void);  /* in duplicate.c */
extern void reset_duplicate_counter(void);         /* in duplicate.c */

#ifdef Win32
HANDLE MainThread;
HANDLE ProfileEvent;

static void doprof(void)
{
    RCNTXT *cptr;
    char buf[1100];
    unsigned long bigv, smallv, nodes;
    int len;

    buf[0] = '\0';
    SuspendThread(MainThread);
    if (R_Mem_Profiling){
	    get_current_mem(&smallv, &bigv, &nodes);
	    if((len = strlen(buf)) < 1000) {
		sprintf(buf+len, ":%ld:%ld:%ld:%ld:", smallv, bigv,
		     nodes, get_duplicate_counter());
	    }
	    reset_duplicate_counter();
    }
    for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
	if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
	    && TYPEOF(cptr->call) == LANGSXP) {
	    SEXP fun = CAR(cptr->call);
	    if(strlen(buf) < 1000) {
		strcat(buf, TYPEOF(fun) == SYMSXP ? CHAR(PRINTNAME(fun)) :
		       "<Anonymous>");
		strcat(buf, " ");
	    }
	}
    }
    ResumeThread(MainThread);
    if(strlen(buf))
	fprintf(R_ProfileOutfile, "%s\n", buf);
}

/* Profiling thread main function */
static void __cdecl ProfileThread(void *pwait)
{
    int wait = *((int *)pwait);

    SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_HIGHEST);
    while(WaitForSingleObject(ProfileEvent, wait) != WAIT_OBJECT_0) {
	doprof();
    }
}
#else /* not Win32 */
static void doprof(int sig)
{
    RCNTXT *cptr;
    int newline = 0;
    unsigned long bigv, smallv, nodes;
    if (R_Mem_Profiling){
	    get_current_mem(&smallv, &bigv, &nodes);
	    if (!newline) newline = 1;
	    fprintf(R_ProfileOutfile, ":%ld:%ld:%ld:%ld:", smallv, bigv,
		     nodes, get_duplicate_counter());
	    reset_duplicate_counter();
    }
    for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
	if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
	    && TYPEOF(cptr->call) == LANGSXP) {
	    SEXP fun = CAR(cptr->call);
	    if (!newline) newline = 1;
	    fprintf(R_ProfileOutfile, "\"%s\" ",
		    TYPEOF(fun) == SYMSXP ? CHAR(PRINTNAME(fun)) :
		    "<Anonymous>");
	}
    }
    if (newline) fprintf(R_ProfileOutfile, "\n");
    signal(SIGPROF, doprof);
}

static void doprof_null(int sig)
{
    signal(SIGPROF, doprof_null);
}
#endif /* not Win32 */


static void R_EndProfiling(void)
{
#ifdef Win32
    SetEvent(ProfileEvent);
    CloseHandle(MainThread);
#else /* not Win32 */
    struct itimerval itv;

    itv.it_interval.tv_sec = 0;
    itv.it_interval.tv_usec = 0;
    itv.it_value.tv_sec = 0;
    itv.it_value.tv_usec = 0;
    setitimer(ITIMER_PROF, &itv, NULL);
    signal(SIGPROF, doprof_null);
#endif /* not Win32 */
    if(R_ProfileOutfile) fclose(R_ProfileOutfile);
    R_ProfileOutfile = NULL;
    R_Profiling = 0;
}

static void R_InitProfiling(SEXP filename, int append, double dinterval, int mem_profiling)
{
#ifndef Win32
    struct itimerval itv;
#else
    int wait;
    HANDLE Proc = GetCurrentProcess();
#endif
    int interval;

    interval = 1e6 * dinterval + 0.5;
    if(R_ProfileOutfile != NULL) R_EndProfiling();
    R_ProfileOutfile = RC_fopen(filename, append ? "a" : "w", TRUE);
    if (R_ProfileOutfile == NULL)
	error(_("Rprof: cannot open profile file '%s'"),
	      translateChar(filename));
    if(mem_profiling)
	fprintf(R_ProfileOutfile, "memory profiling: sample.interval=%d\n", interval);
    else
	fprintf(R_ProfileOutfile, "sample.interval=%d\n", interval);

    R_Mem_Profiling=mem_profiling;
    if (mem_profiling)
	reset_duplicate_counter();

#ifdef Win32
    /* need to duplicate to make a real handle */
    DuplicateHandle(Proc, GetCurrentThread(), Proc, &MainThread,
		    0, FALSE, DUPLICATE_SAME_ACCESS);
    wait = interval/1000;
    if(!(ProfileEvent = CreateEvent(NULL, FALSE, FALSE, NULL)) ||
       (_beginthread(ProfileThread, 0, &wait) == -1))
	R_Suicide("unable to create profiling thread");
    Sleep(wait/2); /* suspend this thread to ensure that the other one starts */
#else /* not Win32 */
    signal(SIGPROF, doprof);

    itv.it_interval.tv_sec = 0;
    itv.it_interval.tv_usec = interval;
    itv.it_value.tv_sec = 0;
    itv.it_value.tv_usec = interval;
    if (setitimer(ITIMER_PROF, &itv, NULL) == -1)
	R_Suicide("setting profile timer failed");
#endif /* not Win32 */
    R_Profiling = 1;
}

292
static SEXP do_Rprof(SEXP call, SEXP op, SEXP args, SEXP rho)
Radford Neal's avatar
Radford Neal committed
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
{
    SEXP filename;
    int append_mode, mem_profiling;
    double dinterval;

#ifdef BC_PROFILING
    if (bc_profiling) {
	warning(_("can't use R profiling while byte code profiling"));
	return R_NilValue;
    }
#endif
    checkArity(op, args);
    if (!isString(CAR(args)) || (LENGTH(CAR(args))) != 1)
	error(_("invalid '%s' argument"), "filename");
    append_mode = asLogical(CADR(args));
    dinterval = asReal(CADDR(args));
    mem_profiling = asLogical(CADDDR(args));
    filename = STRING_ELT(CAR(args), 0);
    if (LENGTH(filename))
	R_InitProfiling(filename, append_mode, dinterval, mem_profiling);
    else
	R_EndProfiling();
    return R_NilValue;
}
#else /* not R_PROFILING */
318
static SEXP do_Rprof(SEXP call, SEXP op, SEXP args, SEXP rho)
Radford Neal's avatar
Radford Neal committed
319 320 321 322 323 324 325 326
{
    error(_("R profiling is not available on this system"));
}
#endif /* not R_PROFILING */

/* NEEDED: A fixup is needed in browser, because it can trap errors,
 *	and currently does not reset the limit to the right value. */

327 328 329 330
#define CHECK_STACK_BALANCE(o,s) do { \
  if (s != R_PPStackTop) check_stack_balance(o,s); \
} while (0)

Radford Neal's avatar
Radford Neal committed
331 332 333 334 335 336 337 338
void attribute_hidden check_stack_balance(SEXP op, int save)
{
    if(save == R_PPStackTop) return;
    REprintf("Warning: stack imbalance in '%s', %d then %d\n",
	     PRIMNAME(op), save, R_PPStackTop);
}


339 340 341 342 343 344 345 346
/* Wait until no value in an argument list is still being computed by a task.
   Macro version does preliminary check in-line for speed. */

#define WAIT_UNTIL_ARGUMENTS_COMPUTED(_args_) \
    do { \
        if (helpers_tasks > 0) { \
            SEXP _a_ = (_args_); \
            while (_a_ != R_NilValue) { \
347
                if (helpers_is_being_computed(CAR(_a_))) { \
348 349 350 351 352 353 354 355 356 357 358 359 360 361
                    wait_until_arguments_computed (_a_); \
                    break; \
                } \
                _a_ = CDR(_a_); \
            } \
        } \
    } while (0)

void attribute_hidden wait_until_arguments_computed (SEXP args)
{
    SEXP wait_for, a;

    if (helpers_tasks == 0) return;

362
    wait_for = R_NoObject;
363 364 365

    for (a = args; a != R_NilValue; a = CDR(a)) {
        SEXP this_arg = CAR(a);
366
        if (helpers_is_being_computed(this_arg)) {
367
            if (wait_for == R_NoObject)
368 369 370
                wait_for = this_arg;
            else {
                helpers_wait_until_not_being_computed2 (wait_for, this_arg);
371
                wait_for = R_NoObject;
372 373 374 375
            }
        }
    }

376
    if (wait_for != R_NoObject)
377 378 379
        helpers_wait_until_not_being_computed (wait_for);
}

380 381
/* e is protected here */
SEXP attribute_hidden forcePromiseUnbound (SEXP e, int variant)
Radford Neal's avatar
Radford Neal committed
382
{
Radford Neal's avatar
Radford Neal committed
383 384 385 386 387
    RPRSTACK prstack;
    SEXP val;

    PROTECT(e);

388
    if (PRSEEN(e)) PRSEEN_error_or_warning(e);
Radford Neal's avatar
Radford Neal committed
389

Radford Neal's avatar
Radford Neal committed
390 391 392 393 394 395 396 397
    /* Mark the promise as under evaluation and push it on a stack
       that can be used to unmark pending promises if a jump out
       of the evaluation occurs. */

    prstack.promise = e;
    prstack.next = R_PendingPromises;
    R_PendingPromises = &prstack;

Radford Neal's avatar
tweak  
Radford Neal committed
398 399
    SET_PRSEEN(e, 1);

400 401
    val = EVALV (PRCODE(e), PRENV(e), 
                 (variant & VARIANT_PENDING_OK) | VARIANT_MISSING_OK);
Radford Neal's avatar
Radford Neal committed
402

403
    /* Pop the stack, unmark the promise and set its value field. */
Radford Neal's avatar
Radford Neal committed
404 405 406

    R_PendingPromises = prstack.next;
    SET_PRSEEN(e, 0);
407 408
    SET_PRVALUE(e, val);
    INC_NAMEDCNT(val);
Radford Neal's avatar
Radford Neal committed
409

410
    /* Attempt to mimic past behaviour... */
411 412 413 414 415 416 417 418 419 420 421
    if (val == R_MissingArg) {
        if ( ! (variant & VARIANT_MISSING_OK) && TYPEOF(PRCODE(e)) == SYMSXP 
                  && R_isMissing (PRCODE(e), PRENV(e)))
            arg_missing_error(PRCODE(e));
    }
    else {
        /* Set the environment to R_NilValue to allow GC to
           reclaim the promise environment (unless value is R_MissingArg);
           this is also useful for fancy games with delayedAssign() */
        SET_PRENV(e, R_NilValue);
    }
Radford Neal's avatar
Radford Neal committed
422 423

    UNPROTECT(1);
424

Radford Neal's avatar
Radford Neal committed
425 426
    return val;
}
427

428
SEXP forcePromise (SEXP e) /* e protected here if necessary */
429 430
{
    if (PRVALUE(e) == R_UnboundValue) {
431
        return forcePromiseUnbound(e,0);
432
    }
Radford Neal's avatar
Radford Neal committed
433 434 435 436
    else
        return PRVALUE(e);
}

437 438 439 440 441 442 443 444 445 446 447 448 449 450 451

/* The "evalv" function returns the value of "e" evaluated in "rho",
   with given variant.  The caller must ensure that both SEXP
   arguments are protected.  The "eval" function is just like "evalv"
   with 0 for the variant return argument.

   The "Rf_evalv2" function, if it exists, is the main part of
   "evalv", split off so that constants may be evaluated with less
   overhead within "eval" or "evalv".  It may also be used in the
   EVALV macro in Defn.h. 

   Some optional tweaks can be done here, controlled by R_EVAL_TWEAKS,
   set to decimal integer XYZ.  If XYZ is zero, no tweaks are done.
   Otherwise, the meanings are

Radford Neal's avatar
Radford Neal committed
452
       Z = 1      Enable and use Rf_evalv2 (also done if X or Y is non-zero)
453
       Y = 1      Have eval do its own prelude, rather than just calling evalv
Radford Neal's avatar
Radford Neal committed
454
       X = 0      Have EVALV in Defn.h just call evalv here
455 456 457 458
           1      Have EVALV do its own prelude, then call evalv2
           2      Have EVALV do its own prelude and easy symbol stuff, then
                  call evalv2
 */
459 460 461 462

SEXP Rf_evalv2(SEXP,SEXP,int);
SEXP Rf_builtin_op (SEXP op, SEXP e, SEXP rho, int variant);

463 464
#define evalcount R_high_frequency_globals.evalcount

465 466 467 468 469 470 471 472 473 474
#define EVAL_PRELUDE do { \
\
    R_variant_result = 0; \
\
    /* Evaluate constants quickly, without the overhead that's necessary when \
       the computation might be complex.  This code is repeated in evalv2 \
       for when evalcount < 0.  That way we avoid calling any procedure \
       other than evalv2 in this procedure, possibly reducing overhead \
       for constant evaluation. */ \
\
475
    if (SELF_EVAL(TYPEOF(e)) && --evalcount >= 0) { \
476 477 478
	/* Make sure constants in expressions have maximum NAMEDCNT when \
	   used as values, so they won't be modified. */ \
        SET_NAMEDCNT_MAX(e); \
Radford Neal's avatar
Radford Neal committed
479
        R_Visible = TRUE; \
480 481 482
        return e; \
    } \
} while (0)
Radford Neal's avatar
Radford Neal committed
483

484
SEXP eval(SEXP e, SEXP rho)
485
{
486 487 488 489 490 491
#   if (R_EVAL_TWEAKS/10)%10 == 0
        return Rf_evalv(e,rho,0);
#   else
        EVAL_PRELUDE;
        return Rf_evalv2(e,rho,0);
#   endif
492 493 494
}

SEXP evalv(SEXP e, SEXP rho, int variant)
Radford Neal's avatar
Radford Neal committed
495
{
496
    if (0) {
497
        /* THE "IF" CONDITION ABOVE IS NORMALLY 0; CAN SET TO 1 FOR DEBUGGING.
498
           Enabling this zeroing of variant will test that callers who normally
Radford Neal's avatar
Radford Neal committed
499
           get a variant result can actually handle an ordinary result. */
500
        variant = 0;
Radford Neal's avatar
Radford Neal committed
501 502
    }

503
    EVAL_PRELUDE;
504 505 506

#if R_EVAL_TWEAKS > 0

507
    return Rf_evalv2(e,rho,variant);
508 509
}

510
SEXP attribute_hidden Rf_evalv2(SEXP e, SEXP rho, int variant)
511
{
512 513

#endif
514

515
    /* Handle check for user interrupt.  When negative, repeats check for 
516 517
       SELF_EVAL which may have already been done, but not acted on since
       evalcount went negative. */
518

519
    if (--evalcount < 0) {
520 521 522 523 524 525 526
        R_CheckUserInterrupt();
        evalcount = 1000;
        /* Evaluate constants quickly. */
        if (SELF_EVAL(TYPEOF(e))) {
            /* Make sure constants in expressions have maximum NAMEDCNT when
	       used as values, so they won't be modified. */
            SET_NAMEDCNT_MAX(e);
Radford Neal's avatar
Radford Neal committed
527
            R_Visible = TRUE;
528 529 530
            return e;
        }
    }
Radford Neal's avatar
Radford Neal committed
531

532 533
    SEXP op, res;

534
    R_EvalDepth += 1;
Radford Neal's avatar
Radford Neal committed
535 536 537

    if (R_EvalDepth > R_Expressions) {
	R_Expressions = R_Expressions_keep + 500;
538 539
	errorcall (R_NilValue /* avoids deparsing call in the error handler */,
         _("evaluation nested too deeply: infinite recursion / options(expressions=)?"));
Radford Neal's avatar
Radford Neal committed
540
    }
541

542
    R_CHECKSTACK();
Radford Neal's avatar
Radford Neal committed
543 544

#ifdef Win32
545
    /* This resets the precision, rounding and exception modes of a ix86 fpu. */
Radford Neal's avatar
Radford Neal committed
546 547 548
    __asm__ ( "fninit" );
#endif

549
    SEXPTYPE typeof_e = TYPEOF(e);
Radford Neal's avatar
Radford Neal committed
550

551
    if (typeof_e == SYMSXP) {
Radford Neal's avatar
Radford Neal committed
552

Radford Neal's avatar
Radford Neal committed
553
	if (e == R_DotsSymbol)
554
	    dotdotdot_error();
Radford Neal's avatar
Radford Neal committed
555

Radford Neal's avatar
Radford Neal committed
556 557
        R_Visible = TRUE;  /* May be set FALSE by active binding / lazy eval */

558 559
	res = DDVAL(e) ? ddfindVar(e,rho) : FIND_VAR_PENDING_OK (e, rho);

Radford Neal's avatar
Radford Neal committed
560
	if (res == R_UnboundValue)
561
            unbound_var_error(e);
562 563

        if (res == R_MissingArg) {
564
            if ( ! (variant & VARIANT_MISSING_OK))
565 566
                if (!DDVAL(e))  /* revert bug fix for the moment */
                    arg_missing_error(e);
567 568
        }
        else if (TYPEOF(res) == PROMSXP) {
Radford Neal's avatar
Radford Neal committed
569
            if (PRVALUE_PENDING_OK(res) == R_UnboundValue)
570 571
                res = forcePromiseUnbound(res,variant);
            else
Radford Neal's avatar
Radford Neal committed
572
                res = PRVALUE_PENDING_OK(res);
Radford Neal's avatar
Radford Neal committed
573 574 575 576 577 578
        }

        /* A NAMEDCNT of 0 might arise from an inadverently missing increment
           somewhere, or from a save/load sequence (since loaded values in
           promises have NAMEDCNT of 0), so fix up here... */

Radford Neal's avatar
Radford Neal committed
579 580
        if (NAMEDCNT_EQ_0(res))
            SET_NAMEDCNT_1(res);
Radford Neal's avatar
Radford Neal committed
581

Radford Neal's avatar
Radford Neal committed
582 583
        if ( ! (variant & VARIANT_PENDING_OK))
            WAIT_UNTIL_COMPUTED(res);
584
    }
Radford Neal's avatar
Radford Neal committed
585

586
    else if (typeof_e == LANGSXP) {
587

588 589
#       if SCALAR_STACK_DEBUG
            SEXP sv_stack = R_scalar_stack;
590 591
#       endif

592
        SEXP fn = CAR(e), args = CDR(e);
Radford Neal's avatar
Radford Neal committed
593

594
        if (TYPEOF(fn) == SYMSXP)
595
            op = FINDFUN(fn,rho);
596 597
        else
            op = eval(fn,rho);
598

599
	if (RTRACE(op)) R_trace_call(e,op);
600

601
	if (TYPEOF(op) == CLOSXP) {
602
            PROTECT(op);
603
	    res = applyClosure_v (e, op, promiseArgs(args,rho), rho, 
604
                                  R_NoObject, variant);
605
            UNPROTECT(1);
606 607 608 609
        }
	else {
            int save = R_PPStackTop;
            const void *vmax = VMAXGET();
610

611 612
            R_Visible = TRUE;

613
            if (TYPEOF(op) == SPECIALSXP)
614 615
                res = CALL_PRIMFUN (e, op, args, rho, variant);
            else if (TYPEOF(op) == BUILTINSXP)
Radford Neal's avatar
Radford Neal committed
616 617
                res = R_Profiling ? Rf_builtin_op(op, e, rho, variant)
                                  : Rf_builtin_op_no_cntxt(op, e, rho, variant);
618
            else
619
                apply_non_function_error();
620

621 622
            if (!R_Visible && PRIMPRINT(op) == 0)
                R_Visible = TRUE;
623

624 625 626
            CHECK_STACK_BALANCE(op, save);
            VMAXSET(vmax);
        }
627

628 629 630 631 632 633 634 635
#       if SCALAR_STACK_DEBUG
            if (variant & VARIANT_SCALAR_STACK_OK) {
                if (R_scalar_stack != sv_stack && (res != sv_stack 
                      || SCALAR_STACK_OFFSET(1) != sv_stack)) abort();
            }
            else {
                if (R_scalar_stack != sv_stack) abort();
            }
636
#       endif
637
    }
638

639
    else if (typeof_e == PROMSXP) {
640

641
	if (PRVALUE_PENDING_OK(e) == R_UnboundValue)
642
            res = forcePromiseUnbound(e,variant);
643
        else
644 645 646 647 648
            res = PRVALUE_PENDING_OK(e);

        if ( ! (variant & VARIANT_PENDING_OK))
            WAIT_UNTIL_COMPUTED(res);

Radford Neal's avatar
Radford Neal committed
649
        R_Visible = TRUE;
650 651 652 653 654
    }

    else if (typeof_e == BCODESXP) {

	res = bcEval(e, rho, TRUE);
Radford Neal's avatar
Radford Neal committed
655
    }
Radford Neal's avatar
Radford Neal committed
656

657 658 659 660 661 662
    else if (typeof_e == DOTSXP)
        dotdotdot_error();

    else
        UNIMPLEMENTED_TYPE("eval", e);

663
    R_EvalDepth -= 1;
664

665 666 667 668 669 670 671 672 673 674
#   if SCALAR_STACK_DEBUG /* Get debug output after typing SCALAR.STACK.DEBUG */
        if (ON_SCALAR_STACK(res) 
             && installed_already("SCALAR.STACK.DEBUG") != R_NoObject)
        { REprintf("SCALAR STACK VALUE RETURNED: %llx %llx %llx %s %f\n",
            (long long) R_scalar_stack_start,
            (long long) res, 
            (long long) R_scalar_stack,
            TYPEOF(res)==INTSXP ? "int" : "real",
            TYPEOF(res)==INTSXP ? (double)*INTEGER(res) : *REAL(res));
        }
675
#   endif
676

Radford Neal's avatar
Radford Neal committed
677 678
    return res;
}
679

680 681 682 683 684 685

/* Like Rf_builtin_op (defined in builtin.c) except that no context is
   created.  Making this separate from Rf_builtin_op saves on stack
   space for the local context variable.  Since the somewhat
   time-consuming context creation is not done, there is no advantage
   to evaluating a single argument with pending OK. */
Radford Neal's avatar
Radford Neal committed
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705

static SEXP Rf_builtin_op_no_cntxt (SEXP op, SEXP e, SEXP rho, int variant)
{
    SEXP args = CDR(e);
    SEXP arg1;
    SEXP res;

    /* See if this may be a fast primitive.  All fast primitives
       should be BUILTIN.  We do a fast call only if there is exactly
       one argument, with no tag, not missing or a ... argument.  
       The argument is stored in arg1. */

    if (args!=R_NilValue) {
        if (PRIMFUN_FAST(op) 
              && TAG(args)==R_NilValue && CDR(args)==R_NilValue
              && (arg1 = CAR(args))!=R_DotsSymbol 
              && arg1!=R_MissingArg && arg1!=R_MissingUnder) {

            PROTECT(arg1 = EVALV (arg1, rho, PRIMFUN_ARG1VAR(op)));

Radford Neal's avatar
Radford Neal committed
706
            if (isObject(arg1) && PRIMFUN_DSPTCH1(op)) {
707 708 709
                if ((PRIMFUN_ARG1VAR (op) & VARIANT_UNCLASS)
                       && (R_variant_result & VARIANT_UNCLASS_FLAG)) {
                    R_variant_result &= ~VARIANT_UNCLASS_FLAG;
Radford Neal's avatar
Radford Neal committed
710 711 712 713 714 715
                }
                else {
                    UNPROTECT(1);
                    PROTECT(args = CONS(arg1,R_NilValue));
                    goto not_fast;
                }
Radford Neal's avatar
Radford Neal committed
716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737
            }

            res = ((SEXP(*)(SEXP,SEXP,SEXP,SEXP,int)) PRIMFUN_FAST(op)) 
                     (e, op, arg1, rho, variant);

            UNPROTECT(1);  /* arg1 */
            return res;
        }

        args = evalList (args, rho);
    }

    PROTECT(args);

    /* Handle a non-fast op.  We may get here after starting to handle a
       fast op, but if so, args has been set to the evaluated argument list. */

  not_fast: 

    res = CALL_PRIMFUN(e, op, args, rho, variant);

    UNPROTECT(1); /* args */
738 739 740
    return res;
}

Radford Neal's avatar
Radford Neal committed
741

Radford Neal's avatar
Radford Neal committed
742 743 744 745 746 747
attribute_hidden
void SrcrefPrompt(const char * prefix, SEXP srcref)
{
    /* If we have a valid srcref, use it */
    if (srcref && srcref != R_NilValue) {
        if (TYPEOF(srcref) == VECSXP) srcref = VECTOR_ELT(srcref, 0);
748
	SEXP srcfile = getAttrib00(srcref, R_SrcfileSymbol);
Radford Neal's avatar
Radford Neal committed
749 750
	if (TYPEOF(srcfile) == ENVSXP) {
	    SEXP filename = findVar(install("filename"), srcfile);
Radford Neal's avatar
Radford Neal committed
751
	    if (isString(filename) && length(filename)) {
Radford Neal's avatar
Radford Neal committed
752 753 754 755 756 757 758 759 760 761 762 763
	    	Rprintf(_("%s at %s#%d: "), prefix, CHAR(STRING_ELT(filename, 0)), 
	                                    asInteger(srcref));
	        return;
	    }
	}
    }
    /* default: */
    Rprintf("%s: ", prefix);
}

/* Apply SEXP op of type CLOSXP to actuals */

Radford Neal's avatar
Radford Neal committed
764 765 766 767 768 769 770 771 772 773 774
static void loadCompilerNamespace(void)
{
    SEXP fun, arg, expr;

    PROTECT(fun = install("getNamespace"));
    PROTECT(arg = mkString("compiler"));
    PROTECT(expr = lang2(fun, arg));
    eval(expr, R_GlobalEnv);
    UNPROTECT(3);
}

Radford Neal's avatar
Radford Neal committed
775 776
static int R_disable_bytecode = 0;

Radford Neal's avatar
Radford Neal committed
777 778 779
void attribute_hidden R_init_jit_enabled(void)
{
    if (R_jit_enabled <= 0) {
Radford Neal's avatar
Radford Neal committed
780
        R_jit_enabled = 0;  /* never do JIT now */
Radford Neal's avatar
Radford Neal committed
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
	char *enable = getenv("R_ENABLE_JIT");
	if (enable != NULL) {
	    int val = atoi(enable);
	    if (val > 0)
		loadCompilerNamespace();
	    R_jit_enabled = val;
	}
    }

    if (R_compile_pkgs <= 0) {
	char *compile = getenv("R_COMPILE_PKGS");
	if (compile != NULL) {
	    int val = atoi(compile);
	    if (val > 0)
		R_compile_pkgs = TRUE;
	    else
		R_compile_pkgs = FALSE;
	}
799 800 801
        char *doit = getenv("R_PKG_BYTECOMPILE");
        if (doit == NULL || strcmp(doit,"TRUE") != 0)
            R_compile_pkgs = FALSE;
Radford Neal's avatar
Radford Neal committed
802
    }
Radford Neal's avatar
Radford Neal committed
803 804 805 806 807 808 809 810 811 812

    if (R_disable_bytecode <= 0) {
	char *disable = getenv("R_DISABLE_BYTECODE");
	if (disable != NULL) {
	    int val = atoi(disable);
	    if (val > 0)
		R_disable_bytecode = TRUE;
	    else
		R_disable_bytecode = FALSE;
	}
813 814 815
        char *use = getenv("R_USE_BYTECODE");
        if (use == NULL || strcmp(use,"TRUE") != 0)
            R_disable_bytecode = TRUE;
Radford Neal's avatar
Radford Neal committed
816
    }
Radford Neal's avatar
Radford Neal committed
817 818 819 820 821 822 823
}
    
SEXP attribute_hidden R_cmpfun(SEXP fun)
{
    SEXP packsym, funsym, call, fcall, val;

    packsym = install("compiler");
Radford Neal's avatar
Radford Neal committed
824
    funsym = install("tryCmpfun");
Radford Neal's avatar
Radford Neal committed
825

Radford Neal's avatar
Radford Neal committed
826
    PROTECT(fcall = lang3(R_TripleColonSymbol, packsym, funsym));
Radford Neal's avatar
Radford Neal committed
827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860
    PROTECT(call = lang2(fcall, fun));
    val = eval(call, R_GlobalEnv);
    UNPROTECT(2);
    return val;
}

static SEXP R_compileExpr(SEXP expr, SEXP rho)
{
    SEXP packsym, funsym, quotesym;
    SEXP qexpr, call, fcall, val;

    packsym = install("compiler");
    funsym = install("compile");
    quotesym = install("quote");

    PROTECT(fcall = lang3(R_DoubleColonSymbol, packsym, funsym));
    PROTECT(qexpr = lang2(quotesym, expr));
    PROTECT(call = lang3(fcall, qexpr, rho));
    val = eval(call, R_GlobalEnv);
    UNPROTECT(3);
    return val;
}

static SEXP R_compileAndExecute(SEXP call, SEXP rho)
{
    int old_enabled = R_jit_enabled;
    SEXP code, val;

    R_jit_enabled = 0;
    PROTECT(call);
    PROTECT(rho);
    PROTECT(code = R_compileExpr(call, rho));
    R_jit_enabled = old_enabled;

Radford Neal's avatar
Radford Neal committed
861
    val = bcEval(code, rho, TRUE);
Radford Neal's avatar
Radford Neal committed
862 863 864 865
    UNPROTECT(3);
    return val;
}

866
static SEXP do_enablejit(SEXP call, SEXP op, SEXP args, SEXP rho)
Radford Neal's avatar
Radford Neal committed
867
{
Radford Neal's avatar
Radford Neal committed
868 869 870
    R_jit_enabled = 0;  /* never use JIT now */
    return ScalarIntegerMaybeConst(0);

Radford Neal's avatar
Radford Neal committed
871 872 873 874 875 876
    int old = R_jit_enabled, new;
    checkArity(op, args);
    new = asInteger(CAR(args));
    if (new > 0)
	loadCompilerNamespace();
    R_jit_enabled = new;
877
    return ScalarIntegerMaybeConst(old);
Radford Neal's avatar
Radford Neal committed
878 879
}

880
static SEXP do_compilepkgs(SEXP call, SEXP op, SEXP args, SEXP rho)
Radford Neal's avatar
Radford Neal committed
881 882 883 884 885 886 887
{
    int old = R_compile_pkgs, new;
    checkArity(op, args);
    new = asLogical(CAR(args));
    if (new != NA_LOGICAL && new)
	loadCompilerNamespace();
    R_compile_pkgs = new;
888
    return ScalarLogicalMaybeConst(old);
Radford Neal's avatar
Radford Neal committed
889 890 891 892
}

/* forward declaration */
static SEXP bytecodeExpr(SEXP);
Radford Neal's avatar
Radford Neal committed
893

894
/* This function gets the srcref attribute from a statement block, 
Radford Neal's avatar
Radford Neal committed
895 896
   and confirms it's in the expected format */
   
897
static R_INLINE void getBlockSrcrefs(SEXP call, SEXP **refs, int *len)
Radford Neal's avatar
Radford Neal committed
898
{
899
    SEXP srcrefs = getAttrib00(call, R_SrcrefSymbol);
900
    if (TYPEOF(srcrefs) == VECSXP) {
901
        *refs = (SEXP *) DATAPTR(srcrefs);
902 903 904 905 906
        *len = LENGTH(srcrefs);
    }
    else
    {   *len = 0;
    }
Radford Neal's avatar
Radford Neal committed
907 908
}

909 910
/* This function extracts one srcref, and confirms the format.  It is 
   passed an index and the array and length from getBlockSrcrefs. */
Radford Neal's avatar
Radford Neal committed
911

912
static R_INLINE SEXP getSrcref(SEXP *refs, int len, int ind)
Radford Neal's avatar
Radford Neal committed
913
{
914 915 916 917 918 919 920
    if (ind < len) {
        SEXP result = refs[ind];
        if (TYPEOF(result) == INTSXP && LENGTH(result) >= 6)
            return result;
    }

    return R_NilValue;
Radford Neal's avatar
Radford Neal committed
921
}
Radford Neal's avatar
Radford Neal committed
922

923
static void printcall (SEXP call, SEXP rho)
924 925 926 927 928 929 930 931
{
    int old_bl = R_BrowseLines;
    int blines = asInteger(GetOption1(install("deparse.max.lines")));
    if (blines != NA_INTEGER && blines > 0) R_BrowseLines = blines;
    PrintValueRec(call,rho);
    R_BrowseLines = old_bl;
}

932 933 934 935 936 937 938
static void start_browser (SEXP call, SEXP op, SEXP stmt, SEXP env)
{
    SrcrefPrompt("debug", R_Srcref);
    PrintValue(stmt);
    do_browser(call, op, R_NilValue, env);
}

939 940
SEXP attribute_hidden applyClosure_v(SEXP call, SEXP op, SEXP arglist, SEXP rho,
                                     SEXP suppliedenv, int variant)
Radford Neal's avatar
Radford Neal committed
941
{
942 943 944
    int vrnt = VARIANT_PENDING_OK | VARIANT_DIRECT_RETURN 
                 | VARIANT_PASS_ON(variant);

945
    SEXP formals, actuals, savedrho, savedsrcref;
Radford Neal's avatar
Radford Neal committed
946
    volatile SEXP body, newrho;
Radford Neal's avatar
Radford Neal committed
947
    SEXP f, a, res;
Radford Neal's avatar
Radford Neal committed
948 949
    RCNTXT cntxt;

950
    PROTECT2(op,arglist);
Radford Neal's avatar
Radford Neal committed
951 952 953 954 955

    formals = FORMALS(op);
    body = BODY(op);
    savedrho = CLOENV(op);

Radford Neal's avatar
Radford Neal committed
956 957 958 959 960 961 962 963 964 965
    if (R_jit_enabled > 0 && TYPEOF(body) != BCODESXP) {
	int old_enabled = R_jit_enabled;
	SEXP newop;
	R_jit_enabled = 0;
	newop = R_cmpfun(op);
	body = BODY(newop);
	SET_BODY(op, body);
	R_jit_enabled = old_enabled;
    }

966 967
    /*  Set up a context with the call in it for use if an error occurs below
        in matchArgs or from running out of memory (eg, in NewEnvironment). */
Radford Neal's avatar
Radford Neal committed
968 969

    begincontext(&cntxt, CTXT_RETURN, call, savedrho, rho, arglist, op);
970
    savedsrcref = R_Srcref;  /* saved in context for longjmp, and protection */
Radford Neal's avatar
Radford Neal committed
971 972 973

    /*  Build a list which matches the actual (unevaluated) arguments
	to the formal paramters.  Build a new environment which
974 975
	contains the matched pairs.  Note that actuals is protected via
        newrho. */
Radford Neal's avatar
Radford Neal committed
976

977
    actuals = matchArgs(formals, NULL, 0, arglist, call);
978 979
    PROTECT(newrho = NewEnvironment(R_NilValue, actuals, savedrho));
        /* no longer passes formals, since matchArg now puts tags in actuals */
Radford Neal's avatar
Radford Neal committed
980 981 982 983 984 985 986 987 988 989 990 991

    /* This piece of code is destructively modifying the actuals list,
       which is now also the list of bindings in the frame of newrho.
       This is one place where internal structure of environment
       bindings leaks out of envir.c.  It should be rewritten
       eventually so as not to break encapsulation of the internal
       environment layout.  We can live with it for now since it only
       happens immediately after the environment creation.  LT */

    f = formals;
    a = actuals;
    while (f != R_NilValue) {
992
	if (MISSING(a) && CAR(f) != R_MissingArg) {
Radford Neal's avatar
Radford Neal committed
993 994 995 996 997 998 999
	    SETCAR(a, mkPROMISE(CAR(f), newrho));
	    SET_MISSING(a, 2);
	}
	f = CDR(f);
	a = CDR(a);
    }

1000
    set_symbits_in_env (newrho);
1001

Radford Neal's avatar
Radford Neal committed
1002 1003
    /*  Fix up any extras that were supplied by usemethod. */

1004
    if (suppliedenv != R_NoObject) {
Radford Neal's avatar
Radford Neal committed
1005
	for (SEXP t = FRAME(suppliedenv); t != R_NilValue; t = CDR(t)) {
Radford Neal's avatar
Radford Neal committed
1006
	    for (a = actuals; a != R_NilValue; a = CDR(a))
Radford Neal's avatar
Radford Neal committed
1007
		if (TAG(a) == TAG(t))
Radford Neal's avatar
Radford Neal committed
1008 1009
		    break;
	    if (a == R_NilValue)
Radford Neal's avatar
Radford Neal committed
1010
		set_var_in_frame (TAG(t), CAR(t), newrho, TRUE, 3);
Radford Neal's avatar
Radford Neal committed
1011 1012 1013
	}
    }

1014
    UNPROTECT(1); /* newrho, which will be protected below via revised context*/
Radford Neal's avatar
Radford Neal committed
1015

1016
    /*  Change the previously-set-up context to have the correct environment.
Radford Neal's avatar
Radford Neal committed
1017

1018
        If we have a generic function we need to use the sysparent of
Radford Neal's avatar
Radford Neal committed
1019
	the generic as the sysparent of the method because the method
1020
	is a straight substitution of the generic. */
Radford Neal's avatar
Radford Neal committed
1021

1022 1023
    if (R_GlobalContext->nextcontext->callflag == CTXT_GENERIC)
	revisecontext (newrho, R_GlobalContext->nextcontext->sysparent);
Radford Neal's avatar
Radford Neal committed
1024
    else
1025
	revisecontext (newrho, rho);
Radford Neal's avatar
Radford Neal committed
1026

1027 1028
    /* Get the srcref record from the closure object */
    
1029
    R_Srcref = getAttrib00(op, R_SrcrefSymbol);
Radford Neal's avatar
Radford Neal committed
1030 1031 1032

    /* Debugging */

1033 1034 1035 1036
    if (RDEBUG(op) | RSTEP(op)) {
        SET_RDEBUG(newrho, 1);
        if (RSTEP(op)) SET_RSTEP(op, 0);
	SEXP savesrcref; SEXP *srcrefs; int len;
Radford Neal's avatar
Radford Neal committed
1037 1038 1039
	/* switch to interpreted version when debugging compiled code */
	if (TYPEOF(body) == BCODESXP)
	    body = bytecodeExpr(body);
Radford Neal's avatar
Radford Neal committed
1040
	Rprintf("debugging in: ");
1041
        printcall(call,rho);
Radford Neal's avatar
Radford Neal committed
1042
	savesrcref = R_Srcref;
1043 1044 1045
	getBlockSrcrefs(body,&srcrefs,&len);
	PROTECT(R_Srcref = getSrcref(srcrefs,len,0));
        start_browser (call, op, body, newrho);
Radford Neal's avatar
Radford Neal committed
1046 1047
	R_Srcref = savesrcref;
	UNPROTECT(1);
Radford Neal's avatar
Radford Neal committed
1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075
    }

    /*  It isn't completely clear that this is the right place to do
	this, but maybe (if the matchArgs above reverses the
	arguments) it might just be perfect.

	This will not currently work as the entry points in envir.c
	are static.
    */

#ifdef  HASHING
    {
	SEXP R_NewHashTable(int);
	SEXP R_HashFrame(SEXP);
	int nargs = length(arglist);
	HASHTAB(newrho) = R_NewHashTable(nargs);
	newrho = R_HashFrame(newrho);
    }
#endif
#undef  HASHING

    /*  Set a longjmp target which will catch any explicit returns
	from the function body.  */

    if ((SETJMP(cntxt.cjmpbuf))) {
	if (R_ReturnedValue == R_RestartToken) {
	    cntxt.callflag = CTXT_RETURN;  /* turn restart off */
	    R_ReturnedValue = R_NilValue;  /* remove restart token */
Radford Neal's avatar
Radford Neal committed
1076
	    PROTECT(res = evalv (body, newrho, vrnt));
Radford Neal's avatar
Radford Neal committed
1077
	}
1078
	else {
Radford Neal's avatar
Radford Neal committed
1079
	    PROTECT(res = R_ReturnedValue);
1080
        }
Radford Neal's avatar
Radford Neal committed
1081 1082
    }
    else {
Radford Neal's avatar
Radford Neal committed
1083
	PROTECT(res = evalv (body, newrho, vrnt));
Radford Neal's avatar
Radford Neal committed
1084 1085
    }

Radford Neal's avatar
Radford Neal committed
1086 1087
    R_variant_result &= ~VARIANT_RTN_FLAG;

1088
    R_Srcref = savedsrcref;
Radford Neal's avatar
Radford Neal committed
1089 1090
    endcontext(&cntxt);

Radford Neal's avatar
Radford Neal committed
1091 1092 1093
    if ( ! (variant & VARIANT_PENDING_OK))
        WAIT_UNTIL_COMPUTED(res);

Radford Neal's avatar
Radford Neal committed
1094 1095
    if (RDEBUG(op)) {
	Rprintf("exiting from: ");
1096
        printcall(call,rho);
Radford Neal's avatar
Radford Neal committed
1097
    }
Radford Neal's avatar
Radford Neal committed
1098

1099
    UNPROTECT(3); /* op, arglist, res */
Radford Neal's avatar
Radford Neal committed
1100
    return res;
Radford Neal's avatar
Radford Neal committed
1101 1102
}

1103 1104 1105 1106 1107 1108
SEXP applyClosure (SEXP call, SEXP op, SEXP arglist, SEXP rho, 
                   SEXP suppliedenv)
{
  return applyClosure_v (call, op, arglist, rho, suppliedenv, 0);
}

Radford Neal's avatar
Radford Neal committed
1109 1110 1111 1112 1113 1114
/* **** FIXME: This code is factored out of applyClosure.  If we keep
   **** it we should change applyClosure to run through this routine
   **** to avoid code drift. */
static SEXP R_execClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho,
			  SEXP newrho)
{
Radford Neal's avatar
Radford Neal committed
1115
    volatile SEXP body;
1116
    SEXP res, savedsrcref;
Radford Neal's avatar
Radford Neal committed
1117 1118
    RCNTXT cntxt;

1119 1120
    PROTECT2(op,arglist);

Radford Neal's avatar
Radford Neal committed
1121 1122
    body = BODY(op);

Radford Neal's avatar
Radford Neal committed
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132
    if (R_jit_enabled > 0 && TYPEOF(body) != BCODESXP) {
	int old_enabled = R_jit_enabled;
	SEXP newop;
	R_jit_enabled = 0;
	newop = R_cmpfun(op);
	body = BODY(newop);
	SET_BODY(op, body);
	R_jit_enabled = old_enabled;
    }

Radford Neal's avatar
Radford Neal committed
1133
    begincontext(&cntxt, CTXT_RETURN, call, newrho, rho, arglist, op);
1134
    savedsrcref = R_Srcref;  /* saved in context for longjmp, and protection */
Radford Neal's avatar
Radford Neal committed
1135

1136 1137 1138
    /* Get the srcref record from the closure object.  Disable for now
       at least, since it's not clear that it's needed. */
    
1139
    R_Srcref = R_NilValue;  /* was: getAttrib(op, R_SrcrefSymbol); */
1140

Radford Neal's avatar
Radford Neal committed
1141 1142
    /* Debugging */

1143 1144 1145 1146
    if (RDEBUG(op) | RSTEP(op)) {
        SET_RDEBUG(newrho, 1);
        if (RSTEP(op)) SET_RSTEP(op, 0);
        SEXP savesrcref; SEXP *srcrefs; int len;
Radford Neal's avatar
Radford Neal committed
1147 1148 1149
	/* switch to interpreted version when debugging compiled code */
	if (TYPEOF(body) == BCODESXP)
	    body = bytecodeExpr(body);
Radford Neal's avatar
Radford Neal committed
1150
	Rprintf("debugging in: ");
1151
	printcall (call, rho);
Radford Neal's avatar
Radford Neal committed
1152
	savesrcref = R_Srcref;
1153 1154 1155
	getBlockSrcrefs(body,&srcrefs,&len);
	PROTECT(R_Srcref = getSrcref(srcrefs,len,0));
        start_browser (call, op, body, newrho);
Radford Neal's avatar
Radford Neal committed
1156 1157
	R_Srcref = savesrcref;
	UNPROTECT(1);
Radford Neal's avatar
Radford Neal committed
1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182
    }

    /*  It isn't completely clear that this is the right place to do
	this, but maybe (if the matchArgs above reverses the
	arguments) it might just be perfect.  */

#ifdef  HASHING
#define HASHTABLEGROWTHRATE  1.2
    {
	SEXP R_NewHashTable(int, double);
	SEXP R_HashFrame(SEXP);
	int nargs = length(arglist);
	HASHTAB(newrho) = R_NewHashTable(nargs, HASHTABLEGROWTHRATE);
	newrho = R_HashFrame(newrho);
    }
#endif
#undef  HASHING

    /*  Set a longjmp target which will catch any explicit returns
	from the function body.  */

    if ((SETJMP(cntxt.cjmpbuf))) {
	if (R_ReturnedValue == R_RestartToken) {
	    cntxt.callflag = CTXT_RETURN;  /* turn restart off */
	    R_ReturnedValue = R_NilValue;  /* remove restart token */
Radford Neal's avatar
Radford Neal committed
1183
	    PROTECT(res = eval(body, newrho));
Radford Neal's avatar
Radford Neal committed
1184
	}
1185
	else {
Radford Neal's avatar
Radford Neal committed
1186 1187
	    PROTECT(res = R_ReturnedValue);
            WAIT_UNTIL_COMPUTED(res);
1188
        }
Radford Neal's avatar
Radford Neal committed
1189 1190
    }
    else {
Radford Neal's avatar
Radford Neal committed
1191
	PROTECT(res = eval(body, newrho));
Radford Neal's avatar
Radford Neal committed
1192 1193
    }

1194
    R_Srcref = savedsrcref;
Radford Neal's avatar
Radford Neal committed
1195 1196 1197 1198
    endcontext(&cntxt);

    if (RDEBUG(op)) {
	Rprintf("exiting from: ");
1199
	printcall (call, rho);
Radford Neal's avatar
Radford Neal committed
1200
    }
Radford Neal's avatar
Radford Neal committed
1201

1202
    UNPROTECT(3);  /* op, arglist, res */
Radford Neal's avatar
Radford Neal committed
1203
    return res;
Radford Neal's avatar
Radford Neal committed
1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229
}

/* **** FIXME: Temporary code to execute S4 methods in a way that
   **** preserves lexical scope. */

/* called from methods_list_dispatch.c */
SEXP R_execMethod(SEXP op, SEXP rho)
{
    SEXP call, arglist, callerenv, newrho, next, val;
    RCNTXT *cptr;

    /* create a new environment frame enclosed by the lexical
       environment of the method */
    PROTECT(newrho = Rf_NewEnvironment(R_NilValue, R_NilValue, CLOENV(op)));

    /* copy the bindings for the formal environment from the top frame
       of the internal environment of the generic call to the new
       frame.  need to make sure missingness information is preserved
       and the environments for any default expression promises are
       set to the new environment.  should move this to envir.c where
       it can be done more efficiently. */
    for (next = FORMALS(op); next != R_NilValue; next = CDR(next)) {
	SEXP symbol =  TAG(next);
	R_varloc_t loc;
	int missing;
	loc = R_findVarLocInFrame(rho,symbol);
1230
	if (loc == R_NoObject)
Radford Neal's avatar
Radford Neal committed
1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286
	    error(_("could not find symbol \"%s\" in environment of the generic function"),
		  CHAR(PRINTNAME(symbol)));
	missing = R_GetVarLocMISSING(loc);
	val = R_GetVarLocValue(loc);
	SET_FRAME(newrho, CONS(val, FRAME(newrho)));
	SET_TAG(FRAME(newrho), symbol);
	if (missing) {
	    SET_MISSING(FRAME(newrho), missing);
	    if (TYPEOF(val) == PROMSXP && PRENV(val) == rho) {
		SEXP deflt;
		SET_PRENV(val, newrho);
		/* find the symbol in the method, copy its expression
		 * to the promise */
		for(deflt = CAR(op); deflt != R_NilValue; deflt = CDR(deflt)) {
		    if(TAG(deflt) == symbol)
			break;
		}
		if(deflt == R_NilValue)
		    error(_("symbol \"%s\" not in environment of method"),
			  CHAR(PRINTNAME(symbol)));
		SET_PRCODE(val, CAR(deflt));
	    }
	}
    }

    /* copy the bindings of the spacial dispatch variables in the top
       frame of the generic call to the new frame */
    defineVar(R_dot_defined, findVarInFrame(rho, R_dot_defined), newrho);
    defineVar(R_dot_Method, findVarInFrame(rho, R_dot_Method), newrho);
    defineVar(R_dot_target, findVarInFrame(rho, R_dot_target), newrho);

    /* copy the bindings for .Generic and .Methods.  We know (I think)
       that they are in the second frame, so we could use that. */
    defineVar(R_dot_Generic, findVar(R_dot_Generic, rho), newrho);
    defineVar(R_dot_Methods, findVar(R_dot_Methods, rho), newrho);

    /* Find the calling context.  Should be R_GlobalContext unless
       profiling has inserted a CTXT_BUILTIN frame. */
    cptr = R_GlobalContext;
    if (cptr->callflag & CTXT_BUILTIN)
	cptr = cptr->nextcontext;

    /* The calling environment should either be the environment of the
       generic, rho, or the environment of the caller of the generic,
       the current sysparent. */
    callerenv = cptr->sysparent; /* or rho? */

    /* get the rest of the stuff we need from the current context,
       execute the method, and return the result */
    call = cptr->call;
    arglist = cptr->promargs;
    val = R_execClosure(call, op, arglist, callerenv, newrho);
    UNPROTECT(1);
    return val;
}

1287
                                  /* Caller needn't protect the s arg below */
1288
static R_INLINE Rboolean asLogicalNoNA(SEXP s, SEXP call)
Radford Neal's avatar
Radford Neal committed
1289
{
1290
    int len, cond;
Radford Neal's avatar
Radford Neal committed
1291

1292
    switch(TYPEOF(s)) { /* common cases done here for efficiency */
Radford Neal's avatar
Radford Neal committed
1293
    case INTSXP:  /* assume logical and integer are the same */
1294 1295
    case LGLSXP:
        len = LENGTH(s);
Radford Neal's avatar
Radford Neal committed
1296 1297
        if (len == 0 || LOGICAL(s)[0] == NA_LOGICAL) goto error;
        cond = LOGICAL(s)[0];
1298 1299 1300
        break;
    default:
        len = length(s);
Radford Neal's avatar
Radford Neal committed
1301 1302
        if (len == 0) goto error;
        cond = asLogical(s);
1303
        break;
Radford Neal's avatar
Radford Neal committed
1304
    }
1305

Radford Neal's avatar
Radford Neal committed
1306
    if (cond == NA_LOGICAL) goto error;
1307

Radford Neal's avatar
Radford Neal committed
1308
    if (len > 1) asLogicalNoNA_warning (s, call);
1309

Radford Neal's avatar
Radford Neal committed
1310
    return cond;
Radford Neal's avatar
Radford Neal committed
1311 1312 1313

  error:
    asLogicalNoNA_error (s, call);
Radford Neal's avatar
Radford Neal committed
1314 1315 1316
}


Radford Neal's avatar
Radford Neal committed
1317
#define BodyHasBraces(body) \
1318
    (isLanguage(body) && CAR(body) == R_BraceSymbol)
Radford Neal's avatar
Radford Neal committed
1319

1320

Radford Neal's avatar
Radford Neal committed
1321
static SEXP do_if (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
1322
{
1323
    SEXP Cond, Stmt;
1324 1325 1326 1327 1328
    int absent_else = 0;

    Cond = CAR(args); args = CDR(args);
    Stmt = CAR(args); args = CDR(args);

1329 1330
    SEXP condval = evalv (Cond, rho, VARIANT_SCALAR_STACK_OK);
    int condlogical = asLogicalNoNA (condval, call);
1331
    if (ON_SCALAR_STACK(condval)) POP_SCALAR_STACK(condval);
1332 1333

    if (!condlogical) {
1334
        /* go to else part */
1335 1336 1337 1338 1339 1340 1341 1342
        if (args != R_NilValue)
            Stmt = CAR(args);
        else {
            absent_else = 1;
            Stmt = R_NilValue;
        }
    }

1343 1344
    if (RDEBUG(rho) && Stmt!=R_NilValue && !BodyHasBraces(Stmt))
        start_browser (call, op, Stmt, rho);
1345 1346 1347 1348 1349 1350

    if (absent_else) {
        R_Visible = FALSE; /* case of no 'else' so return invisible NULL */
        return R_NilValue;
    }

1351
    return evalv (Stmt, rho, VARIANT_PASS_ON(variant));
1352 1353 1354
}


1355 1356
/* For statement.  Unevaluated arguments for different formats are as follows:

Radford Neal's avatar
Radford Neal committed
1357 1358 1359
       for (i in v) body          i, v, body
       for (i down v) body        i, down=v, body
       for (i across v) body      i, across=v, body
1360 1361 1362 1363
       for (i along v) body       i, along=v, body     (ok for vec or for array)
       for (i, j along M) body    i, j, along=M, body     (requires correct dim)
       etc.

Radford Neal's avatar
Radford Neal committed
1364 1365
   Extra variables after i are ignored for 'in', 'down', and 'across'.

1366 1367
   Evaluates body with VARIANT_NULL | VARIANT_PENDING_OK.
 */