/*************************
 * swi_list_walk
 *************************/
int
swi_list_walk(term_t list,
              int (*callback)(term_t item, int i, void *data), void *data)
{
    term_t pl_list, pl_head;
    int    i, err;
    
    pl_list = PL_copy_term_ref(list);
    pl_head = PL_new_term_ref();

    for (i = err = 0; !err && PL_get_list(pl_list, pl_head, pl_list); i++)
        err = callback(pl_head, i, data);
    
    return err;
}

static int
domain_error(term_t actual, const char *expected)
{ term_t ex;

  if ( (ex=PL_new_term_ref()) &&
       PL_unify_term(ex,
		     PL_FUNCTOR, FUNCTOR_error2,
		       PL_FUNCTOR, FUNCTOR_domain_error2,
		         PL_CHARS, expected,
		         PL_TERM, actual,
		       PL_VARIABLE) )
    return PL_raise_exception(ex);

  return FALSE;
}

static int
type_error(const char *expected, term_t found)
{ term_t ex;

  if ( (ex=PL_new_term_ref()) &&
       PL_unify_term(ex,
		     PL_FUNCTOR, FUNCTOR_error2,
		       PL_FUNCTOR, FUNCTOR_type_error2,
		         PL_CHARS, expected,
			 PL_TERM, found,
		       PL_VARIABLE) )
    return PL_raise_exception(ex);

  return FALSE;
}

static foreign_t
snowball_algorithms(term_t list)
{ term_t tail = PL_copy_term_ref(list);
  term_t head = PL_new_term_ref();
  const char **algos = sb_stemmer_list();
  int i;

  for(i=0; algos[i]; i++)
  { if ( !PL_unify_list(tail, head, tail) ||
	 !PL_unify_atom_chars(head, algos[i]) )
      return FALSE;
  }

  return PL_unify_nil(tail);
}

static int
init_prolog_goal(prolog_goal *g, term_t goal, int acknowledge)
{ term_t plain = PL_new_term_ref();

  g->module	 = NULL;
  g->acknowledge = acknowledge;
  g->state       = G_WAITING;
  if ( !PL_strip_module(goal, &g->module, plain) )
    return FALSE;
  if ( !(PL_is_compound(plain) || PL_is_atom(plain)) )
    return type_error(goal, "callable");
  g->goal = PL_record(plain);

  return TRUE;
}

static int
existence_error(term_t actual, const char *type)
{ term_t ex;

  if ( (ex = PL_new_term_ref()) &&
       PL_unify_term(ex,
		     PL_FUNCTOR, FUNCTOR_error2,
		       PL_FUNCTOR, FUNCTOR_existence_error2,
		         PL_CHARS, type,
		         PL_TERM, actual,
		       PL_VARIABLE) )
    return PL_raise_exception(ex);

  return FALSE;
}

static foreign_t
pl_memberchk_eq(term_t element, term_t maybe_list)
{

  term_t head = PL_new_term_ref();      	/* variable for the elements */
  term_t list = PL_copy_term_ref(maybe_list);   /* copy as we need to write */

  while( PL_get_list(list, head, list) )
  { if ( PL_compare(element,head) == 0 )
     PL_succeed ;
  }

  PL_fail;  

}

/********************
 * swi_list_new
 ********************/
term_t
swi_list_new(char **items, int n, term_t result)
{
    term_t list = PL_new_term_ref();
    term_t item = PL_new_term_ref();

    if (n < 0) {                  /* NULL-terminated list, calculate items */
        n = 0;
        if (items)
            while (items[n])
                n++;
    }

    PL_put_nil(list);
    while (n-- > 0) {
        PL_put_atom_chars(item, items[n]);
        PL_cons_list(list, item, list);
    }
    
    if (result && PL_is_variable(result))
        PL_unify(list, result);
    
    return list;
}

static int
permission_error(const char *op, const char *objtype, term_t obj)
{ term_t ex;

  if ( (ex = PL_new_term_ref()) &&
       PL_unify_term(ex,
		     PL_FUNCTOR, FUNCTOR_error2,
		       PL_FUNCTOR, FUNCTOR_permission_error3,
		         PL_CHARS, op,
		         PL_CHARS, objtype,
		         PL_TERM, obj,
		       PL_VARIABLE) )
    return PL_raise_exception(ex);

  return FALSE;
}

word
pl_dwim_predicate(term_t pred, term_t dwim, control_t h)
{ GET_LD
  functor_t fdef;
  Module module = (Module) NULL;
  Procedure proc;
  Symbol symb;
  term_t head = PL_new_term_ref();
  TableEnum e;

  if ( ForeignControl(h) == FRG_CUTTED )
  { e = ForeignContextPtr(h);
    freeTableEnum(e);
    succeed;
  }

  if ( !PL_strip_module(pred, &module, head) )
    fail;
  if ( !PL_get_functor(head, &fdef) )
    fail;				/* silent: leave errors for later */

  if ( ForeignControl(h) == FRG_FIRST_CALL )
    e = newTableEnum(module->procedures);
  else
    e = ForeignContextPtr(h);

  while( (symb = advanceTableEnum(e)) )
  { Definition def;
    char *name;

    proc = symb->value;
    def  = proc->definition;
    name = stringAtom(def->functor->name);

    if ( dwimMatch(stringAtom(nameFunctor(fdef)), name) &&
         isDefinedProcedure(proc) &&
         (name[0] != '$' || SYSTEM_MODE) )
    { if ( !PL_unify_functor(dwim, def->functor->functor) )
	continue;

      ForeignRedoPtr(e);
    }
  }

  freeTableEnum(e);
  fail;
}

void getQueryString(term_t t,char* buf)
{
  term_t head = PL_new_term_ref();
  term_t list = PL_copy_term_ref(t);
  int i=0;
  char* c;
  while(PL_get_list(list,head,list))
    {
      if(!PL_is_variable(head))
	{
	  PL_get_chars(head,&c,CVT_ATOM|BUF_DISCARDABLE);
	  buf[i]=c[0];
	}
      else
	buf[i]='_';
      ++i;
    }
  buf[i]='\0';
}

// parse a list of type terms and encode as a NULL terminated
// string where each character encodes the type of one argument.
static int get_types_list(term_t list, char *typespec, int len)
{
	term_t 	head=PL_new_term_ref();
	int		count=0;

	// copy term ref so as not to modify original
	list=PL_copy_term_ref(list);

	while (PL_get_list(list,head,list) && count<len) {
		atom_t name;
		int	 arity;
		const char  *type;

		if (!PL_get_name_arity(head,&name,&arity)) return type_error(head,"term");
		type=PL_atom_chars(name);
		switch (arity) {
		case 1: {
				if (!strcmp(type,"int")) {
					typespec[count++]='i';
				} else if (!strcmp(type,"double")) {
					typespec[count++]='d';
				} else if (!strcmp(type,"string")) {
					typespec[count++]='s';
				} else if (!strcmp(type,"symbol")) {
					typespec[count++]='S';
				} else if (!strcmp(type,"float")) {
					typespec[count++]='f';
				}
				break;
			}
		case 0: {
				if (!strcmp(type,"true")) typespec[count++]='T';
				else if (!strcmp(type,"false")) typespec[count++]='F';
				else if (!strcmp(type,"nil")) typespec[count++]='N';
				else if (!strcmp(type,"inf")) typespec[count++]='I';
				break;
			}
		}
	}
	typespec[count]=0;
	if (!PL_get_nil(list)) return type_error(list,"nil");
	return TRUE;
}

static bool
clearSourceAdmin(SourceFile sf)
{ GET_LD
  int rc = FALSE;

  fid_t fid = PL_open_foreign_frame();
  term_t name = PL_new_term_ref();
  static predicate_t pred = NULL;

  if ( !pred )
    pred = PL_predicate("$clear_source_admin", 1, "system");

  PL_put_atom(name, sf->name);
  rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, name);

  PL_discard_foreign_frame(fid);

  return rc;
}

cairo_bool_t
plcairo_filter_to_term(cairo_filter_t filter,
                       term_t         t)
{
  term_t t0 = PL_new_term_ref();

  PLCAIRO_debug("    cairo_filter_t: %d  --->  term: 0x%lx", filter, t);

  if ( !ATOM_cairo_filter_fast )
  {
    ATOM_cairo_filter_fast = PL_new_atom("CAIRO_FILTER_FAST");
    ATOM_cairo_filter_good = PL_new_atom("CAIRO_FILTER_GOOD");
    ATOM_cairo_filter_best = PL_new_atom("CAIRO_FILTER_BEST");
    ATOM_cairo_filter_nearest = PL_new_atom("CAIRO_FILTER_NEAREST");
    ATOM_cairo_filter_bilinear = PL_new_atom("CAIRO_FILTER_BILINEAR");
    ATOM_cairo_filter_gaussian = PL_new_atom("CAIRO_FILTER_GAUSSIAN");
  }

  if ( filter == CAIRO_FILTER_FAST )
  { PL_put_atom(t0, ATOM_cairo_filter_fast);
  }
  else if ( filter == CAIRO_FILTER_GOOD )
  { PL_put_atom(t0, ATOM_cairo_filter_good);
  }
  else if ( filter == CAIRO_FILTER_BEST )
  { PL_put_atom(t0, ATOM_cairo_filter_best);
  }
  else if ( filter == CAIRO_FILTER_NEAREST )
  { PL_put_atom(t0, ATOM_cairo_filter_nearest);
  }
  else if ( filter == CAIRO_FILTER_BILINEAR )
  { PL_put_atom(t0, ATOM_cairo_filter_bilinear);
  }
  else if ( filter == CAIRO_FILTER_GAUSSIAN )
  { PL_put_atom(t0, ATOM_cairo_filter_gaussian);
  }
  else
  { g_assert_not_reached();
  }

  return PL_unify(t, t0);
}

cairo_bool_t
plcairo_pattern_type_to_term(cairo_pattern_type_t pattern_type,
                             term_t               t)
{
  term_t t0 = PL_new_term_ref();

  PLCAIRO_debug("    cairo_pattern_type_t: %d  --->  term: 0x%lx", pattern_type, t);

  if ( !ATOM_cairo_pattern_type_solid )
  {
    ATOM_cairo_pattern_type_solid = PL_new_atom("CAIRO_PATTERN_TYPE_SOLID");
    ATOM_cairo_pattern_type_surface = PL_new_atom("CAIRO_PATTERN_TYPE_SURFACE");
    ATOM_cairo_pattern_type_linear = PL_new_atom("CAIRO_PATTERN_TYPE_LINEAR");
    ATOM_cairo_pattern_type_radial = PL_new_atom("CAIRO_PATTERN_TYPE_RADIAL");
    ATOM_cairo_pattern_type_mesh = PL_new_atom("CAIRO_PATTERN_TYPE_MESH");
    ATOM_cairo_pattern_type_raster_source = PL_new_atom("CAIRO_PATTERN_TYPE_RASTER_SOURCE");
  }

  if ( pattern_type == CAIRO_PATTERN_TYPE_SOLID )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_solid);
  }
  else if ( pattern_type == CAIRO_PATTERN_TYPE_SURFACE )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_surface);
  }
  else if ( pattern_type == CAIRO_PATTERN_TYPE_LINEAR )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_linear);
  }
  else if ( pattern_type == CAIRO_PATTERN_TYPE_RADIAL )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_radial);
  }
  else if ( pattern_type == CAIRO_PATTERN_TYPE_MESH )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_mesh);
  }
  else if ( pattern_type == CAIRO_PATTERN_TYPE_RASTER_SOURCE )
  { PL_put_atom(t0, ATOM_cairo_pattern_type_raster_source);
  }
  else
  { g_assert_not_reached();
  }

  return PL_unify(t, t0);
}

static int
get_exe(term_t exe, p_options *info)
{ int arity;
  term_t arg = PL_new_term_ref();

  if ( !PL_get_name_arity(exe, &info->exe_name, &arity) )
    return type_error(exe, "callable");

  PL_put_atom(arg, info->exe_name);

#ifdef __WINDOWS__
  if ( !PL_get_wchars(arg, NULL, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC) )
    return FALSE;
  if ( !win_command_line(exe, arity, info->exe, &info->cmdline) )
    return FALSE;
#else /*__WINDOWS__*/
  if ( !PL_get_chars(arg, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
    return FALSE;

  if ( !(info->argv = PL_malloc((arity+2)*sizeof(char*))) )
    return PL_resource_error("memory");
  memset(info->argv, 0, (arity+2)*sizeof(char*));
  if ( !(info->argv[0] = PL_malloc(strlen(info->exe)+1)) )
    return PL_resource_error("memory");
  strcpy(info->argv[0], info->exe);

  { int i;

    for(i=1; i<=arity; i++)
    { _PL_get_arg(i, exe, arg);

      if ( !PL_get_chars(arg, &info->argv[i],
			 CVT_ATOMIC|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
	return FALSE;
    }
    info->argv[i] = NULL;
  }
#endif /*__WINDOWS__*/

  return TRUE;
}

static int
win_exec(size_t len, const wchar_t *cmd, UINT show)
{ GET_LD
  STARTUPINFOW startup;
  PROCESS_INFORMATION info;
  int rval;
  wchar_t *wcmd;

  memset(&startup, 0, sizeof(startup));
  startup.cb = sizeof(startup);
  startup.wShowWindow = show;

					/* ensure 0-terminated */
  wcmd = PL_malloc((len+1)*sizeof(wchar_t));
  memcpy(wcmd, cmd, len*sizeof(wchar_t));
  wcmd[len] = 0;

  rval = CreateProcessW(NULL,		/* app */
			wcmd,
			NULL, NULL,	/* security */
			FALSE,		/* inherit handles */
			0,		/* flags */
			NULL,		/* environment */
			NULL,		/* Directory */
			&startup,
			&info);		/* process info */
  PL_free(wcmd);

  if ( rval )
  { CloseHandle(info.hProcess);
    CloseHandle(info.hThread);

    succeed;
  } else
  { term_t tmp = PL_new_term_ref();

    return ( PL_unify_wchars(tmp, PL_ATOM, len, cmd) &&
	     PL_error(NULL, 0, WinError(), ERR_SHELL_FAILED, tmp)
	   );
  }
}

tcp_get_socket(term_t Socket, int *id)
{ IOSTREAM *s;
  int socket;

  if ( PL_is_functor(Socket, FUNCTOR_socket1) )
  { term_t a = PL_new_term_ref();

    _PL_get_arg(1, Socket, a);
    if ( PL_get_integer(a, id) )
      return TRUE;
  }

  if ( PL_get_stream_handle(Socket, &s) )
  { socket = (int)(intptr_t)s->handle;

    *id = socket;
    return TRUE;
  }

  return pl_error(NULL, 0, NULL, ERR_ARGTYPE, -1, Socket, "socket");
}

static int
archive_error(archive_wrapper *ar)
{ int eno = archive_errno(ar->archive);

  if ( eno != 0 )
  { const char *s = archive_error_string(ar->archive);
    term_t ex = PL_new_term_ref();

    if ( PL_unify_term(ex,
		       PL_FUNCTOR, FUNCTOR_error2,
		         PL_FUNCTOR, FUNCTOR_archive_error2,
		           PL_INT, errno,
		           PL_CHARS, s,
		         PL_VARIABLE) )
      return PL_raise_exception(ex);

    return FALSE;
  }

  return TRUE;
}

static int
zunlock(zipper *z)
{ int tid = PL_thread_self();

  if ( z->owner == tid )
  { if ( z->lock_count == 0 )
    { term_t t;

    error:
    { GET_LD
      return ( (t=PL_new_term_ref()) &&
	       unify_zipper(t, z) &&
	       PL_permission_error("unlock", "zipper", t)
	     );
    }
    }
    if ( --z->lock_count == 0 )
    { z->owner = 0;
      simpleMutexUnlock(&z->lock);
    }
  } else