/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2013-2021, VU University Amsterdam
			      SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

#include "pl-incl.h"
#include "pl-comp.h"
#include "pl-dict.h"
#include "pl-rsort.h"
#include "pl-funct.h"
#include "pl-prims.h"
#include "pl-wam.h"
#include "pl-fli.h"
#include "pl-gc.h"
#include "pl-gvar.h"

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Dicts are associative arrays,  where  keys   are  either  atoms  or small
integers. Dicts should be considered  an   abstract  data  type. They are
currently represented as compound terms   using the functor `dict`/Arity.
The term has the following layout on the global stack:

  ------------
  | `dict`/A |
  ------------
  | tag      |
  ------------
  | value1   |
  ------------
  | key1     |
  ------------
  | value2   |
  ------------
  | key2     |
      ...

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

static int PL_get_dict_ex(term_t data, term_t tag, term_t dict, int flags);
#define DICT_GET_ALL	0xff
#define DICT_GET_PAIRS	0x01
#define DICT_GET_EQUALS	0x02
#define DICT_GET_COLON	0x04
#define DICT_GET_TERM	0x08

#define CACHED_DICT_FUNCTORS 128

static functor_t dict_functors[CACHED_DICT_FUNCTORS] = {0};

functor_t
dict_functor(int pairs)
{ if ( pairs < CACHED_DICT_FUNCTORS )
  { if ( dict_functors[pairs] )
      return dict_functors[pairs];

    dict_functors[pairs] = lookupFunctorDef(ATOM_dict, pairs*2+1);
    return dict_functors[pairs];
  } else
  { return lookupFunctorDef(ATOM_dict, pairs*2+1);
  }
}

		 /*******************************
		 *      LOW-LEVEL FUNCTIONS	*
		 *******************************/

#define get_dict_ex(t, dp, ex) LDFUNC(get_dict_ex, t, dp, ex)
static int
get_dict_ex(DECL_LD term_t t, Word dp, int ex)
{ Word p = valTermRef(t);

  deRef(p);
  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    FunctorDef fd = valueFunctor(f->definition);

    if ( fd->name == ATOM_dict &&
	 fd->arity%2 == 1 )		/* does *not* validate ordering */
    { *dp = *p;
      return TRUE;
    }
  }

  if ( !ex )
    return FALSE;

  PL_type_error("dict", t);
  return FALSE;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
get_create_dict_ex(DECL_LD +t, -dict) extracts a dict  from t or raises a
type error. The term reference dict contains   a  plain dict term handle
and is never a reference.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define get_create_dict_ex(t, dt) LDFUNC(get_create_dict_ex, t, dt)
static int
get_create_dict_ex(DECL_LD term_t t, term_t dt)
{ Word p = valTermRef(t);

  deRef(p);
  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    FunctorDef fd = valueFunctor(f->definition);

    if ( fd->name == ATOM_dict &&
	 fd->arity%2 == 1 )		/* does *not* validate ordering */
    { *valTermRef(dt) = *p;
      return TRUE;
    }
  }

  if ( PL_get_dict_ex(t, 0, dt, DICT_GET_ALL) )
  { assert(isTerm(*valTermRef(dt)));
    return TRUE;
  }

  return PL_type_error("dict", t);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
dict_lookup_ptr() returns a pointer to the value for a given key
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

Word
dict_lookup_ptr(DECL_LD word dict, word name)
{ Functor data = valueTerm(dict);
  int arity = arityFunctor(data->definition);
  int l = 1, h = arity/2;

  if ( arity == 1 )
    return NULL;			/* empty */
  assert(arity%2 == 1);

  for(;;)
  { int m = (l+h)/2;
    Word p;

    deRef2(&data->arguments[m*2], p);

    if ( *p == name )
      return p-1;

    if ( l == h )
      return NULL;

    if ( *p < name )
      l=m+1;
    else if ( m == l )
      h=m;
    else
      h=m-1;
  }
}


/* True if the keys are proper keys and ordered.  Return values:

   TRUE:  correctly ordered dict
   FALSE: not ordered
   -1:    not a key
   -2:    duplicate key
*/

#define dict_ordered(data, count, dupl) LDFUNC(dict_ordered, data, count, dupl)
static int
dict_ordered(DECL_LD Word data, int count, Word dupl)
{ int ordered = TRUE;
  Word n1, n2;

  if ( count > 0 )
  { data++;			/* skip to key */
    deRef2(data, n1);
    if ( !is_dict_key(*n1) )
      return -1;

    for(; count > 1; count--, data += 2, n1=n2)
    { deRef2(data+2, n2);
      if ( !is_dict_key(*n2) )
	return -1;
      if ( *n1 < *n2 )
	continue;
      if ( *n1 > *n2 )
	ordered = FALSE;
      if ( *n1 == *n2 )
      { if ( dupl )
	{ *dupl = *n1;
	} else
	{ term_t t = PL_new_term_ref();
	  *valTermRef(t) = linkValI(n1);
	  PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, t);
	}
	return -2;
      }
    }
  }

  return ordered;
}


static int
compare_dict_entry(const void *a, const void *b, void *arg)
{ Word p = (Word)a+1;
  Word q = (Word)b+1;
  WITH_LD(arg)
  { deRef(p);
    deRef(q);
  }
  return (*p<*q ? -1 : *p>*q ? 1 : 0);
}


int
dict_order(DECL_LD Word dict, Word dupl)
{ Functor data = (Functor)dict;
  int arity = arityFunctor(data->definition);

  assert(arity%2 == 1);

  sort_r(data->arguments+1, arity/2, sizeof(word)*2,
	 compare_dict_entry, LD);

  return dict_ordered(data->arguments+1, arity/2, dupl);
}


/* dict_order_term_refs() orders an array of indexes into a key/value array
   of term references. Returns 0 if there are no duplicates and else the
   index of the first duplicate.
*/

typedef struct order_term_refs
{ PL_local_data_t *ld;
  term_t *av;
} order_term_refs;


#define compare_term_refs(ip1, ip2, ctx) LDFUNC(compare_term_refs, ip1, ip2, ctx)
static inline int compare_term_refs(DECL_LD const int *ip1, const int *ip2, order_term_refs *ctx);

static int
(compare_term_refs)(const void *a, const void *b, void *arg)
{ return compare_term_refs(PASS_AS_LD(((order_term_refs*)arg)->ld) a, b, arg);
}

static inline int
compare_term_refs(DECL_LD const int *ip1, const int *ip2, order_term_refs *ctx)
{ Word p = valTermRef(ctx->av[*ip1*2]);
  Word q = valTermRef(ctx->av[*ip2*2]);

  assert(!isRef(*p));
  assert(!isRef(*q));

  return (*p<*q ? -1 : *p>*q ? 1 : 0);
}


int
dict_order_term_refs(DECL_LD term_t *av, int *indexes, int count)
{ order_term_refs ctx;

  ctx.ld = LD;
  ctx.av = av;

  sort_r(indexes, count, sizeof(int), compare_term_refs, &ctx);
  if ( count > 1 )
  { word k = *valTermRef(av[indexes[0]*2]);
    int i;

    for(i=1; i<count; i++)
    { word k2 = *valTermRef(av[indexes[i]*2]);

      if ( k == k2 )
	return i;
      k = k2;
    }
  }

  return 0;
}


#define assign_in_dict(dp, val) LDFUNC(assign_in_dict, dp, val)
static int
assign_in_dict(DECL_LD Word dp, Word val)
{ deRef(val);

  if ( !canBind(*val) )
  { *dp = *val;
  } else if ( isAttVar(*val) )
  { *dp = makeRefG(val);
  } else
  { if ( dp < val )
    { if ( unlikely(tTop+1 >= tMax) )
	return TRAIL_OVERFLOW;
      setVar(*dp);
      Trail(val, makeRefG(dp));
    } else
    { *dp = makeRefG(val);
    }
  }

  return TRUE;
}


#define put_dict(dict, size, nv, new_dict) LDFUNC(put_dict, dict, size, nv, new_dict)
static int
put_dict(DECL_LD word dict, int size, Word nv, word *new_dict)
{ Functor data = valueTerm(dict);
  int arity = arityFunctor(data->definition);
  Word new, out, in, in_end, nv_end;
  int modified = FALSE;

  assert(arity%2 == 1);

  if ( size == 0 )
  { *new_dict = dict;
    return TRUE;
  }

  if ( gTop+1+arity+2*size > gMax )
    return GLOBAL_OVERFLOW;

  new    = gTop;
  out    = new+2;			/* functor, tag */
  in     = data->arguments+1;
  in_end = in+arity-1;
  nv_end = nv+size*2;

  while(in < in_end && nv < nv_end)
  { Word i_name, n_name;
    int rc;

    deRef2(in+1, i_name);
    deRef2(nv+1, n_name);

    if ( *i_name == *n_name )
    { if ( (rc=assign_in_dict(out++, nv)) != TRUE )
	return rc;
      *out++ = *i_name;
      if ( !modified && compareStandard(nv, in, TRUE) )
	modified = TRUE;
      in += 2;
      nv += 2;
    } else if ( *i_name < *n_name )
    { *out++ = linkValI(in);
      *out++ = *i_name;
      in += 2;
    } else
    { if ( (rc=assign_in_dict(out++, nv)) != TRUE )
	return rc;
      *out++ = *n_name;
      nv += 2;
      modified = TRUE;
    }
  }

  if ( nv == nv_end )
  { if ( !modified )
    { *new_dict = dict;
      return TRUE;
    }
    while(in < in_end)
    { Word i_name;
      deRef2(in+1, i_name);
      *out++ = linkValI(in);
      *out++ = *i_name;
      in += 2;
    }
  } else
  { while(nv < nv_end)
    { Word n_name;
      int rc;

      deRef2(nv+1, n_name);
      if ( (rc=assign_in_dict(out++, nv)) != TRUE )
	return rc;
      *out++ = *n_name;
      nv += 2;
    }
  }

  gTop = out;
  new[1] = linkValI(&data->arguments[0]);
  new[0] = dict_functor((out-(new+1))/2);

  *new_dict = consPtr(new, TAG_COMPOUND|STG_GLOBAL);

  return TRUE;
}


#define del_dict(dict, key, new_dict) LDFUNC(del_dict, dict, key, new_dict)
static int
del_dict(DECL_LD word dict, word key, word *new_dict)
{ Functor data = valueTerm(dict);
  int arity = arityFunctor(data->definition);
  Word new, out, in, in_end;

  assert(arity%2 == 1);

  if ( gTop+1+arity-2 > gMax )
    return GLOBAL_OVERFLOW;

  new    = gTop;
  out    = new+2;			/* functor, tag */
  in     = data->arguments+1;
  in_end = in+arity-1;

  while(in < in_end)
  { Word i_name;

    deRef2(in+1, i_name);
    if ( *i_name != key )
    { *out++ = linkValI(in);
      *out++ = *i_name;
    }
    in += 2;
  }

  gTop = out;
  new[1] = linkValI(&data->arguments[0]); /* tag */
  new[0] = dict_functor((out-(new+1))/2); /* arity */

  *new_dict = consPtr(new, TAG_COMPOUND|STG_GLOBAL);

  return TRUE;
}


/* partial_unify_dict(dict1, dict2) unifies all common elements of two
   dicts.  It returns TRUE on success, FALSE on a failed unification
   and *_OVERFLOW on some memory overflow
*/

#define partial_unify_dict(dict1, dict2) LDFUNC(partial_unify_dict, dict1, dict2)
static int
partial_unify_dict(DECL_LD word dict1, word dict2)
{ Functor d1 = valueTerm(dict1);
  Functor d2 = valueTerm(dict2);
  Word in1  = d1->arguments;
  Word in2  = d2->arguments;
  Word end1 = in1+arityFunctor(d1->definition);
  Word end2 = in2+arityFunctor(d2->definition);
  int rc;

  /* unify the tages */
  if ( (rc=unify_ptrs(in1, in2, ALLOW_RETCODE)) != TRUE )
    return rc;

  /* advance to first v+k entry */
  in1++;
  in2++;

  while(in1 < end1 && in2 < end2)
  { Word n1, n2;

    deRef2(in1+1, n1);
    deRef2(in2+1, n2);
    if ( *n1 == *n2 )
    { if ( (rc = unify_ptrs(in1, in2, ALLOW_RETCODE)) != TRUE )
	return rc;
      in1 += 2;
      in2 += 2;
    } else if ( *n1 < *n2 )
    { in1 += 2;
    } else
    { in2 += 2;
    }
  }

  return TRUE;
}


/* select_dict() demands del to be a sub-dict of from and assigns
   all remaining values in new.

   Note that unify_ptrs() can push data onto the global stack in
   case it encounters attributed variables.  Therefore we need a
   two pass process.
*/

#define select_dict(del, from, new_dict) LDFUNC(select_dict, del, from, new_dict)
static int
select_dict(DECL_LD word del, word from, word *new_dict)
{ Functor dd = valueTerm(del);
  Functor fd = valueTerm(from);
  Word din  = dd->arguments;
  Word fin  = fd->arguments;
  Word dend = din+arityFunctor(dd->definition);
  Word fend = fin+arityFunctor(fd->definition);
  size_t left = 0;
  int rc;

  /* unify the tags */
  if ( (rc=unify_ptrs(din, fin, ALLOW_RETCODE)) != TRUE )
    return rc;

  /* advance to first v+k entry */
  din++;
  fin++;

  while(din < dend && fin < fend)
  { Word d, f;

    deRef2(din+1, d);
    deRef2(fin+1, f);

    if ( *d == *f )
    { if ( (rc = unify_ptrs(din, fin, ALLOW_RETCODE)) != TRUE )
	return rc;
      din += 2;
      fin += 2;
    } else if ( *d < *f )
    { return FALSE;
    } else
    { fin += 2;
      left++;
    }
  }
  if ( din < dend )
    return FALSE;
  left += (fend-fin)/2;

  if ( !new_dict )
    return TRUE;

  if ( gTop+2+2*left <= gMax )
  { Word out = gTop;

    *new_dict = consPtr(out, TAG_COMPOUND|STG_GLOBAL);

    *out++ = dict_functor(left);
    setVar(*out++);			/* tag for new dict */

    din = dd->arguments+1;
    fin = fd->arguments+1;

    while(left > 0)
    { Word d, f;

      deRef2(din+1, d);
      deRef2(fin+1, f);
      if ( *d == *f )
      { din += 2;
	fin += 2;
      } else
      { *out++ = linkValI(fin);
	*out++ = *f;
	fin += 2;
	left--;
      }
    }
    gTop = out;

    return TRUE;
  }

  return GLOBAL_OVERFLOW;
}


#define get_name_ex(t, np) LDFUNC(get_name_ex, t, np)
static int
get_name_ex(DECL_LD term_t t, Word np)
{ Word p = valTermRef(t);

  deRef(p);
  if ( is_dict_key(*p) )
  { *np = *p;
    return TRUE;
  }

  PL_type_error("dict-key", t);
  return FALSE;
}


#define get_name_value(p, name, value, m, flags) LDFUNC(get_name_value, p, name, value, m, flags)
static int
get_name_value(DECL_LD Word p, Word name, Word value, mark *m, int flags)
{ const char *type;

  deRef(p);

  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);

    if ( (f->definition == FUNCTOR_minus2  && (flags&DICT_GET_PAIRS)) ||
	 (f->definition == FUNCTOR_equals2 && (flags&DICT_GET_EQUALS)) ||
	 (f->definition == FUNCTOR_colon2  && (flags&DICT_GET_COLON)))
    { Word np, vp;

      deRef2(&f->arguments[0], np);
      if ( is_dict_key(*np) )
      { *name = *np;
	deRef2(&f->arguments[1], vp);
	*value = linkValI(vp);

	return TRUE;
      } else
      { Undo(*m);
	PL_type_error("dict-key", pushWordAsTermRef(np));
	popTermRef();

	return FALSE;
      }
    } else if ( arityFunctor(f->definition) == 1 &&
		(flags&DICT_GET_TERM) ) /* Name(Value) */
    { Word vp;

      *name = nameFunctor(f->definition);
      deRef2(&f->arguments[0], vp);
      *value = linkValI(vp);
      return TRUE;
    }
  }

  if ( flags == DICT_GET_PAIRS )
    type = "pair";
  else
    type = "key-value";

  Undo(*m);
  PL_type_error(type, pushWordAsTermRef(p));
  popTermRef();

  return FALSE;				/* type error */
}



		 /*******************************
		 *	 FOREIGN SUPPORT	*
		 *******************************/

int
PL_is_dict(term_t t)
{ GET_LD
  Word p = valTermRef(t);

  deRef(p);
  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    FunctorDef fd = valueFunctor(f->definition);
    word dupl;

    if ( fd->name == ATOM_dict &&
	 fd->arity%2 == 1 &&
	 dict_ordered(f->arguments+1, fd->arity/2, &dupl) == TRUE )
      return TRUE;
  }

  return FALSE;
}


static int
PL_get_dict_ex(term_t data, term_t tag, term_t dict, int flags)
{ GET_LD
  word dupl;

  if ( PL_is_dict(data) )
  { PL_put_term(dict, data);
    return TRUE;
  }

  if ( PL_is_list(data) )
  { intptr_t len = lengthList(data, TRUE);
    Word ap, dp, tail;
    mark m;
    int rc;

    if ( len < 0 )
      return FALSE;			/* not a proper list */

    if ( unlikely(tTop+1 >= tMax) )
    { if ( !makeMoreStackSpace(TRAIL_OVERFLOW, ALLOW_GC|ALLOW_SHIFT) )
	return FALSE;
    }
    if ( (rc=ensureGlobalSpace(len*2+2, ALLOW_GC)) != TRUE )
      return raiseStackOverflow(rc);
    ap = gTop;
    Mark(m);
    dp = ap;
    *ap++ = dict_functor(len);
    if ( tag )
    { Word cp = valTermRef(tag);

      deRef(cp);
      if ( needsRef(*cp) )
      { if ( isVar(*cp) )
	{ setVar(*ap);
	  Trail(cp, makeRefG(ap));
	} else
	{ assert(onStack(global, cp));
	  *ap = makeRefG(cp);
	}
      } else
      { *ap = *cp;
      }
    } else
    { setVar(*ap);
    }
    ap++;

    tail = valTermRef(data);
    deRef(tail);
    while( isList(*tail) )
    { Word head = HeadList(tail);

      if ( !get_name_value(head, ap+1, ap, &m, flags) )
	return FALSE;
      ap += 2;
      tail = TailList(tail);
      deRef(tail);
    }

    if ( (rc=dict_order(dp, &dupl)) == TRUE )
    { gTop = ap;
      *valTermRef(dict) = consPtr(dp, TAG_COMPOUND|STG_GLOBAL);
      DEBUG(CHK_SECURE, checkStacks(NULL));
      return TRUE;
    } else
    { term_t ex;

      assert(rc == -2);
      Undo(m);
      return ( (ex = PL_new_term_ref()) &&
	       _PL_unify_atomic(ex, dupl) &&
	       PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, ex) );
    }
  }					/* TBD: {name:value, ...} */

  return PL_type_error("dict-data", data);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PL_for_dict()  runs  func  on  each  key-value    pair  in  dict.  Returns
immediately with the return value of func   if func returns non-zero. If
the flag DICT_SORTED is given, the  key-value   pairs  are  called in the
standard order of terms.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

typedef struct cmp_dict_index_data
{ Word  data;
  int  *indexes;
  PL_local_data_t *ld;
} cmp_dict_index_data;

#define cmp_dict_index(ip1, ip2, ctx) LDFUNC(cmp_dict_index, ip1, ip2, ctx)
static inline int cmp_dict_index(DECL_LD const int *ip1, const int *ip2, cmp_dict_index_data *ctx);

static int
(cmp_dict_index)(const void *a1, const void *a2, void *arg)
{ return cmp_dict_index(PASS_AS_LD(((cmp_dict_index_data*)arg)->ld) a1, a2, arg);
}

static inline int
cmp_dict_index(DECL_LD const int *ip1, const int *ip2, cmp_dict_index_data *ctx)
{ Word p = &ctx->data[*ip1*2+1];
  Word q = &ctx->data[*ip2*2+1];
  int rc;

  deRef(p);
  deRef(q);

  if ( *p == *q )
  { rc = CMP_EQUAL;
  } else
  { if ( isAtom(*p) )
    { if ( isAtom(*q) )
	rc = compareAtoms(*p, *q);
      else
	rc = CMP_GREATER;
    } else
    { if ( isTaggedInt(*p) )
	rc = valInt(*p) > valInt(*q) ? CMP_GREATER : CMP_LESS;
      else
	rc = CMP_LESS;
    }
  }

  return rc;
}


int
pl_for_dict(DECL_LD term_t dict,
	   int LDFUNCP (*func)(DECL_LD term_t key, term_t value, int last, void *closure),
	   void *closure,
	   int flags)
{ term_t av = PL_new_term_refs(2);
  int i, arity, pairs;
  Word p = valTermRef(dict);
  int index_buf[256];
  int *indexes = NULL;
  int rc = 0;

  deRef(p);
  arity = arityTerm(*p);
  pairs = arity/2;

  if ( (flags&DICT_SORTED) )
  { cmp_dict_index_data ctx;

    if ( pairs < 256 )
      indexes = index_buf;
    else if ( !(indexes = malloc(pairs*sizeof(int))) )
      return PL_no_memory();

    for(i=0; i<pairs; i++)
      indexes[i] = i;

    ctx.ld = LD;
    ctx.data = argTermP(*p,1);
    ctx.indexes = indexes;

    sort_r(indexes, pairs, sizeof(int), cmp_dict_index, &ctx);
  }

  for(i=0; i < pairs; )
  { Word p = valTermRef(dict);
    int in;

    if ( indexes )
    { in = indexes[i]*2+1;
    } else
    { in = i*2+1;
    }

    deRef(p);
    Functor f = valueTerm(*p);
    *valTermRef(av+0) = linkValI(&f->arguments[in+1]);
    *valTermRef(av+1) = linkValI(&f->arguments[in]);

    if ( (rc=LDFUNCP(*func)(av+0, av+1, ++i == pairs, closure)) != 0 )
      break;
  }

  if ( indexes && indexes != index_buf )
    free(indexes);

  return rc;
}


		 /*******************************
		 *	  RELOAD SUPPORT	*
		 *******************************/

/* resortDictsInClause() resorts the contents of dicts in a clause

This predicate is called from pl-wic.c after   reloading a clause from a
.qlf file or state if pl-wic.c  detected   a  dict  inside the clause. It
identifies the code ranges that constitute the  k-v pairs in the dict and
re-orders them according to the new atom-handle ordering.

There    is    a    complicating     factor    with    B_FIRSTVAR/B_VAR,
B_ARGFIRSTVAR/B_ARGVAR and H_FIRSTVAR/H_VAR, that may  get swapped after
reordering.  This  is  corrected   by    fix_firstvars().   The  current
implementation is quadratic in the number of variables in the dict.
*/

typedef struct kv_code
{ word key;
  size_t start;
  size_t len;
} kv_code;

#define KV_PREALOCATED 32
#define C_PREALLOCATED 256

static int
cmp_kv_pos(const void *p1, const void *p2)
{ const kv_code *k1 = p1;
  const kv_code *k2 = p2;

  return k1->key < k2->key ? -1 : k1->key == k2->key ? 0 : 1;
}

static void
fix_firstvars(Code start, Code end)
{ Code PC;

  for( PC=start; PC < end; PC = stepPC(PC) )
  { code op = fetchop(PC);
    code first;
    code var;

    switch(op)
    { case B_VAR0:
      case B_VAR1:
      case B_VAR2:
	var = (code)VAROFFSET(op-B_VAR0);
	first = B_FIRSTVAR;
        goto find_first;
      case B_VAR:
	var = PC[1];
	first = B_FIRSTVAR;
        goto find_first;
      case B_ARGVAR:
	var = PC[1];
	first = B_ARGFIRSTVAR;
        goto find_first;
      case H_VAR:
	var = PC[1];
	first = H_FIRSTVAR;
      find_first:
      { Code pc;

	for(pc=PC; pc < end; pc = stepPC(pc))
	{ code op2 = fetchop(pc);

	  if ( op2 == first && pc[1] == var )
	  { DEBUG(MSG_DICT, Sdprintf("Swapping first vars\n"));
	    *PC = *pc;
	    *pc = encode(op);
	  }
	}
      }
    }
  }
}

static int
resortDictsInCodes(Code PC, Code end)
{
  for( ; PC < end; PC = stepPC(PC) )
  { code op = fetchop(PC);

    switch(op)
    { case H_RFUNCTOR:
      case H_FUNCTOR:
      case B_RFUNCTOR:
      case B_FUNCTOR:
      { word w = (word)PC[1];
	FunctorDef fd = valueFunctor(w);

	if ( fd->name == ATOM_dict &&
	     fd->arity > 1 &&
	     fd->arity%2 == 1 )
	{ int f, fields = fd->arity/2;
	  kv_code kv_buf[KV_PREALOCATED];
	  code c_buf[C_PREALLOCATED];
	  kv_code *kv_pos;
	  Code c_tmp;
	  Code fields_start, fs;

	  if ( fields <= KV_PREALOCATED )
	    kv_pos = kv_buf;
	  else if ( !(kv_pos = malloc(sizeof(kv_code)*fields)) )
	    return PL_no_memory();

	  PC = stepPC(PC);		/* skip *_FUNCTOR */
	  PC = skipArgs(PC, 1);		/* skip the type */
	  fields_start = PC;

	  for(f = 0; f < fields; f++)
	  { Code PCv = PC;

	    kv_pos[f].start = PC-fields_start;
	    PC = skipArgs(PC, 1);	/* skip value */

	    code op = fetchop(PC);
	    switch(op)
	    { case H_ATOM:
	      case B_ATOM:
	      case H_SMALLINT:
	      case B_SMALLINT:
	      { kv_pos[f].key = (word)PC[1];
		break;
	      }
	      default:
	      { if ( kv_pos != kv_buf )
		  free(kv_pos);
		return TRUE;		/* not a dict */
	      }
	    }

	    if ( !resortDictsInCodes(PCv, PC) )
	    { if ( kv_pos != kv_buf )
		free(kv_pos);
	      return FALSE;
	    }

	    PC = stepPC(PC);		/* skip key */
	    kv_pos[f].len = PC-fields_start-kv_pos[f].start;

	    DEBUG(MSG_DICT,
		  { if ( isAtom(kv_pos[f].key) )
		      Sdprintf("Got %s from %p..%p\n",
			       stringAtom(kv_pos[f].key), kv_pos[f].start, PC);
		    else
		      Sdprintf("Got %ld from %p..%p\n",
			       (long)valInt(kv_pos[f].key), kv_pos[f].start, PC);
		  });
	  }

	  qsort(kv_pos, fields, sizeof(*kv_pos), cmp_kv_pos);
	  if ( PC-fields_start <= C_PREALLOCATED )
	    c_tmp = c_buf;
	  else if ( !(c_tmp = malloc((PC-fields_start)*sizeof(code))) )
	  { if ( kv_pos != kv_buf )
	      free(kv_pos);
	    return PL_no_memory();
	  }

	  memcpy(c_tmp, fields_start, (PC-fields_start)*sizeof(code));
	  for(fs=fields_start, f = 0; f < fields; f++)
	  { size_t len = kv_pos[f].len*sizeof(code);

	    memcpy(fs, c_tmp+kv_pos[f].start, len);
	    fs += kv_pos[f].len;
	  }

	  if ( kv_pos != kv_buf )
	    free(kv_pos);
	  if ( c_tmp != c_buf )
	    free(c_tmp);

	  fix_firstvars(fields_start, PC);
	}
      }
    }
  }

  return TRUE;
}

int
resortDictsInClause(Clause clause)
{ Code PC, end;

  PC  = clause->codes;
  end = &PC[clause->code_size];

  return resortDictsInCodes(PC, end);
}


/* resortDictsInTerm() re-sorts dicts inside term.
   Used by loadQlfTerm().  Term may not be cyclic.
*/

#define resort_dicts_in_term(p) LDFUNC(resort_dicts_in_term, p)
static void
resort_dicts_in_term(DECL_LD Word p)
{
right_arg:
  deRef(p);

  if ( isTerm(*p) )
  { Functor t = valueTerm(*p);
    FunctorDef fd = valueFunctor(t->definition);
    Word ea;
    word dupl;

    if ( fd->name == ATOM_dict && fd->arity%2 == 1 &&
	 dict_ordered(&t->arguments[1], fd->arity/2, &dupl) == FALSE )
    { DEBUG(MSG_DICT, Sdprintf("Re-ordering dict\n"));
      dict_order((Word)t, &dupl);
    }

    ea = &t->arguments[fd->arity-1];
    for(p=t->arguments; p<ea; p++)
      resort_dicts_in_term(p);

    goto right_arg;
  }
}


void
resortDictsInTerm(term_t t)
{ GET_LD
  Word p = valTermRef(t);

  resort_dicts_in_term(p);
}



		 /*******************************
		 *       PROLOG PREDICATES	*
		 *******************************/

/** is_dict(@Term)
    is_dict(@Term, ?Tag)

True if Term is a dict that belongs to Tag.

@tbd What if Term has a variable tag?
*/

static
PRED_IMPL("is_dict", 1, is_dict, 0)
{ PRED_LD
  Word p = valTermRef(A1);

  deRef(p);
  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    FunctorDef fd = valueFunctor(f->definition);
    //word dupl;

    if ( fd->name == ATOM_dict &&
	 fd->arity%2 == 1 /*&&
	 dict_ordered(f->arguments+1, fd->arity/2, &dupl) == TRUE*/ )
      return TRUE;
  }

  return FALSE;
}


static
PRED_IMPL("is_dict", 2, is_dict, 0)
{ PRED_LD
  Word p = valTermRef(A1);

  deRef(p);
  if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    FunctorDef fd = valueFunctor(f->definition);
    //word dupl;

    if ( fd->name == ATOM_dict &&
	 fd->arity%2 == 1 /*&&
	 dict_ordered(f->arguments+1, fd->arity/2,  &dupl) == TRUE*/ )
      return unify_ptrs(&f->arguments[0], valTermRef(A2),
			ALLOW_GC|ALLOW_SHIFT);
  }

  return FALSE;
}


/** get_dict(?Key, +Dict, ?Value)

True when Key is associated with Value in Dict. If Name is unbound, this
predicate is true for all Name/Value  pairs   in  the  dict. The order in
which these pairs are enumerated is _undefined_.
*/

static foreign_t
pl_get_dict(term_t PL__t0, int PL__ac, int ex, control_t PL__ctx)
{ PRED_LD
  int i;
  word dict;

  switch( CTX_CNTRL )
  { case FRG_FIRST_CALL:
    { Word np = valTermRef(A1);

      if ( !get_dict_ex(A2, &dict, !ex) )
	return FALSE;

      deRef(np);
      if ( is_dict_key(*np) )
      { Word vp;

	if ( (vp=dict_lookup_ptr(dict, *np)) )
	  return unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT);

	if ( ex )
	  return PL_error(NULL, 0, NULL, ERR_EXISTENCE3,
			  ATOM_key, A1, A2);
	return FALSE;
      }
      if ( canBind(*np) )
      { i = 1;
	goto search;
      }
      if ( !ex )
	return PL_type_error("dict-key", A1);
      return FALSE;
    }
    case FRG_REDO:
    { Functor f;
      int arity;
      fid_t fid;
      Word p;

      i = (int)CTX_INT + 2;
      p = valTermRef(A2);
      deRef(p);
      dict = *p;

    search:
      f = valueTerm(dict);
      arity = arityFunctor(f->definition);

      if ( (fid=PL_open_foreign_frame()) )
      { for( ; i < arity; i += 2 )
	{ Word np;

	  deRef2(&f->arguments[i+1], np);	/* TBD: check type */
	  if ( unify_ptrs(&f->arguments[i], valTermRef(A3),
			  ALLOW_GC|ALLOW_SHIFT) &&
	       _PL_unify_atomic(A1, *np) )
	  { PL_close_foreign_frame(fid);

	    if ( i+2 < arity )
	      ForeignRedoInt(i);
	    else
	      return TRUE;
	  } else if ( exception_term )
	  { PL_close_foreign_frame(fid);
	    return FALSE;
	  }
	  PL_rewind_foreign_frame(fid);
	}
	PL_close_foreign_frame(fid);
      }
      return FALSE;
    }
    default:
      return TRUE;
  }
}


static
PRED_IMPL("get_dict", 3, get_dict, PL_FA_NONDETERMINISTIC)
{ return pl_get_dict(PL__t0, PL__ac, FALSE, PL__ctx);
}


static
PRED_IMPL("get_dict_ex", 3, get_dict_ex, PL_FA_NONDETERMINISTIC)
{ return pl_get_dict(PL__t0, PL__ac, TRUE, PL__ctx);
}


/** get_dict(+Key, +Dict, -Value, -NewDict, -NewValue) is semidet.
*/

static
PRED_IMPL("get_dict", 5, get_dict, 0)
{ PRED_LD
  term_t dt = PL_new_term_refs(4);
  term_t av = dt+1;
  word key;
  Word vp;

  if ( !get_name_ex(A1, &key) ||
       !(*valTermRef(av+1) = key) ||
       !get_create_dict_ex(A2, dt) ||
       !(vp=dict_lookup_ptr(*valTermRef(dt), key)) ||
       !unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT) ||
       !PL_put_term(av+0, A5) )
    return FALSE;

  for(;;)
  { word new;
    int rc;

    if ( (rc = put_dict(*valTermRef(dt),
			1, valTermRef(av), &new)) == TRUE )
    { term_t t = dt+3;

      *valTermRef(t) = new;
      return PL_unify(A4, t);
    } else
    { if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	return FALSE;
    }
  }
}


/** dict_create(-Dict, ?Tag, +Data) is det.

Dict represents the name-value pairs  in  Data.   If  Data  is a dict, Dict
unified  with  Data.  Otherwise,  a  new    Dict   is  created.  Suitable
representations for Data are:

  - {Name:Value, ...}
  - [Name=Value, ...]
  - [Name-Value, ...]
  - [Name(Value), ...]
*/


static
PRED_IMPL("dict_create", 3, dict_create, 0)
{ PRED_LD
  term_t m = PL_new_term_ref();

  if ( PL_get_dict_ex(A3, A2, m, DICT_GET_ALL) )
    return PL_unify(A1, m);

  return FALSE;
}


/** dict_pairs(+Dict, ?Tag, -Pairs)
    dict_pairs(-Dict, ?Tag, +Pairs)
*/

typedef struct dict_pairs_ctx
{ PL_local_data_t *ld;
  term_t head;
  term_t tail;
  term_t tmp;
} dict_pairs_ctx;

#define put_pair(key, value, last, closure) LDFUNC(put_pair, key, value, last, closure)

static int
put_pair(DECL_LD term_t key, term_t value, int last, void *closure)
{ dict_pairs_ctx *ctx = closure;

  if ( PL_cons_functor(ctx->tmp, FUNCTOR_minus2, key, value) &&
       PL_unify_list_ex(ctx->tail, ctx->head, ctx->tail) &&
       PL_unify(ctx->head, ctx->tmp) )
    return 0;

  return -1;
}


static
PRED_IMPL("dict_pairs", 3, dict_pairs, 0)
{ PRED_LD

  if ( !PL_is_variable(A1) )
  { term_t dict = PL_new_term_ref();

    if ( get_create_dict_ex(A1, dict) )
    { dict_pairs_ctx ctx;

      ctx.ld = LD;
      ctx.tail = PL_copy_term_ref(A3);
      ctx.head = PL_new_term_refs(2);
      ctx.tmp  = ctx.head+1;

      if ( PL_get_arg(1, dict, ctx.tmp) &&
	   PL_unify(ctx.tmp, A2) &&
	   PL_for_dict(dict, put_pair, &ctx, DICT_SORTED) == 0 )
	return PL_unify_nil_ex(ctx.tail);

      return FALSE;
    }
  } else
  { term_t m = PL_new_term_ref();

    if ( PL_get_dict_ex(A3, A2, m, DICT_GET_PAIRS) )
      return PL_unify(A1, m);
  }

  return FALSE;
}


/** put_dict(+New, +DictIn, -DictOut)

True when Dict is a copy of Dict0 where values from Dict1 replace or extend
the value set of Dict0.
*/

static
PRED_IMPL("put_dict", 3, put_dict, 0)
{ PRED_LD
  term_t dt;
  fid_t fid = PL_open_foreign_frame();

retry:
  if ( (dt = PL_new_term_refs(2)) &&
       get_create_dict_ex(A2, dt+0) &&
       get_create_dict_ex(A1, dt+1) )
  { Functor f2 = valueTerm(*valTermRef(dt+1));
    int arity = arityFunctor(f2->definition);
    word new;
    int rc;

    if ( (rc = put_dict(*valTermRef(dt+0),
			arity/2, &f2->arguments[1],
			&new)) == TRUE )
    { term_t t = PL_new_term_ref();

      *valTermRef(t) = new;
      return PL_unify(A3, t);
    } else
    { assert(rc == GLOBAL_OVERFLOW);
      PL_rewind_foreign_frame(fid);
      if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	goto retry;
    }
  }

  return FALSE;
}

/** put_dict(+Key, +Dict0, +Value, -Dict)

True when Dict is a copy of Dict0 with Name Value added or replaced.
*/

#define put_dict4(key, dict, value, newdict) LDFUNC(put_dict4, key, dict, value, newdict)
static foreign_t
put_dict4(DECL_LD term_t key, term_t dict, term_t value, term_t newdict)
{ term_t dt = PL_new_term_refs(3);
  term_t av = dt+1;
  fid_t fid = PL_open_foreign_frame();

retry:
  if ( get_create_dict_ex(dict, dt) &&
       get_name_ex(key, valTermRef(av+1)) &&
       PL_put_term(av, value) )
  { word new;
    int rc;

    if ( (rc = put_dict(*valTermRef(dt),
			1, valTermRef(av), &new)) == TRUE )
    { term_t t = PL_new_term_ref();

      *valTermRef(t) = new;
      return PL_unify(newdict, t);
    } else
    { if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
      { PL_rewind_foreign_frame(fid);
	goto retry;
      }
    }
  }

  return FALSE;
}



static
PRED_IMPL("put_dict", 4, put_dict, 0)
{ PRED_LD

  return put_dict4(A1, A2, A3, A4);
}


/** b_set_dict(+Key, !Dict, +Value)

Backtrackable destructive assignment, similar to setarg/3.
*/

#define SETDICT_BACKTRACKABLE    0x1
#define SETDICT_LINK		0x2

#define setdict(key, dict, value, flags) LDFUNC(setdict, key, dict, value, flags)
static int
setdict(DECL_LD term_t key, term_t dict, term_t value, int flags)
{ word k, m;
  Word val;

retry:
  val = valTermRef(value);
  deRef(val);

  if ( (flags&SETDICT_BACKTRACKABLE) )
  { if ( !hasGlobalSpace(0) )
    { int rc;

      if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
	return raiseStackOverflow(rc);
      goto retry;
    }
  } else
  { if ( storage(*val) == STG_GLOBAL )
    { if ( !(flags & SETDICT_LINK) )
      { term_t copy = PL_new_term_ref();

	if ( !duplicate_term(value, copy) )
	  return FALSE;
	value = copy;
	val = valTermRef(value);
	deRef(val);
      }
      freezeGlobal();
    }
  }

  if ( get_dict_ex(dict, &m, TRUE) &&
       get_name_ex(key, &k) )
  { Word vp;

    if ( (vp=dict_lookup_ptr(m, k)) )
    { if ( (flags&SETDICT_BACKTRACKABLE) )
	TrailAssignment(vp);
      unify_vp(vp, val);
      return TRUE;
    }

    return PL_error(NULL, 0, NULL, ERR_EXISTENCE3,
		    ATOM_key, key, dict);
  }

  return FALSE;
}


static
PRED_IMPL("b_set_dict", 3, b_set_dict, 0)
{ PRED_LD

  return setdict(A1, A2, A3, SETDICT_BACKTRACKABLE);
}

static
PRED_IMPL("nb_set_dict", 3, nb_set_dict, 0)
{ PRED_LD

  return setdict(A1, A2, A3, 0);
}

static
PRED_IMPL("nb_link_dict", 3, nb_link_dict, 0)
{ PRED_LD

  return setdict(A1, A2, A3, SETDICT_LINK);
}


/** del_dict(+Key, +DictIn, ?Value, -DictOut)

True when Key-Value is in DictIn and   DictOut  contains all keys of DictIn
except for Key.
*/

static
PRED_IMPL("del_dict", 4, del_dict, 0)
{ PRED_LD
  word key;
  term_t mt = PL_new_term_ref();
  fid_t fid = PL_open_foreign_frame();

retry:
  if ( get_create_dict_ex(A2, mt) &&
       get_name_ex(A1, &key) )
  { Word vp;

    if ( (vp=dict_lookup_ptr(*valTermRef(mt), key)) &&
	 unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT) )
    { int rc;
      word new;

      if ( (rc=del_dict(*valTermRef(mt), key, &new)) == TRUE )
      { term_t t = PL_new_term_ref();

	*valTermRef(t) = new;
	return PL_unify(A4, t);
      } else
      { assert(rc == GLOBAL_OVERFLOW);
	if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	{ PL_rewind_foreign_frame(fid);
	  goto retry;
	}
      }
    }
  }

  return FALSE;
}


/** select_dict(+Select, +From) is semidet.
    select_dict(+Select, +From, -Rest) is semidet.
*/

static
PRED_IMPL("select_dict", 3, select_dict, 0)
{ PRED_LD
  term_t dt = PL_new_term_refs(2);
  word r;

retry:
  if ( get_create_dict_ex(A1, dt+0) &&
       get_create_dict_ex(A2, dt+1) )
  { int rc = select_dict(*valTermRef(dt+0), *valTermRef(dt+1), &r);

    switch(rc)
    { case TRUE:
      { term_t t = PL_new_term_ref();

	*valTermRef(t) = r;
	return PL_unify(A3, t);
      }
      case FALSE:
	return rc;
      case MEMORY_OVERFLOW:
	return PL_no_memory();
      default:
	if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	  return FALSE;
        goto retry;
    }
  }

  return FALSE;
}


static
PRED_IMPL(":<", 2, select_dict, 0)
{ PRED_LD
  term_t dt = PL_new_term_refs(2);

retry:
  if ( get_create_dict_ex(A1, dt+0) &&
       get_create_dict_ex(A2, dt+1) )
  { int rc = select_dict(*valTermRef(dt+0), *valTermRef(dt+1), NULL);

    switch(rc)
    { case TRUE:
      case FALSE:
	return rc;
      case MEMORY_OVERFLOW:
	return PL_no_memory();
      default:
	if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	  return FALSE;
        goto retry;
    }
  }

  return FALSE;
}


static
PRED_IMPL(">:<", 2, punify_dict, 0)
{ PRED_LD
  term_t dt = PL_new_term_refs(2);

retry:
  if ( get_create_dict_ex(A1, dt+0) &&
       get_create_dict_ex(A2, dt+1) )
  { int rc = partial_unify_dict(*valTermRef(dt+0), *valTermRef(dt+1));

    switch(rc)
    { case TRUE:
      case FALSE:
	return rc;
      case MEMORY_OVERFLOW:
	return PL_no_memory();
      default:
	if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	  return FALSE;
        goto retry;
    }
  }

  return FALSE;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Part of FLI
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

int
PL_get_dict_key(atom_t key, term_t dict, term_t value)
{ GET_LD
  word d;
  Word vp;

  if ( !is_dict_key(key) )
    return -1;
  if ( !get_dict_ex(dict, &d, FALSE) )
    return FALSE;
  if ( (vp=dict_lookup_ptr(d, key)) )
  { *valTermRef(value) = linkValI(vp);
    return TRUE;
  }

  return FALSE;
}


		 /*******************************
		 *      PUBLISH PREDICATES	*
		 *******************************/

BeginPredDefs(dict)
  PRED_DEF("is_dict",	   1, is_dict,	    0)
  PRED_DEF("is_dict",	   2, is_dict,	    0)
  PRED_DEF("dict_create",  3, dict_create,  0)
  PRED_DEF("dict_pairs",   3, dict_pairs,   0)
  PRED_DEF("put_dict",	   3, put_dict,	    0)
  PRED_DEF("put_dict",	   4, put_dict,	    0)
  PRED_DEF("b_set_dict",   3, b_set_dict,   0)
  PRED_DEF("nb_set_dict",  3, nb_set_dict,  0)
  PRED_DEF("nb_link_dict", 3, nb_link_dict, 0)
  PRED_DEF("get_dict",	   3, get_dict,	    PL_FA_NONDETERMINISTIC)
  PRED_DEF("$get_dict_ex", 3, get_dict_ex,  PL_FA_NONDETERMINISTIC)
  PRED_DEF("del_dict",	   4, del_dict,	    0)
  PRED_DEF("get_dict",     5, get_dict,     0)
  PRED_DEF("select_dict",  3, select_dict,  0)
  PRED_DEF(":<",	   2, select_dict,  0)
  PRED_DEF(">:<",	   2, punify_dict,  0)
EndPredDefs
