The R Project SVN R

Rev

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1
/*
26763 maechler 2
 *  R : A Computer Language for Statistical Data Analysis
2 r 3
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
26763 maechler 4
 *  Copyright (C) 1997--2002  The R Development Core Team
5
 *  Copyright (C) 2003	      The R Foundation
2 r 6
 *
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
9
 *  the Free Software Foundation; either version 2 of the License, or
10
 *  (at your option) any later version.
11
 *
12
 *  This program is distributed in the hope that it will be useful,
13
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
 *  GNU General Public License for more details.
16
 *
26763 maechler 17
 *  A copy of the GNU General Public License is available via WWW at
18
 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
19
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
20
 *  Suite 330, Boston, MA  02111-1307  USA.
2 r 21
 */
22
 
5187 hornik 23
#ifdef HAVE_CONFIG_H
7701 hornik 24
#include <config.h>
5187 hornik 25
#endif
26
 
2 r 27
#include <string.h>
28
#include <stdlib.h>
29
 
11499 ripley 30
#include <Defn.h>
31
#include <Rmath.h>
12778 pd 32
#include <Rdevices.h>
5187 hornik 33
 
14156 duncan 34
#include <R_ext/RConverters.h>
35
 
5730 ripley 36
#ifndef max
37
#define max(a, b) ((a > b)?(a):(b))
38
#endif
39
 
2 r 40
 
1839 ihaka 41
/* These are set during each call to do_dotCode() below. */
42
 
2 r 43
static SEXP NaokSymbol = NULL;
44
static SEXP DupSymbol = NULL;
6098 pd 45
static SEXP PkgSymbol = NULL;
2 r 46
 
30691 murdoch 47
/* Global variable that should go. Should actually be doing this in a much more straightforward manner. */
48
#include <Rdynpriv.h>
49
enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};
50
typedef struct {
51
    char DLLname[PATH_MAX];
52
    HINSTANCE dll;
53
    SEXP  obj;
54
    int type;
55
} DllReference;
6098 pd 56
 
30691 murdoch 57
 
14156 duncan 58
/* This looks up entry points in DLLs in a platform specific way. */
15776 hornik 59
#include <Rdynpriv.h>
2 r 60
 
30691 murdoch 61
#define MAX_ARGS 65
62
 
63
static DL_FUNC R_FindNativeSymbolFromDLL(char *name, DllReference *dll, R_RegisteredNativeSymbol *symbol);
64
 
65
static SEXP naokfind(SEXP args, int * len, int *naok, int *dup, DllReference *dll);
66
static SEXP pkgtrim(SEXP args, DllReference *dll);
67
 
68
/*
69
  Checks whether the specified object correctly identifies a native routine.
70
  This can be  
71
   a) a string,
72
   b) an external pointer giving the address of the routine (e.g. getNativeSymbolInfo("foo")$address)
73
   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
74
 */
75
static int
76
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun)
77
{
78
    if (isValidString(op))
79
	return(0);
80
 
81
    else if((TYPEOF(op) == EXTPTRSXP && R_ExternalPtrTag(op) == Rf_install("native symbol"))) {
82
 
83
	if((*fun = R_ExternalPtrAddr(op)) == NULL) 
84
	    errorcall(call, "NULL value passed as symbol address.");
85
	return(0);
86
 
87
    } else if(inherits(op, "NativeSymbolInfo")) {
88
 
89
	return(checkValidSymbolId(VECTOR_ELT(op, 1), call, fun));
90
 
91
    }
92
 
93
    errorcall(call, "function name must be a string (of length 1) or native symbol reference.");
94
    return(0);
95
}
96
 
97
 
98
/*
99
  This is the routine that is called by do_dotCode, do_dotcall and do_External
100
  to find the DL_FUNC to invoke. It handles processing the arguments for the
101
  PACKAGE argument, if present, and also takes care of the cases where we are given
102
  a NativeSymbolInfo object, an address directly, and if the DLL is specified.
103
  If no PACKAGE is provided, we check whether the calling function is in a namespace
104
  and look there.
105
*/
106
SEXP
107
resolveNativeRoutine(SEXP args, DL_FUNC *fun, R_RegisteredNativeSymbol *symbol, char *buf, 
108
		     int *nargs, int *naok, int *dup, SEXP call)
109
{
110
    SEXP op;
111
    char *p, *q;
112
    DllReference dll = {"", NULL, NULL, NOT_DEFINED}; 
113
 
114
    op = CAR(args);
115
    checkValidSymbolId(op, call, fun);
116
 
117
    /* The following code modifies the argument list */
118
    /* We know this is ok because do_dotCode is entered */
119
    /* with its arguments evaluated. */
120
 
121
    strcpy(dll.DLLname, "");
122
    if(symbol->type == R_C_SYM || symbol->type == R_FORTRAN_SYM) {
123
	args = naokfind(CDR(args), nargs, naok, dup, &dll);
124
 
125
	if(*naok == NA_LOGICAL)
126
	    errorcall(call, "invalid naok value");
127
	if(*nargs > MAX_ARGS)
128
	    errorcall(call, "too many arguments in foreign function call");
129
    } else {
130
	if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");
131
	args = pkgtrim(args, &dll);
132
    }
133
 
134
    /* Make up the load symbol and look it up. */
135
 
136
    if(TYPEOF(op) == STRSXP) {
137
	p = CHAR(STRING_ELT(op, 0));
138
	q = buf;
139
	while ((*q = *p) != '\0') {
140
	    p++;
141
	    q++;
142
	}
143
    } 
144
 
145
    if(!*fun) {
146
	if(dll.type != FILENAME) {
147
	    *fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol);
148
	    if(!fun) {
149
		errorcall(call, "cannot resolve native routine");
150
	    }
151
	} 
152
 
153
	if (!*fun && !(*fun = R_FindSymbol(buf, dll.DLLname, symbol))) {
154
	    if(strlen(dll.DLLname))
155
		errorcall(call, "%s function name not in DLL for package %s",
156
			   symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", 
157
			   dll.DLLname);
158
	    else
159
		errorcall(call, "%s function name not in load table",
160
			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C"); 
161
	}
162
    }
163
 
164
    return(args);
165
}
166
 
167
 
168
 
5730 ripley 169
/* Convert an R object to a non-moveable C/Fortran object and return
170
   a pointer to it.  This leaves pointers for anything other
6098 pd 171
   than vectors and lists unaltered.
5730 ripley 172
*/
2 r 173
 
22284 duncan 174
static Rboolean
175
checkNativeType(int targetType, int actualType)
176
{
177
   if(targetType > 0) {
178
      if(targetType == INTSXP || targetType == LGLSXP) {
179
	  return(actualType == INTSXP || actualType == LGLSXP);
180
      }
181
      return(targetType == actualType);
182
   }
183
 
184
  return(TRUE);
185
}
186
 
187
 
188
 
20110 duncan 189
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter,
190
                          int targetType)
2 r 191
{
1839 ihaka 192
    int *iptr;
5769 ripley 193
    float *sptr;
1839 ihaka 194
    double *rptr;
5730 ripley 195
    char **cptr, *fptr;
6994 pd 196
    Rcomplex *zptr;
5769 ripley 197
    SEXP *lptr, CSingSymbol=install("Csingle");
1839 ihaka 198
    int i, l, n;
6098 pd 199
 
14156 duncan 200
    if(converter)
201
	*converter = NULL;
202
 
203
    if(length(getAttrib(s, R_ClassSymbol))) {
204
	R_CConvertInfo info;
205
	int success;
206
        void *ans;
207
 
208
	info.naok = naok;
209
	info.dup = dup;
210
	info.narg = narg;
211
	info.Fort = Fort;
212
        info.name = name;
213
 
214
	ans = Rf_convertToC(s, &info, &success, converter);
215
	if(success)
216
	    return(ans);
217
    }
218
 
22284 duncan 219
    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {
20110 duncan 220
     if(!dup) {
26763 maechler 221
       error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)",
22284 duncan 222
	     name, narg + 1, targetType, TYPEOF(s));
26763 maechler 223
     }
20110 duncan 224
 
26763 maechler 225
     if(targetType != SINGLESXP)
20110 duncan 226
        s = coerceVector(s, targetType);
227
    }
228
 
1839 ihaka 229
    switch(TYPEOF(s)) {
230
    case LGLSXP:
231
    case INTSXP:
232
	n = LENGTH(s);
233
	iptr = INTEGER(s);
234
	for (i = 0 ; i < n ; i++) {
235
	    if(!naok && iptr[i] == NA_INTEGER)
5730 ripley 236
		error("NAs in foreign function call (arg %d)", narg);
2 r 237
	}
1839 ihaka 238
	if (dup) {
239
	    iptr = (int*)R_alloc(n, sizeof(int));
240
	    for (i = 0 ; i < n ; i++)
241
		iptr[i] = INTEGER(s)[i];
242
	}
243
	return (void*)iptr;
244
	break;
245
    case REALSXP:
246
	n = LENGTH(s);
247
	rptr = REAL(s);
248
	for (i = 0 ; i < n ; i++) {
5107 maechler 249
	    if(!naok && !R_FINITE(rptr[i]))
5730 ripley 250
		error("NA/NaN/Inf in foreign function call (arg %d)", narg);
1839 ihaka 251
	}
252
	if (dup) {
5769 ripley 253
	    if(asLogical(getAttrib(s, CSingSymbol)) == 1) {
254
		sptr = (float*)R_alloc(n, sizeof(float));
255
		for (i = 0 ; i < n ; i++)
256
		    sptr[i] = (float) REAL(s)[i];
257
		return (void*)sptr;
258
	    } else {
259
		rptr = (double*)R_alloc(n, sizeof(double));
260
		for (i = 0 ; i < n ; i++)
261
		    rptr[i] = REAL(s)[i];
262
		return (void*)rptr;
263
	    }
264
	} else
265
	    return (void*)rptr;
1839 ihaka 266
	break;
267
    case CPLXSXP:
268
	n = LENGTH(s);
269
	zptr = COMPLEX(s);
270
	for (i = 0 ; i < n ; i++) {
5355 hornik 271
	    if(!naok && (!R_FINITE(zptr[i].r) || !R_FINITE(zptr[i].i)))
5730 ripley 272
		error("Complex NA/NaN/Inf in foreign function call (arg %d)", narg);
1839 ihaka 273
	}
274
	if (dup) {
6994 pd 275
	    zptr = (Rcomplex*)R_alloc(n, sizeof(Rcomplex));
1839 ihaka 276
	    for (i = 0 ; i < n ; i++)
277
		zptr[i] = COMPLEX(s)[i];
278
	}
279
	return (void*)zptr;
280
	break;
281
    case STRSXP:
282
	if(!dup)
5730 ripley 283
	    error("character variables must be duplicated in .C/.Fortran");
1839 ihaka 284
	n = LENGTH(s);
5730 ripley 285
	if(Fort) {
286
	    if(n > 1) warning("only first string in char vector used in .Fortran");
10172 luke 287
	    l = strlen(CHAR(STRING_ELT(s, 0)));
5730 ripley 288
	    fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));
10172 luke 289
	    strcpy(fptr, CHAR(STRING_ELT(s, 0)));
5730 ripley 290
	    return (void*)fptr;
291
	} else {
292
	    cptr = (char**)R_alloc(n, sizeof(char*));
293
	    for (i = 0 ; i < n ; i++) {
10172 luke 294
		l = strlen(CHAR(STRING_ELT(s, i)));
5730 ripley 295
		cptr[i] = (char*)R_alloc(l + 1, sizeof(char));
10172 luke 296
		strcpy(cptr[i], CHAR(STRING_ELT(s, i)));
5730 ripley 297
	    }
298
	    return (void*)cptr;
1839 ihaka 299
	}
300
	break;
301
    case VECSXP:
10172 luke 302
	if (!dup) return (void*)VECTOR_PTR(s); /***** Dangerous to GC!!! */
14156 duncan 303
  	n = length(s);
1839 ihaka 304
	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));
305
	for (i = 0 ; i < n ; i++) {
10172 luke 306
	    lptr[i] = VECTOR_ELT(s, i);
1839 ihaka 307
	}
14156 duncan 308
 	return (void*)lptr;
1839 ihaka 309
	break;
310
    case LISTSXP:
5730 ripley 311
	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
1839 ihaka 312
	/* Warning : The following looks like it could bite ... */
313
	if(!dup) return (void*)s;
314
	n = length(s);
315
	cptr = (char**)R_alloc(n, sizeof(char*));
316
	for(i=0 ; i<n ; i++) {
317
	    cptr[i] = (char*)s;
318
	    s = CDR(s);
319
	}
320
	return (void*)cptr;
321
	break;
322
    default:
5730 ripley 323
	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
1839 ihaka 324
	return (void*)s;
325
    }
2 r 326
}
327
 
14156 duncan 328
 
20110 duncan 329
static SEXP CPtrToRObj(void *p, SEXP arg, int Fort, R_NativePrimitiveArgType type)
2 r 330
{
5769 ripley 331
    int *iptr, n=length(arg);
332
    float *sptr;
1839 ihaka 333
    double *rptr;
5730 ripley 334
    char **cptr, buf[256];
6994 pd 335
    Rcomplex *zptr;
5769 ripley 336
    SEXP *lptr, CSingSymbol = install("Csingle");
1839 ihaka 337
    int i;
338
    SEXP s, t;
6098 pd 339
 
1839 ihaka 340
    switch(type) {
341
    case LGLSXP:
342
    case INTSXP:
343
	s = allocVector(type, n);
344
	iptr = (int*)p;
26763 maechler 345
	for(i=0 ; i<n ; i++)
20110 duncan 346
            INTEGER(s)[i] = iptr[i];
1839 ihaka 347
	break;
348
    case REALSXP:
20110 duncan 349
    case SINGLESXP:
350
	s = allocVector(REALSXP, n);
351
	if(type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
5769 ripley 352
	    sptr = (float*) p;
353
	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];
354
	} else {
355
	    rptr = (double*) p;
356
	    for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];
1839 ihaka 357
	}
358
	break;
359
    case CPLXSXP:
360
	s = allocVector(type, n);
6994 pd 361
	zptr = (Rcomplex*)p;
1839 ihaka 362
	for(i=0 ; i<n ; i++) {
363
	    COMPLEX(s)[i] = zptr[i];
364
	}
365
	break;
366
    case STRSXP:
5730 ripley 367
	if(Fort) {
368
	    /* only return one string: warned on the R -> Fortran step */
369
	    strncpy(buf, (char*)p, 255);
26418 rgentlem 370
	    buf[255] = '\0';
5730 ripley 371
	    PROTECT(s = allocVector(type, 1));
10172 luke 372
	    SET_STRING_ELT(s, 0, mkChar(buf));
5730 ripley 373
	    UNPROTECT(1);
374
	} else {
375
	    PROTECT(s = allocVector(type, n));
376
	    cptr = (char**)p;
377
	    for(i = 0 ; i < n ; i++) {
10172 luke 378
		SET_STRING_ELT(s, i, mkChar(cptr[i]));
5730 ripley 379
	    }
380
	    UNPROTECT(1);
1839 ihaka 381
	}
382
	break;
383
    case VECSXP:
384
	PROTECT(s = allocVector(VECSXP, n));
385
	lptr = (SEXP*)p;
386
	for (i = 0 ; i < n ; i++) {
10172 luke 387
	    SET_VECTOR_ELT(s, i, lptr[i]);
1839 ihaka 388
	}
389
	UNPROTECT(1);
390
	break;
391
    case LISTSXP:
392
	PROTECT(t = s = allocList(n));
393
	lptr = (SEXP*)p;
394
	for(i=0 ; i<n ; i++) {
10172 luke 395
	    SETCAR(t, lptr[i]);
1839 ihaka 396
	    t = CDR(t);
397
	}
398
	UNPROTECT(1);
399
    default:
400
	s = (SEXP)p;
401
    }
402
    return s;
2 r 403
}
404
 
26763 maechler 405
#define THROW_REGISTRATION_TYPE_ERROR
406
 
20110 duncan 407
#ifdef THROW_REGISTRATION_TYPE_ERROR
408
static Rboolean
409
comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)
410
{
22284 duncan 411
   if(type == ANYSXP || TYPEOF(s) == type)
20110 duncan 412
      return(TRUE);
2 r 413
 
20110 duncan 414
   if(dup && type == SINGLESXP)
415
      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);
416
 
417
   return(FALSE);
418
}
419
#endif /* end of THROW_REGISTRATION_TYPE_ERROR */
420
 
421
 
1839 ihaka 422
/* Foreign Function Interface.  This code allows a user to call C */
423
/* or Fortran code which is either statically or dynamically linked. */
2 r 424
 
6098 pd 425
/* NB: despite its name, this leaves NAOK and DUP arguments on the list */
2 r 426
 
6098 pd 427
/* find NAOK and DUP, find and remove PACKAGE */
30691 murdoch 428
static SEXP naokfind(SEXP args, int * len, int *naok, int *dup, DllReference *dll)
6098 pd 429
{
14571 duncan 430
    SEXP s, prev;
6098 pd 431
    int nargs=0, naokused=0, dupused=0, pkgused=0;
18560 ripley 432
    char *p;
26763 maechler 433
 
6098 pd 434
    *naok = 0;
435
    *dup = 1;
436
    *len = 0;
14571 duncan 437
    for(s = args, prev=args; s != R_NilValue;) {
6098 pd 438
	if(TAG(s) == NaokSymbol) {
439
	    *naok = asLogical(CAR(s));
14571 duncan 440
	    /* SETCDR(prev, s = CDR(s)); */
6098 pd 441
	    if(naokused++ == 1) warning("NAOK used more than once");
442
	} else if(TAG(s) == DupSymbol) {
443
	    *dup = asLogical(CAR(s));
14571 duncan 444
	    /* SETCDR(prev, s = CDR(s)); */
6098 pd 445
	    if(dupused++ == 1) warning("DUP used more than once");
14571 duncan 446
	} else if(TAG(s) == PkgSymbol) {
30691 murdoch 447
	    dll->obj = CAR(s);
448
	    if(TYPEOF(CAR(s)) == STRSXP) {
449
		p = CHAR(STRING_ELT(CAR(s), 0));
450
		if(strlen(p) > PATH_MAX - 1)
451
		    error("DLL name is too long");
452
		dll->type = FILENAME;
453
		strcpy(dll->DLLname, p);
454
		if(pkgused++ > 1) warning("PACKAGE used more than once");
455
		/* More generally, this should allow us to process
456
		   any additional arguments and not insist that PACKAGE
457
		   be the last argument.
458
		*/
459
	    } else {
460
		    /* Have a DLL object*/
461
	        if(TYPEOF(CAR(s)) == EXTPTRSXP) {
462
		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));
463
		    dll->type = DLL_HANDLE;
464
		} else if(TYPEOF(CAR(s)) == VECSXP) {
465
		    dll->type = R_OBJECT;
466
		    dll->obj = s;
467
		    strcpy(dll->DLLname, CHAR(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));
468
		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));
469
		}
470
	    }
17794 duncan 471
	} else {
472
	    nargs++;
473
	    prev = s;
474
	    s = CDR(s);
475
	    continue;
476
	}
26763 maechler 477
	if(s == args)
17794 duncan 478
	    args = s = CDR(s);
26763 maechler 479
	else
17794 duncan 480
	    SETCDR(prev, s = CDR(s));
6098 pd 481
    }
482
    *len = nargs;
483
    return args;
484
}
485
 
30691 murdoch 486
static void setDLLname(SEXP s, char *DLLname)
18560 ripley 487
{
488
    SEXP ss = CAR(s); char *name;
489
    if(TYPEOF(ss) != STRSXP || length(ss) != 1)
490
	error("PACKAGE argument must be a single character string");
491
    name = CHAR(STRING_ELT(ss, 0));
492
    /* allow the package: form of the name, as returned by find */
493
    if(strncmp(name, "package:", 8) == 0)
494
	name += 8;
495
    if(strlen(name) > PATH_MAX - 1)
496
	error("PACKAGE argument is too long");
497
    strcpy(DLLname, name);
14018 jmc 498
}
499
 
30691 murdoch 500
static SEXP pkgtrim(SEXP args, DllReference *dll)
6098 pd 501
{
502
    SEXP s, ss;
503
    int pkgused=0;
504
 
505
    for(s = args ; s != R_NilValue;) {
506
	ss = CDR(s);
507
	/* Look for PACKAGE=. We look at the next arg, unless
508
	   this is the last one (which will only happen for one arg),
509
	   and remove it */
510
	if(ss == R_NilValue && TAG(s) == PkgSymbol) {
511
	    if(pkgused++ == 1) warning("PACKAGE used more than once");
30691 murdoch 512
	    setDLLname(s, dll->DLLname);
513
	    dll->type = FILENAME;
6098 pd 514
	    return R_NilValue;
515
	}
516
	if(TAG(ss) == PkgSymbol) {
517
	    if(pkgused++ == 1) warning("PACKAGE used more than once");
30691 murdoch 518
	    setDLLname(ss, dll->DLLname);
519
	    dll->type = FILENAME;
10172 luke 520
	    SETCDR(s, CDR(ss));
6098 pd 521
	}
522
	s = CDR(s);
523
    }
524
    return args;
525
}
526
 
2 r 527
 
30691 murdoch 528
 
2 r 529
SEXP do_symbol(SEXP call, SEXP op, SEXP args, SEXP env)
530
{
1839 ihaka 531
    char buf[128], *p, *q;
532
    checkArity(op, args);
6098 pd 533
    if(!isValidString(CAR(args)))
9147 maechler 534
	errorcall(call, R_MSG_IA);
10172 luke 535
    p = CHAR(STRING_ELT(CAR(args), 0));
1839 ihaka 536
    q = buf;
537
    while ((*q = *p) != '\0') {
538
	p++;
539
	q++;
540
    }
2 r 541
#ifdef HAVE_F77_UNDERSCORE
1839 ihaka 542
    if(PRIMVAL(op)) {
543
	*q++ = '_';
544
	*q = '\0';
545
    }
2 r 546
#endif
1839 ihaka 547
    return mkString(buf);
2 r 548
}
549
 
550
SEXP do_isloaded(SEXP call, SEXP op, SEXP args, SEXP env)
551
{
1839 ihaka 552
    SEXP ans;
14577 ripley 553
    char *sym, *pkg= "";
554
    int val = 1, nargs = length(args);
555
 
556
    if (nargs < 1) errorcall(call, "no arguments supplied");
557
    if (nargs > 2) errorcall(call, "too many arguments");
558
 
6098 pd 559
    if(!isValidString(CAR(args)))
9147 maechler 560
	errorcall(call, R_MSG_IA);
10172 luke 561
    sym = CHAR(STRING_ELT(CAR(args), 0));
14577 ripley 562
    if(nargs == 2) {
563
	if(!isValidString(CADR(args)))
564
	    errorcall(call, R_MSG_IA);
565
	pkg = CHAR(STRING_ELT(CADR(args), 0));
566
    }
567
    if (!(R_FindSymbol(sym, pkg, NULL))) val = 0;
1839 ihaka 568
    ans = allocVector(LGLSXP, 1);
569
    LOGICAL(ans)[0] = val;
570
    return ans;
2 r 571
}
572
 
3822 thomas 573
/*   Call dynamically loaded "internal" functions */
574
/*   code by Jean Meloche <jean@stat.ubc.ca> */
575
 
576
SEXP do_External(SEXP call, SEXP op, SEXP args, SEXP env)
577
{
30691 murdoch 578
    DL_FUNC fun = NULL;
6098 pd 579
    SEXP retval;
17164 duncan 580
    R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};
6098 pd 581
    /* I don't like this messing with vmax <TSL> */
582
    /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
30691 murdoch 583
    char *vmax = vmaxget(), buf[128];
3822 thomas 584
 
30691 murdoch 585
    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL, NULL, call);
3822 thomas 586
 
30691 murdoch 587
    /* Some external symbols that are registered may have 0 as the expected number of arguments.
588
       We may want a warning here. However, the number of values may vary across calls
589
       and that is why people use the .External() mechanism.  So perhaps we should just kill this 
590
       check. */
591
#ifdef CHECK_EXTERNAL_ARG_COUNT         /* Off by default. */
14571 duncan 592
    if(symbol.symbol.external && symbol.symbol.external->numArgs > -1) {
593
	if(symbol.symbol.external->numArgs != length(args))
26763 maechler 594
	    error("Incorrect number of arguments (%d), expecting %d for %s",
14571 duncan 595
		  length(args), symbol.symbol.external->numArgs, CHAR(STRING_ELT(op, 0)));
596
    }
30691 murdoch 597
#endif
598
 
6098 pd 599
    retval = (SEXP)fun(args);
600
    vmaxset(vmax);
601
    return retval;
3822 thomas 602
}
603
 
10983 ihaka 604
 
6098 pd 605
/* .Call(name, <args>) */
4855 ihaka 606
SEXP do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)
607
{
30691 murdoch 608
    DL_FUNC fun = NULL;
4855 ihaka 609
    SEXP retval, cargs[MAX_ARGS], pargs;
17164 duncan 610
    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
4855 ihaka 611
    int nargs;
4869 ihaka 612
    char *vmax = vmaxget();
30691 murdoch 613
    char buf[128];
6098 pd 614
 
30691 murdoch 615
    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL, NULL, call);
4855 ihaka 616
    args = CDR(args);
5231 hornik 617
 
4855 ihaka 618
    for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
619
        if (nargs == MAX_ARGS)
5730 ripley 620
            errorcall(call, "too many arguments in foreign function call");
4855 ihaka 621
	cargs[nargs] = CAR(pargs);
622
	nargs++;
623
    }
14571 duncan 624
    if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {
625
	if(symbol.symbol.call->numArgs != nargs)
26763 maechler 626
	    error("Incorrect number of arguments (%d), expecting %d for %s",
14571 duncan 627
		  nargs, symbol.symbol.call->numArgs, CHAR(STRING_ELT(op, 0)));
628
    }
5231 hornik 629
 
630
    retval = R_NilValue;	/* -Wall */
4855 ihaka 631
    switch (nargs) {
632
    case 0:
633
	retval = (SEXP)fun();
634
	break;
635
    case 1:
636
	retval = (SEXP)fun(cargs[0]);
637
	break;
638
    case 2:
639
	retval = (SEXP)fun(cargs[0], cargs[1]);
640
	break;
641
    case 3:
642
	retval = (SEXP)fun(cargs[0], cargs[1], cargs[2]);
643
	break;
644
    case 4:
645
	retval = (SEXP)fun(cargs[0], cargs[1], cargs[2], cargs[3]);
646
	break;
647
    case 5:
648
	retval = (SEXP)fun(
649
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4]);
650
	break;
651
    case 6:
652
	retval = (SEXP)fun(
653
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
654
	    cargs[5]);
655
	break;
656
    case 7:
657
	retval = (SEXP)fun(
658
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
659
	    cargs[5],  cargs[6]);
660
	break;
661
    case 8:
662
	retval = (SEXP)fun(
663
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
664
	    cargs[5],  cargs[6],  cargs[7]);
665
	break;
666
    case 9:
667
	retval = (SEXP)fun(
668
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
669
	    cargs[5],  cargs[6],  cargs[7],  cargs[8]);
670
	break;
671
    case 10:
672
	retval = (SEXP)fun(
673
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
674
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9]);
675
	break;
676
    case 11:
677
	retval = (SEXP)fun(
678
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
679
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
680
	    cargs[10]);
681
	break;
682
    case 12:
683
	retval = (SEXP)fun(
684
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
685
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
686
	    cargs[10], cargs[11]);
687
	break;
688
    case 13:
689
	retval = (SEXP)fun(
690
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
691
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
692
	    cargs[10], cargs[11], cargs[12]);
693
	break;
694
    case 14:
695
	retval = (SEXP)fun(
696
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
697
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
698
	    cargs[10], cargs[11], cargs[12], cargs[13]);
699
	break;
700
    case 15:
701
	retval = (SEXP)fun(
702
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
703
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
704
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14]);
705
	break;
706
    case 16:
707
	retval = (SEXP)fun(
708
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
709
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
710
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
711
	    cargs[15]);
712
	break;
713
    case 17:
714
	retval = (SEXP)fun(
715
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
716
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
717
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
718
	    cargs[15], cargs[16]);
719
	break;
720
    case 18:
721
	retval = (SEXP)fun(
722
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
723
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
724
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
725
	    cargs[15], cargs[16], cargs[17]);
726
	break;
727
    case 19:
728
	retval = (SEXP)fun(
729
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
730
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
731
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
732
	    cargs[15], cargs[16], cargs[17], cargs[18]);
733
	break;
734
    case 20:
735
	retval = (SEXP)fun(
736
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
737
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
738
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
739
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19]);
740
	break;
741
    case 21:
742
	retval = (SEXP)fun(
743
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
744
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
745
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
746
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
747
	    cargs[20]);
748
	break;
749
    case 22:
750
	retval = (SEXP)fun(
751
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
752
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
753
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
754
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
755
	    cargs[20], cargs[21]);
756
	break;
757
    case 23:
758
	retval = (SEXP)fun(
759
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
760
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
761
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
762
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
763
	    cargs[20], cargs[21], cargs[22]);
764
	break;
765
    case 24:
766
	retval = (SEXP)fun(
767
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
768
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
769
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
770
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
771
	    cargs[20], cargs[21], cargs[22], cargs[23]);
772
	break;
773
    case 25:
774
	retval = (SEXP)fun(
775
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
776
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
777
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
778
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
779
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24]);
780
	break;
781
    case 26:
782
	retval = (SEXP)fun(
783
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
784
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
785
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
786
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
787
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
788
	    cargs[25]);
789
	break;
790
    case 27:
791
	retval = (SEXP)fun(
792
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
793
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
794
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
795
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
796
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
797
	    cargs[25], cargs[26]);
798
	break;
799
    case 28:
800
	retval = (SEXP)fun(
801
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
802
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
803
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
804
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
805
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
806
	    cargs[25], cargs[26], cargs[27]);
807
	break;
808
    case 29:
809
	retval = (SEXP)fun(
810
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
811
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
812
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
813
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
814
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
815
	    cargs[25], cargs[26], cargs[27], cargs[28]);
816
	break;
817
    case 30:
818
	retval = (SEXP)fun(
819
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
820
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
821
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
822
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
823
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
824
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29]);
825
	break;
826
    case 31:
827
	retval = (SEXP)fun(
828
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
829
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
830
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
831
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
832
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
833
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
834
	    cargs[30]);
835
	break;
836
    case 32:
837
	retval = (SEXP)fun(
838
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
839
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
840
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
841
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
842
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
843
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
844
	    cargs[30], cargs[31]);
845
	break;
846
    case 33:
847
	retval = (SEXP)fun(
848
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
849
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
850
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
851
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
852
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
853
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
854
	    cargs[30], cargs[31], cargs[32]);
855
	break;
856
    case 34:
857
	retval = (SEXP)fun(
858
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
859
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
860
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
861
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
862
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
863
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
864
	    cargs[30], cargs[31], cargs[32], cargs[33]);
865
	break;
866
    case 35:
867
	retval = (SEXP)fun(
868
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
869
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
870
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
871
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
872
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
873
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
874
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34]);
875
	break;
876
    case 36:
877
	retval = (SEXP)fun(
878
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
879
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
880
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
881
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
882
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
883
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
884
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
885
	    cargs[35]);
886
	break;
887
    case 37:
888
	retval = (SEXP)fun(
889
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
890
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
891
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
892
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
893
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
894
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
895
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
896
	    cargs[35], cargs[36]);
897
	break;
898
    case 38:
899
	retval = (SEXP)fun(
900
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
901
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
902
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
903
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
904
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
905
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
906
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
907
	    cargs[35], cargs[36], cargs[37]);
908
	break;
909
    case 39:
910
	retval = (SEXP)fun(
911
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
912
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
913
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
914
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
915
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
916
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
917
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
918
	    cargs[35], cargs[36], cargs[37], cargs[38]);
919
	break;
920
    case 40:
921
	retval = (SEXP)fun(
922
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
923
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
924
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
925
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
926
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
927
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
928
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
929
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39]);
930
	break;
931
    case 41:
932
	retval = (SEXP)fun(
933
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
934
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
935
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
936
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
937
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
938
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
939
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
940
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
941
	    cargs[40]);
942
	break;
943
    case 42:
944
	retval = (SEXP)fun(
945
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
946
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
947
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
948
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
949
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
950
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
951
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
952
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
953
	    cargs[40], cargs[41]);
954
	break;
955
    case 43:
956
	retval = (SEXP)fun(
957
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
958
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
959
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
960
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
961
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
962
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
963
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
964
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
965
	    cargs[40], cargs[41], cargs[42]);
966
	break;
967
    case 44:
968
	retval = (SEXP)fun(
969
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
970
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
971
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
972
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
973
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
974
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
975
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
976
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
977
	    cargs[40], cargs[41], cargs[42], cargs[43]);
978
	break;
979
    case 45:
980
	retval = (SEXP)fun(
981
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
982
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
983
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
984
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
985
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
986
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
987
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
988
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
989
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44]);
990
	break;
991
    case 46:
992
	retval = (SEXP)fun(
993
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
994
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
995
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
996
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
997
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
998
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
999
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1000
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1001
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1002
	    cargs[45]);
1003
	break;
1004
    case 47:
1005
	retval = (SEXP)fun(
1006
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1007
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1008
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1009
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1010
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1011
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1012
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1013
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1014
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1015
	    cargs[45], cargs[46]);
1016
	break;
1017
    case 48:
1018
	retval = (SEXP)fun(
1019
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1020
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1021
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1022
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1023
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1024
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1025
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1026
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1027
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1028
	    cargs[45], cargs[46], cargs[47]);
1029
	break;
1030
    case 49:
1031
	retval = (SEXP)fun(
1032
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1033
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1034
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1035
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1036
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1037
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1038
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1039
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1040
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1041
	    cargs[45], cargs[46], cargs[47], cargs[48]);
1042
	break;
1043
    case 50:
1044
	retval = (SEXP)fun(
1045
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1046
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1047
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1048
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1049
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1050
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1051
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1052
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1053
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1054
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49]);
1055
	break;
1056
    case 51:
1057
	retval = (SEXP)fun(
1058
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1059
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1060
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1061
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1062
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1063
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1064
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1065
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1066
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1067
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1068
	    cargs[50]);
1069
	break;
1070
    case 52:
1071
	retval = (SEXP)fun(
1072
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1073
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1074
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1075
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1076
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1077
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1078
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1079
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1080
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1081
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1082
	    cargs[50], cargs[51]);
1083
	break;
1084
    case 53:
1085
	retval = (SEXP)fun(
1086
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1087
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1088
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1089
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1090
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1091
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1092
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1093
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1094
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1095
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1096
	    cargs[50], cargs[51], cargs[52]);
1097
	break;
1098
    case 54:
1099
	retval = (SEXP)fun(
1100
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1101
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1102
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1103
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1104
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1105
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1106
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1107
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1108
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1109
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1110
	    cargs[50], cargs[51], cargs[52], cargs[53]);
1111
	break;
1112
    case 55:
1113
	retval = (SEXP)fun(
1114
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1115
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1116
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1117
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1118
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1119
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1120
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1121
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1122
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1123
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1124
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54]);
1125
	break;
1126
    case 56:
1127
	retval = (SEXP)fun(
1128
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1129
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1130
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1131
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1132
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1133
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1134
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1135
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1136
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1137
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1138
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1139
	    cargs[55]);
1140
	break;
1141
    case 57:
1142
	retval = (SEXP)fun(
1143
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1144
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1145
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1146
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1147
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1148
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1149
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1150
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1151
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1152
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1153
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1154
	    cargs[55], cargs[56]);
1155
	break;
1156
    case 58:
1157
	retval = (SEXP)fun(
1158
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1159
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1160
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1161
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1162
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1163
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1164
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1165
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1166
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1167
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1168
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1169
	    cargs[55], cargs[56], cargs[57]);
1170
	break;
1171
    case 59:
1172
	retval = (SEXP)fun(
1173
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1174
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1175
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1176
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1177
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1178
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1179
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1180
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1181
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1182
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1183
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1184
	    cargs[55], cargs[56], cargs[57], cargs[58]);
1185
	break;
1186
    case 60:
1187
	retval = (SEXP)fun(
1188
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1189
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1190
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1191
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1192
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1193
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1194
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1195
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1196
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1197
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1198
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1199
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59]);
1200
	break;
1201
    case 61:
1202
	retval = (SEXP)fun(
1203
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1204
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1205
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1206
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1207
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1208
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1209
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1210
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1211
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1212
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1213
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1214
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1215
	    cargs[60]);
1216
	break;
1217
    case 62:
1218
	retval = (SEXP)fun(
1219
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1220
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1221
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1222
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1223
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1224
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1225
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1226
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1227
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1228
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1229
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1230
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1231
	    cargs[60], cargs[61]);
1232
	break;
1233
    case 63:
1234
	retval = (SEXP)fun(
1235
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1236
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1237
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1238
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1239
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1240
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1241
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1242
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1243
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1244
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1245
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1246
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1247
	    cargs[60], cargs[61], cargs[62]);
1248
	break;
1249
    case 64:
1250
	retval = (SEXP)fun(
1251
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1252
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1253
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1254
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1255
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1256
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1257
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1258
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1259
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1260
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1261
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1262
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1263
	    cargs[60], cargs[61], cargs[62], cargs[63]);
1264
	break;
1265
    case 65:
1266
	retval = (SEXP)fun(
1267
	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1268
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1269
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1270
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1271
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1272
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1273
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1274
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1275
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1276
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1277
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1278
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1279
	    cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);
1280
	break;
1281
    default:
5730 ripley 1282
	errorcall(call, "too many arguments, sorry");
4855 ihaka 1283
    }
4869 ihaka 1284
    vmaxset(vmax);
4855 ihaka 1285
    return retval;
1286
}
1287
 
10983 ihaka 1288
/*  Call dynamically loaded "internal" graphics functions */
1289
/*  .External.gr  and  .Call.gr */
1290
 
1291
SEXP do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)
1292
{
1293
    SEXP retval = do_External(call, op, args, env);
1294
    if (call != R_NilValue) {
1295
        DevDesc *dd = CurrentDevice();
1296
        GCheckState(dd);
1297
	recordGraphicOperation(op, args, dd);
1298
    }
1299
    return retval;
1300
}
1301
 
1302
SEXP do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)
1303
{
1304
    SEXP retval = do_dotcall(call, op, args, env);
1305
    if (call != R_NilValue) {
1306
        DevDesc *dd = CurrentDevice();
16950 murrell 1307
	GCheckState(dd);
10983 ihaka 1308
	recordGraphicOperation(op, args, dd);
1309
    }
1310
    return retval;
1311
}
1312
 
1313
 
30691 murdoch 1314
 
1315
static SEXP
1316
Rf_getCallingDLL()
1317
{
1318
    SEXP e, ans;
1319
    PROTECT(e = allocVector(LANGSXP, 1));
1320
    SETCAR(e, Rf_install("getCallingDLL"));
1321
    ans = eval(e,  R_GlobalEnv);
1322
 
1323
    UNPROTECT(1);
1324
    return(ans);
1325
}
1326
 
1327
 
1328
/*
1329
  We are given the PACKAGE argument in dll.obj
1330
  and we can try to figure out how to resolve this.
1331
  0) dll.obj is NULL.  Then find the environment of the 
1332
   calling function and if it is a namespace, get the 
1333
 
1334
  1) dll.obj is a DLLInfo object
1335
*/
1336
static DL_FUNC
1337
R_FindNativeSymbolFromDLL(char *name, DllReference *dll, R_RegisteredNativeSymbol *symbol)
1338
{
1339
    int numProtects = 0;
1340
    DllInfo *info;
1341
    DL_FUNC fun = NULL;
1342
 
1343
    if(dll->obj == NULL) {
1344
	dll->obj = Rf_getCallingDLL();
1345
	PROTECT(dll->obj); numProtects++;
1346
    }
1347
 
1348
    if(inherits(dll->obj, "DLLInfo")) {
1349
	SEXP tmp;
1350
/*XXX*/
1351
DL_FUNC R_dlsym(DllInfo *info, char const *name, R_RegisteredNativeSymbol *symbol);
1352
	tmp = VECTOR_ELT(dll->obj, 4);
1353
	info = (DllInfo *) R_ExternalPtrAddr(tmp);
1354
	if(!info) 
1355
	    error("NULL value for DLLInfoReference when looking for DLL");
1356
	fun = R_dlsym(info, name, symbol);
1357
    }
1358
 
1359
    if(numProtects)
1360
	UNPROTECT(numProtects);
1361
 
1362
    return(fun);
1363
}
1364
 
1365
 
1366
 
6098 pd 1367
/* .C() {op=0}  or  .Fortran() {op=1} */
2 r 1368
SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)
1369
{
1839 ihaka 1370
    void **cargs;
1371
    int dup, havenames, naok, nargs, which;
30691 murdoch 1372
    DL_FUNC fun = NULL;
1895 ihaka 1373
    SEXP ans, pargs, s;
20110 duncan 1374
    R_toCConverter  *argConverters[65]; /* the post-call converters back to R objects. */
17164 duncan 1375
    R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
20110 duncan 1376
    R_NativePrimitiveArgType *checkTypes = NULL;
1377
    R_NativeArgStyle *argStyles = NULL;
30691 murdoch 1378
    char *vmax, symName[128];
14571 duncan 1379
 
6098 pd 1380
    if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
1839 ihaka 1381
	NaokSymbol = install("NAOK");
1382
	DupSymbol = install("DUP");
6098 pd 1383
	PkgSymbol = install("PACKAGE");
1839 ihaka 1384
    }
1385
    vmax = vmaxget();
1386
    which = PRIMVAL(op);
14571 duncan 1387
    if(which)
1388
	symbol.type = R_FORTRAN_SYM;
1016 maechler 1389
 
30691 murdoch 1390
    args = resolveNativeRoutine(args, &fun, &symbol, symName, &nargs, &naok, &dup, call);
2 r 1391
 
14571 duncan 1392
    if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {
1393
	if(symbol.symbol.c->numArgs != nargs)
26763 maechler 1394
	    error("Incorrect number of arguments (%d), expecting %d for %s",
30691 murdoch 1395
		  nargs, symbol.symbol.c->numArgs, symName);
26763 maechler 1396
 
30691 murdoch 1397
	checkTypes = symbol.symbol.c->types;
1398
	argStyles = symbol.symbol.c->styles;
14571 duncan 1399
    }
14156 duncan 1400
 
30691 murdoch 1401
 
14156 duncan 1402
    /* Convert the arguments for use in foreign */
1403
    /* function calls.  Note that we copy twice */
1404
    /* once here, on the way into the call, and */
1405
    /* once below on the way out. */
14571 duncan 1406
    cargs = (void**)R_alloc(nargs, sizeof(void*));
14156 duncan 1407
    nargs = 0;
1408
    for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
20110 duncan 1409
#ifdef THROW_REGISTRATION_TYPE_ERROR
1410
        if(checkTypes && !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {
1411
            /* We can loop over all the arguments and report all the erroneous ones,
1412
               but then we would also want to avoid the conversions.
1413
               Also, in the future, we may just attempt to coerce the value
1414
               to the appropriate type. This is why we pass the checkTypes[nargs]
26763 maechler 1415
               value to RObjToCPtr(). We just have to sort out the ability to
20110 duncan 1416
               return the correct value which is complicated by dup, etc. */
30691 murdoch 1417
	    error("Wrong type for argument %d in call to %s", nargs+1, symName);
20110 duncan 1418
	}
1419
#endif
26763 maechler 1420
	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,
30691 murdoch 1421
				  which, symName, argConverters + nargs,
20110 duncan 1422
				  checkTypes ? checkTypes[nargs] : 0);
14156 duncan 1423
	nargs++;
1424
    }
1425
 
1426
 
1839 ihaka 1427
    switch (nargs) {
1428
    case 0:
1429
	/* Silicon graphics C chokes here */
1430
	/* if there is no argument to fun. */
1431
	fun(0);
1432
	break;
1433
    case 1:
1434
	fun(cargs[0]);
1435
	break;
1436
    case 2:
1437
	fun(cargs[0], cargs[1]);
1438
	break;
1439
    case 3:
1440
	fun(cargs[0], cargs[1], cargs[2]);
1441
	break;
1442
    case 4:
1443
	fun(cargs[0], cargs[1], cargs[2], cargs[3]);
1444
	break;
1445
    case 5:
1446
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4]);
1447
	break;
1448
    case 6:
1449
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1450
	    cargs[5]);
1451
	break;
1452
    case 7:
1453
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1454
	    cargs[5],  cargs[6]);
1455
	break;
1456
    case 8:
1457
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1458
	    cargs[5],  cargs[6],  cargs[7]);
1459
	break;
1460
    case 9:
1461
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1462
	    cargs[5],  cargs[6],  cargs[7],  cargs[8]);
1463
	break;
1464
    case 10:
1465
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1466
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9]);
1467
	break;
1468
    case 11:
1469
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1470
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1471
	    cargs[10]);
1472
	break;
1473
    case 12:
1474
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1475
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1476
	    cargs[10], cargs[11]);
1477
	break;
1478
    case 13:
1479
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1480
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1481
	    cargs[10], cargs[11], cargs[12]);
1482
	break;
1483
    case 14:
1484
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1485
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1486
	    cargs[10], cargs[11], cargs[12], cargs[13]);
1487
	break;
1488
    case 15:
1489
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1490
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1491
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14]);
1492
	break;
1493
    case 16:
1494
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1495
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1496
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1497
	    cargs[15]);
1498
	break;
1499
    case 17:
1500
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1501
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1502
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1503
	    cargs[15], cargs[16]);
1504
	break;
1505
    case 18:
1506
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1507
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1508
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1509
	    cargs[15], cargs[16], cargs[17]);
1510
	break;
1511
    case 19:
1512
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1513
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1514
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1515
	    cargs[15], cargs[16], cargs[17], cargs[18]);
1516
	break;
1517
    case 20:
1518
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1519
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1520
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1521
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19]);
1522
	break;
1523
    case 21:
1524
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1525
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1526
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1527
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1528
	    cargs[20]);
1529
	break;
1530
    case 22:
1531
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1532
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1533
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1534
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1535
	    cargs[20], cargs[21]);
1536
	break;
1537
    case 23:
1538
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1539
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1540
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1541
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1542
	    cargs[20], cargs[21], cargs[22]);
1543
	break;
1544
    case 24:
1545
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1546
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1547
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1548
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1549
	    cargs[20], cargs[21], cargs[22], cargs[23]);
1550
	break;
1551
    case 25:
1552
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1553
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1554
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1555
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1556
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24]);
1557
	break;
1558
    case 26:
1559
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1560
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1561
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1562
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1563
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1564
	    cargs[25]);
1565
	break;
1566
    case 27:
1567
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1568
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1569
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1570
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1571
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1572
	    cargs[25], cargs[26]);
1573
	break;
1574
    case 28:
1575
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1576
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1577
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1578
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1579
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1580
	    cargs[25], cargs[26], cargs[27]);
1581
	break;
1582
    case 29:
1583
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1584
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1585
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1586
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1587
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1588
	    cargs[25], cargs[26], cargs[27], cargs[28]);
1589
	break;
1590
    case 30:
1591
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1592
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1593
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1594
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1595
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1596
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29]);
1597
	break;
1598
    case 31:
1599
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1600
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1601
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1602
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1603
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1604
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1605
	    cargs[30]);
1606
	break;
1607
    case 32:
1608
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1609
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1610
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1611
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1612
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1613
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1614
	    cargs[30], cargs[31]);
1615
	break;
1616
    case 33:
1617
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1618
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1619
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1620
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1621
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1622
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1623
	    cargs[30], cargs[31], cargs[32]);
1624
	break;
1625
    case 34:
1626
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1627
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1628
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1629
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1630
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1631
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1632
	    cargs[30], cargs[31], cargs[32], cargs[33]);
1633
	break;
1634
    case 35:
1635
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1636
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1637
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1638
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1639
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1640
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1641
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34]);
1642
	break;
1643
    case 36:
1644
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1645
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1646
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1647
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1648
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1649
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1650
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1651
	    cargs[35]);
1652
	break;
1653
    case 37:
1654
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1655
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1656
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1657
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1658
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1659
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1660
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1661
	    cargs[35], cargs[36]);
1662
	break;
1663
    case 38:
1664
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1665
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1666
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1667
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1668
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1669
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1670
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1671
	    cargs[35], cargs[36], cargs[37]);
1672
	break;
1673
    case 39:
1674
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1675
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1676
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1677
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1678
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1679
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1680
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1681
	    cargs[35], cargs[36], cargs[37], cargs[38]);
1682
	break;
1683
    case 40:
1684
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1685
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1686
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1687
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1688
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1689
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1690
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1691
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39]);
1692
	break;
1693
    case 41:
1694
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1695
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1696
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1697
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1698
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1699
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1700
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1701
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1702
	    cargs[40]);
1703
	break;
1704
    case 42:
1705
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1706
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1707
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1708
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1709
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1710
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1711
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1712
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1713
	    cargs[40], cargs[41]);
1714
	break;
1715
    case 43:
1716
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1717
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1718
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1719
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1720
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1721
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1722
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1723
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1724
	    cargs[40], cargs[41], cargs[42]);
1725
	break;
1726
    case 44:
1727
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1728
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1729
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1730
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1731
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1732
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1733
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1734
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1735
	    cargs[40], cargs[41], cargs[42], cargs[43]);
1736
	break;
1737
    case 45:
1738
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1739
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1740
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1741
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1742
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1743
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1744
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1745
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1746
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44]);
1747
	break;
1748
    case 46:
1749
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1750
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1751
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1752
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1753
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1754
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1755
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1756
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1757
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1758
	    cargs[45]);
1759
	break;
1760
    case 47:
1761
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1762
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1763
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1764
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1765
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1766
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1767
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1768
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1769
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1770
	    cargs[45], cargs[46]);
1771
	break;
1772
    case 48:
1773
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1774
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1775
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1776
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1777
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1778
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1779
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1780
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1781
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1782
	    cargs[45], cargs[46], cargs[47]);
1783
	break;
1784
    case 49:
1785
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1786
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1787
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1788
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1789
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1790
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1791
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1792
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1793
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1794
	    cargs[45], cargs[46], cargs[47], cargs[48]);
1795
	break;
1796
    case 50:
1797
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1798
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1799
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1800
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1801
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1802
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1803
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1804
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1805
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1806
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49]);
1807
	break;
1808
    case 51:
1809
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1810
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1811
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1812
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1813
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1814
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1815
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1816
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1817
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1818
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1819
	    cargs[50]);
1820
	break;
1821
    case 52:
1822
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1823
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1824
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1825
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1826
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1827
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1828
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1829
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1830
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1831
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1832
	    cargs[50], cargs[51]);
1833
	break;
1834
    case 53:
1835
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1836
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1837
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1838
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1839
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1840
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1841
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1842
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1843
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1844
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1845
	    cargs[50], cargs[51], cargs[52]);
1846
	break;
1847
    case 54:
1848
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1849
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1850
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1851
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1852
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1853
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1854
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1855
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1856
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1857
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1858
	    cargs[50], cargs[51], cargs[52], cargs[53]);
1859
	break;
1860
    case 55:
1861
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1862
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1863
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1864
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1865
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1866
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1867
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1868
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1869
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1870
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1871
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54]);
1872
	break;
1873
    case 56:
1874
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1875
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1876
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1877
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1878
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1879
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1880
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1881
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1882
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1883
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1884
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1885
	    cargs[55]);
1886
	break;
1887
    case 57:
1888
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1889
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1890
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1891
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1892
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1893
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1894
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1895
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1896
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1897
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1898
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1899
	    cargs[55], cargs[56]);
1900
	break;
1901
    case 58:
1902
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1903
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1904
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1905
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1906
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1907
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1908
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1909
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1910
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1911
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1912
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1913
	    cargs[55], cargs[56], cargs[57]);
1914
	break;
1915
    case 59:
1916
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1917
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1918
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1919
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1920
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1921
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1922
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1923
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1924
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1925
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1926
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1927
	    cargs[55], cargs[56], cargs[57], cargs[58]);
1928
	break;
1929
    case 60:
1930
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1931
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1932
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1933
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1934
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1935
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1936
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1937
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1938
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1939
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1940
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1941
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59]);
1942
	break;
1943
    case 61:
1944
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1945
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1946
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1947
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1948
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1949
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1950
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1951
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1952
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1953
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1954
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1955
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1956
	    cargs[60]);
1957
	break;
1958
    case 62:
1959
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1960
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1961
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1962
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1963
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1964
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1965
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1966
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1967
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1968
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1969
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1970
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1971
	    cargs[60], cargs[61]);
1972
	break;
1973
    case 63:
1974
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1975
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1976
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1977
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1978
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1979
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1980
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1981
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1982
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1983
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1984
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
1985
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
1986
	    cargs[60], cargs[61], cargs[62]);
1987
	break;
1988
    case 64:
1989
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
1990
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
1991
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
1992
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
1993
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
1994
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
1995
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
1996
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
1997
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
1998
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
1999
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
2000
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
2001
	    cargs[60], cargs[61], cargs[62], cargs[63]);
2002
	break;
2003
    case 65:
2004
	fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
2005
	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
2006
	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
2007
	    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
2008
	    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
2009
	    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
2010
	    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34],
2011
	    cargs[35], cargs[36], cargs[37], cargs[38], cargs[39],
2012
	    cargs[40], cargs[41], cargs[42], cargs[43], cargs[44],
2013
	    cargs[45], cargs[46], cargs[47], cargs[48], cargs[49],
2014
	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
2015
	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
2016
	    cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);
2017
	break;
2018
    default:
5730 ripley 2019
	errorcall(call, "too many arguments, sorry");
1839 ihaka 2020
    }
2021
    PROTECT(ans = allocVector(VECSXP, nargs));
2022
    havenames = 0;
2023
    if (dup) {
14156 duncan 2024
	R_FromCConvertInfo info;
2025
	info.cargs = cargs;
2026
	info.allArgs = args;
2027
	info.nargs = nargs;
30691 murdoch 2028
	info.functionName = symName;
2 r 2029
	nargs = 0;
1839 ihaka 2030
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
20110 duncan 2031
	    if(argStyles && argStyles[nargs] == R_ARG_IN) {
2032
	        PROTECT(s = R_NilValue);
2033
	    } else if(argConverters[nargs]) {
14156 duncan 2034
                if(argConverters[nargs]->reverse) {
2035
		    info.argIndex = nargs;
26763 maechler 2036
		    s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),
14156 duncan 2037
                                                       &info, argConverters[nargs]);
2038
		} else
2039
		    s = R_NilValue;
2040
		PROTECT(s);
2041
	    } else {
26763 maechler 2042
		PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,
20110 duncan 2043
				       checkTypes ? checkTypes[nargs] : TYPEOF(CAR(pargs))));
14156 duncan 2044
		SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
2045
		SET_OBJECT(s, OBJECT(CAR(pargs)));
2046
	    }
1839 ihaka 2047
	    if (TAG(pargs) != R_NilValue)
2048
		havenames = 1;
10172 luke 2049
	    SET_VECTOR_ELT(ans, nargs, s);
1839 ihaka 2050
	    nargs++;
2051
	    UNPROTECT(1);
2 r 2052
	}
1839 ihaka 2053
    }
2054
    else {
2055
	nargs = 0;
2056
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
2057
	    if (TAG(pargs) != R_NilValue)
2058
		havenames = 1;
10172 luke 2059
	    SET_VECTOR_ELT(ans, nargs, CAR(pargs));
1839 ihaka 2060
	    nargs++;
2 r 2061
	}
1839 ihaka 2062
    }
2063
    if (havenames) {
1889 ihaka 2064
	SEXP names;
1839 ihaka 2065
	PROTECT(names = allocVector(STRSXP, nargs));
2066
	nargs = 0;
2067
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
2068
	    if (TAG(pargs) == R_NilValue)
10172 luke 2069
		SET_STRING_ELT(names, nargs++, R_BlankString);
1839 ihaka 2070
	    else
10172 luke 2071
		SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));
1839 ihaka 2072
        }
2073
	setAttrib(ans, R_NamesSymbol, names);
2074
	UNPROTECT(1);
2075
    }
2076
    UNPROTECT(1);
2077
    vmaxset(vmax);
2078
    return (ans);
2079
}
2 r 2080
 
3875 hornik 2081
/* FIXME : Must work out what happens here when we replace LISTSXP by
2082
   VECSXP. */
1016 maechler 2083
 
19912 duncan 2084
static const struct {
2085
    const char *name;
2086
    const SEXPTYPE type;
2 r 2087
}
1839 ihaka 2088
typeinfo[] = {
2089
    {"logical",	  LGLSXP },
2090
    {"integer",	  INTSXP },
2091
    {"double",	  REALSXP},
2092
    {"complex",	  CPLXSXP},
2093
    {"character", STRSXP },
2094
    {"list",	  VECSXP },
2095
    {NULL,	  0      }
2 r 2096
};
2097
 
2098
static int string2type(char *s)
2099
{
1839 ihaka 2100
    int i;
2101
    for (i = 0 ; typeinfo[i].name ; i++) {
2102
	if(!strcmp(typeinfo[i].name, s)) {
2103
	    return typeinfo[i].type;
2 r 2104
	}
1839 ihaka 2105
    }
5730 ripley 2106
    error("type \"%s\" not supported in interlanguage calls", s);
1839 ihaka 2107
    return 1; /* for -Wall */
2 r 2108
}
2109
 
2110
void call_R(char *func, long nargs, void **arguments, char **modes,
1839 ihaka 2111
	    long *lengths, char **names, long nres, char **results)
2 r 2112
{
1839 ihaka 2113
    SEXP call, pcall, s;
2114
    SEXPTYPE type;
2115
    int i, j, n;
9317 ripley 2116
 
1839 ihaka 2117
    if (!isFunction((SEXP)func))
5730 ripley 2118
	error("invalid function in call_R");
1839 ihaka 2119
    if (nargs < 0)
5730 ripley 2120
	error("invalid argument count in call_R");
1839 ihaka 2121
    if (nres < 0)
5730 ripley 2122
	error("invalid return value count in call_R");
1839 ihaka 2123
    PROTECT(pcall = call = allocList(nargs + 1));
10172 luke 2124
    SET_TYPEOF(call, LANGSXP);
2125
    SETCAR(pcall, (SEXP)func);
3865 pd 2126
    s = R_NilValue;		/* -Wall */
1839 ihaka 2127
    for (i = 0 ; i < nargs ; i++) {
2128
	pcall = CDR(pcall);
2129
	type = string2type(modes[i]);
2130
	switch(type) {
2 r 2131
	case LGLSXP:
2132
	case INTSXP:
10172 luke 2133
	    n = lengths[i];
2134
	    SETCAR(pcall, allocVector(type, n));
2135
	    memcpy(INTEGER(CAR(pcall)), arguments[i], n * sizeof(int));
1839 ihaka 2136
	    break;
2 r 2137
	case REALSXP:
10172 luke 2138
	    n = lengths[i];
2139
	    SETCAR(pcall, allocVector(REALSXP, n));
2140
	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(double));
1839 ihaka 2141
	    break;
2 r 2142
	case CPLXSXP:
10172 luke 2143
	    n = lengths[i];
2144
	    SETCAR(pcall, allocVector(CPLXSXP, n));
2145
	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(Rcomplex));
1839 ihaka 2146
	    break;
2 r 2147
	case STRSXP:
1839 ihaka 2148
	    n = lengths[i];
10172 luke 2149
	    SETCAR(pcall, allocVector(STRSXP, n));
2150
	    for (j = 0 ; j < n ; j++) {
2151
		char *str = (char*)(arguments[i]);
2152
		s = allocString(strlen(str));
2153
		SET_STRING_ELT(CAR(pcall), i, s);
2154
		strcpy(CHAR(s), str);
9317 ripley 2155
 	    }
1839 ihaka 2156
	    break;
2157
	    /* FIXME : This copy is unnecessary! */
9317 ripley 2158
	    /* FIXME : This is obviously incorrect so disable
1839 ihaka 2159
	case VECSXP:
2160
	    n = lengths[i];
10172 luke 2161
	    SETCAR(pcall, allocVector(VECSXP, n));
1839 ihaka 2162
	    for (j = 0 ; j < n ; j++) {
10172 luke 2163
		SET_VECTOR_ELT(s, i, (SEXP)(arguments[i]));
1839 ihaka 2164
	    }
9317 ripley 2165
	    break; */
2166
	default:
2167
	    error("Mode `%s' is not supported in call_R", modes[i]);
2 r 2168
	}
1839 ihaka 2169
	if(names && names[i])
10172 luke 2170
	    SET_TAG(pcall, install(names[i]));
2171
	SET_NAMED(CAR(pcall), 2);
1839 ihaka 2172
    }
2173
    PROTECT(s = eval(call, R_GlobalEnv));
2174
    switch(TYPEOF(s)) {
2175
    case LGLSXP:
2176
    case INTSXP:
2177
    case REALSXP:
2178
    case CPLXSXP:
2179
    case STRSXP:
2180
	if(nres > 0)
20110 duncan 2181
	    results[0] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL, 0);
1839 ihaka 2182
	break;
2183
    case VECSXP:
2184
	n = length(s);
2185
	if (nres < n) n = nres;
2186
	for (i = 0 ; i < n ; i++) {
20110 duncan 2187
	    results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0, (const char *)NULL, NULL, 0);
1839 ihaka 2188
	}
2189
	break;
2190
    case LISTSXP:
2191
	n = length(s);
2192
	if(nres < n) n = nres;
2193
	for(i=0 ; i<n ; i++) {
20110 duncan 2194
	    results[i] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL, 0);
1839 ihaka 2195
	    s = CDR(s);
2196
	}
2197
	break;
2198
    }
2199
    UNPROTECT(2);
2200
    return;
2 r 2201
}
2202
 
2203
void call_S(char *func, long nargs, void **arguments, char **modes,
1839 ihaka 2204
	    long *lengths, char **names, long nres, char **results)
2 r 2205
{
1839 ihaka 2206
    call_R(func, nargs, arguments, modes, lengths, names, nres, results);
2 r 2207
}