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