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

     DL_FUNC ofun = NULL;
     VarFun fun = NULL;
     SEXP ans, pa, s;
     R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
     R_NativePrimitiveArgType *checkTypes = NULL;
-    R_NativeArgStyle *argStyles = NULL;
     const void *vmax;
     char symName[MaxSymbolBytes];
     if (length(args) < 1) errorcall(call, _("'.NAME' is missing"));
     check1arg2(args, call, ".NAME");
 	    errorcall(call,
 		      _("Incorrect number of arguments (%d), expecting %d for '%s'"),
 		      nargs, symbol.symbol.c->numArgs, symName);
 	checkTypes = symbol.symbol.c->types;
-	argStyles = symbol.symbol.c->styles;
+    }
     /* Construct the return value */
     nargs = 0;
     havenames = FALSE;
     default:
 	errorcall(call, _("too many arguments, sorry"));
+    }
     for (na = 0, pa = args ; pa != R_NilValue ; pa = CDR(pa), na++) {
-	if(argStyles && argStyles[na] == R_ARG_IN) {
-	    SET_VECTOR_ELT(ans, na, R_NilValue);
-	    continue;
-	} else {
-	    void *p = cargs[na];
+	void *p = cargs[na];
-	    SEXP arg = CAR(pa);
+	SEXP arg = CAR(pa);
-	    s = VECTOR_ELT(ans, na);
+	s = VECTOR_ELT(ans, na);
-	    R_NativePrimitiveArgType type =
+	R_NativePrimitiveArgType type =
-		checkTypes ? checkTypes[na] : TYPEOF(arg);
+	    checkTypes ? checkTypes[na] : TYPEOF(arg);
-	    R_xlen_t n = xlength(arg);
+	R_xlen_t n = xlength(arg);
-	    switch(type) {
+	switch(type) {
-	    case RAWSXP:
+	case RAWSXP:
-		if (copy) {
+	    if (copy) {
-		    s = allocVector(type, n);
+		s = allocVector(type, n);
-		    unsigned char *ptr = (unsigned char *) p;
+		unsigned char *ptr = (unsigned char *) p;
-		    memcpy(RAW(s), ptr, n * sizeof(Rbyte));
+		memcpy(RAW(s), ptr, n * sizeof(Rbyte));
-		    ptr += n * sizeof(Rbyte);
+		ptr += n * sizeof(Rbyte);
-		    for (int i = 0; i < NG; i++)
+		for (int i = 0; i < NG; i++)
-			if(*ptr++ != FILL)
+		    if(*ptr++ != FILL)
-			    error("array over-run in %s(\"%s\") in %s argument %d\n",
+			error("array over-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
+			      Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
+			      symName, type2char(type), na+1);
-		    ptr = (unsigned char *) p;
+		ptr = (unsigned char *) p;
-		    for (int i = 0; i < NG; i++)
+		for (int i = 0; i < NG; i++)
-			if(*--ptr != FILL)
+		    if(*--ptr != FILL)
-			    error("array under-run in %s(\"%s\") in %s argument %d\n",
+			error("array under-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
+			      Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
+			      symName, type2char(type), na+1);
+	    }
+	    break;
+	case INTSXP:
+	    if (copy) {
+		s = allocVector(type, n);
+		unsigned char *ptr = (unsigned char *) p;
+		memcpy(INTEGER(s), ptr, n * sizeof(int));
+		ptr += n * sizeof(int);
+		for (int i = 0; i < NG; i++)
+		    if(*ptr++ != FILL)
+			error("array over-run in %s(\"%s\") in %s argument %d\n",
+			      Fort ? ".Fortran" : ".C",
+			      symName, type2char(type), na+1);
+		ptr = (unsigned char *) p;
+		for (int i = 0; i < NG; i++)
+		    if(*--ptr != FILL)
+			error("array under-run in %s(\"%s\") in %s argument %d\n",
+			      Fort ? ".Fortran" : ".C",
+			      symName, type2char(type), na+1);
+	    }
+	    break;
+	case LGLSXP:
+	    if (copy) {
+		s = allocVector(type, n);
+		unsigned char *ptr = (unsigned char *) p;
+		int *iptr = (int*) ptr, tmp;
+		for (R_xlen_t i = 0 ; i < n ; i++) {
+		    tmp =  iptr[i];
+		    LOGICAL(s)[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;
+		}
-		break;
-	    case INTSXP:
-		if (copy) {
-		    s = allocVector(type, n);
-		    unsigned char *ptr = (unsigned char *) p;
-		    memcpy(INTEGER(s), ptr, n * sizeof(int));
-		    ptr += n * sizeof(int);
+		ptr += n * sizeof(int);
-		    for (int i = 0; i < NG; i++)
+		for (int i = 0; i < NG;  i++)
-			if(*ptr++ != FILL)
+		    if(*ptr++ != FILL)
-			    error("array over-run in %s(\"%s\") in %s argument %d\n",
+			error("array over-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
+			      Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
+			      symName, type2char(type), na+1);
-		    ptr = (unsigned char *) p;
+		ptr = (unsigned char *) p;
-		    for (int i = 0; i < NG; i++)
+		for (int i = 0; i < NG; i++)
-			if(*--ptr != FILL)
+		    if(*--ptr != FILL)
-			    error("array under-run in %s(\"%s\") in %s argument %d\n",
+			error("array under-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
+			      Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
+			      symName, type2char(type), na+1);
+	    } else {
+		int *iptr = INTEGER(arg), tmp;
+		for (R_xlen_t i = 0 ; i < n ; i++) {
+		    tmp =  iptr[i];
+		    iptr[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;
+		}
+	    }
-		break;
+	    break;
-	    case LGLSXP:
+	case REALSXP:
+	case SINGLESXP:
-		if (copy) {
+	    if (copy) {
-		    s = allocVector(type, n);
+		s = allocVector(REALSXP, n);
+		if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
+		    float *sptr = (float*) p;
+		    for(R_xlen_t i = 0 ; i < n ; i++)
+			REAL(s)[i] = (double) sptr[i];
+		} else {
 		    unsigned char *ptr = (unsigned char *) p;
-		    int *iptr = (int*) ptr, tmp;
-		    for (R_xlen_t i = 0 ; i < n ; i++) {
+		    memcpy(REAL(s), ptr, n * sizeof(double));
-			tmp =  iptr[i];
-			LOGICAL(s)[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;
-		    }
-		    ptr += n * sizeof(int);
+		    ptr += n * sizeof(double);
-		    for (int i = 0; i < NG;  i++)
+		    for (int i = 0; i < NG; i++)
 			if(*ptr++ != FILL)
 			    error("array over-run in %s(\"%s\") in %s argument %d\n",
 				  Fort ? ".Fortran" : ".C",
 				  symName, type2char(type), na+1);
 		    ptr = (unsigned char *) p;
 		    for (int i = 0; i < NG; i++)
 			if(*--ptr != FILL)
 			    error("array under-run in %s(\"%s\") in %s argument %d\n",
 				  Fort ? ".Fortran" : ".C",
 				  symName, type2char(type), na+1);
-		} else {
-		    int *iptr = INTEGER(arg), tmp;
-		    for (R_xlen_t i = 0 ; i < n ; i++) {
-			tmp =  iptr[i];
-			iptr[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;
-		    }
+		}
-		break;
-	    case REALSXP:
+	    } else {
-	    case SINGLESXP:
+		if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
-		if (copy) {
 		    s = allocVector(REALSXP, n);
-		    if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
-			float *sptr = (float*) p;
+		    float *sptr = (float*) p;
-			for(R_xlen_t i = 0 ; i < n ; i++)
-			    REAL(s)[i] = (double) sptr[i];
-		    } else {
-			unsigned char *ptr = (unsigned char *) p;
-			memcpy(REAL(s), ptr, n * sizeof(double));
-			ptr += n * sizeof(double);
-			for (int i = 0; i < NG; i++)
-			    if(*ptr++ != FILL)
-				error("array over-run in %s(\"%s\") in %s argument %d\n",
-				      Fort ? ".Fortran" : ".C",
-				      symName, type2char(type), na+1);
-			ptr = (unsigned char *) p;
-			for (int i = 0; i < NG; i++)
-			    if(*--ptr != FILL)
-				error("array under-run in %s(\"%s\") in %s argument %d\n",
-				      Fort ? ".Fortran" : ".C",
-				      symName, type2char(type), na+1);
-		    }
-		} else {
-		    if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
-			s = allocVector(REALSXP, n);
-			float *sptr = (float*) p;
-			for(int i = 0 ; i < n ; i++)
+		    for(int i = 0 ; i < n ; i++)
-			    REAL(s)[i] = (double) sptr[i];
+			REAL(s)[i] = (double) sptr[i];
-		    }
-		}
-		break;
-	    case CPLXSXP:
-		if (copy) {
-		    s = allocVector(type, n);
-		    unsigned char *ptr = (unsigned char *) p;
-		    memcpy(COMPLEX(s), p, n * sizeof(Rcomplex));
-		    ptr += n * sizeof(Rcomplex);
-		    for (int i = 0; i < NG;  i++)
-			if(*ptr++ != FILL)
-			    error("array over-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
-		    ptr = (unsigned char *) p;
-		    for (int i = 0; i < NG; i++)
-			if(*--ptr != FILL)
-			    error("array under-run in %s(\"%s\") in %s argument %d\n",
-				  Fort ? ".Fortran" : ".C",
-				  symName, type2char(type), na+1);
+		}
+	    }
-		break;
+	    break;
+	case CPLXSXP:
+	    if (copy) {
+		s = allocVector(type, n);
+		unsigned char *ptr = (unsigned char *) p;
+		memcpy(COMPLEX(s), p, n * sizeof(Rcomplex));
+		ptr += n * sizeof(Rcomplex);
+		for (int i = 0; i < NG;  i++)
+		    if(*ptr++ != FILL)
+			error("array over-run in %s(\"%s\") in %s argument %d\n",
+			      Fort ? ".Fortran" : ".C",
+			      symName, type2char(type), na+1);
+		ptr = (unsigned char *) p;
+		for (int i = 0; i < NG; i++)
+		    if(*--ptr != FILL)
+			error("array under-run in %s(\"%s\") in %s argument %d\n",
+			      Fort ? ".Fortran" : ".C",
+			      symName, type2char(type), na+1);
+	    }
+	    break;
-	    case STRSXP:
+	case STRSXP:
-		if(Fort) {
+	    if(Fort) {
-		    char buf[256];
+		char buf[256];
-		    /* only return one string: warned on the R -> Fortran step */
+		/* only return one string: warned on the R -> Fortran step */
-		    strncpy(buf, (char*)p, 255);
+		strncpy(buf, (char*)p, 255);
-		    buf[255] = '\0';
+		buf[255] = '\0';
-		    PROTECT(s = allocVector(type, 1));
+		PROTECT(s = allocVector(type, 1));
-		    SET_STRING_ELT(s, 0, mkChar(buf));
+		SET_STRING_ELT(s, 0, mkChar(buf));
-		    UNPROTECT(1);
+		UNPROTECT(1);
-		} else if (copy) {
+	    } else if (copy) {
-		    SEXP ss = arg;
+		SEXP ss = arg;
-		    PROTECT(s = allocVector(type, n));
+		PROTECT(s = allocVector(type, n));
-		    char **cptr = (char**) p, **cptr0 = (char**) cargs0[na];
+		char **cptr = (char**) p, **cptr0 = (char**) cargs0[na];
-		    for (R_xlen_t i = 0 ; i < n ; i++) {
+		for (R_xlen_t i = 0 ; i < n ; i++) {
-			unsigned char *ptr = (unsigned char *) cptr[i];
+		    unsigned char *ptr = (unsigned char *) cptr[i];
-			SET_STRING_ELT(s, i, mkChar(cptr[i]));
+		    SET_STRING_ELT(s, i, mkChar(cptr[i]));
-			if (cptr[i] == cptr0[i]) {
+		    if (cptr[i] == cptr0[i]) {
-			    const char *z = translateChar(STRING_ELT(ss, i));
+			const char *z = translateChar(STRING_ELT(ss, i));
-			    for (int j = 0; j < NG; j++)
+			for (int j = 0; j < NG; j++)
-				if(*--ptr != FILL)
+			    if(*--ptr != FILL)
-				    error("array under-run in .C(\"%s\") in character argument %d, element %d",
+				error("array under-run in .C(\"%s\") in character argument %d, element %d",
-					  symName, na+1, (int)(i+1));
+				      symName, na+1, (int)(i+1));
-			    ptr = (unsigned char *) cptr[i];
+			ptr = (unsigned char *) cptr[i];
-			    ptr += strlen(z) + 1;
+			ptr += strlen(z) + 1;
-			    for (int j = 0; j < NG;  j++)
+			for (int j = 0; j < NG;  j++)
-				if(*ptr++ != FILL) {
+			    if(*ptr++ != FILL) {
-				    // force termination
+				// force termination
-				    unsigned char *p = ptr;
+				unsigned char *p = ptr;
-				    for (int k = 1; k < NG - j; k++, p++)
+				for (int k = 1; k < NG - j; k++, p++)
-					if (*p == FILL) *p = '\0';
+				    if (*p == FILL) *p = '\0';
-				    error("array over-run in .C(\"%s\") in character argument %d, element %d\n'%s'->'%s'\n",
+				error("array over-run in .C(\"%s\") in character argument %d, element %d\n'%s'->'%s'\n",
-					  symName, na+1, (int)(i+1),
+				      symName, na+1, (int)(i+1),
-					  z, cptr[i]);
+				      z, cptr[i]);
-				}
+			    }
-			}
+		    }
-		    UNPROTECT(1);
-		} else {
-		    PROTECT(s = allocVector(type, n));
-		    char **cptr = (char**) p;
-		    for (R_xlen_t i = 0 ; i < n ; i++)
-			SET_STRING_ELT(s, i, mkChar(cptr[i]));
-		    UNPROTECT(1);
+		}
-		break;
+		UNPROTECT(1);
-	    default:
+	    } else {
-		break;
-	    }
-	    if (s != arg) {
+		PROTECT(s = allocVector(type, n));
-		PROTECT(s);
+		char **cptr = (char**) p;
-		SHALLOW_DUPLICATE_ATTRIB(s, arg);
+		for (R_xlen_t i = 0 ; i < n ; i++)
-		SET_VECTOR_ELT(ans, na, s);
+		    SET_STRING_ELT(s, i, mkChar(cptr[i]));
 		UNPROTECT(1);
+	    }
+	    break;
+	default:
+	    break;
+	}
+	if (s != arg) {
+	    PROTECT(s);
+	    SHALLOW_DUPLICATE_ATTRIB(s, arg);
+	    SET_VECTOR_ELT(ans, na, s);
+	    UNPROTECT(1);
+	}
+    }
     UNPROTECT(1);
     vmaxset(vmax);
     return ans;

The R Project SVN R

(root)/trunk/src/main/dotcode.c @ 77458 – Rev 71957 → 72231