The R Project SVN R

Rev

Rev 27412 | Rev 31672 | Go to most recent revision | 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
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
24516 ripley 4 
 *  Copyright (C) 2002-3	      The R Foundation
2 r 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
21352 maechler 8 
 *  the Free Software Foundation; either version 2, or (at your option)
9 
 *  any later version.
2 r 10 
 *
21812 maechler 11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
2 r 15 
 *
21352 maechler 16 
 *  A copy of the GNU General Public License is available via WWW at
17 
 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
18 
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
19 
 *  Suite 330, Boston, MA  02111-1307  USA.
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 
 
2 r 29 
#include "Defn.h"
18397 ripley 30 
#include <R_ext/RS.h> /* for Calloc, Realloc */
2 r 31 
 
32 
static SEXP GetObject(RCNTXT *cptr)
33 
{
8130 pd 34 
    SEXP s, sysp, b, formals, funcall, tag;
35 
    sysp = R_GlobalContext->sysparent;
36 
 
37 
    PROTECT(funcall = R_syscall(0, cptr));
38 
 
39 
    if ( TYPEOF(CAR(funcall)) == SYMSXP )
40 
	PROTECT(b = findFun(CAR(funcall), sysp));
41 
    else
42 
	PROTECT(b = eval(CAR(funcall), sysp));
23840 luke 43 
    /**** use R_sysfunction here insteas */
44 
    if (TYPEOF(b) != CLOSXP) error("non-closure generic function");
8130 pd 45 
    formals = FORMALS(b);
46 
 
47 
    tag = TAG(formals);
48 
    if (tag != R_NilValue && tag != R_DotsSymbol) {
49 
	s = R_NilValue;
50 
	/** exact matches **/
21352 maechler 51 
	for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
52 
	    if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {
53 
		if ( s != R_NilValue)
8130 pd 54 
		    error("formal argument \"%s\" matched by multiple actual arguments", tag);
21352 maechler 55 
		else
8130 pd 56 
		    s = CAR(b);
57 
	    }
58 
 
59 
	if ( s == R_NilValue )
60 
	    /** partial matches **/
21352 maechler 61 
	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
62 
		if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {
8130 pd 63 
		    if ( s != R_NilValue)
64 
			error("formal argument \"%s\" matched by multiple actual arguments", tag);
21352 maechler 65 
		    else
8130 pd 66 
			s = CAR(b);
67 
		}
68 
	if ( s == R_NilValue )
69 
	    /** first untagged argument **/
21352 maechler 70 
	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
71 
		if (TAG(b) == R_NilValue )
8130 pd 72 
		{
73 
		    s = CAR(b);
74 
		    break;
75 
		}
76 
	if ( s == R_NilValue )
77 
	    s = CAR(cptr->promargs);
78 
/*
79 
	    error("failed to match argument for dispatch");
80 
*/
81 
    }
82 
    else
83 
	s = CAR(cptr->promargs);
84 
 
85 
    UNPROTECT(2);
1839 ihaka 86 
    if (TYPEOF(s) == PROMSXP) {
8130 pd 87 
	if (PRVALUE(s) == R_UnboundValue)
18214 luke 88 
	    s = eval(s, R_NilValue);
89 
	else
90 
	    s = PRVALUE(s);
1839 ihaka 91 
    }
92 
    return(s);
2 r 93 
}
94 
 
95 
static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho)
96 
{
1839 ihaka 97 
    SEXP ans;
98 
    if (TYPEOF(op) == SPECIALSXP) {
99 
	int save = R_PPStackTop;
100 
	R_Visible = 1 - PRIMPRINT(op);
101 
	ans = PRIMFUN(op) (call, op, args, rho);
102 
	if (save != R_PPStackTop) {
103 
	    Rprintf("stack imbalance in %s, %d then %d\n",
104 
		    PRIMNAME(op), save, R_PPStackTop);
526 maechler 105 
	}
1839 ihaka 106 
    }
107 
    else if (TYPEOF(op) == BUILTINSXP) {
108 
	int save = R_PPStackTop;
109 
	PROTECT(args = evalList(args, rho));
110 
	R_Visible = 1 - PRIMPRINT(op);
111 
	ans = PRIMFUN(op) (call, op, args, rho);
112 
	UNPROTECT(1);
113 
	if (save != R_PPStackTop) {
114 
	    Rprintf("stack imbalance in %s, %d then %d\n",
115 
		    PRIMNAME(op), save, R_PPStackTop);
2 r 116 
	}
1839 ihaka 117 
    }
118 
    else if (TYPEOF(op) == CLOSXP) {
119 
	ans = applyClosure(call, op, args, rho, newrho);
120 
    }
2342 maechler 121 
    else
1839 ihaka 122 
	ans = R_NilValue;  /* for -Wall */
123 
    return ans;
2 r 124 
}
125 
 
126 
 
1839 ihaka 127 
/* "newintoold" -  a destructive matching of arguments; */
128 
/* newargs comes first; any element of oldargs with */
129 
/* a name that matches a named newarg is deleted; the */
130 
/* two resulting lists are appended and returned. */
131 
/* S claims to do this (white book) but doesn't seem to. */
2 r 132 
 
526 maechler 133 
static SEXP newintoold(SEXP new, SEXP old)
2 r 134 
{
1839 ihaka 135 
    if (new == R_NilValue)
136 
	return R_NilValue;
10172 luke 137 
    SETCDR(new, newintoold(CDR(new),old));
1839 ihaka 138 
    while (old != R_NilValue) {
139 
	if (TAG(old) != R_NilValue && TAG(old) == TAG(new)) {
10172 luke 140 
	    SETCAR(old, CAR(new));
1839 ihaka 141 
	    return CDR(new);
2 r 142 
	}
1839 ihaka 143 
	old = CDR(old);
144 
    }
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 
 
154 
/*  usemethod  -  calling functions need to evaluate the object
526 maechler 155 
 *  (== 2nd argument).	They also need to ensure that the
2 r 156 
 *  argument list is set up in the correct manner.
526 maechler 157 
 *
2 r 158 
 *    1. find the context for the calling function (i.e. the generic)
159 
 *	 this gives us the unevaluated arguments for the original call
160 
 *
161 
 *    2. create an environment for evaluating the method and insert
526 maechler 162 
 *	 a handful of variables (.Generic, .Class and .Method) into
163 
 *	 that environment. Also copy any variables in the env of the
164 
 *	 generic that are not formal (or actual) arguments.
2 r 165 
 *
166 
 *    3. fix up the argument list; it should be the arguments to the
526 maechler 167 
 *	 generic matched to the formals of the method to be invoked */
2 r 168 
 
16335 luke 169 
SEXP R_LookupMethod(SEXP method, SEXP rho, SEXP callrho, SEXP defrho)
170 
{
171 
    SEXP val;
172 
 
173 
    if (R_UseNamespaceDispatch) {
174 
	if (TYPEOF(callrho) != ENVSXP && callrho != R_NilValue)
175 
	    error("bad generic call environment");
176 
	if (TYPEOF(defrho) != ENVSXP && defrho != R_NilValue)
177 
	    error("bad generic definition environment");
178 
	if (defrho == R_NilValue)
16634 luke 179 
	    defrho = R_BaseNamespace;
16335 luke 180 
 
181 
	val = findVar(method, callrho);
182 
	if (TYPEOF(val)==PROMSXP)
183 
	    val = eval(val, rho);
184 
	if (isFunction(val))
185 
	    return val;
186 
	else {
23319 luke 187 
	    SEXP table = findVarInFrame3(defrho,
188 
					 install(".__S3MethodsTable__."),
17233 ripley 189 
					 TRUE);
16335 luke 190 
	    if (TYPEOF(table) == PROMSXP)
191 
		table = eval(table, R_NilValue);
192 
	    if (TYPEOF(table) == ENVSXP) {
17233 ripley 193 
		val = findVarInFrame3(table, method, TRUE);
25332 luke 194 
		if (TYPEOF(val)==PROMSXP)
195 
		    val = eval(val, rho);
16335 luke 196 
		if (val != R_UnboundValue)
197 
		    return val;
198 
	    }
199 
	    return R_UnboundValue;
200 
	}
201 
    }
202 
    else {
203 
	val = findVar(method, rho);
204 
	if (TYPEOF(val)==PROMSXP)
205 
	    val = eval(val, rho);
206 
	return val;
207 
    }
208 
}
209 
 
1839 ihaka 210 
int usemethod(char *generic, SEXP obj, SEXP call, SEXP args,
16335 luke 211 
	      SEXP rho, SEXP callrho, SEXP defrho, SEXP *ans)
2 r 212 
{
1839 ihaka 213 
    SEXP class, method, sxp, t, s, matchedarg;
10587 tlumley 214 
    SEXP op, formals, newrho, newcall,tmp;
1839 ihaka 215 
    char buf[512];
216 
    int i, j, nclass, matched;
217 
    RCNTXT *cptr;
2 r 218 
 
1839 ihaka 219 
    /* Get the context which UseMethod was called from. */
2 r 220 
 
1839 ihaka 221 
    cptr = R_GlobalContext;
6188 rgentlem 222 
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != rho)
5731 ripley 223 
	error("UseMethod used in an inappropriate fashion");
214 rgentlem 224 
 
1839 ihaka 225 
    /* Create a new environment without any */
226 
    /* of the formals to the generic in it. */
2 r 227 
 
1839 ihaka 228 
    PROTECT(newrho = allocSExp(ENVSXP));
8516 pd 229 
    /*
1839 ihaka 230 
    PROTECT(op = findFun(CAR(cptr->call), cptr->sysparent));
8516 pd 231 
    */
232 
    op = CAR(cptr->call);
233 
    switch (TYPEOF(op)) {
234 
    case SYMSXP:
235 
	PROTECT(op = findFun(op, cptr->sysparent));
236 
	break;
237 
    case LANGSXP:
238 
	PROTECT(op = eval(op, cptr->sysparent));
239 
	break;
240 
    case CLOSXP:
241 
    case BUILTINSXP:
242 
    case SPECIALSXP:
243 
	PROTECT(op);
244 
	break;
245 
    default:
246 
	error("Invalid generic function in usemethod");
247 
    }
248 
 
1839 ihaka 249 
    if (TYPEOF(op) == CLOSXP) {
250 
	formals = FORMALS(op);
251 
	for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {
252 
	    matched = 0;
253 
	    for (t = formals; t != R_NilValue; t = CDR(t))
254 
		if (TAG(t) == TAG(s))
255 
		    matched = 1;
256 
	    if (!matched)
257 
		defineVar(TAG(s),CAR(s),newrho);
2 r 258 
	}
1839 ihaka 259 
    }
2 r 260 
 
1839 ihaka 261 
    PROTECT(matchedarg = cptr->promargs);
262 
    PROTECT(newcall = duplicate(cptr->call));
2 r 263 
 
26136 luke 264 
    PROTECT(class = R_data_class(obj, FALSE));
22764 jmc 265 
    nclass = length(class);
266 
    for (i = 0; i < nclass; i++) {
25630 ripley 267 
	if(strlen(generic) + strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
268 
	    error("class name too long in %s", generic);
269 
	sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));
22764 jmc 270 
	method = install(buf);
271 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
272 
	/* autoloading requires that promises be evaluated <TSL>*/
25628 ripley 273 
	if (TYPEOF(sxp) == PROMSXP){
25630 ripley 274 
	    PROTECT(tmp = eval(sxp, rho));
275 
	    sxp = tmp;
276 
	    UNPROTECT(1);
22764 jmc 277 
	}
278 
	if (isFunction(sxp)) {
24519 ripley 279 
	    defineVar(install(".Generic"), mkString(generic), newrho);
280 
	    if (i > 0) {
281 
		PROTECT(t = allocVector(STRSXP, nclass - i));
282 
		for (j = 0; j < length(t); j++, i++)
283 
		    SET_STRING_ELT(t, j, STRING_ELT(class, i));
284 
		setAttrib(t, install("previous"), class);
285 
		defineVar(install(".Class"), t, newrho);
286 
		UNPROTECT(1);
287 
	    }
288 
	    else
289 
		defineVar(install(".Class"), class, newrho);
290 
	    PROTECT(t = mkString(buf));
291 
	    defineVar(install(".Method"), t, newrho);
22764 jmc 292 
	    UNPROTECT(1);
24519 ripley 293 
	    if (R_UseNamespaceDispatch) {
294 
		defineVar(install(".GenericCallEnv"), callrho, newrho);
295 
		defineVar(install(".GenericDefEnv"), defrho, newrho);
296 
	    }
297 
	    t = newcall;
298 
	    SETCAR(t, method);
299 
	    R_GlobalContext->callflag = CTXT_GENERIC;
300 
	    *ans = applyMethod(t, sxp, matchedarg, rho, newrho);
301 
	    R_GlobalContext->callflag = CTXT_RETURN;
26136 luke 302 
	    UNPROTECT(5);
24519 ripley 303 
	    return 1;
2 r 304 
	}
1839 ihaka 305 
    }
25630 ripley 306 
    if(strlen(generic) + strlen("default") + 2 > 512)
307 
	error("class name too long in %s", generic);
308 
    sprintf(buf, "%s.default", generic);
1839 ihaka 309 
    method = install(buf);
16335 luke 310 
    sxp = R_LookupMethod(method, rho, callrho, defrho);
23318 luke 311 
    if (TYPEOF(sxp) == PROMSXP)
312 
	sxp = eval(sxp, rho);
1839 ihaka 313 
    if (isFunction(sxp)) {
314 
	defineVar(install(".Generic"), mkString(generic), newrho);
315 
	defineVar(install(".Class"), R_NilValue, newrho);
316 
	PROTECT(t = mkString(buf));
317 
	defineVar(install(".Method"), t, newrho);
318 
	UNPROTECT(1);
16335 luke 319 
	if (R_UseNamespaceDispatch) {
320 
	    defineVar(install(".GenericCallEnv"), callrho, newrho);
321 
	    defineVar(install(".GenericDefEnv"), defrho, newrho);
322 
	}
1839 ihaka 323 
	t = newcall;
10172 luke 324 
	SETCAR(t, method);
1839 ihaka 325 
	R_GlobalContext->callflag = CTXT_GENERIC;
326 
	*ans = applyMethod(t, sxp, matchedarg, rho, newrho);
327 
	R_GlobalContext->callflag = CTXT_RETURN;
26136 luke 328 
	UNPROTECT(5);
1839 ihaka 329 
	return 1;
330 
    }
26136 luke 331 
    UNPROTECT(5);
1839 ihaka 332 
    cptr->callflag = CTXT_RETURN;
333 
    return 0;
2 r 334 
}
335 
 
1839 ihaka 336 
/* Note: "do_usemethod" is not the only entry point to */
337 
/* "usemethod". Things like [ and [[ call usemethod directly, */
338 
/* hence do_usemethod should just be an interface to usemethod. */
2 r 339 
 
340 
SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
341 
{
24519 ripley 342 
    SEXP ans, generic, obj;
16335 luke 343 
    SEXP callenv, defenv;
1839 ihaka 344 
    int nargs;
345 
    RCNTXT *cptr;
2 r 346 
 
1839 ihaka 347 
    nargs = length(args);
2 r 348 
 
16335 luke 349 
    if (nargs < 0)
350 
	errorcall(call, "corrupt internals!");
1858 ihaka 351 
 
16335 luke 352 
    /* get environments needed for dispatching.
353 
       callenv = environment from which the generic was called
354 
       defenv = environment where the generic was defined */
355 
    cptr = R_GlobalContext;
356 
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)
357 
	error("UseMethod used in an inappropriate fashion");
358 
    callenv = cptr->sysparent;
359 
    defenv = TYPEOF(env) == ENVSXP ? ENCLOS(env) : R_NilValue;
360 
 
1839 ihaka 361 
    if (nargs)
24519 ripley 362 
	PROTECT(generic = eval(CAR(args), env));
1839 ihaka 363 
    else
24519 ripley 364 
	generic = R_MissingArg;
2 r 365 
 
24499 ripley 366 
    if (nargs > 2)  /* R-lang says there should be a warning */
367 
	warningcall(call, "Arguments after the first two are ignored");
1839 ihaka 368 
    if (nargs >= 2)
369 
	PROTECT(obj = eval(CADR(args), env));
370 
    else {
371 
	cptr = R_GlobalContext;
372 
	while (cptr != NULL) {
6188 rgentlem 373 
	    if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)
1839 ihaka 374 
		break;
375 
	    cptr = cptr->nextcontext;
2 r 376 
	}
1839 ihaka 377 
	if (cptr == NULL)
5731 ripley 378 
	    error("UseMethod called from outside a closure");
24519 ripley 379 
	if (generic == R_MissingArg)
380 
	    PROTECT(generic = mkString(CHAR(PRINTNAME(CAR(cptr->call)))));
1839 ihaka 381 
	PROTECT(obj = GetObject(cptr));
382 
    }
526 maechler 383 
 
24519 ripley 384 
    if (TYPEOF(generic) != STRSXP ||
385 
	LENGTH(generic) < 1 ||
386 
	strlen(CHAR(STRING_ELT(generic, 0))) == 0)
387 
	errorcall(call, "first argument must be a generic name");
2 r 388 
 
25628 ripley 389 
    if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),
16335 luke 390 
		  env, callenv, defenv, &ans) == 1) {
1839 ihaka 391 
	UNPROTECT(1);
2579 pd 392 
	PROTECT(ans);
1839 ihaka 393 
	findcontext(CTXT_RETURN, env, ans);
2579 pd 394 
	UNPROTECT(1);
1839 ihaka 395 
    }
396 
    else
25628 ripley 397 
	error("no applicable method for \"%s\"", CHAR(STRING_ELT(generic, 0)));
1839 ihaka 398 
    return R_NilValue; /* NOT Used */
2 r 399 
}
400 
 
2524 maechler 401 
/*
2515 rgentlem 402 
   fixcall: fixes up the call when arguments to the function may
403 
   have changed; for now we only worry about tagged args, appending
404 
   them if they are not already there
405 
*/
406 
 
407 
static SEXP fixcall(SEXP call, SEXP args)
408 
{
2524 maechler 409 
    SEXP s, t;
2515 rgentlem 410 
    int found;
411 
 
412 
    for( t = args; t != R_NilValue; t=CDR(t) ) {
413 
	if( TAG(t) != R_NilValue ) {
414 
		found = 0;
2524 maechler 415 
		for(s=call; CDR(s) != R_NilValue; s=CDR(s))
2515 rgentlem 416 
			if( TAG(CDR(s)) == TAG(t) )
417 
				found = 1;
418 
		if( !found ) {
10172 luke 419 
			SETCDR(s, allocList(1));
420 
			SET_TAG(CDR(s), TAG(t));
421 
			SETCAR(CDR(s), duplicate(CAR(t)));
2515 rgentlem 422 
		}
423 
	}
424 
    }
2519 pd 425 
    return call;
2515 rgentlem 426 
}
427 
 
1839 ihaka 428 
/* If NextMethod has any arguments the first must be the generic */
429 
/* the second the object and any remaining are matched with the */
430 
/* formals of the chosen method. */
526 maechler 431 
 
2 r 432 
#define ARGUSED(x) LEVELS(x)
433 
 
434 
SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
435 
{
25628 ripley 436 
    char buf[512], b[512], bb[512], tbuf[10];
1839 ihaka 437 
    SEXP ans, s, t, class, method, matchedarg, generic, nextfun;
438 
    SEXP sysp, m, formals, actuals, tmp, newcall;
6113 rgentlem 439 
    SEXP a, group, basename;
16335 luke 440 
    SEXP callenv, defenv;
1839 ihaka 441 
    RCNTXT *cptr;
21349 tlumley 442 
    int i,j,cftmp;
2 r 443 
 
1839 ihaka 444 
    cptr = R_GlobalContext;
21349 tlumley 445 
    cftmp = cptr->callflag;
1839 ihaka 446 
    cptr->callflag = CTXT_GENERIC;
2 r 447 
 
1839 ihaka 448 
    /* get the env NextMethod was called from */
449 
    sysp = R_GlobalContext->sysparent;
450 
    while (cptr != NULL) {
6188 rgentlem 451 
	if (cptr->callflag & CTXT_FUNCTION && cptr->cloenv == sysp)
1839 ihaka 452 
	    break;
453 
	cptr = cptr->nextcontext;
21352 maechler 454 
    }
1839 ihaka 455 
    if (cptr == NULL)
5731 ripley 456 
	error("NextMethod called from outside a closure");
2 r 457 
 
1839 ihaka 458 
    PROTECT(newcall = duplicate(cptr->call));
214 rgentlem 459 
 
21349 tlumley 460 
    /* eg get("print.ts")(1) */
461 
    if (TYPEOF(CAR(cptr->call)) == LANGSXP)
462 
       error("NextMethod called from anonymous function");
463 
 
23391 luke 464 
    /* Find dispatching environments. Promises shouldn't occur, but
465 
       check to be on the safe side.  If the variables are not in the
466 
       environment (the method was called outside a method dispatch)
467 
       then chose reasonable defaults. */
468 
    if (R_UseNamespaceDispatch) {
469 
	callenv = findVarInFrame3(R_GlobalContext->sysparent,
470 
				  install(".GenericCallEnv"), TRUE);
471 
	if (TYPEOF(callenv) == PROMSXP)
472 
	    callenv = eval(callenv, R_NilValue);
473 
	else if (callenv == R_UnboundValue)
474 
	    callenv = env;
475 
	defenv = findVarInFrame3(R_GlobalContext->sysparent,
476 
				 install(".GenericDefEnv"), TRUE);
477 
	if (TYPEOF(defenv) == PROMSXP)
478 
	    defenv = eval(defenv, R_NilValue);
479 
	else if (defenv == R_UnboundValue)
480 
	    defenv = R_GlobalEnv;
481 
    }
482 
    else {
483 
	callenv = env;
484 
	defenv = R_GlobalEnv;
485 
    }
486 
 
1839 ihaka 487 
    /* set up the arglist */
23391 luke 488 
    s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);
27412 ripley 489 
    if (TYPEOF(s) == PROMSXP)  /* looks like R_LookupMethod just did this */
23391 luke 490 
	s = eval(s, env);
27412 ripley 491 
    if (TYPEOF(s) == SYMSXP && s == R_UnboundValue)
492 
	error("No calling generic was found: was a method called directly?");
21349 tlumley 493 
    if (TYPEOF(s) != CLOSXP){
27412 ripley 494 
	errorcall(R_NilValue, "function is not a closure, but of type %d",
495 
		  TYPEOF(s));
21352 maechler 496 
    }
1975 rgentlem 497 
    /* get formals and actuals; attach the names of the formals to
498 
       the actuals, expanding any ... that occurs */
1839 ihaka 499 
    formals = FORMALS(s);
1975 rgentlem 500 
    PROTECT(actuals = matchArgs(formals, cptr->promargs));
2 r 501 
 
1975 rgentlem 502 
    i=0;
21352 maechler 503 
    for(s=formals, t=actuals; s!=R_NilValue; s=CDR(s), t=CDR(t)) {
10172 luke 504 
	SET_TAG(t, TAG(s));
21352 maechler 505 
	if(TAG(t) == R_DotsSymbol) i=length(CAR(t));
1975 rgentlem 506 
    }
507 
    if(i) {   /* we need to expand out the dots */
2524 maechler 508 
	PROTECT(t = allocList(i+length(actuals)-1));
2807 pd 509 
	for( s=actuals, m=t; s!=R_NilValue; s=CDR(s) ) {
2758 pd 510 
	    if(TYPEOF(CAR(s)) == DOTSXP) {
2524 maechler 511 
		i=1;
512 
		for(a=CAR(s); a!=R_NilValue; a=CDR(a), i++, m=CDR(m) ) {
2758 pd 513 
		    sprintf(tbuf,"..%d",i);
10172 luke 514 
		    SET_TAG(m, mkSYMSXP(mkChar(tbuf), R_UnboundValue));
515 
		    SETCAR(m, CAR(a));
2524 maechler 516 
		}
2758 pd 517 
	    }
518 
	    else {
10172 luke 519 
		SET_TAG(m, TAG(s));
520 
		SETCAR(m, CAR(s));
2807 pd 521 
		m=CDR(m);
2758 pd 522 
	    }
21352 maechler 523 
	}
2758 pd 524 
	UNPROTECT(1);
525 
	actuals=t;
1975 rgentlem 526 
    }
2758 pd 527 
    PROTECT(actuals);
1975 rgentlem 528 
 
2757 pd 529 
 
1839 ihaka 530 
    /* we can't duplicate because it would force the promises */
531 
    /* so we do our own duplication of the promargs */
1975 rgentlem 532 
 
1839 ihaka 533 
    PROTECT(matchedarg = allocList(length(cptr->promargs)));
534 
    for (t = matchedarg, s = cptr->promargs; t != R_NilValue;
21352 maechler 535 
	 s = CDR(s), t=CDR(t)) {
536 
	SETCAR(t, CAR(s));
537 
	SET_TAG(t, TAG(s));
1839 ihaka 538 
    }
539 
    for (t = matchedarg; t != R_NilValue; t = CDR(t)) {
1975 rgentlem 540 
	for (m = actuals; m != R_NilValue; m = CDR(m))
541 
	    if (CAR(m) == CAR(t))  {
1839 ihaka 542 
		if (CAR(m) == R_MissingArg) {
17233 ripley 543 
		    tmp = findVarInFrame3(cptr->cloenv, TAG(m), TRUE);
1839 ihaka 544 
		    if (tmp == R_MissingArg)
545 
			break;
546 
		}
10172 luke 547 
		SETCAR(t, mkPROMISE(TAG(m), cptr->cloenv));
1839 ihaka 548 
		break;
2524 maechler 549 
	   }
1839 ihaka 550 
    }
551 
    /*
552 
      Now see if there were any other arguments passed in
2515 rgentlem 553 
      Currently we seem to only allow named args to change
554 
      or to be added, this is at variance with p. 470 of the
555 
      White Book
556 
    */
2 r 557 
 
1839 ihaka 558 
    s = CADDR(args); /* this is ... and we need to see if it's bound */
559 
    if (s == R_DotsSymbol) {
17233 ripley 560 
	t = findVarInFrame3(env, s, TRUE);
1839 ihaka 561 
	if (t != R_NilValue && t != R_MissingArg) {
10172 luke 562 
	    SET_TYPEOF(t, LISTSXP); /* a safe mutation */
1839 ihaka 563 
	    s = matchmethargs(matchedarg,t);
564 
	    UNPROTECT(1);
565 
	    PROTECT(matchedarg = s);
2515 rgentlem 566 
	    newcall = fixcall(newcall, matchedarg);
2 r 567 
	}
1839 ihaka 568 
    }
569 
    else
5731 ripley 570 
	errorcall(call,"wrong argument ...");
2 r 571 
 
2515 rgentlem 572 
    /*
573 
      .Class is used to determine the next method; if it doesn't
574 
      exist the first argument to the current method is used
575 
      the second argument to NextMethod is another option but
576 
      isn't currently used).
577 
    */
21352 maechler 578 
    class = findVarInFrame3(R_GlobalContext->sysparent,
17233 ripley 579 
			    install(".Class"), TRUE);
2515 rgentlem 580 
 
1839 ihaka 581 
    if (class == R_UnboundValue) {
582 
	s = GetObject(cptr);
583 
	if (!isObject(s))
5731 ripley 584 
	    errorcall(call, "object not specified");
1839 ihaka 585 
	class = getAttrib(s, R_ClassSymbol);
586 
    }
2 r 587 
 
6113 rgentlem 588 
    /* the generic comes from either the sysparent or it's named */
21352 maechler 589 
    generic = findVarInFrame3(R_GlobalContext->sysparent,
17233 ripley 590 
			      install(".Generic"), TRUE);
6113 rgentlem 591 
    if (generic == R_UnboundValue)
592 
	generic = eval(CAR(args), env);
593 
    if( generic == R_NilValue )
594 
	errorcall(call,"generic function not specified");
1839 ihaka 595 
    PROTECT(generic);
2 r 596 
 
1839 ihaka 597 
    if (!isString(generic) || length(generic) > 1)
5731 ripley 598 
	errorcall(call,"invalid generic argument to NextMethod");
21352 maechler 599 
 
10172 luke 600 
    if (strlen(CHAR(STRING_ELT(generic, 0))) == 0)
5731 ripley 601 
	errorcall(call,"generic function not specified");
2 r 602 
 
6113 rgentlem 603 
    /* determine whether we are in a Group dispatch */
604 
 
17233 ripley 605 
    group = findVarInFrame3(R_GlobalContext->sysparent,install(".Group"), TRUE);
1839 ihaka 606 
    if (group == R_UnboundValue){
6113 rgentlem 607 
	PROTECT(group = mkString(""));
1839 ihaka 608 
    }
6113 rgentlem 609 
    else
610 
	PROTECT(group);
611 
 
1839 ihaka 612 
    if (!isString(group) || length(group) > 1)
5731 ripley 613 
	errorcall(call, "invalid group argument found in NextMethod");
2 r 614 
 
6113 rgentlem 615 
    /* determine the root: either the group or the generic will be it */
616 
 
10172 luke 617 
    if( strlen(CHAR(STRING_ELT(group, 0))) == 0 )
6113 rgentlem 618 
	basename = generic;
619 
    else
620 
	basename = group;
621 
 
622 
    nextfun = R_NilValue;
623 
 
624 
    /* find the method currently being invoked and jump over the current call */
625 
    /* if t is R_UnboundValue then we called the current method directly */
626 
 
17233 ripley 627 
    method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);
6113 rgentlem 628 
    if( method != R_UnboundValue) {
21352 maechler 629 
	if( !isString(method) )
6113 rgentlem 630 
	    error("Wrong value for .Method");
25628 ripley 631 
	for( i = 0; i < length(method); i++ ) {
25630 ripley 632 
	if(strlen(CHAR(STRING_ELT(method, i))) >= 512)
633 
	    error("method name too long in %s", CHAR(STRING_ELT(method, i)));
634 
	  sprintf(b, "%s", CHAR(STRING_ELT(method, i)));
6113 rgentlem 635 
	  if( strlen(b) )
636 
	    break;
637 
	}
21352 maechler 638 
	/* for binary operators check that the second argument's method
21282 tlumley 639 
	   is the same or absent */
25630 ripley 640 
	for(j = i; j < length(method); j++){
641 
	if(strlen(CHAR(STRING_ELT(method, j))) >= 512)
642 
	    error("method name too long in %s", CHAR(STRING_ELT(method, j)));
643 
	  sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));
21282 tlumley 644 
	  if (strlen(bb) && strcmp(b,bb))
645 
	      warning("Incompatible methods ignored");
646 
	}
6113 rgentlem 647 
    }
648 
    else {
25630 ripley 649 
	if(strlen(CHAR(PRINTNAME(CAR(cptr->call)))) >= 512)
650 
	   error("call name too long in %s", CHAR(PRINTNAME(CAR(cptr->call))));
651 
      sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));
6113 rgentlem 652 
    }
653 
 
1839 ihaka 654 
    for (j = 0; j < length(class); j++) {
25630 ripley 655 
	if(strlen(CHAR(STRING_ELT(basename, 0))) +
656 
	   strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)
657 
	    error("class name too long in %s", CHAR(STRING_ELT(basename, 0)));
658 
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),
659 
		CHAR(STRING_ELT(class, j)));
660 
	if ( !strcmp(buf, b) )
661 
	    break;
1839 ihaka 662 
    }
2 r 663 
 
6113 rgentlem 664 
    if ( !strcmp(buf,b) ) /* we found a match and start from there */
665 
      j++;
666 
    else
667 
      j = 0;  /*no match so start with the first element of .Class */
668 
 
21282 tlumley 669 
    /* we need the value of i on exit from the for loop to figure out
670 
	   how many classes to drop. */
6113 rgentlem 671 
    for (i = j ; i < length(class); i++) {
25630 ripley 672 
	if(strlen(CHAR(STRING_ELT(generic, 0))) +
673 
	   strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
674 
	    error("class name too long in %s", CHAR(STRING_ELT(generic, 0)));
675 
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),
10172 luke 676 
		CHAR(STRING_ELT(class, i)));
16335 luke 677 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
23318 luke 678 
	if (TYPEOF(nextfun) == PROMSXP)
679 
	    nextfun = eval(nextfun, env);
21282 tlumley 680 
	if (isFunction(nextfun))
681 
	    break;
682 
	if (group !=R_UnboundValue){
683 
	    /* if not Generic.foo, look for Group.foo */
25630 ripley 684 
	    sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),
21282 tlumley 685 
		CHAR(STRING_ELT(class, i)));
21352 maechler 686 
	    nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
23318 luke 687 
	    if (TYPEOF(nextfun) == PROMSXP)
688 
		nextfun = eval(nextfun, env);
21352 maechler 689 
	    if(isFunction(nextfun))
690 
		break;
21282 tlumley 691 
	}
1839 ihaka 692 
	if (isFunction(nextfun))
693 
	    break;
694 
    }
695 
    if (!isFunction(nextfun)) {
25630 ripley 696 
	sprintf(buf, "%s.default", CHAR(STRING_ELT(generic, 0)));
16335 luke 697 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
23318 luke 698 
	if (TYPEOF(nextfun) == PROMSXP)
699 
	    nextfun = eval(nextfun, env);
1839 ihaka 700 
	if (!isFunction(nextfun)) {
10172 luke 701 
	    t = install(CHAR(STRING_ELT(generic, 0)));
1839 ihaka 702 
	    nextfun = findVar(t,env);
22881 luke 703 
	    if (TYPEOF(nextfun)==PROMSXP)
704 
		nextfun = eval(nextfun, env);
1839 ihaka 705 
	    if (!isFunction(nextfun))
5731 ripley 706 
		error("No method to invoke");
1839 ihaka 707 
	    if (TYPEOF(nextfun) == CLOSXP) {
708 
		if (INTERNAL(t) != R_NilValue)
709 
		    nextfun = INTERNAL(t);
710 
		else
5731 ripley 711 
		    error("No method to invoke");
1839 ihaka 712 
	    }
2 r 713 
	}
1839 ihaka 714 
    }
715 
    PROTECT(s = allocVector(STRSXP, length(class) - i));
716 
    PROTECT(class = duplicate(class));
717 
    PROTECT(m = allocSExp(ENVSXP));
718 
    for (j = 0; j < length(s); j++)
10172 luke 719 
	SET_STRING_ELT(s, j, duplicate(STRING_ELT(class, i++)));
1839 ihaka 720 
    setAttrib(s, install("previous"), class);
721 
    defineVar(install(".Class"), s, m);
21282 tlumley 722 
    /* for Ops we need `method' to be a vector */
723 
    PROTECT(method = duplicate(method));
724 
    for(j = 0; j < length(method); j++){
725 
       if (strlen(CHAR(STRING_ELT(method,j))))
726 
	   SET_STRING_ELT(method,j,  mkChar(buf));
727 
    }
1839 ihaka 728 
    defineVar(install(".Method"), method, m);
16335 luke 729 
    if (R_UseNamespaceDispatch) {
730 
	defineVar(install(".GenericCallEnv"), callenv, m);
731 
	defineVar(install(".GenericDefEnv"), defenv, m);
732 
    }
1839 ihaka 733 
    method = install(buf);
2 r 734 
 
1839 ihaka 735 
    defineVar(install(".Generic"), generic, m);
2 r 736 
 
6113 rgentlem 737 
    defineVar(install(".Group"), group, m);
526 maechler 738 
 
10172 luke 739 
    SETCAR(newcall, method);
1839 ihaka 740 
    ans = applyMethod(newcall, nextfun, matchedarg, env, m);
6113 rgentlem 741 
    UNPROTECT(10);
1839 ihaka 742 
    return(ans);
2 r 743 
}
744 
 
745 
SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)
746 
{
1839 ihaka 747 
    checkArity(op, args);
748 
    if (isObject(CAR(args))) {
10172 luke 749 
	SETCAR(args, duplicate(CAR(args)));
1839 ihaka 750 
	setAttrib(CAR(args), R_ClassSymbol, R_NilValue);
751 
    }
752 
    return CAR(args);
2 r 753 
}
754 
 
21352 maechler 755 
/* ___unused___	 InheritsClass() and RemoveClass() */
13606 maechler 756 
Rboolean InheritsClass(SEXP x, char *name)
2 r 757 
{
13606 maechler 758 
/* does an object inherit from a class ? */
1839 ihaka 759 
    SEXP class;
760 
    int i, nclass;
761 
    if (isObject(x)) {
762 
	class = getAttrib(x, R_ClassSymbol);
763 
	nclass = length(class);
764 
	for (i = 0; i < nclass; i++)
10172 luke 765 
	    if (!strcmp(CHAR(STRING_ELT(class, i)), name))
13606 maechler 766 
		return TRUE;
1839 ihaka 767 
    }
13606 maechler 768 
    return FALSE;
2 r 769 
}
770 
 
771 
void RemoveClass(SEXP x, char *name)
772 
{
1839 ihaka 773 
    SEXP class, newclass;
774 
    int i, j, nclass, nmatch;
2 r 775 
 
1839 ihaka 776 
    if (isObject(x)) {
777 
	PROTECT(x);
778 
	class = getAttrib(x, R_ClassSymbol);
779 
	nclass = length(class);
780 
	nmatch = 0;
781 
	for (i = 0; i < nclass; i++)
10172 luke 782 
	    if (!strcmp(CHAR(STRING_ELT(class, i)), name))
1839 ihaka 783 
		nmatch++;
784 
	if (nmatch == nclass) {
785 
	    setAttrib(x, R_ClassSymbol, R_NilValue);
786 
	}
787 
	else if (nmatch > 0) {
788 
	    PROTECT(newclass = allocVector(STRSXP, nclass-nmatch));
789 
	    for (i = 0, j = 0; i < nclass; i++)
10172 luke 790 
		if (strcmp(CHAR(STRING_ELT(class, i)), name)) {
791 
		    SET_STRING_ELT(newclass, j++, STRING_ELT(class, i));
2 r 792 
		}
1839 ihaka 793 
	    setAttrib(x, R_ClassSymbol, newclass);
794 
	    UNPROTECT(1);
2 r 795 
	}
1839 ihaka 796 
	UNPROTECT(1);
797 
    }
2 r 798 
}
9608 rgentlem 799 
 
800 
SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
801 
{
9928 ripley 802 
    SEXP x, class, what, which, rval = R_NilValue /* -Wall */;
803 
    int i, j, nwhat, isvec, nclass;
9608 rgentlem 804 
 
805 
    checkArity(op, args);
806 
 
807 
    x = CAR(args);
808 
    /* if x isn't an object get out asap */
23630 ripley 809 
    /* if( !isObject(x) )
810 
       return mkFalse();
21352 maechler 811 
 
23630 ripley 812 
       class = getAttrib(x, R_ClassSymbol);*/
813 
 
814 
    class = R_data_class(x, FALSE);
9608 rgentlem 815 
    nclass = length(class);
816 
 
817 
    what = CADR(args);
818 
    if( !isString(what) )
819 
	errorcall(call, "what must be a character vector");
820 
    nwhat = length(what);
821 
 
822 
    which = CADDR(args);
823 
    if( !isLogical(which) || (length(which) != 1) )
824 
	errorcall(call, "which must be a length 1 logical vector");
825 
    isvec = asLogical(which);
826 
 
827 
    if( isvec )
828 
	rval = allocVector(INTSXP, nwhat);
829 
 
830 
    for(j=0; j<nwhat; j++) {
831 
	for(i=0; i<nclass; i++) {
832 
	    if( isvec )
833 
		INTEGER(rval)[j] = 0;
10172 luke 834 
	    if(!strcmp(CHAR(STRING_ELT(class,i)), CHAR(STRING_ELT(what,j)))) {
21352 maechler 835 
		if(isvec)
836 
		   INTEGER(rval)[j] = i+1;
837 
		else
9608 rgentlem 838 
		    return mkTrue();
839 
		break;
840 
	    }
841 
	}
842 
    }
21352 maechler 843 
    if( !isvec )
9608 rgentlem 844 
	return mkFalse();
845 
    return rval;
846 
}
15890 jmc 847 
 
21352 maechler 848 
 
15890 jmc 849 
/* standardGeneric:  uses a pointer to R_standardGeneric, to be
850 
   initialized when the methods package is attached.  When and if the
851 
   methods code is automatically included, the pointer will not be
21352 maechler 852 
   needed
15912 ripley 853 
 
15890 jmc 854 
*/
15938 jmc 855 
static R_stdGen_ptr_t R_standardGeneric_ptr = 0;
21102 jmc 856 
static SEXP dispatchNonGeneric(SEXP name, SEXP env, SEXP fdef);
857 
#define NOT_METHODS_DISPATCH_PTR(ptr) (ptr == 0 || ptr == dispatchNonGeneric)
15890 jmc 858 
 
21352 maechler 859 
R_stdGen_ptr_t R_get_standardGeneric_ptr()
16747 ripley 860 
{
861 
    return R_standardGeneric_ptr;
15938 jmc 862 
}
863 
 
26082 jmc 864 
R_stdGen_ptr_t R_set_standardGeneric_ptr(R_stdGen_ptr_t val, SEXP envir)
16747 ripley 865 
{
866 
    R_stdGen_ptr_t old = R_standardGeneric_ptr;
867 
    R_standardGeneric_ptr = val;
26082 jmc 868 
    if(envir && !isNull(envir))
869 
	R_MethodsNamespace = envir;
870 
    /* just in case ... */
871 
    if(!R_MethodsNamespace)
872 
	R_MethodsNamespace = R_GlobalEnv;
16747 ripley 873 
    return old;
15938 jmc 874 
}
875 
 
21102 jmc 876 
SEXP R_isMethodsDispatchOn(SEXP onOff) {
877 
    SEXP value = allocVector(LGLSXP, 1);
878 
    Rboolean onOffValue;
879 
    R_stdGen_ptr_t old = R_get_standardGeneric_ptr();
880 
    LOGICAL(value)[0] = !NOT_METHODS_DISPATCH_PTR(old);
23073 ripley 881 
    if(length(onOff) > 0) {
21102 jmc 882 
	    onOffValue = asLogical(onOff);
883 
	    if(onOffValue == FALSE)
26082 jmc 884 
		    R_set_standardGeneric_ptr(0, 0);
21102 jmc 885 
	    else if(NOT_METHODS_DISPATCH_PTR(old)) {
886 
		    SEXP call;
887 
		    PROTECT(call = allocList(2));
888 
		    SETCAR(call, install("initMethodsDispatch"));
889 
		    eval(call, R_GlobalEnv); /* only works with
21352 maechler 890 
						methods	 attached */
21102 jmc 891 
	    }
892 
    }
893 
    return value;
894 
}
895 
 
23073 ripley 896 
/* simpler version for internal use */
897 
 
898 
Rboolean isMethodsDispatchOn(void)
899 
{
900 
    return !NOT_METHODS_DISPATCH_PTR(R_standardGeneric_ptr);
901 
}
902 
 
903 
 
21352 maechler 904 
static SEXP dispatchNonGeneric(SEXP name, SEXP env, SEXP fdef)
16747 ripley 905 
{
906 
    /* dispatch the non-generic definition of `name'.  Used to trap
907 
       calls to standardGeneric during the loading of the methods package */
908 
    SEXP e, value, rho, fun, symbol, dot_Generic;
909 
    RCNTXT *cptr;
910 
    /* find a non-generic function */
911 
    symbol = install(CHAR(asChar(name)));
912 
    dot_Generic = install(".Generic");
913 
    for(rho = ENCLOS(env); rho != R_NilValue && isEnvironment(rho);
914 
	rho = ENCLOS(rho)) {
17233 ripley 915 
	fun = findVarInFrame3(rho, symbol, TRUE);
16747 ripley 916 
	if(fun == R_UnboundValue) continue;
917 
	switch(TYPEOF(fun)) {
918 
	case BUILTINSXP:  case SPECIALSXP: break;
919 
	case CLOSXP:
17233 ripley 920 
	    value = findVarInFrame3(CLOENV(fun), dot_Generic, TRUE);
16747 ripley 921 
	    if(value == R_UnboundValue) break;
922 
	    /*in all other cases, go on to the parent environment */
923 
	}
924 
	fun = R_UnboundValue;
16372 jmc 925 
    }
16747 ripley 926 
    fun = SYMVALUE(symbol);
927 
    if(fun == R_UnboundValue)
21352 maechler 928 
	error("Unable to find a non-generic version of function \"%s\"",
16747 ripley 929 
	      CHAR(asChar(name)));
930 
    cptr = R_GlobalContext;
931 
    /* check this is the right context */
16372 jmc 932 
    while (cptr != R_ToplevelContext) {
933 
	if (cptr->callflag & CTXT_FUNCTION )
934 
	    if (cptr->cloenv == env)
935 
		break;
936 
	cptr = cptr->nextcontext;
937 
    }
21352 maechler 938 
 
16747 ripley 939 
    PROTECT(e = duplicate(R_syscall(0, cptr)));
940 
    SETCAR(e, fun);
941 
    /* evaluate a call the non-generic with the same arguments and from
942 
       the same environment as the call to the generic version */
943 
    value = eval(e, cptr->sysparent);
944 
    UNPROTECT(1);
945 
    return value;
16372 jmc 946 
}
947 
 
20089 jmc 948 
 
16635 ripley 949 
#ifdef UNUSED
16302 jmc 950 
static void load_methods_package()
951 
{
16747 ripley 952 
    SEXP e;
26082 jmc 953 
    R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);
16747 ripley 954 
    PROTECT(e = allocVector(LANGSXP, 2));
955 
    SETCAR(e, install("library"));
956 
    SETCAR(CDR(e), install("methods"));
957 
    eval(e, R_GlobalEnv);
958 
    UNPROTECT(1);
16302 jmc 959 
}
16635 ripley 960 
#endif
16302 jmc 961 
 
20089 jmc 962 
static SEXP get_this_generic(SEXP args);
963 
 
15890 jmc 964 
SEXP do_standardGeneric(SEXP call, SEXP op, SEXP args, SEXP env)
965 
{
20089 jmc 966 
    SEXP arg, value, fdef; R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr();
16747 ripley 967 
    if(!ptr) {
21102 jmc 968 
	warning("standardGeneric called without methods dispatch enabled (will be ignored)");
26082 jmc 969 
	R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);
16747 ripley 970 
	ptr = R_get_standardGeneric_ptr();
971 
    }
20994 jmc 972 
    PROTECT(args);
16747 ripley 973 
    PROTECT(arg = CAR(args));
22291 jmc 974 
    if(!isValidStringF(arg))
975 
      error("Argument to standardGeneric must be a non-empty character string");
976 
 
20089 jmc 977 
    PROTECT(fdef = get_this_generic(args));
15890 jmc 978 
 
22291 jmc 979 
    if(isNull(fdef))
22293 jmc 980 
      error("Call to standardGeneric(\"%s\") apparently not from the body of that generic function", CHAR(STRING_ELT(arg, 0)));
22291 jmc 981 
 
20089 jmc 982 
    value = (*ptr)(arg, env, fdef);
21352 maechler 983 
 
20994 jmc 984 
    UNPROTECT(3);
16747 ripley 985 
    return value;
15890 jmc 986 
}
987 
 
16707 jmc 988 
static int maxMethodsOffset = 0, curMaxOffset;
989 
typedef enum {NO_METHODS, NEEDS_RESET, HAS_METHODS, SUPPRESSED} prim_methods_t;
990 
 
991 
static prim_methods_t *prim_methods;
992 
static SEXP *prim_generics;
993 
static SEXP *prim_mlist;
994 
#define DEFAULT_N_PRIM_METHODS 100
995 
 
996 
SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,
997 
		       SEXP mlist)
998 
{
16747 ripley 999 
    char *code_string;
1000 
    if(!isValidString(code_vec))
1001 
	error("Argument \"code\" must be a character string");
1002 
    code_string = CHAR(asChar(code_vec));
1003 
    do_set_prim_method(op, code_string, fundef, mlist);
1004 
    return(fname);
16707 jmc 1005 
}
1006 
 
20089 jmc 1007 
SEXP R_primitive_methods(SEXP op)
1008 
{
1009 
    int offset = PRIMOFFSET(op);
24661 ripley 1010 
    if(offset < 0 || offset > curMaxOffset)
21352 maechler 1011 
	return R_NilValue;
20089 jmc 1012 
    else {
21352 maechler 1013 
	SEXP value = prim_mlist[offset];
20089 jmc 1014 
	return value ? value : R_NilValue;
1015 
    }
1016 
}
1017 
 
16707 jmc 1018 
SEXP do_set_prim_method(SEXP op, char *code_string, SEXP fundef, SEXP mlist)
1019 
{
18397 ripley 1020 
    int offset = 0;
1021 
    prim_methods_t code = NO_METHODS; /* -Wall */
1022 
    SEXP value;
1023 
    Rboolean errorcase = FALSE;
1024 
    switch(code_string[0]) {
1025 
    case 'c': /* clear */
1026 
	code = NO_METHODS; break;
1027 
    case 'r': /* reset */
1028 
	code = NEEDS_RESET; break;
20089 jmc 1029 
    case 's': /* set or suppress */
18397 ripley 1030 
	switch(code_string[1]) {
1031 
	case 'e': code = HAS_METHODS; break;
1032 
	case 'u': code = SUPPRESSED; break;
1033 
	default: errorcase = TRUE;
1034 
	}
1035 
	break;
1036 
    default:
1037 
	errorcase = TRUE;
16707 jmc 1038 
    }
18397 ripley 1039 
    if(errorcase) {
20994 jmc 1040 
	error("Invalid primitive methods code (\"%s\"): should be \"clear\", \"reset\", \"set\", or \"suppress\"", code_string);
18397 ripley 1041 
	return R_NilValue;
1042 
    }
1043 
    switch(TYPEOF(op)) {
1044 
    case BUILTINSXP: case SPECIALSXP:
1045 
	offset = PRIMOFFSET(op);
1046 
	break;
21352 maechler 1047 
    default:
18397 ripley 1048 
	error("Invalid object: must be a primitive function");
1049 
    }
1050 
    if(offset >= maxMethodsOffset) {
1051 
	int n;
24205 ripley 1052 
	n = offset + 1;
18397 ripley 1053 
	if(n < DEFAULT_N_PRIM_METHODS)
1054 
	    n = DEFAULT_N_PRIM_METHODS;
1055 
	if(n < 2*maxMethodsOffset)
1056 
	    n = 2 * maxMethodsOffset;
1057 
	if(prim_methods) {
19214 pd 1058 
	    int i;
19197 pd 1059 
 
19214 pd 1060 
	    prim_methods  = Realloc(prim_methods,  n, prim_methods_t);
1061 
	    prim_generics = Realloc(prim_generics, n, SEXP);
21352 maechler 1062 
	    prim_mlist	  = Realloc(prim_mlist,	   n, SEXP);
19214 pd 1063 
 
1064 
	    /* Realloc does not clear the added memory, hence: */
1065 
	    for (i = maxMethodsOffset ; i < n ; i++) {
21352 maechler 1066 
		prim_methods[i]	 = NO_METHODS;
19214 pd 1067 
		prim_generics[i] = NULL;
21352 maechler 1068 
		prim_mlist[i]	 = NULL;
19214 pd 1069 
	    }
18397 ripley 1070 
	}
1071 
	else {
19214 pd 1072 
	    prim_methods  = Calloc(n, prim_methods_t);
18397 ripley 1073 
	    prim_generics = Calloc(n, SEXP);
21352 maechler 1074 
	    prim_mlist	  = Calloc(n, SEXP);
18397 ripley 1075 
	}
1076 
	maxMethodsOffset = n;
1077 
    }
1078 
    if(offset > curMaxOffset)
1079 
	curMaxOffset = offset;
1080 
    prim_methods[offset] = code;
1081 
    /* store a preserved pointer to the generic function if there is not
1082 
       one there currently.  Unpreserve it if no more methods, but don't
1083 
       replace it otherwise:  the generic definition is not allowed to
1084 
       change while it's still defined! (the stored methods list can,
1085 
       however) */
1086 
    value = prim_generics[offset];
20089 jmc 1087 
    if(code == SUPPRESSED) {} /* leave the structure alone */
1088 
    else if(code == NO_METHODS && prim_generics[offset]) {
18397 ripley 1089 
	R_ReleaseObject(prim_generics[offset]);
1090 
	prim_generics[offset] = 0;
1091 
	prim_mlist[offset] = 0;
1092 
    }
1093 
    else if(fundef && !isNull(fundef) && !prim_generics[offset]) {
1094 
	if(TYPEOF(fundef) != CLOSXP)
1095 
	    error("The formal definition of a primitive generic must be a function object (got type %s)",
1096 
		  type2str(TYPEOF(fundef)));
1097 
	R_PreserveObject(fundef);
1098 
	prim_generics[offset] = fundef;
1099 
    }
1100 
    if(code==HAS_METHODS) {
20089 jmc 1101 
	if(!mlist  || isNull(mlist)) {
1102 
		/* turning methods back on after a SUPPRESSED */
1103 
	}
1104 
	else {
1105 
	  if(prim_mlist[offset])
18397 ripley 1106 
	    R_ReleaseObject(prim_mlist[offset]);
20089 jmc 1107 
	  R_PreserveObject(mlist);
1108 
	  prim_mlist[offset] = mlist;
1109 
	}
18397 ripley 1110 
    }
1111 
    return value;
16707 jmc 1112 
}
1113 
 
17092 jmc 1114 
static SEXP get_primitive_methods(SEXP op, SEXP rho)
1115 
{
1116 
    SEXP f, e;
1117 
    int nprotect = 0;
1118 
    f = PROTECT(allocVector(STRSXP, 1));  nprotect++;
1119 
    SET_STRING_ELT(f, 0, mkChar(PRIMNAME(op)));
1120 
    PROTECT(e = allocVector(LANGSXP, 2)); nprotect++;
1121 
    SETCAR(e, install("getMethods"));
1122 
    SETCAR(CDR(e), f);
1123 
    e = eval(e, rho);
1124 
    UNPROTECT(nprotect);
1125 
    return e;
1126 
}
20089 jmc 1127 
 
1128 
/* get the generic function, defined to be the function definition for
1129 
the call to standardGeneric(), or for primitives, passed as the second
1130 
argument to standardGeneric.
1131 
*/
1132 
static SEXP get_this_generic(SEXP args)
1133 
{
22450 ripley 1134 
    SEXP value = R_NilValue; static SEXP gen_name;
20994 jmc 1135 
    int i, n;
1136 
    RCNTXT *cptr; char *fname;
20277 ripley 1137 
 
20089 jmc 1138 
    /* a second argument to the call, if any, is taken as the function */
1139 
    if(CDR(args) != R_NilValue)
20277 ripley 1140 
	return CAR(CDR(args));
20994 jmc 1141 
    /* else use sys.function (this is fairly expensive-- would be good
1142 
     * to force a second argument if possible) */
20154 jmc 1143 
    PROTECT(args);
20994 jmc 1144 
    if(!gen_name)
1145 
	gen_name = install("generic");
20089 jmc 1146 
    cptr = R_GlobalContext;
20994 jmc 1147 
    fname = CHAR(asChar(CAR(args)));
1148 
    n = framedepth(cptr);
1149 
    /* check for a matching "generic" slot */
1150 
    for(i=0;  i<n; i++) {
22379 ripley 1151 
	SEXP rval = R_sysfunction(i, cptr);
20994 jmc 1152 
	if(isObject(rval)) {
1153 
	    SEXP generic = getAttrib(rval, gen_name);
1154 
	    if(TYPEOF(generic) == STRSXP &&
22291 jmc 1155 
	       !strcmp(CHAR(asChar(generic)), fname)) {
1156 
	      value = rval;
1157 
	      break;
1158 
	    }
20994 jmc 1159 
	}
20154 jmc 1160 
    }
1161 
    UNPROTECT(1);
22291 jmc 1162 
    return(value);
20089 jmc 1163 
}
17092 jmc 1164 
 
21352 maechler 1165 
/* Could there be methods for this op?	Checks
16707 jmc 1166 
   only whether methods are currently being dispatched and, if so,
1167 
   whether methods are currently defined for this op. */
17000 jmc 1168 
Rboolean R_has_methods(SEXP op)
16707 jmc 1169 
{
16747 ripley 1170 
    R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr(); int offset;
21102 jmc 1171 
    if(NOT_METHODS_DISPATCH_PTR(ptr))
17000 jmc 1172 
	return(FALSE);
22764 jmc 1173 
    if(!op || TYPEOF(op) == CLOSXP) /* except for primitives, just test for the package */
17000 jmc 1174 
	return(TRUE);
16747 ripley 1175 
    offset = PRIMOFFSET(op);
1176 
    if(offset > curMaxOffset || prim_methods[offset] == NO_METHODS
1177 
       || prim_methods[offset] == SUPPRESSED)
17000 jmc 1178 
	return(FALSE);
1179 
    return(TRUE);
16707 jmc 1180 
}
1181 
 
1182 
static SEXP deferred_default_object;
1183 
 
1184 
SEXP R_deferred_default_method()
1185 
{
16747 ripley 1186 
    if(!deferred_default_object)
1187 
	deferred_default_object = install("__Deferred_Default_Marker__");
1188 
    return(deferred_default_object);
16707 jmc 1189 
}
1190 
 
1191 
 
1192 
static R_stdGen_ptr_t quick_method_check_ptr = NULL;
1193 
void R_set_quick_method_check(R_stdGen_ptr_t value)
1194 
{
16747 ripley 1195 
    quick_method_check_ptr = value;
16707 jmc 1196 
}
23073 ripley 1197 
 
16707 jmc 1198 
/* try to dispatch the formal method for this primitive op, by calling
21352 maechler 1199 
   the stored generic function corresponding to the op.	 Requires that
16707 jmc 1200 
   the methods be set up to return a special object rather than trying
1201 
   to evaluate the default (which would get us into a loop). */
23073 ripley 1202 
SEXP R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho)
16707 jmc 1203 
{
27710 ripley 1204 
    SEXP fundef, value, mlist=R_NilValue;
1205 
    int offset;
1206 
    prim_methods_t current;
23073 ripley 1207 
    offset = PRIMOFFSET(op);
1208 
    if(offset < 0 || offset > curMaxOffset)
1209 
	error("Invalid primitive operation given for dispatch");
1210 
    current = prim_methods[offset];
1211 
    if(current == NO_METHODS || current == SUPPRESSED)
1212 
	return(NULL);
1213 
    /* check that the methods for this function have been set */
1214 
    if(current == NEEDS_RESET) {
1215 
	/* get the methods and store them in the in-core primitive
1216 
	   method table.	The entries will be preserved via
1217 
	   R_preserveobject, so later we can just grab mlist from
1218 
	   prim_mlist */
26648 ripley 1219 
	do_set_prim_method(op, "suppressed", R_NilValue, mlist);
23073 ripley 1220 
	PROTECT(mlist = get_primitive_methods(op, rho));
1221 
	do_set_prim_method(op, "set", R_NilValue, mlist);
26016 jmc 1222 
	current = prim_methods[offset]; /* as revised by do_set_prim_method */
23073 ripley 1223 
	UNPROTECT(1);
1224 
    }
1225 
    mlist = prim_mlist[offset];
1226 
    if(mlist && !isNull(mlist)
1227 
       && quick_method_check_ptr) {
1228 
	value = (*quick_method_check_ptr)(args, mlist, op);
1229 
	if(isPrimitive(value))
1230 
	    return(NULL);
1231 
	if(isFunction(value))
1232 
	    /* found a method, call it */
1233 
	    return applyClosure(call, value, args, rho, R_NilValue);
1234 
	/* else, need to perform full method search */
1235 
    }
1236 
    fundef = prim_generics[offset];
1237 
    if(!fundef || TYPEOF(fundef) != CLOSXP)
1238 
	error("primitive function \"%s\" has been set for methods but no  generic function supplied",
1239 
	      PRIMNAME(op));
1240 
    /* To do:  arrange for the setting to be restored in case of an
1241 
       error in method search */
1242 
    value = applyClosure(call, fundef, args, rho, R_NilValue);
1243 
    prim_methods[offset] = current;
1244 
    if(value == deferred_default_object)
1245 
	return NULL;
1246 
    else
1247 
	return value;
16707 jmc 1248 
}
21853 jmc 1249 
 
1250 
SEXP R_do_MAKE_CLASS( char *what)
1251 
{
1252 
    static SEXP s_getClass = NULL;
1253 
    SEXP e, call;
1254 
    if(!what)
1255 
	error("C level MAKE_CLASS macro called with NULL string pointer");
1256 
    if(!s_getClass)
1257 
	s_getClass = Rf_install("getClass");
1258 
    PROTECT(call = allocVector(LANGSXP, 2));
1259 
    SETCAR(call, s_getClass);
1260 
    SETCAR(CDR(call), mkString(what));
1261 
    e = eval(call, R_GlobalEnv);
1262 
    UNPROTECT(1);
1263 
    return(e);
1264 
}
1265 
 
1266 
SEXP R_do_new_object(SEXP class_def)
1267 
{
1268 
    static SEXP s_virtual = NULL, s_prototype, s_className;
1269 
    SEXP e, value;
1270 
    if(!s_virtual) {
1271 
	s_virtual = Rf_install("virtual");
1272 
	s_prototype = Rf_install("prototype");
1273 
	s_className = Rf_install("className");
1274 
    }
1275 
    if(!class_def)
1276 
	error("C level NEW macro called with null class definition pointer");
1277 
    e = R_do_slot(class_def, s_virtual);
1278 
    if(asLogical(e) != 0)  { /* includes NA, TRUE, or anything other than FALSE */
1279 
	e = R_do_slot(class_def, s_className);
1280 
	error("Trying to generate an object in C from a virtual class (\"%s\")",
1281 
	      CHAR(asChar(e)));
1282 
    }
1283 
    e = R_do_slot(class_def, s_className);
22303 jmc 1284 
    value = duplicate(R_do_slot(class_def, s_prototype));
21853 jmc 1285 
    setAttrib(value, R_ClassSymbol, e);
1286 
    return value;
1287 
}