text: /* BEGIN LICENSE BLOCK
   * Version: CMPL 1.1
   *
   * The contents of this file are subject to the Cisco-style Mozilla Public
   * License Version 1.1 (the "License"); you may not use this file except
   * in compliance with the License.  You may obtain a copy of the License
   * at www.eclipse-clp.org/license.
   * 
   * Software distributed under the License is distributed on an "AS IS"
   * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
   * the License for the specific language governing rights and limitations
   * under the License. 
   * 
   * The Original Code is  The ECLiPSe Constraint Logic Programming System. 
   * The Initial Developer of the Original Code is  Cisco Systems, Inc. 
   * Portions created by the Initial Developer are
   * Copyright (C) 1989-2006 Cisco Systems, Inc.  All Rights Reserved.
   * 
   * Contributor(s): 
   * 
   * END LICENSE BLOCK */
  
  /*
   * VERSION	$Id: bip_array.c,v 1.3 2010/03/19 05:52:16 jschimpf Exp $
   */
  
  /****************************************************************************
   *
   *	SEPIA Built-in Predicates for arrays and global variables
   *
   *	name		C func		type		file
   *	----------------------------------------------------------------
   *	make_array_	p_make_array_	B_SAFE
   *	setval_body	p_setval_body	B_SAFE
   *	getval_body	p_getval_body	B_UNSAFE
   *	incval_body	p_incval_body	B_SAFE
   *	decval_body	p_decval_body	B_SAFE
   *	array_info	p_array_info    B_UNSAFE
   *
   *****************************************************************************/
  
  
  /*
   * Arrays are implemented as values of the property ARRAY_PROP.
   * The tag part holds a type (using the general type of prolog objects) 
   * and the value part holds relevant information for this type:
   * If the arity of the dictionary entry is greater than 0:
   * - TINT: integer array. The second word is a pointer to the array.
   * - TDBL: double float array. The second word is a pointer to the array.
   * - TSTRG: byte array. The second word is a pointer to the array.
   * - TCOMP: prolog array. The second word is a pointer to the array.
   * the header of an array looks as follows (in dident):
   * did    (backpointer and arity can be deduced (questionable approach))
   * dim1
   * ...
   * dimn
   * contents ...
   *
   * Global variables are implemented as the property GLOBVAR_PROP.
   * The property value is the value of the global variable.
   */
  
  
  
  #include "config.h"
  #include "sepia.h"
  #include "types.h"
  #include "embed.h"
  #include "error.h"
  #include "mem.h"
  #include "dict.h"
  #include "emu_export.h"
  #include "property.h"
  #include "module.h"
  
  #if defined(PRINTAM) || defined(LASTPP)
  
  #include "opcode.h"
  
  extern char	*inst_name[];
  char		*vm_inst_flag_;
  uword	        *vm_inst_ctr_;
  
  #endif /* PRINTAM */
  
  /* set and get ARRAY_PROP */
  #define NewArrayItem(did, mod, mod_tag, vis, perr)\
      set_modular_property(did, ARRAY_PROP, mod, mod_tag, vis, perr)
  
  #define NewGlobVarItem(did, mod, mod_tag, scope, perr)\
      set_modular_property(did, GLOBVAR_PROP, mod, mod_tag, scope, perr)
  
  #define VisibleAV(did, prop, mod, mod_tag, perr)\
      get_modular_property(did, prop, mod, mod_tag, VISIBLE_PROP, perr)
  
  #define EraseAV(did, prop, mod, mod_tag, vis)\
      erase_modular_property(did, prop, mod, mod_tag, vis)
  
  int
      p_setval_body(value a, type ta, value v, type t, value vmod, type tmod),
      p_make_array_(value v, type t, value vt, type tt, value vscope, type tscope, value vmod, type tmod),
      p_erase_array_body(value val1, type tag1, value vmod, type tmod),
      p_erase_array_(value val1, type tag1, value vscope, type tscope, value vmod, type tmod);
  
  static int
      p_xget(value vhandle, type thandle, value vi, type ti, value vval, type tval),
      p_xset(value vhandle, type thandle, value vi, type ti, value vval, type tval),
      p_array_info(value varr, type tarr, value vopt, type topt, value vmod, type tmod),
      p_getval_body(value a, type ta, value v, type t, value vmod, type tmod),
      p_incval_body(value a, type ta, value vmod, type tmod),
      p_decval_body(value a, type ta, value vmod, type tmod),
      p_test_and_setval_body(value a, type ta, value vc, type tc, value v, type t, value vmod, type tmod);
  
  static dident	d_reference_;
  static dident	d_reference1_;
  static dident	d_global_reference_;
  static dident	d_global_reference_index_;
  
  pword	*get_array_header(dident adid),
  	*get_kernel_array(dident adid),
  	*get_visible_array_header(dident adid, value vm, type tm, int *res);
  
  pword	*p_installation_dir_;	/* accessed from megalog! */
  
  
  /*
   * For aligning arrays
   */
  
  #define RoundUp(n) ((n) - ((n)-1)%sizeof(maxelsize) - 1 + sizeof(maxelsize))
  
  typedef union {
      uword	w;
      word	l;
      double	d;
  } maxelsize;
  
  
  
  void
  bip_array_init(int flags, char *installation_dir)
  {
      pri		*pd;
      value	v1;
  
      if (flags & INIT_SHARED)
      {
  	GlobalVarIndex = 0;
  	local_built_in(in_dict("array_info", 3), p_array_info, B_UNSAFE)
  	    -> mode = BoundArg(1, GROUND) | BoundArg(2, GROUND);
  	(void) local_built_in(in_dict("make_array_", 4),
  			      p_make_array_, B_SAFE);
  	(void) exported_built_in(in_dict("erase_array_body", 2),
  				 p_erase_array_body, B_SAFE);
  	(void) local_built_in(in_dict("erase_array_", 3),
  				 p_erase_array_, B_SAFE);
  	pd = exported_built_in(in_dict("test_and_setval_body", 4), p_test_and_setval_body, B_SAFE);
  	pd = exported_built_in(in_dict("setval_body", 3), p_setval_body, B_SAFE);
  	pd = exported_built_in(in_dict("getval_body", 3), p_getval_body, B_UNSAFE|U_FRESH);
  	pd -> mode = BoundArg(2, NONVAR);
  	pd = exported_built_in(in_dict("incval_body",2), p_incval_body, B_UNSAFE);
  	pd = exported_built_in(in_dict("decval_body",2), p_decval_body, B_UNSAFE);
  	built_in(in_dict("xget",3), p_xget, B_UNSAFE)->mode = GROUND;
  	built_in(in_dict("xset",3), p_xset, B_SAFE);
      }
  
      if (flags & INIT_PRIVATE)
      {
  	value	vv, vm, vn, vt;
  
  	d_reference_ = in_dict("reference", 0);
  	d_reference1_ = in_dict("reference", 1);
  	d_global_reference_ = in_dict("global_reference", 0);
  	d_global_reference_index_ = in_dict("global_reference_index", 0);
  
  #ifdef DFID
  	/* Initialization of predefined global Prolog variables */
  	vv.did = d_.local0;
  	vm.did = d_.kernel_sepia;
  
  	/* temporary: use old style globvar-index for DFID variables */
  	vt.did = d_global_reference_index_;
  
  	/* global var 0 - unused (used to be postponed list) */
  	GlobalVarIndex++;
  	vm.did = in_dict("dfid", 0);
  	/* global var 1 - DfidDepth */
  	vn.did = in_dict("depth", 0);
  	(void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict);
  	/* global var 2 - MaxDepth */
  	vn.did = in_dict("max_depth", 0);
  	(void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict);
  	/* global var 3 - DepthLimit */
  	vn.did = in_dict("depth_limit", 0);
  	(void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict);
  	/* global var 4 - DepthOV */
  	vn.did = in_dict("depth_ov", 0);
  	(void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict);
  #endif
      }
  
      /*
       * Initialize some global Prolog variables in sepia_kernel
       * that need to be accessed from C as well.
       */
      v1.nint = 0;
      p_installation_dir_ = init_kernel_var(flags,
  		in_dict("sepiadir", 0), v1, tint);
      if (flags & INIT_SHARED)
      {
  	set_string(p_installation_dir_, installation_dir);
      }
  
  #if defined(PRINTAM) || defined(LASTPP)
      if (flags & INIT_SHARED)
      {	/* some facilities for statistics and debugging */
  	register int	i;
  	pword		*pw;
  
  	/* array of flags for every VM instruction	*/
  	(void) make_kernel_array(in_dict("vm_inst_flag",1),
  			NUMBER_OP, d_.byte, d_.global0);
  
  	/* array of VM instruction counters	*/
  	(void) make_kernel_array(in_dict("vm_inst_ctr",1),
  			NUMBER_OP, d_.integer0, d_.global0);
  
  	/* array of VM instruction names	*/
  	(void) make_kernel_array(in_dict("vm_inst_name",1),
  			NUMBER_OP, d_.prolog, d_.global0);
  
  	pw = get_kernel_array(in_dict("vm_inst_name",1))->val.ptr + 1;
  	for(i=0; i<NUMBER_OP; i++, pw++)
  	{
  	    pw->tag.kernel = TNIL;		/* must be initialised */
  	    set_string(pw, inst_name[i]);
  	}
      }
      vm_inst_flag_ = (char*)
  	(get_kernel_array(in_dict("vm_inst_flag",1))->val.ptr + 1);
      vm_inst_ctr_ = (uword*)
  	(get_kernel_array(in_dict("vm_inst_ctr",1))->val.ptr + 1);
  #endif /* PRINTAM */
  
  #ifdef lint
      {
  	pword	*pw;
  	int	r;
  	pw = get_array_header(d_.nil);	/* dummy calls for lint */
  	pw = get_visible_array_header(d_.nil, pw->val, pw->tag, &r);
      }
  #endif
  
  }
  /*
   * function to initialise sepia_kernel global variable from within C
   */
  pword *
  init_kernel_var(int flags, dident vdid, value v, type t)
  {
      int	res;
      pword module;
  
      module.tag.kernel = ModuleTag(d_.kernel_sepia);
      module.val.did = d_.kernel_sepia;
      if (flags & INIT_SHARED)
      {
  	value v_name, v_type, v_vis;
  	v_name.did = vdid;
  	v_type.did = d_.prolog;
  	v_vis.did = d_.local0;
  	(void) p_make_array_(v_name, tdict, v_type, tdict,
  			     v_vis, tdict, module.val, module.tag);
  	(void) p_setval_body(v_name, tdict, v, t, module.val, module.tag);
      }
      return get_modular_property(vdid, GLOBVAR_PROP,
  		module.val.did, module.tag, VISIBLE_PROP, &res);
  }
  
  
  
  pword *
  get_kernel_array(dident adid)
  {
      int res;
      pword module;
      if (DidArity(adid) != 1)
  	return 0;
      module.tag.kernel = ModuleTag(d_.kernel_sepia);
      module.val.did = d_.kernel_sepia;
      return get_modular_property(adid, ARRAY_PROP,
  		module.val.did, module.tag, VISIBLE_PROP, &res);
  }
  
  int
  make_kernel_array(dident adid, int length, dident atype, dident avisib)
  {
      pword module;
      pword buf[5];
  
      if (DidArity(adid) != 1)
  	return RANGE_ERROR;
      module.tag.kernel = ModuleTag(d_.kernel_sepia);
      module.val.did = d_.kernel_sepia;
      buf[0].val.ptr = &buf[3];
      buf[0].tag.kernel = TCOMP;
      buf[1].val.did = atype;
      buf[1].tag.kernel = TDICT;
      buf[2].val.did = avisib;
      buf[2].tag.kernel = TDICT;
      buf[3].val.did = adid;		/*  must be arity 1 !!! */
      buf[3].tag.kernel = TDICT;
      buf[4].val.nint = (word) length;
      buf[4].tag.kernel = TINT;
      return p_make_array_(buf[0].val, buf[0].tag, buf[1].val, buf[1].tag,
  		    buf[2].val, buf[2].tag, module.val, module.tag);
  }
  
  /*
   * this function is used to implement the macros in external.h
   */
  
  pword *
  get_array_header(dident adid)
  {
      if (DidArity(adid) > 0)
  	return get_property(adid, ARRAY_PROP);
      else
  	return get_property(adid, GLOBVAR_PROP);
  }
  
  pword *
  get_visible_array_header(dident adid, value vm, type tm, int *res)
  {
      if (DidArity(adid) > 0)
  	return get_modular_property(adid, ARRAY_PROP,
  				    vm.did, tm, VISIBLE_PROP, res);
      else
  	return get_modular_property(adid, GLOBVAR_PROP,
  				    vm.did, tm, VISIBLE_PROP, res);
  }
  
  
  /*
   * erase(Array/Dim)
   *	erase the given array
   */
  int
  p_erase_array_body(value val1, type tag1, value vmod, type tmod)
  {
      value	vscope;
  
      vscope.did = d_.nil; /* visible (not local nor global) */
      return (p_erase_array_(val1, tag1, vscope, tdict, vmod, tmod));
  }
  
  /*
    erase_array_(Array, Module, Visibility)
  */
  /*ARGSUSED*/
  int
  p_erase_array_(value val1, type tag1, value vscope, type tscope, value vmod, type tmod)
  {
      dident	adid;
      int		prop;
      int		err;
      int		scope = (vscope.did == d_.local0 ? LOCAL_PROP
  			 : (vscope.did == d_.global0 ? GLOBAL_PROP
  			    : VISIBLE_PROP));
  
      Get_Functor_Did(val1, tag1, adid);
      
      if (DidArity(adid) > 0)
  	prop = ARRAY_PROP;
      else
  	prop = GLOBVAR_PROP;
      if ((err = EraseAV(adid, prop, vmod.did, tmod, scope))
  	< PSUCCEED)
      {
  	if (err == PERROR)
  	    err = NOGLOBAL;
          Bip_Error(err);
      }
      Succeed_;
  }
  
  static int 
  p_test_and_setval_body(value a, type ta, value vc, type tc, value v, type t, value vmod, type tmod)
  {
      int		err;
  
      Error_If_Ref(ta);
      if (IsAtom(ta) || IsNil(ta))
      {
      	pword *pw;
  	pword copy_pw;
  	
  	a_mutex_lock(&PropertyLock);
      	if (!(pw = VisibleAV(IsNil(ta) ? d_.nil : a.did,
  				GLOBVAR_PROP, vmod.did, tmod, &err)))
      	{
  	    if (err == PERROR)
  		err = NOGLOBAL;
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
          }
  	if (IsGlobalPrologRefIndex(pw) || IsGlobalPrologRef(pw))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(TYPE_ERROR);
  	}
  	if (ec_compare_terms(vc, tc, pw->val, pw->tag))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Fail_;
  	}
          err = create_heapterm(&copy_pw, v, t);
  	if (err != PSUCCEED)
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
  	free_heapterm(pw);
          move_heapterm(&copy_pw, pw);
  	a_mutex_unlock(&PropertyLock);
  	Succeed_;
      }
      else
      {
          Bip_Error(TYPE_ERROR);
      }
  }
  
  int 
  p_setval_body(value a, type ta, value v, type t, value vmod, type tmod)
  {
      int		err;
      pword	copy_pw;
  
      Error_If_Ref(ta);
      if (IsAtom(ta) || IsNil(ta))
      {
      	pword *pw;
  
  	a_mutex_lock(&PropertyLock);
      	if (!(pw = VisibleAV(IsNil(ta) ? d_.nil : a.did,
  				GLOBVAR_PROP, vmod.did, tmod, &err)))
      	{
  	    if (err == PERROR)
  		err = NOGLOBAL;
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
          }
  	if (IsGlobalPrologRef(pw))
  	{
  	    copy_pw.val.all = v.all;
  	    copy_pw.tag.all = t.all;
  	    ec_ref_set((ec_ref) pw->val.wptr, copy_pw);
  	    a_mutex_unlock(&PropertyLock);
  	    Succeed_;
  	}
  	else if (IsGlobalPrologRefIndex(pw))
  	{
  	    (void) ec_assign(&GLOBVAR[pw->val.nint], v, t);
  	    a_mutex_unlock(&PropertyLock);
  	    Succeed_;
  	}
          err = create_heapterm(&copy_pw, v, t);
  	if (err != PSUCCEED)
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
  	free_heapterm(pw);
          move_heapterm(&copy_pw, pw);
  	a_mutex_unlock(&PropertyLock);
  	Succeed_;
      }
      if (IsStructure(ta) || IsList(ta))
      {
      	uword	*adr;
      	uword	kind;
     
  	a_mutex_lock(&PropertyLock);
      	if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
      	}
  	err = PSUCCEED;
  	switch (kind)
  	{
  	case TCOMP:
  	    free_heapterm((pword *)adr);
  	    err = create_heapterm((pword *)adr,v,t);
  	    break;
  	case TSTRG:
  	    if (IsRef(t)) err = INSTANTIATION_FAULT;
  	    else if (!IsInteger(t)) err = TYPE_ERROR;
  	    else *((unsigned char *) adr) = (v.nint & 0XFF);
  	    break;
  	case TINT:
  	    if (IsRef(t)) err = INSTANTIATION_FAULT;
  	    else if (!IsInteger(t)) err = TYPE_ERROR;
  	    else *((word *) adr) = v.nint;
  	    break;
  	case TDBL:
  	    if (IsRef(t)) err = INSTANTIATION_FAULT;
  	    else if (!IsDouble(t)) err = TYPE_ERROR;
  	    else *((double *) adr) = Dbl(v);
  	    break;
  	}
  	a_mutex_unlock(&PropertyLock);
  	return err;
      }
      else
      {
          Bip_Error(TYPE_ERROR);
      }
  }
  
  
  /* make it fail if no global variable associated	*/
  static int
  p_getval_body(value a, type ta, value v, type t, value vmod, type tmod)
  {
      int		err;
      dident	wd;
  
      Error_If_Ref(ta);
      if (IsNil(ta))
  	wd = d_.nil;
      else
  	wd = a.did;
      if (IsAtom(ta) || IsNil(ta))
      {
      	pword	*p;
  	pword	result;
  	
  	a_mutex_lock(&PropertyLock);
      	if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err)))
      	{
  	    if (err == PERROR)
  		err = NOGLOBAL;
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
      	get_heapterm(p, &result);
  	a_mutex_unlock(&PropertyLock);
  
  	if (IsRef(result.tag) && result.val.ptr == &result)
  	{
  	    Succeed_;		/* a free variable	*/
  	}
  	else if (IsGlobalPrologRef(&result))
  	{
  	    result = ec_ref_get((ec_ref) result.val.wptr);
  	    Return_Unify_Pw(v, t, result.val, result.tag);
  	}
  	else if (IsGlobalPrologRefIndex(&result))
  	{
  	    if (!IsSimple(GLOBVAR[result.val.nint].tag)
  	       && GLOBVAR[result.val.nint].val.ptr >= TG
  	       && GLOBVAR[result.val.nint].val.ptr < B_ORIG )
  	    {
  		Fail_;
  	    }
  	    Return_Unify_Pw(v, t, GLOBVAR[result.val.nint].val,
  		GLOBVAR[result.val.nint].tag);
  	}
  	else
  	{
  	    Return_Unify_Pw(v,t,result.val,result.tag);
  	}
      }
      else if (IsStructure(ta) || IsList(ta))
      {
  	uword	*adr;
  	uword	kind;
  	pword	result;
  
  	a_mutex_lock(&PropertyLock);
  	if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
  	switch (kind)
  	{
  	case TCOMP:
  	    get_heapterm((pword *)adr, &result);
  	    if (IsRef(result.tag) && result.val.ptr == &result)
  	    {
  		a_mutex_unlock(&PropertyLock);
  		Succeed_;		/* a free variable	*/
  	    }
  	    break;
  	case TSTRG:
  	    result.val.nint = (word) *((unsigned char *) adr);
  	    result.tag.kernel = TINT;
  	    break;
  	case TINT:
  	    result.val.nint = (word) *((word *) adr);
  	    result.tag.kernel = TINT;
  	    break;
  	case TDBL:
  	    Make_Float(&result, *((double *) adr))
  	    break;
  	}
  	a_mutex_unlock(&PropertyLock);
  	Return_Unify_Pw(v,t,result.val,result.tag);
      }
      else
      {
  	Bip_Error(TYPE_ERROR);
      }
  }
  
  
  static int
  p_incval_body(value a, type ta, value vmod, type tmod)
  {
      pword	*p;
      int		err;
      dident	wd;
      
      Error_If_Ref(ta);
      if (IsNil(ta))
  	wd = d_.nil;
      else
  	wd = a.did;
      if (IsAtom(ta) || IsNil(ta))
      {
  	a_mutex_lock(&PropertyLock);
      	if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err)))
  	{
  	    if (err == PERROR)
  		err = NOGLOBAL;
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
  	if((!IsInteger(p->tag)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(TYPE_ERROR);
  	}
  	p->val.nint++;
  	a_mutex_unlock(&PropertyLock);
  	Succeed_;
      }
      if (IsStructure(ta) || IsList(ta))
      {
      	uword	*adr;
      	uword	kind;
  	pword	*pi;
  	
  	a_mutex_lock(&PropertyLock);
      	if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
      	}
  	if (kind == TINT)
  	{
  	    (*((int *) adr))++;
  	}
  	else if (kind == TCOMP)
  	{
  	    pi = (pword *) adr;
  	    if (IsInteger(pi->tag))
  	    {
  		pi->val.nint++;
  	    }
  	    else
  	    {
  		a_mutex_unlock(&PropertyLock);
  		Bip_Error(TYPE_ERROR);
  	    }
  	}
  	else
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(TYPE_ERROR);
          }
  	a_mutex_unlock(&PropertyLock);
      	Succeed_;
      }
      else
      {
          Bip_Error(TYPE_ERROR);
      }
  }
  
  static int
  p_decval_body(value a, type ta, value vmod, type tmod)
  {
      pword	*p;
      int		err;
      dident	wd;
  
      Error_If_Ref(ta);
      if (IsNil(ta))
  	wd = d_.nil;
      else
  	wd = a.did;
      if (IsAtom(ta) || IsNil(ta))
      {
  	a_mutex_lock(&PropertyLock);
      	if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err)))
  	{
  	    if (err == PERROR)
  		err = NOGLOBAL;
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
  	}
  	if((!IsInteger(p->tag)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(TYPE_ERROR);
  	}
  	p->val.nint--;
  	a_mutex_unlock(&PropertyLock);
  	Succeed_;
      }
      if (IsStructure(ta) || IsList(ta))
      {
      	uword	*adr;
      	uword	kind;
  	pword	*pi;
     
  	a_mutex_lock(&PropertyLock);
      	if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err)))
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(err);
      	}
  	if (kind == TINT)
  	{
  	    (*((int *) adr))--;
  	}
  	else if (kind == TCOMP)
  	{
  	    pi = (pword *) adr;
  	    if (IsInteger(pi->tag))
  	    {
  		pi->val.nint--;
  	    }
  	    else
  	    {
  		a_mutex_unlock(&PropertyLock);
  		Bip_Error(TYPE_ERROR);
  	    }
  	}
  	else
  	{
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(TYPE_ERROR);
          }
  	a_mutex_unlock(&PropertyLock);
      	Succeed_;
      }
      else
      {
          Bip_Error(TYPE_ERROR);
      }
  }
  
  /*
   * array_info(+Array, ?OptionList, +Module)
   *
   * The arguments of Array will be unified with the dimension sizes,
   * OptionList is unified with a two element list [<type>, <visibility>]
   */
  
  static int
  p_array_info(value varr, type tarr, value vopt, type topt, value vmod, type tmod)
  {
      pword	*prop;
      pword	*pw = (pword *) 0;
      int		i, arity, err, prop_name;
      dident	wdid, vis;
      uword	*w;
      value	v;
      Prepare_Requests
  
      Check_Output_List(topt);
      switch (TagType(tarr))
      {
      case TLIST:
      	wdid = d_.list;
  	pw = varr.ptr;
  	break;
      case TCOMP:
      	wdid = varr.ptr->val.did;
  	pw = varr.ptr + 1;
  	break;
      case TDICT:
      	wdid = varr.did;
  	break;
      case TNIL:
      	wdid = d_.nil;
  	break;
      default:
  	Bip_Error(IsRef(tarr) ? INSTANTIATION_FAULT : TYPE_ERROR);
      }
  
      a_mutex_lock(&PropertyLock);
      arity = DidArity(wdid);
      prop_name = arity ? ARRAY_PROP : GLOBVAR_PROP;
      prop = VisibleAV(wdid, prop_name, vmod.did, tmod, &err);
      if (!prop)
      {
  	if (err == PERROR) /* no array */
  	    err = PFAIL;
  	a_mutex_unlock(&PropertyLock);
  	Bip_Error(err);
      }
      vis = (err == LOCAL_PROP) ? d_.local0 : d_.global0;
  
      if (arity == 0)
      {
  	if (IsGlobalPrologRef(prop) || IsGlobalPrologRefIndex(prop))
  	    wdid = d_reference_;
  	else
  	    wdid = d_.prolog;
      }
      else
      {
  	switch(TagType(prop->tag))		/* get the type */
  	{
  	case TCOMP:
  	    wdid = d_.prolog;
  	    break;
  	case TSTRG:
  	    wdid = d_.byte;
  	    break;
  	case TINT:
  	    wdid = d_.integer0;
  	    break;
  	case TDBL:
  	    wdid = d_.float0;
  	    break;
  	default:
  	    p_fprintf(current_err_,
  		    "internal error: array structure corrupted\n");
  	    ec_flush(current_err_);
  	}
  
  	w = ((uword *)(prop -> val.ptr) + 1);	/* unify the dimensions */
  	for(i = 0; i < arity; i++)
  	{
  	    v.nint = (word) *w++;
  	    Request_Unify_Pw(pw->val, pw->tag, v, tint);
  	    pw++;
  	}
      }
      a_mutex_unlock(&PropertyLock);
  
      pw = TG;				/* make options list */
      TG += 4;
      Check_Gc;
      pw[0].val.did = wdid;		/* [type, visibility] */
      pw[0].tag.kernel = TDICT;
      pw[1].val.ptr = &pw[2];
      pw[1].tag.kernel = TLIST;
      pw[2].val.did = vis;
      pw[2].tag.kernel = TDICT;
      pw[3].tag.kernel = TNIL;
      Request_Unify_List(vopt, topt, pw);
      Return_Unify
  }
  
  
  /* get_elt_address must be called in an interrupt protected area */
  
  uword *
  get_elt_address(value v, type t, uword *kind, dident mod_did, type mod_tag, int *perr)
  {
      pword	*pw, *q, *h, *p;
      int		ndim1, ndim2, i, n;
      dident	arraydid;
      uword	*w;
  
      if (IsList(t))
      	arraydid = d_.list;
      else
     	arraydid = v.ptr->val.did;
      ndim1 = DidArity(arraydid);
      if (IsList(t))
      	p = h = v.ptr - 1;
      else
      	p = h = v.ptr;
      for (i=0; i < ndim1; i++)
      {
  	q = ++h;
  	Dereference_(q)
  	if(IsRef(q->tag))
  	{
  	    *perr = INSTANTIATION_FAULT;
  	    return 0;
  	}
  	if(DifferTypeC(q->tag,TINT))
  	{
  	    *perr = TYPE_ERROR;
  	    return 0;
  	}
      }
  
      if (!(pw = VisibleAV(arraydid, ARRAY_PROP, mod_did, mod_tag, perr)))
      {
  	if (*perr == PERROR)
  	    *perr = NOGLOBAL;
  	return 0;
      }
      *kind = pw->tag.kernel;
      pw = pw->val.ptr;
      ndim2 = DidArity((pw)->val.did);
      n = 0;
      w = ((uword *) pw) + 1;
      for(i = 0; i < ndim2; i++)
      {
  	q = ++p;
  	Dereference_(q)
  	n *= *w;
  	if(*w++ <= q->val.nint || q->val.nint < 0)
  	{
  	    *perr = RANGE_ERROR;
  	    return 0;
  	}
  	n += q->val.nint;
      }
      w = (uword *)pw + RoundUp((ndim2+1)*sizeof(uword))/sizeof(uword);
      switch (*kind)
      {
      case TCOMP:		return (uword *) (((pword *) w) + n);
      case TSTRG:		return (uword *) (((unsigned char *)w) + n);
      case TINT:		return (uword *) (((word *)w) + n);
      case TDBL:		return (uword *) (((double *)w) + n);
      default:		return (uword *) 0;
      }
  }
  
  /* get_first_elt must be called in an interrupt protected area		*/
  word
  get_first_elt(pword *p, pword *q, uword *kind, uword *size, dident vmod_did, type mod_tag)
  {
      dident mydid;
      uword *w;
      int i, n, err;
  
      Dereference_(p)
      if (IsRef(p->tag))
  	return(INSTANTIATION_FAULT);
      if (DifferTypeC(p->tag,TDICT))
  	return(TYPE_ERROR);
      Dereference_(q)
      if (IsRef(q->tag))
  	return(INSTANTIATION_FAULT);
      if (DifferTypeC(q->tag,TINT))
  	return(TYPE_ERROR);
      mydid = check_did(p->val.did, (int) q->val.nint);
      if (mydid == D_UNKNOWN)
  	return(NOGLOBAL);
      if (!(p = VisibleAV(mydid, ARRAY_PROP, vmod_did, mod_tag, &err)))
      {
  	if (err == PERROR)
  	    err = NOGLOBAL;
  	return (err);
      }
      *size = 4;
      *kind = p->tag.kernel;
      if(q->val.nint == 0)
      {
  	return((word) (&(p->val)));
      }
      switch (*kind)
      {
      case TCOMP:		*size = sizeof(pword); break;
      case TSTRG:		*size = sizeof(char); break;
      case TINT:		*size = sizeof(word); break;
      case TDBL:		*size = sizeof(double); break;
      }
      p = p->val.ptr;
      w = ((uword *) p) + 1;
      n = DidArity(mydid);
      for(i = 0; i < n ; i++)
  	*size *= *w++;
      w = (uword *)p + RoundUp((n+1)*sizeof(uword))/sizeof(uword);
      return((word) w);
  }
  
  
  /*
   * free all the memory occupied by the array
   */
  
  void
  free_array(pword *prop_value)
  {
      uword *array_header = (uword *) prop_value->val.ptr;
  
      if (IsStructure(prop_value->tag))
      {
  	int	dim = DidArity(array_header[0]);
  	pword	*array_contents = (pword *)
  	    (array_header + RoundUp((dim+1)*sizeof(uword))/sizeof(uword));
  	uword	size;
  
  	for (size = 1; dim > 0; --dim)	/* compute number of elements */
  	    size *= array_header[dim];
  
  	for (; size > 0; --size)
  	    free_heapterm(array_contents++);
      }
      hg_free((generic_ptr) array_header);
  }
  
  
  /*
   * Support function for the dictionary garbage collector:
   * Mark all DID's inside the array (applies only to 'prolog' arrays)
   */
  
  void
  mark_dids_from_array(pword *prop_value)
  {
      extern void mark_dids_from_heapterm(pword *root);
  
      if (IsStructure(prop_value->tag))
      {
  	uword	*array_header = (uword *) prop_value->val.ptr;
  	int	dim = DidArity(array_header[0]);
  	pword	*array_contents = (pword *)
  	    (array_header + RoundUp((dim+1)*sizeof(uword))/sizeof(uword));
  	register uword	size;
  
  	for (size = 1; dim > 0; --dim)	/* compute number of elements */
  	    size *= array_header[dim];
  
  	for (; size > 0; --size)
  	    mark_dids_from_heapterm(array_contents++);
      }
  }
  
  static int
  p_xset(value vhandle, type thandle, value vi, type ti, value vval, type tval)
  {
      pword pw;
      pw.val = vval;
      pw.tag = tval;
      Check_Type(thandle, THANDLE);
      Check_Type(vhandle.ptr->tag, TEXTERN);
      Check_Integer(ti);
      if (!(ExternalData(vhandle.ptr)))
  	Bip_Error(STALE_HANDLE);
      if (!ExternalClass(vhandle.ptr)->set)
      	{ Bip_Error(UNIMPLEMENTED); }
      return ExternalClass(vhandle.ptr)->set(ExternalData(vhandle.ptr), vi.nint, pw);
  }
  
  static int
  p_xget(value vhandle, type thandle, value vi, type ti, value vval, type tval)
  {
      pword pw;
      pw.val = vval;
      pw.tag = tval;
      Check_Type(thandle, THANDLE);
      Check_Type(vhandle.ptr->tag, TEXTERN);
      Check_Integer(ti);
      if (!(ExternalData(vhandle.ptr)))
  	Bip_Error(STALE_HANDLE);
      if (!ExternalClass(vhandle.ptr)->get)
      	{ Bip_Error(UNIMPLEMENTED); }
      pw = ExternalClass(vhandle.ptr)->get(ExternalData(vhandle.ptr), vi.nint);
      Return_Unify_Pw(vval, tval, pw.val, pw.tag);
  }
  
  
  /* The following builtins use the global error variable ! */
  #undef Bip_Error
  #define Bip_Error(N) Bip_Error_Fail(N)
  
  /*
    Create an array v of type vt in module vmod, vscope can
    be local or global.
  
    vt = prolog			nonlogical variable
    vt = global_reference		reference (via ec_ref)
    vt = global_reference_index 	reference (via GLOBVAR[] array)
  */
  /*ARGSUSED*/
  int
  p_make_array_(value v, type t, value vt, type tt, value vscope, type tscope, value vmod, type tmod)
  {
      int		ndim, size, i, nitem, err;
      pword	*p, *pp, *spw;
      type	tag;
      dident	arraydid;
      uword	*w;
      int		header_size;
      int		scope = (vscope.did == d_.local0 ? LOCAL_PROP : GLOBAL_PROP);
  
      Check_Module(tmod, vmod);
      Check_Module_Access(vmod, tmod);
      /* no need to check for tscope, system use only */
  
      if (IsAtom(t) || IsNil(t))	/* global variable */
      {
  	dident		wd;
  	pword		init_pw;
  
  	if (IsNil(t))
  	    wd = d_.nil;
  	else
  	    wd = v.did;
  
  #ifdef GLOBALREFS_ARE_ECREFS
  	if (IsStructure(tt) && vt.ptr[0].val.did == d_reference1_)
  	{
  	    init_pw = vt.ptr[1];
  	    err = ec_constant_table_enter(vt.ptr[1].val, vt.ptr[1].tag, &init_pw);
  	    if (err != PSUCCEED)
  	    {
  		Bip_Error(err == PFAIL ? UNIMPLEMENTED : err);
  	    }
  	    vt.did = d_global_reference_;
  	}
  	else
  #endif
  	{
  	    Check_Atom(tt);
  	    Make_Integer(&init_pw, 0);
  	}
  #ifdef GLOBALREFS_ARE_ECREFS
  	if (vt.did == d_global_reference_index_)
  #else
  	if (vt.did == d_global_reference_index_
  	 || vt.did == d_global_reference_)
  #endif
  	{
  	    if (GlobalVarIndex >= GLOBAL_VARS_NO) {
  		Bip_Error(RANGE_ERROR);
  	    }
  	}
  #ifdef GLOBALREFS_ARE_ECREFS
  	else if (vt.did != d_global_reference_ && vt.did != d_.prolog)
  #else
  	else if (vt.did != d_.prolog)
  #endif
  	{
  	    Bip_Error(RANGE_ERROR);
  	}
  	if (VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err)) {
  	    Bip_Error(ARRAY_EXISTS);
  	}
  	a_mutex_lock(&PropertyLock);
  	if (!(p = NewGlobVarItem(wd, vmod.did, tmod, scope, &err)))
  	{
  	    /* trying to define a global when there is a global or
  	       a local when there is a local here			*/
  	    a_mutex_unlock(&PropertyLock);
  	    Bip_Error(ARRAY_EXISTS);
  	}
  #ifdef GLOBALREFS_ARE_ECREFS
  	if (vt.did == d_global_reference_)
  	{
  	    p->val.wptr = (uword *) ec_ref_create(init_pw);
  	    p->tag.kernel = GlobalPrologRefTag;
  	} else if (vt.did == d_global_reference_index_)
  #else
  	if (vt.did == d_global_reference_
  	 || vt.did == d_global_reference_index_)
  #endif
  	{
  	    p->val.nint = GlobalVarIndex;
  	    GlobalVarIndex++;
  	    p->tag.kernel = GlobalPrologRefIndexTag;
  	} else {
  	    p->val.ptr = p;
  	    p->tag.kernel = TREF;
  	}
  	a_mutex_unlock(&PropertyLock);
  	Succeed_;
      }
      else if (IsList(t))
      {
      	arraydid = d_.list;
      }
      else
      {
  	Check_Structure(t);
  	arraydid = v.ptr->val.did;
      }
  
      Check_Atom(tt);
      if (vt.did == d_.prolog)
      {
  	tag.kernel = TCOMP;
  	size = sizeof(pword);
      }
      else if(vt.did == d_.byte)
      {
  	tag.kernel = TSTRG;
  	size = 1;
      }
      else if(vt.did == d_.integer0)
      {
  	tag.kernel = TINT;
  	size = sizeof(word);
      }
      else if(vt.did == d_.float0)
      {
  	tag.kernel = TDBL;
  	size = sizeof(double);
      }
      else
      {
  	Bip_Error(RANGE_ERROR);
      }
  
      ndim = DidArity(arraydid);
      nitem = 1;
  
      /* compute the number of items which will be held by the array */
      if (IsList(t))
      	p = v.ptr - 1;
      else
       	p = v.ptr;
      for(i = 0; i < ndim; i++)
      {
  	spw = ++p;
  	Dereference_(spw);
  	Check_Integer(spw->tag);
  	if (spw->val.nint <= 0)
  	{
  	    Bip_Error(RANGE_ERROR);
  	}
  	nitem *= spw->val.nint;
      }
  
      /* We might need padding to properly align the array */
      header_size = RoundUp((ndim+1)*sizeof(uword));
      
      a_mutex_lock(&PropertyLock);
      if (!(p = NewArrayItem(arraydid, vmod.did, tmod, scope, &err)))
      {
  	/* trying to define a global when there is a global or
  	   a local when there is a local here				*/
  	a_mutex_unlock(&PropertyLock);
  	Bip_Error(ARRAY_EXISTS);
      }
  
      /* grab space for this array */
      p->tag.all = tag.all;			/* type of the array */
      p->val.ptr = (pword *)hg_alloc(size*nitem + header_size);
      p = p->val.ptr;
      /* initialize the header of the array */
      
      p->val.did = arraydid;	/* thus backward pointer and
  				   the number of dimensions		*/
      w = ((uword *) p) + 1;     /* skip did information			*/
      
      if (IsList(t))
      	pp = v.ptr - 1;
      else
       	pp = v.ptr;
      for(i = 0; i < ndim; i++)
      {
  	spw = ++pp;
  	Dereference_(spw);
  	*w++ = spw->val.nint;	/* size of each dimension */
      }
  
      /* initialize the elements */
      w = (uword *)p + header_size/sizeof(uword);
      switch (tag.kernel)
      {
      case TCOMP:
  	p = (pword *) w;
  	for(i = 0; i < nitem; i++)
  	{
  	    p->val.ptr = p;
  	    (p++)->tag.kernel = TREF;
  	}
  	break;
      case TSTRG:
  	{
  	    unsigned char *s = (unsigned char *) w;
  	    for(i = 0; i < nitem ; i++) *s++ = 0;
  	}
  	break;
      case TINT:
  	{
  	    word *s = (word *) w;
  	    for(i = 0; i < nitem ; i++) *s++ = 0;
  	}
  	break;
      case TDBL:
  	{
  	    double *s = (double *) w;
  	    for(i = 0; i < nitem ; i++) *s++ = 0.0;
  	}
  	break;
      }
      a_mutex_unlock(&PropertyLock);
      Succeed_;
  }
  