The R Project SVN – R – Diff – /branches/R-exp-R5/src/main/dotcode.c



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2010  The R Development Core Team
 *  Copyright (C) 2003	      The R Foundation
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or

 
    switch(type) {
    case RAWSXP:
    s = allocVector(type, n);
    rawptr = (Rbyte *)p;
    for (i = 0; i < n; i++) RAW(s)[i] = rawptr[i];
 
    break;
    case LGLSXP:
    case INTSXP:
	s = allocVector(type, n);
	iptr = (int*)p;
 
	for(i = 0 ; i < n ; i++) INTEGER(s)[i] = iptr[i];
	break;
    case REALSXP:
    case SINGLESXP:
	s = allocVector(REALSXP, n);
	if(type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
	    sptr = (float*) p;
	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];
	} else {
	    rptr = (double*) p;
	    for(i = 0 ; i < n ; i++) REAL(s)[i] = rptr[i];
	}
	break;
    case CPLXSXP:
	s = allocVector(type, n);
	zptr = (Rcomplex*)p;
 
	for(i = 0 ; i < n ; i++) COMPLEX(s)[i] = zptr[i];
 
	break;
    case STRSXP:
	if(Fort) {
	    /* only return one string: warned on the R -> Fortran step */
	    strncpy(buf, (char*)p, 255);

	}
	break;
    case VECSXP:
	PROTECT(s = allocVector(VECSXP, n));
	lptr = (SEXP*)p;
 
	for (i = 0 ; i < n ; i++) SET_VECTOR_ELT(s, i, lptr[i]);
 
	UNPROTECT(1);
	break;
    case LISTSXP:
	PROTECT(t = s = allocList(n));
	lptr = (SEXP*)p;
	for(i = 0 ; i < n ; i++) {
	    SETCAR(t, lptr[i]);
	    t = CDR(t);
	}
	UNPROTECT(1);
    default:

    SEXP retval;
    R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};
    const void *vmax = vmaxget();
    char buf[MaxSymbolBytes];
 
    if (length(args) < 1) errorcall(call, _("'name' is missing"));
    check1arg(args, call, "name");
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
				NULL, call);
    fun = (R_ExternalRoutine) ofun;
 
    /* Some external symbols that are registered may have 0 as the

    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
    int nargs;
    const void *vmax = vmaxget();
    char buf[MaxSymbolBytes];
 
    if (length(args) < 1) errorcall(call, _("'name' is missing"));
    check1arg(args, call, "name");
    nm = CAR(args);
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
				NULL, call);
    args = CDR(args);
    fun = (VarFun) ofun;

    R_NativePrimitiveArgType *checkTypes = NULL;
    R_NativeArgStyle *argStyles = NULL;
    void *vmax;
    char symName[MaxSymbolBytes], encname[101];
 
    if (length(args) < 1) errorcall(call, _("'name' is missing"));
    check1arg(args, call, "name");
    if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
	NaokSymbol = install("NAOK");
	DupSymbol = install("DUP");
	PkgSymbol = install("PACKAGE");
    }

Rev 51272	Rev 51291
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1997--2007 The R Development Core Team`	4	`* Copyright (C) 1997--2010 The R Development Core Team`
5	`* Copyright (C) 2003 The R Foundation`	5	`* Copyright (C) 2003 The R Foundation`
6	`*`	6	`*`
7	`* This program is free software; you can redistribute it and/or modify`	7	`* This program is free software; you can redistribute it and/or modify`
8	`* it under the terms of the GNU General Public License as published by`	8	`* it under the terms of the GNU General Public License as published by`
9	`* the Free Software Foundation; either version 2 of the License, or`	9	`* the Free Software Foundation; either version 2 of the License, or`
Line 470...	Line 470...
470		470
471	`switch(type) {`	471	`switch(type) {`
472	`case RAWSXP:`	472	`case RAWSXP:`
473	`s = allocVector(type, n);`	473	`s = allocVector(type, n);`
474	`rawptr = (Rbyte *)p;`	474	`rawptr = (Rbyte *)p;`
475	`for (i = 0; i < n; i++)`	475	`for (i = 0; i < n; i++) RAW(s)[i] = rawptr[i];`
476	`RAW(s)[i] = rawptr[i];`	-
477	`break;`	476	`break;`
478	`case LGLSXP:`	477	`case LGLSXP:`
479	`case INTSXP:`	478	`case INTSXP:`
480	`s = allocVector(type, n);`	479	`s = allocVector(type, n);`
481	`iptr = (int*)p;`	480	`iptr = (int*)p;`
482	`for(i=0 ; i<n ; i++)`	-
483	`INTEGER(s)[i] = iptr[i];`	481	`for(i = 0 ; i < n ; i++) INTEGER(s)[i] = iptr[i];`
484	`break;`	482	`break;`
485	`case REALSXP:`	483	`case REALSXP:`
486	`case SINGLESXP:`	484	`case SINGLESXP:`
487	`s = allocVector(REALSXP, n);`	485	`s = allocVector(REALSXP, n);`
488	`if(type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`	486	`if(type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`
489	`sptr = (float*) p;`	487	`sptr = (float*) p;`
490	`for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];`	488	`for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];`
491	`} else {`	489	`} else {`
492	`rptr = (double*) p;`	490	`rptr = (double*) p;`
493	`for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];`	491	`for(i = 0 ; i < n ; i++) REAL(s)[i] = rptr[i];`
494	`}`	492	`}`
495	`break;`	493	`break;`
496	`case CPLXSXP:`	494	`case CPLXSXP:`
497	`s = allocVector(type, n);`	495	`s = allocVector(type, n);`
498	`zptr = (Rcomplex*)p;`	496	`zptr = (Rcomplex*)p;`
499	`for(i=0 ; i<n ; i++) {`	-
500	`COMPLEX(s)[i] = zptr[i];`	497	`for(i = 0 ; i < n ; i++) COMPLEX(s)[i] = zptr[i];`
501	`}`	-
502	`break;`	498	`break;`
503	`case STRSXP:`	499	`case STRSXP:`
504	`if(Fort) {`	500	`if(Fort) {`
505	`/* only return one string: warned on the R -> Fortran step */`	501	`/* only return one string: warned on the R -> Fortran step */`
506	`strncpy(buf, (char*)p, 255);`	502	`strncpy(buf, (char*)p, 255);`
Line 545...	Line 541...
545	`}`	541	`}`
546	`break;`	542	`break;`
547	`case VECSXP:`	543	`case VECSXP:`
548	`PROTECT(s = allocVector(VECSXP, n));`	544	`PROTECT(s = allocVector(VECSXP, n));`
549	`lptr = (SEXP*)p;`	545	`lptr = (SEXP*)p;`
550	`for (i = 0 ; i < n ; i++) {`	-
551	`SET_VECTOR_ELT(s, i, lptr[i]);`	546	`for (i = 0 ; i < n ; i++) SET_VECTOR_ELT(s, i, lptr[i]);`
552	`}`	-
553	`UNPROTECT(1);`	547	`UNPROTECT(1);`
554	`break;`	548	`break;`
555	`case LISTSXP:`	549	`case LISTSXP:`
556	`PROTECT(t = s = allocList(n));`	550	`PROTECT(t = s = allocList(n));`
557	`lptr = (SEXP*)p;`	551	`lptr = (SEXP*)p;`
558	`for(i=0 ; i<n ; i++) {`	552	`for(i = 0 ; i < n ; i++) {`
559	`SETCAR(t, lptr[i]);`	553	`SETCAR(t, lptr[i]);`
560	`t = CDR(t);`	554	`t = CDR(t);`
561	`}`	555	`}`
562	`UNPROTECT(1);`	556	`UNPROTECT(1);`
563	`default:`	557	`default:`
Line 764...	Line 758...
764	`SEXP retval;`	758	`SEXP retval;`
765	`R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};`	759	`R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};`
766	`const void *vmax = vmaxget();`	760	`const void *vmax = vmaxget();`
767	`char buf[MaxSymbolBytes];`	761	`char buf[MaxSymbolBytes];`
768		762
-		763	`if (length(args) < 1) errorcall(call, _("'name' is missing"));`
-		764	`check1arg(args, call, "name");`
769	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,`	765	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,`
770	`NULL, call);`	766	`NULL, call);`
771	`fun = (R_ExternalRoutine) ofun;`	767	`fun = (R_ExternalRoutine) ofun;`
772		768
773	`/* Some external symbols that are registered may have 0 as the`	769	`/* Some external symbols that are registered may have 0 as the`
Line 805...	Line 801...
805	`R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};`	801	`R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};`
806	`int nargs;`	802	`int nargs;`
807	`const void *vmax = vmaxget();`	803	`const void *vmax = vmaxget();`
808	`char buf[MaxSymbolBytes];`	804	`char buf[MaxSymbolBytes];`
809		805
-		806	`if (length(args) < 1) errorcall(call, _("'name' is missing"));`
-		807	`check1arg(args, call, "name");`
810	`nm = CAR(args);`	808	`nm = CAR(args);`
811	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,`	809	`args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,`
812	`NULL, call);`	810	`NULL, call);`
813	`args = CDR(args);`	811	`args = CDR(args);`
814	`fun = (VarFun) ofun;`	812	`fun = (VarFun) ofun;`
Line 1627...	Line 1625...
1627	`R_NativePrimitiveArgType *checkTypes = NULL;`	1625	`R_NativePrimitiveArgType *checkTypes = NULL;`
1628	`R_NativeArgStyle *argStyles = NULL;`	1626	`R_NativeArgStyle *argStyles = NULL;`
1629	`void *vmax;`	1627	`void *vmax;`
1630	`char symName[MaxSymbolBytes], encname[101];`	1628	`char symName[MaxSymbolBytes], encname[101];`
1631		1629
-		1630	`if (length(args) < 1) errorcall(call, _("'name' is missing"));`
-		1631	`check1arg(args, call, "name");`
1632	`if (NaokSymbol == NULL \|\| DupSymbol == NULL \|\| PkgSymbol == NULL) {`	1632	`if (NaokSymbol == NULL \|\| DupSymbol == NULL \|\| PkgSymbol == NULL) {`
1633	`NaokSymbol = install("NAOK");`	1633	`NaokSymbol = install("NAOK");`
1634	`DupSymbol = install("DUP");`	1634	`DupSymbol = install("DUP");`
1635	`PkgSymbol = install("PACKAGE");`	1635	`PkgSymbol = install("PACKAGE");`
1636	`}`	1636	`}`

The R Project SVN R

(root)/branches/R-exp-R5/src/main/dotcode.c @ 63243 – Rev 51272 → 51291