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



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2020  The R Core Team
 *  Copyright (C) 2003	      The R Foundation
 *
 *  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

    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
 
    int nargs;
    const void *vmax = vmaxget();
    char buf[MaxSymbolBytes];
    int nprotect = 0;
 
    if (length(args) < 1) errorcall(call, _("'.NAME' is missing"));
    check1arg2(args, call, ".NAME");
 
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL, call, env);

    if (R_check_constants < 4)
	retval = R_doDotCall(ofun, nargs, cargs, call);
    else {
	SEXP *cargscp = (SEXP *) R_alloc(nargs, sizeof(SEXP));
	int i;
	for(i = 0; i < nargs; i++) {
	    cargscp[i] = PROTECT(duplicate(cargs[i]));
	    nprotect++;
	}
	retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));
	nprotect++;
	Rboolean constsOK = TRUE;
	for(i = 0; constsOK && i < nargs; i++)
	    /* 39: not numerical comparison, not single NA, not attributes as
               set, do ignore byte-code, do ignore environments of closures,
               not ignore srcref

			CHAR(type2str(TYPEOF(cargscp[i]))),
			length(cargscp[i])
		    );
	    R_Suicide("compiler constants were modified (in .Call?)!\n");
	}
	UNPROTECT(nprotect);
    }
    vmaxset(vmax);
    return retval;
}
 

	/* args is escaping, so make sure it is reference counting. */
	/* should alread be handled in do_External, but be safe ... */
	R_args_enable_refcnt(args);
	GErecordGraphicOperation(op, args, dd);
    }
    check_retval(call, retval);
    UNPROTECT(1);
    return retval;
}
 
SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP retval;

	    errorcall(call, _("invalid graphics state"));
	/* args is escaping, so make sure it is reference counting. */
	R_args_enable_refcnt(args);
	GErecordGraphicOperation(op, args, dd);
    }
    check_retval(call, retval);
    UNPROTECT(1);
    return retval;
}
 
static SEXP
Rf_getCallingDLL(void)
{

Rev 77498	Rev 78127
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1997--2018 The R Core Team`	4	`* Copyright (C) 1997--2020 The R Core Team`
5	`* Copyright (C) 2003 The R Foundation`	5	`* Copyright (C) 2003 The R Foundation`
6	`*`	6	`*`
7	`* This program is free software; you can redistribute it and/or modify`	7	`* This program is free software; you can redistribute it and/or modify`
8	`* it under the terms of the GNU General Public License as published by`	8	`* it under the terms of the GNU General Public License as published by`
9	`* the Free Software Foundation; either version 2 of the License, or`	9	`* the Free Software Foundation; either version 2 of the License, or`
Line 1254...	Line 1254...
1254	`R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};`	1254	`R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};`
1255		1255
1256	`int nargs;`	1256	`int nargs;`
1257	`const void *vmax = vmaxget();`	1257	`const void *vmax = vmaxget();`
1258	`char buf[MaxSymbolBytes];`	1258	`char buf[MaxSymbolBytes];`
-		1259	`int nprotect = 0;`
1259		1260
1260	`if (length(args) < 1) errorcall(call, _("'.NAME' is missing"));`	1261	`if (length(args) < 1) errorcall(call, _("'.NAME' is missing"));`
1261	`check1arg2(args, call, ".NAME");`	1262	`check1arg2(args, call, ".NAME");`
1262		1263
1263	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL, call, env);`	1264	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL, call, env);`
Line 1279...	Line 1280...
1279	`if (R_check_constants < 4)`	1280	`if (R_check_constants < 4)`
1280	`retval = R_doDotCall(ofun, nargs, cargs, call);`	1281	`retval = R_doDotCall(ofun, nargs, cargs, call);`
1281	`else {`	1282	`else {`
1282	`SEXP cargscp = (SEXP ) R_alloc(nargs, sizeof(SEXP));`	1283	`SEXP cargscp = (SEXP ) R_alloc(nargs, sizeof(SEXP));`
1283	`int i;`	1284	`int i;`
1284	`for(i = 0; i < nargs; i++)`	1285	`for(i = 0; i < nargs; i++) {`
1285	`cargscp[i] = PROTECT(duplicate(cargs[i]));`	1286	`cargscp[i] = PROTECT(duplicate(cargs[i]));`
-		1287	`nprotect++;`
-		1288	`}`
1286	`retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));`	1289	`retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));`
-		1290	`nprotect++;`
1287	`Rboolean constsOK = TRUE;`	1291	`Rboolean constsOK = TRUE;`
1288	`for(i = 0; constsOK && i < nargs; i++)`	1292	`for(i = 0; constsOK && i < nargs; i++)`
1289	`/* 39: not numerical comparison, not single NA, not attributes as`	1293	`/* 39: not numerical comparison, not single NA, not attributes as`
1290	`set, do ignore byte-code, do ignore environments of closures,`	1294	`set, do ignore byte-code, do ignore environments of closures,`
1291	`not ignore srcref`	1295	`not ignore srcref`
Line 1311...	Line 1315...
1311	`CHAR(type2str(TYPEOF(cargscp[i]))),`	1315	`CHAR(type2str(TYPEOF(cargscp[i]))),`
1312	`length(cargscp[i])`	1316	`length(cargscp[i])`
1313	`);`	1317	`);`
1314	`R_Suicide("compiler constants were modified (in .Call?)!\n");`	1318	`R_Suicide("compiler constants were modified (in .Call?)!\n");`
1315	`}`	1319	`}`
1316	`UNPROTECT(nargs + 1);`	1320	`UNPROTECT(nprotect);`
1317	`}`	1321	`}`
1318	`vmaxset(vmax);`	1322	`vmaxset(vmax);`
1319	`return retval;`	1323	`return retval;`
1320	`}`	1324	`}`
1321		1325
Line 1351...	Line 1355...
1351	`/* args is escaping, so make sure it is reference counting. */`	1355	`/* args is escaping, so make sure it is reference counting. */`
1352	`/* should alread be handled in do_External, but be safe ... */`	1356	`/* should alread be handled in do_External, but be safe ... */`
1353	`R_args_enable_refcnt(args);`	1357	`R_args_enable_refcnt(args);`
1354	`GErecordGraphicOperation(op, args, dd);`	1358	`GErecordGraphicOperation(op, args, dd);`
1355	`}`	1359	`}`
-		1360	`check_retval(call, retval);`
1356	`UNPROTECT(1);`	1361	`UNPROTECT(1);`
1357	`return check_retval(call, retval);`	1362	`return retval;`
1358	`}`	1363	`}`
1359		1364
1360	`SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`	1365	`SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`
1361	`{`	1366	`{`
1362	`SEXP retval;`	1367	`SEXP retval;`
Line 1370...	Line 1375...
1370	`errorcall(call, _("invalid graphics state"));`	1375	`errorcall(call, _("invalid graphics state"));`
1371	`/* args is escaping, so make sure it is reference counting. */`	1376	`/* args is escaping, so make sure it is reference counting. */`
1372	`R_args_enable_refcnt(args);`	1377	`R_args_enable_refcnt(args);`
1373	`GErecordGraphicOperation(op, args, dd);`	1378	`GErecordGraphicOperation(op, args, dd);`
1374	`}`	1379	`}`
-		1380	`check_retval(call, retval);`
1375	`UNPROTECT(1);`	1381	`UNPROTECT(1);`
1376	`return check_retval(call, retval);`	1382	`return retval;`
1377	`}`	1383	`}`
1378		1384
1379	`static SEXP`	1385	`static SEXP`
1380	`Rf_getCallingDLL(void)`	1386	`Rf_getCallingDLL(void)`
1381	`{`	1387	`{`

The R Project SVN R

(root)/trunk/src/main/dotcode.c @ 77458 – Rev 77498 → 78127