The R Project SVN R

Rev

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

Rev 77506 Rev 77801
Line 1723... Line 1723...
1723 
    PROTECT(value = duplicate(R_do_slot(class_def, s_prototype)));
 1723 
    PROTECT(value = duplicate(R_do_slot(class_def, s_prototype)));
1724 
    Rboolean xDataType = TYPEOF(value) == ENVSXP || TYPEOF(value) == SYMSXP ||
 1724 
    Rboolean xDataType = TYPEOF(value) == ENVSXP || TYPEOF(value) == SYMSXP ||
1725 
	TYPEOF(value) == EXTPTRSXP;
 1725 
	TYPEOF(value) == EXTPTRSXP;
1726 
    if((TYPEOF(value) == S4SXP || getAttrib(e, R_PackageSymbol) != R_NilValue) &&
 1726 
    if((TYPEOF(value) == S4SXP || getAttrib(e, R_PackageSymbol) != R_NilValue) &&
1727 
       !xDataType)
 1727 
       !xDataType)
1728 
    { /* Anything but an object from a base "class" (numeric, matrix,..) */
 - 
 
- 
 
 1728 
    {
1729 
	setAttrib(value, R_ClassSymbol, e);
 1729 
	setAttrib(value, R_ClassSymbol, e);
1730 
	SET_S4_OBJECT(value);
 1730 
	SET_S4_OBJECT(value);
1731 
    }
 1731 
    }
1732 
    UNPROTECT(2); /* value, e */
 1732 
    UNPROTECT(2); /* value, e */
1733 
    vmaxset(vmax);
 1733 
    vmaxset(vmax);
1734 
    return value;
 1734 
    return value;
1735 
}
 1735 
}
1736 
 
 1736 
 
- 
 
 1737 
SEXP R_do_new_object2(SEXP class_def)
- 
 
 1738 
{
- 
 
 1739 
    static SEXP s_virtual = NULL, s_prototype, s_className;
- 
 
 1740 
    SEXP e, value = R_NilValue;
- 
 
 1741 
    const void *vmax = vmaxget();
- 
 
 1742 
    if(!s_virtual) {
- 
 
 1743 
	s_virtual = install("virtual");
- 
 
 1744 
	s_prototype = install("prototype");
- 
 
 1745 
	s_className = install("className");
- 
 
 1746 
    }
- 
 
 1747 
    if(!class_def)
- 
 
 1748 
	error(_("C level NEW macro called with null class definition pointer"));
- 
 
 1749 
    e = R_do_slot(class_def, s_virtual);
- 
 
 1750 
    if(asLogical(e) != 0)  { /* includes NA, TRUE, or anything other than FALSE */
- 
 
 1751 
    	e = R_do_slot(class_def, s_className);
- 
 
 1752 
    	error(_("trying to generate an object from a virtual class (\"%s\")"),
- 
 
 1753 
    	      translateChar(asChar(e)));
- 
 
 1754 
    }
- 
 
 1755 
    PROTECT(e = R_do_slot(class_def, s_className));
- 
 
 1756 
    PROTECT(value = duplicate(R_do_slot(class_def, s_prototype)));
- 
 
 1757 
    Rboolean xDataType = TYPEOF(value) == ENVSXP || TYPEOF(value) == SYMSXP ||
- 
 
 1758 
    	TYPEOF(value) == EXTPTRSXP;
- 
 
 1759 
    if((TYPEOF(value) == S4SXP || getAttrib(e, R_PackageSymbol) != R_NilValue) &&
- 
 
 1760 
       !xDataType)
- 
 
 1761 
    	{
- 
 
 1762 
    	    setAttrib(value, R_ClassSymbol, e);
- 
 
 1763 
    	    SET_S4_OBJECT(value);
- 
 
 1764 
    	}
- 
 
 1765 
    UNPROTECT(2); /* value, e */
- 
 
 1766 
    vmaxset(vmax);
- 
 
 1767 
    return value;
- 
 
 1768 
}
- 
 
 1769 
 
1737 
Rboolean attribute_hidden R_seemsOldStyleS4Object(SEXP object)
 1770 
Rboolean attribute_hidden R_seemsOldStyleS4Object(SEXP object)
1738 
{
 1771 
{
1739 
    SEXP klass;
 1772 
    SEXP klass;
1740 
    if(!isObject(object) || IS_S4_OBJECT(object)) return FALSE;
 1773 
    if(!isObject(object) || IS_S4_OBJECT(object)) return FALSE;
1741 
    /* We want to know about S4SXPs with no S4 bit */
 1774 
    /* We want to know about S4SXPs with no S4 bit */