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--2025  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, SEXP env);
 
static SEXP naokfind(SEXP args, int * len, int *naok, DllReference *dll);
static SEXP pkgtrim(SEXP args, DllReference *dll);
 
static R_INLINE bool isNativeSymbolInfo(SEXP op)
{
    /* was: inherits(op, "NativeSymbolInfo")
     * inherits() is slow because of string comparisons, so use
     * structural check instead. */
    return (TYPEOF(op) == VECSXP &&

 
    return args; /* -Wall */
}
 
 
static bool
checkNativeType(int targetType, int actualType)
{
    if(targetType > 0) {
	if(targetType == INTSXP || targetType == LGLSXP) {
	    return(actualType == INTSXP || actualType == LGLSXP);
	}
	return(targetType == actualType);
    }
 
    return(true);
}
 
 
static bool
comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s)
{
   if(type == ANYSXP || TYPEOF(s) == type)
      return(true);
 
   if(type == SINGLESXP)
      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);
 
   return(false);
}
 
 
/* Foreign Function Interface.  This code allows a user to call C */
/* or Fortran code which is either statically or dynamically linked. */

{
    static int inited = FALSE;
    static int check = FALSE;
 
    if (! inited) {
	inited = true;
	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", (void *)val);

	    cargscp[i] = PROTECT(duplicate(cargs[i]));
	    nprotect++;
	}
	retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));
	nprotect++;
	bool 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
 
               srcref is not ignored because ignoring it is expensive
               (it triggers duplication)
	    */
            if (!R_compute_identical(cargs[i], cargscp[i], 39)
		    && !R_checkConstants(FALSE))
		constsOK = false;
	if (!constsOK) {
	    REprintf("ERROR: detected compiler constant(s) modification after"
		" .Call invocation of function %s from library %s (%s).\n",
		buf,
		symbol.dll ? symbol.dll->name : "unknown",

 
attribute_hidden SEXP do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP retval;
    pGEDevDesc dd = GEcurrentDevice();
    bool record = dd->recordGraphics;
#ifdef R_GE_DEBUG
    if (getenv("R_GE_DEBUG_record")) {
        printf("do_Externalgr: record = FALSE\n");
    }
#endif
    dd->recordGraphics = false;
    PROTECT(retval = do_External(call, op, args, env));
#ifdef R_GE_DEBUG
    if (getenv("R_GE_DEBUG_record")) {
        printf("do_Externalgr: record = %d\n", record);
    }

 
attribute_hidden SEXP do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP retval;
    pGEDevDesc dd = GEcurrentDevice();
    bool record = dd->recordGraphics;
#ifdef R_GE_DEBUG
    if (getenv("R_GE_DEBUG_record")) {
        printf("do_dotcallgr: record = FALSE\n");
    }
#endif
    dd->recordGraphics = false;
    PROTECT(retval = do_dotcall(call, op, args, env));
#ifdef R_GE_DEBUG
    if (getenv("R_GE_DEBUG_record")) {
        printf("do_dotcallgr: record = %d\n", record);
    }

Rf_getCallingDLL(void)
{
    SEXP e, ans;
    RCNTXT *cptr;
    SEXP rho = R_NilValue;
    bool found = false;
 
    /* First find the environment of the caller.
       Testing shows this is the right caller, despite the .C/.Call ...
     */
    for (cptr = R_GlobalContext;

       The idea is that we will not find a namespace unless the caller
       was defined in one. */
    while(rho != R_NilValue) {
	if (rho == R_GlobalEnv) break;
	else if (R_IsNamespaceEnv(rho)) {
	    found = true;
	    break;
	}
	rho = ENCLOS(rho);
    }
    if(!found) return R_NilValue;

 
attribute_hidden SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)
{
    void **cargs, **cargs0 = NULL /* -Wall */;
    int naok, na, nargs, Fort;
    bool copy = R_CBoundsCheck; /* options(CboundsCheck) */
    DL_FUNC fun = NULL;
    SEXP ans, pa, s;
    R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
    R_NativePrimitiveArgType *checkTypes = NULL;
    const void *vmax;

	checkTypes = symbol.symbol.c->types;
    }
 
    /* Construct the return value */
    nargs = 0;
    bool havenames = false;
    for(pa = args ; pa != R_NilValue; pa = CDR(pa)) {
	if (TAG(pa) != R_NilValue) havenames = true;
	nargs++;
    }
 
    PROTECT(ans = allocVector(VECSXP, nargs));
    if (havenames) {

	s = CAR(pa);
	/* start with return value a copy of the inputs, as that is
	   what is needed for non-atomic-vector inputs */
	SET_VECTOR_ELT(ans, na, s);
 
	if(checkNativeType(targetType, TYPEOF(s)) == false &&
	   targetType != SINGLESXP) {
	    /* Cannot be called if DUP = FALSE, so only needs to live
	       until copied in the switch.
	       But R_alloc allocates, so missed protection < R 2.15.0.
	    */

Rev 87180	Rev 87902
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--2024 The R Core Team`	4	`* Copyright (C) 1997--2025 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 77...	Line 77...
77	`R_RegisteredNativeSymbol *symbol, SEXP env);`	77	`R_RegisteredNativeSymbol *symbol, SEXP env);`
78		78
79	`static SEXP naokfind(SEXP args, int * len, int naok, DllReference dll);`	79	`static SEXP naokfind(SEXP args, int * len, int naok, DllReference dll);`
80	`static SEXP pkgtrim(SEXP args, DllReference *dll);`	80	`static SEXP pkgtrim(SEXP args, DllReference *dll);`
81		81
82	`static R_INLINE Rboolean isNativeSymbolInfo(SEXP op)`	82	`static R_INLINE bool isNativeSymbolInfo(SEXP op)`
83	`{`	83	`{`
84	`/* was: inherits(op, "NativeSymbolInfo")`	84	`/* was: inherits(op, "NativeSymbolInfo")`
85	`* inherits() is slow because of string comparisons, so use`	85	`* inherits() is slow because of string comparisons, so use`
86	`* structural check instead. */`	86	`* structural check instead. */`
87	`return (TYPEOF(op) == VECSXP &&`	87	`return (TYPEOF(op) == VECSXP &&`
Line 319...	Line 319...
319		319
320	`return args; /* -Wall */`	320	`return args; /* -Wall */`
321	`}`	321	`}`
322		322
323		323
324	`static Rboolean`	324	`static bool`
325	`checkNativeType(int targetType, int actualType)`	325	`checkNativeType(int targetType, int actualType)`
326	`{`	326	`{`
327	`if(targetType > 0) {`	327	`if(targetType > 0) {`
328	`if(targetType == INTSXP \|\| targetType == LGLSXP) {`	328	`if(targetType == INTSXP \|\| targetType == LGLSXP) {`
329	`return(actualType == INTSXP \|\| actualType == LGLSXP);`	329	`return(actualType == INTSXP \|\| actualType == LGLSXP);`
330	`}`	330	`}`
331	`return(targetType == actualType);`	331	`return(targetType == actualType);`
332	`}`	332	`}`
333		333
334	`return(TRUE);`	334	`return(true);`
335	`}`	335	`}`
336		336
337		337
338	`static Rboolean`	338	`static bool`
339	`comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s)`	339	`comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s)`
340	`{`	340	`{`
341	`if(type == ANYSXP \|\| TYPEOF(s) == type)`	341	`if(type == ANYSXP \|\| TYPEOF(s) == type)`
342	`return(TRUE);`	342	`return(true);`
343		343
344	`if(type == SINGLESXP)`	344	`if(type == SINGLESXP)`
345	`return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);`	345	`return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);`
346		346
347	`return(FALSE);`	347	`return(false);`
348	`}`	348	`}`
349		349
350		350
351	`/* Foreign Function Interface. This code allows a user to call C */`	351	`/* Foreign Function Interface. This code allows a user to call C */`
352	`/* or Fortran code which is either statically or dynamically linked. */`	352	`/* or Fortran code which is either statically or dynamically linked. */`
Line 523...	Line 523...
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) {`
528	`inited = TRUE;`	528	`inited = true;`
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) {`
535	`if (val < (SEXP) 16)`	535	`if (val < (SEXP) 16)`
536	`errorcall(call, "WEIRD RETURN VALUE: %p", (void *)val);`	536	`errorcall(call, "WEIRD RETURN VALUE: %p", (void *)val);`
Line 1442...	Line 1442...
1442	`cargscp[i] = PROTECT(duplicate(cargs[i]));`	1442	`cargscp[i] = PROTECT(duplicate(cargs[i]));`
1443	`nprotect++;`	1443	`nprotect++;`
1444	`}`	1444	`}`
1445	`retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));`	1445	`retval = PROTECT(R_doDotCall(ofun, nargs, cargs, call));`
1446	`nprotect++;`	1446	`nprotect++;`
1447	`Rboolean constsOK = TRUE;`	1447	`bool constsOK = true;`
1448	`for(i = 0; constsOK && i < nargs; i++)`	1448	`for(i = 0; constsOK && i < nargs; i++)`
1449	`/* 39: not numerical comparison, not single NA, not attributes as`	1449	`/* 39: not numerical comparison, not single NA, not attributes as`
1450	`set, do ignore byte-code, do ignore environments of closures,`	1450	`set, do ignore byte-code, do ignore environments of closures,`
1451	`not ignore srcref`	1451	`not ignore srcref`
1452		1452
1453	`srcref is not ignored because ignoring it is expensive`	1453	`srcref is not ignored because ignoring it is expensive`
1454	`(it triggers duplication)`	1454	`(it triggers duplication)`
1455	`*/`	1455	`*/`
1456	`if (!R_compute_identical(cargs[i], cargscp[i], 39)`	1456	`if (!R_compute_identical(cargs[i], cargscp[i], 39)`
1457	`&& !R_checkConstants(FALSE))`	1457	`&& !R_checkConstants(FALSE))`
1458	`constsOK = FALSE;`	1458	`constsOK = false;`
1459	`if (!constsOK) {`	1459	`if (!constsOK) {`
1460	`REprintf("ERROR: detected compiler constant(s) modification after"`	1460	`REprintf("ERROR: detected compiler constant(s) modification after"`
1461	`" .Call invocation of function %s from library %s (%s).\n",`	1461	`" .Call invocation of function %s from library %s (%s).\n",`
1462	`buf,`	1462	`buf,`
1463	`symbol.dll ? symbol.dll->name : "unknown",`	1463	`symbol.dll ? symbol.dll->name : "unknown",`
Line 1499...	Line 1499...
1499		1499
1500	`attribute_hidden SEXP do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)`	1500	`attribute_hidden SEXP do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)`
1501	`{`	1501	`{`
1502	`SEXP retval;`	1502	`SEXP retval;`
1503	`pGEDevDesc dd = GEcurrentDevice();`	1503	`pGEDevDesc dd = GEcurrentDevice();`
1504	`Rboolean record = dd->recordGraphics;`	1504	`bool record = dd->recordGraphics;`
1505	`#ifdef R_GE_DEBUG`	1505	`#ifdef R_GE_DEBUG`
1506	`if (getenv("R_GE_DEBUG_record")) {`	1506	`if (getenv("R_GE_DEBUG_record")) {`
1507	`printf("do_Externalgr: record = FALSE\n");`	1507	`printf("do_Externalgr: record = FALSE\n");`
1508	`}`	1508	`}`
1509	`#endif`	1509	`#endif`
1510	`dd->recordGraphics = FALSE;`	1510	`dd->recordGraphics = false;`
1511	`PROTECT(retval = do_External(call, op, args, env));`	1511	`PROTECT(retval = do_External(call, op, args, env));`
1512	`#ifdef R_GE_DEBUG`	1512	`#ifdef R_GE_DEBUG`
1513	`if (getenv("R_GE_DEBUG_record")) {`	1513	`if (getenv("R_GE_DEBUG_record")) {`
1514	`printf("do_Externalgr: record = %d\n", record);`	1514	`printf("do_Externalgr: record = %d\n", record);`
1515	`}`	1515	`}`
Line 1530...	Line 1530...
1530		1530
1531	`attribute_hidden SEXP do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`	1531	`attribute_hidden SEXP do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)`
1532	`{`	1532	`{`
1533	`SEXP retval;`	1533	`SEXP retval;`
1534	`pGEDevDesc dd = GEcurrentDevice();`	1534	`pGEDevDesc dd = GEcurrentDevice();`
1535	`Rboolean record = dd->recordGraphics;`	1535	`bool record = dd->recordGraphics;`
1536	`#ifdef R_GE_DEBUG`	1536	`#ifdef R_GE_DEBUG`
1537	`if (getenv("R_GE_DEBUG_record")) {`	1537	`if (getenv("R_GE_DEBUG_record")) {`
1538	`printf("do_dotcallgr: record = FALSE\n");`	1538	`printf("do_dotcallgr: record = FALSE\n");`
1539	`}`	1539	`}`
1540	`#endif`	1540	`#endif`
1541	`dd->recordGraphics = FALSE;`	1541	`dd->recordGraphics = false;`
1542	`PROTECT(retval = do_dotcall(call, op, args, env));`	1542	`PROTECT(retval = do_dotcall(call, op, args, env));`
1543	`#ifdef R_GE_DEBUG`	1543	`#ifdef R_GE_DEBUG`
1544	`if (getenv("R_GE_DEBUG_record")) {`	1544	`if (getenv("R_GE_DEBUG_record")) {`
1545	`printf("do_dotcallgr: record = %d\n", record);`	1545	`printf("do_dotcallgr: record = %d\n", record);`
1546	`}`	1546	`}`
Line 1562...	Line 1562...
1562	`Rf_getCallingDLL(void)`	1562	`Rf_getCallingDLL(void)`
1563	`{`	1563	`{`
1564	`SEXP e, ans;`	1564	`SEXP e, ans;`
1565	`RCNTXT *cptr;`	1565	`RCNTXT *cptr;`
1566	`SEXP rho = R_NilValue;`	1566	`SEXP rho = R_NilValue;`
1567	`Rboolean found = FALSE;`	1567	`bool found = false;`
1568		1568
1569	`/* First find the environment of the caller.`	1569	`/* First find the environment of the caller.`
1570	`Testing shows this is the right caller, despite the .C/.Call ...`	1570	`Testing shows this is the right caller, despite the .C/.Call ...`
1571	`*/`	1571	`*/`
1572	`for (cptr = R_GlobalContext;`	1572	`for (cptr = R_GlobalContext;`
Line 1581...	Line 1581...
1581	`The idea is that we will not find a namespace unless the caller`	1581	`The idea is that we will not find a namespace unless the caller`
1582	`was defined in one. */`	1582	`was defined in one. */`
1583	`while(rho != R_NilValue) {`	1583	`while(rho != R_NilValue) {`
1584	`if (rho == R_GlobalEnv) break;`	1584	`if (rho == R_GlobalEnv) break;`
1585	`else if (R_IsNamespaceEnv(rho)) {`	1585	`else if (R_IsNamespaceEnv(rho)) {`
1586	`found = TRUE;`	1586	`found = true;`
1587	`break;`	1587	`break;`
1588	`}`	1588	`}`
1589	`rho = ENCLOS(rho);`	1589	`rho = ENCLOS(rho);`
1590	`}`	1590	`}`
1591	`if(!found) return R_NilValue;`	1591	`if(!found) return R_NilValue;`
Line 1660...	Line 1660...
1660		1660
1661	`attribute_hidden SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)`	1661	`attribute_hidden SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)`
1662	`{`	1662	`{`
1663	`void cargs, cargs0 = NULL /* -Wall */;`	1663	`void cargs, cargs0 = NULL /* -Wall */;`
1664	`int naok, na, nargs, Fort;`	1664	`int naok, na, nargs, Fort;`
1665	`Rboolean havenames, copy = R_CBoundsCheck; /* options(CboundsCheck) */`	1665	`bool copy = R_CBoundsCheck; /* options(CboundsCheck) */`
1666	`DL_FUNC fun = NULL;`	1666	`DL_FUNC fun = NULL;`
1667	`SEXP ans, pa, s;`	1667	`SEXP ans, pa, s;`
1668	`R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};`	1668	`R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};`
1669	`R_NativePrimitiveArgType *checkTypes = NULL;`	1669	`R_NativePrimitiveArgType *checkTypes = NULL;`
1670	`const void *vmax;`	1670	`const void *vmax;`
Line 1696...	Line 1696...
1696	`checkTypes = symbol.symbol.c->types;`	1696	`checkTypes = symbol.symbol.c->types;`
1697	`}`	1697	`}`
1698		1698
1699	`/* Construct the return value */`	1699	`/* Construct the return value */`
1700	`nargs = 0;`	1700	`nargs = 0;`
1701	`havenames = FALSE;`	1701	`bool havenames = false;`
1702	`for(pa = args ; pa != R_NilValue; pa = CDR(pa)) {`	1702	`for(pa = args ; pa != R_NilValue; pa = CDR(pa)) {`
1703	`if (TAG(pa) != R_NilValue) havenames = TRUE;`	1703	`if (TAG(pa) != R_NilValue) havenames = true;`
1704	`nargs++;`	1704	`nargs++;`
1705	`}`	1705	`}`
1706		1706
1707	`PROTECT(ans = allocVector(VECSXP, nargs));`	1707	`PROTECT(ans = allocVector(VECSXP, nargs));`
1708	`if (havenames) {`	1708	`if (havenames) {`
Line 1737...	Line 1737...
1737	`s = CAR(pa);`	1737	`s = CAR(pa);`
1738	`/* start with return value a copy of the inputs, as that is`	1738	`/* start with return value a copy of the inputs, as that is`
1739	`what is needed for non-atomic-vector inputs */`	1739	`what is needed for non-atomic-vector inputs */`
1740	`SET_VECTOR_ELT(ans, na, s);`	1740	`SET_VECTOR_ELT(ans, na, s);`
1741		1741
1742	`if(checkNativeType(targetType, TYPEOF(s)) == FALSE &&`	1742	`if(checkNativeType(targetType, TYPEOF(s)) == false &&`
1743	`targetType != SINGLESXP) {`	1743	`targetType != SINGLESXP) {`
1744	`/* Cannot be called if DUP = FALSE, so only needs to live`	1744	`/* Cannot be called if DUP = FALSE, so only needs to live`
1745	`until copied in the switch.`	1745	`until copied in the switch.`
1746	`But R_alloc allocates, so missed protection < R 2.15.0.`	1746	`But R_alloc allocates, so missed protection < R 2.15.0.`
1747	`*/`	1747	`*/`

The R Project SVN R

(root)/trunk/src/main/dotcode.c – Rev 87180 → 87902