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



    /* avoid problems with earlier (and future) versions captured in S4
       methods: but this should be fixed where it is caused, in
       'methods'!
 
       checkArity(op, args); */
    if (nargs < 5)
	error("%d arguments passed to .Internal(%s) which requires %d",
	      length(args), PRIMNAME(op), PRIMARITY(op));
 
    SEXP x = CAR(args); args = CDR(args);
    SEXP y = CAR(args); args = CDR(args);
    num_eq = asLogical(CAR(args)); args = CDR(args);
    single_NA = asLogical(CAR(args)); args = CDR(args);
    attr_as_set = asLogical(CAR(args)); args = CDR(args);
    if (nargs >= 6) 
	ignore_bytecode = asLogical(CAR(args));
    if (nargs >= 7) 
	ignore_env = asLogical(CADR(args));
 
    if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");
    if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");

#define SINGLE_NA       (!(flags & 2))
#define ATTR_AS_SET     (!(flags & 4))
#define IGNORE_BYTECODE (!(flags & 8))
#define IGNORE_ENV      (!(flags & 16))
 
/* do the two objects compute as identical?
   Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
    SEXP ax, ay, atrx, atry;
    if(x == y) /* same pointer */

    if(TYPEOF(x) != TYPEOF(y))
	return FALSE;
    if(OBJECT(x) != OBJECT(y))
	return FALSE;
 
    /* Skip attribute checks for CHARSXP
       -- such attributes are used for the cache.  */
    if(TYPEOF(x) == CHARSXP)
    {
	/* This matches NAs */
	return Seql(x, y);
    }

       don't test them if they are not, and we do not test the order
       if they are.
 
       This code is not very efficient, but then neither is using
       pairlists for attributes.  If long attribute lists become more
       common (and they are used for S4 slots) we should store them in
       a hash table.
    */
    else if(ax != R_NilValue || ay != R_NilValue) {
	if(ax == R_NilValue || ay == R_NilValue)
	    return FALSE;
	if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {

    switch (TYPEOF(x)) {
    case NILSXP:
	return TRUE;
    case LGLSXP:
	if (xlength(x) != xlength(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
		      xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case INTSXP:
	if (xlength(x) != xlength(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
		      xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case REALSXP:
    {
	R_xlen_t n = xlength(x);

	return(x == y ? TRUE : FALSE);
    case EXTPTRSXP:
	return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
    case RAWSXP:
	if (xlength(x) != xlength(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)RAW(x), (void *)RAW(y),
		      xlength(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;
 
/*  case PROMSXP: args are evaluated, so will not be seen */
	/* test for equality of the substituted expression -- or should
	   we require both expression and environment to be identical? */
	/*#define PREXPR(x)	((x)->u.promsxp.expr)
	  #define PRENV(x)	((x)->u.promsxp.env)
	  return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),

Rev 59534	Rev 59545
Line 47...	Line 47...
47	`/* avoid problems with earlier (and future) versions captured in S4`	47	`/* avoid problems with earlier (and future) versions captured in S4`
48	`methods: but this should be fixed where it is caused, in`	48	`methods: but this should be fixed where it is caused, in`
49	`'methods'!`	49	`'methods'!`
50		50
51	`checkArity(op, args); */`	51	`checkArity(op, args); */`
52	`if (nargs < 6)`	52	`if (nargs < 5)`
53	`error("%d arguments passed to .Internal(%s) which requires %d",`	53	`error("%d arguments passed to .Internal(%s) which requires %d",`
54	`length(args), PRIMNAME(op), PRIMARITY(op));`	54	`length(args), PRIMNAME(op), PRIMARITY(op));`
55		55
56	`SEXP x = CAR(args); args = CDR(args);`	56	`SEXP x = CAR(args); args = CDR(args);`
57	`SEXP y = CAR(args); args = CDR(args);`	57	`SEXP y = CAR(args); args = CDR(args);`
58	`num_eq = asLogical(CAR(args)); args = CDR(args);`	58	`num_eq = asLogical(CAR(args)); args = CDR(args);`
59	`single_NA = asLogical(CAR(args)); args = CDR(args);`	59	`single_NA = asLogical(CAR(args)); args = CDR(args);`
60	`attr_as_set = asLogical(CAR(args)); args = CDR(args);`	60	`attr_as_set = asLogical(CAR(args)); args = CDR(args);`
-		61	`if (nargs >= 6)`
61	`ignore_bytecode = asLogical(CAR(args));`	62	`ignore_bytecode = asLogical(CAR(args));`
62	`if (nargs >= 7)`	63	`if (nargs >= 7)`
63	`ignore_env = asLogical(CADR(args));`	64	`ignore_env = asLogical(CADR(args));`
64		65
65	`if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");`	66	`if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");`
66	`if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");`	67	`if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");`
Line 77...	Line 78...
77	`#define SINGLE_NA (!(flags & 2))`	78	`#define SINGLE_NA (!(flags & 2))`
78	`#define ATTR_AS_SET (!(flags & 4))`	79	`#define ATTR_AS_SET (!(flags & 4))`
79	`#define IGNORE_BYTECODE (!(flags & 8))`	80	`#define IGNORE_BYTECODE (!(flags & 8))`
80	`#define IGNORE_ENV (!(flags & 16))`	81	`#define IGNORE_ENV (!(flags & 16))`
81		82
82	`/* do the two objects compute as identical? Also used in unique.c */`	83	`/* do the two objects compute as identical?`
-		84	`Also used in unique.c */`
83	`Rboolean`	85	`Rboolean`
84	`R_compute_identical(SEXP x, SEXP y, int flags)`	86	`R_compute_identical(SEXP x, SEXP y, int flags)`
85	`{`	87	`{`
86	`SEXP ax, ay, atrx, atry;`	88	`SEXP ax, ay, atrx, atry;`
87	`if(x == y) /* same pointer */`	89	`if(x == y) /* same pointer */`
Line 89...	Line 91...
89	`if(TYPEOF(x) != TYPEOF(y))`	91	`if(TYPEOF(x) != TYPEOF(y))`
90	`return FALSE;`	92	`return FALSE;`
91	`if(OBJECT(x) != OBJECT(y))`	93	`if(OBJECT(x) != OBJECT(y))`
92	`return FALSE;`	94	`return FALSE;`
93		95
-		96	`/* Skip attribute checks for CHARSXP`
94	`/* Skip attribute checks for CHARSXP -- such attributes can be used for internal purposes */`	97	`-- such attributes are used for the cache. */`
95	`if(TYPEOF(x) == CHARSXP)`	98	`if(TYPEOF(x) == CHARSXP)`
96	`{`	99	`{`
97	`/* This matches NAs */`	100	`/* This matches NAs */`
98	`return Seql(x, y);`	101	`return Seql(x, y);`
99	`}`	102	`}`
Line 106...	Line 109...
106	`don't test them if they are not, and we do not test the order`	109	`don't test them if they are not, and we do not test the order`
107	`if they are.`	110	`if they are.`
108		111
109	`This code is not very efficient, but then neither is using`	112	`This code is not very efficient, but then neither is using`
110	`pairlists for attributes. If long attribute lists become more`	113	`pairlists for attributes. If long attribute lists become more`
111	`common (and they are used for S4 slots) we should store them in a hash`	114	`common (and they are used for S4 slots) we should store them in`
112	`table.`	115	`a hash table.`
113	`*/`	116	`*/`
114	`else if(ax != R_NilValue \|\| ay != R_NilValue) {`	117	`else if(ax != R_NilValue \|\| ay != R_NilValue) {`
115	`if(ax == R_NilValue \|\| ay == R_NilValue)`	118	`if(ax == R_NilValue \|\| ay == R_NilValue)`
116	`return FALSE;`	119	`return FALSE;`
117	`if(TYPEOF(ax) != LISTSXP \|\| TYPEOF(ay) != LISTSXP) {`	120	`if(TYPEOF(ax) != LISTSXP \|\| TYPEOF(ay) != LISTSXP) {`
Line 146...	Line 149...
146	`switch (TYPEOF(x)) {`	149	`switch (TYPEOF(x)) {`
147	`case NILSXP:`	150	`case NILSXP:`
148	`return TRUE;`	151	`return TRUE;`
149	`case LGLSXP:`	152	`case LGLSXP:`
150	`if (xlength(x) != xlength(y)) return FALSE;`	153	`if (xlength(x) != xlength(y)) return FALSE;`
151	`/* Use memcmp (which is ISO C) to speed up the comparison */`	154	`/* Use memcmp (which is ISO C90) to speed up the comparison */`
152	`return memcmp((void )LOGICAL(x), (void )LOGICAL(y),`	155	`return memcmp((void )LOGICAL(x), (void )LOGICAL(y),`
153	`xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;`	156	`xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;`
154	`case INTSXP:`	157	`case INTSXP:`
155	`if (xlength(x) != xlength(y)) return FALSE;`	158	`if (xlength(x) != xlength(y)) return FALSE;`
156	`/* Use memcmp (which is ISO C) to speed up the comparison */`	159	`/* Use memcmp (which is ISO C90) to speed up the comparison */`
157	`return memcmp((void )INTEGER(x), (void )INTEGER(y),`	160	`return memcmp((void )INTEGER(x), (void )INTEGER(y),`
158	`xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;`	161	`xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;`
159	`case REALSXP:`	162	`case REALSXP:`
160	`{`	163	`{`
161	`R_xlen_t n = xlength(x);`	164	`R_xlen_t n = xlength(x);`
Line 242...	Line 245...
242	`return(x == y ? TRUE : FALSE);`	245	`return(x == y ? TRUE : FALSE);`
243	`case EXTPTRSXP:`	246	`case EXTPTRSXP:`
244	`return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);`	247	`return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);`
245	`case RAWSXP:`	248	`case RAWSXP:`
246	`if (xlength(x) != xlength(y)) return FALSE;`	249	`if (xlength(x) != xlength(y)) return FALSE;`
247	`/* Use memcmp (which is ISO C) to speed up the comparison */`	250	`/* Use memcmp (which is ISO C90) to speed up the comparison */`
248	`return memcmp((void )RAW(x), (void )RAW(y),`	251	`return memcmp((void )RAW(x), (void )RAW(y),`
249	`xlength(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;`	252	`xlength(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;`
250		253
251	`/* case PROMSXP: args are evaluated, so will not be seen */`	254	`/* case PROMSXP: args are evaluated, so will not be seen */`
252	`/* test for equality of the substituted expression -- or should`	255	`/* test for equality of the substituted expression -- or should`
253	`we require both expression and environment to be identical? */`	256	`we require both expression and environment to be identical? */`
254	`/*#define PREXPR(x) ((x)->u.promsxp.expr)`	257	`/*#define PREXPR(x) ((x)->u.promsxp.expr)`
255	`#define PRENV(x) ((x)->u.promsxp.env)`	258	`#define PRENV(x) ((x)->u.promsxp.env)`
256	`return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),`	259	`return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),`

The R Project SVN R

(root)/trunk/src/main/identical.c – Rev 59534 → 59545