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



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1999-2026  The R Core Team.
 *  Copyright (C) 2002-2023  The R Foundation
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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

#endif
 
#define R_USE_SIGNALS 1
#include <Defn.h>
#include <Internal.h>
#include <R_ext/RS.h> /* for R_Calloc, R_Realloc and for S4 object bit, R_allocObject() */
 
static SEXP GetObject(RCNTXT *cptr)
{
    SEXP s, b, formals, tag;
 

    }
    if (TYPEOF(table) == ENVSXP) {
	PROTECT(table);
	REPROTECT(val = R_findVarInFrame(table, method), validx);
	UNPROTECT(1); /* table */
	if (TYPEOF(val) == PROMSXP)
	    REPROTECT(val = eval(val, rho), validx);
	if(val != R_UnboundValue) {
	    UNPROTECT(2); /* top, val */
	    return val;
	}
    }
 
    if (top == R_GlobalEnv)
	top = R_BaseEnv;
    else
	top = ENCLOS(top);

		    }
		    break;
		case 2: // don't forward any variables
		    break;
		case 3: // forward all, with an error when used
#ifdef WARN_ON_FORWARDING
		    if (TAG(s) != R_dot_defined &&
			TAG(s) != R_dot_Method &&
			TAG(s) != R_dot_target &&
			TAG(s) != R_dot_Generic &&
			TAG(s) != R_dot_Methods)

   "usemethod". Things like [ and [[ call usemethod directly,
   hence do_usemethod should just be an interface to usemethod.
*/
 
/* This is a primitive SPECIALSXP */
NORET attribute_hidden
SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
{
    static SEXP do_usemethod_formals = NULL;
    if (do_usemethod_formals == NULL)
	do_usemethod_formals = allocFormalsList2(install("generic"),

    klass = getAttrib(object, R_ClassSymbol);
    return (klass != R_NilValue && LENGTH(klass) == 1 &&
	    getAttrib(klass, R_PackageSymbol) != R_NilValue) ? TRUE: FALSE;
}
 
// a bare object of type "object" (OBJSXP without the S4 bit), as used e.g. by S7
attribute_hidden SEXP do_objsxp(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    return R_allocObject();
}
 
attribute_hidden SEXP do_setS4Object(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP object = CAR(args);
    Rboolean flag = asRbool(CADR(args), call);

Rev 87938	Rev 90234
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) 1999-2025 The R Core Team.`	3	`* Copyright (C) 1999-2026 The R Core Team.`
4	`* Copyright (C) 2002-2023 The R Foundation`	4	`* Copyright (C) 2002-2023 The R Foundation`
5	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	5	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
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`
Line 27...	Line 27...
27	`#endif`	27	`#endif`
28		28
29	`#define R_USE_SIGNALS 1`	29	`#define R_USE_SIGNALS 1`
30	`#include <Defn.h>`	30	`#include <Defn.h>`
31	`#include <Internal.h>`	31	`#include <Internal.h>`
32	`#include <R_ext/RS.h> /* for R_Calloc, R_Realloc and for S4 object bit */`	32	`#include <R_ext/RS.h> /* for R_Calloc, R_Realloc and for S4 object bit, R_allocObject() */`
33		33
34	`static SEXP GetObject(RCNTXT *cptr)`	34	`static SEXP GetObject(RCNTXT *cptr)`
35	`{`	35	`{`
36	`SEXP s, b, formals, tag;`	36	`SEXP s, b, formals, tag;`
37		37
Line 272...	Line 272...
272	`}`	272	`}`
273	`if (TYPEOF(table) == ENVSXP) {`	273	`if (TYPEOF(table) == ENVSXP) {`
274	`PROTECT(table);`	274	`PROTECT(table);`
275	`REPROTECT(val = R_findVarInFrame(table, method), validx);`	275	`REPROTECT(val = R_findVarInFrame(table, method), validx);`
276	`UNPROTECT(1); /* table */`	276	`UNPROTECT(1); /* table */`
277	`if (TYPEOF(val) == PROMSXP)`	277	`if (TYPEOF(val) == PROMSXP)`
278	`REPROTECT(val = eval(val, rho), validx);`	278	`REPROTECT(val = eval(val, rho), validx);`
279	`if(val != R_UnboundValue) {`	279	`if(val != R_UnboundValue) {`
280	`UNPROTECT(2); /* top, val */`	280	`UNPROTECT(2); /* top, val */`
281	`return val;`	281	`return val;`
282	`}`	282	`}`
283	`}`	283	`}`
284		284
285	`if (top == R_GlobalEnv)`	285	`if (top == R_GlobalEnv)`
286	`top = R_BaseEnv;`	286	`top = R_BaseEnv;`
287	`else`	287	`else`
288	`top = ENCLOS(top);`	288	`top = ENCLOS(top);`
Line 425...	Line 425...
425	`}`	425	`}`
426	`break;`	426	`break;`
427	`case 2: // don't forward any variables`	427	`case 2: // don't forward any variables`
428	`break;`	428	`break;`
429	`case 3: // forward all, with an error when used`	429	`case 3: // forward all, with an error when used`
430	`#ifdef WARN_ON_FORWARDING`	430	`#ifdef WARN_ON_FORWARDING`
431	`if (TAG(s) != R_dot_defined &&`	431	`if (TAG(s) != R_dot_defined &&`
432	`TAG(s) != R_dot_Method &&`	432	`TAG(s) != R_dot_Method &&`
433	`TAG(s) != R_dot_target &&`	433	`TAG(s) != R_dot_target &&`
434	`TAG(s) != R_dot_Generic &&`	434	`TAG(s) != R_dot_Generic &&`
435	`TAG(s) != R_dot_Methods)`	435	`TAG(s) != R_dot_Methods)`
Line 534...	Line 534...
534	`"usemethod". Things like [ and [[ call usemethod directly,`	534	`"usemethod". Things like [ and [[ call usemethod directly,`
535	`hence do_usemethod should just be an interface to usemethod.`	535	`hence do_usemethod should just be an interface to usemethod.`
536	`*/`	536	`*/`
537		537
538	`/* This is a primitive SPECIALSXP */`	538	`/* This is a primitive SPECIALSXP */`
539	`NORET attribute_hidden`	539	`NORET attribute_hidden`
540	`SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)`	540	`SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)`
541	`{`	541	`{`
542	`static SEXP do_usemethod_formals = NULL;`	542	`static SEXP do_usemethod_formals = NULL;`
543	`if (do_usemethod_formals == NULL)`	543	`if (do_usemethod_formals == NULL)`
544	`do_usemethod_formals = allocFormalsList2(install("generic"),`	544	`do_usemethod_formals = allocFormalsList2(install("generic"),`
Line 1804...	Line 1804...
1804	`klass = getAttrib(object, R_ClassSymbol);`	1804	`klass = getAttrib(object, R_ClassSymbol);`
1805	`return (klass != R_NilValue && LENGTH(klass) == 1 &&`	1805	`return (klass != R_NilValue && LENGTH(klass) == 1 &&`
1806	`getAttrib(klass, R_PackageSymbol) != R_NilValue) ? TRUE: FALSE;`	1806	`getAttrib(klass, R_PackageSymbol) != R_NilValue) ? TRUE: FALSE;`
1807	`}`	1807	`}`
1808		1808
-		1809	`// a bare object of type "object" (OBJSXP without the S4 bit), as used e.g. by S7`
-		1810	`attribute_hidden SEXP do_objsxp(SEXP call, SEXP op, SEXP args, SEXP env)`
-		1811	`{`
-		1812	`checkArity(op, args);`
-		1813	`return R_allocObject();`
-		1814	`}`
-		1815
1809	`attribute_hidden SEXP do_setS4Object(SEXP call, SEXP op, SEXP args, SEXP env)`	1816	`attribute_hidden SEXP do_setS4Object(SEXP call, SEXP op, SEXP args, SEXP env)`
1810	`{`	1817	`{`
1811	`checkArity(op, args);`	1818	`checkArity(op, args);`
1812	`SEXP object = CAR(args);`	1819	`SEXP object = CAR(args);`
1813	`Rboolean flag = asRbool(CADR(args), call);`	1820	`Rboolean flag = asRbool(CADR(args), call);`

The R Project SVN R

(root)/trunk/src/main/objects.c @ 77458 – Rev 87938 → 90234