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



    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);

    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) {

    /* 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

    /* 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)

	    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));

	}
	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 )

	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) {

    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 32867	Rev 33297
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 361...	Line 361...
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) {`
Line 490...	Line 490...
490	`/* set up the arglist */`	490	`/* set up the arglist */`
491	`s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);`	491	`s = R_LookupMethod(CAR(cptr->call), env, callenv, defenv);`
492	`if (TYPEOF(s) == PROMSXP) /* looks like R_LookupMethod just did this */`	492	`if (TYPEOF(s) == PROMSXP) /* looks like R_LookupMethod just did this */`
493	`s = eval(s, env);`	493	`s = eval(s, env);`
494	`if (TYPEOF(s) == SYMSXP && s == R_UnboundValue)`	494	`if (TYPEOF(s) == SYMSXP && s == R_UnboundValue)`
495	`error(_("No calling generic was found: was a method called directly?"));`	495	`error(_("no calling generic was found: was a method called directly?"));`
496	`if (TYPEOF(s) != CLOSXP){`	496	`if (TYPEOF(s) != CLOSXP){`
497	`errorcall(R_NilValue, _("'function' is not a function, but of type %d"),`	497	`errorcall(R_NilValue, _("'function' is not a function, but of type %d"),`
498	`TYPEOF(s));`	498	`TYPEOF(s));`
499	`}`	499	`}`
500	`/* get formals and actuals; attach the names of the formals to`	500	`/* get formals and actuals; attach the names of the formals to`
Line 628...	Line 628...
628	`/* 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 */`
629		629
630	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`	630	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`
631	`if( method != R_UnboundValue) {`	631	`if( method != R_UnboundValue) {`
632	`if( !isString(method) )`	632	`if( !isString(method) )`
633	`error(_("Wrong value for .Method"));`	633	`error(_("wrong value for .Method"));`
634	`for( i = 0; i < length(method); i++ ) {`	634	`for( i = 0; i < length(method); i++ ) {`
635	`if(strlen(CHAR(STRING_ELT(method, i))) >= 512)`	635	`if(strlen(CHAR(STRING_ELT(method, i))) >= 512)`
636	`error(_("method name too long in %s"),`	636	`error(_("method name too long in '%s'"),`
637	`CHAR(STRING_ELT(method, i)));`	637	`CHAR(STRING_ELT(method, i)));`
638	`sprintf(b, "%s", CHAR(STRING_ELT(method, i)));`	638	`sprintf(b, "%s", CHAR(STRING_ELT(method, i)));`
639	`if( strlen(b) )`	639	`if( strlen(b) )`
640	`break;`	640	`break;`
641	`}`	641	`}`
642	`/* for binary operators check that the second argument's method`	642	`/* for binary operators check that the second argument's method`
643	`is the same or absent */`	643	`is the same or absent */`
644	`for(j = i; j < length(method); j++){`	644	`for(j = i; j < length(method); j++){`
645	`if(strlen(CHAR(STRING_ELT(method, j))) >= 512)`	645	`if(strlen(CHAR(STRING_ELT(method, j))) >= 512)`
646	`error(_("method name too long in %s"),`	646	`error(_("method name too long in '%s'"),`
647	`CHAR(STRING_ELT(method, j)));`	647	`CHAR(STRING_ELT(method, j)));`
648	`sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));`	648	`sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));`
649	`if (strlen(bb) && strcmp(b,bb))`	649	`if (strlen(bb) && strcmp(b,bb))`
650	`warning(_("Incompatible methods ignored"));`	650	`warning(_("Incompatible methods ignored"));`
651	`}`	651	`}`
652	`}`	652	`}`
653	`else {`	653	`else {`
654	`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"),`	655	`error(_("call name too long in '%s'"),`
656	`CHAR(PRINTNAME(CAR(cptr->call))));`	656	`CHAR(PRINTNAME(CAR(cptr->call))));`
657	`sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));`	657	`sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));`
658	`}`	658	`}`
659		659
660	`for (j = 0; j < length(class); j++) {`	660	`for (j = 0; j < length(class); j++) {`
661	`if(strlen(CHAR(STRING_ELT(basename, 0))) +`	661	`if(strlen(CHAR(STRING_ELT(basename, 0))) +`
662	`strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)`	662	`strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)`
663	`error(_("class name too long in %s"),`	663	`error(_("class name too long in '%s'"),`
664	`CHAR(STRING_ELT(basename, 0)));`	664	`CHAR(STRING_ELT(basename, 0)));`
665	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),`	665	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),`
666	`CHAR(STRING_ELT(class, j)));`	666	`CHAR(STRING_ELT(class, j)));`
667	`if ( !strcmp(buf, b) )`	667	`if ( !strcmp(buf, b) )`
668	`break;`	668	`break;`
Line 676...	Line 676...
676	`/* 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`
677	`how many classes to drop. */`	677	`how many classes to drop. */`
678	`for (i = j ; i < length(class); i++) {`	678	`for (i = j ; i < length(class); i++) {`
679	`if(strlen(CHAR(STRING_ELT(generic, 0))) +`	679	`if(strlen(CHAR(STRING_ELT(generic, 0))) +`
680	`strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`	680	`strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)`
681	`error(_("class name too long in %s"),`	681	`error(_("class name too long in '%s'"),`
682	`CHAR(STRING_ELT(generic, 0)));`	682	`CHAR(STRING_ELT(generic, 0)));`
683	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),`	683	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),`
684	`CHAR(STRING_ELT(class, i)));`	684	`CHAR(STRING_ELT(class, i)));`
685	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`	685	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`
686	`if (TYPEOF(nextfun) == PROMSXP)`	686	`if (TYPEOF(nextfun) == PROMSXP)`
Line 709...	Line 709...
709	`t = install(CHAR(STRING_ELT(generic, 0)));`	709	`t = install(CHAR(STRING_ELT(generic, 0)));`
710	`nextfun = findVar(t,env);`	710	`nextfun = findVar(t,env);`
711	`if (TYPEOF(nextfun)==PROMSXP)`	711	`if (TYPEOF(nextfun)==PROMSXP)`
712	`nextfun = eval(nextfun, env);`	712	`nextfun = eval(nextfun, env);`
713	`if (!isFunction(nextfun))`	713	`if (!isFunction(nextfun))`
714	`error(_("No method to invoke"));`	714	`error(_("no method to invoke"));`
715	`if (TYPEOF(nextfun) == CLOSXP) {`	715	`if (TYPEOF(nextfun) == CLOSXP) {`
716	`if (INTERNAL(t) != R_NilValue)`	716	`if (INTERNAL(t) != R_NilValue)`
717	`nextfun = INTERNAL(t);`	717	`nextfun = INTERNAL(t);`
718	`else`	718	`else`
719	`error(_("No method to invoke"));`	719	`error(_("no method to invoke"));`
720	`}`	720	`}`
721	`}`	721	`}`
722	`}`	722	`}`
723	`PROTECT(s = allocVector(STRSXP, length(class) - i));`	723	`PROTECT(s = allocVector(STRSXP, length(class) - i));`
724	`PROTECT(class = duplicate(class));`	724	`PROTECT(class = duplicate(class));`
Line 944...	Line 944...
944	`}`	944	`}`
945	`fun = R_UnboundValue;`	945	`fun = R_UnboundValue;`
946	`}`	946	`}`
947	`fun = SYMVALUE(symbol);`	947	`fun = SYMVALUE(symbol);`
948	`if(fun == R_UnboundValue)`	948	`if(fun == R_UnboundValue)`
949	`error(_("Unable to find a non-generic version of function \"%s\""),`	949	`error(_("unable to find a non-generic version of function \"%s\""),`
950	`CHAR(asChar(name)));`	950	`CHAR(asChar(name)));`
951	`cptr = R_GlobalContext;`	951	`cptr = R_GlobalContext;`
952	`/* check this is the right context */`	952	`/* check this is the right context */`
953	`while (cptr != R_ToplevelContext) {`	953	`while (cptr != R_ToplevelContext) {`
954	`if (cptr->callflag & CTXT_FUNCTION )`	954	`if (cptr->callflag & CTXT_FUNCTION )`
Line 991...	Line 991...
991	`ptr = R_get_standardGeneric_ptr();`	991	`ptr = R_get_standardGeneric_ptr();`
992	`}`	992	`}`
993	`PROTECT(args);`	993	`PROTECT(args);`
994	`PROTECT(arg = CAR(args));`	994	`PROTECT(arg = CAR(args));`
995	`if(!isValidStringF(arg))`	995	`if(!isValidStringF(arg))`
996	`error(_("Argument to standardGeneric must be a non-empty character string"));`	996	`error(_("argument to standardGeneric must be a non-empty character string"));`
997		997
998	`PROTECT(fdef = get_this_generic(args));`	998	`PROTECT(fdef = get_this_generic(args));`
999		999
1000	`if(isNull(fdef))`	1000	`if(isNull(fdef))`
1001	`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)));`
1002		1002
1003	`value = (*ptr)(arg, env, fdef);`	1003	`value = (*ptr)(arg, env, fdef);`
1004		1004
1005	`UNPROTECT(3);`	1005	`UNPROTECT(3);`
1006	`return value;`	1006	`return value;`
Line 1017...	Line 1017...
1017	`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,`
1018	`SEXP mlist)`	1018	`SEXP mlist)`
1019	`{`	1019	`{`
1020	`char *code_string;`	1020	`char *code_string;`
1021	`if(!isValidString(code_vec))`	1021	`if(!isValidString(code_vec))`
1022	`error(_("Argument 'code' must be a character string"));`	1022	`error(_("argument 'code' must be a character string"));`
1023	`code_string = CHAR(asChar(code_vec));`	1023	`code_string = CHAR(asChar(code_vec));`
1024	`do_set_prim_method(op, code_string, fundef, mlist);`	1024	`do_set_prim_method(op, code_string, fundef, mlist);`
1025	`return(fname);`	1025	`return(fname);`
1026	`}`	1026	`}`
1027		1027
Line 1056...	Line 1056...
1056	`break;`	1056	`break;`
1057	`default:`	1057	`default:`
1058	`errorcase = TRUE;`	1058	`errorcase = TRUE;`
1059	`}`	1059	`}`
1060	`if(errorcase) {`	1060	`if(errorcase) {`
1061	`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);`
1062	`return R_NilValue;`	1062	`return R_NilValue;`
1063	`}`	1063	`}`
1064	`switch(TYPEOF(op)) {`	1064	`switch(TYPEOF(op)) {`
1065	`case BUILTINSXP: case SPECIALSXP:`	1065	`case BUILTINSXP: case SPECIALSXP:`
1066	`offset = PRIMOFFSET(op);`	1066	`offset = PRIMOFFSET(op);`
1067	`break;`	1067	`break;`
1068	`default:`	1068	`default:`
1069	`error(_("Invalid object: must be a primitive function"));`	1069	`error(_("invalid object: must be a primitive function"));`
1070	`}`	1070	`}`
1071	`if(offset >= maxMethodsOffset) {`	1071	`if(offset >= maxMethodsOffset) {`
1072	`int n;`	1072	`int n;`
1073	`n = offset + 1;`	1073	`n = offset + 1;`
1074	`if(n < DEFAULT_N_PRIM_METHODS)`	1074	`if(n < DEFAULT_N_PRIM_METHODS)`
Line 1111...	Line 1111...
1111	`prim_generics[offset] = 0;`	1111	`prim_generics[offset] = 0;`
1112	`prim_mlist[offset] = 0;`	1112	`prim_mlist[offset] = 0;`
1113	`}`	1113	`}`
1114	`else if(fundef && !isNull(fundef) && !prim_generics[offset]) {`	1114	`else if(fundef && !isNull(fundef) && !prim_generics[offset]) {`
1115	`if(TYPEOF(fundef) != CLOSXP)`	1115	`if(TYPEOF(fundef) != CLOSXP)`
1116	`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')"),`
1117	`type2str(TYPEOF(fundef)));`	1117	`type2str(TYPEOF(fundef)));`
1118	`R_PreserveObject(fundef);`	1118	`R_PreserveObject(fundef);`
1119	`prim_generics[offset] = fundef;`	1119	`prim_generics[offset] = fundef;`
1120	`}`	1120	`}`
1121	`if(code==HAS_METHODS) {`	1121	`if(code==HAS_METHODS) {`
Line 1225...	Line 1225...
1225	`SEXP fundef, value, mlist=R_NilValue;`	1225	`SEXP fundef, value, mlist=R_NilValue;`
1226	`int offset;`	1226	`int offset;`
1227	`prim_methods_t current;`	1227	`prim_methods_t current;`
1228	`offset = PRIMOFFSET(op);`	1228	`offset = PRIMOFFSET(op);`
1229	`if(offset < 0 \|\| offset > curMaxOffset)`	1229	`if(offset < 0 \|\| offset > curMaxOffset)`
1230	`error(_("Invalid primitive operation given for dispatch"));`	1230	`error(_("invalid primitive operation given for dispatch"));`
1231	`current = prim_methods[offset];`	1231	`current = prim_methods[offset];`
1232	`if(current == NO_METHODS \|\| current == SUPPRESSED)`	1232	`if(current == NO_METHODS \|\| current == SUPPRESSED)`
1233	`return(NULL);`	1233	`return(NULL);`
1234	`/* check that the methods for this function have been set */`	1234	`/* check that the methods for this function have been set */`
1235	`if(current == NEEDS_RESET) {`	1235	`if(current == NEEDS_RESET) {`
Line 1296...	Line 1296...
1296	`if(!class_def)`	1296	`if(!class_def)`
1297	`error(_("C level NEW macro called with null class definition pointer"));`	1297	`error(_("C level NEW macro called with null class definition pointer"));`
1298	`e = R_do_slot(class_def, s_virtual);`	1298	`e = R_do_slot(class_def, s_virtual);`
1299	`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 */`
1300	`e = R_do_slot(class_def, s_className);`	1300	`e = R_do_slot(class_def, s_className);`
1301	`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\")"),`
1302	`CHAR(asChar(e)));`	1302	`CHAR(asChar(e)));`
1303	`}`	1303	`}`
1304	`e = R_do_slot(class_def, s_className);`	1304	`e = R_do_slot(class_def, s_className);`
1305	`value = duplicate(R_do_slot(class_def, s_prototype));`	1305	`value = duplicate(R_do_slot(class_def, s_prototype));`
1306	`setAttrib(value, R_ClassSymbol, e);`	1306	`setAttrib(value, R_ClassSymbol, e);`

The R Project SVN R

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