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



 
    if ( TYPEOF(CAR(funcall)) == SYMSXP )
	PROTECT(b = findFun(CAR(funcall), sysp));
    else
	PROTECT(b = eval(CAR(funcall), sysp));
    /**** use R_sysfunction here instead */
    if (TYPEOF(b) != CLOSXP) error(_("generic 'function' is not a function"));
    formals = FORMALS(b);
 
    tag = TAG(formals);
    if (tag != R_NilValue && tag != R_DotsSymbol) {
	s = R_NilValue;
	/** exact matches **/
	for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
	    if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {
		if ( s != R_NilValue)
		    error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);
		else
		    s = CAR(b);
	    }
 
	if ( s == R_NilValue )
	    /** partial matches **/
	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))
		if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {
		    if ( s != R_NilValue)
			error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);
		    else
			s = CAR(b);
		}
	if ( s == R_NilValue )
	    /** first untagged argument **/

{
    SEXP val;
 
    if (R_UseNamespaceDispatch) {
	if (TYPEOF(callrho) != ENVSXP && callrho != R_NilValue)
	    error(_("bad generic call environment"));
	if (TYPEOF(defrho) != ENVSXP && defrho != R_NilValue)
	    error(_("bad generic definition environment"));
	if (defrho == R_NilValue)
	    defrho = R_BaseNamespace;
 
	val = findVar(method, callrho);
	if (TYPEOF(val)==PROMSXP)

 
    /* Get the context which UseMethod was called from. */
 
    cptr = R_GlobalContext;
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != rho)
	error(_("UseMethod used in an inappropriate fashion"));
 
    /* Create a new environment without any */
    /* of the formals to the generic in it. */
 
    PROTECT(newrho = allocSExp(ENVSXP));

    case BUILTINSXP:
    case SPECIALSXP:
	PROTECT(op);
	break;
    default:
	error(_("Invalid generic function in usemethod"));
    }
 
    if (TYPEOF(op) == CLOSXP) {
	formals = FORMALS(op);
	for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {

 
    PROTECT(class = R_data_class2(obj));
    nclass = length(class);
    for (i = 0; i < nclass; i++) {
	if(strlen(generic) + strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
	    error(_("class name too long in %s"), generic);
	sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));
	method = install(buf);
	sxp = R_LookupMethod(method, rho, callrho, defrho);
	/* autoloading requires that promises be evaluated <TSL>*/
	if (TYPEOF(sxp) == PROMSXP){

	    UNPROTECT(5);
	    return 1;
	}
    }
    if(strlen(generic) + strlen("default") + 2 > 512)
	error(_("class name too long in %s"), generic);
    sprintf(buf, "%s.default", generic);
    method = install(buf);
    sxp = R_LookupMethod(method, rho, callrho, defrho);
    if (TYPEOF(sxp) == PROMSXP)
	sxp = eval(sxp, rho);

    RCNTXT *cptr;
 
    nargs = length(args);
 
    if (nargs < 0)
	errorcall(call, _("corrupt internals!"));
 
    /* get environments needed for dispatching.
       callenv = environment from which the generic was called
       defenv = environment where the generic was defined */
    cptr = R_GlobalContext;
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)
	error(_("UseMethod used in an inappropriate fashion"));
    callenv = cptr->sysparent;
    defenv = TYPEOF(env) == ENVSXP ? ENCLOS(env) : R_NilValue;
 
    if (nargs)
	PROTECT(generic = eval(CAR(args), env));
    else 
	errorcall(call, _("There must be a first argument"));
 
    if (nargs > 2)  /* R-lang says there should be a warning */
	warningcall(call, _("Arguments after the first two are ignored"));
    if (nargs >= 2)
	PROTECT(obj = eval(CADR(args), env));
    else {
	cptr = R_GlobalContext;
	while (cptr != NULL) {
	    if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)
		break;
	    cptr = cptr->nextcontext;
	}
	if (cptr == NULL)
	    error(_("UseMethod called from outside a closure"));
	/* if (generic == R_MissingArg)
	   PROTECT(generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))))); */
	PROTECT(obj = GetObject(cptr));
    }
 
    if (TYPEOF(generic) != STRSXP ||
	LENGTH(generic) < 1 ||
	strlen(CHAR(STRING_ELT(generic, 0))) == 0)
	errorcall(call, _("first argument must be a generic name"));
 
    if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),
		  env, callenv, defenv, &ans) == 1) {
	UNPROTECT(1);
	PROTECT(ans);
	findcontext(CTXT_RETURN, env, ans);
	UNPROTECT(1);
    }
    else
	error(_("no applicable method for \"%s\""), 
	      CHAR(STRING_ELT(generic, 0)));
    return R_NilValue; /* NOT Used */
}
 
/*
   fixcall: fixes up the call when arguments to the function may

	if (cptr->callflag & CTXT_FUNCTION && cptr->cloenv == sysp)
	    break;
	cptr = cptr->nextcontext;
    }
    if (cptr == NULL)
	error(_("NextMethod called from outside a function"));
 
    PROTECT(newcall = duplicate(cptr->call));
 
    /* eg get("print.ts")(1) */
    if (TYPEOF(CAR(cptr->call)) == LANGSXP)
       error(_("NextMethod called from an anonymous function"));
 
    /* Find dispatching environments. Promises shouldn't occur, but
       check to be on the safe side.  If the variables are not in the
       environment (the method was called outside a method dispatch)
       then chose reasonable defaults. */

    /* set up the arglist */
    s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);
    if (TYPEOF(s) == PROMSXP)  /* looks like R_LookupMethod just did this */
	s = eval(s, env);
    if (TYPEOF(s) == SYMSXP && s == R_UnboundValue) 
	error(_("No calling generic was found: was a method called directly?"));
    if (TYPEOF(s) != CLOSXP){
	errorcall(R_NilValue, _("'function' is not a function, but of type %d"), 
		  TYPEOF(s));
    }
    /* get formals and actuals; attach the names of the formals to
       the actuals, expanding any ... that occurs */
    formals = FORMALS(s);

	    PROTECT(matchedarg = s);
	    newcall = fixcall(newcall, matchedarg);
	}
    }
    else
	errorcall(call, _("wrong argument ..."));
 
    /*
      .Class is used to determine the next method; if it doesn't
      exist the first argument to the current method is used
      the second argument to NextMethod is another option but

			    install(".Class"), TRUE);
 
    if (class == R_UnboundValue) {
	s = GetObject(cptr);
	if (!isObject(s))
	    errorcall(call, _("object not specified"));
	class = getAttrib(s, R_ClassSymbol);
    }
 
    /* the generic comes from either the sysparent or it's named */
    generic = findVarInFrame3(R_GlobalContext->sysparent,
			      install(".Generic"), TRUE);
    if (generic == R_UnboundValue)
	generic = eval(CAR(args), env);
    if( generic == R_NilValue )
	errorcall(call, _("generic function not specified"));
    PROTECT(generic);
 
    if (!isString(generic) || length(generic) > 1)
	errorcall(call, _("invalid generic argument to NextMethod"));
 
    if (strlen(CHAR(STRING_ELT(generic, 0))) == 0)
	errorcall(call, _("generic function not specified"));
 
    /* determine whether we are in a Group dispatch */
 
    group = findVarInFrame3(R_GlobalContext->sysparent,install(".Group"), TRUE);
    if (group == R_UnboundValue){

    }
    else
	PROTECT(group);
 
    if (!isString(group) || length(group) > 1)
	errorcall(call, _("invalid 'group' argument found in NextMethod"));
 
    /* determine the root: either the group or the generic will be it */
 
    if( strlen(CHAR(STRING_ELT(group, 0))) == 0 )
	basename = generic;

    /* if t is R_UnboundValue then we called the current method directly */
 
    method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);
    if( method != R_UnboundValue) {
	if( !isString(method) )
	    error(_("Wrong value for .Method"));
	for( i = 0; i < length(method); i++ ) {
	if(strlen(CHAR(STRING_ELT(method, i))) >= 512)
	    error(_("method name too long in %s"),
		  CHAR(STRING_ELT(method, i)));
	  sprintf(b, "%s", CHAR(STRING_ELT(method, i)));
	  if( strlen(b) )
	    break;
	}
	/* for binary operators check that the second argument's method
	   is the same or absent */
	for(j = i; j < length(method); j++){
	if(strlen(CHAR(STRING_ELT(method, j))) >= 512)
	    error(_("method name too long in %s"),
		  CHAR(STRING_ELT(method, j)));
	  sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));
	  if (strlen(bb) && strcmp(b,bb))
	      warning(_("Incompatible methods ignored"));
	}
    }
    else {
	if(strlen(CHAR(PRINTNAME(CAR(cptr->call)))) >= 512)
	   error(_("call name too long in %s"),
		 CHAR(PRINTNAME(CAR(cptr->call))));
      sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));
    }
 
    for (j = 0; j < length(class); j++) {
	if(strlen(CHAR(STRING_ELT(basename, 0))) + 
	   strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)
	    error(_("class name too long in %s"),
		  CHAR(STRING_ELT(basename, 0)));
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),
		CHAR(STRING_ELT(class, j)));
	if ( !strcmp(buf, b) )
	    break;
    }

    /* we need the value of i on exit from the for loop to figure out
	   how many classes to drop. */
    for (i = j ; i < length(class); i++) {
	if(strlen(CHAR(STRING_ELT(generic, 0))) + 
	   strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
	    error(_("class name too long in %s"),
		  CHAR(STRING_ELT(generic, 0)));
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),
		CHAR(STRING_ELT(class, i)));
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
	if (TYPEOF(nextfun) == PROMSXP)
	    nextfun = eval(nextfun, env);

	    t = install(CHAR(STRING_ELT(generic, 0)));
	    nextfun = findVar(t,env);
	    if (TYPEOF(nextfun)==PROMSXP)
		nextfun = eval(nextfun, env);
	    if (!isFunction(nextfun))
		error(_("No method to invoke"));
	    if (TYPEOF(nextfun) == CLOSXP) {
		if (INTERNAL(t) != R_NilValue)
		    nextfun = INTERNAL(t);
		else
		    error(_("No method to invoke"));
	    }
	}
    }
    PROTECT(s = allocVector(STRSXP, length(class) - i));
    PROTECT(class = duplicate(class));

SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    switch(TYPEOF(CAR(args))) {
    case ENVSXP:
	errorcall(call, _("cannot unclass an environment"));
	break;
    case EXTPTRSXP:
	errorcall(call, _("cannot unclass an external pointer"));
	break;
    default:
	break;
    }
    if (isObject(CAR(args))) {

    class = R_data_class(x, FALSE);
    nclass = length(class);
 
    what = CADR(args);
    if( !isString(what) )
	errorcall(call, _("'what' must be a character vector"));
    nwhat = length(what);
 
    which = CADDR(args);
    if( !isLogical(which) || (length(which) != 1) )
	errorcall(call, _("'which' must be a length 1 logical vector"));
    isvec = asLogical(which);
 
    if( isvec )
	rval = allocVector(INTSXP, nwhat);
 

	}
	fun = R_UnboundValue;
    }
    fun = SYMVALUE(symbol);
    if(fun == R_UnboundValue)
	error(_("Unable to find a non-generic version of function \"%s\""),
	      CHAR(asChar(name)));
    cptr = R_GlobalContext;
    /* check this is the right context */
    while (cptr != R_ToplevelContext) {
	if (cptr->callflag & CTXT_FUNCTION )

 
SEXP do_standardGeneric(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP arg, value, fdef; R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr();
    if(!ptr) {
	warning(_("standardGeneric called without methods dispatch enabled (will be ignored)"));
	R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);
	ptr = R_get_standardGeneric_ptr();
    }
    PROTECT(args);
    PROTECT(arg = CAR(args));
    if(!isValidStringF(arg))
      error(_("Argument to standardGeneric must be a non-empty character string"));
 
    PROTECT(fdef = get_this_generic(args));
 
    if(isNull(fdef))
      error(_("Call to standardGeneric(\"%s\") apparently not from the body of that generic function"), CHAR(STRING_ELT(arg, 0)));
 
    value = (*ptr)(arg, env, fdef);
 
    UNPROTECT(3);
    return value;

SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,
		       SEXP mlist)
{
    char *code_string;
    if(!isValidString(code_vec))
	error(_("Argument 'code' must be a character string"));
    code_string = CHAR(asChar(code_vec));
    do_set_prim_method(op, code_string, fundef, mlist);
    return(fname);
}
 

	break;
    default:
	errorcase = TRUE;
    }
    if(errorcase) {
	error(_("Invalid primitive methods code (\"%s\"): should be \"clear\", \"reset\", \"set\", or \"suppress\""), code_string);
	return R_NilValue;
    }
    switch(TYPEOF(op)) {
    case BUILTINSXP: case SPECIALSXP:
	offset = PRIMOFFSET(op);
	break;
    default:
	error(_("Invalid object: must be a primitive function"));
    }
    if(offset >= maxMethodsOffset) {
	int n;
	n = offset + 1;
	if(n < DEFAULT_N_PRIM_METHODS)

	prim_generics[offset] = 0;
	prim_mlist[offset] = 0;
    }
    else if(fundef && !isNull(fundef) && !prim_generics[offset]) {
	if(TYPEOF(fundef) != CLOSXP)
	    error(_("The formal definition of a primitive generic must be a function object (got type %s)"),
		  type2str(TYPEOF(fundef)));
	R_PreserveObject(fundef);
	prim_generics[offset] = fundef;
    }
    if(code==HAS_METHODS) {

    SEXP fundef, value, mlist=R_NilValue; 
    int offset; 
    prim_methods_t current;
    offset = PRIMOFFSET(op);
    if(offset < 0 || offset > curMaxOffset)
	error(_("Invalid primitive operation given for dispatch"));
    current = prim_methods[offset];
    if(current == NO_METHODS || current == SUPPRESSED)
	return(NULL);
    /* check that the methods for this function have been set */
    if(current == NEEDS_RESET) {

	    return applyClosure(call, value, args, rho, R_NilValue);
	/* else, need to perform full method search */
    }
    fundef = prim_generics[offset];
    if(!fundef || TYPEOF(fundef) != CLOSXP)
	error(_("primitive function \"%s\" has been set for methods but no  generic function supplied"),
	      PRIMNAME(op));
    /* To do:  arrange for the setting to be restored in case of an
       error in method search */
    value = applyClosure(call, fundef, args, rho, R_NilValue);
    prim_methods[offset] = current;

SEXP R_do_MAKE_CLASS( char *what)
{
    static SEXP s_getClass = NULL;
    SEXP e, call;
    if(!what)
	error(_("C level MAKE_CLASS macro called with NULL string pointer"));
    if(!s_getClass)
	s_getClass = Rf_install("getClass");
    PROTECT(call = allocVector(LANGSXP, 2));
    SETCAR(call, s_getClass);
    SETCAR(CDR(call), mkString(what));

	s_virtual = Rf_install("virtual");
	s_prototype = Rf_install("prototype");
	s_className = Rf_install("className");
    }
    if(!class_def)
	error(_("C level NEW macro called with null class definition pointer"));
    e = R_do_slot(class_def, s_virtual);
    if(asLogical(e) != 0)  { /* includes NA, TRUE, or anything other than FALSE */
	e = R_do_slot(class_def, s_className);
	error(_("Trying to generate an object in C from a virtual class (\"%s\")"),
	      CHAR(asChar(e)));
    }
    e = R_do_slot(class_def, s_className);
    value = duplicate(R_do_slot(class_def, s_prototype));
    setAttrib(value, R_ClassSymbol, e);

Rev 32380	Rev 32867
Line 40...	Line 40...
40		40
41	`if ( TYPEOF(CAR(funcall)) == SYMSXP )`	41	`if ( TYPEOF(CAR(funcall)) == SYMSXP )`
42	`PROTECT(b = findFun(CAR(funcall), sysp));`	42	`PROTECT(b = findFun(CAR(funcall), sysp));`
43	`else`	43	`else`
44	`PROTECT(b = eval(CAR(funcall), sysp));`	44	`PROTECT(b = eval(CAR(funcall), sysp));`
45	`/**** use R_sysfunction here insteas */`	45	`/**** use R_sysfunction here instead */`
46	`if (TYPEOF(b) != CLOSXP) error("non-closure generic function");`	46	`if (TYPEOF(b) != CLOSXP) error(_("generic 'function' is not a function"));`
47	`formals = FORMALS(b);`	47	`formals = FORMALS(b);`
48		48
49	`tag = TAG(formals);`	49	`tag = TAG(formals);`
50	`if (tag != R_NilValue && tag != R_DotsSymbol) {`	50	`if (tag != R_NilValue && tag != R_DotsSymbol) {`
51	`s = R_NilValue;`	51	`s = R_NilValue;`
52	`/ exact matches /`	52	`/ exact matches /`
53	`for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))`	53	`for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))`
54	`if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {`	54	`if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {`
55	`if ( s != R_NilValue)`	55	`if ( s != R_NilValue)`
56	`error("formal argument \"%s\" matched by multiple actual arguments", tag);`	56	`error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);`
57	`else`	57	`else`
58	`s = CAR(b);`	58	`s = CAR(b);`
59	`}`	59	`}`
60		60
61	`if ( s == R_NilValue )`	61	`if ( s == R_NilValue )`
62	`/ partial matches /`	62	`/ partial matches /`
63	`for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))`	63	`for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))`
64	`if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {`	64	`if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {`
65	`if ( s != R_NilValue)`	65	`if ( s != R_NilValue)`
66	`error("formal argument \"%s\" matched by multiple actual arguments", tag);`	66	`error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);`
67	`else`	67	`else`
68	`s = CAR(b);`	68	`s = CAR(b);`
69	`}`	69	`}`
70	`if ( s == R_NilValue )`	70	`if ( s == R_NilValue )`
71	`/ first untagged argument /`	71	`/ first untagged argument /`
Line 172...	Line 172...
172	`{`	172	`{`
173	`SEXP val;`	173	`SEXP val;`
174		174
175	`if (R_UseNamespaceDispatch) {`	175	`if (R_UseNamespaceDispatch) {`
176	`if (TYPEOF(callrho) != ENVSXP && callrho != R_NilValue)`	176	`if (TYPEOF(callrho) != ENVSXP && callrho != R_NilValue)`
177	`error("bad generic call environment");`	177	`error(_("bad generic call environment"));`
178	`if (TYPEOF(defrho) != ENVSXP && defrho != R_NilValue)`	178	`if (TYPEOF(defrho) != ENVSXP && defrho != R_NilValue)`
179	`error("bad generic definition environment");`	179	`error(_("bad generic definition environment"));`
180	`if (defrho == R_NilValue)`	180	`if (defrho == R_NilValue)`
181	`defrho = R_BaseNamespace;`	181	`defrho = R_BaseNamespace;`
182		182
183	`val = findVar(method, callrho);`	183	`val = findVar(method, callrho);`
184	`if (TYPEOF(val)==PROMSXP)`	184	`if (TYPEOF(val)==PROMSXP)`
Line 220...	Line 220...
220		220
221	`/* Get the context which UseMethod was called from. */`	221	`/* Get the context which UseMethod was called from. */`
222		222
223	`cptr = R_GlobalContext;`	223	`cptr = R_GlobalContext;`
224	`if ( !(cptr->callflag & CTXT_FUNCTION) \|\| cptr->cloenv != rho)`	224	`if ( !(cptr->callflag & CTXT_FUNCTION) \|\| cptr->cloenv != rho)`
225	`error("UseMethod used in an inappropriate fashion");`	225	`error(_("UseMethod used in an inappropriate fashion"));`
226		226
227	`/* Create a new environment without any */`	227	`/* Create a new environment without any */`
228	`/* of the formals to the generic in it. */`	228	`/* of the formals to the generic in it. */`
229		229
230	`PROTECT(newrho = allocSExp(ENVSXP));`	230	`PROTECT(newrho = allocSExp(ENVSXP));`
Line 243...	Line 243...
243	`case BUILTINSXP:`	243	`case BUILTINSXP:`
244	`case SPECIALSXP:`	244	`case SPECIALSXP:`
245	`PROTECT(op);`	245	`PROTECT(op);`
246	`break;`	246	`break;`
247	`default:`	247	`default:`
248	`error("Invalid generic function in usemethod");`	248	`error(_("Invalid generic function in usemethod"));`
249	`}`	249	`}`
250		250
251	`if (TYPEOF(op) == CLOSXP) {`	251	`if (TYPEOF(op) == CLOSXP) {`
252	`formals = FORMALS(op);`	252	`formals = FORMALS(op);`
253	`for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {`	253	`for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {`
Line 265...	Line 265...
265		265
266	`PROTECT(class = R_data_class2(obj));`	266	`PROTECT(class = R_data_class2(obj));`
267	`nclass = length(class);`	267	`nclass = length(class);`
268	`for (i = 0; i < nclass; i++) {`	268	`for (i = 0; i < nclass; i++) {`
269	`if(strlen(generic) + strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`	269	`if(strlen(generic) + strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`
270	`error("class name too long in %s", generic);`	270	`error(_("class name too long in %s"), generic);`
271	`sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));`	271	`sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));`
272	`method = install(buf);`	272	`method = install(buf);`
273	`sxp = R_LookupMethod(method, rho, callrho, defrho);`	273	`sxp = R_LookupMethod(method, rho, callrho, defrho);`
274	`/* autoloading requires that promises be evaluated <TSL>*/`	274	`/* autoloading requires that promises be evaluated <TSL>*/`
275	`if (TYPEOF(sxp) == PROMSXP){`	275	`if (TYPEOF(sxp) == PROMSXP){`
Line 304...	Line 304...
304	`UNPROTECT(5);`	304	`UNPROTECT(5);`
305	`return 1;`	305	`return 1;`
306	`}`	306	`}`
307	`}`	307	`}`
308	`if(strlen(generic) + strlen("default") + 2 > 512)`	308	`if(strlen(generic) + strlen("default") + 2 > 512)`
309	`error("class name too long in %s", generic);`	309	`error(_("class name too long in %s"), generic);`
310	`sprintf(buf, "%s.default", generic);`	310	`sprintf(buf, "%s.default", generic);`
311	`method = install(buf);`	311	`method = install(buf);`
312	`sxp = R_LookupMethod(method, rho, callrho, defrho);`	312	`sxp = R_LookupMethod(method, rho, callrho, defrho);`
313	`if (TYPEOF(sxp) == PROMSXP)`	313	`if (TYPEOF(sxp) == PROMSXP)`
314	`sxp = eval(sxp, rho);`	314	`sxp = eval(sxp, rho);`
Line 347...	Line 347...
347	`RCNTXT *cptr;`	347	`RCNTXT *cptr;`
348		348
349	`nargs = length(args);`	349	`nargs = length(args);`
350		350
351	`if (nargs < 0)`	351	`if (nargs < 0)`
352	`errorcall(call, "corrupt internals!");`	352	`errorcall(call, _("corrupt internals!"));`
353		353
354	`/* get environments needed for dispatching.`	354	`/* get environments needed for dispatching.`
355	`callenv = environment from which the generic was called`	355	`callenv = environment from which the generic was called`
356	`defenv = environment where the generic was defined */`	356	`defenv = environment where the generic was defined */`
357	`cptr = R_GlobalContext;`	357	`cptr = R_GlobalContext;`
358	`if ( !(cptr->callflag & CTXT_FUNCTION) \|\| cptr->cloenv != env)`	358	`if ( !(cptr->callflag & CTXT_FUNCTION) \|\| cptr->cloenv != env)`
359	`error("UseMethod used in an inappropriate fashion");`	359	`error(_("UseMethod used in an inappropriate fashion"));`
360	`callenv = cptr->sysparent;`	360	`callenv = cptr->sysparent;`
361	`defenv = TYPEOF(env) == ENVSXP ? ENCLOS(env) : R_NilValue;`	361	`defenv = TYPEOF(env) == ENVSXP ? ENCLOS(env) : R_NilValue;`
362		362
363	`if (nargs)`	363	`if (nargs)`
364	`PROTECT(generic = eval(CAR(args), env));`	364	`PROTECT(generic = eval(CAR(args), env));`
365	`else`	365	`else`
366	`errorcall(call, "There must be a first argument");`	366	`errorcall(call, _("There must be a first argument"));`
367		367
368	`if (nargs > 2) /* R-lang says there should be a warning */`	368	`if (nargs > 2) /* R-lang says there should be a warning */`
369	`warningcall(call, "Arguments after the first two are ignored");`	369	`warningcall(call, _("Arguments after the first two are ignored"));`
370	`if (nargs >= 2)`	370	`if (nargs >= 2)`
371	`PROTECT(obj = eval(CADR(args), env));`	371	`PROTECT(obj = eval(CADR(args), env));`
372	`else {`	372	`else {`
373	`cptr = R_GlobalContext;`	373	`cptr = R_GlobalContext;`
374	`while (cptr != NULL) {`	374	`while (cptr != NULL) {`
375	`if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)`	375	`if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)`
376	`break;`	376	`break;`
377	`cptr = cptr->nextcontext;`	377	`cptr = cptr->nextcontext;`
378	`}`	378	`}`
379	`if (cptr == NULL)`	379	`if (cptr == NULL)`
380	`error("UseMethod called from outside a closure");`	380	`error(_("UseMethod called from outside a closure"));`
381	`/* if (generic == R_MissingArg)`	381	`/* if (generic == R_MissingArg)`
382	`PROTECT(generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))))); */`	382	`PROTECT(generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))))); */`
383	`PROTECT(obj = GetObject(cptr));`	383	`PROTECT(obj = GetObject(cptr));`
384	`}`	384	`}`
385		385
386	`if (TYPEOF(generic) != STRSXP \|\|`	386	`if (TYPEOF(generic) != STRSXP \|\|`
387	`LENGTH(generic) < 1 \|\|`	387	`LENGTH(generic) < 1 \|\|`
388	`strlen(CHAR(STRING_ELT(generic, 0))) == 0)`	388	`strlen(CHAR(STRING_ELT(generic, 0))) == 0)`
389	`errorcall(call, "first argument must be a generic name");`	389	`errorcall(call, _("first argument must be a generic name"));`
390		390
391	`if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),`	391	`if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),`
392	`env, callenv, defenv, &ans) == 1) {`	392	`env, callenv, defenv, &ans) == 1) {`
393	`UNPROTECT(1);`	393	`UNPROTECT(1);`
394	`PROTECT(ans);`	394	`PROTECT(ans);`
395	`findcontext(CTXT_RETURN, env, ans);`	395	`findcontext(CTXT_RETURN, env, ans);`
396	`UNPROTECT(1);`	396	`UNPROTECT(1);`
397	`}`	397	`}`
398	`else`	398	`else`
399	`error("no applicable method for \"%s\"", CHAR(STRING_ELT(generic, 0)));`	399	`error(_("no applicable method for \"%s\""),`
-		400	`CHAR(STRING_ELT(generic, 0)));`
400	`return R_NilValue; /* NOT Used */`	401	`return R_NilValue; /* NOT Used */`
401	`}`	402	`}`
402		403
403	`/*`	404	`/*`
404	`fixcall: fixes up the call when arguments to the function may`	405	`fixcall: fixes up the call when arguments to the function may`
Line 453...	Line 454...
453	`if (cptr->callflag & CTXT_FUNCTION && cptr->cloenv == sysp)`	454	`if (cptr->callflag & CTXT_FUNCTION && cptr->cloenv == sysp)`
454	`break;`	455	`break;`
455	`cptr = cptr->nextcontext;`	456	`cptr = cptr->nextcontext;`
456	`}`	457	`}`
457	`if (cptr == NULL)`	458	`if (cptr == NULL)`
458	`error("NextMethod called from outside a closure");`	459	`error(_("NextMethod called from outside a function"));`
459		460
460	`PROTECT(newcall = duplicate(cptr->call));`	461	`PROTECT(newcall = duplicate(cptr->call));`
461		462
462	`/* eg get("print.ts")(1) */`	463	`/* eg get("print.ts")(1) */`
463	`if (TYPEOF(CAR(cptr->call)) == LANGSXP)`	464	`if (TYPEOF(CAR(cptr->call)) == LANGSXP)`
464	`error("NextMethod called from anonymous function");`	465	`error(_("NextMethod called from an anonymous function"));`
465		466
466	`/* Find dispatching environments. Promises shouldn't occur, but`	467	`/* Find dispatching environments. Promises shouldn't occur, but`
467	`check to be on the safe side. If the variables are not in the`	468	`check to be on the safe side. If the variables are not in the`
468	`environment (the method was called outside a method dispatch)`	469	`environment (the method was called outside a method dispatch)`
469	`then chose reasonable defaults. */`	470	`then chose reasonable defaults. */`
Line 489...	Line 490...
489	`/* set up the arglist */`	490	`/* set up the arglist */`
490	`s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);`	491	`s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);`
491	`if (TYPEOF(s) == PROMSXP) /* looks like R_LookupMethod just did this */`	492	`if (TYPEOF(s) == PROMSXP) /* looks like R_LookupMethod just did this */`
492	`s = eval(s, env);`	493	`s = eval(s, env);`
493	`if (TYPEOF(s) == SYMSXP && s == R_UnboundValue)`	494	`if (TYPEOF(s) == SYMSXP && s == R_UnboundValue)`
494	`error("No calling generic was found: was a method called directly?");`	495	`error(_("No calling generic was found: was a method called directly?"));`
495	`if (TYPEOF(s) != CLOSXP){`	496	`if (TYPEOF(s) != CLOSXP){`
496	`errorcall(R_NilValue, "function is not a closure, but of type %d",`	497	`errorcall(R_NilValue, _("'function' is not a function, but of type %d"),`
497	`TYPEOF(s));`	498	`TYPEOF(s));`
498	`}`	499	`}`
499	`/* get formals and actuals; attach the names of the formals to`	500	`/* get formals and actuals; attach the names of the formals to`
500	`the actuals, expanding any ... that occurs */`	501	`the actuals, expanding any ... that occurs */`
501	`formals = FORMALS(s);`	502	`formals = FORMALS(s);`
Line 567...	Line 568...
567	`PROTECT(matchedarg = s);`	568	`PROTECT(matchedarg = s);`
568	`newcall = fixcall(newcall, matchedarg);`	569	`newcall = fixcall(newcall, matchedarg);`
569	`}`	570	`}`
570	`}`	571	`}`
571	`else`	572	`else`
572	`errorcall(call,"wrong argument ...");`	573	`errorcall(call, _("wrong argument ..."));`
573		574
574	`/*`	575	`/*`
575	`.Class is used to determine the next method; if it doesn't`	576	`.Class is used to determine the next method; if it doesn't`
576	`exist the first argument to the current method is used`	577	`exist the first argument to the current method is used`
577	`the second argument to NextMethod is another option but`	578	`the second argument to NextMethod is another option but`
Line 581...	Line 582...
581	`install(".Class"), TRUE);`	582	`install(".Class"), TRUE);`
582		583
583	`if (class == R_UnboundValue) {`	584	`if (class == R_UnboundValue) {`
584	`s = GetObject(cptr);`	585	`s = GetObject(cptr);`
585	`if (!isObject(s))`	586	`if (!isObject(s))`
586	`errorcall(call, "object not specified");`	587	`errorcall(call, _("object not specified"));`
587	`class = getAttrib(s, R_ClassSymbol);`	588	`class = getAttrib(s, R_ClassSymbol);`
588	`}`	589	`}`
589		590
590	`/* the generic comes from either the sysparent or it's named */`	591	`/* the generic comes from either the sysparent or it's named */`
591	`generic = findVarInFrame3(R_GlobalContext->sysparent,`	592	`generic = findVarInFrame3(R_GlobalContext->sysparent,`
592	`install(".Generic"), TRUE);`	593	`install(".Generic"), TRUE);`
593	`if (generic == R_UnboundValue)`	594	`if (generic == R_UnboundValue)`
594	`generic = eval(CAR(args), env);`	595	`generic = eval(CAR(args), env);`
595	`if( generic == R_NilValue )`	596	`if( generic == R_NilValue )`
596	`errorcall(call,"generic function not specified");`	597	`errorcall(call, _("generic function not specified"));`
597	`PROTECT(generic);`	598	`PROTECT(generic);`
598		599
599	`if (!isString(generic) \|\| length(generic) > 1)`	600	`if (!isString(generic) \|\| length(generic) > 1)`
600	`errorcall(call,"invalid generic argument to NextMethod");`	601	`errorcall(call, _("invalid generic argument to NextMethod"));`
601		602
602	`if (strlen(CHAR(STRING_ELT(generic, 0))) == 0)`	603	`if (strlen(CHAR(STRING_ELT(generic, 0))) == 0)`
603	`errorcall(call,"generic function not specified");`	604	`errorcall(call, _("generic function not specified"));`
604		605
605	`/* determine whether we are in a Group dispatch */`	606	`/* determine whether we are in a Group dispatch */`
606		607
607	`group = findVarInFrame3(R_GlobalContext->sysparent,install(".Group"), TRUE);`	608	`group = findVarInFrame3(R_GlobalContext->sysparent,install(".Group"), TRUE);`
608	`if (group == R_UnboundValue){`	609	`if (group == R_UnboundValue){`
Line 610...	Line 611...
610	`}`	611	`}`
611	`else`	612	`else`
612	`PROTECT(group);`	613	`PROTECT(group);`
613		614
614	`if (!isString(group) \|\| length(group) > 1)`	615	`if (!isString(group) \|\| length(group) > 1)`
615	`errorcall(call, "invalid group argument found in NextMethod");`	616	`errorcall(call, _("invalid 'group' argument found in NextMethod"));`
616		617
617	`/* determine the root: either the group or the generic will be it */`	618	`/* determine the root: either the group or the generic will be it */`
618		619
619	`if( strlen(CHAR(STRING_ELT(group, 0))) == 0 )`	620	`if( strlen(CHAR(STRING_ELT(group, 0))) == 0 )`
620	`basename = generic;`	621	`basename = generic;`
Line 627...	Line 628...
627	`/* if t is R_UnboundValue then we called the current method directly */`	628	`/* if t is R_UnboundValue then we called the current method directly */`
628		629
629	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`	630	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`
630	`if( method != R_UnboundValue) {`	631	`if( method != R_UnboundValue) {`
631	`if( !isString(method) )`	632	`if( !isString(method) )`
632	`error("Wrong value for .Method");`	633	`error(_("Wrong value for .Method"));`
633	`for( i = 0; i < length(method); i++ ) {`	634	`for( i = 0; i < length(method); i++ ) {`
634	`if(strlen(CHAR(STRING_ELT(method, i))) >= 512)`	635	`if(strlen(CHAR(STRING_ELT(method, i))) >= 512)`
635	`error("method name too long in %s", CHAR(STRING_ELT(method, i)));`	636	`error(_("method name too long in %s"),`
-		637	`CHAR(STRING_ELT(method, i)));`
636	`sprintf(b, "%s", CHAR(STRING_ELT(method, i)));`	638	`sprintf(b, "%s", CHAR(STRING_ELT(method, i)));`
637	`if( strlen(b) )`	639	`if( strlen(b) )`
638	`break;`	640	`break;`
639	`}`	641	`}`
640	`/* for binary operators check that the second argument's method`	642	`/* for binary operators check that the second argument's method`
641	`is the same or absent */`	643	`is the same or absent */`
642	`for(j = i; j < length(method); j++){`	644	`for(j = i; j < length(method); j++){`
643	`if(strlen(CHAR(STRING_ELT(method, j))) >= 512)`	645	`if(strlen(CHAR(STRING_ELT(method, j))) >= 512)`
644	`error("method name too long in %s", CHAR(STRING_ELT(method, j)));`	646	`error(_("method name too long in %s"),`
-		647	`CHAR(STRING_ELT(method, j)));`
645	`sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));`	648	`sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));`
646	`if (strlen(bb) && strcmp(b,bb))`	649	`if (strlen(bb) && strcmp(b,bb))`
647	`warning("Incompatible methods ignored");`	650	`warning(_("Incompatible methods ignored"));`
648	`}`	651	`}`
649	`}`	652	`}`
650	`else {`	653	`else {`
651	`if(strlen(CHAR(PRINTNAME(CAR(cptr->call)))) >= 512)`	654	`if(strlen(CHAR(PRINTNAME(CAR(cptr->call)))) >= 512)`
-		655	`error(_("call name too long in %s"),`
652	`error("call name too long in %s", CHAR(PRINTNAME(CAR(cptr->call))));`	656	`CHAR(PRINTNAME(CAR(cptr->call))));`
653	`sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));`	657	`sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));`
654	`}`	658	`}`
655		659
656	`for (j = 0; j < length(class); j++) {`	660	`for (j = 0; j < length(class); j++) {`
657	`if(strlen(CHAR(STRING_ELT(basename, 0))) +`	661	`if(strlen(CHAR(STRING_ELT(basename, 0))) +`
658	`strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)`	662	`strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)`
659	`error("class name too long in %s", CHAR(STRING_ELT(basename, 0)));`	663	`error(_("class name too long in %s"),`
-		664	`CHAR(STRING_ELT(basename, 0)));`
660	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),`	665	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),`
661	`CHAR(STRING_ELT(class, j)));`	666	`CHAR(STRING_ELT(class, j)));`
662	`if ( !strcmp(buf, b) )`	667	`if ( !strcmp(buf, b) )`
663	`break;`	668	`break;`
664	`}`	669	`}`
Line 671...	Line 676...
671	`/* we need the value of i on exit from the for loop to figure out`	676	`/* we need the value of i on exit from the for loop to figure out`
672	`how many classes to drop. */`	677	`how many classes to drop. */`
673	`for (i = j ; i < length(class); i++) {`	678	`for (i = j ; i < length(class); i++) {`
674	`if(strlen(CHAR(STRING_ELT(generic, 0))) +`	679	`if(strlen(CHAR(STRING_ELT(generic, 0))) +`
675	`strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`	680	`strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`
676	`error("class name too long in %s", CHAR(STRING_ELT(generic, 0)));`	681	`error(_("class name too long in %s"),`
-		682	`CHAR(STRING_ELT(generic, 0)));`
677	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),`	683	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),`
678	`CHAR(STRING_ELT(class, i)));`	684	`CHAR(STRING_ELT(class, i)));`
679	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`	685	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`
680	`if (TYPEOF(nextfun) == PROMSXP)`	686	`if (TYPEOF(nextfun) == PROMSXP)`
681	`nextfun = eval(nextfun, env);`	687	`nextfun = eval(nextfun, env);`
Line 703...	Line 709...
703	`t = install(CHAR(STRING_ELT(generic, 0)));`	709	`t = install(CHAR(STRING_ELT(generic, 0)));`
704	`nextfun = findVar(t,env);`	710	`nextfun = findVar(t,env);`
705	`if (TYPEOF(nextfun)==PROMSXP)`	711	`if (TYPEOF(nextfun)==PROMSXP)`
706	`nextfun = eval(nextfun, env);`	712	`nextfun = eval(nextfun, env);`
707	`if (!isFunction(nextfun))`	713	`if (!isFunction(nextfun))`
708	`error("No method to invoke");`	714	`error(_("No method to invoke"));`
709	`if (TYPEOF(nextfun) == CLOSXP) {`	715	`if (TYPEOF(nextfun) == CLOSXP) {`
710	`if (INTERNAL(t) != R_NilValue)`	716	`if (INTERNAL(t) != R_NilValue)`
711	`nextfun = INTERNAL(t);`	717	`nextfun = INTERNAL(t);`
712	`else`	718	`else`
713	`error("No method to invoke");`	719	`error(_("No method to invoke"));`
714	`}`	720	`}`
715	`}`	721	`}`
716	`}`	722	`}`
717	`PROTECT(s = allocVector(STRSXP, length(class) - i));`	723	`PROTECT(s = allocVector(STRSXP, length(class) - i));`
718	`PROTECT(class = duplicate(class));`	724	`PROTECT(class = duplicate(class));`
Line 747...	Line 753...
747	`SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)`	753	`SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)`
748	`{`	754	`{`
749	`checkArity(op, args);`	755	`checkArity(op, args);`
750	`switch(TYPEOF(CAR(args))) {`	756	`switch(TYPEOF(CAR(args))) {`
751	`case ENVSXP:`	757	`case ENVSXP:`
752	`errorcall(call, "cannot unclass an environment");`	758	`errorcall(call, _("cannot unclass an environment"));`
753	`break;`	759	`break;`
754	`case EXTPTRSXP:`	760	`case EXTPTRSXP:`
755	`errorcall(call, "cannot unclass an external pointer");`	761	`errorcall(call, _("cannot unclass an external pointer"));`
756	`break;`	762	`break;`
757	`default:`	763	`default:`
758	`break;`	764	`break;`
759	`}`	765	`}`
760	`if (isObject(CAR(args))) {`	766	`if (isObject(CAR(args))) {`
Line 826...	Line 832...
826	`class = R_data_class(x, FALSE);`	832	`class = R_data_class(x, FALSE);`
827	`nclass = length(class);`	833	`nclass = length(class);`
828		834
829	`what = CADR(args);`	835	`what = CADR(args);`
830	`if( !isString(what) )`	836	`if( !isString(what) )`
831	`errorcall(call, "what must be a character vector");`	837	`errorcall(call, _("'what' must be a character vector"));`
832	`nwhat = length(what);`	838	`nwhat = length(what);`
833		839
834	`which = CADDR(args);`	840	`which = CADDR(args);`
835	`if( !isLogical(which) \|\| (length(which) != 1) )`	841	`if( !isLogical(which) \|\| (length(which) != 1) )`
836	`errorcall(call, "which must be a length 1 logical vector");`	842	`errorcall(call, _("'which' must be a length 1 logical vector"));`
837	`isvec = asLogical(which);`	843	`isvec = asLogical(which);`
838		844
839	`if( isvec )`	845	`if( isvec )`
840	`rval = allocVector(INTSXP, nwhat);`	846	`rval = allocVector(INTSXP, nwhat);`
841		847
Line 938...	Line 944...
938	`}`	944	`}`
939	`fun = R_UnboundValue;`	945	`fun = R_UnboundValue;`
940	`}`	946	`}`
941	`fun = SYMVALUE(symbol);`	947	`fun = SYMVALUE(symbol);`
942	`if(fun == R_UnboundValue)`	948	`if(fun == R_UnboundValue)`
943	`error("Unable to find a non-generic version of function \"%s\"",`	949	`error(_("Unable to find a non-generic version of function \"%s\""),`
944	`CHAR(asChar(name)));`	950	`CHAR(asChar(name)));`
945	`cptr = R_GlobalContext;`	951	`cptr = R_GlobalContext;`
946	`/* check this is the right context */`	952	`/* check this is the right context */`
947	`while (cptr != R_ToplevelContext) {`	953	`while (cptr != R_ToplevelContext) {`
948	`if (cptr->callflag & CTXT_FUNCTION )`	954	`if (cptr->callflag & CTXT_FUNCTION )`
Line 978...	Line 984...
978		984
979	`SEXP do_standardGeneric(SEXP call, SEXP op, SEXP args, SEXP env)`	985	`SEXP do_standardGeneric(SEXP call, SEXP op, SEXP args, SEXP env)`
980	`{`	986	`{`
981	`SEXP arg, value, fdef; R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr();`	987	`SEXP arg, value, fdef; R_stdGen_ptr_t ptr = R_get_standardGeneric_ptr();`
982	`if(!ptr) {`	988	`if(!ptr) {`
983	`warning("standardGeneric called without methods dispatch enabled (will be ignored)");`	989	`warning(_("standardGeneric called without methods dispatch enabled (will be ignored)"));`
984	`R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);`	990	`R_set_standardGeneric_ptr(dispatchNonGeneric, NULL);`
985	`ptr = R_get_standardGeneric_ptr();`	991	`ptr = R_get_standardGeneric_ptr();`
986	`}`	992	`}`
987	`PROTECT(args);`	993	`PROTECT(args);`
988	`PROTECT(arg = CAR(args));`	994	`PROTECT(arg = CAR(args));`
989	`if(!isValidStringF(arg))`	995	`if(!isValidStringF(arg))`
990	`error("Argument to standardGeneric must be a non-empty character string");`	996	`error(_("Argument to standardGeneric must be a non-empty character string"));`
991		997
992	`PROTECT(fdef = get_this_generic(args));`	998	`PROTECT(fdef = get_this_generic(args));`
993		999
994	`if(isNull(fdef))`	1000	`if(isNull(fdef))`
995	`error("Call to standardGeneric(\"%s\") apparently not from the body of that generic function", CHAR(STRING_ELT(arg, 0)));`	1001	`error(_("Call to standardGeneric(\"%s\") apparently not from the body of that generic function"), CHAR(STRING_ELT(arg, 0)));`
996		1002
997	`value = (*ptr)(arg, env, fdef);`	1003	`value = (*ptr)(arg, env, fdef);`
998		1004
999	`UNPROTECT(3);`	1005	`UNPROTECT(3);`
1000	`return value;`	1006	`return value;`
Line 1011...	Line 1017...
1011	`SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,`	1017	`SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,`
1012	`SEXP mlist)`	1018	`SEXP mlist)`
1013	`{`	1019	`{`
1014	`char *code_string;`	1020	`char *code_string;`
1015	`if(!isValidString(code_vec))`	1021	`if(!isValidString(code_vec))`
1016	`error("Argument \"code\" must be a character string");`	1022	`error(_("Argument 'code' must be a character string"));`
1017	`code_string = CHAR(asChar(code_vec));`	1023	`code_string = CHAR(asChar(code_vec));`
1018	`do_set_prim_method(op, code_string, fundef, mlist);`	1024	`do_set_prim_method(op, code_string, fundef, mlist);`
1019	`return(fname);`	1025	`return(fname);`
1020	`}`	1026	`}`
1021		1027
Line 1050...	Line 1056...
1050	`break;`	1056	`break;`
1051	`default:`	1057	`default:`
1052	`errorcase = TRUE;`	1058	`errorcase = TRUE;`
1053	`}`	1059	`}`
1054	`if(errorcase) {`	1060	`if(errorcase) {`
1055	`error("Invalid primitive methods code (\"%s\"): should be \"clear\", \"reset\", \"set\", or \"suppress\"", code_string);`	1061	`error(_("Invalid primitive methods code (\"%s\"): should be \"clear\", \"reset\", \"set\", or \"suppress\""), code_string);`
1056	`return R_NilValue;`	1062	`return R_NilValue;`
1057	`}`	1063	`}`
1058	`switch(TYPEOF(op)) {`	1064	`switch(TYPEOF(op)) {`
1059	`case BUILTINSXP: case SPECIALSXP:`	1065	`case BUILTINSXP: case SPECIALSXP:`
1060	`offset = PRIMOFFSET(op);`	1066	`offset = PRIMOFFSET(op);`
1061	`break;`	1067	`break;`
1062	`default:`	1068	`default:`
1063	`error("Invalid object: must be a primitive function");`	1069	`error(_("Invalid object: must be a primitive function"));`
1064	`}`	1070	`}`
1065	`if(offset >= maxMethodsOffset) {`	1071	`if(offset >= maxMethodsOffset) {`
1066	`int n;`	1072	`int n;`
1067	`n = offset + 1;`	1073	`n = offset + 1;`
1068	`if(n < DEFAULT_N_PRIM_METHODS)`	1074	`if(n < DEFAULT_N_PRIM_METHODS)`
Line 1105...	Line 1111...
1105	`prim_generics[offset] = 0;`	1111	`prim_generics[offset] = 0;`
1106	`prim_mlist[offset] = 0;`	1112	`prim_mlist[offset] = 0;`
1107	`}`	1113	`}`
1108	`else if(fundef && !isNull(fundef) && !prim_generics[offset]) {`	1114	`else if(fundef && !isNull(fundef) && !prim_generics[offset]) {`
1109	`if(TYPEOF(fundef) != CLOSXP)`	1115	`if(TYPEOF(fundef) != CLOSXP)`
1110	`error("The formal definition of a primitive generic must be a function object (got type %s)",`	1116	`error(_("The formal definition of a primitive generic must be a function object (got type %s)"),`
1111	`type2str(TYPEOF(fundef)));`	1117	`type2str(TYPEOF(fundef)));`
1112	`R_PreserveObject(fundef);`	1118	`R_PreserveObject(fundef);`
1113	`prim_generics[offset] = fundef;`	1119	`prim_generics[offset] = fundef;`
1114	`}`	1120	`}`
1115	`if(code==HAS_METHODS) {`	1121	`if(code==HAS_METHODS) {`
Line 1219...	Line 1225...
1219	`SEXP fundef, value, mlist=R_NilValue;`	1225	`SEXP fundef, value, mlist=R_NilValue;`
1220	`int offset;`	1226	`int offset;`
1221	`prim_methods_t current;`	1227	`prim_methods_t current;`
1222	`offset = PRIMOFFSET(op);`	1228	`offset = PRIMOFFSET(op);`
1223	`if(offset < 0 \|\| offset > curMaxOffset)`	1229	`if(offset < 0 \|\| offset > curMaxOffset)`
1224	`error("Invalid primitive operation given for dispatch");`	1230	`error(_("Invalid primitive operation given for dispatch"));`
1225	`current = prim_methods[offset];`	1231	`current = prim_methods[offset];`
1226	`if(current == NO_METHODS \|\| current == SUPPRESSED)`	1232	`if(current == NO_METHODS \|\| current == SUPPRESSED)`
1227	`return(NULL);`	1233	`return(NULL);`
1228	`/* check that the methods for this function have been set */`	1234	`/* check that the methods for this function have been set */`
1229	`if(current == NEEDS_RESET) {`	1235	`if(current == NEEDS_RESET) {`
Line 1248...	Line 1254...
1248	`return applyClosure(call, value, args, rho, R_NilValue);`	1254	`return applyClosure(call, value, args, rho, R_NilValue);`
1249	`/* else, need to perform full method search */`	1255	`/* else, need to perform full method search */`
1250	`}`	1256	`}`
1251	`fundef = prim_generics[offset];`	1257	`fundef = prim_generics[offset];`
1252	`if(!fundef \|\| TYPEOF(fundef) != CLOSXP)`	1258	`if(!fundef \|\| TYPEOF(fundef) != CLOSXP)`
1253	`error("primitive function \"%s\" has been set for methods but no generic function supplied",`	1259	`error(_("primitive function \"%s\" has been set for methods but no generic function supplied"),`
1254	`PRIMNAME(op));`	1260	`PRIMNAME(op));`
1255	`/* To do: arrange for the setting to be restored in case of an`	1261	`/* To do: arrange for the setting to be restored in case of an`
1256	`error in method search */`	1262	`error in method search */`
1257	`value = applyClosure(call, fundef, args, rho, R_NilValue);`	1263	`value = applyClosure(call, fundef, args, rho, R_NilValue);`
1258	`prim_methods[offset] = current;`	1264	`prim_methods[offset] = current;`
Line 1265...	Line 1271...
1265	`SEXP R_do_MAKE_CLASS( char *what)`	1271	`SEXP R_do_MAKE_CLASS( char *what)`
1266	`{`	1272	`{`
1267	`static SEXP s_getClass = NULL;`	1273	`static SEXP s_getClass = NULL;`
1268	`SEXP e, call;`	1274	`SEXP e, call;`
1269	`if(!what)`	1275	`if(!what)`
1270	`error("C level MAKE_CLASS macro called with NULL string pointer");`	1276	`error(_("C level MAKE_CLASS macro called with NULL string pointer"));`
1271	`if(!s_getClass)`	1277	`if(!s_getClass)`
1272	`s_getClass = Rf_install("getClass");`	1278	`s_getClass = Rf_install("getClass");`
1273	`PROTECT(call = allocVector(LANGSXP, 2));`	1279	`PROTECT(call = allocVector(LANGSXP, 2));`
1274	`SETCAR(call, s_getClass);`	1280	`SETCAR(call, s_getClass);`
1275	`SETCAR(CDR(call), mkString(what));`	1281	`SETCAR(CDR(call), mkString(what));`
Line 1286...	Line 1292...
1286	`s_virtual = Rf_install("virtual");`	1292	`s_virtual = Rf_install("virtual");`
1287	`s_prototype = Rf_install("prototype");`	1293	`s_prototype = Rf_install("prototype");`
1288	`s_className = Rf_install("className");`	1294	`s_className = Rf_install("className");`
1289	`}`	1295	`}`
1290	`if(!class_def)`	1296	`if(!class_def)`
1291	`error("C level NEW macro called with null class definition pointer");`	1297	`error(_("C level NEW macro called with null class definition pointer"));`
1292	`e = R_do_slot(class_def, s_virtual);`	1298	`e = R_do_slot(class_def, s_virtual);`
1293	`if(asLogical(e) != 0) { /* includes NA, TRUE, or anything other than FALSE */`	1299	`if(asLogical(e) != 0) { /* includes NA, TRUE, or anything other than FALSE */`
1294	`e = R_do_slot(class_def, s_className);`	1300	`e = R_do_slot(class_def, s_className);`
1295	`error("Trying to generate an object in C from a virtual class (\"%s\")",`	1301	`error(_("Trying to generate an object in C from a virtual class (\"%s\")"),`
1296	`CHAR(asChar(e)));`	1302	`CHAR(asChar(e)));`
1297	`}`	1303	`}`
1298	`e = R_do_slot(class_def, s_className);`	1304	`e = R_do_slot(class_def, s_className);`
1299	`value = duplicate(R_do_slot(class_def, s_prototype));`	1305	`value = duplicate(R_do_slot(class_def, s_prototype));`
1300	`setAttrib(value, R_ClassSymbol, e);`	1306	`setAttrib(value, R_ClassSymbol, e);`

The R Project SVN R

(root)/trunk/src/main/objects.c @ 28362 – Rev 32380 → 32867