The R Project SVN – R – Diff – /trunk/src/main/dotcode.c



     Original code by Jean Meloche <jean@stat.ubc.ca> */
 
typedef SEXP (*R_ExternalRoutine)(SEXP);
typedef SEXP (*R_ExternalRoutine2)(SEXP, SEXP, SEXP, SEXP);
 
static SEXP check_retval(SEXP call, SEXP val)
{
    static int inited = FALSE;
    static int check = FALSE;
 
    if (! inited) {

	const char *p = getenv("_R_CHECK_DOTCODE_RETVAL_");
	if (p != NULL && StringTrue(p))
	    check = TRUE;
    }
 
    if (check) {
	if (val < (SEXP) 16)
	    errorcall(call, "WEIRD RETURN VALUE: %p", val);
    }
    else if (val == NULL) {
	warningcall(call, "converting NULL pointer to R NULL");
	val = R_NilValue;
    }
 
    return val;
}
    
SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env)
{
    DL_FUNC ofun = NULL;

    } else {
	R_ExternalRoutine fun = (R_ExternalRoutine) ofun;
	retval = fun(args);
    }
    vmaxset(vmax);
    return check_retval(call, retval);
 
}
 
#ifdef __cplusplus
typedef SEXP (*VarFun)(...);
#else

	    cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);
	break;
    default:
	errorcall(call, _("too many arguments, sorry"));
    }
    return check_retval(call, retval);
 
}
 
/* .Call(name, <args>) */
SEXP attribute_hidden do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)
{

	if (!GEcheckState(dd))
	    errorcall(call, _("invalid graphics state"));
	GErecordGraphicOperation(op, args, dd);
    }
    UNPROTECT(1);
    return check_retval(call, retval);
 
}
 
SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP retval;

	if (!GEcheckState(dd))
	    errorcall(call, _("invalid graphics state"));
	GErecordGraphicOperation(op, args, dd);
    }
    UNPROTECT(1);
    return check_retval(call, retval);
 
}
 
static SEXP
Rf_getCallingDLL(void)
{

Rev 77355	Rev 77358
Line 517...	Line 517...
517	`Original code by Jean Meloche <jean@stat.ubc.ca> */`	517	`Original code by Jean Meloche <jean@stat.ubc.ca> */`
518		518
519	`typedef SEXP (*R_ExternalRoutine)(SEXP);`	519	`typedef SEXP (*R_ExternalRoutine)(SEXP);`
520	`typedef SEXP (*R_ExternalRoutine2)(SEXP, SEXP, SEXP, SEXP);`	520	`typedef SEXP (*R_ExternalRoutine2)(SEXP, SEXP, SEXP, SEXP);`
521		521
522	`static void check_retval(SEXP call, SEXP val)`	522	`static SEXP check_retval(SEXP call, SEXP val)`
523	`{`	523	`{`
524	`static int inited = FALSE;`	524	`static int inited = FALSE;`
525	`static int check = FALSE;`	525	`static int check = FALSE;`
526		526
527	`if (! inited) {`	527	`if (! inited) {`
Line 529...	Line 529...
529	`const char *p = getenv("_R_CHECK_DOTCODE_RETVAL_");`	529	`const char *p = getenv("_R_CHECK_DOTCODE_RETVAL_");`
530	`if (p != NULL && StringTrue(p))`	530	`if (p != NULL && StringTrue(p))`
531	`check = TRUE;`	531	`check = TRUE;`
532	`}`	532	`}`
533		533
-		534	`if (check) {`
534	`if (check && val < (SEXP) 16)`	535	`if (val < (SEXP) 16)`
535	`errorcall(call, "WEIRD RETURN VALUE: %p", val);`	536	`errorcall(call, "WEIRD RETURN VALUE: %p", val);`
-		537	`}`
-		538	`else if (val == NULL) {`
-		539	`warningcall(call, "converting NULL pointer to R NULL");`
-		540	`val = R_NilValue;`
-		541	`}`
-		542
-		543	`return val;`
536	`}`	544	`}`
537		545
538	`SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env)`	546	`SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env)`
539	`{`	547	`{`
540	`DL_FUNC ofun = NULL;`	548	`DL_FUNC ofun = NULL;`
Line 562...	Line 570...
562	`} else {`	570	`} else {`
563	`R_ExternalRoutine fun = (R_ExternalRoutine) ofun;`	571	`R_ExternalRoutine fun = (R_ExternalRoutine) ofun;`
564	`retval = fun(args);`	572	`retval = fun(args);`
565	`}`	573	`}`
566	`vmaxset(vmax);`	574	`vmaxset(vmax);`
567	`check_retval(call, retval);`	575	`return check_retval(call, retval);`
568	`return retval;`	-
569	`}`	576	`}`
570		577
571	`#ifdef __cplusplus`	578	`#ifdef __cplusplus`
572	`typedef SEXP (*VarFun)(...);`	579	`typedef SEXP (*VarFun)(...);`
573	`#else`	580	`#else`
Line 1230...	Line 1237...
1230	`cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);`	1237	`cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);`
1231	`break;`	1238	`break;`
1232	`default:`	1239	`default:`
1233	`errorcall(call, _("too many arguments, sorry"));`	1240	`errorcall(call, _("too many arguments, sorry"));`
1234	`}`	1241	`}`
1235	`check_retval(call, retval);`	1242	`return check_retval(call, retval);`
1236	`return retval;`	-
1237	`}`	1243	`}`
1238		1244
1239	`/* .Call(name, <args>) */`	1245	`/* .Call(name, <args>) */`
1240	`SEXP attribute_hidden do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)`	1246	`SEXP attribute_hidden do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)`
1241	`{`	1247	`{`
Line 1339...	Line 1345...
1339	`if (!GEcheckState(dd))`	1345	`if (!GEcheckState(dd))`
1340	`errorcall(call, _("invalid graphics state"));`	1346	`errorcall(call, _("invalid graphics state"));`
1341	`GErecordGraphicOperation(op, args, dd);`	1347	`GErecordGraphicOperation(op, args, dd);`
1342	`}`	1348	`}`
1343	`UNPROTECT(1);`	1349	`UNPROTECT(1);`
1344	`check_retval(call, retval);`	1350	`return check_retval(call, retval);`
1345	`return retval;`	-
1346	`}`	1351	`}`
1347		1352
1348	`SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`	1353	`SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`
1349	`{`	1354	`{`
1350	`SEXP retval;`	1355	`SEXP retval;`
Line 1357...	Line 1362...
1357	`if (!GEcheckState(dd))`	1362	`if (!GEcheckState(dd))`
1358	`errorcall(call, _("invalid graphics state"));`	1363	`errorcall(call, _("invalid graphics state"));`
1359	`GErecordGraphicOperation(op, args, dd);`	1364	`GErecordGraphicOperation(op, args, dd);`
1360	`}`	1365	`}`
1361	`UNPROTECT(1);`	1366	`UNPROTECT(1);`
1362	`check_retval(call, retval);`	1367	`return check_retval(call, retval);`
1363	`return retval;`	-
1364	`}`	1368	`}`
1365		1369
1366	`static SEXP`	1370	`static SEXP`
1367	`Rf_getCallingDLL(void)`	1371	`Rf_getCallingDLL(void)`
1368	`{`	1372	`{`

The R Project SVN R

(root)/trunk/src/main/dotcode.c @ 77458 – Rev 77355 → 77358