The R Project SVN R

Rev

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

Rev 36990 Rev 37711
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--2005  The R Development Core Team
 4 
 *  Copyright (C) 1997--2006  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 202... Line 202...
202 
 
 202 
 
203 
    if(TYPEOF(op) == STRSXP) {
 203 
    if(TYPEOF(op) == STRSXP) {
204 
	p = CHAR(STRING_ELT(op, 0));
 204 
	p = CHAR(STRING_ELT(op, 0));
205 
	q = buf;
 205 
	q = buf;
206 
	while ((*q = *p) != '\0') {
 206 
	while ((*q = *p) != '\0') {
- 
 
 207 
	    if(symbol->type == R_FORTRAN_SYM) *q = tolower(*q);
207 
	    p++;
 208 
	    p++;
208 
	    q++;
 209 
	    q++;
209 
	}
 210 
	}
210 
    }
 211 
    }
- 
 
 212 
    /*
- 
 
 213 
    if(symbol->type == R_FORTRAN_SYM && strchr(buf, '_'))
- 
 
 214 
	warningcall(call, _("Fortran symbol names contaning '_' are not portable"));
- 
 
 215 
    */
211 
 
 216 
 
212 
    if(!*fun) {
 217 
    if(!*fun) {
213 
	if(dll.type != FILENAME) {
 218 
	if(dll.type != FILENAME) {
214 
	    /* no PACKAGE= arg, so see if we can identify a DLL
 219 
	    /* no PACKAGE= arg, so see if we can identify a DLL
215 
	       from the namespace defining the function */
 220 
	       from the namespace defining the function */
Line 219... Line 224...
219 
	       if(!fun)
 224 
	       if(!fun)
220 
	           errorcall(call, _("cannot resolve native routine"));
 225 
	           errorcall(call, _("cannot resolve native routine"));
221 
	    */
 226 
	    */
222 
	}
 227 
	}
223 
 
 228 
 
- 
 
 229 
	/* NB: the actual conversion to the symbol is done in
- 
 
 230 
	   R_dlsym in Rdynload.c.  That prepends an underscore (usually),
- 
 
 231 
	   and may append one or more underscores.
- 
 
 232 
	*/
- 
 
 233 
 
224 
	if (!*fun && !(*fun = R_FindSymbol(buf, dll.DLLname, symbol))) {
 234 
	if (!*fun && !(*fun = R_FindSymbol(buf, dll.DLLname, symbol))) {
225 
	    if(strlen(dll.DLLname))
 235 
	    if(strlen(dll.DLLname))
226 
		errorcall(call,
 236 
		errorcall(call,
227 
			  _("%s entry point \"%s%s\" not in DLL for package \"%s\""),
 237 
			  _("%s symbol name \"%s\" not in DLL for package \"%s\""),
228 
			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf,
 238 
			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf,
229 
#ifdef HAVE_F77_UNDERSCORE
 - 
 
230 
			  symbol->type == R_FORTRAN_SYM ? "_" : "",
 - 
 
231 
#else
 - 
 
232 
			  "",
 - 
 
233 
#endif
 - 
 
234 
			  dll.DLLname);
 239 
			  dll.DLLname);
235 
	    else
 240 
	    else
236 
		errorcall(call, _("%s entry point \"%s%s\" not in load table"),
 241 
		errorcall(call, _("%s symbol name \"%s\" not in load table"),
237 
			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf,
 242 
			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf);
238 
#ifdef HAVE_F77_UNDERSCORE
 - 
 
239 
			  symbol->type == R_FORTRAN_SYM ? "_" : ""
 - 
 
240 
#else
 - 
 
241 
			  ""
 - 
 
242 
#endif
- 
 
243 
			  );
 - 
 
244 
	}
 243 
	}
245 
    }
 244 
    }
246 
 
 245 
 
247 
    return(args);
 246 
    return(args);
248 
}
 247 
}
Line 727... Line 726...
727 
 
 726 
 
728 
 
 727 
 
729 
SEXP attribute_hidden do_symbol(SEXP call, SEXP op, SEXP args, SEXP env)
 728 
SEXP attribute_hidden do_symbol(SEXP call, SEXP op, SEXP args, SEXP env)
730 
{
 729 
{
731 
    char buf[128], *p, *q;
 730 
    char buf[128], *p, *q;
- 
 
 731 
 
732 
    checkArity(op, args);
 732 
    checkArity(op, args);
- 
 
 733 
 
733 
    if(!isValidString(CAR(args)))
 734 
    if(!isValidString(CAR(args)))
734 
	errorcall(call, R_MSG_IA);
 735 
	errorcall(call, R_MSG_IA);
- 
 
 736 
 
- 
 
 737 
    warningcall(call, _("'%s' is deprecated"),
- 
 
 738 
		PRIMVAL(op) ? "symbol.For" : "symbol.C");
735 
    p = CHAR(STRING_ELT(CAR(args), 0));
 739 
    p = CHAR(STRING_ELT(CAR(args), 0));
736 
    q = buf;
 740 
    q = buf;
737 
    while ((*q = *p) != '\0') {
 741 
    while ((*q = *p) != '\0') {
- 
 
 742 
	if(PRIMVAL(op)) *q = tolower(*q);
738 
	p++;
 743 
	p++;
739 
	q++;
 744 
	q++;
740 
    }
 745 
    }
741 
#ifdef HAVE_F77_UNDERSCORE
 746 
#ifdef HAVE_F77_UNDERSCORE
742 
    if(PRIMVAL(op)) {
 747 
    if(PRIMVAL(op)) {
743 
	*q++ = '_';
 748 
	*q++ = '_';
744 
	*q = '\0';
 749 
	*q = '\0';
745 
    }
 750 
    }
746 
#endif
 751 
#endif
- 
 
 752 
#ifdef HAVE_F77_EXTRA_UNDERSCORE
- 
 
 753 
    p = CHAR(STRING_ELT(CAR(args), 0));
- 
 
 754 
    if(strchr(p, '_') && PRIMVAL(op)) {
- 
 
 755 
	*q++ = '_';
- 
 
 756 
	*q = '\0';
- 
 
 757 
    }
- 
 
 758 
#endif
747 
    return mkString(buf);
 759 
    return mkString(buf);
748 
}
 760 
}
749 
 
 761 
 
750 
SEXP attribute_hidden do_isloaded(SEXP call, SEXP op, SEXP args, SEXP env)
 762 
SEXP attribute_hidden do_isloaded(SEXP call, SEXP op, SEXP args, SEXP env)
751 
{
 763 
{