The R Project SVN R

Rev

Rev 87938 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
526 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
90234 maechler 3 
 *  Copyright (C) 1999-2026  The R Core Team.
83581 maechler 4 
 *  Copyright (C) 2002-2023  The R Foundation
2 r 5 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
6 
 *
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
21352 maechler 9 
 *  the Free Software Foundation; either version 2, or (at your option)
10 
 *  any later version.
2 r 11 
 *
21812 maechler 12 
 *  This program is distributed in the hope that it will be useful,
13 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 
 *  GNU General Public License for more details.
2 r 16 
 *
42307 ripley 17 
 *  You should have received a copy of the GNU General Public License
18 
 *  along with this program; if not, a copy is available at
68947 ripley 19 
 *  https://www.R-project.org/Licenses/
2 r 20 
 */
21 
 
1839 ihaka 22 
/*  This module contains support for S-style generic */
23 
/*  functions and "class" support.  Gag, barf ...  */
2 r 24 
 
5187 hornik 25 
#ifdef HAVE_CONFIG_H
7701 hornik 26 
#include <config.h>
5187 hornik 27 
#endif
28 
 
57538 ripley 29 
#define R_USE_SIGNALS 1
60667 ripley 30 
#include <Defn.h>
31 
#include <Internal.h>
90234 maechler 32 
#include <R_ext/RS.h> /* for R_Calloc, R_Realloc and for S4 object bit, R_allocObject() */
2 r 33 
 
34 
static SEXP GetObject(RCNTXT *cptr)
35 
{
66693 luke 36 
    SEXP s, b, formals, tag;
8130 pd 37 
 
66693 luke 38 
    b = cptr->callfun;
32867 ripley 39 
    if (TYPEOF(b) != CLOSXP) error(_("generic 'function' is not a function"));
8130 pd 40 
    formals = FORMALS(b);
41 
 
42 
    tag = TAG(formals);
43 
    if (tag != R_NilValue && tag != R_DotsSymbol) {
63050 luke 44 
	s = NULL;
8130 pd 45 
	/** exact matches **/
21352 maechler 46 
	for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
47 
	    if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {
63050 luke 48 
		if (s != NULL)
85614 kalibera 49 
		    error(_("formal argument \"%s\" matched by multiple actual arguments"),
50 
		          CHAR(PRINTNAME(tag)));
21352 maechler 51 
		else
8130 pd 52 
		    s = CAR(b);
53 
	    }
54 
 
63050 luke 55 
	if (s == NULL)
8130 pd 56 
	    /** partial matches **/
21352 maechler 57 
	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
58 
		if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {
63050 luke 59 
		    if ( s != NULL)
85614 kalibera 60 
			error(_("formal argument \"%s\" matched by multiple actual arguments"),
61 
			      CHAR(PRINTNAME(tag)));
21352 maechler 62 
		    else
8130 pd 63 
			s = CAR(b);
64 
		}
63050 luke 65 
	if (s == NULL)
8130 pd 66 
	    /** first untagged argument **/
21352 maechler 67 
	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
68 
		if (TAG(b) == R_NilValue )
8130 pd 69 
		{
70 
		    s = CAR(b);
71 
		    break;
72 
		}
63050 luke 73 
	if (s == NULL)
8130 pd 74 
	    s = CAR(cptr->promargs);
75 
/*
76 
	    error("failed to match argument for dispatch");
77 
*/
78 
    }
79 
    else
80 
	s = CAR(cptr->promargs);
81 
 
1839 ihaka 82 
    if (TYPEOF(s) == PROMSXP) {
85690 luke 83 
	if (! PROMISE_IS_EVALUATED(s))
35450 murdoch 84 
	    s = eval(s, R_BaseEnv);
18214 luke 85 
	else
86 
	    s = PRVALUE(s);
1839 ihaka 87 
    }
88 
    return(s);
2 r 89 
}
90 
 
66694 luke 91 
static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newvars)
2 r 92 
{
1839 ihaka 93 
    SEXP ans;
94 
    if (TYPEOF(op) == SPECIALSXP) {
40090 ripley 95 
	int save = R_PPStackTop, flag = PRIMPRINT(op);
50745 ripley 96 
	const void *vmax = vmaxget();
40090 ripley 97 
	R_Visible = flag != 1;
1839 ihaka 98 
	ans = PRIMFUN(op) (call, op, args, rho);
40090 ripley 99 
	if (flag < 2) R_Visible = flag != 1;
39232 ripley 100 
	check_stack_balance(op, save);
41825 ripley 101 
	vmaxset(vmax);
1839 ihaka 102 
    }
38982 ripley 103 
    /* In other places we add a context to builtins when profiling,
42110 maechler 104 
       but we have not bothered here (as there seem to be no primitives
38982 ripley 105 
       used as methods, and this would have to be a primitive to be
106 
       found).
38522 ripley 107 
     */
1839 ihaka 108 
    else if (TYPEOF(op) == BUILTINSXP) {
40090 ripley 109 
	int save = R_PPStackTop, flag = PRIMPRINT(op);
50745 ripley 110 
	const void *vmax = vmaxget();
50690 ripley 111 
	PROTECT(args = evalList(args, rho, call, 0));
40090 ripley 112 
	R_Visible = flag != 1;
1839 ihaka 113 
	ans = PRIMFUN(op) (call, op, args, rho);
40090 ripley 114 
	if (flag < 2) R_Visible = flag != 1;
1839 ihaka 115 
	UNPROTECT(1);
39232 ripley 116 
	check_stack_balance(op, save);
41825 ripley 117 
	vmaxset(vmax);
1839 ihaka 118 
    }
119 
    else if (TYPEOF(op) == CLOSXP) {
85283 luke 120 
	ans = applyClosure(call, op, args, rho, newvars, FALSE);
1839 ihaka 121 
    }
2342 maechler 122 
    else
1839 ihaka 123 
	ans = R_NilValue;  /* for -Wall */
124 
    return ans;
2 r 125 
}
126 
 
127 
 
1839 ihaka 128 
/* "newintoold" -  a destructive matching of arguments; */
129 
/* newargs comes first; any element of oldargs with */
130 
/* a name that matches a named newarg is deleted; the */
131 
/* two resulting lists are appended and returned. */
132 
/* S claims to do this (white book) but doesn't seem to. */
2 r 133 
 
39866 duncan 134 
static SEXP newintoold(SEXP _new, SEXP old)
2 r 135 
{
39866 duncan 136 
    if (_new == R_NilValue) return R_NilValue;
137 
    SETCDR(_new, newintoold(CDR(_new),old));
1839 ihaka 138 
    while (old != R_NilValue) {
39866 duncan 139 
	if (TAG(old) != R_NilValue && TAG(old) == TAG(_new)) {
140 
	    SETCAR(old, CAR(_new));
141 
	    return CDR(_new);
2 r 142 
	}
1839 ihaka 143 
	old = CDR(old);
144 
    }
39866 duncan 145 
    return _new;
2 r 146 
}
147 
 
148 
static SEXP matchmethargs(SEXP oldargs, SEXP newargs)
149 
{
1839 ihaka 150 
    newargs = newintoold(newargs, oldargs);
151 
    return listAppend(oldargs, newargs);
2 r 152 
}
153 
 
63624 ripley 154 
/* R_MethodsNamespace is initialized to R_GlobalEnv when R is
155 
   initialized.  If it set to the methods namespace when the latter is
156 
   loaded, and back to R_GlobalEnv when it is unloaded. */
157 
 
48117 jmc 158 
#ifdef S3_for_S4_warn /* not currently used */
66622 maechler 159 
static SEXP s_check_S3_for_S4 = NULL;
48117 jmc 160 
void R_warn_S3_for_S4(SEXP method) {
161 
  SEXP call;
162 
  if(!s_check_S3_for_S4)
163 
    s_check_S3_for_S4 = install(".checkS3forS4");
164 
  PROTECT(call = lang2(s_check_S3_for_S4, method));
165 
  eval(call, R_MethodsNamespace);
166 
  UNPROTECT(1);
167 
}
168 
#endif
169 
 
73781 hornik 170 
static SEXP findFunInEnvRange(SEXP symbol, SEXP rho, SEXP target)
171 
{
172 
    SEXP vl;
173 
    while(rho != R_EmptyEnv) {
86821 luke 174 
	vl = R_findVarInFrame(rho, symbol);
73781 hornik 175 
	if (vl != R_UnboundValue) {
176 
	    if (TYPEOF(vl) == PROMSXP) {
177 
		PROTECT(vl);
178 
		vl = eval(vl, rho);
179 
		UNPROTECT(1);
180 
	    }
181 
	    if ((TYPEOF(vl) == CLOSXP ||
182 
		 TYPEOF(vl) == BUILTINSXP ||
183 
		 TYPEOF(vl) == SPECIALSXP))
184 
		return (vl);
185 
	}
186 
	if(rho == target)
187 
	    return (R_UnboundValue);
188 
	else
189 
	    rho = ENCLOS(rho);
190 
    }
191 
    return (R_UnboundValue);
192 
}
193 
 
194 
static SEXP findFunWithBaseEnvAfterGlobalEnv(SEXP symbol, SEXP rho)
195 
{
196 
    SEXP vl;
197 
    while(rho != R_EmptyEnv) {
86821 luke 198 
	vl = R_findVarInFrame(rho, symbol);
73781 hornik 199 
	if (vl != R_UnboundValue) {
200 
	    if (TYPEOF(vl) == PROMSXP) {
201 
		PROTECT(vl);
202 
		vl = eval(vl, rho);
203 
		UNPROTECT(1);
204 
	    }
205 
	    if ((TYPEOF(vl) == CLOSXP ||
206 
		 TYPEOF(vl) == BUILTINSXP ||
207 
		 TYPEOF(vl) == SPECIALSXP))
208 
		return (vl);
209 
	}
210 
	if(rho == R_GlobalEnv)
211 
	    rho = R_BaseEnv;
212 
	else
213 
	    rho = ENCLOS(rho);
214 
    }
215 
    return (R_UnboundValue);
216 
}
217 
 
2 r 218 
/*  usemethod  -  calling functions need to evaluate the object
526 maechler 219 
 *  (== 2nd argument).	They also need to ensure that the
2 r 220 
 *  argument list is set up in the correct manner.
526 maechler 221 
 *
2 r 222 
 *    1. find the context for the calling function (i.e. the generic)
223 
 *	 this gives us the unevaluated arguments for the original call
224 
 *
225 
 *    2. create an environment for evaluating the method and insert
526 maechler 226 
 *	 a handful of variables (.Generic, .Class and .Method) into
227 
 *	 that environment. Also copy any variables in the env of the
228 
 *	 generic that are not formal (or actual) arguments.
2 r 229 
 *
230 
 *    3. fix up the argument list; it should be the arguments to the
526 maechler 231 
 *	 generic matched to the formals of the method to be invoked */
2 r 232 
 
61771 ripley 233 
attribute_hidden
16335 luke 234 
SEXP R_LookupMethod(SEXP method, SEXP rho, SEXP callrho, SEXP defrho)
235 
{
73790 hornik 236 
    SEXP val, top = R_NilValue;	/* -Wall */
66441 luke 237 
    static SEXP s_S3MethodsTable = NULL;
75532 kalibera 238 
    PROTECT_INDEX validx;
16335 luke 239 
 
66693 luke 240 
    if (TYPEOF(callrho) != ENVSXP) {
68923 ripley 241 
	if (TYPEOF(callrho) == NILSXP)
66693 luke 242 
	    error(_("use of NULL environment is defunct"));
68923 ripley 243 
	else
32867 ripley 244 
	    error(_("bad generic call environment"));
66693 luke 245 
    }
38132 ripley 246 
    if (defrho == R_BaseEnv)
247 
	defrho = R_BaseNamespace;
66693 luke 248 
    else if (TYPEOF(defrho) != ENVSXP) {
68923 ripley 249 
	if (TYPEOF(defrho) == NILSXP)
250 
	    error(_("use of NULL environment is defunct"));
251 
	else
252 
	    error(_("bad generic definition environment"));
66693 luke 253 
    }
42110 maechler 254 
 
38135 ripley 255 
    /* This evaluates promises */
74253 hornik 256 
    PROTECT(top = topenv(R_NilValue, callrho));
257 
    val = findFunInEnvRange(method, callrho, top);
258 
    if(val != R_UnboundValue) {
75532 kalibera 259 
	UNPROTECT(1); /* top */
74253 hornik 260 
	return val;
73790 hornik 261 
    }
74253 hornik 262 
 
75532 kalibera 263 
    PROTECT_WITH_INDEX(val, &validx);
73790 hornik 264 
    /* We assume here that no one registered a non-function */
265 
    if (!s_S3MethodsTable)
266 
	s_S3MethodsTable = install(".__S3MethodsTable__.");
86821 luke 267 
    SEXP table = R_findVarInFrame(defrho, s_S3MethodsTable);
73790 hornik 268 
    if (TYPEOF(table) == PROMSXP) {
269 
	PROTECT(table);
270 
	table = eval(table, R_BaseEnv);
75532 kalibera 271 
	UNPROTECT(1); /* table */
73781 hornik 272 
    }
73790 hornik 273 
    if (TYPEOF(table) == ENVSXP) {
74441 kalibera 274 
	PROTECT(table);
86821 luke 275 
	REPROTECT(val = R_findVarInFrame(table, method), validx);
75532 kalibera 276 
	UNPROTECT(1); /* table */
90234 maechler 277 
	if (TYPEOF(val) == PROMSXP)
75532 kalibera 278 
	    REPROTECT(val = eval(val, rho), validx);
74253 hornik 279 
	if(val != R_UnboundValue) {
75532 kalibera 280 
	    UNPROTECT(2); /* top, val */
66693 luke 281 
	    return val;
74253 hornik 282 
	}
90234 maechler 283 
    }
73790 hornik 284 
 
83907 hornik 285 
    if (top == R_GlobalEnv)
286 
	top = R_BaseEnv;
74253 hornik 287 
    else
83907 hornik 288 
	top = ENCLOS(top);
289 
    REPROTECT(val = findFunWithBaseEnvAfterGlobalEnv(method, top),
290 
	      validx);
73790 hornik 291 
 
75532 kalibera 292 
    UNPROTECT(2); /* top, val */
74253 hornik 293 
    return val;
16335 luke 294 
}
295 
 
48068 ripley 296 
#ifdef UNUSED
48062 jmc 297 
static int match_to_obj(SEXP arg, SEXP obj) {
298 
  return (arg == obj) ||
299 
    (TYPEOF(arg) == PROMSXP && PRVALUE(arg) == obj);
300 
}
48068 ripley 301 
#endif
48062 jmc 302 
 
48694 jmc 303 
/* look up the class name in the methods package table of S3 classes
304 
   which should be explicitly converted when an S3 method is applied
305 
   to an object from an S4 subclass.
306 
*/
86655 luke 307 
attribute_hidden int isBasicClass(const char *ss) {
66622 maechler 308 
    static SEXP s_S3table = NULL;
48694 jmc 309 
    if(!s_S3table) {
86821 luke 310 
      s_S3table = R_findVarInFrame(R_MethodsNamespace,
311 
				   install(".S3MethodsClasses"));
48694 jmc 312 
      if(s_S3table == R_UnboundValue)
60844 ripley 313 
	error(_("no '.S3MethodsClass' table, cannot use S4 objects with S3 methods ('methods' package not attached?)"));
66622 maechler 314 
      if (TYPEOF(s_S3table) == PROMSXP)  /* findVar... ignores lazy data */
315 
	s_S3table = eval(s_S3table, R_MethodsNamespace);
48694 jmc 316 
    }
317 
    if(s_S3table == R_UnboundValue)
318 
      return FALSE; /* too screwed up to do conversions */
86790 luke 319 
    return R_existsVarInFrame(s_S3table, install(ss));
48694 jmc 320 
}
321 
 
66641 maechler 322 
/* Note that ./attrib.c 's S4_extends() has an alternative
323 
   'sanity check for methods package available' */
86655 luke 324 
attribute_hidden Rboolean R_has_methods_attached(void) {
66641 maechler 325 
    return(
326 
	isMethodsDispatchOn() &&
327 
	// based on unlockBinding() in ../library/methods/R/zzz.R  {since 2003}:
328 
	!R_BindingIsLocked(install(".BasicFunsList"), R_MethodsNamespace));
329 
}
330 
 
66694 luke 331 
static R_INLINE
332 
SEXP addS3Var(SEXP vars, SEXP name, SEXP value) {
333 
 
66713 luke 334 
    SEXP res = CONS(value, vars);
335 
    SET_TAG(res, name);
336 
    return res;
66694 luke 337 
}
338 
 
339 
attribute_hidden
340 
SEXP createS3Vars(SEXP dotGeneric, SEXP dotGroup, SEXP dotClass, SEXP dotMethod,
68923 ripley 341 
		  SEXP dotGenericCallEnv, SEXP dotGenericDefEnv) {
66694 luke 342 
 
343 
    SEXP v = R_NilValue;
344 
    v = addS3Var(v, R_dot_GenericDefEnv, dotGenericDefEnv);
345 
    v = addS3Var(v, R_dot_GenericCallEnv, dotGenericCallEnv);
346 
    v = addS3Var(v, R_dot_Group, dotGroup);
347 
    v = addS3Var(v, R_dot_Method, dotMethod);
348 
    v = addS3Var(v, R_dot_Class, dotClass);
349 
    v = addS3Var(v, R_dot_Generic, dotGeneric);
350 
 
351 
    return v;
352 
}
353 
 
354 
 
66327 luke 355 
static
356 
SEXP dispatchMethod(SEXP op, SEXP sxp, SEXP dotClass, RCNTXT *cptr, SEXP method,
357 
		    const char *generic, SEXP rho, SEXP callrho, SEXP defrho) {
52431 maechler 358 
 
66694 luke 359 
    SEXP newvars = PROTECT(createS3Vars(
68923 ripley 360 
	PROTECT(mkString(generic)),
361 
	R_BlankScalarString,
362 
	dotClass,
363 
	PROTECT(ScalarString(PRINTNAME(method))),
364 
	callrho,
365 
	defrho
66694 luke 366 
    ));
367 
 
66327 luke 368 
    /* Create a new environment without any */
369 
    /* of the formals to the generic in it. */
370 
 
371 
    if (TYPEOF(op) == CLOSXP) {
372 
	SEXP formals = FORMALS(op);
373 
	SEXP s, t;
374 
	int matched;
375 
 
376 
	for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {
377 
	    matched = 0;
378 
	    for (t = formals; t != R_NilValue; t = CDR(t))
68923 ripley 379 
		if (TAG(t) == TAG(s)) {
66327 luke 380 
		    matched = 1;
66441 luke 381 
		    break;
66327 luke 382 
		}
66694 luke 383 
	    if (!matched) {
85323 luke 384 
#ifdef USEMETHOD_FORWARD_LOCALS
68923 ripley 385 
		UNPROTECT(1); /* newvars */
386 
		newvars = PROTECT(CONS(CAR(s), newvars));
387 
		SET_TAG(newvars, TAG(s));
85323 luke 388 
#else
389 
		static int option = -1;
390 
		if (option == -1) {
86135 luke 391 
		    option = 2; // none: the default
85323 luke 392 
		    const char *val = getenv("R_USEMETHOD_FORWARD_LOCALS");
85974 luke 393 
		    if (val != NULL) {
85323 luke 394 
			if (strcmp(val, "all") == 0)
395 
			    option = 0;
396 
			else if (strcmp(val, "S4") == 0)
397 
			    option = 1;
398 
			else if (strcmp(val, "none") == 0)
399 
			    option = 2;
400 
			else if (strcmp(val, "error") == 0)
401 
			    option = 3;
85979 luke 402 
			else if (strcmp(val, "warning") == 0)
403 
			    option = 4;
85974 luke 404 
			else
85323 luke 405 
			    warning("bad value for R_USEMETHOD_FORWARD_LOCALS");
406 
		    }
407 
		}
408 
		SEXP val;
409 
		char buf[8192];
410 
		switch(option) {
86135 luke 411 
		case 0: // forward all, as in the past before R 4.4.0
85323 luke 412 
		    UNPROTECT(1); /* newvars */
413 
		    newvars = PROTECT(CONS(CAR(s), newvars));
414 
		    SET_TAG(newvars, TAG(s));
415 
		    break;
416 
		case 1: // forward only S4 variables
417 
		    if (TAG(s) == R_dot_defined ||
418 
			TAG(s) == R_dot_Method ||
419 
			TAG(s) == R_dot_target ||
420 
			TAG(s) == R_dot_Generic ||
421 
			TAG(s) == R_dot_Methods) {
422 
			UNPROTECT(1); /* newvars */
423 
			newvars = PROTECT(CONS(CAR(s), newvars));
424 
			SET_TAG(newvars, TAG(s));
425 
		    }
426 
		    break;
427 
		case 2: // don't forward any variables
428 
		    break;
429 
		case 3: // forward all, with an error when used
90234 maechler 430 
#ifdef WARN_ON_FORWARDING
85341 luke 431 
		    if (TAG(s) != R_dot_defined &&
432 
			TAG(s) != R_dot_Method &&
433 
			TAG(s) != R_dot_target &&
434 
			TAG(s) != R_dot_Generic &&
435 
			TAG(s) != R_dot_Methods)
436 
			warningcall_immediate(R_NilValue,
437 
					      "UseMethod forwarding '%s' "
438 
					      "in generic '%s'",
439 
				CHAR(PRINTNAME(TAG(s))),
440 
				generic);
85361 luke 441 
#endif
85323 luke 442 
		    snprintf(buf, sizeof(buf),
85341 luke 443 
			     "stop(\"getting UseMethod variable '%s' "
85979 luke 444 
			     "from generic '%s'; "
445 
			     "this is no longer supported\")",
85341 luke 446 
			     CHAR(PRINTNAME(TAG(s))),
447 
			     generic);
85323 luke 448 
		    val = mkPROMISE(R_ParseString(buf), R_GlobalEnv);
449 
		    UNPROTECT(1); /* newvars */
450 
		    newvars = PROTECT(CONS(val, newvars));
451 
		    SET_TAG(newvars, TAG(s));
452 
		    break;
453 
		default:
454 
		    option = 0;
455 
		    warning("bad value for R_USEMETHOD_FORWARD_LOCALS");
456 
		}
457 
#endif
68923 ripley 458 
	    }
66327 luke 459 
	}
460 
    }
461 
 
74750 kalibera 462 
    /* Debug a method when debugging the generic. When called via UseMethod or
463 
       NextMethod, RSTEP(op) will always be zero because the bit is cleared by
464 
       applyClosure. We thus approximate and enter the debugger also when
465 
       RDEBUG(rho) is set. */
466 
    if ((RDEBUG(op) && R_current_debug_state()) || RSTEP(op) || RDEBUG(rho))
68923 ripley 467 
	SET_RSTEP(sxp, 1);
66327 luke 468 
 
74623 luke 469 
    SEXP newcall =  PROTECT(shallow_duplicate(cptr->call));
66327 luke 470 
    SETCAR(newcall, method);
471 
    R_GlobalContext->callflag = CTXT_GENERIC;
66694 luke 472 
    SEXP matchedarg = PROTECT(cptr->promargs); /* ? is this PROTECT needed ? */
473 
    SEXP ans = applyMethod(newcall, sxp, matchedarg, rho, newvars);
66327 luke 474 
    R_GlobalContext->callflag = CTXT_RETURN;
66694 luke 475 
    UNPROTECT(5); /* "generic,method", newvars, newcall, matchedarg */
66327 luke 476 
 
477 
    return ans;
478 
}
479 
 
61771 ripley 480 
attribute_hidden
41784 ripley 481 
int usemethod(const char *generic, SEXP obj, SEXP call, SEXP args,
16335 luke 482 
	      SEXP rho, SEXP callrho, SEXP defrho, SEXP *ans)
2 r 483 
{
66328 luke 484 
    SEXP klass, method, sxp;
66327 luke 485 
    SEXP op;
66441 luke 486 
    int i, nclass;
1839 ihaka 487 
    RCNTXT *cptr;
2 r 488 
 
1839 ihaka 489 
    /* Get the context which UseMethod was called from. */
2 r 490 
 
1839 ihaka 491 
    cptr = R_GlobalContext;
66693 luke 492 
    op = cptr->callfun;
39866 duncan 493 
    PROTECT(klass = R_data_class2(obj));
48062 jmc 494 
 
39866 duncan 495 
    nclass = length(klass);
48409 jmc 496 
    for (i = 0; i < nclass; i++) {
63181 ripley 497 
	const void *vmax = vmaxget();
68923 ripley 498 
	const char *ss = translateChar(STRING_ELT(klass, i));
66388 luke 499 
	method = installS3Signature(generic, ss);
63181 ripley 500 
	vmaxset(vmax);
22764 jmc 501 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
502 
	if (isFunction(sxp)) {
66328 luke 503 
	    if(method == R_SortListSymbol && CLOENV(sxp) == R_BaseNamespace)
52266 jmc 504 
		continue; /* kludge because sort.list is not a method */
68250 luke 505 
	    PROTECT(sxp);
68923 ripley 506 
	    if (i > 0) {
66441 luke 507 
		SEXP dotClass = PROTECT(stringSuffix(klass, i));
66328 luke 508 
		setAttrib(dotClass, R_PreviousSymbol, klass);
66327 luke 509 
		*ans = dispatchMethod(op, sxp, dotClass, cptr, method, generic,
510 
				      rho, callrho, defrho);
511 
		UNPROTECT(1); /* dotClass */
512 
	    } else {
68923 ripley 513 
		*ans = dispatchMethod(op, sxp, klass, cptr, method, generic,
66327 luke 514 
				      rho, callrho, defrho);
68923 ripley 515 
	    }
68250 luke 516 
	    UNPROTECT(2); /* klass, sxp */
24519 ripley 517 
	    return 1;
2 r 518 
	}
1839 ihaka 519 
    }
66388 luke 520 
    method = installS3Signature(generic, "default");
68250 luke 521 
    PROTECT(sxp = R_LookupMethod(method, rho, callrho, defrho));
1839 ihaka 522 
    if (isFunction(sxp)) {
68923 ripley 523 
	*ans = dispatchMethod(op, sxp, R_NilValue, cptr, method, generic,
66327 luke 524 
			      rho, callrho, defrho);
68250 luke 525 
	UNPROTECT(2); /* klass, sxp */
1839 ihaka 526 
	return 1;
527 
    }
68250 luke 528 
    UNPROTECT(2); /* klass, sxp */
1839 ihaka 529 
    cptr->callflag = CTXT_RETURN;
530 
    return 0;
2 r 531 
}
532 
 
51245 ripley 533 
/* Note: "do_usemethod" is not the only entry point to
534 
   "usemethod". Things like [ and [[ call usemethod directly,
52431 maechler 535 
   hence do_usemethod should just be an interface to usemethod.
51245 ripley 536 
*/
2 r 537 
 
51245 ripley 538 
/* This is a primitive SPECIALSXP */
90234 maechler 539 
NORET attribute_hidden
83454 ripley 540 
SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 541 
{
66326 luke 542 
    static SEXP do_usemethod_formals = NULL;
543 
    if (do_usemethod_formals == NULL)
68923 ripley 544 
	do_usemethod_formals = allocFormalsList2(install("generic"),
66326 luke 545 
						 install("object"));
546 
 
83581 maechler 547 
    SEXP argList = PROTECT(matchArgs_NR(do_usemethod_formals, args, call));
51265 ripley 548 
    if (CAR(argList) == R_MissingArg)
52431 maechler 549 
	errorcall(call, _("there must be a 'generic' argument"));
83581 maechler 550 
    // else
551 
    SEXP generic = PROTECT(eval(CAR(argList), env));
68586 ripley 552 
    if(!isString(generic) || LENGTH(generic) != 1)
51265 ripley 553 
	errorcall(call, _("'generic' argument must be a character string"));
2 r 554 
 
16335 luke 555 
    /* get environments needed for dispatching.
556 
       callenv = environment from which the generic was called
557 
       defenv = environment where the generic was defined */
83581 maechler 558 
    RCNTXT *cptr = R_GlobalContext;
16335 luke 559 
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)
41713 ripley 560 
	errorcall(call, _("'UseMethod' used in an inappropriate fashion"));
83581 maechler 561 
    SEXP callenv = cptr->sysparent;
38132 ripley 562 
    /* We need to find the generic to find out where it is defined.
563 
       This is set up to avoid getting caught by things like
42110 maechler 564 
 
45446 ripley 565 
	mycoef <- function(x)
38132 ripley 566 
       {
45446 ripley 567 
	   mycoef <- function(x) stop("not this one")
568 
	   UseMethod("mycoef")
38132 ripley 569 
       }
38141 ripley 570 
 
571 
	The generic need not be a closure (Henrik Bengtsson writes
572 
	UseMethod("$"), although only functions are documented.)
38132 ripley 573 
    */
83905 hornik 574 
    SEXP defenv = topenv(R_NilValue, env);
83581 maechler 575 
    SEXP obj = PROTECT((CADR(argList) != R_MissingArg)
576 
		       ? eval(CADR(argList), env)
577 
		       : GetObject(cptr));
578 
    SEXP ans;
40705 ripley 579 
    if (usemethod(translateChar(STRING_ELT(generic, 0)), obj, call, CDR(args),
16335 luke 580 
		  env, callenv, defenv, &ans) == 1) {
67024 luke 581 
	UNPROTECT(3); /* obj, generic, argList */
40236 ripley 582 
	findcontext(CTXT_RETURN, env, ans); /* does not return */
1839 ihaka 583 
    }
83581 maechler 584 
    else { // no method found
585 
#define CLLEN 1024
586 
	char cl[CLLEN] = {0};
587 
	SEXP klass = PROTECT(R_data_class2(obj));
588 
	int nclass = length(klass);
589 
	if(!nclass)
590 
	    errorcall(call, _("illegal class of length 0 when using method for '%s'"),
591 
		      translateChar(STRING_ELT(generic, 0)));
592 
	const char *c_name = translateChar(STRING_ELT(klass, 0));
593 
	if (nclass == 1) {
594 
	    strncpy(cl, c_name, CLLEN-1); cl[CLLEN-1] = '\0';
595 
	} else { // nclass >= 2
596 
	    size_t cl_count = 3; // 3 : "c(" + \0
48717 ripley 597 
	    strcpy(cl, "c('");
66751 maechler 598 
	    for (int i = 0; i < nclass; i++) {
83581 maechler 599 
		if(i > 0) {
600 
		    c_name = translateChar(STRING_ELT(klass, i));
601 
		    cl_count += 4; // "', '"
602 
		    if (cl_count < CLLEN) strcat(cl, "', '");
603 
		}
604 
		size_t len_nm = strlen(c_name);
605 
		if (cl_count + len_nm >= CLLEN) {
606 
		    cl_count += 2;
607 
		    if(cl_count < CLLEN) strcat(cl, "..");
608 
		    break;
609 
		}
610 
		// else
611 
		cl_count += len_nm;
612 
		strcat(cl, c_name);
48717 ripley 613 
	    }
83581 maechler 614 
	    if (++cl_count < CLLEN) strcat(cl, "'");
615 
	    if (++cl_count < CLLEN) strcat(cl, ")");
48717 ripley 616 
	}
617 
	errorcall(call, _("no applicable method for '%s' applied to an object of class \"%s\""),
618 
		  translateChar(STRING_ELT(generic, 0)), cl);
619 
    }
2 r 620 
}
621 
 
2524 maechler 622 
/*
2515 rgentlem 623 
   fixcall: fixes up the call when arguments to the function may
624 
   have changed; for now we only worry about tagged args, appending
625 
   them if they are not already there
626 
*/
627 
 
628 
static SEXP fixcall(SEXP call, SEXP args)
629 
{
2524 maechler 630 
    SEXP s, t;
2515 rgentlem 631 
    int found;
632 
 
38135 ripley 633 
    for(t = args; t != R_NilValue; t = CDR(t)) {
634 
	if(TAG(t) != R_NilValue) {
2515 rgentlem 635 
		found = 0;
38135 ripley 636 
		for(s = call; CDR(s) != R_NilValue; s = CDR(s))
66441 luke 637 
		    if(TAG(CDR(s)) == TAG(t)) {
68923 ripley 638 
			found = 1;
639 
			break;
640 
		    }
2515 rgentlem 641 
		if( !found ) {
10172 luke 642 
			SETCDR(s, allocList(1));
643 
			SET_TAG(CDR(s), TAG(t));
79253 hornik 644 
			SETCAR(CDR(s), lazy_duplicate(CAR(t)));
2515 rgentlem 645 
		}
646 
	}
647 
    }
2519 pd 648 
    return call;
2515 rgentlem 649 
}
650 
 
66388 luke 651 
/*
652 
   equalS3Signature: compares "signature" and "left.right"
66693 luke 653 
   all arguments must be non-null
66388 luke 654 
*/
655 
static
656 
Rboolean equalS3Signature(const char *signature, const char *left,
68923 ripley 657 
			 const char *right) {
66388 luke 658 
 
659 
    const char *s = signature;
660 
    const char *a;
661 
 
662 
    for(a = left; *a; s++, a++) {
68923 ripley 663 
	if (*s != *a)
664 
	    return FALSE;
66388 luke 665 
    }
666 
    if (*s++ != '.')
68923 ripley 667 
	return FALSE;
66388 luke 668 
    for(a = right; *a; s++, a++) {
68923 ripley 669 
	if (*s != *a)
670 
	    return FALSE;
66388 luke 671 
    }
672 
    return (*s == 0) ? TRUE : FALSE;
673 
}
674 
 
69256 luke 675 
 
676 
static R_INLINE SEXP getPrimitive(SEXP symbol)
677 
{
678 
    SEXP value = SYMVALUE(symbol);
679 
    if (TYPEOF(value) == PROMSXP) {
680 
	PROTECT(value);
681 
	value = eval(value, R_GlobalEnv);
682 
	UNPROTECT(1);
73166 luke 683 
	ENSURE_NAMEDMAX(value);
69256 luke 684 
    }
685 
    if (TYPEOF(value) == BUILTINSXP || TYPEOF(value) == SPECIALSXP)
686 
        return value;
687 
 
688 
    if (TYPEOF(value) == CLOSXP) {
689 
	/* probably means a package redefined the base function so
690 
	   try to get the real thing from the internal table of
691 
	   primitives */
692 
	value = R_Primitive(CHAR(PRINTNAME(symbol)));
693 
    } else
694 
	value = R_NilValue;
695 
 
696 
    return value;
697 
}
698 
 
1839 ihaka 699 
/* If NextMethod has any arguments the first must be the generic */
700 
/* the second the object and any remaining are matched with the */
701 
/* formals of the chosen method. */
526 maechler 702 
 
2 r 703 
 
51245 ripley 704 
/* This is a special .Internal */
83446 ripley 705 
attribute_hidden SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 706 
{
41784 ripley 707 
    const char *sb, *sg, *sk;
66388 luke 708 
    SEXP ans, s, t, klass, method, matchedarg, generic;
709 
    SEXP nextfun, nextfunSignature;
67102 luke 710 
    SEXP sysp, formals, newcall;
711 
    SEXP group, basename;
16335 luke 712 
    SEXP callenv, defenv;
1839 ihaka 713 
    RCNTXT *cptr;
55061 ripley 714 
    int i, j;
2 r 715 
 
1839 ihaka 716 
    cptr = R_GlobalContext;
717 
    cptr->callflag = CTXT_GENERIC;
2 r 718 
 
1839 ihaka 719 
    /* get the env NextMethod was called from */
720 
    sysp = R_GlobalContext->sysparent;
721 
    while (cptr != NULL) {
38135 ripley 722 
	if (cptr->callflag & CTXT_FUNCTION && cptr->cloenv == sysp) break;
1839 ihaka 723 
	cptr = cptr->nextcontext;
21352 maechler 724 
    }
1839 ihaka 725 
    if (cptr == NULL)
33692 ripley 726 
	error(_("'NextMethod' called from outside a function"));
2 r 727 
 
79253 hornik 728 
    PROTECT(newcall = shallow_duplicate(cptr->call));
214 rgentlem 729 
 
74297 kalibera 730 
    /* eg get("print.ts")(1) or do.call() */
731 
    if (TYPEOF(CAR(cptr->call)) != SYMSXP)
33692 ripley 732 
       error(_("'NextMethod' called from an anonymous function"));
21349 tlumley 733 
 
66713 luke 734 
    readS3VarsFromFrame(sysp, &generic, &group, &klass, &method,
68923 ripley 735 
			&callenv, &defenv);
66713 luke 736 
 
23391 luke 737 
    /* Find dispatching environments. Promises shouldn't occur, but
738 
       check to be on the safe side.  If the variables are not in the
739 
       environment (the method was called outside a method dispatch)
740 
       then chose reasonable defaults. */
38132 ripley 741 
    if (TYPEOF(callenv) == PROMSXP)
742 
	callenv = eval(callenv, R_BaseEnv);
743 
    else if (callenv == R_UnboundValue)
66713 luke 744 
	callenv = env;
38135 ripley 745 
    if (TYPEOF(defenv) == PROMSXP) defenv = eval(defenv, R_BaseEnv);
746 
    else if (defenv == R_UnboundValue) defenv = R_GlobalEnv;
23391 luke 747 
 
1839 ihaka 748 
    /* set up the arglist */
66713 luke 749 
    s = cptr->callfun;
750 
 
38134 ripley 751 
    if (TYPEOF(s) != CLOSXP){ /* R_LookupMethod looked for a function */
66713 luke 752 
	if (s == R_UnboundValue)
753 
	    error(_("no calling generic was found: was a method called directly?"));
754 
	else
755 
	    errorcall(R_NilValue,
42110 maechler 756 
		  _("'function' is not a function, but of type %d"),
27412 ripley 757 
		  TYPEOF(s));
21352 maechler 758 
    }
1975 rgentlem 759 
    /* get formals and actuals; attach the names of the formals to
760 
       the actuals, expanding any ... that occurs */
1839 ihaka 761 
    formals = FORMALS(s);
67102 luke 762 
    PROTECT(matchedarg = patchArgsByActuals(formals, cptr->promargs, cptr->cloenv));
2 r 763 
 
1839 ihaka 764 
    /*
765 
      Now see if there were any other arguments passed in
2515 rgentlem 766 
      Currently we seem to only allow named args to change
767 
      or to be added, this is at variance with p. 470 of the
768 
      White Book
769 
    */
2 r 770 
 
1839 ihaka 771 
    s = CADDR(args); /* this is ... and we need to see if it's bound */
772 
    if (s == R_DotsSymbol) {
86821 luke 773 
	t = R_findVarInFrame(env, s);
1839 ihaka 774 
	if (t != R_NilValue && t != R_MissingArg) {
10172 luke 775 
	    SET_TYPEOF(t, LISTSXP); /* a safe mutation */
38135 ripley 776 
	    s = matchmethargs(matchedarg, t);
1839 ihaka 777 
	    UNPROTECT(1);
778 
	    PROTECT(matchedarg = s);
2515 rgentlem 779 
	    newcall = fixcall(newcall, matchedarg);
2 r 780 
	}
1839 ihaka 781 
    }
782 
    else
41686 ripley 783 
	error(_("wrong argument ..."));
2 r 784 
 
2515 rgentlem 785 
    /*
786 
      .Class is used to determine the next method; if it doesn't
787 
      exist the first argument to the current method is used
788 
      the second argument to NextMethod is another option but
789 
      isn't currently used).
790 
    */
39866 duncan 791 
    if (klass == R_UnboundValue) {
66713 luke 792 
	/* we can get the object from actuals directly, but this
793 
	   branch seems to be very cold if not dead */
1839 ihaka 794 
	s = GetObject(cptr);
41686 ripley 795 
	if (!isObject(s)) error(_("object not specified"));
39866 duncan 796 
	klass = getAttrib(s, R_ClassSymbol);
1839 ihaka 797 
    }
2 r 798 
 
6113 rgentlem 799 
    /* the generic comes from either the sysparent or it's named */
800 
    if (generic == R_UnboundValue)
801 
	generic = eval(CAR(args), env);
66713 luke 802 
    if (generic == R_NilValue)
41686 ripley 803 
	error(_("generic function not specified"));
1839 ihaka 804 
    PROTECT(generic);
2 r 805 
 
68586 ripley 806 
    if (!isString(generic) || LENGTH(generic) != 1)
60844 ripley 807 
	error(_("invalid generic argument to 'NextMethod'"));
21352 maechler 808 
 
40724 ripley 809 
    if (CHAR(STRING_ELT(generic, 0))[0] == '\0')
41686 ripley 810 
	error(_("generic function not specified"));
2 r 811 
 
6113 rgentlem 812 
    /* determine whether we are in a Group dispatch */
813 
    /* determine the root: either the group or the generic will be it */
66713 luke 814 
    if (group == R_UnboundValue) {
815 
	group = R_BlankScalarString;
816 
	basename = generic;
817 
    } else {
68586 ripley 818 
	if (!isString(group) || LENGTH(group) != 1)
68923 ripley 819 
	    error(_("invalid 'group' argument found in 'NextMethod'"));
66713 luke 820 
	if (CHAR(STRING_ELT(group, 0))[0] == '\0') basename = generic;
821 
	else basename = group;
822 
    }
823 
    PROTECT(group);
6113 rgentlem 824 
 
825 
    nextfun = R_NilValue;
66388 luke 826 
    nextfunSignature = R_NilValue;
6113 rgentlem 827 
 
42110 maechler 828 
    /*
38135 ripley 829 
       Find the method currently being invoked and jump over the current call
830 
       If t is R_UnboundValue then we called the current method directly
831 
    */
66388 luke 832 
    const void *vmax = vmaxget(); /* needed for translateChar */
833 
    const char *b = NULL;
66713 luke 834 
    if (method != R_UnboundValue) {
835 
	if (!isString(method))
33297 ripley 836 
	    error(_("wrong value for .Method"));
68586 ripley 837 
	for(i = 0; i < LENGTH(method); i++) {
66388 luke 838 
	    b = translateChar(STRING_ELT(method, i));
839 
	    if (strlen(b)) break;
6113 rgentlem 840 
	}
21352 maechler 841 
	/* for binary operators check that the second argument's method
21282 tlumley 842 
	   is the same or absent */
68586 ripley 843 
	for(j = i; j < LENGTH(method); j++) {
66388 luke 844 
	    const char *bb = translateChar(STRING_ELT(method, j));
62580 ripley 845 
	    if (strlen(bb) && strcmp(b,bb))
846 
		warning(_("Incompatible methods ignored"));
21282 tlumley 847 
	}
6113 rgentlem 848 
    }
849 
    else {
66388 luke 850 
	b = CHAR(PRINTNAME(CAR(cptr->call)));
6113 rgentlem 851 
    }
42110 maechler 852 
 
40705 ripley 853 
    sb = translateChar(STRING_ELT(basename, 0));
66388 luke 854 
    Rboolean foundSignature = FALSE;
68586 ripley 855 
    for (j = 0; j < LENGTH(klass); j++) {
40705 ripley 856 
	sk = translateChar(STRING_ELT(klass, j));
66713 luke 857 
	if (equalS3Signature(b, sb, sk)) { /* b == sb.sk */
66388 luke 858 
	    foundSignature = TRUE;
859 
	    break;
860 
	}
1839 ihaka 861 
    }
2 r 862 
 
66388 luke 863 
    if (foundSignature) /* we found a match and start from there */
6113 rgentlem 864 
      j++;
865 
    else
66713 luke 866 
      j = 0;  /* no match so start with the first element of .Class */
6113 rgentlem 867 
 
21282 tlumley 868 
    /* we need the value of i on exit from the for loop to figure out
869 
	   how many classes to drop. */
42110 maechler 870 
 
40705 ripley 871 
    sg = translateChar(STRING_ELT(generic, 0));
68586 ripley 872 
    for (i = j ; i < LENGTH(klass); i++) {
40705 ripley 873 
	sk = translateChar(STRING_ELT(klass, i));
68923 ripley 874 
	nextfunSignature = installS3Signature(sg, sk);
66388 luke 875 
	nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);
38135 ripley 876 
	if (isFunction(nextfun)) break;
38134 ripley 877 
	if (group != R_UnboundValue) {
21282 tlumley 878 
	    /* if not Generic.foo, look for Group.foo */
66388 luke 879 
	    nextfunSignature = installS3Signature(sb, sk);
880 
	    nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);
21352 maechler 881 
	    if(isFunction(nextfun))
882 
		break;
21282 tlumley 883 
	}
1839 ihaka 884 
	if (isFunction(nextfun))
885 
	    break;
886 
    }
887 
    if (!isFunction(nextfun)) {
66388 luke 888 
	nextfunSignature = installS3Signature(sg, "default");
889 
	nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);
39508 ripley 890 
	/* If there is no default method, try the generic itself,
891 
	   provided it is primitive or a wrapper for a .Internal
892 
	   function of the same name.
893 
	 */
1839 ihaka 894 
	if (!isFunction(nextfun)) {
40705 ripley 895 
	    t = install(sg);
86821 luke 896 
	    nextfun = R_findVar(t, env);
68325 luke 897 
	    if (TYPEOF(nextfun) == PROMSXP) {
898 
		PROTECT(nextfun);
22881 luke 899 
		nextfun = eval(nextfun, env);
68325 luke 900 
		UNPROTECT(1);
901 
	    }
1839 ihaka 902 
	    if (!isFunction(nextfun))
33297 ripley 903 
		error(_("no method to invoke"));
1839 ihaka 904 
	    if (TYPEOF(nextfun) == CLOSXP) {
905 
		if (INTERNAL(t) != R_NilValue)
906 
		    nextfun = INTERNAL(t);
69256 luke 907 
		else {
908 
		    nextfun = getPrimitive(t);
909 
		    if (nextfun == R_NilValue)
910 
		        error(_("no method to invoke"));
911 
		}
1839 ihaka 912 
	    }
2 r 913 
	}
1839 ihaka 914 
    }
68250 luke 915 
    PROTECT(nextfun);
66441 luke 916 
    PROTECT(s = stringSuffix(klass, i));
917 
    setAttrib(s, R_PreviousSymbol, klass);
39508 ripley 918 
    /* It is possible that if a method was called directly that
38913 ripley 919 
	'method' is unset */
920 
    if (method != R_UnboundValue) {
45446 ripley 921 
	/* for Ops we need `method' to be a vector */
38913 ripley 922 
	PROTECT(method = duplicate(method));
68586 ripley 923 
	for(j = 0; j < LENGTH(method); j++) {
38913 ripley 924 
	    if (strlen(CHAR(STRING_ELT(method,j))))
66388 luke 925 
		SET_STRING_ELT(method, j,  PRINTNAME(nextfunSignature));
45446 ripley 926 
	}
38913 ripley 927 
    } else
66388 luke 928 
	PROTECT(method = PRINTNAME(nextfunSignature));
66694 luke 929 
 
930 
    SEXP newvars = PROTECT(createS3Vars(
68923 ripley 931 
	generic,
932 
	group,
933 
	s,
934 
	method,
935 
	callenv,
936 
	defenv
66694 luke 937 
    ));
938 
 
66388 luke 939 
    SETCAR(newcall, nextfunSignature);
526 maechler 940 
 
63147 pd 941 
    /* applyMethod expects that the parent of the caller is the caller
942 
       of the generic, so fixup by brute force. This should fix
943 
       PR#15267 --pd */
944 
    R_GlobalContext->sysparent = callenv;
945 
 
66694 luke 946 
    ans = applyMethod(newcall, nextfun, matchedarg, env, newvars);
66388 luke 947 
    vmaxset(vmax);
68250 luke 948 
    UNPROTECT(8);
1839 ihaka 949 
    return(ans);
2 r 950 
}
951 
 
51267 ripley 952 
/* primitive */
83446 ripley 953 
attribute_hidden SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 954 
{
1839 ihaka 955 
    checkArity(op, args);
51267 ripley 956 
    check1arg(args, call, "x");
957 
 
1839 ihaka 958 
    if (isObject(CAR(args))) {
66622 maechler 959 
	switch(TYPEOF(CAR(args))) {
960 
	case ENVSXP:
961 
	    errorcall(call, _("cannot unclass an environment"));
962 
	    break;
963 
	case EXTPTRSXP:
964 
	    errorcall(call, _("cannot unclass an external pointer"));
965 
	    break;
966 
	default:
967 
	    break;
968 
	}
65373 luke 969 
	if (MAYBE_REFERENCED(CAR(args)))
75534 luke 970 
	    SETCAR(args, R_shallow_duplicate_attr(CAR(args)));
1839 ihaka 971 
	setAttrib(CAR(args), R_ClassSymbol, R_NilValue);
972 
    }
973 
    return CAR(args);
2 r 974 
}
975 
 
71307 lawrence 976 
/** Version of inherits() that supports S4 inheritance and implicit
977 
    classes.  The inlined inherits() does not have access to private
978 
    entry points R_data_class() and R_data_class2(). The semantics of
979 
    inherits2() are identical to that of the R-level inherits(),
980 
    except there is no translation.
981 
*/
46128 jmc 982 
 
87901 ripley 983 
attribute_hidden Rboolean inherits2(SEXP x, const char *what) {
71307 lawrence 984 
    if (OBJECT(x)) {
985 
	SEXP klass;
73097 maechler 986 
 
71307 lawrence 987 
	if(IS_S4_OBJECT(x))
988 
	    PROTECT(klass = R_data_class2(x));
989 
	else
990 
	    PROTECT(klass = R_data_class(x, FALSE));
991 
	int nclass = length(klass);
992 
	for (int i = 0; i < nclass; i++) {
993 
	    if (!strcmp(CHAR(STRING_ELT(klass, i)), what)) {
994 
		UNPROTECT(1);
995 
		return TRUE;
996 
	    }
997 
	}
998 
	UNPROTECT(1);
999 
    }
1000 
    return FALSE;
1001 
}
52431 maechler 1002 
 
1003 
/* NOTE: Fast  inherits(x, what)    in ../include/Rinlinedfuns.h
1004 
 * ----        ----------------- */
1005 
/** C API for  R  inherits(x, what, which)
1006 
 *
1007 
 * @param x any R object
1008 
 * @param what character vector
1009 
 * @param which logical: "want vector result" ?
1010 
 *
1011 
 * @return if which is false, logical TRUE or FALSE
1012 
 *	   if which is true, integer vector of length(what) ..
1013 
 */
61765 ripley 1014 
static SEXP inherits3(SEXP x, SEXP what, SEXP which)
9608 rgentlem 1015 
{
63181 ripley 1016 
    const void *vmax = vmaxget();
52431 maechler 1017 
    SEXP klass, rval = R_NilValue /* -Wall */;
63181 ripley 1018 
 
46128 jmc 1019 
    if(IS_S4_OBJECT(x))
70613 maechler 1020 
	PROTECT(klass = R_data_class2(x)); // -> := S4_extends( "class(x)" )
48409 jmc 1021 
    else
52266 jmc 1022 
	PROTECT(klass = R_data_class(x, FALSE));
9608 rgentlem 1023 
 
38135 ripley 1024 
    if(!isString(what))
84105 luke 1025 
	error(_("'what' must be a character vector "
1026 
		"or an object with a nameOfClass() method"));
68586 ripley 1027 
    int j, nwhat = LENGTH(what);
9608 rgentlem 1028 
 
68586 ripley 1029 
    if( !isLogical(which) || (LENGTH(which) != 1) )
41686 ripley 1030 
	error(_("'which' must be a length 1 logical vector"));
87891 ripley 1031 
    bool isvec = asRbool(which, R_NilValue);
9608 rgentlem 1032 
 
38135 ripley 1033 
    if(isvec)
50715 murdoch 1034 
	PROTECT(rval = allocVector(INTSXP, nwhat));
9608 rgentlem 1035 
 
38135 ripley 1036 
    for(j = 0; j < nwhat; j++) {
66477 luke 1037 
	const char *ss = translateChar(STRING_ELT(what, j));
1038 
	int i = stringPositionTr(klass, ss);
1039 
	if (isvec)
1040 
	    INTEGER(rval)[j] = i+1; /* 0 when ss is not in klass */
1041 
	else if (i >= 0) {
1042 
	    vmaxset(vmax);
1043 
	    UNPROTECT(1);
1044 
	    return mkTrue();
9608 rgentlem 1045 
	}
1046 
    }
63181 ripley 1047 
    vmaxset(vmax);
50715 murdoch 1048 
    if(!isvec) {
68923 ripley 1049 
	UNPROTECT(1);
9608 rgentlem 1050 
	return mkFalse();
50715 murdoch 1051 
    }
1052 
    UNPROTECT(2);
9608 rgentlem 1053 
    return rval;
1054 
}
15890 jmc 1055 
 
84105 luke 1056 
static R_INLINE SEXP nameOfClass(SEXP what, SEXP env)
1057 
{
1058 
    static SEXP call = NULL;
1059 
    static SEXP Xsym = NULL;
1060 
    if (call == NULL) {
1061 
	Xsym = install("X");
1062 
	call = R_ParseString("base::nameOfClass(X)");
1063 
	R_PreserveObject(call);
1064 
    }
1065 
 
1066 
    SEXP callenv = PROTECT(R_NewEnv(env, FALSE, 0));
1067 
    defineVar(Xsym, what, callenv);
1068 
    INCREMENT_NAMED(what);
1069 
    SEXP name = eval(call, callenv);
1070 
    /* could remove 'what' from callenv to drop REFCNT */
1071 
    UNPROTECT(1); /* callenv */
1072 
 
1073 
    return name;
1074 
}
1075 
 
83446 ripley 1076 
attribute_hidden SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
52431 maechler 1077 
{
1078 
    checkArity(op, args);
21352 maechler 1079 
 
84105 luke 1080 
    SEXP x = CAR(args);
1081 
    SEXP what = CADR(args);
1082 
    SEXP which = CADDR(args);
1083 
 
1084 
    if (OBJECT(what) && TYPEOF(what) != STRSXP) {
1085 
	SEXP name = nameOfClass(what, env);
1086 
	if (name != R_NilValue) {
1087 
	    PROTECT(name);
1088 
	    SEXP val = inherits3(x, name, which);
1089 
	    UNPROTECT(1); /* name */
1090 
	    return val;
1091 
	}
1092 
	/* fall through */
1093 
    }
1094 
 
1095 
    return inherits3(x, what, which);
52431 maechler 1096 
}
1097 
 
1098 
 
63624 ripley 1099 
/*
1100 
   ==============================================================
1101 
 
1102 
     code from here on down is support for the methods package
1103 
 
1104 
   ==============================================================
1105 
*/
1106 
 
54492 maechler 1107 
/**
1108 
 * Return the 0-based index of an is() match in a vector of class-name
1109 
 * strings terminated by an empty string.  Returns -1 for no match.
1110 
 *
1111 
 * @param x  an R object, about which we want is(x, .) information.
1112 
 * @param valid vector of possible matches terminated by an empty string.
1113 
 * @param rho  the environment in which the class definitions exist.
1114 
 *
1115 
 * @return index of match or -1 for no match
1116 
 */
86655 luke 1117 
attribute_hidden
54492 maechler 1118 
int R_check_class_and_super(SEXP x, const char **valid, SEXP rho)
1119 
{
87137 maechler 1120 
  if(isObject(x)) {
54492 maechler 1121 
    int ans;
82838 kalibera 1122 
    SEXP clattr = getAttrib(x, R_ClassSymbol);
1123 
    SEXP cl = PROTECT(asChar(clattr));
68325 luke 1124 
    const char *class = CHAR(cl);
82838 kalibera 1125 
    for (ans = 0; strlen(valid[ans]); ans++)
68325 luke 1126 
	if (!strcmp(class, valid[ans])) {
1127 
	    UNPROTECT(1); /* cl */
1128 
	    return ans;
1129 
	}
87137 maechler 1130 
    /* if not found directly, then look for a match among the nonvirtual
82838 kalibera 1131 
       superclasses, possibly after finding the environment 'rho' in which
1132 
       class(x) is defined */
54492 maechler 1133 
    if(IS_S4_OBJECT(x)) {
82838 kalibera 1134 
	if (rho == NULL) {
1135 
	    SEXP pkg = getAttrib(clattr, R_PackageSymbol);
1136 
	    if (!isNull(pkg)) {
1137 
		static SEXP meth_classEnv = NULL;
1138 
		if(!meth_classEnv)
1139 
		    meth_classEnv = install(".classEnv");
1140 
		/* FIXME: fails if 'methods' is not loaded */
1141 
		SEXP clEnvCall = PROTECT(lang2(meth_classEnv, clattr));
1142 
		rho = eval(clEnvCall, R_MethodsNamespace);
1143 
		UNPROTECT(1); /* clEnvCall */
1144 
		if(!isEnvironment(rho))
1145 
		    error(_("could not find correct environment; "
1146 
			    "please report!"));
1147 
	    } else
1148 
		rho = R_GlobalEnv;
1149 
	}
1150 
	PROTECT(rho);
54492 maechler 1151 
	SEXP classExts, superCl, _call;
1152 
	static SEXP s_contains = NULL, s_selectSuperCl = NULL;
1153 
	if(!s_contains) {
1154 
	    s_contains      = install("contains");
1155 
	    s_selectSuperCl = install(".selectSuperClasses");
1156 
	}
68094 luke 1157 
	SEXP classDef = PROTECT(R_getClassDef(class));
1158 
	PROTECT(classExts = R_do_slot(classDef, s_contains));
87137 maechler 1159 
	/* .selectSuperClasses(getClassDef(class)@contains,
1160 
	 *                     dropVirtual = TRUE, namesOnly = TRUE,
82838 kalibera 1161 
	 *                     directOnly = FALSE, simpleOnly = TRUE):
73103 maechler 1162 
	 */
82838 kalibera 1163 
	PROTECT(_call = lang6(s_selectSuperCl, classExts,
1164 
			      ScalarLogical(1), ScalarLogical(1),
1165 
			      ScalarLogical(0), ScalarLogical(1)));
54492 maechler 1166 
	superCl = eval(_call, rho);
68094 luke 1167 
	UNPROTECT(3); /* _call, classExts, classDef */
54492 maechler 1168 
	PROTECT(superCl);
82838 kalibera 1169 
	for(int i = 0; i < LENGTH(superCl); i++) {
54492 maechler 1170 
	    const char *s_class = CHAR(STRING_ELT(superCl, i));
82838 kalibera 1171 
	    for (ans = 0; strlen(valid[ans]); ans++)
54492 maechler 1172 
		if (!strcmp(s_class, valid[ans])) {
82838 kalibera 1173 
		    UNPROTECT(3); /* superCl, rho, cl */
54492 maechler 1174 
		    return ans;
1175 
		}
1176 
	}
82838 kalibera 1177 
	UNPROTECT(2); /* superCl, rho */
54492 maechler 1178 
    }
68325 luke 1179 
    UNPROTECT(1); /* cl */
87137 maechler 1180 
  } // only if isObject(x)
1181 
  return -1;
54492 maechler 1182 
}
1183 
 
57849 maechler 1184 
/**
1185 
 * Return the 0-based index of an is() match in a vector of class-name
1186 
 * strings terminated by an empty string.  Returns -1 for no match.
1187 
 * Strives to find the correct environment() for is(), using .classEnv()
1188 
 * (from \pkg{methods}).
1189 
 *
1190 
 * @param x  an R object, about which we want is(x, .) information.
1191 
 * @param valid vector of possible matches terminated by an empty string.
1192 
 *
1193 
 * @return index of match or -1 for no match
1194 
 */
1195 
int R_check_class_etc(SEXP x, const char **valid)
1196 
{
82838 kalibera 1197 
    return R_check_class_and_super(x, valid, NULL);
57849 maechler 1198 
}
1199 
 
15890 jmc 1200 
/* standardGeneric:  uses a pointer to R_standardGeneric, to be
63624 ripley 1201 
   initialized when the methods namespace is loaded,
1202 
   via R_initMethodDispatch.
15890 jmc 1203 
*/
15938 jmc 1204 
static R_stdGen_ptr_t R_standardGeneric_ptr = 0;
21102 jmc 1205 
static SEXP dispatchNonGeneric(SEXP name, SEXP env, SEXP fdef);
1206 
#define NOT_METHODS_DISPATCH_PTR(ptr) (ptr == 0 || ptr == dispatchNonGeneric)
15890 jmc 1207 
 
61776 ripley 1208 
static
44195 ripley 1209 
R_stdGen_ptr_t R_get_standardGeneric_ptr(void)
16747 ripley 1210 
{
1211 
    return R_standardGeneric_ptr;
15938 jmc 1212 
}
1213 
 
63624 ripley 1214 
/* Also called from R_initMethodDispatch in methods C code, which is
1215 
   called when the methods namespace is loaded. */
26082 jmc 1216 
R_stdGen_ptr_t R_set_standardGeneric_ptr(R_stdGen_ptr_t val, SEXP envir)
16747 ripley 1217 
{
1218 
    R_stdGen_ptr_t old = R_standardGeneric_ptr;
1219 
    R_standardGeneric_ptr = val;
26082 jmc 1220 
    if(envir && !isNull(envir))
1221 
	R_MethodsNamespace = envir;
1222 
    /* just in case ... */
1223 
    if(!R_MethodsNamespace)
1224 
	R_MethodsNamespace = R_GlobalEnv;
16747 ripley 1225 
    return old;
15938 jmc 1226 
}
1227 
 
66622 maechler 1228 
// R's .isMethodsDispatchOn() -> do_S4on() ->
63624 ripley 1229 
static SEXP R_isMethodsDispatchOn(SEXP onOff)
1230 
{
21102 jmc 1231 
    R_stdGen_ptr_t old = R_get_standardGeneric_ptr();
63624 ripley 1232 
    int ival =  !NOT_METHODS_DISPATCH_PTR(old);
23073 ripley 1233 
    if(length(onOff) > 0) {
87891 ripley 1234 
	bool onOffValue = asRbool(onOff, R_NilValue);
60395 ripley 1235 
	if(onOffValue == NA_INTEGER)
1236 
	    error(_("'onOff' must be TRUE or FALSE"));
1237 
	else if(onOffValue == FALSE)
63624 ripley 1238 
	    R_set_standardGeneric_ptr(NULL, R_GlobalEnv);
1239 
	// TRUE is not currently used
60395 ripley 1240 
	else if(NOT_METHODS_DISPATCH_PTR(old)) {
63624 ripley 1241 
	    // so not already on
1242 
	    // This may not work correctly: the default arg is incorrect.
1243 
	    warning("R_isMethodsDispatchOn(TRUE) called -- may not work correctly");
66622 maechler 1244 
	    SEXP call = PROTECT(lang1(install("initMethodDispatch")));
63624 ripley 1245 
	    eval(call, R_MethodsNamespace); // only works with methods loaded
60395 ripley 1246 
	    UNPROTECT(1);
1247 
	}
21102 jmc 1248 
    }
63624 ripley 1249 
    return ScalarLogical(ival);
21102 jmc 1250 
}
1251 
 
60395 ripley 1252 
/* simpler version for internal use, in attrib.c and print.c */
37088 ripley 1253 
attribute_hidden
23073 ripley 1254 
Rboolean isMethodsDispatchOn(void)
1255 
{
1256 
    return !NOT_METHODS_DISPATCH_PTR(R_standardGeneric_ptr);
1257 
}
1258 
 
1259 
 
63624 ripley 1260 
/* primitive for .isMethodsDispatchOn
1261 
   This is generally called without an arg, but is call with
1262 
   onOff=FALSE when package methods is detached/unloaded.
1263 
 
1264 
   It seems it is not currently called with onOff = TRUE (and would
1265 
   not have worked prior to 3.0.2).
66622 maechler 1266 
*/
60395 ripley 1267 
attribute_hidden
1268 
SEXP do_S4on(SEXP call, SEXP op, SEXP args, SEXP env)
1269 
{
1270 
    if(length(args) == 0) return ScalarLogical(isMethodsDispatchOn());
1271 
    return R_isMethodsDispatchOn(CAR(args));
1272 
}
1273 
 
1274 
 
21352 maechler 1275 
static SEXP dispatchNonGeneric(SEXP name, SEXP env, SEXP fdef)
16747 ripley 1276 
{
1277 
    /* dispatch the non-generic definition of `name'.  Used to trap
1278 
       calls to standardGeneric during the loading of the methods package */
54029 luke 1279 
    SEXP e, value, rho, fun, symbol;
16747 ripley 1280 
    RCNTXT *cptr;
63181 ripley 1281 
 
16747 ripley 1282 
    /* find a non-generic function */
63223 ripley 1283 
    symbol = installTrChar(asChar(name));
36174 murdoch 1284 
    for(rho = ENCLOS(env); rho != R_EmptyEnv;
16747 ripley 1285 
	rho = ENCLOS(rho)) {
86821 luke 1286 
	fun = R_findVarInFrame(rho, symbol);
16747 ripley 1287 
	if(fun == R_UnboundValue) continue;
1288 
	switch(TYPEOF(fun)) {
1289 
	case CLOSXP:
86821 luke 1290 
	    value = R_findVarInFrame(CLOENV(fun), R_dot_Generic);
16747 ripley 1291 
	    if(value == R_UnboundValue) break;
31908 ripley 1292 
	case BUILTINSXP:  case SPECIALSXP:
1293 
	default:
1294 
	    /* in all other cases, go on to the parent environment */
1295 
	    break;
16747 ripley 1296 
	}
1297 
	fun = R_UnboundValue;
16372 jmc 1298 
    }
16747 ripley 1299 
    fun = SYMVALUE(symbol);
1300 
    if(fun == R_UnboundValue)
33297 ripley 1301 
	error(_("unable to find a non-generic version of function \"%s\""),
40705 ripley 1302 
	      translateChar(asChar(name)));
16747 ripley 1303 
    cptr = R_GlobalContext;
1304 
    /* check this is the right context */
16372 jmc 1305 
    while (cptr != R_ToplevelContext) {
1306 
	if (cptr->callflag & CTXT_FUNCTION )
1307 
	    if (cptr->cloenv == env)
1308 
		break;
1309 
	cptr = cptr->nextcontext;
1310 
    }
21352 maechler 1311 
 
79253 hornik 1312 
    PROTECT(e = shallow_duplicate(R_syscall(0, cptr)));
16747 ripley 1313 
    SETCAR(e, fun);
1314 
    /* evaluate a call the non-generic with the same arguments and from
1315 
       the same environment as the call to the generic version */
1316 
    value = eval(e, cptr->sysparent);
1317 
    UNPROTECT(1);
1318 
    return value;
16372 jmc 1319 
}
1320 
 
20089 jmc 1321 
 
1322 
static SEXP get_this_generic(SEXP args);
1323 
 
83446 ripley 1324 
attribute_hidden SEXP do_standardGeneric(SEXP call, SEXP op, SEXP args, SEXP env)
15890 jmc 1325 
{
20089 jmc 1326 
    SEXP arg, value, fdef; R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr();
51267 ripley 1327 
 
74907 maechler 1328 
    checkArity(op, args); /* set to -1 */
51267 ripley 1329 
    check1arg(args, call, "f");
1330 
 
16747 ripley 1331 
    if(!ptr) {
42110 maechler 1332 
	warningcall(call,
60844 ripley 1333 
		    _("'standardGeneric' called without 'methods' dispatch enabled (will be ignored)"));
26082 jmc 1334 
	R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);
16747 ripley 1335 
	ptr = R_get_standardGeneric_ptr();
1336 
    }
42110 maechler 1337 
 
41270 ripley 1338 
    arg = CAR(args);
22291 jmc 1339 
    if(!isValidStringF(arg))
42675 ripley 1340 
	errorcall(call,
60844 ripley 1341 
		  _("argument to 'standardGeneric' must be a non-empty character string"));
22291 jmc 1342 
 
20089 jmc 1343 
    PROTECT(fdef = get_this_generic(args));
15890 jmc 1344 
 
22291 jmc 1345 
    if(isNull(fdef))
42675 ripley 1346 
	error(_("call to standardGeneric(\"%s\") apparently not from the body of that generic function"), translateChar(STRING_ELT(arg, 0)));
22291 jmc 1347 
 
20089 jmc 1348 
    value = (*ptr)(arg, env, fdef);
21352 maechler 1349 
 
41270 ripley 1350 
    UNPROTECT(1);
16747 ripley 1351 
    return value;
15890 jmc 1352 
}
1353 
 
16707 jmc 1354 
static int maxMethodsOffset = 0, curMaxOffset;
50609 jmc 1355 
static Rboolean allowPrimitiveMethods = TRUE;
16707 jmc 1356 
typedef enum {NO_METHODS, NEEDS_RESET, HAS_METHODS, SUPPRESSED} prim_methods_t;
1357 
 
1358 
static prim_methods_t *prim_methods;
1359 
static SEXP *prim_generics;
1360 
static SEXP *prim_mlist;
1361 
#define DEFAULT_N_PRIM_METHODS 100
1362 
 
66659 maechler 1363 
// Called from methods package, ../library/methods/src/methods_list_dispatch.c
16707 jmc 1364 
SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,
1365 
		       SEXP mlist)
1366 
{
41784 ripley 1367 
    const char *code_string;
63181 ripley 1368 
    const void *vmax = vmaxget();
16747 ripley 1369 
    if(!isValidString(code_vec))
67542 maechler 1370 
	error(_("argument '%s' must be a character string"), "code");
40705 ripley 1371 
    code_string = translateChar(asChar(code_vec));
50609 jmc 1372 
    /* with a NULL op, turns all primitive matching off or on (used to avoid possible infinite
1373 
     recursion in methods computations*/
1374 
    if(op == R_NilValue) {
66659 maechler 1375 
	SEXP value = allowPrimitiveMethods ? mkTrue() : mkFalse();
50609 jmc 1376 
	switch(code_string[0]) {
1377 
	case 'c': case 'C':/* clear */
1378 
	    allowPrimitiveMethods = FALSE; break;
1379 
	case 's': case 'S': /* set */
1380 
	    allowPrimitiveMethods = TRUE; break;
1381 
	default: /* just report the current state */
1382 
	    break;
1383 
	}
1384 
	return value;
1385 
    }
69636 lawrence 1386 
    if (!isPrimitive(op)) {
1387 
        SEXP internal = R_do_slot(op, install("internal"));
72301 kalibera 1388 
        op = INTERNAL(installTrChar(asChar(internal)));
69636 lawrence 1389 
        if (op == R_NilValue) {
1390 
          error("'internal' slot does not name an internal function: %s",
1391 
                CHAR(asChar(internal)));
1392 
        }
1393 
    }
16747 ripley 1394 
    do_set_prim_method(op, code_string, fundef, mlist);
63181 ripley 1395 
    vmaxset(vmax);
1396 
    return fname;
16707 jmc 1397 
}
1398 
 
20089 jmc 1399 
SEXP R_primitive_methods(SEXP op)
1400 
{
1401 
    int offset = PRIMOFFSET(op);
24661 ripley 1402 
    if(offset < 0 || offset > curMaxOffset)
21352 maechler 1403 
	return R_NilValue;
20089 jmc 1404 
    else {
21352 maechler 1405 
	SEXP value = prim_mlist[offset];
20089 jmc 1406 
	return value ? value : R_NilValue;
1407 
    }
1408 
}
1409 
 
39016 jmc 1410 
SEXP R_primitive_generic(SEXP op)
1411 
{
1412 
    int offset = PRIMOFFSET(op);
1413 
    if(offset < 0 || offset > curMaxOffset)
1414 
	return R_NilValue;
1415 
    else {
1416 
	SEXP value = prim_generics[offset];
1417 
	return value ? value : R_NilValue;
1418 
    }
1419 
}
1420 
 
66659 maechler 1421 
// used in the methods package, but also here
41784 ripley 1422 
SEXP do_set_prim_method(SEXP op, const char *code_string, SEXP fundef,
1423 
			SEXP mlist)
16707 jmc 1424 
{
18397 ripley 1425 
    int offset = 0;
1426 
    prim_methods_t code = NO_METHODS; /* -Wall */
1427 
    SEXP value;
1428 
    Rboolean errorcase = FALSE;
1429 
    switch(code_string[0]) {
1430 
    case 'c': /* clear */
1431 
	code = NO_METHODS; break;
1432 
    case 'r': /* reset */
1433 
	code = NEEDS_RESET; break;
20089 jmc 1434 
    case 's': /* set or suppress */
18397 ripley 1435 
	switch(code_string[1]) {
1436 
	case 'e': code = HAS_METHODS; break;
1437 
	case 'u': code = SUPPRESSED; break;
1438 
	default: errorcase = TRUE;
1439 
	}
1440 
	break;
1441 
    default:
1442 
	errorcase = TRUE;
16707 jmc 1443 
    }
18397 ripley 1444 
    if(errorcase) {
33297 ripley 1445 
	error(_("invalid primitive methods code (\"%s\"): should be \"clear\", \"reset\", \"set\", or \"suppress\""), code_string);
18397 ripley 1446 
	return R_NilValue;
1447 
    }
1448 
    switch(TYPEOF(op)) {
1449 
    case BUILTINSXP: case SPECIALSXP:
1450 
	offset = PRIMOFFSET(op);
1451 
	break;
21352 maechler 1452 
    default:
33297 ripley 1453 
	error(_("invalid object: must be a primitive function"));
18397 ripley 1454 
    }
1455 
    if(offset >= maxMethodsOffset) {
1456 
	int n;
24205 ripley 1457 
	n = offset + 1;
18397 ripley 1458 
	if(n < DEFAULT_N_PRIM_METHODS)
1459 
	    n = DEFAULT_N_PRIM_METHODS;
1460 
	if(n < 2*maxMethodsOffset)
1461 
	    n = 2 * maxMethodsOffset;
1462 
	if(prim_methods) {
19214 pd 1463 
	    int i;
19197 pd 1464 
 
81479 ripley 1465 
	    prim_methods  = R_Realloc(prim_methods,  n, prim_methods_t);
1466 
	    prim_generics = R_Realloc(prim_generics, n, SEXP);
1467 
	    prim_mlist	  = R_Realloc(prim_mlist,	   n, SEXP);
19214 pd 1468 
 
81479 ripley 1469 
	    /* R_Realloc does not clear the added memory, hence: */
19214 pd 1470 
	    for (i = maxMethodsOffset ; i < n ; i++) {
21352 maechler 1471 
		prim_methods[i]	 = NO_METHODS;
19214 pd 1472 
		prim_generics[i] = NULL;
21352 maechler 1473 
		prim_mlist[i]	 = NULL;
19214 pd 1474 
	    }
18397 ripley 1475 
	}
1476 
	else {
81479 ripley 1477 
	    prim_methods  = R_Calloc(n, prim_methods_t);
1478 
	    prim_generics = R_Calloc(n, SEXP);
1479 
	    prim_mlist	  = R_Calloc(n, SEXP);
18397 ripley 1480 
	}
1481 
	maxMethodsOffset = n;
1482 
    }
1483 
    if(offset > curMaxOffset)
1484 
	curMaxOffset = offset;
1485 
    prim_methods[offset] = code;
1486 
    /* store a preserved pointer to the generic function if there is not
1487 
       one there currently.  Unpreserve it if no more methods, but don't
1488 
       replace it otherwise:  the generic definition is not allowed to
1489 
       change while it's still defined! (the stored methods list can,
1490 
       however) */
1491 
    value = prim_generics[offset];
20089 jmc 1492 
    if(code == SUPPRESSED) {} /* leave the structure alone */
1493 
    else if(code == NO_METHODS && prim_generics[offset]) {
18397 ripley 1494 
	R_ReleaseObject(prim_generics[offset]);
1495 
	prim_generics[offset] = 0;
1496 
	prim_mlist[offset] = 0;
1497 
    }
1498 
    else if(fundef && !isNull(fundef) && !prim_generics[offset]) {
1499 
	if(TYPEOF(fundef) != CLOSXP)
33297 ripley 1500 
	    error(_("the formal definition of a primitive generic must be a function object (got type '%s')"),
85146 luke 1501 
		  R_typeToChar(fundef));
18397 ripley 1502 
	R_PreserveObject(fundef);
1503 
	prim_generics[offset] = fundef;
1504 
    }
41111 ripley 1505 
    if(code == HAS_METHODS) {
20089 jmc 1506 
	if(!mlist  || isNull(mlist)) {
41111 ripley 1507 
	    /* turning methods back on after a SUPPRESSED */
1508 
	} else {
1509 
	    if(prim_mlist[offset])
1510 
		R_ReleaseObject(prim_mlist[offset]);
1511 
	    R_PreserveObject(mlist);
1512 
	    prim_mlist[offset] = mlist;
20089 jmc 1513 
	}
18397 ripley 1514 
    }
1515 
    return value;
16707 jmc 1516 
}
1517 
 
17092 jmc 1518 
static SEXP get_primitive_methods(SEXP op, SEXP rho)
1519 
{
50609 jmc 1520 
    SEXP f, e, val;
17092 jmc 1521 
    int nprotect = 0;
1522 
    f = PROTECT(allocVector(STRSXP, 1));  nprotect++;
1523 
    SET_STRING_ELT(f, 0, mkChar(PRIMNAME(op)));
1524 
    PROTECT(e = allocVector(LANGSXP, 2)); nprotect++;
50609 jmc 1525 
    SETCAR(e, install("getGeneric"));
1526 
    val = CDR(e); SETCAR(val, f);
1527 
    val = eval(e, rho);
1528 
    /* a rough sanity check that this looks like a generic function */
1529 
    if(TYPEOF(val) != CLOSXP || !IS_S4_OBJECT(val))
60844 ripley 1530 
	error(_("object returned as generic function \"%s\" does not appear to be one"), PRIMNAME(op));
17092 jmc 1531 
    UNPROTECT(nprotect);
50609 jmc 1532 
    return CLOENV(val);
17092 jmc 1533 
}
20089 jmc 1534 
 
50609 jmc 1535 
 
20089 jmc 1536 
/* get the generic function, defined to be the function definition for
1537 
the call to standardGeneric(), or for primitives, passed as the second
1538 
argument to standardGeneric.
1539 
*/
1540 
static SEXP get_this_generic(SEXP args)
1541 
{
75479 kalibera 1542 
    static SEXP gen_name = NULL;
41784 ripley 1543 
    RCNTXT *cptr;
75479 kalibera 1544 
    SEXP fname;
20277 ripley 1545 
 
20089 jmc 1546 
    /* a second argument to the call, if any, is taken as the function */
1547 
    if(CDR(args) != R_NilValue)
20277 ripley 1548 
	return CAR(CDR(args));
20994 jmc 1549 
    if(!gen_name)
1550 
	gen_name = install("generic");
75479 kalibera 1551 
    fname = STRING_ELT(CAR(args), 0); /* type and length checked by caller */
1552 
 
20994 jmc 1553 
    /* check for a matching "generic" slot */
75479 kalibera 1554 
    for(cptr = R_GlobalContext; cptr != NULL; cptr = cptr->nextcontext)
1555 
	if((cptr->callflag & CTXT_FUNCTION) && isObject(cptr->callfun)) {
1556 
	    SEXP generic = getAttrib(cptr->callfun, gen_name);
1557 
	    if(isValidString(generic) && Seql(fname, STRING_ELT(generic, 0)))
1558 
		/* not duplicating/marking immutable, used read-only */
1559 
		return cptr->callfun;
20994 jmc 1560 
	}
75479 kalibera 1561 
    return R_NilValue;
20089 jmc 1562 
}
17092 jmc 1563 
 
21352 maechler 1564 
/* Could there be methods for this op?	Checks
16707 jmc 1565 
   only whether methods are currently being dispatched and, if so,
1566 
   whether methods are currently defined for this op. */
61771 ripley 1567 
attribute_hidden
17000 jmc 1568 
Rboolean R_has_methods(SEXP op)
16707 jmc 1569 
{
16747 ripley 1570 
    R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr(); int offset;
21102 jmc 1571 
    if(NOT_METHODS_DISPATCH_PTR(ptr))
17000 jmc 1572 
	return(FALSE);
22764 jmc 1573 
    if(!op || TYPEOF(op) == CLOSXP) /* except for primitives, just test for the package */
17000 jmc 1574 
	return(TRUE);
50609 jmc 1575 
    if(!allowPrimitiveMethods) /* all primitives turned off by a call to R_set_prim */
1576 
	return FALSE;
16747 ripley 1577 
    offset = PRIMOFFSET(op);
1578 
    if(offset > curMaxOffset || prim_methods[offset] == NO_METHODS
1579 
       || prim_methods[offset] == SUPPRESSED)
17000 jmc 1580 
	return(FALSE);
1581 
    return(TRUE);
16707 jmc 1582 
}
1583 
 
1584 
static SEXP deferred_default_object;
1585 
 
82931 ripley 1586 
SEXP R_deferred_default_method(void)
16707 jmc 1587 
{
16747 ripley 1588 
    if(!deferred_default_object)
1589 
	deferred_default_object = install("__Deferred_Default_Marker__");
1590 
    return(deferred_default_object);
16707 jmc 1591 
}
1592 
 
1593 
 
1594 
static R_stdGen_ptr_t quick_method_check_ptr = NULL;
1595 
void R_set_quick_method_check(R_stdGen_ptr_t value)
1596 
{
16747 ripley 1597 
    quick_method_check_ptr = value;
16707 jmc 1598 
}
23073 ripley 1599 
 
16707 jmc 1600 
/* try to dispatch the formal method for this primitive op, by calling
21352 maechler 1601 
   the stored generic function corresponding to the op.	 Requires that
16707 jmc 1602 
   the methods be set up to return a special object rather than trying
1603 
   to evaluate the default (which would get us into a loop). */
42292 ripley 1604 
 
1605 
/* called from DispatchOrEval, DispatchGroup, do_matprod
1606 
   When called from the first the arguments have been enclosed in
1607 
   promises, but not from the other two: there all the arguments have
1608 
   already been evaluated.
1609 
 */
83446 ripley 1610 
attribute_hidden SEXP
45446 ripley 1611 
R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
42292 ripley 1612 
		    Rboolean promisedArgs)
16707 jmc 1613 
{
70724 lawrence 1614 
    SEXP fundef, value, mlist=R_NilValue, s, a, b, suppliedvars;
42110 maechler 1615 
    int offset;
27710 ripley 1616 
    prim_methods_t current;
23073 ripley 1617 
    offset = PRIMOFFSET(op);
1618 
    if(offset < 0 || offset > curMaxOffset)
33297 ripley 1619 
	error(_("invalid primitive operation given for dispatch"));
23073 ripley 1620 
    current = prim_methods[offset];
1621 
    if(current == NO_METHODS || current == SUPPRESSED)
1622 
	return(NULL);
1623 
    /* check that the methods for this function have been set */
1624 
    if(current == NEEDS_RESET) {
1625 
	/* get the methods and store them in the in-core primitive
1626 
	   method table.	The entries will be preserved via
1627 
	   R_preserveobject, so later we can just grab mlist from
1628 
	   prim_mlist */
26648 ripley 1629 
	do_set_prim_method(op, "suppressed", R_NilValue, mlist);
23073 ripley 1630 
	PROTECT(mlist = get_primitive_methods(op, rho));
1631 
	do_set_prim_method(op, "set", R_NilValue, mlist);
26016 jmc 1632 
	current = prim_methods[offset]; /* as revised by do_set_prim_method */
23073 ripley 1633 
	UNPROTECT(1);
1634 
    }
1635 
    mlist = prim_mlist[offset];
1636 
    if(mlist && !isNull(mlist)
1637 
       && quick_method_check_ptr) {
1638 
	value = (*quick_method_check_ptr)(args, mlist, op);
1639 
	if(isPrimitive(value))
1640 
	    return(NULL);
42292 ripley 1641 
	if(isFunction(value)) {
69636 lawrence 1642 
            if (inherits(value, "internalDispatchMethod")) {
1643 
                return(NULL);
1644 
            }
70724 lawrence 1645 
            PROTECT(suppliedvars = list1(mkString(PRIMNAME(op))));
1646 
            SET_TAG(suppliedvars, R_dot_Generic);
42292 ripley 1647 
	    /* found a method, call it with promised args */
1648 
	    if(!promisedArgs) {
1649 
		PROTECT(s = promiseArgs(CDR(call), rho));
1650 
		if (length(s) != length(args)) error(_("dispatch error"));
1651 
		for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
84280 luke 1652 
		    IF_PROMSXP_SET_PRVALUE(CAR(b), CAR(a));
85283 luke 1653 
		value =  applyClosure(call, value, s, rho, suppliedvars, TRUE);
70724 lawrence 1654 
		UNPROTECT(2);
42292 ripley 1655 
		return value;
70724 lawrence 1656 
	    } else {
77506 luke 1657 
		/* INC/DEC of REFCNT needed for non-tracking args */
1658 
		for (SEXP a = args; a != R_NilValue; a = CDR(a))
1659 
		    INCREMENT_REFCNT(CAR(a));
85283 luke 1660 
		value = applyClosure(call, value, args, rho,
1661 
				     suppliedvars, FALSE);
77506 luke 1662 
		for (SEXP a = args; a != R_NilValue; a = CDR(a))
1663 
		    DECREMENT_REFCNT(CAR(a));
70724 lawrence 1664 
                UNPROTECT(1);
1665 
                return value;
1666 
            }
42292 ripley 1667 
	}
23073 ripley 1668 
	/* else, need to perform full method search */
1669 
    }
1670 
    fundef = prim_generics[offset];
1671 
    if(!fundef || TYPEOF(fundef) != CLOSXP)
33387 ripley 1672 
	error(_("primitive function \"%s\" has been set for methods but no generic function supplied"),
23073 ripley 1673 
	      PRIMNAME(op));
1674 
    /* To do:  arrange for the setting to be restored in case of an
45446 ripley 1675 
       error in method search */
42292 ripley 1676 
    if(!promisedArgs) {
1677 
	PROTECT(s = promiseArgs(CDR(call), rho));
1678 
	if (length(s) != length(args)) error(_("dispatch error"));
1679 
	for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
84280 luke 1680 
	    IF_PROMSXP_SET_PRVALUE(CAR(b), CAR(a));
85291 luke 1681 
	value = applyClosure(call, fundef, s, rho, R_NilValue, TRUE);
42292 ripley 1682 
	UNPROTECT(1);
77506 luke 1683 
    } else {
1684 
	/* INC/DEC of REFCNT needed for non-tracking args */
1685 
	for (SEXP a = args; a != R_NilValue; a = CDR(a))
1686 
	    INCREMENT_REFCNT(CAR(a));
85283 luke 1687 
	value = applyClosure(call, fundef, args, rho, R_NilValue, FALSE);
77506 luke 1688 
	for (SEXP a = args; a != R_NilValue; a = CDR(a))
1689 
	    DECREMENT_REFCNT(CAR(a));
1690 
    }
23073 ripley 1691 
    prim_methods[offset] = current;
1692 
    if(value == deferred_default_object)
1693 
	return NULL;
1694 
    else
1695 
	return value;
16707 jmc 1696 
}
21853 jmc 1697 
 
41771 ripley 1698 
SEXP R_do_MAKE_CLASS(const char *what)
21853 jmc 1699 
{
1700 
    static SEXP s_getClass = NULL;
1701 
    SEXP e, call;
1702 
    if(!what)
32867 ripley 1703 
	error(_("C level MAKE_CLASS macro called with NULL string pointer"));
48346 maechler 1704 
    if(!s_getClass) s_getClass = install("getClass");
21853 jmc 1705 
    PROTECT(call = allocVector(LANGSXP, 2));
1706 
    SETCAR(call, s_getClass);
1707 
    SETCAR(CDR(call), mkString(what));
63624 ripley 1708 
    e = eval(call, R_MethodsNamespace);
21853 jmc 1709 
    UNPROTECT(1);
1710 
    return(e);
1711 
}
1712 
 
66622 maechler 1713 
// similar, but gives NULL instead of an error for a non-existing class
1714 
// and 'what' is never checked
86655 luke 1715 
attribute_hidden SEXP R_getClassDef_R(SEXP what)
42110 maechler 1716 
{
1717 
    static SEXP s_getClassDef = NULL;
48346 maechler 1718 
    if(!s_getClassDef) s_getClassDef = install("getClassDef");
66622 maechler 1719 
    if(!isMethodsDispatchOn()) error(_("'methods' package not yet loaded"));
1720 
    SEXP call = PROTECT(lang2(s_getClassDef, what));
1721 
    SEXP e = eval(call, R_MethodsNamespace);
42110 maechler 1722 
    UNPROTECT(1);
1723 
    return(e);
1724 
}
1725 
 
66622 maechler 1726 
SEXP R_getClassDef(const char *what)
1727 
{
1728 
    if(!what)
1729 
	error(_("R_getClassDef(.) called with NULL string pointer"));
68094 luke 1730 
    SEXP s = PROTECT(mkString(what));
1731 
    SEXP ans = R_getClassDef_R(s);
1732 
    UNPROTECT(1); /* s */
1733 
    return ans;
66622 maechler 1734 
}
1735 
 
86655 luke 1736 
attribute_hidden Rboolean R_isVirtualClass(SEXP class_def, SEXP env)
66622 maechler 1737 
{
1738 
    if(!isMethodsDispatchOn()) return(FALSE);
1739 
    static SEXP isVCl_sym = NULL;
1740 
    if(!isVCl_sym) isVCl_sym = install("isVirtualClass");
1741 
    SEXP call = PROTECT(lang2(isVCl_sym, class_def));
75532 kalibera 1742 
    SEXP e = PROTECT(eval(call, env));
66622 maechler 1743 
    // return(LOGICAL(e)[0]);
1744 
    // more cautious:
75532 kalibera 1745 
    Rboolean ans = (asLogical(e) == TRUE);
1746 
    UNPROTECT(2); /* call, e */
1747 
    return ans;
66622 maechler 1748 
}
1749 
 
86655 luke 1750 
attribute_hidden Rboolean R_extends(SEXP class1, SEXP class2, SEXP env)
66622 maechler 1751 
{
1752 
    if(!isMethodsDispatchOn()) return(FALSE);
1753 
    static SEXP extends_sym = NULL;
1754 
    if(!extends_sym) extends_sym = install("extends");
1755 
    SEXP call = PROTECT(lang3(extends_sym, class1, class2));
75532 kalibera 1756 
    SEXP e = PROTECT(eval(call, env));
66622 maechler 1757 
    // return(LOGICAL(e)[0]);
1758 
    // more cautious:
75532 kalibera 1759 
    Rboolean ans = (asLogical(e) == TRUE);
1760 
    UNPROTECT(2); /* call, e */
1761 
    return ans;
66622 maechler 1762 
}
1763 
 
60044 ripley 1764 
/* in Rinternals.h */
21853 jmc 1765 
SEXP R_do_new_object(SEXP class_def)
1766 
{
1767 
    static SEXP s_virtual = NULL, s_prototype, s_className;
1768 
    SEXP e, value;
63181 ripley 1769 
    const void *vmax = vmaxget();
21853 jmc 1770 
    if(!s_virtual) {
48346 maechler 1771 
	s_virtual = install("virtual");
1772 
	s_prototype = install("prototype");
1773 
	s_className = install("className");
41111 ripley 1774 
    }
21853 jmc 1775 
    if(!class_def)
32867 ripley 1776 
	error(_("C level NEW macro called with null class definition pointer"));
21853 jmc 1777 
    e = R_do_slot(class_def, s_virtual);
1778 
    if(asLogical(e) != 0)  { /* includes NA, TRUE, or anything other than FALSE */
1779 
	e = R_do_slot(class_def, s_className);
39077 jmc 1780 
	error(_("trying to generate an object from a virtual class (\"%s\")"),
40705 ripley 1781 
	      translateChar(asChar(e)));
21853 jmc 1782 
    }
68094 luke 1783 
    PROTECT(e = R_do_slot(class_def, s_className));
67099 luke 1784 
    PROTECT(value = duplicate(R_do_slot(class_def, s_prototype)));
87891 ripley 1785 
    bool xDataType = TYPEOF(value) == ENVSXP || TYPEOF(value) == SYMSXP ||
73057 lawrence 1786 
	TYPEOF(value) == EXTPTRSXP;
85463 luke 1787 
    if((TYPEOF(value) == OBJSXP || getAttrib(e, R_PackageSymbol) != R_NilValue) &&
73057 lawrence 1788 
       !xDataType)
77801 lawrence 1789 
    {
41111 ripley 1790 
	setAttrib(value, R_ClassSymbol, e);
1791 
	SET_S4_OBJECT(value);
1792 
    }
68094 luke 1793 
    UNPROTECT(2); /* value, e */
63181 ripley 1794 
    vmaxset(vmax);
21853 jmc 1795 
    return value;
1796 
}
37403 jmc 1797 
 
87901 ripley 1798 
attribute_hidden Rboolean R_seemsOldStyleS4Object(SEXP object)
41270 ripley 1799 
{
1800 
    SEXP klass;
1801 
    if(!isObject(object) || IS_S4_OBJECT(object)) return FALSE;
1802 
    /* We want to know about S4SXPs with no S4 bit */
1803 
    /* if(TYPEOF(object) == S4SXP) return FALSE; */
1804 
    klass = getAttrib(object, R_ClassSymbol);
1805 
    return (klass != R_NilValue && LENGTH(klass) == 1 &&
48346 maechler 1806 
	    getAttrib(klass, R_PackageSymbol) != R_NilValue) ? TRUE: FALSE;
41270 ripley 1807 
}
39103 jmc 1808 
 
90234 maechler 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 
 
83446 ripley 1816 
attribute_hidden SEXP do_setS4Object(SEXP call, SEXP op, SEXP args, SEXP env)
41111 ripley 1817 
{
60633 ripley 1818 
    checkArity(op, args);
1819 
    SEXP object = CAR(args);
87815 ripley 1820 
    Rboolean flag = asRbool(CADR(args), call);
1821 
    int complete = asInteger(CADDR(args));
60633 ripley 1822 
    if(length(CADR(args)) != 1 || flag == NA_INTEGER)
60395 ripley 1823 
	error("invalid '%s' argument", "flag");
1824 
    if(complete == NA_INTEGER)
1825 
	error("invalid '%s' argument", "complete");
41111 ripley 1826 
    if(flag == IS_S4_OBJECT(object))
45446 ripley 1827 
	return object;
48062 jmc 1828 
    else
1829 
      return asS4(object, flag, complete);
39077 jmc 1830 
}
39348 ripley 1831 
 
61776 ripley 1832 
#ifdef UNUSED
42110 maechler 1833 
SEXP R_get_primname(SEXP object)
39348 ripley 1834 
{
1835 
    SEXP f;
1836 
    if(TYPEOF(object) != BUILTINSXP && TYPEOF(object) != SPECIALSXP)
60044 ripley 1837 
	error("'R_get_primname' called on a non-primitive");
48062 jmc 1838 
    PROTECT(f = allocVector(STRSXP, 1));
39348 ripley 1839 
    SET_STRING_ELT(f, 0, mkChar(PRIMNAME(object)));
1840 
    UNPROTECT(1);
1841 
    return f;
1842 
}
61776 ripley 1843 
#endif
41631 ripley 1844 
 
87938 ripley 1845 
// in Rinternals.h
41631 ripley 1846 
Rboolean isS4(SEXP s)
1847 
{
1848 
    return IS_S4_OBJECT(s);
1849 
}
1850 
 
87938 ripley 1851 
// in Rinternals.h
48062 jmc 1852 
SEXP asS4(SEXP s, Rboolean flag, int complete)
41631 ripley 1853 
{
1854 
    if(flag == IS_S4_OBJECT(s))
45446 ripley 1855 
	return s;
48062 jmc 1856 
    PROTECT(s);
67099 luke 1857 
    if(MAYBE_SHARED(s)) {
64970 luke 1858 
	s = shallow_duplicate(s);
67099 luke 1859 
	UNPROTECT(1);
1860 
	PROTECT(s);
1861 
    }
41631 ripley 1862 
    if(flag) SET_S4_OBJECT(s);
48062 jmc 1863 
    else {
1864 
	if(complete) {
1865 
	    SEXP value;
1866 
	    /* TENTATIVE:  how much does this change? */
1867 
	    if((value = R_getS4DataSlot(s, ANYSXP))
67023 luke 1868 
	       != R_NilValue && !IS_S4_OBJECT(value)) {
1869 
	      UNPROTECT(1);
48062 jmc 1870 
	      return value;
67023 luke 1871 
	    }
48062 jmc 1872 
	    /* else no plausible S3 object*/
1873 
	    else if(complete == 1) /* ordinary case (2, for conditional) */
60844 ripley 1874 
	      error(_("object of class \"%s\" does not correspond to a valid S3 object"),
48062 jmc 1875 
		      CHAR(STRING_ELT(R_data_class(s, FALSE), 0)));
67023 luke 1876 
	    else {
68923 ripley 1877 
		UNPROTECT(1);
1878 
		return s; /*  unchanged */
67023 luke 1879 
	    }
48062 jmc 1880 
	}
1881 
	UNSET_S4_OBJECT(s);
1882 
    }
67023 luke 1883 
    UNPROTECT(1);
41631 ripley 1884 
    return s;
1885 
}