R-alpha: Better Dyn.load for HP-UX

Mike Meyer (mikem@stat.cmu.edu)
Fri, 07 Jun 1996 12:46:54 -0400


Message-Id: <199606071646.MAA08413@desire.stat.cmu.edu>
To: r-testers@stat.math.ethz.ch
Subject: R-alpha: Better Dyn.load for HP-UX
Date: Fri, 07 Jun 1996 12:46:54 -0400
From: Mike Meyer <mikem@stat.cmu.edu>

Luke Tierney wrote a dl emulation library for HP-UX.  Using this is
much cleaner (and clearer) than the hodgepodge of fixes I had
implented.   The following shar file  includes Luke's library,
dotcode.c (for all systems) and a minor change to the configure script.

R+R.  Just cd src and unshar.  

 --Mike

Mike Meyer, Department of Statistics, Carnegie Mellon University



# This is a shell archive.  Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by Mike Meyer <mikem@desire> on Fri Jun  7 12:44:10 1996
#
# This archive contains:
#	README.MMM		./configure		
#	./hpdl			./hpdl/Makefile		
#	./hpdl/README		./hpdl/dlfcn.c		
#	./hpdl/dlfcn.h		./hpdl/vsystem.c	
#	./Systems		./Systems/HP		
#	./Systems/HP.README	./main			
#	./main/dotcode.c	
#

LANG=""; export LANG
PATH=/bin:/usr/bin:$PATH; export PATH

echo x - README.MMM
cat >README.MMM <<'@EOF'
Here are the changes.

configure
	I changed it cat out Systems/$1.README, if it exists.  This is
        so that the installer can see machine specific instructions at
        configure time.

hpdl	A dl emulation library for the HP, from Luke Teirney

Systems/HP
	HP configuration, using hpdl dyn.loading

Systems/HP.README
	Instructions for compiling hpdl

main/dotcode.c
	Back to the base dotcode.c, with all my silly #ifdefs removed.

Enjoy, --Mike
@EOF

chmod 644 README.MMM

echo x - configure
cat >configure <<'@EOF'
case $# in
0)	echo
	echo Supported Platforms:
	echo
	ls Systems
	echo
	exit 0;;
esac

if [ ! -f Systems/$1 ]
then
	echo
	echo "ERROR: There is no configuration file for $1".
	echo
	echo "Check that you have typed your operating system name"
	echo "correctly.  Typing just \"configure\" will produce a"
	echo "list of supported systems.  If your system does not"
	echo "appear, you will have to create your own configuration"
	echo "file or modify an existing one."
	echo
	exit 0
fi

(cd blas; cat ../Systems/$1 Makefile.in > Makefile)
(cd eispack; cat ../Systems/$1 Makefile.in > Makefile)
(cd graphics; cat ../Systems/$1 Makefile.in > Makefile)
(cd linpack; cat ../Systems/$1 Makefile.in > Makefile)
(cd main; cat ../Systems/$1 Makefile.in > Makefile)
(cd math; cat ../Systems/$1 Makefile.in > Makefile)
(cd stat; cat ../Systems/$1 Makefile.in > Makefile)

if [ -f Systems/$1.README ]
then
	cat Systems/$1.README 
fi
@EOF

chmod 755 configure

echo mkdir - hpdl
mkdir hpdl

chmod 755 hpdl

echo x - hpdl/Makefile
cat >hpdl/Makefile <<'@EOF'
CFLAGS=-g -Aa +Z -I.

OBJS=dlfcn.o vsystem.o

LIBNAME=libdl.sl

libdl.sl: ${OBJS}
	ld -o ${LIBNAME} -b ${OBJS}

clean:
	rm -f *.o

cleanall: clean
	rm -f ${LIBNAME}
@EOF

chmod 644 hpdl/Makefile

echo x - hpdl/README
cat >hpdl/README <<'@EOF'
All good things come from Luke.  This code, from Luke Tierney.  One
minor modification for R by Mike Meyer.


This is a minimal implementation of the ELF-style shared library
access routines dlopen, dlclose, dlsym and dlerror. Also included is a
simple version of gettxt, which is not in HP-UX A.09.05 at least.
These seem adequate to get S up and running. You need to make the
library and install it and the include file someplace appropriate and
modify the S setup script for hp accordingly. Currently the SETUP.hp
script assumes the library and include file live in the directory
$SHOME/hpdl.

Also included is vsystem(), a vfork-based replacement for system().

Luke Tierney
School of Statistics
University of Minnesota
@EOF

chmod 644 hpdl/README

echo x - hpdl/dlfcn.c
cat >hpdl/dlfcn.c <<'@EOF'
#include <dlfcn.h>

/*
 * This is a minimal implementation of the ELF dlopen, dlclose, dlsym
 * and dlerror routines based on HP's shl_load, shl_unload and
 * shl_findsym. */

/*
 * Reference Counting.
 *
 * Empirically it looks like the HP routines do not mainain a
 * reference count, so I maintain one here.
 */

typedef struct lib_entry {
  shl_t handle;
  int count;
  struct lib_entry *next;
} *LibEntry;

#define lib_entry_handle(e) ((e)->handle)
#define lib_entry_count(e) ((e)->count)
#define lib_entry_next(e) ((e)->next)
#define set_lib_entry_handle(e,v) ((e)->handle = (v))
#define set_lib_entry_count(e,v) ((e)->count = (v))
#define set_lib_entry_next(e,v) ((e)->next = (v))
#define increment_lib_entry_count(e) ((e)->count++)
#define decrement_lib_entry_count(e) ((e)->count--)

static LibEntry Entries = NULL;

static LibEntry find_lib_entry(shl_t handle)
{
  LibEntry entry;

  for (entry = Entries; entry != NULL; entry = lib_entry_next(entry))
    if (lib_entry_handle(entry) == handle)
      return entry;
  return NULL;
}

static LibEntry new_lib_entry(shl_t handle)
{
  LibEntry entry;

  if ((entry = (LibEntry) malloc(sizeof(struct lib_entry))) != NULL) {
    set_lib_entry_handle(entry, handle);
    set_lib_entry_count(entry, 1);
    set_lib_entry_next(entry, Entries);
    Entries = entry;
  }
  return entry;
}

static void free_lib_entry(LibEntry entry)
{
  if (entry == Entries)
    Entries = lib_entry_next(entry);
  else {
    LibEntry last, next;
    for (last = Entries, next = lib_entry_next(last);
	 next != NULL;
	 last = next, next = lib_entry_next(last)) {
      if (entry == next) {
	set_lib_entry_next(last, lib_entry_next(entry));
	break;
      }
    }
  }
  free(entry);
}


/*
 * Error Handling.
 */

#define ERRBUFSIZE 1000

static char errbuf[ERRBUFSIZE];
static int dlerrno = 0;

char *dlerror(void)
{
  return dlerrno ? errbuf : NULL;
}


/*
 * Opening and Closing Liraries.
 */

void *dlopen(const char *fname, int mode)
{
  shl_t handle;
  LibEntry entry = NULL;
  
  dlerrno = 0;
  if (fname == NULL)
    handle = PROG_HANDLE;
  else {
    handle = shl_load(fname, mode, 0L);
    if (handle != NULL) {
      if ((entry = find_lib_entry(handle)) == NULL) {
	if ((entry = new_lib_entry(handle)) == NULL) {
	  shl_unload(handle);
	  handle = NULL;
	}
      }
      else
	increment_lib_entry_count(entry);
    }
    if (handle == NULL) {
      dlerrno = 1;
      sprintf(errbuf, "can't open %s", fname);
    }
  }
#ifdef DEBUG
  printf("opening library %s, handle = %x, count = %d\n",
	 fname, handle, entry ? lib_entry_count(entry) : -1);
  if (dlerrno) printf("%s\n", dlerror());
#endif
  return (void *) handle;
}

int dlclose(void *handle)
{
  LibEntry entry;
#ifdef DEBUG
  entry = find_lib_entry(handle);
  printf("closing library handle = %x, count = %d\n",
	 handle, entry ? lib_entry_count(entry) : -1);
#endif

  dlerrno = 0;
  if ((shl_t) handle == PROG_HANDLE)
    return 0; /* ignore attempts to close main program */
  else {

    if ((entry = find_lib_entry((shl_t) handle)) != NULL) {
      decrement_lib_entry_count(entry);
      if (lib_entry_count(entry) > 0)
	return 0;
      else {
	/* unload once reference count reaches zero */
	free_lib_entry(entry);
	if (shl_unload((shl_t) handle) == 0)
	  return 0;
      }
    }
    /* if you get to here, an error has occurred */
    dlerrno = 1;
    sprintf(errbuf, "attempt to close library failed");
#ifdef DEBUG
    printf("%s\n", dlerror());
#endif
    return -1;
  }
}


/*
 * Symbol Lookup.
 */

void *dlsym(void *handle, const char *name)
{
  void *f;
  shl_t myhandle;

  dlerrno = 0;
  myhandle = (handle == NULL) ? PROG_HANDLE : (shl_t) handle;

  /* name+1 used below because R&R prepend an underscore, not needed
     on HP's */

  if (shl_findsym(&myhandle, name+1, TYPE_PROCEDURE, &f) != 0) {
    dlerrno = 1;
    sprintf(errbuf, "symbol %s not found", name);
#ifdef DEBUG
    printf("symbol %s not found", name);
#endif

    f = NULL;
  }

  return(f);
}
@EOF

chmod 644 hpdl/dlfcn.c

echo x - hpdl/dlfcn.h
cat >hpdl/dlfcn.h <<'@EOF'
#include <dl.h>

#define RTLD_LAZY (BIND_DEFERRED | BIND_NONFATAL)

void *dlopen(const char *, int);
void *dlsym(void *, const char *);
int dlclose(void *);
char *dlerror(void);

@EOF

chmod 644 hpdl/dlfcn.h

echo x - hpdl/vsystem.c
cat >hpdl/vsystem.c <<'@EOF'
#include <stdlib.h>

/* A replacement for system() that uses vfork. S4 seems to get
   confused after using the regular system() but not with this one. */

int vsystem(const char *command)
{
  int pid, w, stat;
  if ((pid = vfork()) == 0) {
    execlp("/bin/posix/sh", "sh", "-c", command, 0);
    _exit(127);
  }
  while ((w = wait(&stat)) != pid && w != -1)
    ;
  if (w == -1)
    stat = -1;
  return stat;
}
@EOF

chmod 644 hpdl/vsystem.c

echo mkdir - Systems
mkdir Systems

chmod 755 Systems

echo x - Systems/HP
cat >Systems/HP <<'@EOF'
# Hewlett-Packard Unix Machines using X11R5
# This worked on on desire.stat.cmu.edu (thanks Mike!)
# Note the -Dno_f77_underscore

# System Dependencies
SYSTEM= -DHP -DUnix -Dno_f77_underscore -DSVIDArith -DProctime -DDLSupport 

# C Compiler and Options
CC= gcc
CFLAGS= -g -I../hpdl -I/usr/include/X11R5 $(SYSTEM)

# Fortran Compiler and Options (-E for Dynamic loading)
F77= f77
FFLAGS= -O 

# Yacc (Note: Bison does not work, get byacc).
YACC=yacc

# Command to Create Libraries from Object Files
MKLIB= ../tools/library.bsd

# Create an Executable from Objects and Libraries (-E for Dynamic loading)
LD= f77 -O -Wl,-E

# Libraries to Load Against
LIBS= -lm -ldld -Wl,-L,../hpdl -ldl /usr/lib/X11R5/libX11.a
@EOF

chmod 644 Systems/HP

echo x - Systems/HP.README
cat >Systems/HP.README <<'@EOF'
HP-UX specific instructions.  In order to build dynamic library support,
First
	cd hpdl
	make
	cd ..
and then continue with the regular make.
@EOF

chmod 644 Systems/HP.README

echo mkdir - main
mkdir main

chmod 755 main

echo x - main/dotcode.c
cat >main/dotcode.c <<'@EOF'
/*
 *  R : A Computer Langage for Statistical Data Analysis
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "Defn.h"
#include <string.h>
#include <stdlib.h>


#ifdef DLSupport

	/* This code adds dynamic loading of code to R.  It */
	/* replaces the original dotcode.c and contains code */
	/* from that file. This code should work on a system */
	/* that implements the Solaris dlopen interface */
	/* standard. Shared libraries are loaded by dlopen */
	/* and symbols are looked for by dlsym. Unloading of */
	/* code is not implemented. This code was developed */
	/* on ELF-Linux. */
	/* Modifications Copyright (C) 1996 Heiner Schwarte */
	/* Minor cleanup and bug fix (C) 1996 Ross Ihaka */


#include <dlfcn.h>

	/* The dlopen function returns a handle after successfully */
	/* loading a library. These handles are collected in a list. */

struct voidptrlist{
	void *ptr;
	struct voidptrlist *next;
};

static struct voidptrlist *list=NULL;

static void add_ptr(void *p)
{
	struct voidptrlist *tmp;
	if (p==NULL)
		return;
	tmp=(struct voidptrlist *)malloc(sizeof(struct voidptrlist));
	tmp->ptr=p;
	tmp->next=list;
	list=tmp;
}


	/* findDynProc checks whether one of the libraries */
	/* that have been loaded contains the symbol name and */
	/* returns a pointer to that symbol upon success. */

int (*findDynProc(char *name))()
{
	struct voidptrlist *tmp;
	void *fcnptr;
	char buf[64];

	sprintf(buf, "_%s", name);
	tmp = list;
	while(tmp != NULL){
		if((fcnptr = dlsym(tmp->ptr, buf)) != NULL)
			return fcnptr;
		tmp = tmp->next;
	}
	return NULL;
}


	/* do_dynload implements the R-Interface for the */
	/* loading of libraries */

#ifndef RTLD_LAZY
#define RTLD_LAZY 1
#endif

SEXP do_dynload(SEXP call, SEXP op, SEXP args, SEXP env)
{
	void *handle;
	char *error;
	checkArity(op,args);
	if (!isString(CAR(args)))
		errorcall(call, "character argument expected\n");
	handle = dlopen(CHAR(STRING(CAR(args))[0]), RTLD_LAZY);
	if(!handle) {
		error = dlerror();
		errorcall(call, error);
		free(error); 
	}
	add_ptr(handle);
	return R_NilValue;
}

#else

SEXP do_dynload(SEXP call, SEXP op, SEXP args, SEXP env)
{
	error("no dyn.load support in this R version\n");
}

#endif




#define NIL -1

typedef int (*FUNC) ();

typedef struct {
	char *name;
	FUNC func;
} CFunTabEntry;

#ifdef no_f77_underscore
# define F77_SUBROUTINE(x) int x ## ();
#else
# define F77_SUBROUTINE(x) int x ## _();
#endif
#define C_FUNCTION(x) int x ## ();
#include "dotcode.h"
#undef F77_SUBROUTINE
#undef C_FUNCTION

#ifdef no_f77_underscore
#define F77_SUBROUTINE(x) {#x, x},
#else
#define F77_SUBROUTINE(x) {#x ## "_", x ## _ },
#endif
#define C_FUNCTION(x) {#x, x },
static CFunTabEntry CFunTab[] =
{
#include "dotcode.h"
	{NULL, NULL}
};
#undef F77_SUBROUTINE
#undef C_FUNCTION


	/* HashTable stores name - pointer pairs. Open addressing */
	/* with linear probing is used. Sometimes the hashtable */
	/* will be expanded and reorganized. The implementation */
	/* is entirely elementary.  Possible sizes of the */
	/* table are 2^p+1 where p is a positive integer. */

static CFunTabEntry *HashTable;
static int HASHSIZE;
static int NumberElem;


static int HashCode(char *symbol)
{
	unsigned int  code=0;
	char *p = symbol;

	while (*p)
		code = 8 * code + *p++;
	return code % HASHSIZE;
}


static void HashInstall(char *name, FUNC func)
{
	int key;
	NumberElem++;
	key = HashCode(name);
	while (HashTable[key].name != NULL)
		key = (key + 1) % HASHSIZE;
	HashTable[key].name = (char*)malloc(strlen(name)+1);
	strcpy(HashTable[key].name,name);
	HashTable[key].func = func;
}

static void HashExpand()
{
	int oldsize;
	int i;
	CFunTabEntry *OldTable;
	oldsize=HASHSIZE;
	OldTable=HashTable;
	HASHSIZE=2*HASHSIZE-1;
	NumberElem=0;
	HashTable = (CFunTabEntry *) malloc(HASHSIZE * sizeof(CFunTabEntry));
	for (i = 0; i < HASHSIZE; i++)
		HashTable[i].name = NULL;
	for(i=0;i<oldsize;i++) {
		if(OldTable[i].name!=NULL)
			HashInstall(OldTable[i].name,OldTable[i].func);
	}	
	for(i=0;i<oldsize;i++)
		free(OldTable[i].name);
	free(OldTable);
}

static FUNC HashLookup(char *symbol)
{
	int key;
	key = HashCode(symbol);
	while (HashTable[key].name != NULL) {
		if (strcmp(symbol, HashTable[key].name) == 0)
			return HashTable[key].func;
		else
			key = (key + 1) % HASHSIZE;
	}
	return NULL;
}


	/* Initialization of the hashed load table */

static SEXP NaokSymbol;

void InitFunctionHashing()
{
	int n;
	int i, size = 3;
	NaokSymbol = install("NAOK");
	n = sizeof(CFunTab)/sizeof(CFunTabEntry);
	while(size < n)
		size = 2*size-1;
	HASHSIZE = size;	
	NumberElem = 0;
	HashTable = (CFunTabEntry*) malloc(HASHSIZE * sizeof(CFunTabEntry));
	for (i = 0; i < HASHSIZE; i++)
		HashTable[i].name = NULL;
	for (i = 0; CFunTab[i].name; i++)
		HashInstall(CFunTab[i].name, CFunTab[i].func);
	HashExpand();
}

	/* Convert an R object to a non-moveable C object */
	/* and return a pointer to it.  This leaves pointers */
	/* for anything other than vectors and lists unaltered. */

static void *RObjToCPtr(SEXP s, int naok)
{
	int *iptr;
	double *rptr;
	char **cptr;
	int i, l, n;

	switch(TYPEOF(s)) {
		case LGLSXP:
		case FACTSXP:
		case ORDSXP:
		case INTSXP:
			n = LENGTH(s);
			iptr = (int*)R_alloc(n, sizeof(int));
			for(i=0 ; i<n ; i++) {
				iptr[i] = INTEGER(s)[i];
				if(!naok && iptr[i] == NA_INTEGER)
					error("NAs non permitted in
foreign function calls\n");
			}
			return (void*)iptr;
			break;
		case REALSXP:
			n = LENGTH(s);
			rptr = (double*)R_alloc(n, sizeof(double));
			for(i=0 ; i<n ; i++) {
				rptr[i] = REAL(s)[i];
				if(!naok && rptr[i] == NA_REAL)
					error("NAs non permitted in
foreign function calls\n");
			}
			return (void*)rptr;
			break;
		case STRSXP:
			n = LENGTH(s);
			cptr = (char**)R_alloc(n, sizeof(char*));
			for(i=0 ; i<n ; i++) {
				l = strlen(CHAR(STRING(s)[i]));
				cptr[i] = (char*)R_alloc(l+1, sizeof(char));
				strcpy(cptr[i], CHAR(STRING(s)[i]));
			}
			return (void*)cptr;
			break;
		case LISTSXP:
			n = length(s);
			cptr = (char**)R_alloc(n, sizeof(char*));
			for(i=0 ; i<n ; i++) {
				cptr[i] = (char*)s;
				s = CDR(s);
			}
			return (void*)cptr;
		default:
			return (char*)s;
	}
}

static SEXP CPtrToRObj(void *p, int n, SEXPTYPE type)
{
	int *iptr;
	double *rptr;
	char **cptr;
	SEXP *lptr;
	int i;
	SEXP s, t;

	switch(type) {
		case LGLSXP:
		case FACTSXP:
		case ORDSXP:
		case INTSXP:
			s = allocVector(type, n);
			iptr = (int*)p;
			for(i=0 ; i<n ; i++) {
				INTEGER(s)[i] = iptr[i];
			}
			break;
		case REALSXP:
			s = allocVector(type, n);
			rptr = (double*)p;
			for(i=0 ; i<n ; i++) {
				REAL(s)[i] = rptr[i];
			}
			break;
		case STRSXP:
			PROTECT(s = allocVector(type, n));
			cptr = (char**)p;
			for(i=0 ; i<n ; i++) {
				STRING(s)[i] = mkChar(cptr[i]);
			}
			UNPROTECT(1);
			break;
		case LISTSXP:
			PROTECT(t = s = allocList(n));
			lptr = (SEXP*)p;
			for(i=0 ; i<n ; i++) {
				CAR(t) = lptr[i];
				t = CDR(t);
			}
			UNPROTECT(1);
		default:
			s = (SEXP)p;
	}
	return s;
}

	/* Foreign Function Interface.  This code allows a */
	/* user to call C or Fortran code which is either */
	/* statically or dynamically linked into R. */


static SEXP naoktrim(SEXP s, int * len, int *naok)
{
	SEXP value;

	if(s == R_NilValue) {
		value = R_NilValue;
		*naok = 0;
		*len = 0;
	}
	else if(TAG(s) == NaokSymbol) {
		value = naoktrim(CDR(s), len, naok);
		*naok = asLogical(CAR(s));
	}
	else {
		CDR(s) = naoktrim(CDR(s), len, naok);
		*len = *len + 1;
	}
	return s;
}

#define MAX_ARGS 35

SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)
{
	void **cargs;
	int naok, nargs, which;
	FUNC fun;
	SEXP pargs, s;
	char buf[128], *p, *q, *vmax;
	
	vmax = vmaxget();
	which = PRIMVAL(op);

	op = CAR(args);
	if (!isString(op))
		errorcall(call, "function name must be a string\n");
	
	args = naoktrim(CDR(args), &nargs, &naok);
	if(naok == NA_LOGICAL)
		errorcall(call, "invalid naok value\n");
	if(nargs > MAX_ARGS)
		errorcall(call, "too many arguments in foreign function call\n");
	cargs = (void**)R_alloc(nargs, sizeof(void*));
	
		/* Convert the arguments for use in foreign */
		/* function calls.  Note that we copy twice */
		/* once here, on the way into the call, and */
		/* once below on the way out. */

	nargs = 0;
	for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
		cargs[nargs++] = RObjToCPtr(CAR(pargs), naok);
	}
	
	/* make up load symbol & look it up */
	
	p = CHAR(STRING(op)[0]);
	q = buf;
	while ((*q = *p) != '\0') {
		p++;
		q++;
	}
#ifdef no_f77_underscore
#else
	if (which)
		*q++ = '_';
	*q = '\0';
#endif
	if (!(fun = HashLookup(buf))){
#ifdef DLSupport
		if(!(fun = findDynProc(buf))) {
			errorcall(call, "C/Fortran function not in load table\n");
		}
		else {
			if((1.0*NumberElem)/HASHSIZE > 0.5)
				HashExpand();
			HashInstall(buf,fun);
		}
#else
		errorcall(call, "C/Fortran function not in load table\n");
#endif
	}
	
	switch (nargs) {
	case 0:
		/* Silicon graphics C chokes if there is */
		/* no argument to fun */
		fun(0);
		break;
	case 1:
		fun(cargs[0]);
		break;
	case 2:
		fun(cargs[0], cargs[1]);
		break;
	case 3:
		fun(cargs[0], cargs[1], cargs[2]);
		break;
	case 4:
		fun(cargs[0], cargs[1], cargs[2], cargs[3]);
		break;
	case 5:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4]);
		break;
	case 6:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5]);
		break;
	case 7:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6]);
		break;
	case 8:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7]);
		break;
	case 9:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8]);
		break;
	case 10:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9]);
		break;
	case 11:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10]);
		break;
	case 12:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11]);
		break;
	case 13:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12]);
		break;
	case 14:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13]);
		break;
	case 15:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14]);
		break;
	case 16:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15]);
		break;
	case 17:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16]);
		break;
	case 18:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17]);
		break;
	case 19:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18]);
		break;
	case 20:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19]);
		break;
	case 21:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20]);
		break;
	case 22:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21]);
		break;
	case 23:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22]);
		break;
	case 24:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23]);
		break;
	case 25:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24]);
		break;
	case 26:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25]);
		break;
	case 27:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26]);
		break;
	case 28:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27]);
		break;
	case 29:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28]);
		break;
	case 30:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29]);
		break;
	case 31:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
		    cargs[30]);
		break;
	case 32:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
		    cargs[30], cargs[31]);
		break;
	case 33:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
		    cargs[30], cargs[31], cargs[32]);
		break;
	case 34:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
		    cargs[30], cargs[31], cargs[32], cargs[33]);
		break;
	case 35:
		fun(cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],
		    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],
		    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],
		    cargs[15], cargs[16], cargs[17], cargs[18], cargs[19],
		    cargs[20], cargs[21], cargs[22], cargs[23], cargs[24],
		    cargs[25], cargs[26], cargs[27], cargs[28], cargs[29],
		    cargs[30], cargs[31], cargs[32], cargs[33], cargs[34]);
		break;
	default:
		errorcall(call, "too many arguments, sorry\n");
	}

	nargs = 0;
	for(pargs=args ; pargs != R_NilValue ; pargs=CDR(pargs)) {
		PROTECT(s = CPtrToRObj(cargs[nargs], LENGTH(CAR(pargs)),
				TYPEOF(CAR(pargs))));
		ATTRIB(s) = duplicate(ATTRIB(CAR(pargs)));
		CAR(pargs) = s;
		nargs++;
		UNPROTECT(1);
	}
	vmaxset(vmax);
	return (args);
}

static struct {
	char *name;
	SEXPTYPE type;
} typeinfo[] = {
	{"logical",	LGLSXP},
	{"integer",	INTSXP},
	{"double",	REALSXP},
	{"character",	STRSXP},
	{"list",	LISTSXP},
	{NULL,		0}
};

static int string2type(char *s)
{
	int i;
	for(i=0 ; typeinfo[i].name ; i++) {
		if(!strcmp(typeinfo[i].name, s)) {
			return typeinfo[i].type;
		}
	}
	error("type \"%s\" not supported in interlanguage calls\n", s);
}

void call_R(char *func, long nargs, void **arguments, char **modes,
	long *lengths, char **names, long nres, char **results)
{
	SEXP call, pcall, s;
	SEXPTYPE type;
	int i, j, n;

	if(!isFunction((SEXP)func))
		error("invalid function in call_R\n");
	if(nargs < 0)
		error("invalid argument count in call_R\n");
	if(nres < 0)
		error("invalid return value count in call_R\n");
	PROTECT(pcall = call = allocList(nargs+1));
	TYPEOF(call) = LANGSXP;
	CAR(pcall) = (SEXP)func;

	for(i=0 ; i<nargs ; i++) {
		pcall = CDR(pcall);
		type = string2type(modes[i]);
		switch(type) {
		case LGLSXP:
		case INTSXP:
			CAR(pcall) = allocSExp(type);
			INTEGER(CAR(pcall)) = (int*)(arguments[i]);
			LENGTH(CAR(pcall)) = lengths[i];
			break;
		case REALSXP:
			CAR(pcall) = allocSExp(REALSXP);
			REAL(CAR(pcall)) = (double*)(arguments[i]);
			LENGTH(CAR(pcall)) = lengths[i];
			break;
		case STRSXP:
			n = lengths[i];
			CAR(pcall) = allocVector(STRSXP, n);
			for(j=0 ; j<n ; j++) {
				s = allocSExp(CHARSXP);
				CHAR(s) = (char*)(arguments[i]);
				LENGTH(s) = strlen(CHAR(s));
				STRING(CAR(pcall))[i] = s;
			}
			break;
		case LISTSXP:
			n = lengths[i];
			CAR(pcall) = allocList(n);
			s = CAR(pcall);
			for(j=0 ; j<n ; j++) {
				CAR(s) = (SEXP)(arguments[i]);
				s = CDR(s);
			}
			break;
		}
		if(names && names[i])
			TAG(pcall) = install(names[i]);
		NAMED(CAR(pcall)) = 2;
	}

	PROTECT(s = eval(call, R_GlobalEnv));

	switch(TYPEOF(s)) {
	case LGLSXP:
	case INTSXP:
	case REALSXP:
	case STRSXP:
		if(nres > 0)
			results[0] = RObjToCPtr(s, 1);
		break;
	case LISTSXP:
		n = length(s);
		if(nres < n) n = nres;
		for(i=0 ; i<n ; i++) {
			results[i] = RObjToCPtr(s, 1);
			s = CDR(s);
		}
	}
	UNPROTECT(2);
	return;
}

void call_S(char *func, long nargs, void **arguments, char **modes,
	long *lengths, char **names, long nres, char **results)
{
	call_R(func, nargs, arguments, modes,
		lengths, names, nres, results);
}

@EOF

chmod 644 main/dotcode.c

exit 0
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-testers mailing list -- To (un)subscribe, send
subscribe	or	unsubscribe
(in the "body", not the subject !)  To: r-testers-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-