The R Project SVN R

Rev

Rev 25628 | Rev 26016 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 25628 Rev 25630
Line 262... Line 262...
262 
    PROTECT(newcall = duplicate(cptr->call));
 262 
    PROTECT(newcall = duplicate(cptr->call));
263 
 
 263 
 
264 
    class = R_data_class(obj, FALSE);
 264 
    class = R_data_class(obj, FALSE);
265 
    nclass = length(class);
 265 
    nclass = length(class);
266 
    for (i = 0; i < nclass; i++) {
 266 
    for (i = 0; i < nclass; i++) {
- 
 
 267 
	if(strlen(generic) + strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
- 
 
 268 
	    error("class name too long in %s", generic);
267 
	snprintf(buf, 512, "%s.%s", generic, CHAR(STRING_ELT(class, i)));
 269 
	sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));
268 
	method = install(buf);
 270 
	method = install(buf);
269 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
 271 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
270 
	/* autoloading requires that promises be evaluated <TSL>*/
 272 
	/* autoloading requires that promises be evaluated <TSL>*/
271 
	if (TYPEOF(sxp) == PROMSXP){
 273 
	if (TYPEOF(sxp) == PROMSXP){
272 
	  PROTECT(tmp = eval(sxp, rho));
 274 
	    PROTECT(tmp = eval(sxp, rho));
273 
	  sxp = tmp;
 275 
	    sxp = tmp;
274 
	  UNPROTECT(1);
 276 
	    UNPROTECT(1);
275 
	}
 277 
	}
276 
	if (isFunction(sxp)) {
 278 
	if (isFunction(sxp)) {
277 
	    defineVar(install(".Generic"), mkString(generic), newrho);
 279 
	    defineVar(install(".Generic"), mkString(generic), newrho);
278 
	    if (i > 0) {
 280 
	    if (i > 0) {
279 
		PROTECT(t = allocVector(STRSXP, nclass - i));
 281 
		PROTECT(t = allocVector(STRSXP, nclass - i));
Line 299... Line 301...
299 
	    R_GlobalContext->callflag = CTXT_RETURN;
 301 
	    R_GlobalContext->callflag = CTXT_RETURN;
300 
	    UNPROTECT(4);
 302 
	    UNPROTECT(4);
301 
	    return 1;
 303 
	    return 1;
302 
	}
 304 
	}
303 
    }
 305 
    }
- 
 
 306 
    if(strlen(generic) + strlen("default") + 2 > 512)
- 
 
 307 
	error("class name too long in %s", generic);
304 
    snprintf(buf, 512, "%s.default", generic);
 308 
    sprintf(buf, "%s.default", generic);
305 
    method = install(buf);
 309 
    method = install(buf);
306 
    sxp = R_LookupMethod(method, rho, callrho, defrho);
 310 
    sxp = R_LookupMethod(method, rho, callrho, defrho);
307 
    if (TYPEOF(sxp) == PROMSXP)
 311 
    if (TYPEOF(sxp) == PROMSXP)
308 
	sxp = eval(sxp, rho);
 312 
	sxp = eval(sxp, rho);
309 
    if (isFunction(sxp)) {
 313 
    if (isFunction(sxp)) {
Line 621... Line 625...
621 
    method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);
 625 
    method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);
622 
    if( method != R_UnboundValue) {
 626 
    if( method != R_UnboundValue) {
623 
	if( !isString(method) )
 627 
	if( !isString(method) )
624 
	    error("Wrong value for .Method");
 628 
	    error("Wrong value for .Method");
625 
	for( i = 0; i < length(method); i++ ) {
 629 
	for( i = 0; i < length(method); i++ ) {
- 
 
 630 
	if(strlen(CHAR(STRING_ELT(method, i))) >= 512)
- 
 
 631 
	    error("method name too long in %s", CHAR(STRING_ELT(method, i)));
626 
	  snprintf(b, 512, "%s", CHAR(STRING_ELT(method, i)));
 632 
	  sprintf(b, "%s", CHAR(STRING_ELT(method, i)));
627 
	  if( strlen(b) )
 633 
	  if( strlen(b) )
628 
	    break;
 634 
	    break;
629 
	}
 635 
	}
630 
	/* for binary operators check that the second argument's method
 636 
	/* for binary operators check that the second argument's method
631 
	   is the same or absent */
 637 
	   is the same or absent */
632 
	for(j=i;j<length(method); j++){
 638 
	for(j = i; j < length(method); j++){
- 
 
 639 
	if(strlen(CHAR(STRING_ELT(method, j))) >= 512)
- 
 
 640 
	    error("method name too long in %s", CHAR(STRING_ELT(method, j)));
633 
	  snprintf(bb, 512, "%s",CHAR(STRING_ELT(method, j)));
 641 
	  sprintf(bb, "%s",CHAR(STRING_ELT(method, j)));
634 
	  if (strlen(bb) && strcmp(b,bb))
 642 
	  if (strlen(bb) && strcmp(b,bb))
635 
	      warning("Incompatible methods ignored");
 643 
	      warning("Incompatible methods ignored");
636 
	}
 644 
	}
637 
    }
 645 
    }
638 
    else {
 646 
    else {
- 
 
 647 
	if(strlen(CHAR(PRINTNAME(CAR(cptr->call)))) >= 512)
- 
 
 648 
	   error("call name too long in %s", CHAR(PRINTNAME(CAR(cptr->call))));
639 
      snprintf(b, 512, "%s", CHAR(PRINTNAME(CAR(cptr->call))));
 649 
      sprintf(b, "%s", CHAR(PRINTNAME(CAR(cptr->call))));
640 
    }
 650 
    }
641 
 
 651 
 
642 
    for (j = 0; j < length(class); j++) {
 652 
    for (j = 0; j < length(class); j++) {
- 
 
 653 
	if(strlen(CHAR(STRING_ELT(basename, 0))) +
- 
 
 654 
	   strlen(CHAR(STRING_ELT(class, j))) + 2 > 512)
- 
 
 655 
	    error("class name too long in %s", CHAR(STRING_ELT(basename, 0)));
643 
      snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),
 656 
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),
644 
	CHAR(STRING_ELT(class, j)));
 657 
		CHAR(STRING_ELT(class, j)));
645 
      if ( !strcmp(buf,b) )
 658 
	if ( !strcmp(buf, b) )
646 
	break;
 659 
	    break;
647 
    }
 660 
    }
648 
 
 661 
 
649 
    if ( !strcmp(buf,b) ) /* we found a match and start from there */
 662 
    if ( !strcmp(buf,b) ) /* we found a match and start from there */
650 
      j++;
 663 
      j++;
651 
    else
 664 
    else
652 
      j = 0;  /*no match so start with the first element of .Class */
 665 
      j = 0;  /*no match so start with the first element of .Class */
653 
 
 666 
 
654 
    /* we need the value of i on exit from the for loop to figure out
 667 
    /* we need the value of i on exit from the for loop to figure out
655 
	   how many classes to drop. */
 668 
	   how many classes to drop. */
656 
    for (i = j ; i < length(class); i++) {
 669 
    for (i = j ; i < length(class); i++) {
- 
 
 670 
	if(strlen(CHAR(STRING_ELT(generic, 0))) +
- 
 
 671 
	   strlen(CHAR(STRING_ELT(class, i))) + 2 > 512)
- 
 
 672 
	    error("class name too long in %s", CHAR(STRING_ELT(generic, 0)));
657 
	    snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(generic, 0)),
 673 
	sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),
658 
		CHAR(STRING_ELT(class, i)));
 674 
		CHAR(STRING_ELT(class, i)));
659 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
 675 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
660 
	if (TYPEOF(nextfun) == PROMSXP)
 676 
	if (TYPEOF(nextfun) == PROMSXP)
661 
	    nextfun = eval(nextfun, env);
 677 
	    nextfun = eval(nextfun, env);
662 
	if (isFunction(nextfun))
 678 
	if (isFunction(nextfun))
663 
	    break;
 679 
	    break;
664 
	if (group !=R_UnboundValue){
 680 
	if (group !=R_UnboundValue){
665 
	    /* if not Generic.foo, look for Group.foo */
 681 
	    /* if not Generic.foo, look for Group.foo */
666 
	    snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),
 682 
	    sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),
667 
		CHAR(STRING_ELT(class, i)));
 683 
		CHAR(STRING_ELT(class, i)));
668 
	    nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
 684 
	    nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
669 
	    if (TYPEOF(nextfun) == PROMSXP)
 685 
	    if (TYPEOF(nextfun) == PROMSXP)
670 
		nextfun = eval(nextfun, env);
 686 
		nextfun = eval(nextfun, env);
671 
	    if(isFunction(nextfun))
 687 
	    if(isFunction(nextfun))
Line 673... Line 689...
673 
	}
 689 
	}
674 
	if (isFunction(nextfun))
 690 
	if (isFunction(nextfun))
675 
	    break;
 691 
	    break;
676 
    }
 692 
    }
677 
    if (!isFunction(nextfun)) {
 693 
    if (!isFunction(nextfun)) {
678 
	snprintf(buf, 512, "%s.default", CHAR(STRING_ELT(generic, 0)));
 694 
	sprintf(buf, "%s.default", CHAR(STRING_ELT(generic, 0)));
679 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
 695 
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
680 
	if (TYPEOF(nextfun) == PROMSXP)
 696 
	if (TYPEOF(nextfun) == PROMSXP)
681 
	    nextfun = eval(nextfun, env);
 697 
	    nextfun = eval(nextfun, env);
682 
	if (!isFunction(nextfun)) {
 698 
	if (!isFunction(nextfun)) {
683 
	    t = install(CHAR(STRING_ELT(generic, 0)));
 699 
	    t = install(CHAR(STRING_ELT(generic, 0)));