id.h

#ifndef __ID_H
#define __ID_H

struct __closure
{
  _imp_t	method;
  oop		data;
};

struct __lookup
{
  struct __closure *closure;
  oop		    state;
};

struct __libid
{
  /* bootstrap */

  dlhandle_t	 (*dlopen )(const char *path, int mode);
  void		*(*dlsym  )(dlhandle_t handle, const char *symbol);
  int		 (*dlclose)(dlhandle_t handle);

  void		  *unused03;
  void		  *unused04;
  void		  *unused05;
  void		  *unused06;
  void		  *unused07;

  /* globals */

  oop		  _object;
  oop		  tag_vtable;
  oop		  nil_vtable;

  void		  *unused11;
  void		  *unused12;
  void		  *unused13;
  void		  *unused14;
  void		  *unused15;

  /* allocation */

  oop		 (*intern)(const char *string);
  oop		 (*proto)(oop base);
  void		 (*method)(oop type, oop selector, _imp_t method);
  oop		 (*alloc)(oop type, size_t size);
  oop		*(*palloc)(size_t size);
  void		*(*balloc)(size_t size);

  void		  *unused22;
  void		  *unused23;

  /* environment */

  oop		 (*import)(const char *key);
  oop		 (*export)(const char *key, oop value);
  void		*(*param)(int index);

  void		  *unused27;
  void		  *unused28;
  void		  *unused29;
  void		  *unused30;
  void		  *unused31;

  /* messaging */

  struct __closure *(*bind )(oop selector, oop receiver);
  struct __lookup   (*bind2)(oop selector, oop receiver);

  void		  *unused34;
  void		  *unused35;

  oop		 (*nlreturn)(oop nlr, oop result);
  oop		 (*nlresult)(void);

  void		  *unused38;
  void		  *unused39;
  void		  *unused40;
  void		  *unused41;

  /* debugging */

  void		*(*enter)(char *name, char *type, char *file);
  void		 (*line)(int line);
  void		 (*leave)(void *cookie);
  char		*(*backtrace)(void);

  void		  *unused46;
  void		  *unused47;
  void		  *unused48;
  void		  *unused49;
  void		  *unused50;
  void		  *unused51;

  /* gc */

  void		 (*gc_addRoots)(char *low, char *high);
  void		 (*gc_gcollect)(void);
  int		 (*gc_generalRegisterDisappearingLink)(void **link, void *obj);
  int		 (*gc_unregisterDisappearingLink)(void **link);

  void		  *unused56;
  void		  *unused57;
  void		  *unused58;
  void		  *unused59;
  void		  *unused60;
  void		  *unused61;
  void		  *unused62;
  void		  *unused63;
};

#endif /* __ID_H */

libid.c

#include <stdio.h>					/* cum mortuis in lingua mortua */
#include <stdlib.h>
#include <stdarg.h>
#include <signal.h>
#include <setjmp.h>
#include <string.h>
#include <ctype.h>
#include <fcntl.h>
#include <unistd.h>
#include <errno.h>
#include <sys/time.h>
#include <sys/stat.h>
#include <sys/param.h>
#include <assert.h>
#if defined(WIN32)
# include <windows.h>
  typedef HINSTANCE dlhandle_t;
# define RTLD_DEFAULT	0
# define RTLD_LAZY	0
# define RTLD_GLOBAL	0
# define RTLD_NOW	0
  dlhandle_t  dlopen(const char *path, int mode);
  void	     *dlsym(dlhandle_t handle, const char *symbol);
  int	      dlclose(dlhandle_t handle);
#else
# include <dlfcn.h>
  typedef void *dlhandle_t;
#endif

#include "gc/gc.h"

#define GLOBAL_MCACHE	1
#define USE_GC		1
#define DEBUG_ALL	0

#if EMULATION
# undef	 USE_GC
# define USE_GC		0
#endif

#if DEBUG_ALL
# define dprintf(fmt, args...)  fprintf(stdout, fmt, ##args)
#else
# define dprintf(fmt, args...)
#endif

typedef struct t__object *oop;

typedef oop (*_imp_t)(oop closure, oop state, oop receiver, ...);

#include <id/id.h>

struct __libid	  *_libid_init    (int *argcp, char ***argvp, char ***envp);
oop  		   _libid_intern  (const char *string);
oop  		   _libid_proto   (oop base);
oop  		   _libid_import  (const char *name);
oop  		   _libid_export  (const char *name, oop value);
void 		   _libid_method  (oop type, oop selector, _imp_t method);
oop  		   _libid_alloc   (oop type, size_t size);
oop  		  *_libid_palloc  (size_t size);
void  		  *_libid_balloc  (size_t size);
void		   _libid_flush   (oop selector);
struct __closure  *_libid_bind    (oop selector, oop receiver);
struct __lookup    _libid_bind2   (oop selector, oop receiver);
oop                _libid_nlreturn(oop nlr, oop result);
oop                _libid_nlresult(void);
void		  *_libid_enter(char *name, char *type, char *file);
void		   _libid_line(int line);
void		   _libid_leave(void *cookie);
char		  *_libid_backtrace(void);

#define _send(MSG, RCV, ARG...) ({		\
  oop _r= (RCV);				\
  struct __closure *_c= _libid_bind((MSG), _r);	\
  (_c->method)((oop)_c, _r, _r, ##ARG);		\
})

static int    _argc= 0;
static char **_argv= 0;
static char **_envp= 0;

static oop s_methodAt_put_with_= 0;
static oop s__intern_= 0;
static oop s_init= 0;
static oop s_flush= 0;
static oop s_lookup_= 0;
static oop s_findKeyOrNil_= 0;
static oop s__delegated= 0;
static oop s__vtable= 0;
static oop s__alloc_= 0;
static oop s__beTagType= 0;
static oop s__beNilType= 0;
static oop s__import_= 0;
static oop s_doesNotUnderstand_= 0;
static oop s__delegate= 0;

typedef struct t__object   _object_t;
typedef struct t__selector _selector_t;
typedef struct t__closure  _closure_t;
typedef struct t__assoc    _assoc_t;
typedef struct t__vector   _vector_t;
typedef struct t__vtable   _vtable_t;

static struct __libid _libid;

struct t__selector
{
  size_t	 size;
  char	 	*elements;
};

static oop _selector_vtable= 0;
static oop _selector= 0;

struct t__assoc
{
  oop		 key;
  oop		 value;
};

static oop _assoc_vtable= 0;
static oop _assoc= 0;

struct t__closure
{
  oop		 method;
  oop		 data;
};

static oop _closure_vtable= 0;
static oop _closure= 0;

struct t__vector
{
  size_t	 size;
  oop		 elements[0];	/* INLINE */
};

static oop _vector_vtable= 0;
static oop _vector= 0;

struct t__vtable
{
  size_t	 tally;
  oop		 bindings;
  oop		 delegate;
};

static oop _vtable_vtable= 0;
static oop _vtable= 0;

struct t__object
{
  union {
    oop		_vtable[0];
    _closure_t	 closure;
    _selector_t	 selector;
    _assoc_t	 assoc;
    _vector_t	 vector;
    _vtable_t	 vtable;
  };
};

static oop _object_vtable= 0;
static oop _object= 0;

oop _libid_nil_vtable= 0;
oop _libid_tag_vtable= 0;

static oop _selector_Table= 0;
static oop _object_Table= 0;

struct __entry
{
  oop		 vtable;
  oop		 selector;
  _closure_t	*closure;
} _libid_mcache[1024];

#define isMemberOf(obj, type)	((0 == (obj)) || ((obj)->_vtable[-1] == type##_vtable))
#define isKindOf(obj, type)	((0 == (obj)) || ((obj)->_vtable[-1] == type##_vtable) || (_libid_isKindOf(obj, type##_vtable)))

#if !defined(NDEBUG)
static int _libid_isKindOf(oop obj, oop family)
{
  oop vt= obj->_vtable[-1];
  assert(vt);
  while ((vt= ((struct t__vtable *)vt)->delegate))
    if (vt == family) return 1;
  return 0;
}
#endif

static void fatal(const char *fmt, ...)
{
  va_list ap;
  va_start(ap, fmt);
  fflush(stdout);
  fputs("\n", stderr);
  vfprintf(stderr, fmt, ap);
  fputs("\n", stderr);
  va_end(ap);
  fputs(_libid_backtrace(), stderr);
  exit(1);
}

static oop _object__init(oop _thunk, oop state, oop self)
{
  assert(isMemberOf(self, _object));
  return self;
}

static oop _vector__init_(oop _thunk, oop state, oop self, size_t size)
{
  assert(isMemberOf(self, _vector));
  dprintf("_vector__init_(%p, %d)\n", self, (int)size);
  self->vector.size= size;
  return self;
}

static oop _assoc__init(oop _thunk, oop state, oop self)
{
  assert(isMemberOf(self, _assoc));
  self->assoc.key= 0;
  self->assoc.value= 0;
  return self;
}

static oop _closure__init(oop _thunk, oop state, oop self)
{
  assert(isMemberOf(self, _closure));
  self->closure.method= 0;
  self->closure.data= 0;
  return self;
}

static oop _selector__init_(oop _thunk, oop state, oop self, size_t size)
{
  assert(isMemberOf(self, _selector));
  self->selector.size= size;
  self->selector.elements= (char *)_libid_balloc(size);
  return self;
}

static oop _vtable___alloc_(oop _thunk, oop state, oop self, size_t size)
{
  oop *object= _libid_palloc(sizeof(_vtable_t *) + (size ? size : 1));
  assert(isKindOf(self, _vtable));
  dprintf("_vtable___alloc_(%p, %p, %p, %d) -> %p\n", _thunk, self, state, (int)size, object);
  if (!object) fatal("out of memory");
  *object++= self;
  dprintf("  object %p\n", object);
  return (oop)object;
}

// #define new(type)		type##__init(0, _vtable___alloc_(0, type##_vtable, sizeof(type##_t)))
// #define new__(type, xs, sz)	type##__init_(0, _vtable___alloc_(0, type##_vtable, sizeof(type##_t) + (xs)), sz)

#define new(type) ({									\
      oop obj= _vtable___alloc_(0, type##_vtable, type##_vtable, sizeof(type##_t));	\
      type##__init(0, obj, obj);							\
      obj;										\
})

#define new__(type, xs, sz) ({									\
      oop obj= _vtable___alloc_(0, type##_vtable, type##_vtable, sizeof(type##_t) + (xs));	\
      type##__init_(0, obj, obj, sz);								\
      obj;											\
})

static oop _vector__grow(oop _thunk, oop state, oop self)
{
  oop newVector= 0;
  int newSize= 0;
  assert(isMemberOf(self, _vector));
  dprintf("_vector__grow(%p, %p, %p)\n", _thunk, self, state);
  newSize= self->vector.size * 2;
  newVector= new__(_vector, sizeof(oop) * newSize, newSize);
  memcpy(newVector->vector.elements, self->vector.elements, sizeof(oop) * self->vector.size);
  return newVector;
}

static oop _vtable__init(oop _thunk, oop state, oop self)
{
  assert(isKindOf(self, _vtable));
  self->vtable.tally= 0;
  self->vtable.bindings= new__(_vector, 16, 4);
  self->vtable.delegate= 0;
  return self;
}

static oop _vtable__delegated(oop _thunk, oop state, oop self)
{
  oop vt= _vtable___alloc_(0, self->_vtable[-1], self->_vtable[-1], sizeof(_vtable_t));
  assert(isKindOf(self, _vtable));
  vt->vtable.tally= 0;
  vt->vtable.bindings= new__(_vector, 16, 4);
  vt->vtable.delegate= self;
  return vt;
}

static oop _object___vtable(oop _thunk, oop state, oop self)
{
  return self ? (((unsigned)self & 1) ? _libid_tag_vtable :  self->_vtable[-1]) : _libid_nil_vtable;
}

static oop _object___delegate(oop _thunk, oop state, oop self)
{
  return 0;
}

static oop _object___delegated(oop _thunk, oop state, oop self)
{
  oop obj= _vtable__delegated(0, self->_vtable[-1], self->_vtable[-1]);
  return _vtable___alloc_(0, obj, obj, 0);
}

static oop _vtable__findKeyOrNil_(oop _thunk, oop state, oop self, oop key)
{
  oop *assocs= self->vtable.bindings->vector.elements;
  size_t       i, tally= self->vtable.tally;
  assert(isKindOf(self, _vtable));
  for (i= tally;  i--;)
    if (assocs[i]->assoc.key == key)
      return assocs[i];
  return 0;
}

static oop _vtable__lookup_(oop _thunk, oop state, oop self, oop selector)
{
  oop assoc= 0;
  dprintf("_vtable__lookup_(%p, %p, %p, %p<%s>)\n", _thunk, self, state, selector, selector->selector.elements);
  assoc= _vtable__findKeyOrNil_(0, self, self, selector);
  assert(isKindOf(self, _vtable));
  if (assoc) return assoc;
  if (self->vtable.delegate)
    {
      if (self == self->vtable.delegate) fatal("delegation loop\n");
      return _vtable__lookup_(0, self->vtable.delegate, self->vtable.delegate, selector);
    }
  return 0;
}

static oop _vtable__add_(oop _thunk, oop state, oop self, oop object)
{
  assert(isKindOf(self, _vtable));
  if (self->vtable.tally == self->vtable.bindings->vector.size)
    self->vtable.bindings= _vector__grow(0, self->vtable.bindings, self->vtable.bindings);
  return self->vtable.bindings->vector.elements[self->vtable.tally++]= object;
}

static oop _vtable__methodAt_put_with_(oop _thunk, oop state, oop self, oop selector, oop method, oop data)
{
  oop assoc= _vtable__findKeyOrNil_(0, self, self, selector);
  dprintf("_vtable__methodAt_put_with_(%p, %p, %p, %p<%s>, %p, %p)\n", _thunk, self, state, selector, selector->selector.elements, method, data);
  assert(isKindOf(self, _vtable));
  if (!assoc)
    {
      assoc= new(_assoc);
      assoc->assoc.key= selector;
      assoc->assoc.value= new(_closure);
      _vtable__add_(0, self, self, assoc);
    }
  assoc->assoc.value->closure.method= method;
  assoc->assoc.value->closure.data= data;
  _libid_flush(selector);
  return assoc->assoc.value;
}

static oop _vtable__flush(oop _thunk, oop state, oop self)
{
#if GLOBAL_MCACHE
  memset(_libid_mcache, 0, sizeof(_libid_mcache));
#endif
  return self;
}

static oop _selector__withCString_(oop _thunk, oop state, oop self, const char *string)
{
  assert(isMemberOf(self, _selector));
  self= new__(_selector, 0, strlen(string) + 1);
  memcpy(self->selector.elements, string, self->selector.size);
  self->selector.size -= 1; /* crop the NUL */
  return self;
}

static oop _selector___intern_(oop _thunk, oop state, oop self, const char *string)
{
  oop *table= _selector_Table->vtable.bindings->vector.elements;
  size_t i= 0;
  assert(isMemberOf(self, _selector));
  dprintf("_selector___intern_(%p, %p, %p, \"%s\")\n", _thunk, self, state, string);
  for (i= 0;  i < _selector_Table->vtable.tally;  ++i)
    {
      /*dprintf("compare %s %s -> %d\n", string, table[i]->selector.elements, !strcmp(string, table[i]->selector.elements));*/
      if (!strcmp(string, table[i]->selector.elements))
	return table[i];
    }
  return _vtable__add_(0, _selector_Table, _selector_Table, _selector__withCString_(0, _selector, _selector, string));
}

static oop _object___beTagType(oop _thunk, oop state, oop self)
{
  return _libid_tag_vtable= _object___vtable(0, self, self);
}

static oop _object___beNilType(oop _thunk, oop state, oop self)
{
  return _libid_nil_vtable= _object___vtable(0, self, self);
}

#define ID_RTLD_FLAGS	RTLD_LAZY | RTLD_GLOBAL

static oop _object___import_(oop _thunk, oop state, oop self, char *fileName, char *initName)
{
  dlhandle_t lib= 0;
  void *init= 0;
  init= dlsym(RTLD_DEFAULT, initName);
  dprintf("dlsym RTLD_DEFAULT %s -> %p\n", initName, init);
  if (!init)
    {
      lib= dlopen(0, ID_RTLD_FLAGS);
      dprintf("1  dlopen 0 -> %p\n", lib);
      init= dlsym(lib, initName);
      dprintf("2  dlsym %p %s -> %p\n", lib, initName, init);
      dlclose(lib);
    }
  if (init)
    {
      dprintf("INTERNAL IMPORT <%s>\n", initName);
    }
  else
    {
      char  path[MAXPATHLEN];
      snprintf(path, MAXPATHLEN, "%s.so", fileName);
      lib= dlopen(path, ID_RTLD_FLAGS);
      dprintf("3  dlopen %s -> %p\n", path, lib);
      if (!lib)
	{
	  snprintf(path, MAXPATHLEN, "./%s.so", fileName);
	  lib= dlopen(path, ID_RTLD_FLAGS);
	  dprintf("4  dlopen %s -> %p\n", path, lib);
	}
      if (!lib)
	{
	  char *prefix;
	  if (!(prefix= getenv("IDC_LIBDIR"))) prefix= PREFIX;
	  snprintf(path, MAXPATHLEN, "%s%s.so", prefix, fileName);
	  lib= dlopen(path, ID_RTLD_FLAGS);
	  dprintf("5  dlopen %s -> %p\n", path, lib);
	}
#      if defined(WIN32)
      if (!lib)
	{
	  char *p;
	  for (p= path;  *p;  ++p)
	    if ('/' == *p) *p= '\\';
	  lib= dlopen(path, ID_RTLD_FLAGS);
	  dprintf("7  dlopen %s -> %p\n", path, lib);
	}
      if (!lib)
	{
	  snprintf(path, MAXPATHLEN, ".\\%s.so", fileName);
	  lib= dlopen(path, ID_RTLD_FLAGS);
	  dprintf("6  dlopen %s -> %p\n", path, lib);
	}
#      endif
      if (!lib) fatal("import: %s.so: No such file or directory\n", fileName);
      init= dlsym(lib, "__id__init__");
      dprintf("7  dlsym %p __id__init__ -> %p\n", lib, init);
      if (!init) fatal("%s: __id__init__: Undefined symbol\n", path);
    }
  dprintf("INIT %s %p %p\n", fileName, lib, init);
  ((void (*)(struct __libid *))init)(&_libid);
  return self;
}

static char *nameOf(oop object)
{
  static char buf[32];
  char *name= buf;
  oop vtable= 0;
  if      (object == 0)			     name= "(0x0)";
  else if ((unsigned)object & 1)	     sprintf(buf, "(#%p=0x%x=%d)", object, (int)object >> 1, (int)object >> 1);
  else
    {
      vtable= object->_vtable[-1];
      if     (!vtable)				 sprintf(buf, "(%p,%p)", object, vtable);
      else if (vtable == _object  ->_vtable[-1]) name= "(_object)";
      else if (vtable == _selector->_vtable[-1]) name= "(_selector)";
      else if (vtable == _closure ->_vtable[-1]) name= "(_closure)";
      else if (vtable == _assoc   ->_vtable[-1]) name= "(_assoc)";
      else if (vtable == _vtable  ->_vtable[-1]) name= "(_vtable)";
      else if (vtable == _libid_tag_vtable)	 name= "(SmallInteger)";
      else if (vtable == _libid_nil_vtable)	 name= "(UndefinedObject)";
      else					 sprintf(buf, "(%p,%p)", object, vtable);
    }
  dprintf("NAME OF %p = %s\n", object, name);
  return name;
}

oop _libid_intern(const char *string)
{
  dprintf("_libid_intern(\"%s\")\n", string);
  return _send(s__intern_, _selector, string);
}

#if 0
static void binary(void *p)
{
  unsigned long l= (unsigned long)p;
  int i;
  for (i= 0;  i < 32;  ++i)
    {
      putchar('0' + (l >> 31));
      l <<= 1;
    }
}
#endif

#if defined(__MACH__) || defined(__CYGWIN__) || defined(__WIN32__)
# define _ "_"
#else
# define _
#endif

#if GLOBAL_MCACHE && defined(__GNUC__) && defined(__i386__)
asm (
"	.text					\n"
"	.align	4				\n"
"	.globl	"_"_libid_bind			\n"
_"_libid_bind:					\n"
"	movl	8(%esp), %eax			\n"	// eax = receiver
"	testb	$0x1, %al			\n"
"	jne	__t1				\n"	// tagged
"	testl	%eax, %eax			\n"
"	je	__t0				\n"	// nil
"	movl	-4(%eax), %edx			\n"	// edx = recevier.vtable
"__tok:	movl	4(%esp), %ecx			\n"	// ecx = selector
"	movl	%edx, %eax			\n"	// eax = vtable
"	shll	$4, %eax			\n"	// eax = vtable << 2+2
"	shrl	$1, %ecx			\n"	// ecx = selector >> 3-2
"	xorl	%ecx, %eax			\n"	// eax = (vtable << 2) ^ (selector >> 3)
"	andl	$0xffc, %eax			\n"	// eax = (vtable << 2) ^ (selector >> 3) & CacheSize
"	leal	"_"_libid_mcache(%eax,%eax,2), %eax \n"	// eax = mcache + eax * sizeof(entry)
"	cmpl	(%eax), %edx			\n"	// eax.vtable == vtable ?
"	jne	"_"_libid_bind_fill		\n"
"	movl	4(%esp), %ecx			\n"	// ecx = selector
"	cmp	4(%eax), %ecx			\n"	// eax.selector == selector ?
"	jne	"_"_libid_bind_fill		\n"
"	movl	8(%eax), %eax			\n"	// ecx = closure
//"	addl	$1, "_"_libid_hits		\n"
"	ret					\n"	// hit
"__t0:	movl	"_"_libid_nil_vtable, %edx	\n"
"	jmp	__tok				\n"
"__t1:	movl	"_"_libid_tag_vtable, %edx	\n"
"	jmp	__tok				\n"
);
# define _libid_bind _libid_bind_fill
#endif

#if GLOBAL_MCACHE && defined(__GNUC__) && defined(__ppc__)
asm (
"	.text						\n"
"	.align	4					\n"
"	.globl	"_"_libid_bind				\n"
_"_libid_bind:						\n"	// r3= selector, r4= receiver
"	andi.	r0, r4, 1				\n"
"	bne	__t1					\n"	// tagged
"	cmpwi	r4, 0					\n"
"	beq	__t0					\n"	// nil
"	lwz	r5, -4(r4)				\n"	// r5 = recevier.vtable
"__tok:	slwi	r6, r5, 4				\n"	// r6 = vtable << 4 (2+2)
"	srawi	r7, r3, 1				\n"	// r7 = selector >> 1 (3-2)
"	xor	r6, r6, r7				\n"	// r6 = (vtable << 2) ^ (selector >> 3)
"	andi.	r6, r6, 0xffc				\n"	// r6 = (vtable << 2) ^ (selector >> 3) & CacheSize
"	add	r7, r6, r6				\n"
"	add	r6, r6, r7				\n"
"	addis	r6, r6, ha16("_"_libid_mcache)		\n"
"	addi	r6, r6, lo16("_"_libid_mcache)		\n"
"	lwz	r7, 0(r6)				\n"	// line.vtable
"	cmpw	r5, r7					\n"	// line.vtable == receiver.vtable ?
"	bne	"_"_libid_bind_fill			\n"
"	lwz	r7, 4(r6)				\n"	// line.selector
"	cmpw	r3, r7					\n"	// line.selector == selector ?
"	bne	"_"_libid_bind_fill			\n"
"	lwz	r3, 8(r6)				\n"	// return line.closure
"	blr						\n"
"__t0:	lis	r5, ha16("_"_libid_nil_vtable)		\n"
"	lwz	r5, lo16("_"_libid_nil_vtable)(r5)	\n"
"	b	__tok					\n"
"__t1:	lis	r5, ha16("_"_libid_tag_vtable)		\n"
"	lwz	r5, lo16("_"_libid_tag_vtable)(r5)	\n"
"	b	__tok					\n"
);
# define _libid_bind _libid_bind_fill
#endif

#undef _

struct __closure *_libid_bind(oop selector, oop receiver)
#undef _libid_bind
{
  static int recursionGuard= 0;
#if GLOBAL_MCACHE
  struct __entry *entry= 0;
#endif
  oop assoc= 0;
  oop vtable= receiver ? (((unsigned)receiver & 1) ? _libid_tag_vtable : receiver->_vtable[-1]) : _libid_nil_vtable;
  dprintf("_libid_bind(%p<%s>, %p\n", selector, selector->selector.elements, receiver);
  if (!vtable) fatal("panic: cannot send '%s' to %s: no vtable", selector->selector.elements, nameOf(receiver));

#if GLOBAL_MCACHE
# if 0
  binary(vtable); putchar(' '); binary(selector); putchar('\n');
# endif
  entry= _libid_mcache + ((((unsigned)vtable << 2) ^ ((unsigned)selector >> 3)) & ((sizeof(_libid_mcache) / sizeof(struct __entry)) - 1));
  if (entry->selector == selector && entry->vtable == vtable)
    return (struct __closure *) entry->closure;
#endif

  assoc= recursionGuard++ ? _vtable__lookup_(0, vtable, vtable, selector) : _send(s_lookup_, vtable, selector);
/*assoc= _vtable__lookup_(0, vtable, selector);*/
  --recursionGuard;
  if (!assoc)
    {
      if (selector != s_doesNotUnderstand_)
	{
	  oop result= _send(s_doesNotUnderstand_, receiver, selector);
	  if (_object___vtable(0, result, result) == _closure->_vtable[-1])
	    return (struct __closure *)result;
	}
      fatal("primitive error handling failed (%p %p)", receiver, selector);
    }
#if GLOBAL_MCACHE
  entry->selector= selector;
  entry->vtable=   vtable;
  entry->closure= &assoc->assoc.value->closure;
#endif
  return (struct __closure *)&assoc->assoc.value->closure;
}

struct __lookup _libid_bind2(oop selector, oop receiver)
{
  oop fragment= receiver;
  static int recursionGuard= 0;
#if GLOBAL_MCACHE
  struct __entry *entry= 0;
#endif
  oop assoc= 0;
  do {
    oop vtable= fragment ? (((unsigned)fragment & 1) ? _libid_tag_vtable : fragment->_vtable[-1]) : _libid_nil_vtable;
    dprintf("_libid_bind(%p<%s>, %p\n", selector, selector->selector.elements, fragment);
    if (!vtable) fatal("panic: cannot send '%s' to %s: no vtable", selector->selector.elements, nameOf(fragment));
#  if GLOBAL_MCACHE
    entry= _libid_mcache + ((((unsigned)vtable << 2) ^ ((unsigned)selector >> 3)) & ((sizeof(_libid_mcache) / sizeof(struct __entry)) - 1));
    if (entry->selector == selector && entry->vtable == vtable)
      return (struct __lookup){ (struct __closure *)entry->closure, fragment };
#  endif
    assoc= recursionGuard++ ? _vtable__lookup_(0, vtable, vtable, selector) : _send(s_lookup_, vtable, selector);
  /*assoc= _vtable__lookup_(0, vtable, selector);*/
    --recursionGuard;
    if (assoc)
      {
#      if GLOBAL_MCACHE
	entry->selector= selector;
	entry->vtable=   vtable;
	entry->closure= &assoc->assoc.value->closure;
#      endif
	return (struct __lookup){ (struct __closure *)&assoc->assoc.value->closure, fragment };
      }
    fragment= _send(s__delegate, fragment);
  } while (fragment);

  if (selector != s_doesNotUnderstand_)
    {
      oop result= _send(s_doesNotUnderstand_, receiver, selector);
      if (_object___vtable(0, result, result) == _closure->_vtable[-1])
	return (struct __lookup){ (struct __closure *)result, receiver };
    }
  fatal("primitive error handling failed (%p %p)", receiver, selector);
  return (struct __lookup){ 0, 0 };
}

void _libid_flush(oop selector)
{
#if GLOBAL_MCACHE
  struct __entry *entry;
  if (selector)
    {
      for (entry= _libid_mcache;  entry < _libid_mcache + (sizeof(_libid_mcache) / sizeof(struct __entry));  ++entry)
	if (entry->selector == selector)
	  entry->selector= entry->vtable= 0;
    }
  else
    for (entry= _libid_mcache;  entry < _libid_mcache + (sizeof(_libid_mcache) / sizeof(struct __entry));  ++entry)
      entry->selector= entry->vtable= 0;
#endif
}

oop _libid_proto(oop base)
{
  return _send(s__delegated, (base ? base : _object));
}

oop _libid_import(const char *key)
{
  oop name= _selector___intern_(0, _selector, _selector, key);
  oop assoc= _vtable__findKeyOrNil_(0, _object_Table, _object_Table, name);
  if (!assoc) fatal("import: '%s' is undefined", key);
  dprintf("IMPORT %s -> %p\n", key, assoc->assoc.value);
  return assoc->assoc.value;
}

oop _libid_export(const char *key, oop value)
{
  oop name= _selector___intern_(0, _selector, _selector, key);
  oop assoc= _vtable__findKeyOrNil_(0, _object_Table, _object_Table, name);
  if (!assoc)
    {
      assoc= new(_assoc);
      assoc->assoc.key= name;
    }
  assoc->assoc.value= value;
  _vtable__add_(0, _object_Table, _object_Table, assoc);
  dprintf("EXPORT %s -> %p\n", key, assoc->assoc.value);
  return value;
}

void _libid_method(oop type, oop selector, _imp_t method)
{
  oop vt= 0;
  dprintf("_libid_method(%p, %p<%s>, %p)\n", type, selector, selector->selector.elements, method);
  vt= _send(s__vtable, type);
  _send(s_methodAt_put_with_, vt, selector, method, 0);
}

oop _libid_alloc(oop type, size_t size)
{
  oop vt= type->_vtable[-1];
  dprintf("LIBID_ALLOC %p [%p] %ld\n", type, type->_vtable[-1], (long)size);
  return _vtable___alloc_(0, vt, vt, size);
}

oop *_libid_palloc(size_t size)
{
  dprintf("LIBID_PALLOC %ld\n", (long)size);
#if USE_GC
  return GC_malloc(size);
#else
  return calloc(1, size);
#endif
}

void *_libid_balloc(size_t size)
{
  dprintf("LIBID_BALLOC %4ld\n", (long)size);
#if USE_GC
  return GC_malloc_atomic(size);
#else
  return calloc(1, size);
#endif
}

static oop nlresult= 0;

oop _libid_nlresult(void)
{
  return nlresult;
}

oop _libid_nlreturn(oop nlr, oop result)
{
  nlresult= result;
  longjmp(*((jmp_buf *)nlr), 1);
  return 0;
}

void *_libid_param(int index)
{
  switch (index)
    {
    case -1:	return (void *)errno;
    case  0:	return (void *)_argc;
    case  1:	return (void *)_argv;
    case  2:	return (void *)_envp;
#  if USE_GC
    case  3:	return (void *)(GC_gcollect(), 0);
    case  4:	return (void *)GC_get_free_bytes();
#  endif
    case  5:	return (void *)SYSARCH;
    case  6:	return (void *)SYSOS;
#  if defined(WIN32)
    case  7:	return (void *)'\\';
#  else
    case  7:	return (void *)'/';
#  endif
    }
  return 0;
}

/*----------------------------------------------------------------*/

struct position
{
  char *name, *type, *file;
  int   line;
};

static struct position *positions= 0;
static int position= 0;
static int maxPosition= 0;

void *_libid_enter(char *name, char *type, char *file)
{
  struct position *p= 0;
  if (position >= maxPosition)
    {
      if (positions)
	{
	  maxPosition *= 2;
	  positions= realloc(positions, sizeof(struct position) * maxPosition);
	}
      else
	{
	  maxPosition= 128;
	  positions= malloc(sizeof(struct position) * maxPosition);
	}
    }
  p= positions + position++;
  p->name= name;
  p->type= type;
  p->file= file;
  p->line= 0;
  return (void *)(position - 1);
}

void _libid_line(int line)
{
  positions[position - 1].line= line;
}

void _libid_leave(void *cookie)
{
  position= (int)(long)cookie;
}

char *_libid_backtrace(void)
{
  int i, indent= 0, len= 0;
  int size= 2048;
  char *result;

 grow:
  size *= 2;
  {
    int offset= 0;
    result= _libid_balloc(size);
    for (i= position;  i--;)
      {
	char *base= strrchr(positions[i].file, '/');
	if (base) positions[i].file= base + 1;
	if (indent < (len= strlen(positions[i].file)))
	  indent= len;
      }
    indent += 9;
    for (i= position;  i--;)    /*for (i= 0;  i< position;  ++i)*/
      {
	int width= snprintf(result + offset, size - offset, "  %s:%-4d ", positions[i].file, positions[i].line);
	offset += width;
	if (indent < width)
	  indent= width;
	else
	  {
	    width= snprintf(result + offset, size - offset, "%*s", indent - width, "");
	    offset += width;
	  }
	width= snprintf(result + offset, size - offset, "%s %s\n", positions[i].type, positions[i].name);
	offset += width;
      }
    if (offset == size) goto grow;
  }
  return result;
}

static void sigint(int signum)	{ fatal("\nInterrupt"); }
#if defined(SIGHUP)
static void sighup(int signum)	{ fprintf(stderr, "\nHangup\n");  fputs(_libid_backtrace(), stderr); }
#endif

struct __libid *_libid_init(int *argcp, char ***argvp, char ***envpp)
{
  dprintf("_libid_init()\n");

#if USE_GC
  GC_INIT();
#endif

  if (argcp)
    {
      _argc= *argcp;
      _argv= *argvp;
      _envp= *envpp;
    }

  _vtable_vtable= new(_vtable);
  _vtable_vtable->_vtable[-1]= _vtable_vtable;

  _vector_vtable= new(_vtable);
  _vtable_vtable->vtable.bindings->_vtable[-1]= _vector_vtable;
  _vector_vtable->vtable.bindings->_vtable[-1]= _vector_vtable;

  _object_vtable= new(_vtable);
  _vtable_vtable->vtable.delegate= _object_vtable;
  _vector_vtable->vtable.delegate= _object_vtable;

  _selector_Table= new(_vtable);
  _object_Table= new(_vtable);

  _object= new(_object);
  _vtable= new(_vtable);
  _vector= new__(_vector, 0, 0);

  _assoc=    _object___delegated(0, _object, _object);  _assoc_vtable=    _assoc->_vtable[-1];
  _selector= _object___delegated(0, _object, _object);  _selector_vtable= _selector->_vtable[-1];
  _closure=  _object___delegated(0, _object, _object);  _closure_vtable=  _closure->_vtable[-1];

# define check(type)						\
  dprintf("type %s %p\n", #type, type);				\
  assert(type);							\
  dprintf("%s->_vtable[-1] %p\n", #type, type->_vtable[-1]);	\
  dprintf("%s_vtable %p\n", #type, type##_vtable);		\
  assert(type->_vtable[-1] == type##_vtable);			\
  assert(type##_vtable);					\
  assert(type##_vtable->_vtable[-1]= _vtable_vtable);
  check(_vtable);
  check(_vector);
  check(_object);
  check(_selector);
  check(_assoc);
  check(_closure);
# undef check

  s_methodAt_put_with_= _selector___intern_(0, _selector, _selector, "methodAt:put:with:");
  _vtable__methodAt_put_with_(0, _vtable_vtable, _vtable_vtable, s_methodAt_put_with_, (oop)_vtable__methodAt_put_with_, 0);

  s_lookup_= _selector___intern_(0, _selector, _selector, "lookup:");
  _vtable__methodAt_put_with_(0, _vtable_vtable, _vtable_vtable, s_lookup_, (oop)_vtable__lookup_, 0);

# define method(type, sel, var)								\
  s_##var= _selector___intern_(0, _selector, _selector, sel);				\
  _send(s_methodAt_put_with_, type##_vtable, s_##var, (_imp_t)type##__##var, 0);

  method(_selector, "_intern:",   	  _intern_);
  method(_object,   "_delegate", 	  _delegate);
  method(_object,   "_delegated", 	  _delegated);
  method(_object,   "_vtable",    	  _vtable);
  method(_vtable,   "init",		  init);
  method(_vtable,   "_alloc:",    	  _alloc_);
  method(_vtable,   "findKeyOrNil:",      findKeyOrNil_);
  method(_vtable,   "flush",		  flush);
  method(_object,   "_beTagType", 	  _beTagType);
  method(_object,   "_beNilType", 	  _beNilType);
  method(_object,   "_import:",   	  _import_);
# undef method

  s_doesNotUnderstand_= _selector___intern_(0, _selector, _selector, "doesNotUnderstand:");

# define export(type) _libid_export(#type, type)
  export(_object);
  export(_selector);
  export(_assoc);
  export(_closure);
  export(_vector);
  export(_vtable);
# undef export

  signal(SIGINT, sigint);
# if defined(SIGHUP)
  signal(SIGHUP, sighup);
# endif

  _libid.dlopen		= dlopen;
  _libid.dlsym		= dlsym;
  _libid.dlclose	= dlclose;

  _libid._object	= _object;
  _libid.nil_vtable	= _libid_nil_vtable;
  _libid.tag_vtable	= _libid_tag_vtable;

  _libid.intern		= _libid_intern;
  _libid.proto		= _libid_proto;
  _libid.method		= _libid_method;
  _libid.alloc		= _libid_alloc;
  _libid.palloc		= _libid_palloc;
  _libid.balloc		= _libid_balloc;

  _libid.import		= _libid_import;
  _libid.export		= _libid_export;
  _libid.param		= _libid_param;

  _libid.bind		= _libid_bind;

  _libid.nlreturn	= _libid_nlreturn;
  _libid.nlresult	= _libid_nlresult;

  _libid.enter		= _libid_enter;
  _libid.line		= _libid_line;
  _libid.leave		= _libid_leave;
  _libid.backtrace	= _libid_backtrace;

  _libid.gc_addRoots			    = _libid.dlsym(RTLD_DEFAULT, "GC_add_roots");
  _libid.gc_gcollect			    = _libid.dlsym(RTLD_DEFAULT, "GC_gcollect");
  _libid.gc_unregisterDisappearingLink	    = _libid.dlsym(RTLD_DEFAULT, "GC_unregister_disappearing_link");
  _libid.gc_generalRegisterDisappearingLink = _libid.dlsym(RTLD_DEFAULT, "GC_general_register_disappearing_link");

  return &_libid;
}


#if defined(WIN32)

# include <tlhelp32.h>

struct dll
{
  char		*name;
  dlhandle_t	 handle;
  struct dll	*next;
};

static struct dll *dlls= 0;

static int dlinitialised= 0;

static void dlinit(void);

dlhandle_t dlopen(const char *path, int mode)
{
  dlhandle_t handle= 0;
  if (!dlinitialised) dlinit();
  {
    unsigned int errormode= SetErrorMode(SEM_FAILCRITICALERRORS);
    SetErrorMode(errormode | SEM_FAILCRITICALERRORS);
    handle= GetModuleHandle(path);
    if ((!handle) && path) handle= LoadLibrary(path);
    SetErrorMode(errormode);
  }
  if (handle)
    {
      struct dll *dll= (struct dll *)malloc(sizeof(struct dll));
      dll->handle= handle;
      dll->next= dlls;
      dlls= dll;
    }
  return handle;
}

static void dlinit(void)
{
  HANDLE snapshot;
  dlinitialised= 1;
  if ((HANDLE)-1 != (snapshot= CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, getpid())))
    {
      MODULEENTRY32 me32;
      me32.dwSize= sizeof(MODULEENTRY32);
      if (Module32First(snapshot, &me32))
	do
	  dlopen(me32.szModule, RTLD_NOW | RTLD_GLOBAL);
	while (Module32Next(snapshot, &me32));
      CloseHandle(snapshot);
    }
}

void *dlsym(dlhandle_t handle, const char *symbol)
{
  void *addr= 0;
  struct dll *dll;
  if (!dlinitialised) dlinit();
  if (handle)
    {
      addr= GetProcAddress(handle, symbol);
      dprintf("dlsym %p \"%s\" -> %p\n", handle, symbol, addr);
      return addr;
    }
  if ((addr= GetProcAddress(GetModuleHandle(0), symbol)))
    {
      dprintf("dlsym <main> \"%s\" -> %p\n", symbol, addr);
      return addr;
    }
  for (dll= dlls;  dll;  dll= dll->next)
    if ((addr= GetProcAddress(dll->handle, symbol)))
      {
	dprintf("dlsym dll %p \"%s\" -> %p\n", dll->handle, symbol, addr);
	return addr;
      }
  dprintf("dlsym 0 \"%s\" -> FAIL\n", symbol);
  return 0;
}

int dlclose(dlhandle_t handle)
{
  struct dll *dll, **dllp;
  for (dllp= &dlls;  (dll= *dllp);  dllp= &dll->next)
    if (dll->handle == handle)
      {
	*dllp= dll->next;
	free(dll);
	break;
      }
  FreeLibrary(handle);
  return 0;
}

#endif