/*
|| This file is part of Pike. For copyright information see COPYRIGHT.
|| Pike is distributed under GPL, LGPL and MPL. See the file COPYING
|| for more information.
*/

#include "global.h"
#include "interpret.h"
#include "svalue.h"
#include "pike_macros.h"
#include "object.h"
#include "program.h"
#include "array.h"
#include "pike_error.h"
#include "constants.h"
#include "mapping.h"
#include "stralloc.h"
#include "multiset.h"
#include "pike_types.h"
#include "pike_rusage.h"
#include "operators.h"
#include "fsort.h"
#include "callback.h"
#include "gc.h"
#include "backend.h"
#include "main.h"
#include "pike_memory.h"
#include "threads.h"
#include "time_stuff.h"
#include "version.h"
#include "encode.h"
#include <math.h>
#include <ctype.h>
#include "module_support.h"
#include "module.h"
#include "opcodes.h"
#include "cyclic.h"
#include "signal_handler.h"
#include "pike_security.h"
#include "builtin_functions.h"
#include "bignum.h"
#include "peep.h"
#include "docode.h"
#include "lex.h"
#include "pike_float.h"
#include "pike_compiler.h"

#include <errno.h>

#ifdef HAVE_POLL
#ifdef HAVE_POLL_H
#include <poll.h>
#endif /* HAVE_POLL_H */

#ifdef HAVE_SYS_POLL_H
#include <sys/poll.h>
#endif /* HAVE_SYS_POLL_H */
#endif /* HAVE_POLL */

#ifdef HAVE_CRYPT_H
#include <crypt.h>
#endif

/* #define DIFF_DEBUG */
/* #define ENABLE_DYN_DIFF */

/*! @decl int equal(mixed a, mixed b)
 *!
 *!   This function checks if the values @[a] and @[b] are equal.
 *!
 *!   For all types but arrays, multisets and mappings, this operation is
 *!   the same as doing @expr{@[a] == @[b]@}.
 *!   For arrays, mappings and multisets however, their contents are checked
 *!   recursively, and if all their contents are the same and in the same
 *!   place, they are considered equal.
 *!
 *! @seealso
 *!   @[copy_value()]
 */
PMOD_EXPORT void f_equal(INT32 args)
{
  int i;
  if(args != 2)
    SIMPLE_TOO_FEW_ARGS_ERROR("equal", 2);

  i=is_equal(Pike_sp-2,Pike_sp-1);
  pop_n_elems(args);
  push_int(i);
}

/*! @decl array aggregate(mixed ... elements)
 *!
 *!   Construct an array with the arguments as indices.
 *!
 *!   This function could be written in Pike as:
 *! @code
 *! array aggregate(mixed ... elems) { return elems; }
 *! @endcode
 *!
 *! @note
 *!   Arrays are dynamically allocated there is no need to declare them
 *!   like @expr{int a[10]=allocate(10);@} (and it isn't possible either) like
 *!   in C, just @expr{array(int) a=allocate(10);@} will do.
 *!
 *! @seealso
 *!   @[sizeof()], @[arrayp()], @[allocate()]
 */
PMOD_EXPORT void debug_f_aggregate(INT32 args)
{
  struct array *a;
  a=aggregate_array(args);
  push_array(a); /* beware, macro */
}

static node *optimize_f_aggregate(node *n)
{
  /* Split long argument lists into multiple function calls.
   *
   * aggregate(...) ==> `+(aggregate(...arg32), aggregate(arg33...), ...)
   *
   * Also removes splices.
   *
   * Note: We assume that the argument list is in left-recursive form.
   */
  node *args = CDR(n);
  node *new_args = NULL;
  node *add_args = NULL;
  int count;
  if (!args) return NULL;
  args->parent = NULL;
  for (count = 0; args->token == F_ARG_LIST; args = CAR(args)) {
    if (CDR(args) && CDR(args)->token == F_PUSH_ARRAY) {
      /* Splices have a weight of 16. */
      count += 16;
    } else {
      count++;
    }
    if (!CAR(args)) break;
    CAR(args)->parent = args;
  }
  if (args->token == F_PUSH_ARRAY) {
    /* Last argument is a splice */
    count += 16;
  } else if (args->token != F_ARG_LIST) {
    count++;
  }

  /* Ignore cases with 32 or less arguments. */
  if (count <= 32) {
    CDR(n)->parent = n;
    return NULL;
  }

  /*
   * Perform the actual rewrite.
   *
   * Start with the last arg, and work towards the first.
   */

  count = 0;
  if (args->token != F_ARG_LIST) {
    if (args->token == F_PUSH_ARRAY) {
      /* Splice operator. */
      add_args = copy_node(CAR(args));
    } else {
      new_args = copy_node(args);
      count = 1;
    }
    args = args->parent;
  }

  for(; args; args = args->parent) {
    if (!CDR(args)) continue;
    if (CDR(args)->token == F_PUSH_ARRAY) {
      if (count) {
	add_args = mknode(F_ARG_LIST, add_args,
			  mkapplynode(copy_node(CAR(n)), new_args));
	new_args = NULL;
	count = 0;
      }
      add_args = mknode(F_ARG_LIST, add_args, copy_node(CADR(args)));
    } else {
      new_args = mknode(F_ARG_LIST, new_args, copy_node(CDR(args)));
      count++;
      if (count > 31) {
	add_args = mknode(F_ARG_LIST, add_args,
			  mkapplynode(copy_node(CAR(n)), new_args));
	new_args = NULL;
	count = 0;
      }
    }
  }
  if (count) {
    add_args = mknode(F_ARG_LIST, add_args,
		      mkapplynode(copy_node(CAR(n)), new_args));
    new_args = NULL;
    count = 0;
  }
  CDR(n)->parent = n;
  return mkefuncallnode("`+", add_args);
}

/*! @decl __deprecated__ int hash_7_4(string s)
 *! @decl __deprecated__ int hash_7_4(string s, int max)
 *!
 *! @deprecated 7.4::hash
 *!
 *! @seealso
 *!   @[7.4::hash()], @[hash()]
 */

/*! @namespace 7.4::
 */

#define MK_HASHMEM(NAME, TYPE)		ATTRIBUTE((const))	\
  static INLINE size_t NAME(const TYPE *str, ptrdiff_t len, ptrdiff_t maxn) \
  {                                                                         \
      size_t ret,c;                                                         \
                                                                            \
      ret = len*92873743;                                                   \
                                                                            \
      len = MINIMUM(maxn,len);                                              \
      for(; len>=0; len--)                                                  \
      {                                                                     \
          c=str++[0];                                                       \
          ret ^= ( ret << 4 ) + c ;                                         \
          ret &= 0x7fffffff;                                                \
      }                                                                     \
      return ret;                                                           \
  }

MK_HASHMEM(simple_hashmem, unsigned char)
MK_HASHMEM(simple_hashmem1, p_wchar1)
MK_HASHMEM(simple_hashmem2, p_wchar2)

/*! @decl int hash(string s)
 *! @decl int hash(string s, int max)
 *!
 *!   Return an integer derived from the string @[s]. The same string
 *!   will always hash to the same value, also between processes.
 *!
 *!   If @[max] is given, the result will be >= 0 and < @[max],
 *!   otherwise the result will be >= 0 and <= 0x7fffffff.
 *!
 *! @note
 *!   This function is provided for backward compatibility reasons.
 *!
 *!   This function is byte-order dependant for wide strings.
 *!
 *! @seealso
 *!   @[predef::hash()], @[7.0::hash()]
 */
static void f_hash_7_4(INT32 args)
{
  size_t i = 0;
  struct pike_string *s = Pike_sp[-args].u.string;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("7.4::hash",1);

  if(TYPEOF(Pike_sp[-args]) != T_STRING)
    SIMPLE_BAD_ARG_ERROR("7.4::hash", 1, "string");

  i = simple_hashmem((unsigned char *)s->str, s->len<<s->size_shift,
		     100<<s->size_shift);

  if(args > 1)
  {
    if(TYPEOF(Pike_sp[1-args]) != T_INT)
      SIMPLE_BAD_ARG_ERROR("7.4::hash",2,"int");
    
    if(!Pike_sp[1-args].u.integer)
      PIKE_ERROR("7.4::hash", "Modulo by zero.\n", Pike_sp, args);

    i%=(unsigned INT32)Pike_sp[1-args].u.integer;
  }
  pop_n_elems(args);
  push_int64(i);
}

/*! @endnamespace
 */

ATTRIBUTE((const)) static INLINE size_t hashstr(const unsigned char *str, ptrdiff_t maxn)
{
  size_t ret,c;
  
  if(!(ret=str++[0]))
    return ret;
  for(; maxn>=0; maxn--)
  {
    c=str++[0];
    if(!c) break;
    ret ^= ( ret << 4 ) + c ;
    ret &= 0x7fffffff;
  }

  return ret;
}

/*! @decl int hash_7_0(string s)
 *! @decl int hash_7_0(string s, int max)
 *!
 *!   Return an integer derived from the string @[s]. The same string
 *!   always hashes to the same value, also between processes.
 *!
 *!   If @[max] is given, the result will be >= 0 and < @[max],
 *!   otherwise the result will be >= 0 and <= 0x7fffffff.
 *!
 *! @note
 *!   This function is provided for backward compatibility with
 *!   code written for Pike up and including version 7.0.
 *!
 *!   This function is not NUL-safe, and is byte-order dependant.
 *!
 *! @seealso
 *!   @[hash()], @[7.4::hash()]
 */
static void f_hash_7_0( INT32 args )
{
  struct pike_string *s = Pike_sp[-args].u.string;
  unsigned int i;
  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("7.0::hash",1);
  if(TYPEOF(Pike_sp[-args]) != T_STRING)
    SIMPLE_BAD_ARG_ERROR("7.0::hash", 1, "string");

  if( s->size_shift )
  {
    f_hash_7_4( args );
    return;
  }

  i = DO_NOT_WARN((unsigned int)hashstr( (unsigned char *)s->str,
					 MINIMUM(100,s->len)));
  if(args > 1)
  {
    if(TYPEOF(Pike_sp[1-args]) != T_INT)
      SIMPLE_BAD_ARG_ERROR("7.0::hash",2,"int");
    
    if(!Pike_sp[1-args].u.integer)
      PIKE_ERROR("7.0::hash", "Modulo by zero.\n", Pike_sp, args);

    i%=(unsigned INT32)Pike_sp[1-args].u.integer;
  }
  pop_n_elems(args);
  push_int( i );
}

/*! @decl int hash(string s)
 *! @decl int hash(string s, int max)
 *!
 *!   Return an integer derived from the string @[s]. The same string
 *!   always hashes to the same value, also between processes,
 *!   architectures, and Pike versions (see compatibility notes below,
 *!   though).
 *!
 *!   If @[max] is given, the result will be >= 0 and < @[max],
 *!   otherwise the result will be >= 0 and <= 0x7fffffff.
 *!
 *! @note
 *!   The hash algorithm was changed in Pike 7.5. If you want a hash
 *!   that is compatible with Pike 7.4 and earlier, use @[7.4::hash()].
 *!   The difference only affects wide strings.
 *!
 *!   The hash algorithm was also changed in Pike 7.1. If you want a hash
 *!   that is compatible with Pike 7.0 and earlier, use @[7.0::hash()].
 *!
 *! @note
 *!   This hash function differs from the one provided by @[hash_value()],
 *!   in that @[hash_value()] returns a process specific value.
 *!
 *! @seealso
 *!   @[hash_7_0()], @[7.4::hash()], @[hash_value]
 */
PMOD_EXPORT void f_hash(INT32 args)
{
  size_t i = 0;
  struct pike_string *s;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("hash",1);

  if(TYPEOF(Pike_sp[-args]) != T_STRING)
    SIMPLE_BAD_ARG_ERROR("hash", 1, "string");

  s = Pike_sp[-args].u.string;
  switch(s->size_shift) {
  case 0:
    i = simple_hashmem(STR0(s), s->len, 100);
    break;
  case 1:
    i = simple_hashmem1(STR1(s), s->len, 100);
    break;
  case 2:
    i = simple_hashmem2(STR2(s), s->len, 100);
    break;
#ifdef PIKE_DEBUG
  default:
    Pike_fatal("hash(): Unsupported string shift: %d\n", s->size_shift);
    break;
#endif
  }

  if(args > 1)
  {
    if(TYPEOF(Pike_sp[1-args]) != T_INT)
      SIMPLE_BAD_ARG_ERROR("hash",2,"int");
    
    if(Pike_sp[1-args].u.integer <= 0)
      PIKE_ERROR("hash", "Modulo < 1.\n", Pike_sp, args);

    i%=(unsigned INT32)Pike_sp[1-args].u.integer;
  }
  pop_n_elems(args);
  push_int64(i);
}

/*! @decl int hash_value (mixed value)
 *!
 *! Return a hash value for the argument. It's an integer in the
 *! native integer range.
 *!
 *! The hash will be the same for the same value in the running
 *! process only (the memory address is typically used as the basis
 *! for the hash value).
 *!
 *! If the value is an object with an @[lfun::__hash], that function
 *! is called and its result returned.
 *!
 *! @note
 *!   This is the hashing method used by mappings.
 *!
 *! @seealso
 *!   @[hash()], @[lfun::__hash()]
 */
void f_hash_value(INT32 args)
{
  unsigned INT32 h;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("hash_value",1);

  h = hash_svalue (Pike_sp - args);
  pop_n_elems (args);
  push_int (h);
}

/*! @decl mixed copy_value(mixed value)
 *!
 *!   Copy a value recursively.
 *!
 *!   If the result value is changed destructively (only possible for
 *!   multisets, arrays and mappings) the copied value will not be changed.
 *!
 *!   The resulting value will always be equal to the copied (as tested with
 *!   the function @[equal()]), but they may not the the same value (as tested
 *!   with @[`==()]).
 *!
 *! @seealso
 *!   @[equal()]
 */
PMOD_EXPORT void f_copy_value(INT32 args)
{
  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("copy_value",1);

  pop_n_elems(args-1);
  push_undefined();	/* Placeholder */
  copy_svalues_recursively_no_free(Pike_sp-1,Pike_sp-2,1,0);
  free_svalue(Pike_sp-2);
  move_svalue (Pike_sp - 2, Pike_sp - 1);
  Pike_sp--;
  dmalloc_touch_svalue(Pike_sp-1);
}

struct case_info {
  INT32 low;	/* low end of range. */
  INT16 mode;
  INT16 data;
};

#define CIM_NONE	   0	/* Case-less */
#define CIM_UPPERDELTA	   1	/* Upper-case, delta to lower-case in data */
#define CIM_LOWERDELTA	   2	/* Lower-case, -delta to upper-case in data */
#define CIM_CASEBIT	   3	/* Some case, case mask in data */
#define CIM_CASEBITOFF	   4	/* Same as above, but also offset by data */
#define CIM_LONGUPPERDELTA 5	/* Upper-case, delta + 0x7fff. */
#define CIM_LONGLOWERDELTA 6	/* Lower-case, delta + 0x7fff. */

static const struct case_info case_info[] = {
#include "case_info.h"
  { 0x7fffffff, CIM_NONE, 0x0000, },	/* End sentinel. */
};

static struct case_info *find_ci(INT32 c)
{
  static struct case_info *cache = NULL;
  struct case_info *ci = cache;
  int lo = 0;
  int hi = NELEM(case_info);

  if ((c < 0) || (c > 0xeffff)) {
    /* Negative, or plane 15 and above. */
    return NULL;
  }

  if ((ci) && (ci[0].low <= c) && (ci[1].low > c)) {
    return ci; 
  }

  while (lo != hi-1) {
    int mid = (lo + hi)/2;
    if (case_info[mid].low < c) {
      lo = mid;
    } else if (case_info[mid].low == c) {
      lo = mid;
      break;
    } else {
      hi = mid;
    }
  }
  return(cache = (struct case_info *)case_info + lo);
}

static struct case_info *find_ci_shift0(INT32 c)
{
  static struct case_info *cache = NULL;
  struct case_info *ci = cache;
  int lo = 0;
  int hi = CASE_INFO_SHIFT0_HIGH;

  if ((c < 0) || (c > 0xefffff)) {
    /* Negative, or plane 15 and above. */
    return NULL;
  }

  if ((ci) && (ci[0].low <= c) && (ci[1].low > c)) {
    return ci; 
  }

  while (lo != hi-1) {
    int mid = (lo + hi)>>1;
    if (case_info[mid].low < c) {
      lo = mid;
    } else if (case_info[mid].low == c) {
      lo = mid;
      break;
    } else {
      hi = mid;
    }
  }
  return(cache = (struct case_info *)case_info + lo);
}

#define DO_LOWER_CASE(C) do {\
    INT32 c = C; \
    if(c<0xb5){if(c >= 'A' && c <= 'Z' ) C=c+0x20; } \
    /*else if(c==0xa77d) C=0x1d79;*/ else { \
    struct case_info *ci = find_ci(c); \
    if (ci) { \
      switch(ci->mode) { \
      case CIM_NONE: case CIM_LOWERDELTA: case CIM_LONGLOWERDELTA: break; \
      case CIM_UPPERDELTA: C = c + ci->data; break; \
      case CIM_CASEBIT: C = c | ci->data; break; \
      case CIM_CASEBITOFF: C = ((c - ci->data) | ci->data) + ci->data; break; \
      case CIM_LONGUPPERDELTA: \
        C = c + ci->data + ( ci->data>0 ? 0x7fff : -0x8000 ); break; \
      DO_IF_DEBUG( default: Pike_fatal("lower_case(): Unknown case_info mode: %d\n", ci->mode); ) \
    } \
   }} \
  } while(0)

#define DO_LOWER_CASE_SHIFT0(C) do {\
    INT32 c = C; \
    if(c<0xb5){if(c >= 'A' && c <= 'Z' ) C=c+0x20;}else {\
    struct case_info *ci = find_ci_shift0(c); \
    if (ci) { \
      switch(ci->mode) { \
      case CIM_NONE: case CIM_LOWERDELTA: break; \
      case CIM_UPPERDELTA: C = c + ci->data; break; \
      case CIM_CASEBIT: C = c | ci->data; break; \
      case CIM_CASEBITOFF: C = ((c - ci->data) | ci->data) + ci->data; break; \
      DO_IF_DEBUG( default: Pike_fatal("lower_case(): Unknown case_info mode: %d\n", ci->mode); ) \
    } \
   }} \
  } while(0)

#define DO_UPPER_CASE(C) do {\
    INT32 c = C; \
    if(c<0xb5){if(c >= 'a' && c <= 'z' ) C=c-0x20; } \
    /*else if(c==0x1d79) C=0xa77d;*/ else {\
    struct case_info *ci = find_ci(c); \
    if (ci) { \
      switch(ci->mode) { \
      case CIM_NONE: case CIM_UPPERDELTA: case CIM_LONGUPPERDELTA: break; \
      case CIM_LOWERDELTA: C = c - ci->data; break; \
      case CIM_CASEBIT: C = c & ~ci->data; break; \
      case CIM_CASEBITOFF: C = ((c - ci->data)& ~ci->data) + ci->data; break; \
      case CIM_LONGLOWERDELTA: \
        C = c - ci->data - ( ci->data>0 ? 0x7fff : -0x8000 ); break; \
      DO_IF_DEBUG( default: Pike_fatal("upper_case(): Unknown case_info mode: %d\n", ci->mode); ) \
    } \
   }} \
  } while(0)

#define DO_UPPER_CASE_SHIFT0(C) do {\
    INT32 c = C; \
    if(c<0xb5){if(c >= 'a' && c <= 'z' ) C=c-0x20;}else {\
    struct case_info *ci = find_ci_shift0(c); \
    if (ci) { \
      switch(ci->mode) { \
      case CIM_NONE: case CIM_UPPERDELTA: break; \
      case CIM_LOWERDELTA: C = c - ci->data; break; \
      case CIM_CASEBIT: C = c & ~ci->data; break; \
      case CIM_CASEBITOFF: C = ((c - ci->data)& ~ci->data) + ci->data; break; \
      DO_IF_DEBUG( default: Pike_fatal("lower_case(): Unknown case_info mode: %d\n", ci->mode); ) \
    } \
   }} \
  } while(0)

/*! @decl string lower_case(string s)
 *! @decl int lower_case(int c)
 *!
 *!   Convert a string or character to lower case.
 *!
 *! @returns
 *!   Returns a copy of the string @[s] with all upper case characters
 *!   converted to lower case, or the character @[c] converted to lower
 *!   case.
 *!
 *! @note
 *!   Assumes the string or character to be coded according to
 *!   ISO-10646 (aka Unicode). If they are not, @[Charset.decoder] can
 *!   do the initial conversion for you.
 *!
 *! @note
 *!   Prior to Pike 7.5 this function only accepted strings.
 *!
 *! @seealso
 *!   @[upper_case()], @[Charset.decoder]
 */
PMOD_EXPORT void f_lower_case(INT32 args)
{
  ptrdiff_t i;
  struct pike_string *orig;
  struct pike_string *ret;

  check_all_args("lower_case", args, BIT_STRING|BIT_INT, 0);

  if (TYPEOF(Pike_sp[-args]) == T_INT) {
    /* NOTE: Performs the case change in place. */
    DO_LOWER_CASE(Pike_sp[-args].u.integer);
    pop_n_elems(args-1);
    return;
  }

  orig = Pike_sp[-args].u.string;

  if( orig->flags & STRING_IS_LOWERCASE )
      return;

  ret = begin_wide_shared_string(orig->len, orig->size_shift);

  memcpy(ret->str, orig->str, orig->len << orig->size_shift);

  i = orig->len;

  if (!orig->size_shift) {
    p_wchar0 *str = STR0(ret);

    while(i--) {
      DO_LOWER_CASE_SHIFT0(str[i]);
    }
  } else if (orig->size_shift == 1) {
    p_wchar1 *str = STR1(ret);

    while(i--) {
      DO_LOWER_CASE(str[i]);
    }
  } else if (orig->size_shift == 2) {
    p_wchar2 *str = STR2(ret);

    while(i--) {
      DO_LOWER_CASE(str[i]);
    }
#ifdef PIKE_DEBUG
  } else {
    Pike_fatal("lower_case(): Bad string shift:%d\n", orig->size_shift);
#endif
  }

  ret = end_shared_string(ret);
  ret->flags |= STRING_IS_LOWERCASE;
  pop_n_elems(args);
  push_string(ret);
}

/*! @decl string upper_case(string s)
 *! @decl int upper_case(int c)
 *!
 *!   Convert a string or character to upper case.
 *!
 *! @returns
 *!   Returns a copy of the string @[s] with all lower case characters
 *!   converted to upper case, or the character @[c] converted to upper
 *!   case.
 *!
 *! @note
 *!   Assumes the string or character to be coded according to
 *!   ISO-10646 (aka Unicode). If they are not, @[Charset.decoder] can
 *!   do the initial conversion for you.
 *!
 *! @note
 *!   Prior to Pike 7.5 this function only accepted strings.
 *!
 *! @seealso
 *!   @[lower_case()], @[Charset.decoder]
 */
PMOD_EXPORT void f_upper_case(INT32 args)
{
  ptrdiff_t i;
  struct pike_string *orig;
  struct pike_string *ret;
  check_all_args("upper_case", args, BIT_STRING|BIT_INT, 0);

  if (TYPEOF(Pike_sp[-args]) == T_INT) {
    /* NOTE: Performs the case change in place. */
    DO_UPPER_CASE(Pike_sp[-args].u.integer);
    pop_n_elems(args-1);
    return;
  }

  orig = Pike_sp[-args].u.string;
  if( orig->flags & STRING_IS_UPPERCASE )
  {
      return;
  }

  ret=begin_wide_shared_string(orig->len,orig->size_shift);
  memcpy(ret->str, orig->str, orig->len << orig->size_shift);

  i = orig->len;

  if (!orig->size_shift) {
    p_wchar0 *str = STR0(ret);

    while(i--) {
      if(str[i]!=0xff && str[i]!=0xb5) {
	DO_UPPER_CASE_SHIFT0(str[i]);
      } else {

	/* Ok, so our shiftsize 0 string contains 0xff or 0xb5 which
	   prompts for a shiftsize 1 string. */
	int j = orig->len;
	struct pike_string *wret = begin_wide_shared_string(j, 1);
	p_wchar1 *wstr = STR1(wret);

	/* Copy what we have done */
	while(--j>i)
	  wstr[j] = str[j];

	/* upper case the rest */
	i++;
	while(i--)
	  switch( str[i] ) {
	  case 0xff: wstr[i] = 0x178; break;
	  case 0xb5: wstr[i] = 0x39c; break;
	  default:
	    DO_UPPER_CASE_SHIFT0(str[i]);
	    wstr[i] = str[i];
	    break;
	  }

	/* Discard the too narrow string and use the new one instead. */
	do_free_unlinked_pike_string(ret);
	ret = wret;
	break;
      }
    }
  } else if (orig->size_shift == 1) {
    p_wchar1 *str = STR1(ret);

    while(i--) {
      DO_UPPER_CASE(str[i]);
    }
  } else if (orig->size_shift == 2) {
    p_wchar2 *str = STR2(ret);

    while(i--) {
      DO_UPPER_CASE(str[i]);
    }
#ifdef PIKE_DEBUG
  } else {
    Pike_fatal("lower_case(): Bad string shift:%d\n", orig->size_shift);
#endif
  }

  pop_n_elems(args);
  ret = end_shared_string(ret);
  ret->flags |= STRING_IS_UPPERCASE;
  push_string(ret);
}

/*! @decl string random_string(int len)
 *!
 *!   Returns a string of random characters 0-255 with the length @[len].
 */
PMOD_EXPORT void f_random_string(INT32 args)
{
  struct pike_string *ret;
  INT_TYPE len, e = 0;
  unsigned INT32 *str;
  get_all_args("random_string",args,"%+",&len);
  ret = begin_shared_string(len);

  /* Note: Assumes pike_string->str is aligned on a 4 byte boundary
   * (it is, currently)
   */
  str = (unsigned INT32 *)ret->str;

  while( (e+=sizeof(INT32)) <= len )
  {
    str[0] = DO_NOT_WARN(my_rand());
    str++;
  }

  for(e-=sizeof(INT32);e<len;e++)
  {
    ret->str[e] = DO_NOT_WARN((char)my_rand());
  }

  pop_n_elems(args);
  push_string(end_shared_string(ret));
}

/*! @decl void random_seed(int seed)
 *!
 *!   This function sets the initial value for the random generator.
 *!
 *! @seealso
 *!   @[random()]
 */
PMOD_EXPORT void f_random_seed(INT32 args)
{
  INT_TYPE i;
  check_all_args("random_seed",args,BIT_INT | BIT_OBJECT, 0);

  if(TYPEOF(Pike_sp[-args]) == T_INT)
  {
    i=Pike_sp[-args].u.integer;
  }else{
    i=hash_svalue(Pike_sp-args);
  }
  my_srand(i);
  pop_n_elems(args);
}

/*! @decl int query_num_arg()
 *!
 *!   Returns the number of arguments given when the previous function was
 *!   called.
 *!
 *!   This is useful for functions that take a variable number of arguments.
 *!
 *! @seealso
 *!   @[call_function()]
 */
void f_query_num_arg(INT32 args)
{
  pop_n_elems(args);
  push_int(Pike_fp ? Pike_fp->args : 0);
}

/*! @decl int search(string haystack, string|int needle, int|void start)
 *! @decl int search(array haystack, mixed needle, int|void start)
 *! @decl mixed search(mapping haystack, mixed needle, mixed|void start)
 *! @decl mixed search(object haystack, mixed needle, mixed|void start)
 *!
 *!   Search for @[needle] in @[haystack].
 *!
 *! @param haystack
 *!   Item to search in. This can be one of:
 *!   @mixed
 *!     @type string
 *!       When @[haystack] is a string @[needle] must be a string or an int,
 *!       and the first occurrence of the string or int is returned.
 *!
 *!     @type array
 *!       When @[haystack] is an array, @[needle] is compared only to
 *!       one value at a time in @[haystack].
 *!
 *!     @type mapping
 *!       When @[haystack] is a mapping, @[search()] tries to find the index
 *!       connected to the data @[needle]. That is, it tries to lookup the
 *!       mapping backwards.
 *!
 *!     @type object
 *!       When @[haystack] is an object implementing @[lfun::_search()],
 *!       the result of calling @[lfun::_search()] with @[needle] and @[start]
 *!       will be returned.
 *!
 *!       If @[haystack] is an object that doesn't implement @[lfun::_search()]
 *!       it is assumed to be an @[Iterator], and implement
 *!       @[Iterator()->index()], @[Iterator()->value()], and
 *!       @[Iterator()->next()]. @[search()] will then start comparing
 *!       elements with @[`==()] until a match with @[needle] is found.
 *!       If @[needle] is found @[haystack] will be advanced to the element,
 *!       and the iterator index will be returned. If @[needle] is not
 *!       found, @[haystack] will be advanced to the end.
 *!   @endmixed
 *!
 *! @param start
 *!   If the optional argument @[start] is present search is started at
 *!   this position.
 *!
 *! @returns
 *!   Returns the position of @[needle] in @[haystack] if found.
 *!
 *!   If not found the returned value depends on the type of @[haystack]:
 *!   @mixed
 *!     @type string|array
 *!       @expr{-1@}.
 *!     @type mapping|object(Iterator)
 *!       @[UNDEFINED].
 *!     @type object
 *!       The value returned by @[lfun::_search()].
 *!   @endmixed
 *!
 *! @note
 *!   If @[start] is supplied to an iterator object without an
 *!   @[lfun::_search()], @[haystack] will need to implement
 *!   @[Iterator()->set_index()].
 *!
 *! @note
 *!   For mappings and object @[UNDEFINED] will be returned when not found.
 *!   In all other cases @expr{-1@} will be returned when not found.
 *!
 *! @seealso
 *!   @[indices()], @[values()], @[zero_type()], @[has_value()], 
 *!   @[has_prefix()], @[has_suffix()]
 */
PMOD_EXPORT void f_search(INT32 args)
{
  ptrdiff_t start;

  if(args < 2)
    SIMPLE_TOO_FEW_ARGS_ERROR("search", 2);

  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_STRING:
  {
    struct pike_string *haystack = Pike_sp[-args].u.string;

    start=0;
    if(args > 2)
    {
      if(TYPEOF(Pike_sp[2-args]) != T_INT)
	SIMPLE_BAD_ARG_ERROR("search", 3, "int");

      start=Pike_sp[2-args].u.integer;
      if(start<0) {
	bad_arg_error("search", Pike_sp-args, args, 3, "int(0..)", Pike_sp+2-args,
		   "Start must be greater or equal to zero.\n");
      }
    }

    if(haystack->len < start)
      bad_arg_error("search", Pike_sp-args, args, 3, "int(0..)", Pike_sp-args,
		    "Start must not be greater than the "
		    "length of the string.\n");

    if ((TYPEOF(Pike_sp[1-args]) == T_INT) ||
	((TYPEOF(Pike_sp[1-args]) == T_STRING) &&
	 (Pike_sp[1-args].u.string->len == 1))) {
      INT_TYPE val;
      if (TYPEOF(Pike_sp[1-args]) == T_INT) {
	val = Pike_sp[1-args].u.integer;
      } else {
	val = index_shared_string(Pike_sp[1-args].u.string, 0);
      }

      if( !string_range_contains( haystack, val )  )
      {
          pop_n_elems(args);
          push_int( -1 );
          return;
      }
      switch(Pike_sp[-args].u.string->size_shift) {
      case 0:
	{
	  p_wchar0 *str = STR0(haystack);
	  if (val >= 256) {
	    start = -1;
	    break;
	  }
	  while (start < haystack->len) {
	    if (str[start] == val) break;
	    start++;
	  }
	}
	break;
      case 1:
	{
	  p_wchar1 *str = STR1(haystack);
	  if (val >= 65536) {
	    start = -1;
	    break;
	  }
	  while (start < haystack->len) {
	    if (str[start] == val) break;
	    start++;
	  }
	}
	break;
      case 2:
	{
	  p_wchar2 *str = STR2(haystack);
	  while (start < haystack->len) {
	    if (str[start] == (p_wchar2)val) break;
	    start++;
	  }
	}
	break;
#ifdef PIKE_DEBUG
      default:
	Pike_fatal("search(): Unsupported string shift: %d!\n",
	      haystack->size_shift);
	break;
#endif
      }
      if (start >= haystack->len) {
	start = -1;
      }
    } else if(TYPEOF(Pike_sp[1-args]) == T_STRING) {
      /* Handle searching for the empty string. */
      if (Pike_sp[1-args].u.string->len) {
	start = string_search(haystack,
			      Pike_sp[1-args].u.string,
			      start);
      }
    } else {
      SIMPLE_BAD_ARG_ERROR("search", 2, "string | int");
    }
    pop_n_elems(args);
    push_int64(start);
    break;
  }

  case T_ARRAY:
    start=0;
    if(args > 2)
    {
      if(TYPEOF(Pike_sp[2-args]) != T_INT)
	SIMPLE_BAD_ARG_ERROR("search", 3, "int");

      start=Pike_sp[2-args].u.integer;
      if(start<0) {
	bad_arg_error("search", Pike_sp-args, args, 3, "int(0..)", Pike_sp+2-args,
		   "Start must be greater or equal to zero.\n");
      }
    }
    start=array_search(Pike_sp[-args].u.array,Pike_sp+1-args,start);
    pop_n_elems(args);
    push_int64(start);
    break;

  case T_MAPPING:
    if(args > 2) {
      mapping_search_no_free(Pike_sp,Pike_sp[-args].u.mapping,Pike_sp+1-args,Pike_sp+2-args);
    } else {
      mapping_search_no_free(Pike_sp,Pike_sp[-args].u.mapping,Pike_sp+1-args,0);
    }
    free_svalue(Pike_sp-args);
    Pike_sp[-args]=*Pike_sp;
    dmalloc_touch_svalue(Pike_sp);
    pop_n_elems(args-1);
    return;

  case T_OBJECT:
    {
      struct program *p;
      if ((p = (Pike_sp[-args].u.object->prog))) {
	struct object *o = Pike_sp[-args].u.object;
	int id_level = p->inherits[SUBTYPEOF(Pike_sp[-args])].identifier_level;
	int id;
	int next, ind;
	p = p->inherits[SUBTYPEOF(Pike_sp[-args])].prog;

	/* NOTE: Fake lfun! */
	id = low_find_lfun(p, LFUN__SEARCH);
	/* First try lfun::_search(). */
	if (id >= 0) {
	  apply_low(o, id + id_level, args-1);
	  stack_pop_n_elems_keep_top(1);
	  return;
	}

	/* Check if we have an iterator. */
	if (((id = find_identifier("value", p)) >= 0) &&
	    ((next = find_identifier("next", p)) >= 0) &&
	    ((ind = find_identifier("index", p)) >= 0)) {
	  /* We have an iterator. */

	  id += id_level;
	  next += id_level;
	  ind += id_level;

	  /* Set the start position if needed. */
	  if (args > 2) {
	    int fun = find_identifier("set_index", p);
	    if (fun < 0)
	      Pike_error ("Cannot call unknown function \"%s\".\n", fun);
	    apply_low(o, fun + id_level, args-2);
	    pop_stack();
	  }

	  /* At this point we have two values on the stack. */

	  while(1) {
	    apply_low(o, id, 0);
	    if (is_eq(Pike_sp-2, Pike_sp-1)) {
	      /* Found. */
	      apply_low(o, ind, 0);
	      stack_pop_n_elems_keep_top(3);
	      return;
	    }
	    apply_low(o, next, 0);
	    if (UNSAFE_IS_ZERO(Pike_sp-1)) {
	      /* Not found. */
	      pop_n_elems(4);
	      /* FIXME: Should probably indicate not found in some other way.
	       *        On the other hand, the iterator should be false now.
	       */
	      push_undefined();	
	      return;
	    }
	    pop_n_elems(2);
	  }
	}
      }
    }
    /* FALL_THROUGH */
  default:
    SIMPLE_BAD_ARG_ERROR("search", 1, "string|array|mapping|object");
  }
}

/*! @decl int has_prefix(string|object s, string prefix)
 *!
 *!   Returns @expr{1@} if the string @[s] starts with @[prefix],
 *!   returns @expr{0@} (zero) otherwise.
 *!
 *!   When @[s] is an object, it needs to implement
 *!   @[lfun::_sizeof()] and @[lfun::`[]].
 *!
 *! @seealso
 *!    @[has_suffix()], @[has_value()], @[search()]
 */
PMOD_EXPORT void f_has_prefix(INT32 args)
{
  struct pike_string *a, *b;

  if(args<2)
    SIMPLE_TOO_FEW_ARGS_ERROR("has_prefix", 2);
  if((TYPEOF(Pike_sp[-args]) != T_STRING) &&
     (TYPEOF(Pike_sp[-args]) != T_OBJECT))
    SIMPLE_ARG_TYPE_ERROR("has_prefix", 1, "string|object");
  if(TYPEOF(Pike_sp[1-args]) != T_STRING)
    SIMPLE_ARG_TYPE_ERROR("has_prefix", 2, "string");

  b = Pike_sp[1-args].u.string;

  if (TYPEOF(Pike_sp[-args]) == T_OBJECT) {
    ptrdiff_t i;
    struct object *o = Pike_sp[-args].u.object;
    int inherit_no = SUBTYPEOF(Pike_sp[-args]);

    if (!o->prog || FIND_LFUN(o->prog, LFUN__SIZEOF) < 0) {
      Pike_error("Object in argument 1 lacks lfun::_sizeof().\n");
    }

    apply_lfun(o, LFUN__SIZEOF, 0);
    if ((TYPEOF(Pike_sp[-1]) != T_INT) || (Pike_sp[-1].u.integer < b->len)) {
      pop_n_elems(args + 1);
      push_int(0);
      return;
    }

    for (i = 0; i < b->len; i++) {
      p_wchar2 ch = index_shared_string(b, i);
      Pike_sp[-1].u.integer = i;
      /* Note: Integers do not need to be freed. */
      object_index_no_free(Pike_sp-1, o, inherit_no, Pike_sp-1);
      if (TYPEOF(Pike_sp[-1]) != PIKE_T_INT) {
	Pike_error("Unexepected value returned from index operator.\n");
      }
      if (ch != Pike_sp[-1].u.integer) {
	pop_n_elems(args + 1);
	push_int(0);
	return;
      }
    }
    pop_n_elems(args+1);
    push_int(1);
    return;
  }

  a = Pike_sp[-args].u.string;

  /* First handle some common special cases. */
  if ((b->len > a->len) || (b->size_shift > a->size_shift)
      || !string_range_contains_string(a, b)) {
    pop_n_elems(args);
    push_int(0);
    return;
  }

  /* Trivial cases. */
  if ((a == b)||(!b->len)) {
    pop_n_elems(args);
    push_int(1);
    return;
  }

  if (a->size_shift == b->size_shift) {
    int res = !memcmp(a->str, b->str, b->len << b->size_shift);
    pop_n_elems(args);
    push_int(res);
    return;
  }

  /* At this point a->size_shift > b->size_shift */
#define TWO_SHIFTS(S1, S2)	((S1)|((S2)<<2))
  switch(TWO_SHIFTS(a->size_shift, b->size_shift)) {
#define CASE_SHIFT(S1, S2) \
  case TWO_SHIFTS(S1, S2): \
    { \
      PIKE_CONCAT(p_wchar,S1) *s1 = PIKE_CONCAT(STR,S1)(a); \
      PIKE_CONCAT(p_wchar,S2) *s2 = PIKE_CONCAT(STR,S2)(b); \
      ptrdiff_t len = b->len; \
      while(len-- && (s1[len] == s2[len])) \
	; \
      pop_n_elems(args); \
      push_int(len == -1); \
      return; \
    } \
    break

    CASE_SHIFT(1,0);
    CASE_SHIFT(2,0);
    CASE_SHIFT(2,1);
#ifdef PIKE_DEBUG
  default:
    Pike_error("Unexpected string shift combination: a:%d, b:%d!\n",
	  a->size_shift, b->size_shift);
    break;
#endif
  }
#undef CASE_SHIFT
#undef TWO_SHIFTS
}

/*! @decl int has_suffix(string s, string suffix)
 *!
 *!   Returns @expr{1@} if the string @[s] ends with @[suffix],
 *!   returns @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!    @[has_prefix()], @[has_value()], @[search()]
 */
PMOD_EXPORT void f_has_suffix(INT32 args)
{
  struct pike_string *a, *b;

  if(args<2)
    SIMPLE_TOO_FEW_ARGS_ERROR("has_suffix", 2);
  if(TYPEOF(Pike_sp[-args]) != T_STRING)
    SIMPLE_ARG_TYPE_ERROR("has_suffix", 1, "string");
  if(TYPEOF(Pike_sp[1-args]) != T_STRING)
    SIMPLE_ARG_TYPE_ERROR("has_suffix", 2, "string");

  a = Pike_sp[-args].u.string;
  b = Pike_sp[1-args].u.string;

  /* First handle some common special cases. */
  if ((b->len > a->len) || (b->size_shift > a->size_shift)
      || !string_range_contains_string(a, b)) {
    pop_n_elems(args);
    push_int(0);
    return;
  }

  /* Trivial cases. */
  if ((a == b)||(!b->len)) {
    pop_n_elems(args);
    push_int(1);
    return;
  }

  if (a->size_shift == b->size_shift) {
    int res = !memcmp(a->str + ((a->len - b->len)<<b->size_shift), b->str,
		      b->len << b->size_shift);
    pop_n_elems(args);
    push_int(res);
    return;
  }

  /* At this point a->size_shift > b->size_shift */
#define TWO_SHIFTS(S1, S2)	((S1)|((S2)<<2))
  switch(TWO_SHIFTS(a->size_shift, b->size_shift)) {
#define CASE_SHIFT(S1, S2) \
  case TWO_SHIFTS(S1, S2): \
    { \
      PIKE_CONCAT(p_wchar,S1) *s1 = PIKE_CONCAT(STR,S1)(a) + a->len - b->len; \
      PIKE_CONCAT(p_wchar,S2) *s2 = PIKE_CONCAT(STR,S2)(b); \
      ptrdiff_t len = b->len; \
      while(len-- && (s1[len] == s2[len])) \
	; \
      pop_n_elems(args); \
      push_int(len == -1); \
      return; \
    } \
    break

    CASE_SHIFT(1,0);
    CASE_SHIFT(2,0);
    CASE_SHIFT(2,1);
#ifdef PIKE_DEBUG
  default:
    Pike_error("Unexpected string shift combination: a:%d, b:%d!\n",
	  a->size_shift, b->size_shift);
    break;
#endif
  }
#undef CASE_SHIFT
#undef TWO_SHIFTS
}

/*! @decl int has_index(string haystack, int index)
 *! @decl int has_index(array haystack, int index)
 *! @decl int has_index(mapping|multiset|object|program haystack, mixed index)
 *!
 *!   Search for @[index] in @[haystack].
 *!
 *! @returns
 *!   Returns @expr{1@} if @[index] is in the index domain of @[haystack],
 *!   or @expr{0@} (zero) if not found.
 *!
 *!   This function is equivalent to (but sometimes faster than):
 *!
 *! @code
 *! search(indices(haystack), index) != -1
 *! @endcode
 *!
 *! @note
 *!   A negative index in strings and arrays as recognized by the
 *!   index operators @expr{`[]()@} and @expr{`[]=()@} is not considered
 *!   a proper index by @[has_index()]
 *!
 *! @seealso
 *!   @[has_value()], @[has_prefix()], @[has_suffix()], @[indices()],
 *!   @[search()], @[values()], @[zero_type()]
 */
PMOD_EXPORT void f_has_index(INT32 args)
{
  int t = 0;
  
  if(args < 2)
    SIMPLE_TOO_FEW_ARGS_ERROR("has_index", 2);
  if(args > 2)
    pop_n_elems(args-2);

  switch(TYPEOF(Pike_sp[-2]))
  {
    case T_STRING:
      if(TYPEOF(Pike_sp[-1]) == T_INT)
	t = (0 <= Pike_sp[-1].u.integer && Pike_sp[-1].u.integer < Pike_sp[-2].u.string->len);
  
      pop_n_elems(args);
      push_int(t);
      break;
      
    case T_ARRAY:
      if(TYPEOF(Pike_sp[-1]) == T_INT)
	t = (0 <= Pike_sp[-1].u.integer && Pike_sp[-1].u.integer < Pike_sp[-2].u.array->size);
      
      pop_n_elems(args);
      push_int(t);
      break;
      
    case T_MAPPING:
        t=!!low_mapping_lookup( Pike_sp[-2].u.mapping, Pike_sp-1 );
        pop_n_elems(2);
        push_int(t);
        break;

    case T_MULTISET:
        t = multiset_member( Pike_sp[-2].u.multiset, Pike_sp-1 );
        pop_n_elems(2);
        push_int(t);
        break;
      
    case T_OBJECT:
    case T_PROGRAM:
      /* FIXME: If the object behaves like an array, it will throw an
	 error for non-valid indices. Therefore it's not a good idea
	 to use the index operator.

	 Maybe we should use object->_has_index(index) provided that
	 the object implements it.
	 
	 /Noring */
      /* If it is an iterator object we may want to use the iterator
         interface to look for the index. */

      stack_swap();
      f_indices(1);
      stack_swap();
      f_search(2);
      
      if(TYPEOF(Pike_sp[-1]) == T_INT)
	Pike_sp[-1].u.integer = (Pike_sp[-1].u.integer != -1);
      else
	PIKE_ERROR("has_index",
		   "Function `search' gave incorrect result.\n", Pike_sp, args);
      break;

    default:
      SIMPLE_ARG_TYPE_ERROR ("has_index", 1,
			     "string|array|mapping|multiset|object|program");
  }
}

/*! @decl int has_value(string haystack, string value)
 *! @decl int has_value(string haystack, int value)
 *! @decl int has_value(array|mapping|object|program haystack, mixed value)
 *!
 *!   Search for @[value] in @[haystack].
 *!
 *! @returns
 *!   Returns @expr{1@} if @[value] is in the value domain of @[haystack],
 *!   or @expr{0@} (zero) if not found.
 *!
 *!   This function is in all cases except when both arguments are strings
 *!   equivalent to (but sometimes faster than):
 *!
 *! @code
 *! search(values(@[haystack]), @[value]) != -1
 *! @endcode
 *!
 *!   If both arguments are strings, @[has_value()] is equivalent to:
 *!
 *! @code
 *! search(@[haystack], @[value]) != -1
 *! @endcode
 *!
 *! @seealso
 *!   @[has_index()], @[indices()], @[search()], @[has_prefix()], 
 *!   @[has_suffix()], @[values()], @[zero_type()]
 */
PMOD_EXPORT void f_has_value(INT32 args)
{
  if(args < 2)
    SIMPLE_TOO_FEW_ARGS_ERROR("has_value", 2);
  if(args > 2)
    pop_n_elems(args-2);

  switch(TYPEOF(Pike_sp[-2]))
  {
    case T_MAPPING:
      f_search(2);
      f_zero_type(1);
      
      if(TYPEOF(Pike_sp[-1]) == T_INT)
	Pike_sp[-1].u.integer = !Pike_sp[-1].u.integer;
      else
	PIKE_ERROR("has_value",
		   "Function `zero_type' gave incorrect result.\n", Pike_sp, args);
      break;

    case T_PROGRAM:
    case T_OBJECT:
      /* FIXME: It's very sad that we always have to do linear search
	 with `values' in case of objects. The problem is that we cannot
	 use `search' directly since it's undefined whether it returns
	 -1 (array) or 0 (mapping) during e.g. some data type emulation.
	 
	 Maybe we should use object->_has_value(value) provided that
	 the object implements it.
	 
	 /Noring */

      /* FALL_THROUGH */

    case T_MULTISET:
      /* FIXME: This behavior for multisets isn't clean. It should be
       * compat only. */
      stack_swap();
      f_values(1);
      stack_swap();

      /* FALL_THROUGH */

    case T_STRING:   /* Strings are odd. /Noring */
    case T_ARRAY:
      f_search(2);

      if(TYPEOF(Pike_sp[-1]) == T_INT)
	Pike_sp[-1].u.integer = (Pike_sp[-1].u.integer != -1);
      else
	PIKE_ERROR("has_value", "Search gave incorrect result.\n", Pike_sp, args);
      break;

    default:
      SIMPLE_ARG_TYPE_ERROR ("has_value", 1, "string|array|mapping|object|program");
  }
}

/*! @decl void add_constant(string name, mixed value)
 *! @decl void add_constant(string name)
 *!
 *!   Add a new predefined constant.
 *!
 *!   This function is often used to add builtin functions.
 *!   All programs compiled after the @[add_constant()] function has been
 *!   called can access @[value] by the name @[name].
 *!
 *!   If there is a constant called @[name] already, it will be replaced by
 *!   by the new definition. This will not affect already compiled programs.
 *!
 *!   Calling @[add_constant()] without a value will remove that name from
 *!   the list of constants. As with replacing, this will not affect already
 *!   compiled programs.
 *!
 *! @seealso
 *!   @[all_constants()]
 */
PMOD_EXPORT void f_add_constant(INT32 args)
{
  ASSERT_SECURITY_ROOT("add_constant");

  if(args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("add_constant", 1);

  if(TYPEOF(Pike_sp[-args]) != T_STRING)
    SIMPLE_BAD_ARG_ERROR("add_constant", 1, "string");

  if(args>1)
  {
    dmalloc_touch_svalue(Pike_sp-args+1);
    low_add_efun(Pike_sp[-args].u.string, Pike_sp-args+1);
  }else{
    low_add_efun(Pike_sp[-args].u.string, 0);
  }
  pop_n_elems(args);
}

/*! @decl string combine_path(string path, string ... paths)
 *! @decl string combine_path_unix(string path, string ... paths)
 *! @decl string combine_path_nt(string path, string ... paths)
 *! @decl string combine_path_amigaos(string path, string ... paths)
 *!
 *!   Concatenate a number of paths to a straightforward path without
 *!   any @expr{"//"@}, @expr{"/.."@} or @expr{"/."@}. If any path
 *!   argument is absolute then the result is absolute and the
 *!   preceding arguments are ignored. If the result is relative then
 *!   it might have leading @expr{".."@} components. If the last
 *!   nonempty argument ends with a directory separator then the
 *!   result ends with that too. If all components in a relative path
 *!   disappear due to subsequent @expr{".."@} components then the
 *!   result is @expr{"."@}.
 *!
 *!   @[combine_path_unix()] concatenates in UNIX style, which also is
 *!   appropriate for e.g. URL:s ("/" separates path components and
 *!   absolute paths start with "/"). @[combine_path_nt()]
 *!   concatenates according to NT filesystem conventions ("/" and "\"
 *!   separates path components and there might be a drive letter in
 *!   front of absolute paths). @[combine_path_amigaos()] concatenates
 *!   according to AmigaOS filesystem conventions.
 *!
 *!   @[combine_path()] is equivalent to @[combine_path_unix()] on UNIX-like
 *!   operating systems, and equivalent to @[combine_path_nt()] on NT-like
 *!   operating systems, and equivalent to @[combine_path_amigaos()] on
 *!   AmigaOS-like operating systems.
 *!
 *! @seealso
 *!   @[getcwd()], @[Stdio.append_path()]
 */

#define NT_COMBINE_PATH
#include "combine_path.h"

#define UNIX_COMBINE_PATH
#include "combine_path.h"

#define AMIGAOS_COMBINE_PATH
#include "combine_path.h"



/*! @decl int zero_type(mixed a)
 *!
 *!   Return the type of zero.
 *!
 *!   There are many types of zeros out there, or at least there are two.
 *!   One is returned by normal functions, and one returned by mapping
 *!   lookups and @[find_call_out()] when what you looked for wasn't there.
 *!   The only way to separate these two kinds of zeros is @[zero_type()].
 *!
 *! @returns
 *!   When doing a @[find_call_out()] or mapping lookup, @[zero_type()] on
 *!   this value will return @expr{1@} if there was no such thing present in
 *!   the mapping, or if no such @tt{call_out@} could be found.
 *!
 *!   If the argument to @[zero_type()] is a destructed object or a function
 *!   in a destructed object, @expr{2@} will be returned.
 *!
 *!   In all other cases @[zero_type()] will return @expr{0@} (zero).
 *!
 *! @seealso
 *!   @[find_call_out()]
 */
PMOD_EXPORT void f_zero_type(INT32 args)
{
  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("zero_type",1);

  if(IS_DESTRUCTED(Pike_sp-args))
  {
    pop_n_elems(args);
    push_int(NUMBER_DESTRUCTED);
  }
  else if(TYPEOF(Pike_sp[-args]) != T_INT)
  {
    pop_n_elems(args);
    push_int(0);
  }
  else
  {
    pop_n_elems(args-1);
    Pike_sp[-1].u.integer = SUBTYPEOF(Pike_sp[-1]);
    SET_SVAL_SUBTYPE(Pike_sp[-1], NUMBER_NUMBER);
  }
}

static int generate_arg_for(node *n)
{
  if(count_args(CDR(n)) != 1) return 0;
  if(do_docode(CDR(n),DO_NOT_COPY) != 1)
    Pike_fatal("Count args was wrong in generate_zero_type().\n");
  return 1;
}

static int generate_zero_type(node *n)
{
  struct compilation *c = THIS_COMPILATION;
  if( generate_arg_for( n ) )
      emit0(F_ZERO_TYPE);
  else
      return 0;
  return 1;
}

static int generate_undefinedp(node *n)
{
  struct compilation *c = THIS_COMPILATION;
  if( generate_arg_for(n) )
      emit0(F_UNDEFINEDP);
  else
      return 0;
  return 1;
}

static int generate_destructedp(node *n)
{
  struct compilation *c = THIS_COMPILATION;
  if( generate_arg_for(n) )
      emit0(F_DESTRUCTEDP);
  else
      return 0;
  return 1;
}

/*
 * Some wide-strings related functions
 */

/*! @decl string(0..255) string_to_unicode(string s, int(0..2)|void byteorder)
 *!
 *!   Converts a string into an UTF16 compliant byte-stream.
 *!
 *! @param s
 *!   String to convert to UTF16.
 *!
 *! @param byteorder
 *!   Byte-order for the output. One of:
 *!   @int
 *!     @value 0
 *!       Network (aka big-endian) byte-order (default).
 *!     @value 1
 *!       Little-endian byte-order.
 *!     @value 2
 *!       Native byte-order.
 *!   @endint
 *!
 *! @note
 *!   Throws an error if characters not legal in an UTF16 stream are
 *!   encountered. Valid characters are in the range 0x00000 - 0x10ffff,
 *!   except for characters 0xfffe and 0xffff.
 *!
 *!   Characters in range 0x010000 - 0x10ffff are encoded using surrogates.
 *!
 *! @seealso
 *!   @[Charset.decoder()], @[string_to_utf8()], @[unicode_to_string()],
 *!   @[utf8_to_string()]
 */
PMOD_EXPORT void f_string_to_unicode(INT32 args)
{
  struct pike_string *in;
  struct pike_string *out = NULL;
  ptrdiff_t len;
  ptrdiff_t i;
  unsigned INT_TYPE byteorder = 0;

  get_all_args("string_to_unicode", args, "%W.%i", &in, &byteorder);

  if (byteorder >= 2) {
    if (byteorder == 2) {
#if PIKE_BYTEORDER == 1234
      /* Little endian. */
      byteorder = 1;
#else
      byteorder = 0;
#endif
    } else {
      SIMPLE_BAD_ARG_ERROR("string_to_unicode", 2, "int(0..2)|void");
    }
  }

  switch(in->size_shift) {
  case 0:
    /* Just 8bit characters */
    len = in->len * 2;
    out = begin_shared_string(len);
    if (len) {
      memset(out->str, 0, len);	/* Clear the upper (and lower) byte */
      for(i = in->len; i--;) {
	out->str[i * 2 + 1 - byteorder] = in->str[i];
      }
    }
    out = end_shared_string(out);
    break;
  case 1:
    /* 16 bit characters */
    /* FIXME: Should we check for 0xfffe & 0xffff here too? */
    len = in->len * 2;
    out = begin_shared_string(len);
    if (byteorder ==
#if (PIKE_BYTEORDER == 4321)
	1	/* Little endian. */
#else
	0	/* Big endian. */
#endif
	) {
      /* Other endianness, may need to do byte-order conversion also. */
      p_wchar1 *str1 = STR1(in);
      for(i = in->len; i--;) {
	unsigned INT32 c = str1[i];
	out->str[i * 2 + 1 - byteorder] = c & 0xff;
	out->str[i * 2 + byteorder] = c >> 8;
      }
    } else {
      /* Native byte order -- We don't need to do much...
       *
       * FIXME: Future optimization: Check if refcount is == 1,
       * and perform sufficient magic to be able to convert in place.
       */
      memcpy(out->str, in->str, len);
    }
    out = end_shared_string(out);
    break;
  case 2:
    /* 32 bit characters -- Is someone writing in Klingon? */
    {
      p_wchar2 *str2 = STR2(in);
      ptrdiff_t j;
      len = in->len * 2;
      /* Check how many extra wide characters there are. */
      for(i = in->len; i--;) {
	if (str2[i] > 0xfffd) {
	  if (str2[i] < 0x10000) {
	    /* 0xfffe: Byte-order detection illegal character.
	     * 0xffff: Illegal character.
	     */
	    Pike_error("Illegal character 0x%04x (index %ld) "
                       "is not a Unicode character.",
                       str2[i], PTRDIFF_T_TO_LONG(i));
	  }
	  if (str2[i] > 0x10ffff) {
	    Pike_error("Character 0x%08x (index %ld) "
                       "is out of range (0x00000000..0x0010ffff).",
                       str2[i], PTRDIFF_T_TO_LONG(i));
	  }
	  /* Extra wide characters take two UTF16 characters in space.
	   * ie One UTF16 character extra.
	   */
	  len += 2;
	}
      }
      out = begin_shared_string(len);
      j = len;
      for(i = in->len; i--;) {
	unsigned INT32 c = str2[i];

	j -= 2;

	if (c > 0xffff) {
	  /* Use surrogates */
	  c -= 0x10000;

	  out->str[j + 1 - byteorder] = c & 0xff;
	  out->str[j + byteorder] = 0xdc | ((c >> 8) & 0x03);
	  j -= 2;
	  c >>= 10;
	  c |= 0xd800;
	}
	out->str[j + 1 - byteorder] = c & 0xff;
	out->str[j + byteorder] = c >> 8;
      }
#ifdef PIKE_DEBUG
      if (j) {
	Pike_fatal("string_to_unicode(): Indexing error: len:%ld, j:%ld.\n",
	      PTRDIFF_T_TO_LONG(len), PTRDIFF_T_TO_LONG(j));
      }
#endif /* PIKE_DEBUG */
      out = end_shared_string(out);
    }
    break;
#ifdef PIKE_DEBUG
  default:
    Pike_fatal("string_to_unicode(): Bad string shift: %d!\n", in->size_shift);
    break;
#endif
  }
  pop_n_elems(args);
  push_string(out);
}

/*! @decl string unicode_to_string(string(0..255) s, int(0..2)|void byteorder)
 *!
 *!   Converts an UTF16 byte-stream into a string.
 *!
 *! @param s
 *!   String to convert to UTF16.
 *!
 *! @param byteorder
 *!   Default input byte-order. One of:
 *!   @int
 *!     @value 0
 *!       Network (aka big-endian) byte-order (default).
 *!     @value 1
 *!       Little-endian byte-order.
 *!     @value 2
 *!       Native byte-order.
 *!   @endint
 *!   Note that this argument is disregarded if @[s] starts with a BOM.
 *!
 *! @note
 *!   This function did not decode surrogates in Pike 7.2 and earlier.
 *!
 *! @seealso
 *!   @[Charset.decoder()], @[string_to_unicode()], @[string_to_utf8()],
 *!   @[utf8_to_string()]
 */
PMOD_EXPORT void f_unicode_to_string(INT32 args)
{
  struct pike_string *in;
  struct pike_string *out = NULL;
  ptrdiff_t len, i, num_surrogates = 0;
  INT_TYPE byteorder = 0;
  int swab=0;
  p_wchar1 surr1, surr2, surrmask, *str0;

  get_all_args("unicode_to_string", args, "%S.%i", &in, &byteorder);

  if (in->len & 1) {
    bad_arg_error("unicode_to_string", Pike_sp-args, args, 1, "string", Pike_sp-args,
		  "String length is odd.\n");
  }

  if (byteorder >= 2) {
    if (byteorder == 2) {
#if PIKE_BYTEORDER == 1234
      /* Little endian. */
      byteorder = 1;
#else
      byteorder = 0;
#endif
    } else {
      SIMPLE_BAD_ARG_ERROR("unicode_to_string", 2, "int(0..2)|void");
    }
  }

  if (byteorder !=
#if PIKE_BYTEORDER == 1234
      1
#else
      0
#endif
      ) {
    /* Need to swap as the wanted byte-order differs
     * from the native byte-order.
     */
    swab = 1;
  }

  /* Check byteorder of UTF data */
  str0 = (p_wchar1 *)in->str;
  len = in->len;
  if (len && (str0[0] == 0xfeff)) {
    /* Correct byte order mark.  No swap necessary. */
    swab = 0;
    str0 ++;
    len -= 2;
  } else if (len && (str0[0] == 0xfffe)) {
    /* Reversed byte order mark.  Need to swap. */
    swab = 1;
    str0 ++;
    len -= 2;
  } else {
    /* No byte order mark.  Use the user-specified byte-order. */
  }

  /* Indentify surrogates by pre-swapped bitmasks, for efficiency */
  if (swab) {
    surr1 = 0xd8;
    surr2 = 0xdc;
    surrmask = 0xfc;
  } else {
    surr1 = 0xd800;
    surr2 = 0xdc00;
    surrmask = 0xfc00;
  }

  /* Count number of surrogates */
  for (i = len; i >= 4; i -= 2, str0++)
    if ( (str0[0]&surrmask) == surr1 &&
	 (str0[1]&surrmask) == surr2 )
      num_surrogates ++;

  /* Move str0 past the last word */
  str0++;

  len = len / 2 - num_surrogates;

  out = begin_wide_shared_string(len, (num_surrogates? 2 : 1));

  if (!swab) {
    /* Native endian */
    if (num_surrogates) {
      /* Convert surrogates */

      p_wchar2 *str2 = STR2(out);

      for (i = len; i--; --str0)

	if ((str0[-1]&surrmask) == surr2 && num_surrogates &&
	    (str0[-2]&surrmask) == surr1) {
	    
	  str2[i] = ((str0[-2]&0x3ff)<<10) + (str0[-1]&0x3ff) + 0x10000;

	  --str0;
	  --num_surrogates;

	} else

	  str2[i] = str0[-1];

    } else
    /*
     * FIXME: Future optimization: Perform sufficient magic
     * to do the conversion in place if the ref-count is == 1.
     */
      memcpy(out->str, str0-len, len*2);
  } else {
    /* Reverse endian */
    
    if (num_surrogates) {
      /* Convert surrogates */

      p_wchar2 *str2 = STR2(out);

      for (i = len; i--; --str0) {

	if ((str0[-1]&surrmask) == surr2 && num_surrogates &&
	    (str0[-2]&surrmask) == surr1) {
	    
#if (PIKE_BYTEORDER == 4321)
	  str2[i] = ((((unsigned char *)str0)[-3]&3)<<18) +
	    (((unsigned char *)str0)[-4]<<10) +
	    ((((unsigned char *)str0)[-1]&3)<<8) +
	    ((unsigned char *)str0)[-2] +
	    0x10000;
#else /* PIKE_BYTEORDER != 4321 */
	  str2[i] = ((((unsigned char *)str0)[-4]&3)<<18) +
	    (((unsigned char *)str0)[-3]<<10) +
	    ((((unsigned char *)str0)[-2]&3)<<8) +
	    ((unsigned char *)str0)[-1] +
	    0x10000;
#endif /* PIKE_BYTEORDER == 4321 */
	  --str0;
	  --num_surrogates;

	} else {
#if (PIKE_BYTEORDER == 4321)
	  str2[i] = (((unsigned char *)str0)[-1]<<8) +
	    ((unsigned char *)str0)[-2];
#else /* PIKE_BYTEORDER != 4321 */
	  str2[i] = (((unsigned char *)str0)[-2]<<8) +
	    ((unsigned char *)str0)[-1];
#endif /* PIKE_BYTEORDER == 4321 */
	}
      }
    } else {
      /* No surrogates */

      p_wchar1 *str1 = STR1(out);

      for (i = len; i--; --str0) {
#if (PIKE_BYTEORDER == 4321)
	str1[i] = (((unsigned char *)str0)[-1]<<8) +
	  ((unsigned char *)str0)[-2];
#else /* PIKE_BYTEORDER != 4321 */
	str1[i] = (((unsigned char *)str0)[-2]<<8) +
	  ((unsigned char *)str0)[-1];
#endif /* PIKE_BYTEORDER == 4321 */
      }
    }
  }
  out = end_shared_string(out);
  pop_n_elems(args);
  push_string(out);
}

/*! @decl string(1..) string_filter_non_unicode(string s)
 *!
 *!  Replace the most obviously non-unicode characters from @[s] with
 *!  the unicode replacement character.
 *!
 *! @note
 *!   This will replace characters outside the ranges
 *!   @expr{0x00000000-0x0000d7ff@} and @expr{0x0000e000-0x0010ffff@}
 *!   with 0xffea (the replacement character).
 *!
 *! @seealso
 *!   @[Charset.encoder()], @[string_to_unicode()],
 *!   @[unicode_to_string()], @[utf8_to_string()], @[string_to_utf8()]
 */
static void f_string_filter_non_unicode( INT32 args )
{
  struct pike_string *in;
  INT32 min,max;
  int i;
  static const p_wchar1 replace = 0xfffd;
  static const PCHARP repl_char = {(void*)&replace,1};

  get_all_args("filter_non_unicode", args, "%W", &in);
  check_string_range( in, 1, &min, &max );

  if( !in->len || (min >= 0 && max < 0xd800) )
      return; /* The string is obviously ok. */

  if( (max < 0 || min > 0x10ffff) || (max < 0xe000 && min > 0xd7ff) )
  {
      /* All invalid. Could probably be optimized. */
      debug_make_shared_binary_pcharp( repl_char, 1 );
      push_int( in->len );
      o_multiply();
  }
  else
  {
      /* Note: we could optimize this by not doing any string builder
       * at all unless there is at least one character that needs to
       * be replaced.
       */
      struct string_builder out;
      /* on average shift 1 is more correct than in->size_shift, since
       * there is usually only the one character that is outside the
       * range.
       */
      init_string_builder_alloc( &out, in->len, 1 );
      for( i=0; i<in->len; i++ )
      {
          p_wchar2 c = index_shared_string(in,i);
          if( (c < 0 || c > 0x10ffff) || (c>0xd7ff && c<0xe000) )
              string_builder_append( &out, repl_char, 1 );
          else
              string_builder_putchar( &out, c );
      }
      push_string( finish_string_builder( &out ) );
  }
}

/*! @decl string(0..255) string_to_utf8(string s)
 *! @decl string(0..255) string_to_utf8(string s, int extended)
 *!
 *!   Convert a string into a UTF-8 compliant byte-stream.
 *!
 *! @param s
 *!   String to encode into UTF-8.
 *!
 *! @param extended
 *!   Bitmask with extension options.
 *!   @int
 *!     @value 1
 *!       Accept and encode the characters outside the valid ranges
 *!       using the same algorithm. Such encoded characters are
 *!       however not UTF-8 compliant.
 *!     @value 2
 *!       Encode characters outside the BMP with UTF-8 encoded UTF-16
 *!       (ie split them into surrogate pairs and encode).
 *!   @endint
 *!
 *! @note
 *!   Throws an error if characters not valid in an UTF-8 stream are
 *!   encountered. Valid characters are in the ranges
 *!   @expr{0x00000000-0x0000d7ff@} and @expr{0x0000e000-0x0010ffff@}.
 *!
 *! @seealso
 *!   @[Charset.encoder()], @[string_to_unicode()],
 *!   @[unicode_to_string()], @[utf8_to_string()]
 */
PMOD_EXPORT void f_string_to_utf8(INT32 args)
{
  ptrdiff_t len;
  struct pike_string *in;
  struct pike_string *out;
  ptrdiff_t i,j;
  INT_TYPE extended = 0;
  PCHARP src;
  INT32 min, max;

  get_all_args("string_to_utf8", args, "%W.%i", &in, &extended);

  len = in->len;

  check_string_range(in, 1, &min, &max);

  if (min >= 0 && max <= 0x7f) {
    /* 7bit string -- already valid utf8. */
    pop_n_elems(args - 1);
    return;
  }

  for(i=0,src=MKPCHARP_STR(in); i < in->len; INC_PCHARP(src,1),i++) {
    unsigned INT32 c = EXTRACT_PCHARP(src);
    if (c & ~0x7f) {
      /* 8bit or more. */
      len++;
      if (c & ~0x7ff) {
	/* 12bit or more. */
	len++;
	if (c & ~0xffff) {
	  /* 17bit or more. */
	  len++;
	  if (!(extended & 1) && c > 0x10ffff)
	    bad_arg_error ("string_to_utf8", Pike_sp - args, args, 1,
			   NULL, Pike_sp - args,
			   "Character 0x%08x at index %"PRINTPTRDIFFT"d is "
			   "outside the allowed range.\n",
			   c, i);
	  if ((extended & 2) && (c <= 0x10ffff)) {
	    /* Encode with a surrogate pair. */
	    len += 2;
	  } else if (c & ~0x1fffff) {
	    /* 22bit or more. */
	    len++;
	    if (c & ~0x3ffffff) {
	      /* 27bit or more. */
	      len++;
	      if (c & ~0x7fffffff) {
		/* 32bit or more. */
		len++;
		/* FIXME: Needs fixing when we get 64bit chars... */
	      }
	    }
	  }
	}
	else if (!(extended & 1) && c >= 0xd800 && c <= 0xdfff)
	  bad_arg_error ("string_to_utf8", Pike_sp - args, args, 1,
			 NULL, Pike_sp - args,
			 "Character 0x%08x at index %"PRINTPTRDIFFT"d is "
			 "in the surrogate range and therefore invalid.\n",
			 c, i);
      }
    }
  }
  if (len == in->len) {
    /* 7bit string -- already valid utf8. */
    pop_n_elems(args - 1);
    return;
  }
  out = begin_shared_string(len);

  for(i=j=0,src=MKPCHARP_STR(in); i < in->len; INC_PCHARP(src,1),i++) {
    unsigned INT32 c = EXTRACT_PCHARP(src);
    if (!(c & ~0x7f)) {
      /* 7bit */
      out->str[j++] = c;
    } else if (!(c & ~0x7ff)) {
      /* 11bit */
      out->str[j++] = 0xc0 | (c >> 6);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else if (!(c & ~0xffff)) {
      /* 16bit */
      out->str[j++] = 0xe0 | (c >> 12);
      out->str[j++] = 0x80 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else if ((extended & 2) && (c <= 0x10ffff)) {
      /* Encode with surrogates. */
      c -= 0x10000;
      /* 0xd800 | (c>>10)
       * 0b1101 10cccc cccccc
       * UTF8: 11101101 1010cccc 10cccccc
       */
      out->str[j++] = 0xed;
      out->str[j++] = 0xa0 | (c >> 16);
      out->str[j++] = 0x80 | ((c >> 10) & 0x3f);
      /* 0xdc00 | (c & 0x3ff)
       * 0b1101 11cccc cccccc
       * UTF8: 11101101 1011cccc 10cccccc
       */
      out->str[j++] = 0xed;
      out->str[j++] = 0xb0 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else if (!(c & ~0x1fffff)) {
      /* 21bit */
      out->str[j++] = 0xf0 | (c >> 18);
      out->str[j++] = 0x80 | ((c >> 12) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else if (!(c & ~0x3ffffff)) {
      /* 26bit */
      out->str[j++] = 0xf8 | (c >> 24);
      out->str[j++] = 0x80 | ((c >> 18) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 12) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else if (!(c & ~0x7fffffff)) {
      /* 31bit */
      out->str[j++] = 0xfc | (c >> 30);
      out->str[j++] = 0x80 | ((c >> 24) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 18) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 12) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    } else {
      /* 32 - 36bit */
      out->str[j++] = DO_NOT_WARN((char)0xfe);
      out->str[j++] = 0x80 | ((c >> 30) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 24) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 18) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 12) & 0x3f);
      out->str[j++] = 0x80 | ((c >> 6) & 0x3f);
      out->str[j++] = 0x80 | (c & 0x3f);
    }
  }
#ifdef PIKE_DEBUG
  if (len != j) {
    Pike_fatal("string_to_utf8(): Calculated and actual lengths differ: "
	       "%"PRINTPTRDIFFT"d != %"PRINTPTRDIFFT"d\n", len, j);
  }
#endif /* PIKE_DEBUG */
  out = end_shared_string(out);
  pop_n_elems(args);
  push_string(out);
}

/*! @decl string utf8_to_string(string(0..255) s)
 *! @decl string utf8_to_string(string(0..255) s, int extended)
 *!
 *!   Converts an UTF-8 byte-stream into a string.
 *!
 *! @param s
 *!   String of UTF-8 encoded data to decode.
 *!
 *! @param extended
 *!   Bitmask with extension options.
 *!   @int
 *!     @value 1
 *!       Accept and decode the extension used by @[string_to_utf8()].
 *!     @value 2
 *!       Accept and decode UTF-8 encoded UTF-16 (ie accept and
 *!       decode valid surrogates).
 *!   @endint
 *!
 *! @note
 *!   Throws an error if the stream is not a legal UTF-8 byte-stream.
 *!
 *! @note
 *!   In conformance with RFC 3629 and Unicode 3.1 and later,
 *!   non-shortest forms are not decoded. An error is thrown instead.
 *!
 *! @seealso
 *!   @[Charset.encoder()], @[string_to_unicode()], @[string_to_utf8()],
 *!   @[unicode_to_string()]
 */
PMOD_EXPORT void f_utf8_to_string(INT32 args)
{
  struct pike_string *in;
  struct pike_string *out;
  ptrdiff_t len = 0;
  int shift = 0;
  ptrdiff_t i,j=0;
  INT_TYPE extended = 0;
  INT32 min, max;

  get_all_args("utf8_to_string", args, "%S.%i", &in, &extended);

  check_string_range(in, 1, &min, &max);

  if (min >= 0 && max <= 0x7f) {
    /* 7bit string -- already valid utf8. */
    pop_n_elems(args - 1);
    return;
  }

  for(i=0; i < in->len; i++) {
    unsigned int c = STR0(in)[i];
    len++;
    if (c & 0x80) {
      int cont = 0;

      /* From table 3-6 in the Unicode standard 4.0: Well-Formed UTF-8
       * Byte Sequences
       *
       *  Code Points   1st Byte  2nd Byte  3rd Byte  4th Byte
       * 000000-00007f   00-7f
       * 000080-0007ff   c2-df     80-bf
       * 000800-000fff    e0       a0-bf     80-bf
       * 001000-00cfff   e1-ec     80-bf     80-bf
       * 00d000-00d7ff    ed       80-9f     80-bf
       * 00e000-00ffff   ee-ef     80-bf     80-bf
       * 010000-03ffff    f0       90-bf     80-bf     80-bf
       * 040000-0fffff   f1-f3     80-bf     80-bf     80-bf
       * 100000-10ffff    f4       80-8f     80-bf     80-bf
       */

      if ((c & 0xc0) == 0x80) {
	bad_arg_error ("utf8_to_string", Pike_sp - args, args, 1,
		       NULL, Pike_sp - args,
		       "Invalid continuation character 0x%02x "
		       "at index %"PRINTPTRDIFFT"d.\n",
		       c, i);
      }

#define GET_CHAR(in, i, c) do {						\
	i++;								\
	if (i >= in->len)						\
	  bad_arg_error ("utf8_to_string", Pike_sp - args, args, 1,	\
			 NULL, Pike_sp - args,				\
			 "Truncated UTF-8 sequence at end of string.\n"); \
	c = STR0 (in)[i];						\
      } while(0)
#define GET_CONT_CHAR(in, i, c) do {					\
	GET_CHAR(in, i, c);						\
	if ((c & 0xc0) != 0x80)						\
	  bad_arg_error ("utf8_to_string", Pike_sp - args, args, 1,	\
			 NULL, Pike_sp - args,				\
			 "Expected continuation character at index %d, " \
			 "got 0x%02x.\n",				\
			 i, c);						\
      } while (0)

#define UTF8_SEQ_ERROR(prefix, c, i, problem) do {			\
	bad_arg_error ("utf8_to_string", Pike_sp - args, args, 1,	\
		       NULL, Pike_sp - args,				\
		       "UTF-8 sequence beginning with %s0x%02x "	\
		       "at index %"PRINTPTRDIFFT"d %s.\n",		\
		       prefix, c, i, problem);				\
      } while (0)

      if ((c & 0xe0) == 0xc0) {
	/* 11bit */
	if (!(c & 0x1e))
	  UTF8_SEQ_ERROR ("", c, i, "is a non-shortest form");
	cont = 1;
	if (c & 0x1c) {
	  if (shift < 1) {
	    shift = 1;
	  }
	}
      }

      else if ((c & 0xf0) == 0xe0) {
	/* 16bit */
	if (c == 0xe0) {
	  GET_CONT_CHAR (in, i, c);
	  if (!(c & 0x20))
	    UTF8_SEQ_ERROR ("0xe0 ", c, i - 1, "is a non-shortest form");
	  cont = 1;
	}
	else if (!(extended & 1) && c == 0xed) {
	  GET_CONT_CHAR (in, i, c);
	  if (c & 0x20) {
	    /* Surrogate. */
	    if (!(extended & 2)) {
	      UTF8_SEQ_ERROR ("0xed ", c, i - 1, "would decode to "
			      "a UTF-16 surrogate character");
	    }
	    if (c & 0x10) {
	      UTF8_SEQ_ERROR ("0xed ", c, i - 1, "would decode to "
			      "a UTF-16 low surrogate character");
	    }
	    GET_CONT_CHAR(in, i, c);

	    GET_CHAR (in, i, c);
	    if (c != 0xed) {
	      UTF8_SEQ_ERROR ("", c, i-1, "UTF-16 low surrogate "
			      "character required");
	    }
	    GET_CONT_CHAR (in, i, c);
	    if ((c & 0xf0) != 0xb0) {
	      UTF8_SEQ_ERROR ("0xed ", c, i-1, "UTF-16 low surrogate "
			      "character required");
	    }
	    shift = 2;
	  }
	  cont = 1;
	}
	else
	  cont = 2;
	if (shift < 1) {
	  shift = 1;
	}
      }

      else {
	if ((c & 0xf8) == 0xf0) {
	  /* 21bit */
	  if (c == 0xf0) {
	    GET_CONT_CHAR (in, i, c);
	    if (!(c & 0x30))
	      UTF8_SEQ_ERROR ("0xf0 ", c, i - 1, "is a non-shortest form");
	    cont = 2;
	  }
	  else if (!(extended & 1)) {
	    if (c > 0xf4)
	      UTF8_SEQ_ERROR ("", c, i, "would decode to "
			      "a character outside the valid UTF-8 range");
	    else if (c == 0xf4) {
	      GET_CONT_CHAR (in, i, c);
	      if (c > 0x8f)
		UTF8_SEQ_ERROR ("0xf4 ", c, i - 1, "would decode to "
				"a character outside the valid UTF-8 range");
	      cont = 2;
	    }
	    else
	      cont = 3;
	  }
	  else
	    cont = 3;
	}

	else if (c == 0xff)
	  bad_arg_error ("utf8_to_string", Pike_sp - args, args, 1,
			 NULL, Pike_sp - args,
			 "Invalid character 0xff at index %"PRINTPTRDIFFT"d.\n",
			 i);

	else if (!(extended & 1))
	  UTF8_SEQ_ERROR ("", c, i, "would decode to "
			  "a character outside the valid UTF-8 range");

	else {
	  if ((c & 0xfc) == 0xf8) {
	    /* 26bit */
	    if (c == 0xf8) {
	      GET_CONT_CHAR (in, i, c);
	      if (!(c & 0x38))
		UTF8_SEQ_ERROR ("0xf8 ", c, i - 1, "is a non-shortest form");
	      cont = 3;
	    }
	    else
	      cont = 4;
	  } else if ((c & 0xfe) == 0xfc) {
	    /* 31bit */
	    if (c == 0xfc) {
	      GET_CONT_CHAR (in, i, c);
	      if (!(c & 0x3c))
		UTF8_SEQ_ERROR ("0xfc ", c, i - 1, "is a non-shortest form");
	      cont = 4;
	    }
	    else
	      cont = 5;
	  } else if (c == 0xfe) {
	    /* 36bit */
	    GET_CONT_CHAR (in, i, c);
	    if (!(c & 0x3e))
	      UTF8_SEQ_ERROR ("0xfe ", c, i - 1, "is a non-shortest form");
	    else if (c & 0x3c)
	      UTF8_SEQ_ERROR ("0xfe ", c, i - 1, "would decode to "
			      "a too large character value");
	    cont = 5;
	  }
	}

	if (shift < 2)
	  shift = 2;
      }

      while(cont--)
	GET_CONT_CHAR (in, i, c);

#undef GET_CHAR
#undef GET_CONT_CHAR
#undef UTF8_SEQ_ERROR
    }
  }
  if (len == in->len) {
    /* 7bit in == 7bit out */
    pop_n_elems(args-1);
    return;
  }

  out = begin_wide_shared_string(len, shift);

  switch (shift) {
    case 0: {
      p_wchar0 *out_str = STR0 (out);
      for(i=0; i < in->len;) {
	unsigned int c = STR0(in)[i++];
	/* NOTE: No tests here since we've already tested the string above. */
	if (c & 0x80) {
	  /* 11bit */
	  unsigned int c2 = STR0(in)[i++] & 0x3f;
	  c &= 0x1f;
	  c = (c << 6) | c2;
	}
	out_str[j++] = c;
      }
      break;
    }

    case 1: {
      p_wchar1 *out_str = STR1 (out);
      for(i=0; i < in->len;) {
	unsigned int c = STR0(in)[i++];
	/* NOTE: No tests here since we've already tested the string above. */
	if (c & 0x80) {
	  if ((c & 0xe0) == 0xc0) {
	    /* 11bit */
	    unsigned int c2 = STR0(in)[i++] & 0x3f;
	    c &= 0x1f;
	    c = (c << 6) | c2;
	  } else {
	    /* 16bit */
	    unsigned int c2 = STR0(in)[i++] & 0x3f;
	    unsigned int c3 = STR0(in)[i++] & 0x3f;
	    c &= 0x0f;
	    c = (c << 12) | (c2 << 6) | c3;
	  }
	}
	out_str[j++] = c;
      }
      break;
    }

    case 2: {
      p_wchar2 *out_str = STR2 (out);
      for(i=0; i < in->len;) {
	unsigned int c = STR0(in)[i++];
	/* NOTE: No tests here since we've already tested the string above. */
	if (c & 0x80) {
	  int cont = 0;
	  if ((c & 0xe0) == 0xc0) {
	    /* 11bit */
	    cont = 1;
	    c &= 0x1f;
	  } else if ((c & 0xf0) == 0xe0) {
	    /* 16bit */
	    cont = 2;
	    c &= 0x0f;
	  } else if ((c & 0xf8) == 0xf0) {
	    /* 21bit */
	    cont = 3;
	    c &= 0x07;
	  } else if ((c & 0xfc) == 0xf8) {
	    /* 26bit */
	    cont = 4;
	    c &= 0x03;
	  } else if ((c & 0xfe) == 0xfc) {
	    /* 31bit */
	    cont = 5;
	    c &= 0x01;
	  } else {
	    /* 36bit */
	    cont = 6;
	    c = 0;
	  }
	  while(cont--) {
	    unsigned int c2 = STR0(in)[i++] & 0x3f;
	    c = (c << 6) | c2;
	  }
	  if ((extended & 2) && (c & 0xfc00) == 0xdc00) {
	    /* Low surrogate */
	    c &= 0x3ff;
	    c |= ((out_str[--j] & 0x3ff)<<10) + 0x10000;
	  }
	}
	out_str[j++] = c;
      }
      break;
    }
  }

#ifdef PIKE_DEBUG
  if (j != len) {
    Pike_fatal("Calculated and actual lengths differ: "
	       "%"PRINTPTRDIFFT"d != %"PRINTPTRDIFFT"d\n",
               len, j);
  }
#endif /* PIKE_DEBUG */
  out = low_end_shared_string(out);
#ifdef PIKE_DEBUG
  check_string (out);
#endif
  pop_n_elems(args);
  push_string(out);
}

/*! @decl string(0..255) __parse_pike_type(string(0..255) t)
 */
static void f_parse_pike_type( INT32 args )
{
  struct pike_type *t;

  if( !args || TYPEOF(Pike_sp[-1]) != T_STRING ||
      Pike_sp[-1].u.string->size_shift )
    Pike_error( "__parse_pike_type requires a 8bit string as its first argument\n" );
  t = parse_type( (char *)STR0(Pike_sp[-1].u.string) );
  pop_stack();

  push_string(type_to_string(t));
  free_type(t);
}

/*! @module Pike
 */

/*! @decl type soft_cast(type to, type from)
 *!
 *!   Return the resulting type from a soft cast of @[from] to @[to].
 */
static void f___soft_cast(INT32 args)
{
  struct pike_type *res;
  if (args < 2) Pike_error("Bad number of arguments to __soft_cast().\n");
  if (TYPEOF(Pike_sp[-args]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 1 to __soft_cast() expected type.\n");
  }
  if (TYPEOF(Pike_sp[1-args]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 2 to __soft_cast() expected type.\n");
  }
  if (!(res = soft_cast(Pike_sp[-args].u.type,
			Pike_sp[1-args].u.type, 0))) {
    pop_n_elems(args);
    push_undefined();
  } else {
    pop_n_elems(args);
    push_type_value(res);
  }
}

/*! @decl type low_check_call(type fun_type, type arg_type)
 *! @decl type low_check_call(type fun_type, type arg_type, int flags)
 *!
 *!   Check whether a function of type @[fun_type] may be called
 *!   with a first argument of type @[arg_type].
 *!
 *! @param flags
 *!   The following flags are currently defined:
 *!   @int
 *!     @value 1
 *!       Strict types. Fail if not all possible values in @[arg_type]
 *!       are valid as the first argument to @[fun_type].
 *!     @value 2
 *!       Last argument. @[arg_type] is the last argument to @[fun_type].
 *!     @value 3
 *!       Both strict types and last argument as above.
 *!   @endint
 *!
 *! @returns
 *!   Returns a continuation type on success.
 *!
 *!   Returns @tt{0@} (zero) on failure.
 */
static void f___low_check_call(INT32 args)
{
  struct pike_type *res;
  INT32 flags = CALL_NOT_LAST_ARG;
  struct svalue *sval = NULL;
  if (args < 2) Pike_error("Bad number of arguments to __low_check_call().\n");
  if (TYPEOF(Pike_sp[-args]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 1 to __low_check_call() expected type.\n");
  }
  if (TYPEOF(Pike_sp[1-args]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 2 to __low_check_call() expected type.\n");
  }
  if (args > 2) {
    if (TYPEOF(Pike_sp[2-args]) != PIKE_T_INT) {
      Pike_error("Bad argument 3 to __low_check_call() expected int.\n");
    }
    flags = Pike_sp[2-args].u.integer ^ CALL_NOT_LAST_ARG;
  }
  if (args > 3) sval = Pike_sp + 3 - args;
  if (!(res = low_new_check_call(Pike_sp[-args].u.type,
				 Pike_sp[1-args].u.type, flags, sval))) {
    pop_n_elems(args);
    push_undefined();
  } else {
    pop_n_elems(args);
    push_type_value(res);
  }
}

/*! @decl type get_return_type(type fun_type)
 *!
 *!   Check what a function of the type @[fun_type] will
 *!   return if called with no arguments.
 *!
 *! @returns
 *!   Returns the type of the returned value on success
 *!
 *!   Returns @tt{0@} (zero) on failure.
 */
static void f___get_return_type(INT32 args)
{
  struct pike_type *res;
  if (args != 1) {
    Pike_error("Bad number of arguments to __get_return_type().\n");
  }
  if (TYPEOF(Pike_sp[-1]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 1 to __get_return_type() expected type.\n");
  }
  if (!(res = new_get_return_type(Pike_sp[-1].u.type, 0))) {
    pop_n_elems(args);
    push_undefined();
  } else {
    pop_n_elems(args);
    push_type_value(res);
  }
}

/*! @decl type get_first_arg_type(type fun_type)
 *!
 *!   Check if a function of the type @[fun_type] may be called
 *!   with an argument, and return the type of that argument.
 *!
 *! @returns
 *!   Returns the expected type of the first argument to the function.
 *!
 *!   Returns @tt{0@} (zero) if a function of the type @[fun_type]
 *!   may not be called with any argument, or if it is not callable.
 */
void f___get_first_arg_type(INT32 args)
{
  struct pike_type *res;
  if (args != 1) {
    Pike_error("Bad number of arguments to __get_first_arg_type().\n");
  }
  if (TYPEOF(Pike_sp[-1]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 1 to __get_first_arg_type() expected type.\n");
  }
  if (!(res = get_first_arg_type(Pike_sp[-1].u.type, CALL_NOT_LAST_ARG)) &&
      !(res = get_first_arg_type(Pike_sp[-1].u.type, 0))) {
    pop_n_elems(args);
    push_undefined();
  } else {
    pop_n_elems(args);
    push_type_value(res);
  }
}

/*! @decl array(string) get_type_attributes(type t)
 *!
 *!   Get the attribute markers for a type.
 *!
 *! @returns
 *!   Returns an array with the attributes for the type @[t].
 *!
 *! @seealso
 *!   @[get_return_type()], @[get_first_arg_type()]
 */
static void f___get_type_attributes(INT32 args)
{
  struct pike_type *t;
  int count = 0;
  if (args != 1) {
    Pike_error("Bad number of arguments to __get_type_attributes().\n");
  }
  if (TYPEOF(Pike_sp[-1]) != PIKE_T_TYPE) {
    Pike_error("Bad argument 1 to __get_type_attributes() expected type.\n");
  }
  t = Pike_sp[-1].u.type;
  /* Note: We assume that the set of attributes is small
   *       enough that we won't run out of stack. */
  while ((t->type == PIKE_T_ATTRIBUTE) || (t->type == PIKE_T_NAME)) {
    if (t->type == PIKE_T_ATTRIBUTE) {
      ref_push_string((struct pike_string *)t->car);
      count++;
    }
    t = t->cdr;
  }
  f_aggregate(count);
  stack_pop_n_elems_keep_top(args);
}

/*! @endmodule Pike
 */

/*! @decl mapping (string:mixed) all_constants()
 *!
 *!   Returns a mapping containing all global constants, indexed on the name
 *!   of the constant, and with the value of the constant as value.
 *!
 *! @seealso
 *!   @[add_constant()]
 */
PMOD_EXPORT void f_all_constants(INT32 args)
{
  pop_n_elems(args);
  ref_push_mapping(get_builtin_constants());
}

/*! @decl CompilationHandler get_active_compilation_handler()
 *!
 *!   Returns the currently active compilation compatibility handler, or
 *!   @tt{0@} (zero) if none is active.
 *!
 *! @note
 *!   This function should only be used during a call of @[compile()].
 *!
 *! @seealso
 *!   @[get_active_error_handler()], @[compile()],
 *!   @[master()->get_compilation_handler()], @[CompilationHandler]
 */
PMOD_EXPORT void f_get_active_compilation_handler(INT32 args)
{
  struct compilation *c = NULL;

  if (compilation_program) {
    struct pike_frame *compiler_frame = Pike_fp;

    while (compiler_frame &&
	   (compiler_frame->context->prog != compilation_program)) {
      compiler_frame = compiler_frame->next;
    }

    if (compiler_frame) {
      c = (struct compilation *)compiler_frame->current_storage;
    }
  }
  
  pop_n_elems(args);
  if (c && c->compat_handler) {
    ref_push_object(c->compat_handler);
  } else {
    push_int(0);
  }
}

/*! @decl CompilationHandler get_active_error_handler()
 *!
 *!   Returns the currently active compilation error handler
 *!   (second argument to @[compile()]), or @tt{0@} (zero) if none
 *!   is active.
 *!
 *! @note
 *!   This function should only be used during a call of @[compile()].
 *!
 *! @seealso
 *!   @[get_active_compilation_handler()], @[compile()], @[CompilationHandler]
 */
PMOD_EXPORT void f_get_active_error_handler(INT32 args)
{
  struct compilation *c = NULL;

  if (compilation_program) {
    struct pike_frame *compiler_frame = Pike_fp;

    while (compiler_frame &&
	   (compiler_frame->context->prog != compilation_program)) {
      compiler_frame = compiler_frame->next;
    }

    if (compiler_frame) {
      c = (struct compilation *)compiler_frame->current_storage;
    }
  }
  
  pop_n_elems(args);
  if (c && c->handler) {
    ref_push_object(c->handler);
  } else {
    push_int(0);
  }
}

/*! @decl array allocate(int size)
 *! @decl array allocate(int size, mixed init)
 *!
 *!   Allocate an array of @[size] elements. If @[init] is specified
 *!   then each element is initialized by copying that value
 *!   recursively.
 *!
 *! @seealso
 *!   @[sizeof()], @[aggregate()], @[arrayp()]
 */
PMOD_EXPORT void f_allocate(INT32 args)
{
  INT_TYPE size;
  struct array *a;
  struct svalue *init = NULL;

  get_all_args("allocate", args, "%+.%*", &size, &init);
  if (size > MAX_INT32)
    SIMPLE_ARG_ERROR ("allocate", 1, "Integer too large to use as array size.");

  a=allocate_array(size);
  if(args>1)
  {
    INT32 e;
    push_array (a);
    if (init) {
      for(e=0;e<size;e++)
	copy_svalues_recursively_no_free(a->item+e, init, 1, 0);
      a->type_field = 1 << TYPEOF(*init);
    }
    else {
      /* It's somewhat quirky that allocate(17) and allocate(17, UNDEFINED)
       * have different behavior, but it's of some use, and it's compatible
       * with previous versions. */
      for(e=0;e<size;e++)
	ITEM (a)[e] = svalue_undefined;
      a->type_field = BIT_INT;
    }
    stack_pop_n_elems_keep_top (args);
  }
  else {
    a->type_field = BIT_INT;
    pop_n_elems(args);
    push_array(a);
  }
}

/*! @decl object this_object(void|int level);
 *!
 *!   Returns the object we are currently evaluating in.
 *!
 *!   @[level] might be used to access the object of a surrounding
 *!   class: The object at level 0 is the current object, the object
 *!   at level 1 is the one belonging to the class that surrounds
 *!   the class that the object comes from, and so on.
 *!
 *! @note
 *!   As opposed to a qualified @expr{this@} reference such as
 *!   @expr{global::this@}, this function doesn't always access the
 *!   objects belonging to the lexically surrounding classes. If the
 *!   class containing the call has been inherited then the objects
 *!   surrounding the inheriting class are accessed.
 */
void f_this_object(INT32 args)
{
  int level, l;
  struct object *o;

  if (args) {
    if (TYPEOF(Pike_sp[-args]) != T_INT || Pike_sp[-args].u.integer < 0)
      SIMPLE_BAD_ARG_ERROR ("this_object", 1, "a non-negative integer");
    level = Pike_sp[-args].u.integer;
  }
  else
    level = 0;

  pop_n_elems(args);

  o = Pike_fp->current_object;
  for (l = 0; l < level; l++) {
    struct program *p = o->prog;
    if (!p)
      Pike_error ("Object %d level(s) up is destructed - cannot get the parent.\n", l);
    if (!(p->flags & PROGRAM_USES_PARENT))
      /* FIXME: Ought to write out the object here. */
      Pike_error ("Object %d level(s) up lacks parent reference.\n", l);
    o = PARENT_INFO(o)->parent;
  }
  ref_push_object(o);
}

static node *optimize_this_object(node *n)
{
  int level = 0;

  if (CDR (n)) {
    struct compilation *c = THIS_COMPILATION;
    struct program_state *state = Pike_compiler;

    CHECK_COMPILER();

    if (CDR (n)->token != F_CONSTANT) {
      /* Not a constant expression. Make sure there are parent
       * pointers all the way. */
      int i;
      for (i = 0; i < c->compilation_depth; i++, state = state->previous)
	state->new_program->flags |= PROGRAM_USES_PARENT | PROGRAM_NEEDS_PARENT;
      return NULL;
    }
    else {
      int i;
#ifdef PIKE_DEBUG
      if (TYPEOF(CDR(n)->u.sval) != T_INT || CDR(n)->u.sval.u.integer < 0)
	Pike_fatal ("The type check for this_object() failed.\n");
#endif
      level = CDR (n)->u.sval.u.integer;
      for (i = MINIMUM(level, c->compilation_depth); i;
	   i--, state = state->previous) {
	state->new_program->flags |=
	  PROGRAM_USES_PARENT | PROGRAM_NEEDS_PARENT;
      }
    }
  }

  /* We can only improve the type when accessing the innermost object:
   * Since this_object always follows the object pointers it might not
   * access the lexically surrounding objects. Thus the
   * PROGRAM_USES_PARENT stuff above is a bit of a long shot, but it's
   * better than nothing. */
  if (!level) {
    free_type(n->type);
    type_stack_mark();
    /* We are rather sure that we contain ourselves... */
    /* push_object_type(1, Pike_compiler->new_program->id); */
    /* But it did not work yet, so... */
    push_object_type(0, Pike_compiler->new_program->id);
    n->type = pop_unfinished_type();
    if (n->parent) {
      n->parent->node_info |= OPT_TYPE_NOT_FIXED;
    }
  }

  return NULL;
}

static int generate_this_object(node *n)
{
  int level;
  struct compilation *c = THIS_COMPILATION;
  CHECK_COMPILER();

  if (CDR (n)) {
    if (CDR (n)->token != F_CONSTANT)
      /* Not a constant expression. Make a call to f_this_object. */
      return 0;
    else {
#ifdef PIKE_DEBUG
      if (TYPEOF(CDR(n)->u.sval) != T_INT || CDR(n)->u.sval.u.integer < 0)
	Pike_fatal ("The type check for this_object() failed.\n");
#endif
      level = CDR (n)->u.sval.u.integer;
    }
  }
  else level = 0;

  emit1(F_THIS_OBJECT, level);
  modify_stack_depth(1);
  return 1;
}

/*! @decl mixed|void throw(mixed value)
 *!
 *!   Throw @[value] to a waiting @[catch].
 *!
 *!   If no @[catch] is waiting the global error handling will send the
 *!   value to @[master()->handle_error()].
 *!
 *!   If you throw an array with where the first index contains an error
 *!   message and the second index is a backtrace, (the output from
 *!   @[backtrace()]) then it will be treated exactly like a real error
 *!   by overlying functions.
 *!
 *! @seealso
 *!   @[catch]
 */
PMOD_EXPORT void f_throw(INT32 args)
{
  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("throw", 1);
  assign_svalue(&throw_value,Pike_sp-args);
  pop_n_elems(args);
  throw_severity=0;
  pike_throw();
}

int in_forked_child = 0;

/*! @decl void exit(int returncode, void|string fmt, mixed ... extra)
 *!
 *!   Exit the whole Pike program with the given @[returncode].
 *!
 *!   Using @[exit()] with any other value than @expr{0@} (zero) indicates
 *!   that something went wrong during execution. See your system manuals
 *!   for more information about return codes.
 *!
 *!   The arguments after the @[returncode] will be used for a call to
 *!   @[werror] to output a message on stderr.
 *!
 *! @seealso
 *!   @[_exit()]
 */
PMOD_EXPORT void f_exit(INT32 args)
{
  static int in_exit=0;
  ASSERT_SECURITY_ROOT("exit");

  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("exit", 1);

  if(TYPEOF(Pike_sp[-args]) != T_INT)
    SIMPLE_BAD_ARG_ERROR("exit", 1, "int");

  if(in_exit) Pike_error("exit already called!\n");
  in_exit=1;

  if(args>1 && TYPEOF(Pike_sp[1-args]) == T_STRING) {
    struct svalue *s =
      simple_mapping_string_lookup(get_builtin_constants(), "werror");
    if (s) {
      apply_svalue(s, args-1);
      pop_stack();
    } else {
      fprintf(stderr, "No efun::werror() at exit.\n");
      pop_n_elems(args-1);
    }
    args=1;
  }

  if (in_forked_child) {
    /* Don't bother to clean up if we're running in a forked child. */
    f__exit(args);
  }

  assign_svalue(&throw_value, Pike_sp-args);
  throw_severity=THROW_EXIT;
  pike_throw();
}

/*! @decl void _exit(int returncode)
 *!
 *!   This function does the same as @[exit], but doesn't bother to clean
 *!   up the Pike interpreter before exiting. This means that no destructors
 *!   will be called, caches will not be flushed, file locks might not be
 *!   released, and databases might not be closed properly.
 *!
 *!   Use with extreme caution.
 *!
 *! @seealso
 *!   @[exit()]
 */
void f__exit(INT32 args)
{
  int code;
  ASSERT_SECURITY_ROOT("_exit");

  get_all_args("_exit", args, "%d", &code);

#ifdef PIKE_DEBUG
  {
    /* This will allow -p to work with _exit -Hubbe */
    exit_opcodes();
  }
#endif

  /* FIXME: Shouldn't _exit(2) be called here? */
  exit(code);
}

/*! @decl int time();
 *! @decl int time(int(1..1) one)
 *! @decl float time(int(2..) t)
 *!
 *!   This function returns the number of seconds since 00:00:00 UTC, 1 Jan 1970.
 *!
 *!   The second syntax does not query the system for the current
 *!   time, instead the last time value used by the pike process is returned
 *!   again. It avoids a system call, and thus is slightly faster,
 *!   but can be wildly inaccurate. Pike
 *!   queries the time internally when a thread has waited for
 *!   something, typically in @[sleep] or in a backend (see
 *!   @[Pike.Backend]).
 *!
 *!   The third syntax can be used to measure time more precisely than one
 *!   second. It returns how many seconds have passed since @[t]. The precision
 *!   of this function varies from system to system.
 *!
 *! @seealso
 *!   @[ctime()], @[localtime()], @[mktime()], @[gmtime()],
 *!   @[System.gettimeofday], @[gethrtime]
 */
PMOD_EXPORT void f_time(INT32 args)
{
  struct timeval ret;
  if(!args ||
     (TYPEOF(Pike_sp[-args]) == T_INT && Pike_sp[-args].u.integer == 0))
  {
    ACCURATE_GETTIMEOFDAY(&ret);
    pop_n_elems(args);
    push_int(ret.tv_sec);

    return;
  }else{
    if(TYPEOF(Pike_sp[-args]) == T_INT && Pike_sp[-args].u.integer > 1)
    {
      struct timeval tmp;
      ACCURATE_GETTIMEOFDAY(&ret);
      tmp.tv_sec=Pike_sp[-args].u.integer;
      tmp.tv_usec=0;
      my_subtract_timeval(&tmp,&ret);
      pop_n_elems(args);
      push_float( - (FLOAT_TYPE)tmp.tv_sec-((FLOAT_TYPE)tmp.tv_usec)/1000000 );
      return;
    }
  }
  pop_n_elems(args);
  INACCURATE_GETTIMEOFDAY(&ret);
  push_int(ret.tv_sec);
}

/*! @decl string(0..127) crypt(string password)
 *! @decl int(0..1) crypt(string typed_password, string crypted_password)
 *!
 *!   This function crypts and verifies a short string (only the first
 *!   8 characters are significant).
 *!
 *!   The first syntax crypts the string @[password] into something that
 *!   is hopefully hard to decrypt.
 *!
 *!   The second syntax is used to verify @[typed_password] against
 *!   @[crypted_password], and returns @expr{1@} if they match, and
 *!   @expr{0@} (zero) otherwise.
 *!
 *! @note
 *!   Note that strings containing null characters will only be
 *!   processed up until the null character.
 */
PMOD_EXPORT void f_crypt(INT32 args)
{
  char salt[3];
  char *ret, *pwd, *saltp = NULL;
  char *choise =
    "cbhisjKlm4k65p7qrJfLMNQOPxwzyAaBDFgnoWXYCZ0123tvdHueEGISRTUV89./";

  get_all_args("crypt", args, "%s.%s", &pwd, &saltp);

  if(saltp)
  {
    if( Pike_sp[1-args].u.string->len < 2 )
    {
      pop_n_elems(args);
      push_int(0);
      return;
    }
  } else {
    unsigned int foo; /* Sun CC wants this :( */
    foo=my_rand();
    salt[0] = choise[foo % (size_t) strlen(choise)];
    foo=my_rand();
    salt[1] = choise[foo % (size_t) strlen(choise)];
    salt[2] = 0;
    saltp=salt;
    if (args > 1) {
      pop_n_elems(args-1);
      args = 1;
    }
  }
#ifdef HAVE_CRYPT
  ret = (char *)crypt(pwd, saltp);
#else
#ifdef HAVE__CRYPT
  ret = (char *)_crypt(pwd, saltp);
#else
#error No crypt function found and fallback failed.
#endif
#endif
  if(args < 2)
  {
    if (!ret) {
      switch(errno) {
#ifdef ELIBACC
      case ELIBACC:
	Pike_error("Failed to load a required shared library. "
		   "Unsupported salt.\n");
	break;
#endif
      case ENOMEM:
	Pike_error("Out of memory.\n");
	break;
      case EINVAL:
      default:
	Pike_error("Unsupported salt (%d).\n", errno);
	break;
      }
    }

    pop_n_elems(args);
    push_text(ret);
  }else{
    int i;
    i = ret && !strcmp(ret,saltp);
    pop_n_elems(args);
    push_int(i);
  }
}

/*! @decl void destruct(void|object o)
 *!
 *!   Mark an object as destructed.
 *!
 *!   Calls @expr{o->destroy()@}, and then clears all variables in the
 *!   object. If no argument is given, the current object is destructed.
 *!
 *!   All pointers and function pointers to this object will become zero.
 *!   The destructed object will be freed from memory as soon as possible.
 */ 
PMOD_EXPORT void f_destruct(INT32 args)
{
  struct object *o;
  if(args)
  {
    if(TYPEOF(Pike_sp[-args]) != T_OBJECT) {
      if ((TYPEOF(Pike_sp[-args]) == T_INT) &&
	  (!Pike_sp[-args].u.integer)) {
	pop_n_elems(args);
	return;
      }
      SIMPLE_BAD_ARG_ERROR("destruct", 1, "object");
    }

    o=Pike_sp[-args].u.object;
  }else{
    if(!Pike_fp) {
      PIKE_ERROR("destruct",
		 "Destruct called without argument from callback function.\n",
		 Pike_sp, args);
    }
    o=Pike_fp->current_object;
  }
  if (o->prog && o->prog->flags & PROGRAM_NO_EXPLICIT_DESTRUCT)
    PIKE_ERROR("destruct", "Object can't be destructed explicitly.\n",
	       Pike_sp, args);
#ifdef PIKE_SECURITY
  if(!CHECK_DATA_SECURITY(o, SECURITY_BIT_DESTRUCT))
    Pike_error("Destruct permission denied.\n");
#endif
  debug_malloc_touch(o);
  destruct_object (o, DESTRUCT_EXPLICIT);
  pop_n_elems(args);
  destruct_objects_to_destruct();
}

/*! @decl array indices(string|array|mapping|multiset|object x)
 *!
 *!   Return an array of all valid indices for the value @[x].
 *!
 *!   For strings and arrays this is simply an array of ascending
 *!   numbers.
 *!
 *!   For mappings and multisets, the array might contain any value.
 *!
 *!   For objects which define @[lfun::_indices()] that return value
 *!   is used.
 *!
 *!   For other objects an array with all non-protected symbols is
 *!   returned.
 *!
 *! @seealso
 *!   @[values()], @[types()], @[lfun::_indices()]
 */
PMOD_EXPORT void f_indices(INT32 args)
{
  ptrdiff_t size;
  struct array *a = NULL;

  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("indices", 1);

  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_STRING:
    size=Pike_sp[-args].u.string->len;
    goto qjump;

  case T_ARRAY:
    size=Pike_sp[-args].u.array->size;

  qjump:
    a=allocate_array_no_init(size,0);
    while(--size>=0)
    {
      /* Elements are already integers. */
      ITEM(a)[size].u.integer = DO_NOT_WARN((INT_TYPE)size);
    }
    a->type_field = BIT_INT;
    break;

  case T_MAPPING:
    a=mapping_indices(Pike_sp[-args].u.mapping);
    break;

  case T_MULTISET:
    a = multiset_indices (Pike_sp[-args].u.multiset);
    break;

  case T_OBJECT:
    a=object_indices(Pike_sp[-args].u.object, SUBTYPEOF(Pike_sp[-args]));
    break;

  case T_PROGRAM:
    a = program_indices(Pike_sp[-args].u.program);
    break;

  case T_FUNCTION:
    {
      struct program *p = program_from_svalue(Pike_sp-args);
      if (p) {
	a = program_indices(p);
	break;
      }
    }
    /* FALL THROUGH */

  default:
    SIMPLE_BAD_ARG_ERROR("indices", 1,
			 "string|array|mapping|"
			 "multiset|object|program|function");
    return; /* make apcc happy */
  }
  pop_n_elems(args);
  push_array(a);
}

/* this should probably be moved to pike_types.c or something */
#define FIX_OVERLOADED_TYPE(n, lf, X) fix_overloaded_type(n,lf,X,CONSTANT_STRLEN(X))
/* FIXME: This function messes around with the implementation of pike_type,
 * and should probably be in pike_types.h instead.
 */
static node *fix_overloaded_type(node *n, int lfun, const char *deftype, int UNUSED(deftypelen))
{
  node **first_arg;
  struct pike_type *t, *t2;
  first_arg=my_get_arg(&_CDR(n), 0);
  if(!first_arg) return 0;
  t=first_arg[0]->type;
  if(!t || match_types(t, object_type_string))
  {
    /* Skip any name-nodes. */
    while(t && t->type == PIKE_T_NAME) {
      t = t->cdr;
    }

    /* FIXME: Ought to handle or-nodes here. */
    if(t && (t->type == T_OBJECT))
    {
      struct program *p = id_to_program(CDR_TO_INT(t));
      if(p)
      {
	int fun=FIND_LFUN(p, lfun);

	/* FIXME: function type string should really be compiled from
	 * the arguments so that or:ed types are handled correctly
	 */
	if(fun!=-1 &&
	   (t2 = check_call(function_type_string, ID_FROM_INT(p, fun)->type,
			    0)))
	{
	  free_type(n->type);
	  n->type = t2;
	  return 0;
	}
      }
    }

    /* If it is an object, it *may* be overloaded, we or with 
     * the deftype....
     */
#if 1
    if(deftype)
    {
      t2 = make_pike_type(deftype);
      t = n->type;
      n->type = or_pike_types(t,t2,0);
      free_type(t);
      free_type(t2);
    }
#endif
  }
  
  return 0; /* continue optimization */
}

static node *fix_indices_type(node *n)
{
  return FIX_OVERLOADED_TYPE(n, LFUN__INDICES, tArray);
}

static node *fix_values_type(node *n)
{
  return FIX_OVERLOADED_TYPE(n, LFUN__VALUES, tArray);
}

static node *fix_aggregate_mapping_type(node *n)
{
  struct pike_type *types[2] = { NULL, NULL };
  node *args = CDR(n);
  struct pike_type *new_type = NULL;

#ifdef PIKE_DEBUG
  if (l_flag > 2) {
    fprintf(stderr, "Fixing type for aggregate_mapping():\n");
    print_tree(n);

    fprintf(stderr, "Original type:");
    simple_describe_type(n->type);
  }
#endif /* PIKE_DEBUG */

  if (args) {
    node *arg = args;
    int argno = 0;

    /* Make it easier to find... */
    args->parent = 0;

    while(arg) {
#ifdef PIKE_DEBUG
      if (l_flag > 4) {
	fprintf(stderr, "Searching for arg #%d...\n", argno);
      }
#endif /* PIKE_DEBUG */
      if (arg->token == F_ARG_LIST) {
	if (CAR(arg)) {
	  CAR(arg)->parent = arg;
	  arg = CAR(arg);
	  continue;
	}
	if (CDR(arg)) {
	  CDR(arg)->parent = arg;
	  arg = CDR(arg);
	  continue;
	}
	/* Retrace */
      retrace:
#ifdef PIKE_DEBUG
	if (l_flag > 4) {
	  fprintf(stderr, "Retracing in search for arg %d...\n", argno);
	}
#endif /* PIKE_DEBUG */
	while (arg->parent &&
	       (!CDR(arg->parent) || (CDR(arg->parent) == arg))) {
	  arg = arg->parent;
	}
	if (!arg->parent) {
	  /* No more args. */
	  break;
	}
	arg = arg->parent;
	CDR(arg)->parent = arg;
	arg = CDR(arg);
	continue;
      }
      if (arg->token == F_PUSH_ARRAY) {
	/* FIXME: Should get the type from the pushed array. */
	/* FIXME: Should probably be fixed in las.c:fix_type_field() */
	/* FIXME: */
	MAKE_CONSTANT_TYPE(new_type, tMap(tMixed, tMixed));
	goto set_type;
      }
#ifdef PIKE_DEBUG
      if (l_flag > 4) {
	fprintf(stderr, "Found arg #%d:\n", argno);
	print_tree(arg);
	simple_describe_type(arg->type);
      }
#endif /* PIKE_DEBUG */
      do {
	if (types[argno]) {
	  struct pike_type *t = or_pike_types(types[argno], arg->type, 0);
	  free_type(types[argno]);
	  types[argno] = t;
#ifdef PIKE_DEBUG
	  if (l_flag > 4) {
	    fprintf(stderr, "Resulting type for arg #%d:\n", argno);
	    simple_describe_type(types[argno]);
	  }
#endif /* PIKE_DEBUG */
	} else {
	  copy_pike_type(types[argno], arg->type);
	}
	argno = !argno;
	/* Handle the special case where CAR & CDR are the same.
	 * Only occurrs with SHARED_NODES.
	 */
      } while (argno && arg->parent && CAR(arg->parent) == CDR(arg->parent));
      goto retrace;
    }

    if (argno) {
      yyerror("Odd number of arguments to aggregate_mapping().");
      goto done;
    }

    if (!types[0]) {
      MAKE_CONSTANT_TYPE(new_type, tMap(tZero, tZero));
      goto set_type;
    }

    type_stack_mark();
    push_finished_type(types[1]);
    push_finished_type(types[0]);
    push_type(T_MAPPING);
    new_type = pop_unfinished_type();
  } else {
    MAKE_CONSTANT_TYPE(new_type, tMap(tZero, tZero));
    goto set_type;
  }
  if (new_type) {
  set_type:
    free_type(n->type);
    n->type = new_type;

#ifdef PIKE_DEBUG
    if (l_flag > 2) {
      fprintf(stderr, "Result type: ");
      simple_describe_type(new_type);
    }
#endif /* PIKE_DEBUG */

    if (n->parent) {
      n->parent->node_info |= OPT_TYPE_NOT_FIXED;
    }    
  }
 done:
  if (args) {
    /* Not really needed, but... */
    args->parent = n;
  }
  if (types[1]) {
    free_type(types[1]);
  }
  if (types[0]) {
    free_type(types[0]);
  }
  return NULL;
}

/*! @decl array values(string|array|mapping|multiset|object x)
 *!
 *!   Return an array of all possible values from indexing the value
 *!   @[x].
 *!
 *!   For strings an array of int with the ISO10646 codes of the
 *!   characters in the string is returned.
 *!
 *!   For a multiset an array filled with ones (@expr{1@}) is
 *!   returned.
 *!
 *!   For arrays a single-level copy of @[x] is returned.
 *!
 *!   For mappings the array may contain any value.
 *!
 *!   For objects which define @[lfun::_values()] that return value
 *!   is used.
 *!
 *!   For other objects an array with the values of all non-protected
 *!   symbols is returned.
 *!
 *! @seealso
 *!   @[indices()], @[types()], @[lfun::_values()]
 */
PMOD_EXPORT void f_values(INT32 args)
{
  ptrdiff_t size;
  struct array *a = NULL;
  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("values", 1);

  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_STRING:
    size = Pike_sp[-args].u.string->len;
    a = allocate_array_no_init(size,0);
    while(--size >= 0)
    {
      /* Elements are already integers. */
      ITEM(a)[size].u.integer = index_shared_string(Pike_sp[-args].u.string, size);
    }
    a->type_field = BIT_INT;
    break;

  case T_ARRAY:
    a=copy_array(Pike_sp[-args].u.array);
    break;

  case T_MAPPING:
    a=mapping_values(Pike_sp[-args].u.mapping);
    break;

  case T_MULTISET:
    a = multiset_values (Pike_sp[-args].u.multiset);
    break;

  case T_OBJECT:
    a=object_values(Pike_sp[-args].u.object, SUBTYPEOF(Pike_sp[-args]));
    break;

  case T_PROGRAM:
    a = program_values(Pike_sp[-args].u.program);
    break;

  case T_FUNCTION:
    {
      struct program *p = program_from_svalue(Pike_sp - args);
      if (p) {
	a = program_values(p);
	break;
      }
    }
    /* FALL THROUGH */

  default:
    SIMPLE_BAD_ARG_ERROR("values", 1,
			 "string|array|mapping|multiset|"
			 "object|program|function");
    return;  /* make apcc happy */
  }
  pop_n_elems(args);
  push_array(a);
}

/*! @decl array(type(mixed)) types(string|array|mapping|multiset|object x)
 *!
 *!   Return an array of all valid indices for the value @[x].
 *!
 *!   For strings this is simply an array with @tt{int@}
 *!
 *!   For arrays, mappings and multisets this is simply
 *!   an array with @tt{mixed@}.
 *!
 *!   For objects which define @[lfun::_types()] that return value
 *!   is used.
 *!
 *!   For other objects an array with type types for all non-protected
 *!   symbols is returned.
 *!
 *! @note
 *!   This function was added in Pike 7.9.
 *!
 *! @seealso
 *!   @[indices()], @[values()], @[lfun::_types()]
 */
PMOD_EXPORT void f_types(INT32 args)
{
  ptrdiff_t size;
  struct array *a = NULL;
  struct pike_type *default_type = mixed_type_string;

  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("types", 1);

  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_STRING:
    default_type = int_type_string;
    size=Pike_sp[-args].u.string->len;
    goto qjump;

  case T_MAPPING:
    size = Pike_sp[-args].u.mapping->data->size;
    goto qjump;

  case T_MULTISET:
    /* FIXME: Ought to be int(1..1). */
    default_type = int_type_string;
    size = Pike_sp[-args].u.multiset->msd->size;
    goto qjump;

  case T_ARRAY:
    size=Pike_sp[-args].u.array->size;

  qjump:
    a=allocate_array_no_init(size,0);
    while(--size>=0)
    {
      /* Elements are already integers. */
      SET_SVAL(ITEM(a)[size], PIKE_T_TYPE, 0, type, default_type);
      add_ref(default_type);
    }
    a->type_field = BIT_TYPE;
    break;

  case T_OBJECT:
    a=object_types(Pike_sp[-args].u.object, SUBTYPEOF(Pike_sp[-args]));
    break;

  case T_PROGRAM:
    a = program_types(Pike_sp[-args].u.program);
    break;

  case T_FUNCTION:
    {
      struct program *p = program_from_svalue(Pike_sp-args);
      if (p) {
	a = program_types(p);
	break;
      }
    }
    /* FALL THROUGH */

  default:
    SIMPLE_BAD_ARG_ERROR("types", 1,
			 "string|array|mapping|"
			 "multiset|object|program|function");
    return; /* make apcc happy */
  }
  pop_n_elems(args);
  push_array(a);
}

/*! @decl object next_object(object o)
 *! @decl object next_object()
 *!
 *!   Returns the next object from the list of all objects.
 *!
 *!   All objects are stored in a linked list.
 *!
 *! @returns
 *!   If no arguments have been given @[next_object()] will return the first
 *!   object from the list.
 *!
 *!   If @[o] has been specified the object after @[o] on the list will be
 *!   returned.
 *!
 *! @note
 *!   This function is not recomended to use.
 *!
 *! @seealso
 *!   @[destruct()]
 */
PMOD_EXPORT void f_next_object(INT32 args)
{
  struct object *o;

  ASSERT_SECURITY_ROOT("next_object");

  if(args < 1)
  {
    o = first_object;
  }else{
    if(TYPEOF(Pike_sp[-args]) != T_OBJECT)
      SIMPLE_BAD_ARG_ERROR("next_object", 1, "object");
    o = Pike_sp[-args].u.object->next;
  }
  while(o && !o->prog) o=o->next;
  pop_n_elems(args);
  if(!o)
  {
    push_int(0);
  }else{
    ref_push_object(o);
  }
}

/*! @decl program|function object_program(mixed o)
 *!
 *!   Return the program from which @[o] was instantiated. If the
 *!   object was instantiated from a class using parent references
 *!   the generating function will be returned.
 *!
 *!   If @[o] is not an object or has been destructed @expr{0@} (zero)
 *!   will be returned.
 */
PMOD_EXPORT void f_object_program(INT32 args)
{
  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("object_program", 1);

  if(TYPEOF(Pike_sp[-args]) == T_OBJECT)
  {
    struct object *o=Pike_sp[-args].u.object;
    struct program *p = o->prog;

    if(p)
    {
      if (SUBTYPEOF(Pike_sp[-args])) {
	/* FIXME: This probably works for the subtype-less case as well.
	 */
	struct external_variable_context loc;
	loc.o = o;
	p = (loc.inherit = p->inherits + SUBTYPEOF(Pike_sp[-args]))->prog;
	if (p->flags & PROGRAM_USES_PARENT) {
	  loc.parent_identifier = loc.inherit->parent_identifier;
	  find_external_context(&loc, 1);
	  add_ref(loc.o);
	  pop_n_elems(args);
	  push_function(loc.o, loc.parent_identifier);
	  return;
	}
      } else if((p->flags & PROGRAM_USES_PARENT) && 
	 PARENT_INFO(o)->parent &&
	 PARENT_INFO(o)->parent->prog)
      {
	INT32 id=PARENT_INFO(o)->parent_identifier;
	o=PARENT_INFO(o)->parent;
	add_ref(o);
	pop_n_elems(args);
	push_function(o, id);
	return;
      }
      add_ref(p);
      pop_n_elems(args);
      push_program(p);
      return;
    }
  }

  pop_n_elems(args);
  push_int(0);
}

node *fix_object_program_type(node *n)
{
  /* Fix the type for a common case:
   *
   * object_program(object(is|implements foo))
   */
  node *nn;
  struct pike_type *new_type = NULL;

  if (!n->type) {
    copy_pike_type(n->type, program_type_string);
  }
  if (!(nn = CDR(n))) return NULL;
  if ((nn->token == F_ARG_LIST) && (!(nn = CAR(nn)))) return NULL;
  if (!nn->type) return NULL;

  /* Perform the actual conversion. */
  new_type = object_type_to_program_type(nn->type);
  if (new_type) {
    free_type(n->type);
    n->type = new_type;
  }
  return NULL;
}

/*! @decl string reverse(string s, int|void start, int|void end)
 *! @decl array reverse(array a, int|void start, int|void end)
 *! @decl int reverse(int i, int|void start, int|void end)
 *!
 *!   Reverses a string, array or int.
 *!
 *!   @param s
 *!     String to reverse.
 *!   @param a
 *!     Array to reverse.
 *!   @param i
 *!     Integer to reverse.
 *!   @param start
 *!     Optional start index of the range to reverse.
 *!     Default: @expr{0@} (zero).
 *!   @param end
 *!     Optional end index of the range to reverse.
 *!     Default for strings: @expr{sizeof(s)-1@}.
 *!     Default for arrays: @expr{sizeof(a)-1@}.
 *!     Default for integers: @expr{Pike.get_runtime_info()->int_size - 1@}.
 *!
 *!   This function reverses a string, char by char, an array, value
 *!   by value or an int, bit by bit and returns the result. It's not
 *!   destructive on the input value.
 *!
 *!   Reversing strings can be particularly useful for parsing difficult
 *!   syntaxes which require scanning backwards.
 *!
 *! @seealso
 *!   @[sscanf()]
 */
PMOD_EXPORT void f_reverse(INT32 args)
{
  struct svalue *sv;
  int start = 0, end = -1;

  get_all_args("reverse", args, "%*.%d%d", &sv, &start, &end);

  switch(TYPEOF(*sv))
  {
  case T_STRING:
  {
    INT32 e;
    struct pike_string *s;
    struct pike_string *orig = sv->u.string;;
    if (start < 0) {
      start = 0;
    } else if (start >= orig->len) {
      /* Noop. */
      pop_n_elems(args-1);
      break;
    }
    if ((end < 0) || (end >= orig->len)) {
      end = orig->len;
    } else if (end <= start) {
      /* Noop. */
      pop_n_elems(args-1);
      break;
    } else {
      end++;
    }
    s=begin_wide_shared_string(orig->len, orig->size_shift);
    if ((orig->len << orig->size_shift) >= 524288) {
      /* More than 512KB. Release the interpreter lock. */
      THREADS_ALLOW();
      switch(orig->size_shift)
      {
      case 0:
	for(e=0;e<start;e++)
	  STR0(s)[e]=STR0(orig)[e];
	for(;e<end;e++)
	  STR0(s)[e]=STR0(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR0(s)[e]=STR0(orig)[e];
	break;

      case 1:
	for(e=0;e<start;e++)
	  STR1(s)[e]=STR1(orig)[e];
	for(;e<end;e++)
	  STR1(s)[e]=STR1(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR1(s)[e]=STR1(orig)[e];
	break;

      case 2:
	for(e=0;e<start;e++)
	  STR2(s)[e]=STR2(orig)[e];
	for(;e<end;e++)
	  STR2(s)[e]=STR2(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR2(s)[e]=STR2(orig)[e];
	break;
      }
      THREADS_DISALLOW();
    } else {
      switch(orig->size_shift)
      {
      case 0:
	for(e=0;e<start;e++)
	  STR0(s)[e]=STR0(orig)[e];
	for(;e<end;e++)
	  STR0(s)[e]=STR0(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR0(s)[e]=STR0(orig)[e];
	break;

      case 1:
	for(e=0;e<start;e++)
	  STR1(s)[e]=STR1(orig)[e];
	for(;e<end;e++)
	  STR1(s)[e]=STR1(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR1(s)[e]=STR1(orig)[e];
	break;

      case 2:
	for(e=0;e<start;e++)
	  STR2(s)[e]=STR2(orig)[e];
	for(;e<end;e++)
	  STR2(s)[e]=STR2(orig)[end-1-e-start];
	for(;e<orig->len;e++)
	  STR2(s)[e]=STR2(orig)[e];
	break;
      }
    }
    s=low_end_shared_string(s);
    pop_n_elems(args);
    push_string(s);
    break;
  }

  case T_INT:
  {
    /* FIXME: Ought to use INT_TYPE! */
    INT32 e;
    e=Pike_sp[-args].u.integer;
    e=((e & 0x55555555UL)<<1) + ((e & 0xaaaaaaaaUL)>>1);
    e=((e & 0x33333333UL)<<2) + ((e & 0xccccccccUL)>>2);
    e=((e & 0x0f0f0f0fUL)<<4) + ((e & 0xf0f0f0f0UL)>>4);
    e=((e & 0x00ff00ffUL)<<8) + ((e & 0xff00ff00UL)>>8);
    e=((e & 0x0000ffffUL)<<16)+ ((e & 0xffff0000UL)>>16);
    Pike_sp[-args].u.integer=e;
    pop_n_elems(args-1);
    break;
  }

  /* FIXME: Bignum support. */

  case T_ARRAY:
  {
    struct array *a = sv->u.array;
    a = reverse_array(a, start, (end < 0)?a->size:end);
    pop_n_elems(args);
    push_array(a);
    break;
  }

  default:
    SIMPLE_BAD_ARG_ERROR("reverse", 1, "string|int|array");    
  }
}

/* Magic, magic and more magic */
/* Returns the index in v for the string that is the longest prefix of
 * str (if any).
 *
 * v is the sorted (according to generic_quick_binary_strcmp()) vector
 * of replacement strings. It also has the prefix forest identified.
 *
 * a is the lower bound.
 * b is the upper bound + 1.
 */
int find_longest_prefix(char *str,
			ptrdiff_t len,
			int size_shift,
			struct replace_many_tupel *v,
			INT32 a,
			INT32 b)
{
  INT32 c, match=-1, match_len=-1;
  ptrdiff_t tmp;

  check_c_stack(2048);

  while(a<b)
  {
    c=(a+b)/2;

    if (v[c].ind->len <= match_len) {
      /* Can't be a suffix of (or is equal to) the current match. */
      b = c;
      continue;
    }

    tmp=generic_find_binary_prefix(v[c].ind->str,
				   v[c].ind->len,
				   v[c].ind->size_shift,
				   str,
				   MINIMUM(len,v[c].ind->len),
				   size_shift);

    if(tmp<0)
    {
      /* Check if we might have a valid prefix that is better than
       * the current match. */
      if (~tmp > match_len) {
	/* We need to look closer to see if we might have a partial prefix. */
	int d = c;
	tmp = -tmp;
	while (((d = v[d].prefix) >= a) && (v[d].ind->len > match_len)) {
	  if (v[d].ind->len < tmp) {
	    /* Found a valid prefix. */
	    match = d;
	    match_len = v[d].ind->len;
	    break;
	  }
	}
      }
      a = c+1;
    }
    else if(tmp>0)
    {
      b=c;
      while ((c = v[b].prefix) > a) {
	if (v[c].ind->len < tmp) {
	  if (v[c].ind->len > match_len) {
	    match = c;
	    match_len = v[c].ind->len;
	  }
	  a = c+1;
	  break;
	}
	b = c;
      }
    }
    else
    {
      if (!v[c].is_prefix) {
	return c;
      }
      a=c+1; /* There might still be a better match... */
      match=c;
      match_len = v[c].ind->len;
    }
  }
  return match;
}
			       

static int replace_sortfun(struct replace_many_tupel *a,
			   struct replace_many_tupel *b)
{
  return DO_NOT_WARN((int)my_quick_strcmp(a->ind, b->ind));
}

void free_replace_many_context(struct replace_many_context *ctx)
{
  if (ctx->v) {
    if (ctx->flags) {
      /* Used for the precompiled case. */
      int e = ctx->num;
      while (e--) {
	free_string(ctx->v[e].ind);
	free_string(ctx->v[e].val);
      }
      if (ctx->empty_repl) {
	free_string(ctx->empty_repl);
      }
    }
    free (ctx->v);
    ctx->v = NULL;
  }
}

void compile_replace_many(struct replace_many_context *ctx,
			  struct array *from,
			  struct array *to,
			  int reference_strings)
{
  INT32 e, num;

  ctx->v = NULL;
  ctx->empty_repl = NULL;

#if INT32_MAX >= LONG_MAX
  /* NOTE: The following test is needed, since sizeof(struct tupel)
   *       is somewhat greater than sizeof(struct svalue).
   */
  if (from->size > (ptrdiff_t)(LONG_MAX/sizeof(struct replace_many_tupel)))
    Pike_error("Array too large (size %" PRINTPTRDIFFT "d "
	       "exceeds %" PRINTSIZET "u).\n",
	       from->size,
	       (size_t)(LONG_MAX/sizeof(struct replace_many_tupel)));
#endif
  ctx->v = (struct replace_many_tupel *)
    xalloc(sizeof(struct replace_many_tupel) * from->size);

  for(num=e=0;e<from->size;e++)
  {
    if (!ITEM(from)[e].u.string->len) {
      if (ITEM(to)[e].u.string->len) {
	ctx->empty_repl = ITEM(to)[e].u.string;
      }
      continue;
    }

    ctx->v[num].ind=ITEM(from)[e].u.string;
    ctx->v[num].val=ITEM(to)[e].u.string;
    ctx->v[num].prefix=-2; /* Uninitialized */
    ctx->v[num].is_prefix=0;
    num++;
  }

  ctx->flags = reference_strings;
  if (reference_strings) {
    /* Used for the precompiled compiled case. */
    if (ctx->empty_repl) add_ref(ctx->empty_repl);
    for (e = 0; e < num; e++) {
      add_ref(ctx->v[e].ind);
      add_ref(ctx->v[e].val);
    }
  }

  fsort((char *)ctx->v, num, sizeof(struct replace_many_tupel),
	(fsortfun)replace_sortfun);

  memset(ctx->set_start, 0, sizeof(ctx->set_start));
  memset(ctx->set_end, 0, sizeof(ctx->set_end));
  ctx->other_start = num;

  for(e=0;e<num;e++)
  {
    {
      p_wchar2 x;

      if (ctx->v[num-1-e].ind->len) {
	x=index_shared_string(ctx->v[num-1-e].ind,0);
	if ((size_t) x < NELEM(ctx->set_start))
	  ctx->set_start[x]=num-e-1;
	else
	  ctx->other_start = num-e-1;
      }

      if (ctx->v[e].ind->len) {
	x=index_shared_string(ctx->v[e].ind,0);
	if ((size_t) x < NELEM(ctx->set_end))
	  ctx->set_end[x]=e+1;
      }
    }
    {
      INT32 prefix = e-1;
      if (prefix >= 0) {
	ptrdiff_t tmp =
	  generic_find_binary_prefix(ctx->v[e].ind->str,
				     ctx->v[e].ind->len,
				     ctx->v[e].ind->size_shift,
				     ctx->v[prefix].ind->str,
				     ctx->v[prefix].ind->len,
				     ctx->v[prefix].ind->size_shift);
	if (!tmp) {
	  /* ctx->v[prefix] is a valid prefix to ctx->v[e]. */
	} if (tmp == 1) {
	  /* Optimization. */
	  prefix = -1;
	} else {
#ifdef PIKE_DEBUG
	  if (tmp < 0) Pike_fatal("Sorting with replace_sortfunc failed.\n");
#endif

	  /* Find the first prefix that is shorter than the point at which
	   * the initial strings differed.
	   */
	  while (prefix >= 0) {
	    if (ctx->v[prefix].ind->len < tmp) break;
	    prefix = ctx->v[prefix].prefix;
	  }
	}
	if (prefix >= 0) {
	  ctx->v[prefix].is_prefix = 1;
	}
      }
      ctx->v[e].prefix = prefix;
    }
  }
  ctx->num = num;
}

struct pike_string *execute_replace_many(struct replace_many_context *ctx,
					 struct pike_string *str)
{
  struct string_builder ret;
  ONERROR uwp;

  init_string_builder(&ret, str->size_shift);
  SET_ONERROR(uwp, free_string_builder, &ret);

  /* FIXME: We really ought to build a trie! */

  switch (str->size_shift) {
#define CASE(SZ)					\
    case (SZ):						\
      {							\
	PIKE_CONCAT(p_wchar, SZ) *ss =			\
	  PIKE_CONCAT(STR, SZ)(str);			\
	ptrdiff_t e, s, length = str->len;		\
	for(e = s = 0;length > 0;)			\
	{						\
	  INT32 a, b;					\
	  p_wchar2 ch;					\
							\
	  ch = ss[s];					\
	  if(OPT_IS_CHAR(ch)) {				\
	    b = ctx->set_end[ch];			\
	    if (!b)					\
	      goto PIKE_CONCAT(next_char, SZ);		\
	    a = ctx->set_start[ch];			\
	  } else {					\
	    b = ctx->num;				\
	    a = ctx->other_start;			\
	  }						\
	  if (a >= b)					\
	    goto PIKE_CONCAT(next_char, SZ);		\
							\
	  a = find_longest_prefix((char *)(ss + s),	\
				  length,		\
				  SZ,			\
				  ctx->v, a, b);	\
							\
	  if(a >= 0)					\
	  {						\
	    if (s != e) {				\
	      PIKE_CONCAT(string_builder_binary_strcat,	\
			  SZ)(&ret, ss+e, s-e);		\
	    }						\
	    ch = ctx->v[a].ind->len;			\
	    s += ch;					\
	    length -= ch;				\
	    e = s;					\
	    string_builder_shared_strcat(&ret,		\
					 ctx->v[a].val);	\
	    if (ctx->empty_repl && length) {		\
	      /* Append the replacement for		\
	       * the empty string too. */		\
	      string_builder_shared_strcat(&ret,	\
					   ctx->empty_repl);	\
	    }						\
	    continue;					\
	  }						\
							\
	PIKE_CONCAT(next_char, SZ):			\
	  s++;						\
	  length--;					\
	  if (ctx->empty_repl && length) {		\
	    /* We have a replace with the empty string,	\
	     * and we're not on the last character	\
	     * in the source string.			\
	     */						\
	    string_builder_putchar(&ret, ch);		\
	    string_builder_shared_strcat(&ret,		\
					 ctx->empty_repl);	\
	    e = s;					\
	  }						\
	}						\
	if (e < s) {					\
	  PIKE_CONCAT(string_builder_binary_strcat, SZ)	\
	    (&ret, ss+e, s-e);				\
	}						\
      }							\
    break
#define OPT_IS_CHAR(X)	1
    CASE(0);
#undef OPT_IS_CHAR
#define OPT_IS_CHAR(X)	((size_t) (X) < NELEM(ctx->set_end))
    CASE(1);
    CASE(2);
#undef OPT_IS_CHAR
  }

  UNSET_ONERROR(uwp);
  return finish_string_builder(&ret);
}

static struct pike_string *replace_many(struct pike_string *str,
					struct array *from,
					struct array *to)
{
  struct replace_many_context ctx;
  ONERROR uwp;
  struct pike_string *ret;

  if(from->size != to->size)
    Pike_error("Replace must have equal-sized from and to arrays.\n");

  if(!from->size)
  {
    reference_shared_string(str);
    return str;
  }

  if( (from->type_field & ~BIT_STRING) &&
      (array_fix_type_field(from) & ~BIT_STRING) )
    Pike_error("replace: from array not array(string).\n");

  if( (to->type_field & ~BIT_STRING) &&
      (array_fix_type_field(to) & ~BIT_STRING) )
    Pike_error("replace: to array not array(string).\n");

  if (from->size == 1) {
    /* Just a single string... */
    return string_replace(str, from->item[0].u.string, to->item[0].u.string);
  }

  compile_replace_many(&ctx, from, to, 0);
  SET_ONERROR(uwp, free_replace_many_context, &ctx);

  ret = execute_replace_many(&ctx, str);

  CALL_AND_UNSET_ONERROR(uwp);

  return ret;
}

/*! @decl string replace(string s, string from, string to)
 *! @decl string replace(string s, array(string) from, array(string) to)
 *! @decl string replace(string s, array(string) from, string to)
 *! @decl string replace(string s, mapping(string:string) replacements)
 *! @decl array replace(array a, mixed from, mixed to)
 *! @decl mapping replace(mapping a, mixed from, mixed to)
 *!
 *!   Generic replace function.
 *!
 *!   This function can do several kinds replacement operations, the
 *!   different syntaxes do different things as follows:
 *! 
 *!   If all the arguments are strings, a copy of @[s] with every
 *!   occurrence of @[from] replaced with @[to] will be returned.
 *!   Special case: @[to] will be inserted between every character in
 *!   @[s] if @[from] is the empty string.
 *!
 *!   If the first argument is a string, and the others array(string), a string
 *!   with every occurrance of @[from][@i{i@}] in @[s] replaced with
 *!   @[to][@i{i@}] will be returned. Instead of the arrays @[from] and @[to]
 *!   a mapping equivalent to @expr{@[mkmapping](@[from], @[to])@} can be
 *!   used.
 *!
 *!   If the first argument is an array or mapping, the values of @[a] which
 *!   are @[`==()] with @[from] will be replaced with @[to] destructively.
 *!   @[a] will then be returned.
 *!
 *! @note
 *!   Note that @[replace()] on arrays and mappings is a destructive operation.
 */
PMOD_EXPORT void f_replace(INT32 args)
{
  if(args < 3)
  {
     if (args==2 &&
	 TYPEOF(Pike_sp[-1]) == T_MAPPING)
     {
       struct mapping *m = Pike_sp[-1].u.mapping;
       if( (m->data->ind_types & ~BIT_STRING) ||
	   (m->data->val_types & ~BIT_STRING) ) {
	 mapping_fix_type_field(Pike_sp[-1].u.mapping);
	 if( (m->data->ind_types & ~BIT_STRING) ||
	     (m->data->val_types & ~BIT_STRING) ) {
	   SIMPLE_BAD_ARG_ERROR("replace", 2, "mapping(string:string)");
	 }
       }

	stack_dup();
	f_indices(1);
	stack_swap();
	f_values(1);
	args++;
     }
     else
	SIMPLE_TOO_FEW_ARGS_ERROR("replace", 3);
  } else if (args > 3) {
    pop_n_elems(args-3);
    args = 3;
  }

  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_ARRAY:
  {
    array_replace(Pike_sp[-args].u.array,Pike_sp+1-args,Pike_sp+2-args);
    pop_n_elems(args-1);
    break;
  }

  case T_MAPPING:
  {
    mapping_replace(Pike_sp[-args].u.mapping,Pike_sp+1-args,Pike_sp+2-args);
    pop_n_elems(args-1);
    break;
  }

  case T_STRING:
  {
    struct pike_string *s;
    switch(TYPEOF(Pike_sp[1-args]))
    {
    default:
      SIMPLE_BAD_ARG_ERROR("replace", 2, "string|array");

    case T_STRING:
      if(TYPEOF(Pike_sp[2-args]) != T_STRING)
	SIMPLE_BAD_ARG_ERROR("replace", 3, "string");

      s=string_replace(Pike_sp[-args].u.string,
		       Pike_sp[1-args].u.string,
		       Pike_sp[2-args].u.string);
      break;
      
    case T_ARRAY:
      if (TYPEOF(Pike_sp[2-args]) == T_STRING) {
	push_int(Pike_sp[1-args].u.array->size);
	stack_swap();
	f_allocate(2);
      } else if(TYPEOF(Pike_sp[2-args]) != T_ARRAY)
	SIMPLE_BAD_ARG_ERROR("replace", 3, "array|string");

      s=replace_many(Pike_sp[-args].u.string,
		     Pike_sp[1-args].u.array,
		     Pike_sp[2-args].u.array);
    
    }
    pop_n_elems(args);
    push_string(s);
    break;
  }

  default:
    SIMPLE_BAD_ARG_ERROR("replace", 1, "array|mapping|string");
  }
}

node *optimize_replace(node *n)
{
  node **arg0 = my_get_arg(&_CDR(n), 0);
  struct pike_type *array_zero;
  struct pike_type *mapping_zero;

  if (!arg0) return NULL;

  MAKE_CONSTANT_TYPE(array_zero, tArr(tZero));
  MAKE_CONSTANT_TYPE(mapping_zero, tMap(tZero, tZero));

  if ((pike_types_le(array_zero, (*arg0)->type) ||
       pike_types_le(mapping_zero, (*arg0)->type))) {
    /* First argument might be an array or a mapping.
     *
     * replace() is destructive on arrays and mappings.
     */
    n->node_info |= OPT_SIDE_EFFECT;
    n->tree_info |= OPT_SIDE_EFFECT;
  } else {
    /* First argument is not an array or mapping,
     *
     * It must thus be a string.
     */
    node **arg1 = my_get_arg(&_CDR(n), 1);
    node **arg2 = my_get_arg(&_CDR(n), 2);

    /* This variable is modified in between setjmp and longjmp,
     * so it needs to be volatile to prevent it from being globbered.
     */
    struct program * volatile replace_compiler = NULL;

    if (arg1 && ((pike_types_le((*arg1)->type, array_type_string) &&
		  arg2 &&
		  (pike_types_le((*arg2)->type, array_type_string) ||
		   pike_types_le((*arg2)->type, string_type_string))) ||
		 (pike_types_le((*arg1)->type, mapping_type_string)))) {
      /* Handle the cases:
       *
       *   replace(string, array, array)
       *   replace(string, array, string)
       *   replace(string, mapping(string:string))
       */
      extern struct program *multi_string_replace_program;
      replace_compiler = multi_string_replace_program;
    } else if (arg1 && pike_types_le((*arg1)->type, string_type_string) &&
	       arg2 && pike_types_le((*arg2)->type, string_type_string)) {
      extern struct program *single_string_replace_program;
      replace_compiler = single_string_replace_program;
    }
    if (replace_compiler && !is_const(*arg0) && is_const(*arg1) &&
	(!arg2 || is_const(*arg2))) {
      /* The second and third (if any) arguments are constants. */
      struct svalue *save_sp = Pike_sp;
      JMP_BUF tmp;
      if (SETJMP(tmp)) {
	struct svalue thrown;
	struct pike_string *s;
	move_svalue (&thrown, &throw_value);
	mark_free_svalue (&throw_value);
	pop_n_elems(Pike_sp - save_sp);
	yywarning("Optimizer failure in replace().");
	s = format_exception_for_error_msg (&thrown);
	if (s) {
	  yywarning ("%S", s);
	  free_string (s);
	}
	free_svalue(&thrown);
      } else {
	INT16 lfun;
	struct object *replace_obj;
	node *ret = NULL;
	INT32 args;
	args = eval_low(*arg1, 1);
	if (args != 1) goto failed;
	if (arg2) {
	  args += eval_low(*arg2, 1);
	  if (!args) {
	    /* eval_low() returned -1. */
	    goto failed;
	  }
	}

	replace_obj = clone_object(replace_compiler, args);

	push_object(replace_obj);
	if (replace_obj->prog &&
	    ((lfun = FIND_LFUN(replace_obj->prog, LFUN_CALL)) != -1)) {
	  SET_SVAL(Pike_sp[-1], PIKE_T_FUNCTION, lfun, object, replace_obj);
	  ADD_NODE_REF2(*arg0,
			ret = mkapplynode(mkconstantsvaluenode(Pike_sp-1),
					  *arg0);
			);

	  UNSETJMP(tmp);
	  pop_n_elems(Pike_sp - save_sp);

	  free_type(array_zero);
	  free_type(mapping_zero);
	  return ret;
	}
      }
    failed:
      UNSETJMP(tmp);
      pop_n_elems(Pike_sp - save_sp);
    }
  }

  free_type(array_zero);
  free_type(mapping_zero);

  return NULL;
}

/*! @decl program compile(string source, CompilationHandler|void handler, @
 *!                       int|void major, int|void minor,@
 *!                       program|void target, object|void placeholder)
 *!
 *!   Compile a string to a program.
 *!
 *!   This function takes a piece of Pike code as a string and
 *!   compiles it into a clonable program.
 *!
 *!   The optional argument @[handler] is used to specify an alternative
 *!   error handler. If it is not specified the current master object will
 *!   be used.
 *!
 *!   The optional arguments @[major] and @[minor] are used to tell the
 *!   compiler to attempt to be compatible with Pike @[major].@[minor].
 *!
 *! @note
 *!   Note that @[source] must contain the complete source for a program.
 *!   It is not possible to compile a single expression or statement.
 *!
 *!   Also note that @[compile()] does not preprocess the program.
 *!   To preprocess the program you can use @[compile_string()] or
 *!   call the preprocessor manually by calling @[cpp()].
 *!
 *! @seealso
 *!   @[compile_string()], @[compile_file()], @[cpp()], @[master()],
 *!   @[CompilationHandler], @[DefaultCompilerEnvironment]
 */
PMOD_EXPORT void f_compile(INT32 args)
{
  apply_low(compilation_environment, CE_COMPILE_FUN_NUM, args);
}


/*! @decl array|mapping|multiset set_weak_flag(array|mapping|multiset m, @
 *!                                            int state)
 *!
 *!   Set the value @[m] to use weak or normal references in its
 *!   indices and/or values (whatever is applicable). @[state] is a
 *!   bitfield built by using @expr{|@} between the following flags:
 *!   
 *!   @int
 *!   	@value Pike.WEAK_INDICES
 *!   	  Use weak references for indices. Only applicable for
 *!   	  multisets and mappings.
 *!   	@value Pike.WEAK_VALUES
 *!   	  Use weak references for values. Only applicable for arrays
 *!   	  and mappings.
 *!   	@value Pike.WEAK
 *!   	  Shorthand for @expr{Pike.WEAK_INDICES|Pike.WEAK_VALUES@}.
 *!   @endint
 *!   
 *!   If a flag is absent, the corresponding field will use normal
 *!   references. @[state] can also be @expr{1@} as a compatibility
 *!   measure; it's treated like @[Pike.WEAK].
 *!
 *! @returns
 *!   @[m] will be returned.
 */
#define SETFLAG(FLAGS,FLAG,ONOFF) \
  FLAGS = (FLAGS & ~FLAG) | ( ONOFF ? FLAG : 0 )
void f_set_weak_flag(INT32 args)
{
  struct svalue *s;
  INT_TYPE ret;
  int flags;

  get_all_args("set_weak_flag",args,"%*%i",&s,&ret);

  if (ret == 1) ret = PIKE_WEAK_BOTH;

  switch(TYPEOF(*s))
  {
    case T_ARRAY:
      flags = array_get_flags(s->u.array);
      SETFLAG(flags,ARRAY_WEAK_FLAG,ret & PIKE_WEAK_VALUES);
      s->u.array = array_set_flags(s->u.array, flags);
      break;
    case T_MAPPING:
      flags = mapping_get_flags(s->u.mapping);
      flags = (flags & ~PIKE_WEAK_BOTH) | (ret & PIKE_WEAK_BOTH);
      mapping_set_flags(s->u.mapping, flags);
      break;
    case T_MULTISET:
      flags = multiset_get_flags (s->u.multiset);
      flags = (flags & ~PIKE_WEAK_BOTH) | (ret & PIKE_WEAK_BOTH);
      multiset_set_flags (s->u.multiset, flags);
      break;
    default:
      SIMPLE_BAD_ARG_ERROR("set_weak_flag",1,"array|mapping|multiset");
  }
  pop_n_elems(args-1);
}

/*! @decl int objectp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is an object, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[mappingp()], @[programp()], @[arrayp()], @[stringp()], @[functionp()],
 *!   @[multisetp()], @[floatp()], @[intp()]
 */
PMOD_EXPORT void f_objectp(INT32 args)
{
  if(args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("objectp", 1);
  if(TYPEOF(Pike_sp[-args]) != T_OBJECT || !Pike_sp[-args].u.object->prog
     || is_bignum_object(Pike_sp[-args].u.object))
  {
    pop_n_elems(args);
    push_int(0);
  }else{
    pop_n_elems(args);
    push_int(1);
  }
}

/*! @decl int functionp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a function, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[mappingp()], @[programp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[intp()]
 */
PMOD_EXPORT void f_functionp(INT32 args)
{
  int res = 0;
  if(args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("functionp", 1);
  if( TYPEOF(Pike_sp[-args]) == T_FUNCTION &&
      (SUBTYPEOF(Pike_sp[-args]) == FUNCTION_BUILTIN ||
       Pike_sp[-args].u.object->prog))
    res=1;
  pop_n_elems(args);
  push_int(res);
}

PMOD_EXPORT int callablep(struct svalue *s)
{
  int ret = 0;
  DECLARE_CYCLIC();

  if (BEGIN_CYCLIC(s, NULL)) {
    END_CYCLIC();
    return 1;
  }

  SET_CYCLIC_RET((ptrdiff_t)1);

  switch( TYPEOF(*s) )
  {
    case T_FUNCTION:
      if( SUBTYPEOF(*s) == FUNCTION_BUILTIN
	  || s->u.object->prog)
	ret = 1;
      break;
    case T_PROGRAM:
      ret = 1;
      break;
    case T_OBJECT:
      {
	struct program *p;
	if((p = s->u.object->prog) &&
	   FIND_LFUN(p->inherits[SUBTYPEOF(*s)].prog,
		     LFUN_CALL ) != -1)
          ret = 1;
      }
      break;
    case T_ARRAY:
      array_fix_type_field(s->u.array);
      if( !s->u.array->type_field) {
        ret = 1;
	break;
      }
      if( !(s->u.array->type_field & ~(BIT_CALLABLE|BIT_INT)) ) {
	struct array *a = s->u.array;
	int i;
	ret = 1;
	for(i=0; i<a->size; i++)
	  if( TYPEOF(ITEM(a)[i])!=T_INT && !callablep(&ITEM(a)[i]) )
	    ret = 0;
      }
      break;
  }

  END_CYCLIC();
  return ret;
}

/*! @decl int callablep(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a callable, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[mappingp()], @[programp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[intp()]
 */
PMOD_EXPORT void f_callablep(INT32 args)
{
  int res = 0;
  if(args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("callablep", 1);

  res = callablep(&Pike_sp[-args]);
  pop_n_elems(args);
  push_int(res);
}
#ifndef HAVE_AND_USE_POLL
#undef HAVE_POLL
#endif

static void delaysleep(double delay, unsigned do_abort_on_signal,
 unsigned do_microsleep)
{
#define POLL_SLEEP_LIMIT 0.02

   struct timeval gtod_t0 = {0,0}, gtod_tv = {0,0};
   cpu_time_t t0, tv;

   /* Special case, sleep(0) means 'yield' */
   if(delay == 0.0)
   {
     check_threads_etc();
     /* Since check_threads doesn't yield on every call, we need this
      * to ensure th_yield gets called. */
     pike_thread_yield();
     return;
   }

   if(sizeof(FLOAT_TYPE)<sizeof(double))
     delay += FLT_EPSILON*5;	/* round up */

   t0 = tv = get_real_time();
   if (t0 == -1) {
     /* Paranoia in case get_real_time fails. */
     /* fprintf (stderr, "get_real_time failed in sleep()\n"); */
     ACCURATE_GETTIMEOFDAY (&gtod_t0);
     gtod_tv = gtod_t0;
   }

#define FIX_LEFT()							\
   if (t0 == -1) {							\
     ACCURATE_GETTIMEOFDAY (&gtod_tv);					\
     left = delay - ((gtod_tv.tv_sec-gtod_t0.tv_sec) +			\
		     (gtod_tv.tv_usec-gtod_t0.tv_usec)*1e-6);		\
   }									\
   else {								\
     tv = get_real_time();						\
     left = delay - (tv - t0) * (1.0 / CPU_TIME_TICKS);			\
   }									\
   if (do_microsleep) left-=POLL_SLEEP_LIMIT;

   if (!do_microsleep || delay>POLL_SLEEP_LIMIT)
   {
     for(;;)
     {
       double left;
       /* THREADS_ALLOW may take longer time then POLL_SLEEP_LIMIT */
       THREADS_ALLOW();
       FIX_LEFT();
       if(left>0.0)
	 sysleep(left);
       THREADS_DISALLOW();
       if(do_abort_on_signal) {
	 INVALIDATE_CURRENT_TIME();
	 return;
       }
       FIX_LEFT();
       if(left<=0.0)
	 break;
       check_threads_etc();
     }
     INVALIDATE_CURRENT_TIME();
   }

   if (do_microsleep) {
     if (t0 == -1) {
       while (delay> ((gtod_tv.tv_sec-gtod_t0.tv_sec) +
		      (gtod_tv.tv_usec-gtod_t0.tv_usec)*1e-6))
	 ACCURATE_GETTIMEOFDAY (&gtod_tv);
     }
     else {
       while (delay> (tv - t0) * (1.0 / CPU_TIME_TICKS))
	 tv = get_real_time();
     }
   }

   /* fprintf (stderr, "slept %g\n", (tv - t0) * (1.0 / CPU_TIME_TICKS)); */
}

/*! @decl void sleep(int|float s, void|int abort_on_signal)
 *!
 *!   This function makes the program stop for @[s] seconds.
 *!
 *!   Only signal handlers can interrupt the sleep, and only when
 *!   @[abort_on_signal] is set. If more than one thread is running
 *!   the signal must be sent to the sleeping thread. Other callbacks
 *!   are not called during sleep.
 *!
 *!   If @[s] is zero then this thread will yield to other threads but
 *!   not sleep otherwise. Note that Pike yields internally at regular
 *!   intervals so it's normally not necessary to do this.
 *!
 *! @seealso
 *!   @[signal()], @[delay()]
 */
PMOD_EXPORT void f_sleep(INT32 args)
{
   double delay=0.0;
   unsigned do_abort_on_signal;

   switch(TYPEOF(Pike_sp[-args]))
   {
      case T_INT:
	 delay=(double)Pike_sp[-args].u.integer;
	 break;

      case T_FLOAT:
	 delay=(double)Pike_sp[-args].u.float_number;
	 break;
   }

   do_abort_on_signal = delay!=0.0 && args > 1
    && !UNSAFE_IS_ZERO(Pike_sp + 1-args);
   pop_n_elems(args);

   delaysleep(delay, do_abort_on_signal, 0);
}

#undef FIX_LEFT
#undef TIME_ELAPSED

/*! @decl void delay(int|float s)
 *!
 *!   This function makes the program stop for @[s] seconds.
 *!
 *!   Only signal handlers can interrupt the sleep. Other callbacks are
 *!   not called during delay. Beware that this function uses busy-waiting
 *!   to achieve the highest possible accuracy.
 *!   
 *! @seealso
 *!   @[signal()], @[sleep()]
 */
PMOD_EXPORT void f_delay(INT32 args)
{
   double delay=0.0;
   unsigned do_abort_on_signal;

   switch(TYPEOF(Pike_sp[-args]))
   {
      case T_INT:
	 delay=(double)Pike_sp[-args].u.integer;
	 break;

      case T_FLOAT:
	 delay=(double)Pike_sp[-args].u.float_number;
	 break;
   }

   do_abort_on_signal = delay!=0.0 && args > 1
    && !UNSAFE_IS_ZERO(Pike_sp + 1-args);
   pop_n_elems(args);

   delaysleep(delay, do_abort_on_signal, !do_abort_on_signal && delay<10);
}

/*! @decl int gc(mapping|void quick)
 *!
 *!   Force garbage collection.
 *!
 *! @param quick
 *!   Perform a quick garbage collection on just this value,
 *!   which must have been made weak by @[set_weak_flag()].
 *!   All values that only have a single reference from
 *!   @[quick] will then be freed.
 *!
 *!   When @[quick] hasn't been specified or is @[UNDEFINED],
 *!   this function checks all the memory for cyclic structures such
 *!   as arrays containing themselves and frees them if appropriate.
 *!   It also frees up destructed objects and things with only weak
 *!   references.
 *!
 *!   Normally there is no need to call this function since Pike will
 *!   call it by itself every now and then. (Pike will try to predict
 *!   when 20% of all arrays/object/programs in memory is 'garbage'
 *!   and call this routine then.)
 *!
 *! @returns
 *!   The amount of garbage is returned. This is the number of arrays,
 *!   mappings, multisets, objects and programs that had no nonweak
 *!   external references during the garbage collection. It's normally
 *!   the same as the number of freed things, but there might be some
 *!   difference since destroy() functions are called during freeing,
 *!   which can cause more things to be freed or allocated.
 *!
 *! @seealso
 *!   @[Pike.gc_parameters], @[Debug.gc_status]
 */
void f_gc(INT32 args)
{
  ptrdiff_t res = 0;
  if (args && (TYPEOF(Pike_sp[-args]) == PIKE_T_MAPPING)) {
    res = do_gc_weak_mapping(Pike_sp[-args].u.mapping);
    pop_n_elems(args);
  } else {
    pop_n_elems(args);
    res = do_gc(NULL, 1);
  }
  push_int(res);
}

#ifdef TYPEP
#undef TYPEP
#endif


#define TYPEP(ID,NAME,TYPE,TYPE_NAME)					\
  PMOD_EXPORT void ID(INT32 args)					\
  {									\
    int t;								\
    struct program *p;							\
    if (args<1)								\
      SIMPLE_TOO_FEW_ARGS_ERROR(NAME, 1);				\
    if (TYPEOF(Pike_sp[-args]) == T_OBJECT &&				\
	(p = Pike_sp[-args].u.object->prog))				\
    {									\
      int fun = FIND_LFUN(p->inherits[SUBTYPEOF(Pike_sp[-args])].prog,	\
			  LFUN__IS_TYPE);				\
      if (fun != -1)							\
      {									\
	int id_level =							\
	  p->inherits[SUBTYPEOF(Pike_sp[-args])].identifier_level;	\
	ref_push_string(literal_##TYPE_NAME##_string);			\
	apply_low(Pike_sp[-args-1].u.object, fun + id_level, 1);	\
	stack_unlink(args);						\
	return;								\
      }									\
    }									\
    t = TYPEOF(Pike_sp[-args]) == TYPE;					\
    pop_n_elems(args);							\
    push_int(t);							\
  }

/*! @decl int undefinedp(mixed arg)
 *!
 *! Returns @expr{1@} if @[arg] is undefined, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[zero_type], @[destructedp], @[intp]
 */
PMOD_EXPORT void f_undefinedp(INT32 args)
{
  if( args<1 )
    SIMPLE_TOO_FEW_ARGS_ERROR("undefinedp", 1);
  f_zero_type(args);
  Pike_sp[-1].u.integer = ( Pike_sp[-1].u.integer == NUMBER_UNDEFINED);
}

/*! @decl int destructedp(mixed arg)
 *!
 *! Returns @expr{1@} if @[arg] is a destructed object, @expr{0@}
 *! (zero) otherwise.
 *!
 *! @seealso
 *!   @[zero_type], @[undefinedp], @[intp]
 */
PMOD_EXPORT void f_destructedp(INT32 args)
{
  if( args<1 )
    SIMPLE_TOO_FEW_ARGS_ERROR("destructedp", 1);
  f_zero_type(args);
  Pike_sp[-1].u.integer = ( Pike_sp[-1].u.integer == NUMBER_DESTRUCTED);
}

/*! @decl int programp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a program, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[mappingp()], @[intp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[functionp()]
 */
PMOD_EXPORT void f_programp(INT32 args)
{
  if(args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("programp", 1);
  switch(TYPEOF(Pike_sp[-args]))
  {
  case T_PROGRAM:
    pop_n_elems(args);
    push_int(1);
    return;

  case T_FUNCTION:
    if(program_from_function(Pike_sp-args))
    {
      pop_n_elems(args);
      push_int(1);
      return;
    }

  default:
    pop_n_elems(args);
    push_int(0);
  }
}

/*! @decl int intp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is an int, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[mappingp()], @[programp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[functionp()]
 */

/*! @decl int mappingp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a mapping, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[intp()], @[programp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[functionp()]
 */

/*! @decl int arrayp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is an array, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[intp()], @[programp()], @[mappingp()], @[stringp()], @[objectp()],
 *!   @[multisetp()], @[floatp()], @[functionp()]
 */

/*! @decl int multisetp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a multiset, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[intp()], @[programp()], @[arrayp()], @[stringp()], @[objectp()],
 *!   @[mappingp()], @[floatp()], @[functionp()]
 */

/*! @decl int stringp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a string, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[intp()], @[programp()], @[arrayp()], @[multisetp()], @[objectp()],
 *!   @[mappingp()], @[floatp()], @[functionp()]
 */

/*! @decl int floatp(mixed arg)
 *!
 *!   Returns @expr{1@} if @[arg] is a float, @expr{0@} (zero) otherwise.
 *!
 *! @seealso
 *!   @[intp()], @[programp()], @[arrayp()], @[multisetp()], @[objectp()],
 *!   @[mappingp()], @[stringp()], @[functionp()]
 */


TYPEP(f_intp, "intp", T_INT, int)
TYPEP(f_mappingp, "mappingp", T_MAPPING, mapping)
TYPEP(f_arrayp, "arrayp", T_ARRAY, array)
TYPEP(f_multisetp, "multisetp", T_MULTISET, multiset)
TYPEP(f_stringp, "stringp", T_STRING, string)
TYPEP(f_floatp, "floatp", T_FLOAT, float)

/*! @decl array sort(array(mixed) index, array(mixed) ... data)
 *!
 *!   Sort arrays destructively.
 *!
 *!   This function sorts the array @[index] destructively. That means
 *!   that the array itself is changed and returned, no copy is created.
 *!
 *!   If extra arguments are given, they are supposed to be arrays of the
 *!   same size as @[index]. Each of these arrays will be modified in the
 *!   same way as @[index]. I.e. if index 3 is moved to position 0 in @[index]
 *!   index 3 will be moved to position 0 in all the other arrays as well.
 *!
 *!   The sort order is as follows:
 *!
 *!   @ul
 *!   @item
 *!     Integers and floats are sorted in ascending order.
 *!   @item
 *!     Strings are sorted primarily on the first characters that are
 *!     different, and secondarily with shorter strings before longer.
 *!     Different characters are sorted in ascending order on the
 *!     character value. Thus the sort order is not locale dependent.
 *!   @item
 *!     Arrays are sorted recursively on the first element. Empty
 *!     arrays are sorted before nonempty ones.
 *!   @item
 *!     Multisets are sorted recursively on the first index. Empty
 *!     multisets are sorted before nonempty ones.
 *!   @item
 *!     Objects are sorted in ascending order according to @[`<()],
 *!     @[`>()] and @[`==()].
 *!   @item
 *!     Other types aren't reordered.
 *!   @item
 *!     Different types are sorted in this order: Arrays, mappings,
 *!     multisets, objects, functions, programs, strings, types,
 *!     integers and floats. Note however that objects can control
 *!     their ordering wrt other types with @[`<], @[`>] and @[`==],
 *!     so this ordering of types only applies to objects without
 *!     those functions.
 *!   @endul
 *!
 *! @returns
 *!   The first argument is returned.
 *! 
 *! @note
 *!   The sort is stable, i.e. elements that are compare-wise equal
 *!   aren't reordered.
 *!
 *! @seealso
 *!   @[Array.sort_array], @[reverse()]
 */
PMOD_EXPORT void f_sort(INT32 args)
{
  INT32 e,*order;
  struct array *a;

  if(args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("sort", 1);
  if(TYPEOF(Pike_sp[-args]) != T_ARRAY)
    SIMPLE_BAD_ARG_ERROR("sort", 1, "array");
  a = Pike_sp[-args].u.array;

  for(e=1;e<args;e++)
  {
    if(TYPEOF(Pike_sp[e-args]) != T_ARRAY)
      SIMPLE_BAD_ARG_ERROR("sort", e+1, "array");

    if(Pike_sp[e-args].u.array->size != a->size)
      bad_arg_error("sort", Pike_sp-args, args, e+1, "array", Pike_sp+e-args,
		    "Argument %d has wrong size.\n", (e+1));
  }

  if(args > 1)
  {
    order = stable_sort_array_destructively(a);
    for(e=1;e<args;e++) order_array(Pike_sp[e-args].u.array,order);
    pop_n_elems(args-1);
    free(order);
  }
  else {
    /* If there are only simple types in the array we can use unstable
     * sorting. */
    array_fix_unfinished_type_field (a);
    if (a->type_field & BIT_COMPLEX)
      free (stable_sort_array_destructively (a));
    else
      sort_array_destructively (a);
  }
}

/*! @decl array rows(mixed data, array index)
 *!
 *!   Select a set of rows from an array.
 *!
 *!   This function is en optimized equivalent to:
 *!
 *! @code
 *! map(@[index], lambda(mixed x) { return @[data][x]; })
 *! @endcode
 *!
 *!   That is, it indices data on every index in the array index and
 *!   returns an array with the results.
 *!
 *! @seealso
 *!   @[column()]
 */
PMOD_EXPORT void f_rows(INT32 args)
{
  INT32 e;
  struct array *a,*tmp;
  struct svalue *val;
  TYPE_FIELD types;

  get_all_args("rows", args, "%*%a", &val, &tmp);

  /* Optimization */
  if(tmp->refs == 1)
  {
    struct svalue sval;
    tmp->type_field = BIT_MIXED | BIT_UNFINISHED;
    types = 0;
    for(e=0;e<tmp->size;e++)
    {
      index_no_free(&sval, val, ITEM(tmp)+e);
      types |= 1 << TYPEOF(sval);
      free_svalue(ITEM(tmp)+e);
      move_svalue (ITEM(tmp) + e, &sval);
    }
    tmp->type_field = types;
    stack_swap();
    pop_stack();
    return;
  }

  push_array(a=allocate_array(tmp->size));
  types = 0;
  for(e=0;e<a->size;e++) {
    index_no_free(ITEM(a)+e, val, ITEM(tmp)+e);
    types |= 1 << TYPEOF(ITEM(a)[e]);
  }
  a->type_field = types;
  
  Pike_sp--;
  dmalloc_touch_svalue(Pike_sp);
  pop_n_elems(args);
  push_array(a);
}


/*! @decl int map_all_objects(function(object:void) cb)
 *! @belongs Debug
 *!
 *! Call cb for all objects that currently exist. The callback will
 *! not be called with destructed objects as it's argument.
 *!
 *! Objects might be missed if @[cb] creates new objects or destroys
 *! old ones.
 *!
 *! This function is only intended to be used for debug purposes.
 *!
 *! @returns
 *!   The total number of objects
 *!
 *! @seealso
 *!   @[next_object()], @[find_all_clones()]
 */
static void f_map_all_objects( INT32 UNUSED(args) )
{
    struct object *o = first_object;
    INT32 total = 0;
    ASSERT_SECURITY_ROOT("_map_all_objects");
    while( o )
    {
        struct object *next = o->next;
        if( o->prog )
        {
            ref_push_object( o );
            safe_apply_svalue( Pike_sp-2, 1, 1 );
            pop_stack();
        }
        total++;
        o = next;
    }
    pop_stack();
    push_int(total);
}

/*! @decl array(object) find_all_clones(program p, @
 *!                                     int(0..1)|void include_subclasses)
 *!
 *!   Return an array with all objects that are clones of @[p].
 *!
 *! @param p
 *!   Program that the objects should be a clone of.
 *!
 *! @param include_subclasses
 *!   If true, include also objects that are clones of programs
 *!   that have inherited @[p]. Note that this adds significant
 *!   overhead.
 *!
 *! This function is only intended to be used for debug purposes.
 *!
 *! @seealso
 *!   @[map_all_objects()]
 */
static void f_find_all_clones(INT32 args)
{
  INT_TYPE include_subclasses = 0;
  struct object *o = first_object;
  struct program *p = NULL;

  get_all_args("Debug.find_all_clones", args, "%p.%i",
	       &p, &include_subclasses);

  BEGIN_AGGREGATE_ARRAY(10) {

    for (o = first_object; o; o = o->next) {
      if (o->prog == p) {
	ref_push_object(o);
	DO_AGGREGATE_ARRAY(120);
	continue;
      }
      if (include_subclasses && o->prog &&
	  (o->prog->num_inherits > p->num_inherits)) {
	int e;
	/* Check if o->prog has inherited p. */
	if (o->prog->storage_needed < p->storage_needed) continue;
	for (e = o->prog->num_inherits + 1 - p->num_inherits; e-- > 1;) {
	  if (o->prog->inherits[e].prog == p) {
	    /* Found. */
	    ref_push_object(o);
	    DO_AGGREGATE_ARRAY(120);
	    break;
	  }
	}
      }
    }

  } END_AGGREGATE_ARRAY;

  stack_pop_n_elems_keep_top(args);
}

/*! @decl void verify_internals()
 *! @belongs Debug
 *!
 *!   Perform sanity checks.
 *!
 *!   This function goes through most of the internal Pike structures and
 *!   generates a fatal error if one of them is found to be out of order.
 *!   It is only used for debugging.
 *!
 *! @note
 *!   This function does a more thorough check if the Pike runtime has
 *!   been compiled with RTL debug.
 */
PMOD_EXPORT void f__verify_internals(INT32 args)
{
  INT32 tmp=d_flag;
  ASSERT_SECURITY_ROOT("_verify_internals");

  /* Keep below calls to low_thorough_check_short_svalue, or else we
   * get O(n!) or so, where n is the number of allocated things. */
  d_flag = 49;

#ifdef PIKE_DEBUG
  do_debug();			/* Calls do_gc() since d_flag > 3. */
#else
  do_gc(NULL, 1);
#endif
  d_flag=tmp;
  pop_n_elems(args);
}

#ifdef PIKE_DEBUG

/*! @decl int(0..) debug(int(0..) level)
 *! @belongs Debug
 *!
 *!   Set the run-time debug level.
 *!
 *! @returns
 *!   The old debug level will be returned.
 *! 
 *! @note
 *!   This function is only available if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__debug(INT32 args)
{
  INT_TYPE d;

  ASSERT_SECURITY_ROOT("_debug");

  get_all_args("_debug", args, "%+", &d);
  pop_n_elems(args);
  push_int(d_flag);
  d_flag = d;
}

/*! @decl int(0..) optimizer_debug(int(0..) level)
 *! @belongs Debug
 *!
 *!   Set the optimizer debug level.
 *!
 *! @returns
 *!   The old optimizer debug level will be returned.
 *! 
 *! @note
 *!   This function is only available if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__optimizer_debug(INT32 args)
{
  INT_TYPE l;

  ASSERT_SECURITY_ROOT("_optimizer_debug");

  get_all_args("_optimizer_debug", args, "%+", &l);
  pop_n_elems(args);
  push_int(l_flag);
  l_flag = l;
}


/*! @decl int(0..) assembler_debug(int(0..) level)
 *! @belongs Debug
 *!
 *!   Set the assembler debug level.
 *!
 *! @returns
 *!   The old assembler debug level will be returned.
 *! 
 *! @note
 *!   This function is only available if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__assembler_debug(INT32 args)
{
  INT_TYPE l;

  ASSERT_SECURITY_ROOT("_assembler_debug");

  get_all_args("_assembler_debug", args, "%+", &l);
  pop_n_elems(args);
  push_int(a_flag);
  a_flag = l;
}

/*! @decl void dump_program_tables(program p, int(0..)|void indent)
 *! @belongs Debug
 *!
 *! Dumps the internal tables for the program @[p] on stderr.
 *!
 *! @param p
 *!   Program to dump.
 *!
 *! @param indent
 *!   Number of spaces to indent the output.
 *!
 *! @note
 *!   In Pike 7.8.308 and earlier @[indent] wasn't supported.
 */
void f__dump_program_tables(INT32 args)
{
  struct program *p;
  INT_TYPE indent = 0;

  ASSERT_SECURITY_ROOT("_dump_program_tables");	/* FIXME: Might want lower. */
  get_all_args("_dump_program_tables", args, "%p.%+", &p, &indent);

  dump_program_tables(p, indent);
  pop_n_elems(args);
}

#ifdef YYDEBUG

/*! @decl int(0..) compiler_trace(int(0..) level)
 *! @belongs Debug
 *!
 *!   Set the compiler trace level.
 *!
 *! @returns
 *!   The old compiler trace level will be returned.
 *! 
 *! @note
 *!   This function is only available if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__compiler_trace(INT32 args)
{
  extern int yydebug;
  INT_TYPE yyd;
  ASSERT_SECURITY_ROOT("_compiler_trace");

  get_all_args("_compiler_trace", args, "%i", &yyd);
  pop_n_elems(args);
  push_int(yydebug);
  yydebug = yyd;
}

#endif /* YYDEBUG */
#endif

static void encode_struct_tm(struct tm *tm)
{
  push_text("sec");
  push_int(tm->tm_sec);
  push_text("min");
  push_int(tm->tm_min);
  push_text("hour");
  push_int(tm->tm_hour);

  push_text("mday");
  push_int(tm->tm_mday);
  push_text("mon");
  push_int(tm->tm_mon);
  push_text("year");
  push_int(tm->tm_year);

  push_text("wday");
  push_int(tm->tm_wday);
  push_text("yday");
  push_int(tm->tm_yday);
  push_text("isdst");
  push_int(tm->tm_isdst);
}

/*! @decl mapping(string:int) gmtime(int timestamp)
 *!
 *!   Convert seconds since 00:00:00 UTC, Jan 1, 1970 into components.
 *!
 *!   This function works like @[localtime()] but the result is
 *!   not adjusted for the local time zone.
 *!
 *! @seealso
 *!   @[localtime()], @[time()], @[ctime()], @[mktime()]
 */
PMOD_EXPORT void f_gmtime(INT32 args)
{
#if defined (HAVE_GMTIME_R) || defined (HAVE_GMTIME_S)
  struct tm tm_s;
#endif
  struct tm *tm;
  LONGEST tt;
  time_t t;

  get_all_args("gmtime", args, "%l", &tt);

#if SIZEOF_TIME_T < SIZEOF_LONGEST
  if (tt > MAX_TIME_T || tt < MIN_TIME_T)
    SIMPLE_ARG_ERROR ("gmtime", 1, "Timestamp outside valid range.");
#endif
  t = (time_t) tt;

#ifdef HAVE_GMTIME_R
  tm = gmtime_r (&t, &tm_s);
#elif defined (HAVE_GMTIME_S)
  if (!gmtime_s (&tm_s, &t)) tm = &tm_s; else tm = NULL;
#else
  tm = gmtime(&t);
#endif
  if (!tm) Pike_error ("gmtime() on this system cannot handle "
		       "the timestamp %"PRINTLONGEST"d.\n", (LONGEST) t);
  pop_n_elems(args);
  encode_struct_tm(tm);

  push_text("timezone");
  push_int(0);
  f_aggregate_mapping(20);
}

/*! @decl mapping(string:int) localtime(int timestamp)
 *!
 *!   Convert seconds since 00:00:00 UTC, 1 Jan 1970 into components.
 *!
 *! @returns
 *!   This function returns a mapping with the following components:
 *!   @mapping
 *!   	@member int(0..60) "sec"
 *!   	  Seconds over the minute.
 *!   	@member int(0..59) "min"
 *!   	  Minutes over the hour.
 *!   	@member int(0..23) "hour"
 *!   	  Hour of the day.
 *!   	@member int(1..31) "mday"
 *!   	  Day of the month.
 *!   	@member int(0..11) "mon"
 *!   	  Month of the year.
 *!   	@member int(0..) "year"
 *!   	  Year since 1900.
 *!   	@member int(0..6) "wday"
 *!   	  Day of week (0 = Sunday).
 *!   	@member int(0..365) "yday"
 *!   	  Day of the year.
 *!   	@member int(0..1) "isdst"
 *!   	  Is daylight-saving time active.
 *!   	@member int "timezone"
 *!   	  Offset from UTC, including daylight-saving time adjustment.
 *!   @endmapping
 *!
 *! An error is thrown if the localtime(2) call failed on the system.
 *! It's platform dependent what time ranges that function can handle,
 *! e.g. Windows doesn't handle a negative @[timestamp].
 *!
 *! @note
 *!   Prior to Pike 7.5 the field @expr{"timezone"@} was sometimes not
 *!   present, and was sometimes not adjusted for daylight-saving time.
 *!
 *! @seealso
 *!   @[Calendar], @[gmtime()], @[time()], @[ctime()], @[mktime()]
 */
PMOD_EXPORT void f_localtime(INT32 args)
{
  struct tm *tm;
  LONGEST tt;
  time_t t;

  get_all_args("localtime", args, "%l", &tt);

#if SIZEOF_TIME_T < SIZEOF_LONGEST
  if (tt > MAX_TIME_T || tt < MIN_TIME_T)
    SIMPLE_ARG_ERROR ("localtime", 1, "Timestamp outside valid range.");
#endif
  t = (time_t) tt;

  tm = localtime(&t);
  if (!tm) Pike_error ("localtime() on this system cannot handle "
		       "the timestamp %ld.\n", (long) t);
  pop_n_elems(args);
  encode_struct_tm(tm);

  push_text("timezone");
#ifdef STRUCT_TM_HAS_GMTOFF
  push_int(-tm->tm_gmtoff);
#elif defined(STRUCT_TM_HAS___TM_GMTOFF)
  push_int(-tm->__tm_gmtoff);
#elif defined(HAVE_EXTERNAL_TIMEZONE)
  /* Assume dst is one hour. */
  push_int(timezone - 3600*tm->tm_isdst);
#else
  /* Assume dst is one hour. */
  push_int(-3600*tm->tm_isdst);
#endif
  f_aggregate_mapping(20);
}

time_t mktime_zone(struct tm *date, int other_timezone, int tz)
{
  time_t retval;
  int normalised_time;

  date->tm_wday = -1;		/* flag to determine failure */

  {
    int sec, min, hour;
    sec = date->tm_sec;
    min = date->tm_min;
    hour = date->tm_hour;

    min += sec / 60;
    if ((sec %= 60) < 0)
      min--, sec += 60;
    hour += min / 60;
    if ((min %= 60) < 0)
      hour--, min += 60;
    if ((hour %= 24) < 0)
      hour += 24;
    normalised_time = ((hour * 60) + min) * 60 + sec;
  }

  retval = mktime(date);
  if (date->tm_wday < 0)
    Pike_error("Time conversion unsuccessful.\n");

  if(other_timezone)
  {
    normalised_time -= ((date->tm_hour * 60) + date->tm_min) * 60 + date->tm_sec;
    if (normalised_time < -12*60*60)
      normalised_time += 24*60*60;
    else if (normalised_time > 12*60*60)
      normalised_time -= 24*60*60;

#ifdef STRUCT_TM_HAS___TM_GMTOFF
    retval += date->__tm_gmtoff;
#elif defined(STRUCT_TM_HAS_GMTOFF)
    retval += date->tm_gmtoff;
#elif defined(HAVE_EXTERNAL_TIMEZONE) && defined(HAVE_EXTERNAL_ALTZONE)
    if (date->tm_isdst) {
      retval -= altzone;
    } else {
      retval -= timezone;
    }
#else
    {
      /* NB: The tm from gmtime(3F) will always have tm_isdst == 0,
       *     but mktime() is always in the local time zone, and will
       *     adjust it and tm_hour if the local time zone is in dst.
       *     This causes an error of typically one hour in dst when
       *     used without preadjustment.
       */
      struct tm gmt_tm = *gmtime(&retval);
      gmt_tm.tm_isdst = date->tm_isdst;
      normalised_time += retval - mktime(&gmt_tm);
    }
#endif
    retval += normalised_time + tz;
  }
  return retval;
}

/*! @decl int mktime(mapping(string:int) tm)
 *! @decl int mktime(int sec, int min, int hour, int mday, int mon, int year, @
 *!                  int|void isdst, int|void tz)
 *!
 *!   This function converts information about date and time into an integer
 *!   which contains the number of seconds since 00:00:00 UTC, Jan 1, 1970.
 *!
 *!   You can either call this function with a mapping containing the
 *!   following elements:
 *!   @mapping
 *!   	@member int(0..60) "sec"
 *!   	  Seconds over the minute.
 *!   	@member int(0..59) "min"
 *!   	  Minutes over the hour.
 *!   	@member int(0..23) "hour"
 *!   	  Hour of the day.
 *!   	@member int(1..31) "mday"
 *!   	  Day of the month.
 *!   	@member int(0..11) "mon"
 *!   	  Month of the year.
 *!   	@member int(0..) "year"
 *!   	  Year since 1900.
 *!   	@member int(-1..1) "isdst"
 *!   	  Is daylight-saving time active.  If omitted or set to @expr{-1@},
 *!       it means that the information is not available.
 *!   	@member int "timezone"
 *!   	  The timezone offset from UTC in seconds. If omitted, the time
 *!       will be calculated in the local timezone.
 *!   @endmapping
 *!
 *!   Or you can just send them all on one line as the second syntax suggests.
 *!
 *! @note
 *!   For proper UTC calculations ensure that @expr{isdst = 0@} @b{and@}
 *!   @expr{timezone = 0@}; omitting either one of these parameters
 *!   @b{will@} mess up the UTC calculation.
 *!
 *! @note
 *!   On some operating systems (notably AIX and Win32), dates before
 *!   00:00:00 UTC, Jan 1, 1970 are not supported.
 *!
 *!   On most 32-bit systems, the supported range of dates is from Dec 13, 1901
 *!   20:45:52 UTC through to Jan 19, 2038 03:14:07 UTC (inclusive).
 *!
 *!   On most 64-bit systems, the supported range of dates is expressed
 *!   in 56 bits and is thus practically
 *!   unlimited (at least up to 1141 milion years in the past
 *!   and into the future).
 *!
 *! @seealso
 *!   @[time()], @[ctime()], @[localtime()], @[gmtime()]
 */
PMOD_EXPORT void f_mktime (INT32 args)
{
  INT_TYPE sec, min, hour, mday, mon, year;
  INT_TYPE isdst = -1, tz = 0;
  struct tm date;
  time_t retval;
  int normalised_time;

  if (args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("mktime", 1);

  if(args == 1)
  {
    push_text("sec");
    push_text("min");
    push_text("hour");
    push_text("mday");
    push_text("mon");
    push_text("year");
    push_text("isdst");
    push_text("timezone");
    f_aggregate(8);
    f_rows(2);
    Pike_sp--;
    dmalloc_touch_svalue(Pike_sp);
    push_array_items(Pike_sp->u.array);

    args=8;
  }

  get_all_args("mktime",args, "%i%i%i%i%i%i.%i%i",
	       &sec, &min, &hour, &mday, &mon, &year, &isdst, &tz);

  memset(&date, 0, sizeof(date));
  date.tm_sec=sec;
  date.tm_min=min;
  date.tm_hour=hour;
  date.tm_mday=mday;
  date.tm_mon=mon;
  date.tm_year=year;
  date.tm_isdst=isdst;
  /* date.tm_zone = NULL; */

  retval = mktime_zone(&date,
                       args > 7 && SUBTYPEOF(Pike_sp[7-args]) == NUMBER_NUMBER,
	               tz);

  pop_n_elems(args);
#if SIZEOF_TIME_T > SIZEOF_INT_TYPE
  push_int64 (retval);
#else
  push_int(retval);
#endif
}

/* Common case: both strings are 8bit. */
static int does_match_8_8( const unsigned char *s, int j, int sl,
                          const unsigned char *m, int i, int ml)
{
  for (; i<ml; i++)
  {
    switch (m[i])
    {
     case '?':
       if(j++>=sl) return 0;
       break;

     case '*':
      while(m[i] == '*' && i<ml )
        i++;
      while( m[i] == '?' && i<ml && j<sl)
      {
        i++;
        j++;
      }
      if (i==ml) return 1;

      for (;j<sl;j++)
      {
        if( s[j] == m[i] &&
            does_match_8_8(s,j,sl,m,i,ml))
          return 1;
      }
      return 0;

     default:
         if(j>=sl || m[i] != s[j] )
             return 0;
         j++;
    }
  }
  return j==sl;
}

static int does_match_16_8( const unsigned short *s, int j, int sl,
                            const unsigned char *m, int i, int ml)
{
  for (; i<ml; i++)
  {
    switch (m[i])
    {
     case '?':
       if(j++>=sl) return 0;
       break;

     case '*':
      while(m[i] == '*' && i<ml )
        i++;
      while( m[i] == '?' && i<ml && j<sl)
      {
        i++;
        j++;
      }
      if (i==ml) return 1;

      for (;j<sl;j++)
      {
        if( s[j] == m[i] &&
            does_match_16_8(s,j,sl,m,i,ml))
          return 1;
      }
      return 0;

     default:
         if(j>=sl || m[i] != s[j] )
             return 0;
         j++;
    }
  }
  return j==sl;
}


/* Check if the string s[0..len[ matches the glob m[0..mlen[ */
static int does_match_x_x(struct pike_string *s,int j,
                          struct pike_string *m,int i)
{
  for (; i<m->len; i++)
  {
    switch (index_shared_string(m,i))
    {
     case '?':
       if(j++>=s->len) return 0;
       break;

     case '*': 
      i++;
      if (i==m->len) return 1;	/* slut */

      for (;j<s->len;j++)
	if (does_match_x_x(s,j,m,i))
	  return 1;

      return 0;

     default: 
       if(j>=s->len ||
	  index_shared_string(m,i)!=index_shared_string(s,j)) return 0;
       j++;
    }
  }
  return j==s->len;
}

static int does_match(struct pike_string *s,int j,
		      struct pike_string *m,int i)
{
    if( s->size_shift + m->size_shift == 0 )
      return does_match_8_8((const unsigned char*)s->str, j, s->len,
                           (const unsigned char*)m->str, i, m->len);
    if( s->size_shift==1 && m->size_shift == 0 )
      return does_match_16_8((const unsigned short*)s->str, j, s->len,
                             (const unsigned char*)m->str, i, m->len);
    return does_match_x_x( s,j,m,i );
}
/*! @decl int(0..1) glob(string glob, string str)
 *! @decl int(0..1) glob(array(string) glob, string str)
 *! @decl array(string) glob(string glob, array(string) str)
 *! @decl array(string) glob(array(string) glob, array(string) str)
 *!
 *! Match strings against a glob pattern.
 *!
 *! @param glob
 *!   @mixed
 *!    @type string 
 *!      The glob pattern. A question sign ('?') matches any character
 *!      and an asterisk ('*') matches a string of arbitrary length. All
 *!      other characters only match themselves.
 *!    @type array(string)
 *!      the function returns true, or keeps a string, if any of the given
 *!       patterns match
 *!  @endmixed
 *!
 *! @param str
 *!   @mixed
 *!     @type string
 *!       @expr{1@} is returned if the string @[str] matches @[glob],
 *!       @expr{0@} (zero) otherwise.
 *!
 *!     @type array(string)
 *!       All strings in the array @[str] are matched against @[glob],
 *!       and those that match are returned in an array (in the same
 *!       order).
 *!   @endmixed
 *!
 *! @seealso
 *!   @[sscanf()], @[Regexp]
 */

static int any_does_match( struct svalue *items, int nglobs, struct pike_string *str )
{
   INT32 i;
   for( i =0; i<nglobs; i++ )
   {
     struct pike_string *str2 = items[i].u.string;
     if( str == str2 )
       return 1;
     if( does_match(str,0,str2,0) )
       return 1;
   }
   return 0;
} 

PMOD_EXPORT void f_glob(INT32 args)
{
  INT32 i;
  struct array *a;
  struct svalue *glob;
  int nglobs;

  if(args < 2)
    SIMPLE_TOO_FEW_ARGS_ERROR("glob", 2);

  if(args > 2)
    pop_n_elems(args-2);
  args=2;

  if (TYPEOF(Pike_sp[-args]) == T_STRING)
  {
      glob=Pike_sp-args;
      nglobs = 1;
  }
  else if( TYPEOF(Pike_sp[-args]) == PIKE_T_ARRAY)
  {
      struct array *ga = Pike_sp[-args].u.array;
      glob = ga->item;
      nglobs = ga->size;
      for( i=0; i<nglobs; i++ )
	  if( TYPEOF(ga->item[i]) != PIKE_T_STRING )
              SIMPLE_BAD_ARG_ERROR("glob", 1, "string|array(string)");
  }
  else
      SIMPLE_BAD_ARG_ERROR("glob", 1, "string|array(string)");


  switch(TYPEOF(Pike_sp[1-args]))
  {
  case T_STRING:
      i = any_does_match(glob,nglobs,Pike_sp[1-args].u.string);
      pop_n_elems(2);
      push_int(i);
   break;
    
  case T_ARRAY: {
    INT32 j;
    unsigned matches = 0;
    struct svalue *res;
    a=Pike_sp[1-args].u.array;

    if( (a->type_field & ~BIT_STRING) &&
	(array_fix_type_field(a) & ~BIT_STRING) )
      SIMPLE_BAD_ARG_ERROR("glob", 2, "string|array(string)");

    check_stack(120);
    BEGIN_AGGREGATE_ARRAY (MINIMUM (a->size, 120)) {
      res = Pike_sp - 1;

      for(i=0;i<a->size;i++)
      {
        if(any_does_match(glob,nglobs,ITEM(a)[i].u.string) )
	{
	  matches++;
	  ref_push_string(ITEM(a)[i].u.string);
	  DO_AGGREGATE_ARRAY (120);
	}
      }
      /* We know what this array contains - avoid array_fix_type_field
       * in END_AGGREGATE_ARRAY. */
      res->u.array->type_field = matches ? BIT_STRING : 0;
    } END_AGGREGATE_ARRAY;

    stack_pop_n_elems_keep_top (2);
    break;
  }

  default:
    SIMPLE_BAD_ARG_ERROR("glob", 2, "string|array(string)");
  }
}

/* comb_merge */

/*! @module Array
 */

/*! @decl array(int) interleave_array(array(mapping(int:mixed)) tab)
 *!
 *!   Interleave a sparse matrix.
 *!
 *!   Returns an array with offsets that describe how to shift the
 *!   rows of @[tab] so that only at most one non-zero value exists in
 *!   every column.
 */
static void f_interleave_array(INT32 args)
{
  struct array *arr = NULL;
  struct array *min = NULL;
  struct array *order = NULL;
  int max = 0;
  int nelems = 0;
  int i;

  get_all_args("interleave_array", args, "%a", &arr);

  /* We're not interrested in any other arguments. */
  pop_n_elems(args-1);

  if( (arr->type_field & ~BIT_MAPPING) &&
      (array_fix_type_field(arr) & ~BIT_MAPPING) )
    SIMPLE_BAD_ARG_ERROR("interleave_array", 1, "array(mapping(int:mixed))");

  /* The order array */
  ref_push_array(arr);
  f_indices(1);
  order = Pike_sp[-1].u.array;

  /* The min array */
  push_array(min = allocate_array(arr->size));

  /* Initialize the min array */
  for (i = 0; i < arr->size; i++) {
    struct mapping_data *md;
    /* e and k are used by NEW_MAPPING_LOOP() */
    INT32 e;
    struct keypair *k;
    INT_TYPE low = MAX_INT_TYPE;
#ifdef PIKE_DEBUG
    if (TYPEOF(ITEM(arr)[i]) != T_MAPPING) {
      Pike_error("Element %d is not a mapping!\n", i);
    }
#endif /* PIKE_DEBUG */
    md = ITEM(arr)[i].u.mapping->data;
    NEW_MAPPING_LOOP(md) {
      if (TYPEOF(k->ind) != T_INT) {
	Pike_error("Index not an integer in mapping %d!\n", i);
      }
      if (low > k->ind.u.integer) {
	low = k->ind.u.integer;
	if (low < 0) {
	  Pike_error("Index %"PRINTPIKEINT"d in mapping %d is negative!\n",
		low, i);
	}
      }
      if (max < k->ind.u.integer) {
	max = k->ind.u.integer;
      }
      nelems++;
    }
    ITEM(min)[i].u.integer = low;
  }

  min->type_field = BIT_INT;
  ref_push_array(order);
  f_sort(2);	/* Sort the order array on the minimum index */

  /* State on stack now:
   *
   * array(mapping(int:mixed))	arr
   * array(int)			order
   * array(int)			min (now sorted)
   */

  /* Now we can start with the real work... */
  {
    char *tab;
    int size;
    int minfree = 0;

    /* Initialize the lookup table */
    max += 1;
    max *= 2;
    /* max will be the padding at the end. */
    size = (nelems + max) * 8;	/* Initial size */
    if (!(tab = malloc(size + max))) {
      SIMPLE_OUT_OF_MEMORY_ERROR("interleave_array", size+max);
    }
    memset(tab, 0, size + max);

    for (i = 0; i < order->size; i++) {
      int low = ITEM(min)[i].u.integer;
      int j = ITEM(order)[i].u.integer;
      int offset = 0;
      int ok = 0;
      struct mapping *m;
      struct mapping_data *md;
      INT32 e;
      struct keypair *k;

      if (! m_sizeof(m = ITEM(arr)[j].u.mapping)) {
	/* Not available */
	ITEM(min)[i].u.integer = -1;
	continue;
      }

      if (low < minfree) {
	offset = minfree - low;
      } else {
	minfree = offset;
      }

      md = m->data;
      while (!ok) {
	ok = 1;
	NEW_MAPPING_LOOP(md) {
	  int ind = k->ind.u.integer;
	  if (tab[offset + ind]) {
	    ok = 0;
	    while (tab[++offset + ind])
	      ;
	  }
	}
      }
      NEW_MAPPING_LOOP(md) {
	tab[offset + k->ind.u.integer] = 1;
      }
      while(tab[minfree]) {
	minfree++;
      }
      ITEM(min)[i].u.integer = offset;

      /* Check need for realloc */
      if (offset >= size) {
	char *newtab = realloc(tab, size*2 + max);
	if (!newtab) {
	  free(tab);
	  Pike_error("Couldn't extend table!\n");
	}
	tab = newtab;
	memset(tab + size + max, 0, size);
	size = size * 2;
      }
    }
    free(tab);
  }

  /* We want these two to survive the stackpopping. */
  add_ref(min);
  add_ref(order);

  pop_n_elems(3);

  /* Return value */
  ref_push_array(min);

  /* Restore the order */
  push_array(order);
  push_array(min);
  f_sort(2);
  pop_stack();
}

/* longest_ordered_sequence */

static int find_gt(struct array *a, int i, int *stack, int top)
{
  struct svalue *x = a->item + i;
  int l,h;

  /* FIXME: Should it perhaps be is_ge below instead? */
  if (!top || !is_lt(x, a->item + stack[top - 1])) return top;

  l = 0;
  h = top;

  while (l < h) {
    int middle = (l + h)/2;
    if (!is_gt(a->item + stack[middle], x)) {
      l = middle+1;
    } else {
      h = middle;
    }
  }
  return l;
}

static struct array *longest_ordered_sequence(struct array *a)
{
  int *stack;
  int *links;
  int i, top=0, ltop=-1;
  struct array *res;
  ONERROR tmp;
  ONERROR tmp2;

  if(!a->size)
    return allocate_array(0);

  stack = malloc(sizeof(int)*a->size);
  links = malloc(sizeof(int)*a->size);

  if (!stack || !links)
  {
    if (stack) free(stack);
    if (links) free(links);
    return 0;
  }

  /* is_gt(), is_lt() and low_allocate_array() can generate errors. */

  SET_ONERROR(tmp, free, stack);
  SET_ONERROR(tmp2, free, links);

  for (i=0; i<a->size; i++) {
    int pos;

    pos = find_gt(a, i, stack, top);

    if (pos == top) {
      top++;
      ltop = i;
    }
    if (pos != 0)
      links[i] = stack[pos-1];
    else
      links[i] = -1;
    stack[pos] = i;
  }

  /* FIXME(?) memory unfreed upon error here */
  res = low_allocate_array(top, 0); 
  while (ltop != -1)
  {
    ITEM(res)[--top].u.integer = ltop;
    ltop = links[ltop];
  }
  res->type_field = BIT_INT;

  UNSET_ONERROR(tmp2);
  UNSET_ONERROR(tmp);

  free(stack);
  free(links);
  return res;
}

/*! @decl array(int) longest_ordered_sequence(array a)
 *!
 *!   Find the longest ordered sequence of elements.
 *!
 *!   This function returns an array of the indices in the longest
 *!   ordered sequence of elements in the array.
 *!
 *! @seealso
 *!   @[diff()]
 */
static void f_longest_ordered_sequence(INT32 args)
{
  struct array *a = NULL;
  struct array *aa = NULL;

  get_all_args("longest_ordered_sequence", args, "%a", &a);

  /* THREADS_ALLOW(); */

  aa = longest_ordered_sequence(a);

  /* THREADS_DISALLOW(); */

  if (!aa) {
    SIMPLE_OUT_OF_MEMORY_ERROR("longest_ordered_sequence",
			       (int)sizeof(int *)*a->size*2);
  }

  pop_n_elems(args);
  push_array(aa);
}

/**** diff ************************************************************/

static struct array* diff_compare_table(struct array *a,struct array *b,int *u)
{
   struct array *res;
   struct mapping *map;
   struct svalue *pval;
   int i;
   TYPE_FIELD types;

   if (u) {
     *u = 0;	/* Unique rows in array b */
   }

   map=allocate_mapping(256);
   push_mapping(map); /* in case of out of memory */

   for (i=0; i<b->size; i++)
   {
      pval=low_mapping_lookup(map,b->item+i);
      if (!pval)
      {
	 struct svalue val;
	 SET_SVAL(val, T_ARRAY, 0, array, low_allocate_array(1,1));
	 ITEM(val.u.array)[0].u.integer=i;
	 val.u.array->type_field = BIT_INT;
	 mapping_insert(map,ITEM(b)+i,&val);
	 free_svalue(&val);
	 if (u) {
	   (*u)++;
	 }
      }
      else
      {
	struct array *a = pval->u.array=
	  resize_array(pval->u.array,pval->u.array->size+1);
	struct svalue *s = ITEM(a) + pval->u.array->size-1;
	SET_SVAL(*s, T_INT, NUMBER_NUMBER, integer, i);
      }
   }

   res=low_allocate_array(a->size,0);
   types = 0;

   for (i=0; i<a->size; i++)
   {
      pval=low_mapping_lookup(map,a->item+i);
      if (!pval)
      {
	 SET_SVAL(ITEM(res)[i], T_ARRAY, 0, array, &empty_array);
	 add_ref(&empty_array);
	 types |= BIT_ARRAY;
      }
      else
      {
	 assign_svalue(ITEM(res)+i,pval);
	 types |= 1 << TYPEOF(ITEM(res)[i]);
      }
   }

   res->type_field = types;
   pop_stack();
   return res;
}

struct diff_magic_link
{ 
   int x;
   int refs;
   struct diff_magic_link *prev;
};

struct diff_magic_link_pool
{
   struct diff_magic_link *firstfree;
   struct diff_magic_link_pool *next;
   int firstfreenum;
   struct diff_magic_link dml[1];
};

struct diff_magic_link_head
{
  unsigned int depth;
  struct diff_magic_link *link;
};

#define DMLPOOLSIZE 16384

static int dmls=0;

static INLINE struct diff_magic_link_pool*
         dml_new_pool(struct diff_magic_link_pool **pools)
{
   struct diff_magic_link_pool *new;

   new=malloc(sizeof(struct diff_magic_link_pool)+
	      sizeof(struct diff_magic_link)*DMLPOOLSIZE);
   if (!new) return NULL; /* fail */

   new->firstfreenum=0;
   new->firstfree=NULL;
   new->next=*pools;
   *pools=new;
   return *pools;
}

static INLINE struct diff_magic_link* 
       dml_new(struct diff_magic_link_pool **pools)
{
   struct diff_magic_link *new;
   struct diff_magic_link_pool *pool;

   dmls++;

   if ( *pools && (new=(*pools)->firstfree) )
   {
      (*pools)->firstfree=new->prev;
      new->prev=NULL;
      return new;
   }

   pool=*pools;
   while (pool)
   {
      if (pool->firstfreenum<DMLPOOLSIZE)
	 return pool->dml+(pool->firstfreenum++);
      pool=pool->next;
   }

   if ( (pool=dml_new_pool(pools)) )
   {
      pool->firstfreenum=1;
      return pool->dml;
   }
   
   return NULL;
}	

static INLINE void dml_free_pools(struct diff_magic_link_pool *pools)
{
   struct diff_magic_link_pool *pool;

   while (pools)
   {
      pool=pools->next;
      free(pools);
      pools=pool;
   }
}

static INLINE void dml_delete(struct diff_magic_link_pool *pools,
			      struct diff_magic_link *dml)
{
  struct diff_magic_link *prev;
  while(1)
  {
    prev=dml->prev;
    dmls--;
    dml->prev=pools->firstfree;
    pools->firstfree=dml;
    if (prev && !--prev->refs)
      dml=prev;
    else
      break;
  }
}

static INLINE int diff_ponder_stack(int x,
				    struct diff_magic_link **dml,
				    int top)
{
   int middle,a,b;
   
   a=0; 
   b=top;
   while (b>a)
   {
      middle=(a+b)/2;
      if (dml[middle]->x<x) a=middle+1;
      else if (dml[middle]->x>x) b=middle;
      else return middle;
   }
   if (a<top && dml[a]->x<x) a++;
   return a;
}

static INLINE int diff_ponder_array(int x,
				    struct svalue *arr,
				    int top)
{
   int middle,a,b;
   
   a=0; 
   b=top;
   while (b>a)
   {
      middle=(a+b)/2;
      if (arr[middle].u.integer<x) a=middle+1;
      else if (arr[middle].u.integer>x) b=middle;
      else return middle;
   }
   if (a<top && arr[a].u.integer<x) a++;
   return a;
}

/*
 * The Grubba-Mirar Longest Common Sequence algorithm.
 *
 * This algorithm is O((Na * Nb / K)*lg(Na * Nb / K)), where:
 *
 *  Na == sizeof(a)
 *  Nb == sizeof(b)
 *  K  == sizeof(correlation(a,b))
 *
 * For binary data:
 *  K == 256 => O(Na * Nb * lg(Na * Nb)),
 *  Na ~= Nb ~= N => O(N² * lg(N))
 *
 * For ascii data:
 *  K ~= C * min(Na, Nb), C constant => O(max(Na, Nb)*lg(max(Na,Nb))),
 *  Na ~= Nb ~= N => O(N * lg(N))
 *
 * diff_longest_sequence() takes two arguments:
 *  cmptbl == diff_compare_table(a, b)
 *  blen == sizeof(b) >= max(@(cmptbl*({})))
 */
static struct array *diff_longest_sequence(struct array *cmptbl, int blen)
{
   int i,j,top=0;
   struct array *a;
   struct diff_magic_link_pool *pools=NULL;
   struct diff_magic_link *dml;
   struct diff_magic_link **stack;
   char *marks;

   if(!cmptbl->size)
     return allocate_array(0);

   stack = malloc(sizeof(struct diff_magic_link*)*cmptbl->size);

   if (!stack) {
     int args = 0;
     SIMPLE_OUT_OF_MEMORY_ERROR("diff_longest_sequence",
				(int)sizeof(struct diff_magic_link*) *
				cmptbl->size);
   }

   /* NB: marks is used for optimization purposes only */
   marks = calloc(blen, 1);

   if (!marks && blen) {
     int args = 0;
     free(stack);
     SIMPLE_OUT_OF_MEMORY_ERROR("diff_longest_sequence", blen);
   }

#ifdef DIFF_DEBUG
   fprintf(stderr, "\n\nDIFF: sizeof(cmptbl)=%d, blen=%d\n",
	   cmptbl->size, blen);
#endif /* DIFF_DEBUG */

   for (i = 0; i<cmptbl->size; i++)
   {
      struct svalue *inner=cmptbl->item[i].u.array->item;

#ifdef DIFF_DEBUG
      fprintf(stderr, "DIFF: i=%d\n", i);
#endif /* DIFF_DEBUG */

      for (j = cmptbl->item[i].u.array->size; j--;)
      {
	 int x = inner[j].u.integer;

#ifdef DIFF_DEBUG
	 fprintf(stderr, "DIFF:  j=%d, x=%d\n", j, x);
#endif /* DIFF_DEBUG */
#ifdef PIKE_DEBUG
	 if (x >= blen) {
	   Pike_fatal("diff_longest_sequence(): x:%d >= blen:%d\n", x, blen);
	 } else if (x < 0) {
	   Pike_fatal("diff_longest_sequence(): x:%d < 0\n", x);
	 }
#endif /* PIKE_DEBUG */
	 if (!marks[x]) {
	   int pos;

	   if (top && x<=stack[top-1]->x) {
	     /* Find the insertion point. */
	     pos = diff_ponder_stack(x, stack, top);
	     if (pos != top) {
	       /* Not on the stack anymore. */
	       marks[stack[pos]->x] = 0;
	     }
	   } else
	     pos=top;

#ifdef DIFF_DEBUG
	   fprintf(stderr, "DIFF:  pos=%d\n", pos);
#endif /* DIFF_DEBUG */

	   /* This part is only optimization (j accelleration). */
	   if (pos && j)
	   {
	     if (!marks[inner[j-1].u.integer])
	     {
	       /* Find the element to insert. */
	       j = diff_ponder_array(stack[pos-1]->x+1, inner, j);
	       x = inner[j].u.integer;
	     }
	   }
	   else
	   {
	     j = 0;
	     x = inner->u.integer;
	   }

#ifdef DIFF_DEBUG
	   fprintf(stderr, "DIFF: New j=%d, x=%d\n", j, x);
#endif /* DIFF_DEBUG */
#ifdef PIKE_DEBUG
	   if (x >= blen) {
	     Pike_fatal("diff_longest_sequence(): x:%d >= blen:%d\n", x, blen);
	   } else if (x < 0) {
	     Pike_fatal("diff_longest_sequence(): x:%d < 0\n", x);
	   }
#endif /* PIKE_DEBUG */

	   /* Put x on the stack. */
	   marks[x] = 1;
	   if (pos == top)
	   {
#ifdef DIFF_DEBUG
	     fprintf(stderr, "DIFF:  New top element\n");
#endif /* DIFF_DEBUG */

	     if (! (dml=dml_new(&pools)) )
	     {
	       int args = 0;
	       dml_free_pools(pools);
	       free(stack);
	       SIMPLE_OUT_OF_MEMORY_ERROR("diff_longest_sequence",
					  sizeof(struct diff_magic_link_pool) +
					  sizeof(struct diff_magic_link) *
					  DMLPOOLSIZE);
	     }

	     dml->x = x;
	     dml->refs = 1;

	     if (pos)
	       (dml->prev = stack[pos-1])->refs++;
	     else
	       dml->prev = NULL;

	     top++;
	    
	     stack[pos] = dml;
	   } else if (pos && 
		      stack[pos]->refs == 1 &&
		      stack[pos-1] == stack[pos]->prev)
	   {
#ifdef DIFF_DEBUG
	     fprintf(stderr, "DIFF:  Optimized case\n");
#endif /* DIFF_DEBUG */

	     /* Optimization. */
	     stack[pos]->x = x;
	   } else {
#ifdef DIFF_DEBUG
	     fprintf(stderr, "DIFF:  Generic case\n");
#endif /* DIFF_DEBUG */

	     if (! (dml=dml_new(&pools)) )
	     {
	       int args = 0;
	       dml_free_pools(pools);
	       free(stack);
	       SIMPLE_OUT_OF_MEMORY_ERROR("diff_longest_sequence",
					  sizeof(struct diff_magic_link_pool) +
					  sizeof(struct diff_magic_link) *
					  DMLPOOLSIZE);
	     }

	     dml->x = x;
	     dml->refs = 1;

	     if (pos)
	       (dml->prev = stack[pos-1])->refs++;
	     else
	       dml->prev = NULL;

	     if (!--stack[pos]->refs)
	       dml_delete(pools, stack[pos]);
	    
	     stack[pos] = dml;
	   }
#ifdef DIFF_DEBUG
	 } else {
	   fprintf(stderr, "DIFF:  Already marked (%d)!\n", marks[x]);
#endif /* DIFF_DEBUG */
	 }
      }
#ifdef DIFF_DEBUG
      for(j=0; j < top; j++) {
	fprintf(stderr, "DIFF:  stack:%d, mark:%d\n",
		stack[j]->x, marks[stack[j]->x]);
      }
#endif /* DIFF_DEBUG */
   }

   /* No need for marks anymore. */

   free(marks);

   /* FIXME(?) memory unfreed upon error here. */
   a=low_allocate_array(top,0); 
   if (top)
   {
       dml=stack[top-1];
       while (dml)
       {
	  ITEM(a)[--top].u.integer=dml->x;
	  dml=dml->prev;
       }
       a->type_field = BIT_INT;
   }

   free(stack);
   dml_free_pools(pools);
   return a;
}

/*
 * The dynamic programming Longest Common Sequence algorithm.
 *
 * This algorithm is O(Na * Nb), where:
 *
 *  Na == sizeof(a)
 *  Nb == sizeof(b)
 *
 * This makes it faster than the G-M algorithm on binary data,
 * but slower on ascii data.
 *
 * NOT true! The G-M algorithm seems to be faster on most data anyway.
 *	/grubba 1998-05-19
 */
static struct array *diff_dyn_longest_sequence(struct array *cmptbl, int blen)
{
  struct array *res = NULL;
  struct diff_magic_link_head *table;
  struct diff_magic_link_pool *dml_pool = NULL;
  struct diff_magic_link *dml;
  unsigned int sz = (unsigned int)cmptbl->size;
  unsigned int i;
  unsigned int off1 = 0;
  unsigned int off2 = blen + 1;
  ONERROR err;

  table = calloc(sizeof(struct diff_magic_link_head)*2, off2);
  if (!table) {
    int args = 0;
    SIMPLE_OUT_OF_MEMORY_ERROR("diff_dyn_longest_sequence",
			       sizeof(struct diff_magic_link_head) * 2 * off2);
  }

  /* FIXME: Assumes NULL is represented with all zeroes */
  /* NOTE: Scan strings backwards to get the same result as the G-M
   * algorithm.
   */
  for (i = sz; i--;) {
    struct array *boff = cmptbl->item[i].u.array;

#ifdef DIFF_DEBUG
    fprintf(stderr, "  i:%d\n", i);
#endif /* DIFF_DEBUG */

    if (boff->size) {
      unsigned int bi;
      unsigned int base = blen;
      unsigned int tmp = off1;
      off1 = off2;
      off2 = tmp;

      for (bi = boff->size; bi--;) {
	unsigned int ib = boff->item[bi].u.integer;

#ifdef DIFF_DEBUG
	fprintf(stderr, "    Range [%d - %d] differ\n", base - 1, ib + 1);
#endif /* DIFF_DEBUG */
	while ((--base) > ib) {
	  /* Differ */
	  if (table[off1 + base].link) {
	    if (!--(table[off1 + base].link->refs)) {
	      dml_delete(dml_pool, table[off1 + base].link);
	    }
	  }
	  /* FIXME: Should it be > or >= here to get the same result
	   * as with the G-M algorithm?
	   */
	  if (table[off2 + base].depth > table[off1 + base + 1].depth) {
	    table[off1 + base].depth = table[off2 + base].depth;
	    dml = (table[off1 + base].link = table[off2 + base].link);
	  } else {
	    table[off1 + base].depth = table[off1 + base + 1].depth;
	    dml = (table[off1 + base].link = table[off1 + base + 1].link);
	  }
	  if (dml) {
	    dml->refs++;
	  }
	}
	/* Equal */
#ifdef DIFF_DEBUG
	fprintf(stderr, "    Equal\n");
#endif /* DIFF_DEBUG */

	if (table[off1 + ib].link) {
	  if (!--(table[off1 + ib].link->refs)) {
	    dml_delete(dml_pool, table[off1 + ib].link);
	  }
	}
	table[off1 + ib].depth = table[off2 + ib + 1].depth + 1;
	dml = (table[off1 + ib].link = dml_new(&dml_pool));
	if (!dml) {
	  int args = 0;
	  dml_free_pools(dml_pool);
	  free(table);
	  SIMPLE_OUT_OF_MEMORY_ERROR("diff_dyn_longest_sequence",
				     sizeof(struct diff_magic_link_pool) +
				     sizeof(struct diff_magic_link) *
				     DMLPOOLSIZE);
	}
	dml->refs = 1;
	dml->prev = table[off2 + ib + 1].link;
	if (dml->prev) {
	  dml->prev->refs++;
	}
	dml->x = ib;
      }
#ifdef DIFF_DEBUG
      fprintf(stderr, "    Range [0 - %d] differ\n", base-1);
#endif /* DIFF_DEBUG */
      while (base--) {
	/* Differ */
	if (table[off1 + base].link) {
	  if (!--(table[off1 + base].link->refs)) {
	    dml_delete(dml_pool, table[off1 + base].link);
	  }
	}
	/* FIXME: Should it be > or >= here to get the same result
	 * as with the G-M algorithm?
	 */
	if (table[off2 + base].depth > table[off1 + base + 1].depth) {
	  table[off1 + base].depth = table[off2 + base].depth;
	  dml = (table[off1 + base].link = table[off2 + base].link);
	} else {
	  table[off1 + base].depth = table[off1 + base + 1].depth;
	  dml = (table[off1 + base].link = table[off1 + base + 1].link);
	}
	if (dml) {
	  dml->refs++;
	}
      }
    }
  }

  /* Convert table into res */
  sz = table[off1].depth;
  dml = table[off1].link;
  free(table);
#ifdef DIFF_DEBUG
  fprintf(stderr, "Result array size:%d\n", sz);
#endif /* DIFF_DEBUG */

  if(dml_pool) SET_ONERROR(err, dml_free_pools, dml_pool);
  res = allocate_array(sz);
  if(dml_pool) UNSET_ONERROR(err);

  i = 0;
  while(dml) {
#ifdef PIKE_DEBUG
    if (i >= sz) {
      Pike_fatal("Consistency error in diff_dyn_longest_sequence()\n");
    }
#endif /* PIKE_DEBUG */
#ifdef DIFF_DEBUG
    fprintf(stderr, "  %02d: %d\n", i, dml->x);
#endif /* DIFF_DEBUG */
    res->item[i].u.integer = dml->x;
    dml = dml->prev;
    i++;
  }
  res->type_field = BIT_INT;
#ifdef PIKE_DEBUG
  if (i != sz) {
    Pike_fatal("Consistency error in diff_dyn_longest_sequence()\n");
  }
#endif /* PIKE_DEBUG */

  dml_free_pools(dml_pool);
  return(res);
}

static struct array* diff_build(struct array *a,
				struct array *b,
				struct array *seq)
{
   struct array *ad,*bd;
   ptrdiff_t bi, ai, lbi, lai, i, eqstart;

   /* FIXME(?) memory unfreed upon error here (and later) */
   ad=low_allocate_array(0,32);
   bd=low_allocate_array(0,32);
   
   eqstart=0;
   lbi=bi=ai=-1;
   for (i=0; i<seq->size; i++)
   {
      bi=seq->item[i].u.integer;

      if (bi!=lbi+1 || !is_equal(a->item+ai+1,b->item+bi))
      {
	 /* insert the equality */
	 if (lbi>=eqstart)
	 {
	    push_array(friendly_slice_array(b,eqstart,lbi+1));
	    ad=append_array(ad,Pike_sp-1);
	    bd=append_array(bd,Pike_sp-1);
	    pop_stack();
	 }
	 /* insert the difference */
	 lai=ai;
	 ai=array_search(a,b->item+bi,ai+1)-1;

	 push_array(friendly_slice_array(b,lbi+1,bi));
	 bd=append_array(bd, Pike_sp-1);
	 pop_stack();

	 push_array(friendly_slice_array(a,lai+1,ai+1));
	 ad=append_array(ad,Pike_sp-1);
	 pop_stack();

	 eqstart=bi;
      }
      ai++;
      lbi=bi;
   }

   if (lbi>=eqstart)
   {
      push_array(friendly_slice_array(b,eqstart,lbi+1));
      ad=append_array(ad,Pike_sp-1);
      bd=append_array(bd,Pike_sp-1);
      pop_stack();
   }

   if (b->size>bi+1 || a->size>ai+1)
   {
      push_array(friendly_slice_array(b,lbi+1,b->size));
      bd=append_array(bd, Pike_sp-1);
      pop_stack();
      
      push_array(friendly_slice_array(a,ai+1,a->size));
      ad=append_array(ad,Pike_sp-1);
      pop_stack();
   }

   push_array(ad);
   push_array(bd);
   return aggregate_array(2);
}

/*! @decl array permute(array in, int(0..) number)
 *!
 *!   Give a specified permutation of an array.
 *!
 *!   The number of permutations is equal to @expr{sizeof(@[in])!@}
 *!   (the factorial of the size of the given array).
 *!
 *! @seealso
 *!   @[shuffle()]
 */
PMOD_EXPORT void f_permute( INT32 args )
{
  INT_TYPE q, i=0, n;
  struct array *a;
  struct svalue *it;

  if( args != 2 )
    SIMPLE_TOO_FEW_ARGS_ERROR("permute", 2);
  if( TYPEOF(Pike_sp[ -2 ]) != T_ARRAY )
     SIMPLE_BAD_ARG_ERROR("permute", 1, "array");
  if (TYPEOF(Pike_sp[ -1 ]) != T_INT)
    SIMPLE_BAD_ARG_ERROR("permute", 2, "int");

  n  = Pike_sp[ -1 ].u.integer;
  if( n<0 ) Pike_error("Only positive permutations are allowed.\n");
  a = copy_array( Pike_sp[ -2 ].u.array );
  pop_n_elems( args );
  q = a->size;
  it = a->item;
  while( n && q )
  {
    int x = n % q;
    n /= q;
    q--;
    if( x )
    {
      struct svalue tmp;
      tmp     = it[i];
      it[i]   = it[i+x];
      it[i+x] = tmp;
    }
    i++;
  }
  push_array( a );
}

/*! @decl array(array(array)) diff(array a, array b)
 *!
 *!   Calculates which parts of the arrays that are common to both, and
 *!   which parts that are not.
 *!
 *! @returns
 *!   Returns an array with two elements, the first is an array of parts in
 *!   array @[a], and the second is an array of parts in array @[b].
 *!
 *! @seealso
 *!   @[diff_compare_table()], @[diff_longest_sequence()],
 *!   @[String.fuzzymatch()]
 */
PMOD_EXPORT void f_diff(INT32 args)
{
   struct array *seq;
   struct array *cmptbl;
   struct array *diff;
   struct array *a, *b;
   int uniq;

   get_all_args("diff", args, "%a%a", &a, &b);

   if ((a == b) || !a->size || !b->size) {
     if (!a->size && !b->size) {
       /* Both arrays are empty. */
       ref_push_array(a);
       ref_push_array(b);
       f_aggregate(2);
     } else {
       /* The arrays are equal or one of them is empty. */
       ref_push_array(a);
       f_aggregate(1);
       ref_push_array(b);
       f_aggregate(1);
       f_aggregate(2);
     }
     stack_pop_n_elems_keep_top(args);
     return;
   }

   cmptbl = diff_compare_table(a, b, &uniq);

   push_array(cmptbl);
#ifdef ENABLE_DYN_DIFF
   if (uniq * 100 > cmptbl->size) {
#endif /* ENABLE_DYN_DIFF */
#ifdef DIFF_DEBUG
     fprintf(stderr, "diff: Using G-M algorithm, u:%d, s:%d\n",
	     uniq, cmptbl->size);
#endif /* DIFF_DEBUG */
     seq = diff_longest_sequence(cmptbl, b->size);
#ifdef ENABLE_DYN_DIFF
   } else {
#ifdef DIFF_DEBUG
     fprintf(stderr, "diff: Using dyn algorithm, u:%d, s:%d\n",
	     uniq, cmptbl->size);
#endif /* DIFF_DEBUG */
     seq = diff_dyn_longest_sequence(cmptbl, b->size);
   }     
#endif /* ENABLE_DYN_DIFF */
   push_array(seq);
   
   diff=diff_build(a,b,seq);

   pop_n_elems(2+args);
   push_array(diff);
}

/*! @decl array(array(int)) diff_compare_table(array a, array b)
 *!
 *!   Returns an array which maps from index in @[a] to corresponding
 *!   indices in @[b].
 *!
 *! @pre{
 *! > Array.diff_compare_table( ({ "a","b","c" }), ({ "b", "b", "c", "d", "b" }));
 *! Result: ({
 *!             ({ }),
 *!             ({
 *!                 0,
 *!                 1,
 *!                 4
 *!             }),
 *!             ({
 *!                 2
 *! 	        })
 *!         })
 *! @}
 *!
 *! @seealso
 *!   @[diff()], @[diff_longest_sequence()], @[String.fuzzymatch()]
 */
PMOD_EXPORT void f_diff_compare_table(INT32 args)
{
  struct array *a;
  struct array *b;
  struct array *cmptbl;

  get_all_args("diff_compare_table", args, "%a%a", &a, &b);

  cmptbl = diff_compare_table(a, b, NULL);

  pop_n_elems(args);
  push_array(cmptbl);
}

/*! @decl array(int) diff_longest_sequence(array a, array b)
 *!
 *!   Gives the longest sequence of indices in @[b] that have corresponding
 *!   values in the same order in @[a].
 *!
 *! @seealso
 *!   @[diff()], @[diff_compare_table()], @[String.fuzzymatch()]
 */
PMOD_EXPORT void f_diff_longest_sequence(INT32 args)
{
  struct array *a;
  struct array *b;
  struct array *seq;
  struct array *cmptbl;

  get_all_args("diff_longest_sequence", args, "%a%a", &a, &b);

  cmptbl = diff_compare_table(a, b, NULL);

  push_array(cmptbl);

  seq = diff_longest_sequence(cmptbl, b->size);

  pop_n_elems(args+1);
  push_array(seq); 
}

/*! @decl array(int) diff_dyn_longest_sequence(array a, array b)
 *!
 *!   Gives the longest sequence of indices in @[b] that have corresponding
 *!   values in the same order in @[a].
 *!
 *!   This function performs the same operation as @[diff_longest_sequence()],
 *!   but uses a different algorithm, which in some rare cases might be faster
 *!   (usually it's slower though).
 *!
 *! @seealso
 *!   @[diff_longest_sequence()], @[diff()], @[diff_compare_table()],
 *!   @[String.fuzzymatch()]
 */
PMOD_EXPORT void f_diff_dyn_longest_sequence(INT32 args)
{
  struct array *a;
  struct array *b;
  struct array *seq;
  struct array *cmptbl;

  get_all_args("diff_dyn_longest_sequence", args, "%a%a", &a, &b);

  cmptbl=diff_compare_table(a, b, NULL);

  push_array(cmptbl);

  seq = diff_dyn_longest_sequence(cmptbl, b->size);

  pop_n_elems(args+1);
  push_array(seq); 
}

/*! @endmodule
 */

/**********************************************************************/

static struct callback_list memory_usage_callback;

struct callback *add_memory_usage_callback(callback_func call,
					  void *arg,
					  callback_func free_func)
{
  return add_to_callback(&memory_usage_callback, call, arg, free_func);
}

/*! @decl mapping(string:int) memory_usage()
 *! @belongs Debug
 *!
 *!   Check memory usage.
 *!
 *!   This function is mostly intended for debugging. It delivers a mapping
 *!   with information about how many arrays/mappings/strings etc. there
 *!   are currently allocated and how much memory they use.
 *!
 *!   The entries in the mapping are typically paired, with one
 *!   named @expr{"num_" + SYMBOL + "s"@} containing a count,
 *!   and the other named @expr{SYMBOL + "_bytes"@} containing
 *!   a best effort approximation of the size in bytes.
 *!
 *! @note
 *!   Exactly what fields this function returns is version dependant.
 *!
 *! @seealso
 *!   @[_verify_internals()]
 */
PMOD_EXPORT void f__memory_usage(INT32 args)
{
  size_t num,size;
  struct svalue *ss;
#ifdef USE_DL_MALLOC
  struct mallinfo mi = dlmallinfo();
#elif HAVE_MALLINFO2
  struct mallinfo2 mi = mallinfo2();
#elif HAVE_MALLINFO
  struct mallinfo mi = mallinfo();
#endif

  pop_n_elems(args);
  ss=Pike_sp;

  /* TODO: If USE_DL_MALLOC is defined then this will report the
   * statistics from our bundled Doug Lea malloc, and not the
   * underlying system malloc. Ideally we should include both. */

#if defined(HAVE_MALLINFO2) || defined(HAVE_MALLINFO) || defined(USE_DL_MALLOC)

  push_text("num_malloc_blocks");
  push_ulongest(1 + mi.hblks);	/* 1 for the arena. */
  push_text("malloc_block_bytes");
#ifdef HAVE_MALLINFO2
  size = mi.arena + mi.hblkhd;
#else
  if (mi.arena < 0) {
    /* Kludge for broken Linux libc, where the fields are ints.
     *
     * 31-bit overflow, so perform an unsigned read.
     */
    size = (unsigned int)mi.arena;
  } else {
    /* On Solaris the fields are unsigned long (and may thus be 64-bit). */
    size = mi.arena;
  }
  /* NB: Kludge for glibc: hblkhd is intended for malloc overhead
   *     according to the Solaris manpages, but glibc keeps the
   *     amount of mmapped memory there, and uses the arena only
   *     for the amount from sbrk.
   *
   *     The hblkhd value on proper implementations should be
   *     small enough not to affect the total much, so no need
   *     for a special case.
   */
  if (mi.hblkhd < 0) {
    size += (unsigned int)mi.hblkhd;
  } else {
    size += mi.hblkhd;
  }
#endif
  push_ulongest(size);

  push_text("num_malloc");
  push_ulongest(mi.ordblks + mi.smblks);
  push_text("malloc_bytes");
#ifdef HAVE_MALLINFO2
  size = mi.uordblks + mi.usmblks;
#else
  if (mi.uordblks < 0) {
    size = (unsigned int)mi.uordblks;
  } else {
    size = mi.uordblks;
  }
  if (mi.smblks) {
    /* NB: Not dlmalloc where usmblks contains the max uordblks value. */
    if (mi.usmblks < 0) {
      size += (unsigned int)mi.usmblks;
    } else {
      size += mi.usmblks;
    }
  }
#endif
  push_ulongest(size);

  push_text("num_free_blocks");
  push_int(1);
  push_text("free_block_bytes");
#ifdef HAVE_MALLINFO2
  size = mi.fsmblks + mi.fordblks;
#else
  if (mi.fsmblks < 0) {
    size = (unsigned int)mi.fsmblks;
  } else {
    size = mi.fsmblks;
  }
  if (mi.fordblks < 0) {
    size += (unsigned int)mi.fordblks;
  } else {
    size += mi.fordblks;
  }
#endif
  push_ulongest(size);

#endif

#define COUNT(TYPE) do {					\
    PIKE_CONCAT3(count_memory_in_, TYPE, s)(&num, &size);	\
    push_text("num_" #TYPE "s");				\
    push_ulongest(num);						\
    push_text(#TYPE "_bytes");					\
    push_ulongest(size);					\
  } while(0)

  COUNT(array);
  COUNT(ba_mixed_frame);
  COUNT(callable);
  COUNT(callback);
  COUNT(catch_context);
  COUNT(compat_cb_box);
  COUNT(destroy_called_mark);
  COUNT(gc_rec_frame);
  COUNT(mapping);
  COUNT(marker);
  COUNT(mc_marker);
  COUNT(multiset);
  COUNT(node_s);
  COUNT(object);
  COUNT(pike_frame);
  COUNT(pike_list_node);
  COUNT(pike_type);
  COUNT(program);
  COUNT(short_pike_string);
  COUNT(string);
#ifdef PIKE_DEBUG
  COUNT(supporter_marker);
#endif

#ifdef DEBUG_MALLOC
  {
    extern void count_memory_in_memory_maps(size_t*, size_t*);
    extern void count_memory_in_memory_map_entrys(size_t*, size_t*);
    extern void count_memory_in_memlocs(size_t*, size_t*);
    extern void count_memory_in_memhdrs(size_t*, size_t*);

    COUNT(memory_map);
    COUNT(memory_map_entry);
    COUNT(memloc);
    COUNT(memhdr);
  }
#endif

  call_callback(&memory_usage_callback, NULL);

  f_aggregate_mapping(DO_NOT_WARN(Pike_sp - ss));
}

/* Estimate the size of an svalue, not including objects.
   this is used from size_object.

   It should not include the size of the svalue itself, so the basic
   types count as 0 bytes.

   This is an estimate mainly because it is very hard to know to whom
   a certain array/mapping/multiset or string "belongs".

   The returned size will be the memory usage of the svalue divided by
   the number of references to it.
*/

struct string_header
{
    PIKE_STRING_CONTENTS;
};

unsigned int rec_size_svalue( struct svalue *s, struct mapping **m )
{
    unsigned int res = 0;
    int i;
    ptrdiff_t node_ref;
    INT32 e;
    struct svalue *x;
    struct keypair *k;

    switch( TYPEOF(*s) )
    {
        case PIKE_T_STRING:
            /* FIXME: This makes assumptions about the threshold for short strings. */
            if( s->u.string->flags & STRING_IS_SHORT )
                return (16+sizeof(struct string_header)) / s->u.string->refs;
            return ((s->u.string->len << s->u.string->size_shift) +
                    sizeof(struct string_header)) / s->u.string->refs;
        case PIKE_T_INT:
        case PIKE_T_OBJECT:
        case PIKE_T_FLOAT:
        case PIKE_T_FUNCTION:
        case PIKE_T_TYPE:
            return 0;
    }
    if( !m ) return 0;

    if( !*m )
        *m = allocate_mapping( 10 );
    else if( (x = low_mapping_lookup( *m, s )) )
    {
        /* Already counted. Use the old size. */
        return x->u.integer;
    }

    low_mapping_insert( *m, s, &svalue_int_one, 0 );
    switch( TYPEOF(*s) )
    {
        case PIKE_T_ARRAY:
            res = sizeof( struct array );
            for( i=0; i<s->u.array->size; i++ )
                res += sizeof(struct svalue) + rec_size_svalue( s->u.array->item+i, m );
            break;

        case PIKE_T_MULTISET:
            res = sizeof(struct multiset) + sizeof(struct multiset_data);
            node_ref = multiset_last( s->u.multiset );
            while( node_ref != -1 )
            {
                res += rec_size_svalue( get_multiset_value (s->u.multiset, node_ref), m )
                    /* each node has the index and left/right node pointers. */
                    + sizeof(struct svalue) + (sizeof(void*)*2);
                node_ref = multiset_prev( s->u.multiset, node_ref );
            }
            break;

        case PIKE_T_MAPPING:
            res = sizeof(struct mapping);
            {
                struct mapping_data *d = s->u.mapping->data;
                struct keypair *f = d->free_list;
                int data_size = sizeof( struct mapping_data );
                data_size += d->hashsize * sizeof(struct keypair *) - sizeof(struct keypair *);
                while( f )
                {
                    data_size += sizeof(struct keypair);
                    f = f->next;
                }
                NEW_MAPPING_LOOP( s->u.mapping->data  )
                {
                    data_size += rec_size_svalue( &k->ind, m );
                    data_size += rec_size_svalue( &k->val, m );
                    data_size += sizeof( struct keypair );
                }
                res += data_size / (d->hardlinks+1);
            }
            break;
    }
    res /= *s->u.refs;
    low_mapping_lookup(*m,s)->u.integer = res;
    return res;
}

/*! @decl int size_object(object o)
 *! @belongs Debug
 *!
 *!  Return the aproximate size of the object, in bytes.
 *!  This might not work very well for native objects
 *!
 *!
 *! The function tries to estimate the memory usage of variables
 *! belonging to the object.
 *!
 *! It will not, however, include the size of objects assigned to
 *! variables in the object.
 *!
 *!
 *! If the object has a @[lfun::_size_object()] it will be called
 *! without arguments, and the return value will be added to the final
 *! size. It is primarily intended to be used by C-objects that
 *! allocate memory that is not normally visible to pike.
 *!
 *! @seealso
 *!   @[lfun::_size_object()], @[sizeof()]
 */
static void f__size_object( INT32 UNUSED(args) )
{
    size_t sum;
    unsigned int i;
    ptrdiff_t fun;
    struct object *o;
    struct program *p;
    struct mapping *map = NULL;
    if( TYPEOF(Pike_sp[-1]) != PIKE_T_OBJECT )
        Pike_error("Expected an object as argument\n");
    o = Pike_sp[-1].u.object;

    if( !(p=o->prog) )
    {
        pop_stack();
        push_int(0);
        return;
    }
    sum = sizeof(struct object);
    sum += p->storage_needed;

    if( (fun = low_find_lfun( p, LFUN__SIZE_OBJECT)) != -1 )
    {
        apply_low( o, fun, 0 );
        if( TYPEOF(Pike_sp[-1]) == PIKE_T_INT )
            sum += Pike_sp[-1].u.integer;
        pop_stack();
    }

    Pike_sp++;
    for (i = 0; i < p->num_identifier_references; i++)
    {
        struct reference *ref = PTR_FROM_INT(p, i);
        struct identifier *id =  ID_FROM_PTR(p, ref);
        struct inherit *inh = p->inherits;
        if (!IDENTIFIER_IS_VARIABLE(id->identifier_flags) ||
            id->run_time_type == PIKE_T_GET_SET)
        {
            continue;
        }

        /* NOTE: makes the assumption that a variable saved in an
         * object has at least one reference.
         */
        low_object_index_no_free(Pike_sp-1, o, i + inh->identifier_level);
        if (REFCOUNTED_TYPE(TYPEOF(Pike_sp[-1])))
            sub_ref( Pike_sp[-1].u.dummy );
        sum += rec_size_svalue(Pike_sp-1, &map);
    }
    Pike_sp--;
    if( map ) free_mapping(map);

    pop_stack();
    push_int(sum);
}


/*! @decl mixed _next(mixed x)
 *!
 *!   Find the next object/array/mapping/multiset/program or string.
 *!
 *!   All objects, arrays, mappings, multisets, programs and strings are
 *!   stored in linked lists inside Pike. This function returns the next
 *!   item on the corresponding list. It is mainly meant for debugging
 *!   the Pike runtime, but can also be used to control memory usage.
 *!
 *! @seealso
 *!   @[next_object()], @[_prev()]
 */
PMOD_EXPORT void f__next(INT32 args)
{
  struct svalue tmp;

  ASSERT_SECURITY_ROOT("_next");

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("_next", 1);
  
  pop_n_elems(args-1);
  args = 1;
  tmp=Pike_sp[-1];
  switch(TYPEOF(tmp))
  {
  case T_OBJECT:  tmp.u.object=tmp.u.object->next; break;
  case T_ARRAY:   tmp.u.array=tmp.u.array->next; break;
  case T_MAPPING: tmp.u.mapping=tmp.u.mapping->next; break;
  case T_MULTISET:tmp.u.multiset=tmp.u.multiset->next; break;
  case T_PROGRAM: tmp.u.program=tmp.u.program->next; break;
  case T_STRING:  tmp.u.string=next_pike_string(tmp.u.string); break;
  default:
    SIMPLE_BAD_ARG_ERROR("_next", 1,
			 "object|array|mapping|multiset|program|string");
  }
  if(tmp.u.refs)
  {
    assign_svalue(Pike_sp-1,&tmp);
  }else{
    pop_stack();
    push_int(0);
  }
}

/*! @decl mixed _prev(mixed x)
 *!
 *!   Find the previous object/array/mapping/multiset or program.
 *!
 *!   All objects, arrays, mappings, multisets and programs are
 *!   stored in linked lists inside Pike. This function returns the previous
 *!   item on the corresponding list. It is mainly meant for debugging
 *!   the Pike runtime, but can also be used to control memory usage.
 *!
 *! @note
 *!   Unlike @[_next()] this function does not work on strings.
 *!
 *! @seealso
 *!   @[next_object()], @[_next()]
 */
PMOD_EXPORT void f__prev(INT32 args)
{
  struct svalue tmp;

  ASSERT_SECURITY_ROOT("_prev");

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("_prev", 1);
  
  pop_n_elems(args-1);
  args = 1;
  tmp=Pike_sp[-1];
  switch(TYPEOF(tmp))
  {
  case T_OBJECT:  tmp.u.object=tmp.u.object->prev; break;
  case T_ARRAY:   tmp.u.array=tmp.u.array->prev; break;
  case T_MAPPING: tmp.u.mapping=tmp.u.mapping->prev; break;
  case T_MULTISET:tmp.u.multiset=tmp.u.multiset->prev; break;
  case T_PROGRAM: tmp.u.program=tmp.u.program->prev; break;
  default:
    SIMPLE_BAD_ARG_ERROR("_prev", 1, "object|array|mapping|multiset|program");
  }
  if(tmp.u.refs)
  {
    assign_svalue(Pike_sp-1,&tmp);
  }else{
    pop_stack();
    push_int(0);
  }
}

/*! @decl int _refs(string|array|mapping|multiset|function|object|program o)
 *!
 *!   Return the number of references @[o] has.
 *!
 *!   It is mainly meant for debugging the Pike runtime, but can also be
 *!   used to control memory usage.
 *!
 *! @note
 *!   Note that the number of references will always be at least one since
 *!   the value is located on the stack when this function is executed.
 *!
 *! @seealso
 *!   @[_next()], @[_prev()]
 */
PMOD_EXPORT void f__refs(INT32 args)
{
  INT32 i;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("_refs", 1);

  if(!REFCOUNTED_TYPE(TYPEOF(Pike_sp[-args])))
    SIMPLE_BAD_ARG_ERROR("refs", 1,
			 "array|mapping|multiset|object|"
			 "function|program|string");

  i=Pike_sp[-args].u.refs[0];
  pop_n_elems(args);
  push_int(i);
}

#ifdef PIKE_DEBUG
/* This function is for debugging *ONLY*
 * do not document please. /Hubbe
 */
PMOD_EXPORT void f__leak(INT32 args)
{
  INT32 i;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("_leak", 1);

  if(!REFCOUNTED_TYPE(TYPEOF(Pike_sp[-args])))
    SIMPLE_BAD_ARG_ERROR("_leak", 1,
			 "array|mapping|multiset|object|"
			 "function|program|string");

  add_ref(Pike_sp[-args].u.dummy);
  i=Pike_sp[-args].u.refs[0];
  pop_n_elems(args);
  push_int(i);
}
#endif

/*! @decl type _typeof(mixed x)
 *!
 *!   Return the runtime type of @[x].
 *!
 *! @seealso
 *!   @[typeof()]
 */
PMOD_EXPORT void f__typeof(INT32 args)
{
  struct pike_type *t;

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("_typeof", 1);

  t = get_type_of_svalue(Pike_sp-args);

  pop_n_elems(args);
  push_type_value(t);
}

/*! @decl void replace_master(object o)
 *!
 *!   Replace the master object with @[o].
 *!
 *!   This will let you control many aspects of how Pike works, but beware that
 *!   @tt{master.pike@} may be required to fill certain functions, so it is
 *!   usually a good idea to have your master inherit the original master and
 *!   only re-define certain functions.
 *!
 *!   FIXME: Tell how to inherit the master.
 *!
 *! @seealso
 *!   @[master()]
 */
PMOD_EXPORT void f_replace_master(INT32 args)
{
  struct object *new_master;
  ASSERT_SECURITY_ROOT("replace_master");

  if(!args)
    SIMPLE_TOO_FEW_ARGS_ERROR("replace_master", 1);
  if(TYPEOF(Pike_sp[-args]) != T_OBJECT)
    SIMPLE_BAD_ARG_ERROR("replace_master", 1, "object");
  new_master = Pike_sp[-args].u.object;
  if(!new_master->prog)
    bad_arg_error("replace_master", Pike_sp-args, args, 1, "object", Pike_sp-args,
		  "Called with destructed object.\n");

  if (SUBTYPEOF(Pike_sp[-args]))
    bad_arg_error("replace_master", Pike_sp-args, args, 1, "object", Pike_sp-args,
		  "Subtyped master objects are not supported yet.\n");

  push_text ("is_pike_master");
  args++;
  object_set_index (new_master, 0, Pike_sp - 1, (struct svalue *) &svalue_int_one);

  free_object(master_object);
  master_object=new_master;
  add_ref(master_object);

  free_program(master_program);
  master_program=master_object->prog;
  add_ref(master_program);

  pop_n_elems(args);
}

/*! @decl object master();
 *!
 *!   Return the current master object.
 *!
 *! @note
 *!   May return @[UNDEFINED] if no master has been loaded yet.
 *!
 *! @seealso
 *!   @[replace_master()]
 */
PMOD_EXPORT void f_master(INT32 args)
{
  struct object *o;
  pop_n_elems(args);
  o = get_master();
  if (o) ref_push_object(o);
  else push_undefined();
}

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif

/*! @decl int gethrvtime (void|int nsec)
 *!
 *! Return the CPU time that has been consumed by this process or
 *! thread. -1 is returned if the system couldn't determine it. The
 *! time is normally returned in microseconds, but if the optional
 *! argument @[nsec] is nonzero it's returned in nanoseconds.
 *!
 *! The CPU time includes both user and system time, i.e. it's
 *! approximately the same thing you would get by adding together the
 *! "utime" and "stime" fields returned by @[System.getrusage] (but
 *! perhaps with better accuracy).
 *!
 *! It's however system dependent whether or not it's the time
 *! consumed in all threads or in the current one only;
 *! @[System.CPU_TIME_IS_THREAD_LOCAL] tells which. If both types are
 *! available then thread local time is preferred.
 *!
 *! @note
 *!   The actual accuracy on many systems is significantly less than
 *!   microseconds or nanoseconds. See @[System.CPU_TIME_RESOLUTION].
 *!
 *! @note
 *!   The garbage collector might run automatically at any time. The
 *!   time it takes is not included in the figure returned by this
 *!   function, so that normal measurements aren't randomly clobbered
 *!   by it. Explicit calls to @[gc] are still included, though.
 *!
 *! @note
 *!   The special function @[gauge] is implemented with this function.
 *!
 *! @seealso
 *!   @[System.CPU_TIME_IS_THREAD_LOCAL], @[System.CPU_TIME_RESOLUTION],
 *!   @[gauge()], @[System.getrusage()], @[gethrtime()]
 */
PMOD_EXPORT void f_gethrvtime(INT32 args)
{
  int nsec = 0;
  cpu_time_t time = get_cpu_time();

  if (time == (cpu_time_t) -1) {
    pop_n_elems (args);
    push_int (-1);
    return;
  }

#ifdef CPU_TIME_MIGHT_BE_THREAD_LOCAL
  if (cpu_time_is_thread_local)
    time -= Pike_interpreter.thread_state->auto_gc_time;
  else
#endif
  {
#ifdef CPU_TIME_MIGHT_NOT_BE_THREAD_LOCAL
    time -= auto_gc_time;
#endif
  }

  nsec = args && !UNSAFE_IS_ZERO(Pike_sp-args);

  pop_n_elems(args);

  if (nsec) {
    push_int64(time);
#ifndef LONG_CPU_TIME
    push_int (1000000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  }
  else {
#if CPU_TIME_TICKS_LOW > 1000000
    push_int64(time / (CPU_TIME_TICKS / 1000000));
#else
    push_int64 (time);
    push_int (1000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  }
}

/*! @decl int gethrtime (void|int nsec)
 *!
 *! Return the high resolution real time since some arbitrary event in
 *! the past. The time is normally returned in microseconds, but if
 *! the optional argument @[nsec] is nonzero it's returned in
 *! nanoseconds.
 *!
 *! It's system dependent whether or not this time is monotonic, i.e.
 *! if it's unaffected by adjustments of the calendaric clock in the
 *! system. @[System.REAL_TIME_IS_MONOTONIC] tells what it is. Pike
 *! tries to use monotonic time for this function if it's available.
 *!
 *! @note
 *!   The actual accuracy on many systems is significantly less than
 *!   microseconds or nanoseconds. See @[System.REAL_TIME_RESOLUTION].
 *!
 *! @seealso
 *!   @[System.REAL_TIME_IS_MONOTONIC], @[System.REAL_TIME_RESOLUTION],
 *!   @[time()], @[System.gettimeofday()], @[gethrvtime()],
 *!   @[Pike.implicit_gc_real_time]
 */
PMOD_EXPORT void f_gethrtime(INT32 args)
{
  int nsec = 0;
  cpu_time_t time = get_real_time();

  if (time == (cpu_time_t) -1) {
    pop_n_elems (args);
    push_int (-1);
    return;
  }

  nsec = args && !UNSAFE_IS_ZERO(Pike_sp-args);

  pop_n_elems(args);
  if (nsec) {
    push_int64(time);
#ifndef LONG_CPU_TIME
    push_int (1000000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  }
  else {
#if CPU_TIME_TICKS_LOW > 1000000
    push_int64(time / (CPU_TIME_TICKS / 1000000));
#else
    push_int64 (time);
    push_int (1000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  }
}

/*! @decl int gethrdtime(void|int nsec)
 *!
 *! Return the high resolution real time spent with threads disabled
 *! since the Pike interpreter was started. The time is normally
 *! returned in microseconds, but if the optional argument @[nsec]
 *! is nonzero it's returned in nanoseconds.
 *!
 *! @note
 *!   The actual accuracy on many systems is significantly less than
 *!   microseconds or nanoseconds. See @[System.REAL_TIME_RESOLUTION].
 *!
 *! @seealso
 *!   @[_disable_threads()], @[gethrtime()]
 */
static void f_gethrdtime(INT32 args)
{
  int nsec = args && !UNSAFE_IS_ZERO(Pike_sp-args);
  cpu_time_t time;
#ifdef PIKE_THREADS
  time = threads_disabled_acc_time;
  if (threads_disabled) {
    time += get_real_time() - threads_disabled_start;
  }
#else
  time = get_real_time();
#endif
  pop_n_elems(args);

  if (nsec) {
    push_int64(time);
#ifndef LONG_CPU_TIME
    push_int(1000000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  } else {
#if CPU_TIME_TICKS_LOW > 1000000
    push_int64(time / (CPU_TIME_TICKS / 1000000));
#else
    push_int64 (time);
    push_int (1000000 / CPU_TIME_TICKS);
    o_multiply();
#endif
  }
}

#ifdef PROFILING
/*! @decl array(int|mapping(string:array(int))) @
 *!           get_profiling_info(program prog)
 *!
 *!   Get profiling information.
 *!
 *! @returns
 *!   Returns an array with two elements.
 *!   @array
 *!   	@elem int num_clones
 *!   	  The first element is the number of times the program @[prog] has been
 *!   	  instantiated.
 *!   	@elem mapping(string:array(int)) fun_prof_info
 *!   	  The second element is mapping from function name to an
 *!   	  array with three elements.
 *!   	  @array
 *!   	    @elem int num_calls
 *!   	      The first element is the number of times the function has been
 *!   	      called.
 *!   	    @elem int total_time
 *!   	      The second element is the total time (in milliseconds) spent
 *!   	      executing this function, and any functions called from it.
 *!   	    @elem int self_time
 *!   	      The third element is the time (in milliseconds) actually spent
 *!   	      in this function so far.
 *!   	  @endarray
 *!   @endarray
 *!
 *! @note
 *!   This function is only available if the runtime was compiled with
 *!   the option @tt{--with-profiling@}.
 */
static void f_get_prof_info(INT32 args)
{
  struct program *prog = 0;
  int num_functions;
  int i;

  if (!args) {
    SIMPLE_TOO_FEW_ARGS_ERROR("get_profiling_info", 1);
  }
  prog = program_from_svalue(Pike_sp-args);
  if(!prog)
    SIMPLE_BAD_ARG_ERROR("get_profiling_info", 1, "program");

  /* ({ num_clones, ([ "fun_name":({ num_calls, total_time, self_time }) ]) })
   */

  pop_n_elems(args-1);
  args = 1;

  push_int(prog->num_clones);

  for(num_functions=i=0; i<(int)prog->num_identifiers; i++) {
    if (prog->identifiers[i].num_calls)
    {
      num_functions++;
      ref_push_string(prog->identifiers[i].name);

      push_int(prog->identifiers[i].num_calls);
      if (CPU_TIME_TICKS == 1000) {
	push_int64(prog->identifiers[i].total_time);
	push_int64(prog->identifiers[i].self_time);
      } else {
	push_int64(prog->identifiers[i].total_time/1000000);
	push_int64(prog->identifiers[i].self_time/1000000);
      }
      f_aggregate(3);
    }
  }
  f_aggregate_mapping(num_functions * 2);
  f_aggregate(2);

  stack_swap();
  pop_stack();
}
#endif /* PROFILING */

/*! @decl int(0..1) object_variablep(object o, string var)
 *!
 *!   Find out if an object identifier is a variable.
 *!
 *! @returns
 *!   This function returns @expr{1@} if @[var] exists as a
 *!   non-protected variable in @[o], and returns @expr{0@} (zero)
 *!   otherwise.
 *!
 *! @seealso
 *!   @[indices()], @[values()]
 */
PMOD_EXPORT void f_object_variablep(INT32 args)
{
  struct object *o;
  struct pike_string *s;
  int ret;

  get_all_args("variablep",args,"%o%S",&o, &s);

  if(!o->prog)
    bad_arg_error("variablep", Pike_sp-args, args, 1, "object", Pike_sp-args,
		  "Called on destructed object.\n");

  /* FIXME: Ought to be overloadable, since `[]=() is... */

  ret=find_shared_string_identifier(s,o->prog);
  if(ret!=-1)
  {
    ret=IDENTIFIER_IS_VARIABLE(ID_FROM_INT(o->prog, ret)->identifier_flags);
  }else{
    ret=0;
  }
  pop_n_elems(args);
  push_int(!!ret);
}

/*! @module Array
 */

/*! @decl array uniq(array a)
 *!
 *!   Remove elements that are duplicates.
 *!
 *! @returns
 *!   This function returns an copy of the array @[a] with all
 *!   duplicate values removed. The order of the values is kept in the
 *!   result; it's always the first of several equal elements that is
 *!   kept.
 *!
 *! @note
 *!   Elements are compared with @[`==]. They are also hashed (see
 *!   @[lfun::__hash] for further details if the array contains
 *!   objects).
 */
PMOD_EXPORT void f_uniq_array(INT32 args)
{
  struct array *a, *b;
  struct mapping *m;
  int i, j=0,size=0;

  get_all_args("uniq", args, "%a", &a);
  push_mapping(m = allocate_mapping(a->size));
  push_array(b = allocate_array(a->size));

  for(i =0; i< a->size; i++)
  {
    mapping_insert(m, ITEM(a)+i, &svalue_int_one);
    if(m_sizeof(m) != size)
    {
      size=m_sizeof(m);
      assign_svalue_no_free(ITEM(b)+ j++, ITEM(a)+i);
    }
  }
  dmalloc_touch_svalue(Pike_sp-1);
  Pike_sp--; /* keep the ref to 'b' */
  ACCEPT_UNFINISHED_TYPE_FIELDS {
    b=resize_array(b,  j);
  } END_ACCEPT_UNFINISHED_TYPE_FIELDS;
  b->type_field = a->type_field;
  pop_n_elems(args-1); /* pop args and the mapping */
  push_array(b);
}

/*! @decl array(mixed) splice(array(mixed) arr1, array(mixed) arr2, @
 *!                           array(mixed) ... more_arrays)
 *!
 *!   Splice two or more arrays.
 *!
 *!   This means that the returned array has the first element in the
 *!   first given array, then the first argument in next array and so
 *!   on for all arrays. Then the second elements are added, etc.
 *!
 *! @seealso
 *!   @[`/()], @[`*()], @[`+()], @[`-()], @[everynth()]
 */
PMOD_EXPORT void f_splice(INT32 args)
{
  struct array *out;
  INT32 size=0x7fffffff;
  INT32 i,j,k;

  for(i=0;i<args;i++)
    if (TYPEOF(Pike_sp[i-args]) != T_ARRAY)
      SIMPLE_BAD_ARG_ERROR("splice", i+1, "array");
    else
      if (Pike_sp[i-args].u.array->size < size)
	size=Pike_sp[i-args].u.array->size;

  out=allocate_array(args * size);
  if (!args)
  {
    push_array(out);
    return;
  }

  out->type_field=0;
  for(i=-args; i<0; i++) out->type_field|=Pike_sp[i].u.array->type_field;

  for(k=j=0; j<size; j++)
    for(i=-args; i<0; i++)
      assign_svalue_no_free(out->item+(k++), Pike_sp[i].u.array->item+j);

  pop_n_elems(args);
  push_array(out);
  return;
}

/*! @decl array(mixed) everynth(array(mixed) a, void|int n, @
 *!                             void|int start)
 *!
 *!   Return an array with every @[n]:th element of the array @[a].
 *!
 *!   If @[n] is zero every other element will be returned.
 *!
 *! @seealso
 *!   @[splice()], @[`/()]
 */
PMOD_EXPORT void f_everynth(INT32 args)
{
  INT32 k,n=2;
  INT32 start=0;
  struct array *a;
  struct array *ina;
  TYPE_FIELD types;
  INT32 size=0;

  check_all_args("everynth", args,
		 BIT_ARRAY, BIT_INT | BIT_VOID, BIT_INT | BIT_VOID , 0);

  switch(args)
  {
    default:
    case 3:
     start=Pike_sp[2-args].u.integer;
     if(start<0)
       bad_arg_error("everynth", Pike_sp-args, args, 3, "int", Pike_sp+2-args,
		     "Argument negative.\n");
    case 2:
      n=Pike_sp[1-args].u.integer;
      if(n<1)
	bad_arg_error("everynth", Pike_sp-args, args, 2, "int", Pike_sp+1-args,
		      "Argument negative.\n");
    case 1:
      ina=Pike_sp[-args].u.array;
  }

  a=allocate_array(((size=ina->size)-start+n-1)/n);
  types = 0;
  for(k=0; start<size; k++, start+=n) {
    assign_svalue_no_free(ITEM(a) + k, ina->item+start);
    types |= 1 << TYPEOF(ITEM(a)[k]);
  }
  a->type_field=types;

  pop_n_elems(args);
  push_array(a);
  return;
}

/*! @decl array(array) transpose(array(array) matrix)
 *! Takes an array of equally sized arrays (essentially a matrix of size M*N)
 *! and returns the transposed (N*M) version of it, where rows and columns
 *! are exchanged for one another.
 */
PMOD_EXPORT void f_transpose(INT32 args)
{
  struct array *out;
  struct array *in;
  struct array *outinner;
  INT32 sizeininner=0,sizein=0;
  INT32 j,i;
  TYPE_FIELD type=0;

  if (args<1)
    SIMPLE_TOO_FEW_ARGS_ERROR("transpose", 1);

  if (TYPEOF(Pike_sp[-args]) != T_ARRAY)
    SIMPLE_BAD_ARG_ERROR("transpose", 1, "array(array)");

  in=Pike_sp[-args].u.array;
  sizein=in->size;

  if(!sizein)
  {
    pop_n_elems(args);
    out=allocate_array(0);
    push_array(out);
    return; 
  }

  if( (in->type_field != BIT_ARRAY) &&
      (array_fix_type_field(in) != BIT_ARRAY) )
    SIMPLE_BAD_ARG_ERROR("transpose", 1, "array(array)");

  sizeininner=in->item->u.array->size;

  for(i=1 ; i<sizein; i++)
    if (sizeininner!=(in->item+i)->u.array->size)
      Pike_error("The array given as argument 1 to transpose must contain arrays of the same size.\n");

  out=allocate_array(sizeininner);

  for(i=0; i<sizein; i++)
    type|=in->item[i].u.array->type_field;
  
  for(j=0; j<sizeininner; j++)
  {
    struct svalue * ett;
    struct svalue * tva;

    outinner=allocate_array(sizein);
    ett=outinner->item;
    tva=in->item;
    for(i=0; i<sizein; i++)
      assign_svalue_no_free(ett+i, tva[i].u.array->item+j);

    outinner->type_field=type;
    SET_SVAL(out->item[j], T_ARRAY, 0, array, outinner);
  }

  out->type_field=BIT_ARRAY;
  pop_n_elems(args);
  push_array(out);
  return;
}

/*! @endmodule
 */

#ifdef DEBUG_MALLOC
/*! @decl void reset_dmalloc()
 *! @belongs Debug
 *!
 *! @note
 *!   Only available when compiled with dmalloc.
 */
PMOD_EXPORT void f__reset_dmalloc(INT32 args)
{
  ASSERT_SECURITY_ROOT("_reset_dmalloc");
  pop_n_elems(args);
  reset_debug_malloc();
}

/*! @decl void dmalloc_set_name(string filename, int(1..) linenumber)
 *! @belongs Debug
 *!
 *! @note
 *!   Only available when compiled with dmalloc.
 */
PMOD_EXPORT void f__dmalloc_set_name(INT32 args)
{
  char *s;
  INT_TYPE i;
  extern char * dynamic_location(const char *file, INT_TYPE line);
  extern char * dmalloc_default_location;

  if(args)
  {
    get_all_args("_dmalloc_set_name", args, "%s%+", &s, &i);
    dmalloc_default_location = dynamic_location(s, i);
  }else{
    dmalloc_default_location=0;
  }
  pop_n_elems(args);
}

/*! @decl void list_open_fds()
 *! @belongs Debug
 *!
 *! @note
 *!   Only available when compiled with dmalloc.
 */
PMOD_EXPORT void f__list_open_fds(INT32 args)
{
  extern void list_open_fds(void);
  list_open_fds();
}

/*! @decl void dump_dmalloc_locations(string|array|mapping| @
 *!                                   multiset|function|object| @
 *!                                   program|type o)
 *! @belongs Debug
 *!
 *! @note
 *!   Only available when compiled with dmalloc.
 */
PMOD_EXPORT void f__dump_dmalloc_locations(INT32 args)
{
  ASSERT_SECURITY_ROOT("_dump_dmalloc_locations");
  if(args)
    debug_malloc_dump_references (Pike_sp[-args].u.refs, 2, 1, 0);
  pop_n_elems(args-1);
}
#endif

#ifdef PIKE_DEBUG
/*! @decl void locate_references(string|array|mapping| @
 *!                              multiset|function|object| @
 *!                              program|type o)
 *! @belongs Debug
 *!
 *!   This function is mostly intended for debugging. It will search through
 *!   all data structures in Pike looking for @[o] and print the
 *!   locations on stderr. @[o] can be anything but @expr{int@} or
 *!   @expr{float@}.
 *!
 *! @note
 *!   This function only exists if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__locate_references(INT32 args)
{
  ASSERT_SECURITY_ROOT("_locate_references");
  if(args)
    locate_references(Pike_sp[-args].u.refs);
  pop_n_elems(args-1);
}

/*! @decl mixed describe(mixed x)
 *! @belongs Debug
 *!
 *!   Prints out a description of the thing @[x] to standard error.
 *!   The description contains various internal info associated with
 *!   @[x].
 *!
 *! @note
 *!   This function only exists if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__describe(INT32 args)
{
  struct svalue *s;
  ASSERT_SECURITY_ROOT("_describe");
  get_all_args("_describe", args, "%*", &s);
  debug_describe_svalue(debug_malloc_pass(s));
  pop_n_elems(args-1);
}

/*! @decl void gc_set_watch(array|multiset|mapping|object|function|program|string x)
 *! @belongs Debug
 *!
 *!   Sets a watch on the given thing, so that the gc will print a
 *!   message whenever it's encountered. Intended to be used together
 *!   with breakpoints to debug the garbage collector.
 *!
 *! @note
 *!   This function only exists if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__gc_set_watch(INT32 args)
{
  ASSERT_SECURITY_ROOT("_gc_set_watch");

  if (args < 1)
    SIMPLE_TOO_FEW_ARGS_ERROR("_gc_set_watch", 1);
  if (!REFCOUNTED_TYPE(TYPEOF(Pike_sp[-args])))
    SIMPLE_BAD_ARG_ERROR("_gc_set_watch", 1, "reference type");
  gc_watch(Pike_sp[-args].u.refs);
  pop_n_elems(args);
}

/*! @decl void dump_backlog()
 *! @belongs Debug
 *!
 *!   Dumps the 1024 latest executed opcodes, along with the source
 *!   code lines, to standard error. The backlog is only collected on
 *!   debug level 1 or higher, set with @[_debug] or with the @tt{-d@}
 *!   argument on the command line.
 *!
 *! @note
 *!   This function only exists if the Pike runtime has been compiled
 *!   with RTL debug.
 */
PMOD_EXPORT void f__dump_backlog(INT32 args)
{
  ASSERT_SECURITY_ROOT("_dump_backlog");
  pop_n_elems(args);
  dump_backlog();
}

#endif

/*! @decl mixed map(mixed arr, void|mixed fun, mixed ... extra)
 *!
 *!   Applies @[fun] to the elements in @[arr] and collects the results.
 *!
 *!   @[arr] is treated as a set of elements, as follows:
 *!
 *!   @dl
 *!     @item array
 *!     @item multiset
 *!     @item string
 *!       @[fun] is applied in order to each element. The results are
 *!       collected, also in order, to a value of the same type as
 *!       @[arr], which is returned.
 *!
 *!     @item mapping
 *!       @[fun] is applied to the values, and each result is assigned
 *!       to the same index in a new mapping, which is returned.
 *!
 *!     @item program
 *!       The program is treated as a mapping containing the
 *!       identifiers that are indexable from it and their values.
 *!
 *!     @item object
 *!       If there is a @[lfun::cast] method in the object, it's
 *!       called to try to cast the object to an array, a mapping, or
 *!       a multiset, in that order, which is then handled as
 *!       described above.
 *!   @enddl
 *!
 *!   @[fun] is applied in different ways depending on its type:
 *!
 *!   @dl
 *!     @item function
 *!       @[fun] is called for each element. It gets the current
 *!       element as the first argument and @[extra] as the rest. The
 *!       result of the call is collected.
 *!
 *!     @item object
 *!       @[fun] is used as a function like above, i.e. the
 *!       @[lfun::`()] method in it is called.
 *!
 *!     @item multiset
 *!     @item mapping
 *!       @[fun] is indexed with each element. The result of that is
 *!       collected.
 *!
 *!     @item "zero or left out"
 *!       Each element that is callable is called with @[extra] as
 *!       arguments. The result of the calls are collected. Elements
 *!       that aren't callable gets zero as result.
 *!
 *!     @item string
 *!       Each element is indexed with the given string. If the result
 *!       of that is zero then a zero is collected, otherwise it's
 *!       called with @[extra] as arguments and the result of that
 *!       call is collected.
 *!
 *!       This is typically used when @[arr] is a collection of
 *!       objects, and @[fun] is the name of some function in them.
 *!   @enddl
 *!
 *! @note
 *!   The function is never destructive on @[arr].
 *!
 *! @seealso
 *!   @[filter()], @[enumerate()], @[foreach()]
 */
PMOD_EXPORT void f_map(INT32 args)
{
   struct svalue *mysp;
   struct array *a,*d;
   int splice,i,n;
   TYPE_FIELD types;

   if (args<1)
      SIMPLE_TOO_FEW_ARGS_ERROR("map", 1);
   else if (args<2)
      { push_int(0); args++; }

   switch (TYPEOF(Pike_sp[-args]))
   {
      case T_ARRAY:
	 break;

      case T_MAPPING:
      case T_PROGRAM:
      case T_FUNCTION:
	 /* mapping ret =                             
	       mkmapping(indices(arr),                
	                 map(values(arr),fun,@extra)); */
	 f_aggregate(args-2);
	 mysp=Pike_sp;
	 splice=mysp[-1].u.array->size;

	 push_svalue(mysp-3); /* arr */
	 f_values(1);
	 push_svalue(mysp-2); /* fun */
	 move_svalue (Pike_sp, mysp-1); /* extra */
	 mark_free_svalue (mysp-1);
	 dmalloc_touch_svalue(Pike_sp);
	 push_array_items(Pike_sp->u.array);
	 f_map(splice+2);     /* ... arr fun extra -> ... retval */
	 stack_pop_2_elems_keep_top(); /* arr fun extra ret -> arr retval */
	 stack_swap();        /* retval arr */
	 f_indices(1);        /* retval retind */
	 stack_swap();        /* retind retval */
	 f_mkmapping(2);      /* ret :-) */
	 return;

      case T_MULTISET:
	 /* multiset ret =                             
	       (multiset)(map(indices(arr),fun,@extra)); */
	 push_svalue(Pike_sp-args);      /* take indices from arr */
	 free_svalue(Pike_sp-args-1);    /* move it to top of stack */
	 mark_free_svalue (Pike_sp-args-1);
	 f_indices(1);              /* call f_indices */
	 Pike_sp--;
	 dmalloc_touch_svalue(Pike_sp);
	 Pike_sp[-args]=Pike_sp[0];           /* move it back */
	 f_map(args);               

	 push_multiset (mkmultiset (Pike_sp[-1].u.array));
	 free_array (Pike_sp[-2].u.array);
	 dmalloc_touch_svalue(Pike_sp-1);
	 Pike_sp[-2] = Pike_sp[-1];
	 Pike_sp--;
	 return;

      case T_STRING:
	 /* multiset ret =                             
	       (string)(map((array)arr,fun,@extra)); */
	 push_svalue(Pike_sp-args);      /* take indices from arr */
	 free_svalue(Pike_sp-args-1);    /* move it to top of stack */
	 mark_free_svalue (Pike_sp-args-1);
	 o_cast(NULL,T_ARRAY);      /* cast the string to an array */
	 Pike_sp--;                       
	 dmalloc_touch_svalue(Pike_sp);
	 Pike_sp[-args]=Pike_sp[0];           /* move it back */
	 f_map(args);               
	 o_cast(NULL,T_STRING);     /* cast the array to a string */
	 return;

      case T_OBJECT:
	 /* if arr->cast :              
               try map((array)arr,fun,@extra);
               try map((mapping)arr,fun,@extra);
               try map((multiset)arr,fun,@extra); */

	 mysp=Pike_sp+3-args;

	 {
           struct object *o = mysp[-3].u.object;
           INT16 osub = SUBTYPEOF(mysp[-3]);
           int f = FIND_LFUN(o->prog->inherits[osub].prog,
                             LFUN_CAST);

           if( f!=-1 )
           {

             ref_push_string(literal_array_string);
             apply_low(o, f, 1);
             if (TYPEOF(Pike_sp[-1]) == T_ARRAY)
             {
	       free_svalue(mysp-3);
	       mysp[-3]=*(--Pike_sp);
	       dmalloc_touch_svalue(Pike_sp);
	       f_map(args);
	       return;
             }
             pop_stack();

             ref_push_string(literal_mapping_string);
             apply_low(o, f, 1);
             if (TYPEOF(Pike_sp[-1]) == T_MAPPING)
             {
	       free_svalue(mysp-3);
	       mysp[-3]=*(--Pike_sp);
	       dmalloc_touch_svalue(Pike_sp);
	       f_map(args);
	       return;
             }
             pop_stack();

             ref_push_string(literal_multiset_string);
             apply_low(o, f, 1);
             if (TYPEOF(Pike_sp[-1]) == T_MULTISET)
             {
	       free_svalue(mysp-3);
	       mysp[-3]=*(--Pike_sp);
	       dmalloc_touch_svalue(Pike_sp);
	       f_map(args);
	       return;
             }
             pop_stack();
           }
	 }

	 SIMPLE_BAD_ARG_ERROR("map",1,
			      "object that works in map");

      default:
	 SIMPLE_BAD_ARG_ERROR("map",1,
			      "array|mapping|program|function|"
			      "multiset|string|object");
   }

   if (UNSAFE_IS_ZERO (Pike_sp-args+1)) {
     free_svalue (Pike_sp-args+1);
     move_svalue (Pike_sp-args+1, Pike_sp-args);
     mark_free_svalue (Pike_sp-args);
     mega_apply (APPLY_STACK, args-1, 0, 0);
     stack_pop_keep_top();
     return;
   }

   f_aggregate(args-2);
   mysp=Pike_sp;
   splice=mysp[-1].u.array->size;

   a=mysp[-3].u.array;
   n=a->size;

   switch (TYPEOF(mysp[-2]))
   {
      case T_FUNCTION:
      case T_PROGRAM:
      case T_OBJECT:
      case T_ARRAY:
	 /* ret[i]=fun(arr[i],@extra); */
         push_array(d=allocate_array(n));
	 d=Pike_sp[-1].u.array;
	 types = 0;

	 if(TYPEOF(mysp[-2]) == T_FUNCTION &&
	    SUBTYPEOF(mysp[-2]) == FUNCTION_BUILTIN)
	 {
	   c_fun fun=mysp[-2].u.efun->function;
	   struct svalue *spbase=Pike_sp;

	   if(splice)
	   {
	     for (i=0; i<n; i++)
	     {
	       push_svalue(a->item+i);
	       add_ref_svalue(mysp-1);
	       push_array_items(mysp[-1].u.array);
	       (* fun)(1+splice);
	       if(Pike_sp>spbase)
	       {
		 stack_pop_to_no_free (ITEM(d) + i);
		 types |= 1 << TYPEOF(ITEM(d)[i]);
		 pop_n_elems(Pike_sp-spbase);
	       }
	       else
		 types |= BIT_INT;
	     }
	   }else{
	     for (i=0; i<n; i++)
	     {
	       push_svalue(ITEM(a)+i);
	       (* fun)(1);
	       if(Pike_sp>spbase)
	       {
		 stack_pop_to_no_free (ITEM(d) + i);
		 types |= 1 << TYPEOF(ITEM(d)[i]);
		 pop_n_elems(Pike_sp-spbase);
	       }
	       else
		 types |= BIT_INT;
	     }
	   }
	 }else{
	   for (i=0; i<n; i++)
	   {
	     push_svalue(ITEM(a)+i);
	     if (splice) 
	     {
	       add_ref_svalue(mysp-1);
	       push_array_items(mysp[-1].u.array);
	       apply_svalue(mysp-2,1+splice);
	     }
	     else
	     {
	       apply_svalue(mysp-2,1);
	     }
	     stack_pop_to_no_free (ITEM(d) + i);
	     types |= 1 << TYPEOF(ITEM(d)[i]);
	   }
	 }
	 d->type_field = types;
	 stack_pop_n_elems_keep_top(3); /* fun arr extra d -> d */
	 return;

      case T_MAPPING:
      case T_MULTISET:
	 /* ret[i]=fun[arr[i]]; */
	 pop_stack();
	 stack_swap();
	 f_rows(2);
	 return; 

      case T_STRING:
	 /* ret[i]=arr[i][fun](@extra); */
         push_array(d=allocate_array(n));
	 types = 0;
	 for (i=0; i<n; i++)
	 {
	    push_svalue(ITEM(a)+i);
	    push_svalue(mysp-2);
	    f_arrow(2);
	    if(UNSAFE_IS_ZERO(Pike_sp-1))
	    {
	      types |= BIT_INT;
	      pop_stack();
	      continue;
	    }
	    add_ref_svalue(mysp-1);
	    push_array_items(mysp[-1].u.array);
	    f_call_function(splice+1);
	    stack_pop_to_no_free (ITEM(d) + i);
	    types |= 1 << TYPEOF(ITEM(d)[i]);
	 }
	 d->type_field = types;
	 stack_pop_n_elems_keep_top(3); /* fun arr extra d -> d */
	 return;

      default:
	 SIMPLE_BAD_ARG_ERROR("map",2,
			      "function|program|object|"
			      "string|int(0..0)|multiset");
   }      
}

/*! @decl mixed filter(mixed arr, void|mixed fun, mixed ...extra)
 *!
 *!   Filters the elements in @[arr] through @[fun].
 *!
 *!   @[arr] is treated as a set of elements to be filtered, as
 *!   follows:
 *!
 *!   @dl
 *!     @item array
 *!     @item multiset
 *!     @item string
 *!       Each element is filtered with @[fun]. The return value is of
 *!       the same type as @[arr] and it contains the elements that
 *!       @[fun] accepted. @[fun] is applied in order to each element,
 *!       and that order is retained between the kept elements.
 *!
 *!       If @[fun] is an array, it should have the same length as
 *!       @[arr]. In this case, the elements in @[arr] are kept where
 *!       the corresponding positions in @[fun] are nonzero. Otherwise
 *!       @[fun] is used as described below.
 *!
 *!     @item mapping
 *!       The values are filtered with @[fun], and the index/value
 *!       pairs it accepts are kept in the returned mapping.
 *!
 *!     @item program
 *!       The program is treated as a mapping containing the
 *!       identifiers that are indexable from it and their values.
 *!
 *!     @item object
 *!       If there is a @[lfun::cast] method in the object, it's called
 *!       to try to cast the object to an array, a mapping, or a
 *!       multiset, in that order, which is then filtered as described
 *!       above.
 *!   @enddl
 *!
 *!   Unless something else is mentioned above, @[fun] is used as
 *!   filter like this:
 *!
 *!   @dl
 *!     @item function
 *!       @[fun] is called for each element. It gets the current
 *!       element as the first argument and @[extra] as the rest. The
 *!       element is kept if it returns true, otherwise it's filtered
 *!       out.
 *!
 *!     @item object
 *!       The object is used as a function like above, i.e. the
 *!       @[lfun::`()] method in it is called.
 *!
 *!     @item multiset
 *!     @item mapping
 *!       @[fun] is indexed with each element. The element is kept if
 *!       the result is nonzero, otherwise it's filtered out.
 *!
 *!     @item "zero or left out"
 *!       Each element that is callable is called with @[extra] as
 *!       arguments. The element is kept if the result of the call is
 *!       nonzero, otherwise it's filtered out. Elements that aren't
 *!       callable are also filtered out.
 *!
 *!     @item string
 *!       Each element is indexed with the given string. If the result
 *!       of that is zero then the element is filtered out, otherwise
 *!       the result is called with @[extra] as arguments. The element
 *!       is kept if the return value is nonzero, otherwise it's
 *!       filtered out.
 *!
 *!       This is typically used when @[arr] is a collection of
 *!       objects, and @[fun] is the name of some predicate function
 *!       in them.
 *!   @enddl
 *!
 *! @note
 *!   The function is never destructive on @[arr].
 *!
 *! @seealso
 *!   @[map()], @[foreach()]
 */
PMOD_EXPORT void f_filter(INT32 args)
{
   int n,i,m,k;
   struct array *a,*y,*f;
   struct svalue *mysp;

   if (args<1)
      SIMPLE_TOO_FEW_ARGS_ERROR("filter", 1);
   
   switch (TYPEOF(Pike_sp[-args]))
   {
      case T_ARRAY:
	 if (args >= 2 && TYPEOF(Pike_sp[1-args]) == T_ARRAY) {
	   if (Pike_sp[1-args].u.array->size != Pike_sp[-args].u.array->size)
	     SIMPLE_BAD_ARG_ERROR("filter", 2, "array of same size as the first");
	   pop_n_elems(args-2);
	 }
	 else {
	   memmove(Pike_sp-args+1,Pike_sp-args,args*sizeof(*Pike_sp));
	   dmalloc_touch_svalue(Pike_sp);
	   Pike_sp++;
	   add_ref_svalue(Pike_sp-args);
	   f_map(args);
	 }

	 f=Pike_sp[-1].u.array;
	 a=Pike_sp[-2].u.array;
	 n=a->size;
	 for (k=m=i=0; i<n; i++)
	    if (!UNSAFE_IS_ZERO(f->item+i))
	    {
	       push_svalue(a->item+i);
	       if (m++>32) 
	       {
		  f_aggregate(m);
		  m=0;
		  if (++k>32) {
		    f_add(k);
		    k=1;
		  }
	       }
	    }
	 if (m || !k) {
	   f_aggregate(m);
	   k++;
	 }
	 if (k > 1) f_add(k);
	 stack_pop_2_elems_keep_top();
	 return;

      case T_MAPPING:
      case T_PROGRAM:
      case T_FUNCTION:
	 /* mapping ret =                             
	       mkmapping(indices(arr),                
	                 map(values(arr),fun,@extra)); */
	 memmove(Pike_sp-args+2,Pike_sp-args,args*sizeof(*Pike_sp));
	 Pike_sp+=2;
	 mark_free_svalue (Pike_sp-args-2);
	 mark_free_svalue (Pike_sp-args-1);

	 push_svalue(Pike_sp-args);
	 f_indices(1);
	 dmalloc_touch_svalue(Pike_sp-1);
	 Pike_sp--;
	 Pike_sp[-args-2]=*Pike_sp;
	 dmalloc_touch_svalue(Pike_sp);
	 push_svalue(Pike_sp-args);
	 f_values(1);
	 Pike_sp--;
	 Pike_sp[-args-1]=*Pike_sp;
	 dmalloc_touch_svalue(Pike_sp);

	 assign_svalue(Pike_sp-args,Pike_sp-args-1); /* loop values only */
	 f_map(args);

	 y=Pike_sp[-3].u.array;
	 a=Pike_sp[-2].u.array;
	 f=Pike_sp[-1].u.array;
	 n=a->size;

	 for (m=i=0; i<n; i++)
	    if (!UNSAFE_IS_ZERO(f->item+i)) m++;

	 push_mapping(allocate_mapping(MAXIMUM(m,4)));

	 for (i=0; i<n; i++)
	    if (!UNSAFE_IS_ZERO(f->item+i))
	       mapping_insert(Pike_sp[-1].u.mapping,y->item+i,a->item+i);

	 stack_pop_n_elems_keep_top(3);
	 return;

      case T_MULTISET:
	 push_svalue(Pike_sp-args);      /* take indices from arr */
	 free_svalue(Pike_sp-args-1);    /* move it to top of stack */
	 mark_free_svalue (Pike_sp-args-1);
	 f_indices(1);              /* call f_indices */
	 Pike_sp--;                       
	 dmalloc_touch_svalue(Pike_sp);
	 Pike_sp[-args]=Pike_sp[0];           /* move it back */
	 f_filter(args);

	 push_multiset (mkmultiset (Pike_sp[-1].u.array));
	 free_array (Pike_sp[-2].u.array);
	 Pike_sp[-2] = Pike_sp[-1];
	 dmalloc_touch_svalue(Pike_sp-1);
	 Pike_sp--;
	 return;

      case T_STRING:
	 push_svalue(Pike_sp-args);      /* take indices from arr */
	 free_svalue(Pike_sp-args-1);    /* move it to top of stack */
	 mark_free_svalue (Pike_sp-args-1);
	 o_cast(NULL,T_ARRAY);      /* cast the string to an array */
	 Pike_sp--;                       
	 dmalloc_touch_svalue(Pike_sp);
	 Pike_sp[-args]=Pike_sp[0];           /* move it back */
	 f_filter(args);               
	 o_cast(NULL,T_STRING);     /* cast the array to a string */
	 return;

      case T_OBJECT:
	 mysp=Pike_sp+3-args;

	 {
            struct object *o = mysp[-3].u.object;
            int f = FIND_LFUN(o->prog->inherits[SUBTYPEOF(mysp[-3])].prog,
                              LFUN_CAST);

            if( f!=-1 )
            {
              ref_push_string(literal_array_string);
              apply_low(o, f, 1);
              if (TYPEOF(Pike_sp[-1]) == T_ARRAY)
              {
                free_svalue(mysp-3);
                mysp[-3]=*(--Pike_sp);
                dmalloc_touch_svalue(Pike_sp);
                f_filter(args);
                return;
              }
              pop_stack();

              ref_push_string(literal_mapping_string);
              apply_low(o, f, 1);
              if (TYPEOF(Pike_sp[-1]) == T_MAPPING)
              {
                free_svalue(mysp-3);
                mysp[-3]=*(--Pike_sp);
                dmalloc_touch_svalue(Pike_sp);
                f_filter(args);
                return;
              }
              pop_stack();

              ref_push_string(literal_multiset_string);
              apply_low(o, f, 1);
              if (TYPEOF(Pike_sp[-1]) == T_MULTISET)
              {
                free_svalue(mysp-3);
                mysp[-3]=*(--Pike_sp);
                dmalloc_touch_svalue(Pike_sp);
                f_filter(args);
                return;
              }
              pop_stack();
            }
	 }

	 SIMPLE_BAD_ARG_ERROR("filter",1,
			      "...|object that can be cast to array, multiset or mapping");

      default:
	 SIMPLE_BAD_ARG_ERROR("filter",1,
			      "array|mapping|program|function|"
			      "multiset|string|object");
   }
}

/* map() and filter() inherit sideeffects from their
 * second argument.
 */
static node *fix_map_node_info(node *n)
{
  int argno;
  node **cb_;
  /* Assume worst case. */
  int node_info = OPT_SIDE_EFFECT | OPT_EXTERNAL_DEPEND;

  /* Note: argument 2 has argno 1. */
  for (argno = 1; (cb_ = my_get_arg(&_CDR(n), argno)); argno++) {
    node *cb = *cb_;

    if ((cb->token == F_CONSTANT) &&
	(TYPEOF(cb->u.sval) == T_FUNCTION) &&
	(SUBTYPEOF(cb->u.sval) == FUNCTION_BUILTIN)) {
      if (cb->u.sval.u.efun->optimize == fix_map_node_info) {
	/* map() or filter(). */
	continue;
      }
      node_info &= cb->u.sval.u.efun->flags;
    }
    /* FIXME: Type-checking? */
    break;
  }

  if (!cb_) {
    yyerror("Too few arguments to map() or filter()!\n");
  }

  n->node_info |= node_info;
  n->tree_info |= node_info;

  return 0;	/* continue optimization */
}

/*! @decl array(int) enumerate(int n)
 *! @decl array enumerate(int n, void|mixed step, void|mixed start, @
 *!                       void|function operator)
 *!
 *!   Create an array with an enumeration, useful for initializing arrays
 *!   or as first argument to @[map()] or @[foreach()].
 *!
 *!   The defaults are: @[step] = 1, @[start] = 0, @[operator] = @[`+]
 *!
 *!   @section Advanced use
 *!   	The resulting array is calculated like this:
 *! @code
 *! array enumerate(int n, mixed step, mixed start, function operator)
 *! {
 *!   array res = allocate(n);
 *!   for (int i=0; i < n; i++)
 *!   {
 *!     res[i] = start;
 *!     start = operator(start, step);
 *!   }
 *!   return res;
 *! }
 *! @endcode
 *!   @endsection
 *!
 *! @seealso
 *!   @[map()], @[foreach()]
 */
void f_enumerate(INT32 args)
{
   struct array *d;
   int i;
   INT_TYPE n;

   if (args<1)
      SIMPLE_TOO_FEW_ARGS_ERROR("enumerate", 1);
   if (args<2) 
   {
      push_int(1);
      args++;
   }
   if (args<3)
   {
      push_int(0);
      args++;
   }

   if (args<=3 &&
       (TYPEOF(Pike_sp[1-args]) == T_INT &&
	TYPEOF(Pike_sp[2-args]) == T_INT))
   {
      INT_TYPE step,start;

      get_all_args("enumerate", args, "%+%i%i", &n, &step, &start);

      {
        INT_TYPE tmp;

        /* this checks if
         *      (n - 1) * step + start
         * will overflow. if it does, we continue with the slow path. If it does not,
         * adding step to start repeatedly will not overflow below. This check has
         * false positives, but is much simpler to check than e.g. doing one check
         * for every iteration
         */
        if (DO_INT_TYPE_MUL_OVERFLOW(n-1, step, &tmp) || INT_TYPE_ADD_OVERFLOW(tmp, start))
          goto slow_path;
      }

      pop_n_elems(args);
      push_array(d=allocate_array(n));
      for (i=0; i<n; i++)
      {
	 ITEM(d)[i].u.integer=start;
	 start+=step;
      }
      d->type_field = BIT_INT;
   }
   else if (args<=3 &&
	    ((TYPEOF(Pike_sp[1-args]) == T_INT ||
	      TYPEOF(Pike_sp[1-args]) == T_FLOAT) &&
	     (TYPEOF(Pike_sp[2-args]) == T_INT ||
	      TYPEOF(Pike_sp[2-args]) == T_FLOAT) ) )
   {
      FLOAT_TYPE step, start;

      get_all_args("enumerate", args, "%+%F%F", &n, &step, &start);
      pop_n_elems(args);
      push_array(d=allocate_array(n));
      for (i=0; i<n; i++)
      {
	 SET_SVAL(d->item[i], T_FLOAT, 0, float_number, start);
	 start+=step;
      }
      d->type_field = BIT_FLOAT;
   }
   else
   {
      TYPE_FIELD types;
slow_path:
      types = 0;
      get_all_args("enumerate", args, "%+", &n);
      if (args>4) pop_n_elems(args-4);
      push_array(d=allocate_array(n));
      if (args<4)
      {
	 push_svalue(Pike_sp-2); /* start */
	 for (i=0; i<n; i++)
	 {
	    assign_svalue_no_free(ITEM(d)+i,Pike_sp-1);
	    types |= 1 << TYPEOF(ITEM(d)[i]);
	    if (i<n-1)
	    {
	       push_svalue(Pike_sp-4); /* step */
	       f_add(2);
	    }
	 }
      }
      else
      {
	 push_svalue(Pike_sp-3); /* start */
	 for (i=0; i<n; i++)
	 {
	    assign_svalue_no_free(ITEM(d)+i,Pike_sp-1);
	    types |= 1 << TYPEOF(ITEM(d)[i]);
	    if (i<n-1)
	    {
	       push_svalue(Pike_sp-3); /* function */
	       stack_swap();
	       push_svalue(Pike_sp-6); /* step */
	       f_call_function(3);
	    }
	 }
      }
      d->type_field = types;
      pop_stack();
      stack_pop_n_elems_keep_top(args);
   }
}

/*! @module Program
 */


/*! @decl string defined(program x, string identifier)
 *!
 *!   Returns a string with filename and linenumber where @[identifier]
 *!   in @[x] was defined.
 *!
 *!   Returns @expr{0@} (zero) when no line can be found, e.g. for
 *!   builtin functions.
 *!
 *!   If @[identifier] can not be found in @[x] this function returns
 *!   where the program is defined.
 */
PMOD_EXPORT void f_program_identifier_defined(INT32 args)
{
  struct program *p;
  struct pike_string *ident;
  struct program *id_prog, *p2;
  struct identifier *id;
  INT_TYPE line;
  INT_TYPE offset;
  struct pike_string *file = NULL;

  if( !(p = program_from_svalue(Pike_sp-args)) )
      Pike_error("Illegal argument 1 to defined(program,string)\n");

  if( TYPEOF(Pike_sp[1-args]) != PIKE_T_STRING )
      Pike_error("Illegal argument 2 to defined(program,string)\n");
  else
      ident = Pike_sp[-args+1].u.string;

  if( (offset = find_shared_string_identifier( ident, p )) == -1 )
  {
      INT_TYPE line;
      struct pike_string *tmp = low_get_program_line(p, &line);

      pop_n_elems(args);

      if (tmp) 
      {
          push_string(tmp);
          if(line >= 1)
          {
              push_text(":");
              push_int(line);
              f_add(3);
          }
      }
      else
          push_int(0);
      return;
  }

  id = ID_FROM_INT(p, offset);
  id_prog = PROG_FROM_INT (p, offset);

  if(IDENTIFIER_IS_PIKE_FUNCTION( id->identifier_flags ) &&
     id->func.offset != -1)
      file = low_get_line(id_prog->program + id->func.offset, id_prog, &line);
  else if (IDENTIFIER_IS_CONSTANT (id->identifier_flags) &&
           id->func.const_info.offset >= 0 &&
           (p2 = program_from_svalue (&id_prog->constants[id->func.const_info.offset].sval)))
      file = low_get_program_line (p2, &line);
  else
      /* The program line is better than nothing for C functions. */
      file = low_get_program_line (p, &line);

  if (file)
  {
      pop_n_elems(args);
      if (line) {
          push_string(file);
          push_text(":");
          push_int(line);
          f_add(3);
      }
      else
          push_string (file);
      return;
  }
  pop_n_elems(args);
  push_int(0);
}

/*! @decl array(program) inherit_list(program p)
 *!
 *!   Returns an array with the programs that @[p] has inherited.
 */
PMOD_EXPORT void f_inherit_list(INT32 args)
{
  struct program *p;
  struct svalue *arg;
  struct object *par;
  int parid,e,q=0;

  get_all_args("inherit_list",args,"%*",&arg);
  if(TYPEOF(Pike_sp[-args]) == T_OBJECT)
    f_object_program(1);
  
  p=program_from_svalue(arg);
  if(!p) 
    SIMPLE_BAD_ARG_ERROR("inherit_list", 1, "program");

  if(TYPEOF(*arg) == T_FUNCTION)
  {
    par=arg->u.object;
    parid = SUBTYPEOF(*arg);
  }else{
    par=0;
    parid=-1;
  }

  check_stack(p->num_inherits);
  for(e=0;e<p->num_inherits;e++)
  {
    struct inherit *in=p->inherits+e;

    if(in->inherit_level==1)
    {
      if(in->prog->flags & PROGRAM_USES_PARENT)
      {
	switch(in->parent_offset)
	{
	  default:
	  {
	    struct external_variable_context tmp;
	    if(!par)
	    {
	      ref_push_program(in->prog);
	    }else{
	      tmp.o=par;
	      tmp.parent_identifier=parid;
	      tmp.inherit=INHERIT_FROM_INT(par->prog,parid);
	      
	      find_external_context(&tmp, in->parent_offset-1);
	      ref_push_function(tmp.o,
				in->parent_identifier +
				tmp.inherit->identifier_level);
	    }
	  }
	  break;
	  
	  case INHERIT_PARENT:
	    ref_push_function(in->parent, in->parent_identifier);
	    break;
	    
	  case OBJECT_PARENT:
	    if(par)
	    {
	      ref_push_function(par, parid);
	    }else{
	      ref_push_program(in->prog);
	    }
	    break;
	}
      }else{
	ref_push_program(in->prog);
      }
      q++;
    }
  }
  f_aggregate(q);
}

/*! @endmodule
 */

/*! @module Function
 */

/*! @decl string defined(function fun)
 *!
 *!   Returns a string with filename and linenumber where @[fun]
 *!   was defined.
 *!
 *!   Returns @expr{0@} (zero) when no line can be found, e.g. for
 *!   builtin functions and functions in destructed objects.
 */
PMOD_EXPORT void f_function_defined(INT32 args)
{
  check_all_args("Function.defined",args,BIT_FUNCTION, 0);

  if(SUBTYPEOF(Pike_sp[-args]) != FUNCTION_BUILTIN &&
     Pike_sp[-args].u.object->prog)
  {
    struct program *p = Pike_sp[-args].u.object->prog;
    struct program *id_prog, *p2;
    int func = SUBTYPEOF(Pike_sp[-args]);
    struct identifier *id;
    INT_TYPE line;
    struct pike_string *file = NULL;

    if (p == pike_trampoline_program) {
      struct pike_trampoline *t =
	(struct pike_trampoline *) Pike_sp[-args].u.object->storage;
      if (t->frame->current_object->prog) {
	p = t->frame->current_object->prog;
	func = t->func;
      }
    }

    id=ID_FROM_INT(p, func);
    id_prog = PROG_FROM_INT (p, func);

    if(IDENTIFIER_IS_PIKE_FUNCTION( id->identifier_flags ) &&
      id->func.offset != -1)
      file = low_get_line(id_prog->program + id->func.offset, id_prog, &line);
    else if (IDENTIFIER_IS_CONSTANT (id->identifier_flags) &&
	     id->func.const_info.offset >= 0 &&
	     (p2 = program_from_svalue (&id_prog->constants[id->func.const_info.offset].sval)))
      file = low_get_program_line (p2, &line);
    else
      /* The program line is better than nothing for C functions. */
      file = low_get_program_line (p, &line);

    if (file)
    {
      pop_n_elems(args);
      if (line) {
	push_string(file);
	push_text(":");
	push_int(line);
	f_add(3);
      }
      else
	push_string (file);
      return;
    }
  }

  pop_n_elems(args);
  push_int(0);
}

/*! @endmodule Function
 */

/* FIXME: Document catch and gauge. */

void init_builtin_efuns(void)
{
  struct program *pike___master_program;

  ADD_EFUN("gethrvtime",f_gethrvtime,
	   tFunc(tOr(tInt,tVoid),tInt), OPT_EXTERNAL_DEPEND);
  ADD_EFUN("gethrtime", f_gethrtime,
	   tFunc(tOr(tInt,tVoid),tInt), OPT_EXTERNAL_DEPEND);
  ADD_EFUN("gethrdtime", f_gethrdtime,
	   tFunc(tOr(tInt,tVoid),tInt), OPT_EXTERNAL_DEPEND);

#ifdef PROFILING
  ADD_EFUN("get_profiling_info", f_get_prof_info,
	   tFunc(tPrg(tObj),tArray), OPT_EXTERNAL_DEPEND);
#endif /* PROFILING */

  ADD_EFUN("_refs",f__refs,tFunc(tRef,tInt),OPT_EXTERNAL_DEPEND);
#ifdef PIKE_DEBUG
  ADD_EFUN("_leak",f__leak,tFunc(tRef,tInt),OPT_EXTERNAL_DEPEND);
#endif
  ADD_EFUN("_typeof", f__typeof, tFunc(tSetvar(0, tMix), tType(tVar(0))), 0);

  /* class __master
   * Used to prototype the master object.
   */
  start_new_program();
  ADD_PROTOTYPE("_main", tFunc(tArr(tStr) tArr(tStr),tVoid), 0);

  ADD_PROTOTYPE("cast_to_object", tFunc(tStr tStr tOr(tVoid, tObj), tObj), 0);
  ADD_PROTOTYPE("cast_to_program", tFunc(tStr tStr tOr(tVoid, tObj), tPrg(tObj)), 0);
  ADD_PROTOTYPE("compile_error", tFunc(tStr tInt tStr, tVoid), 0);
  ADD_PROTOTYPE("compile_warning", tFunc(tStr tInt tStr, tVoid), 0);
  ADD_PROTOTYPE("decode_charset", tFunc(tStr tStr, tStr), 0);
  ADD_PROTOTYPE("describe_backtrace", tFunc(tOr(tObj, tArr(tMix)) tOr(tVoid, tInt), tStr), 0);
  ADD_PROTOTYPE("handle_error", tFunc(tOr(tArr(tMix),tObj), tVoid), 0);
  ADD_PROTOTYPE("handle_import",
		tFunc(tStr tOr(tStr, tVoid) tOr(tObj, tVoid), tMix), 0);
  ADD_PROTOTYPE("handle_include", tFunc(tStr tStr tInt, tStr), 0);
  ADD_PROTOTYPE("handle_inherit", tFunc(tStr tStr tOr(tObj, tVoid), tPrg(tObj)), 0);
  ADD_PROTOTYPE("write", tFunc(tStr tOr(tVoid,tMix), tVoid), OPT_SIDE_EFFECT);
  ADD_PROTOTYPE("werror", tFunc(tStr tOr(tVoid,tMix), tVoid), OPT_SIDE_EFFECT);

  ADD_PROTOTYPE("read_include", tFunc(tStr, tStr), 0);
  ADD_PROTOTYPE("resolv",
		tFunc(tStr tOr(tStr,tVoid) tOr(tObj,tVoid), tMix), 0);

  pike___master_program = end_program();
  add_program_constant("__master", pike___master_program, 0);

  /* FIXME: */
  ADD_EFUN("replace_master", f_replace_master,
	   tFunc(tObj, tVoid), OPT_SIDE_EFFECT);
  ADD_EFUN("master", f_master,
	   tFunc(tNone, tObj), OPT_EXTERNAL_DEPEND);

  /* __master still contains a reference */
  free_program(pike___master_program);
  
/* function(string,void|mixed:void) */
  ADD_EFUN("add_constant", f_add_constant,
	   tFunc(tStr tOr(tVoid,tMix),tVoid),OPT_SIDE_EFFECT);

/* function(0=mixed ...:array(0)) */
  ADD_EFUN2("aggregate",debug_f_aggregate,
	    tFuncV(tNone,tSetvar(0,tMix),tArr(tVar(0))),
	    OPT_TRY_OPTIMIZE, optimize_f_aggregate, 0);
  
/* function(0=mixed ...:multiset(0)) */
  ADD_EFUN("aggregate_multiset",f_aggregate_multiset,
	   tFuncV(tNone,tSetvar(0,tMix),tSet(tVar(0))),OPT_TRY_OPTIMIZE);
  
/* function(0=mixed ...:mapping(0:0)) */
  ADD_EFUN2("aggregate_mapping",f_aggregate_mapping,
	    tFuncV(tNone,tSetvar(0,tMix),tMap(tVar(0),tVar(0))),
	    OPT_TRY_OPTIMIZE, fix_aggregate_mapping_type, 0);

/* function(:mapping(string:mixed)) */
  ADD_EFUN("all_constants",f_all_constants,
	   tFunc(tNone,tMap(tStr,tMix)),OPT_EXTERNAL_DEPEND);
  
  /* function(:object) */
  ADD_EFUN("get_active_compilation_handler",
	   f_get_active_compilation_handler,
	   tFunc(tNone, tObj), OPT_EXTERNAL_DEPEND);
  
  /* function(:object) */
  ADD_EFUN("get_active_error_handler",
	   f_get_active_error_handler,
	   tFunc(tNone, tObj), OPT_EXTERNAL_DEPEND);
  
/* function(int,void|0=mixed:array(0)) */
  ADD_EFUN("allocate", f_allocate,
	   tFunc(tInt tOr(tVoid,tSetvar(0,tMix)),tArr(tVar(0))), 0);
  
/* function(mixed:int) */
  ADD_EFUN("arrayp", f_arrayp,tFunc(tMix,tInt01),0);

/* function(string...:string) */
  ADD_EFUN("combine_path_nt",f_combine_path_nt,tFuncV(tNone,tStr,tStr),0);
  ADD_EFUN("combine_path_unix",f_combine_path_unix,tFuncV(tNone,tStr,tStr),0);
  ADD_EFUN("combine_path_amigaos",f_combine_path_amigaos,tFuncV(tNone,tStr,tStr),0);
#if defined(__NT__) || defined(__OS2__)
  ADD_EFUN("combine_path",f_combine_path_nt,tFuncV(tNone,tStr,tStr),0);
#else
#ifdef __amigaos__
  ADD_EFUN("combine_path",f_combine_path_amigaos,tFuncV(tNone,tStr,tStr),0);
#else
  ADD_EFUN("combine_path",f_combine_path_unix,tFuncV(tNone,tStr,tStr),0);
#endif
#endif
  
  ADD_EFUN("compile", f_compile,
	   tFunc(tStr tOr(tObj, tVoid) tOr(tInt, tVoid) tOr(tInt, tVoid) tOr(tPrg(tObj), tVoid) tOr(tObj, tVoid) ,tPrg(tObj)),
	   OPT_EXTERNAL_DEPEND);
  
/* function(1=mixed:1) */
  ADD_EFUN("copy_value",f_copy_value,tFunc(tSetvar(1,tMix),tVar(1)),0);
  
/* function(string:string)|function(string,string:int) */
  ADD_EFUN("crypt",f_crypt,
	   tOr(tFunc(tStr,tStr7),tFunc(tStr tStr,tInt01)),OPT_EXTERNAL_DEPEND);
  
/* function(object|void:void) */
  ADD_EFUN("destruct",f_destruct,tFunc(tOr(tObj,tVoid),tVoid),OPT_SIDE_EFFECT);
  
/* function(mixed,mixed:int) */
  ADD_EFUN("equal",f_equal,tFunc(tMix tMix,tInt01),OPT_TRY_OPTIMIZE);

  /* function(array(0=mixed),int|void,int|void:array(0)) */
  ADD_FUNCTION2("everynth",f_everynth,
		tFunc(tArr(tSetvar(0,tMix)) tOr(tInt,tVoid) tOr(tInt,tVoid),
		      tArr(tVar(0))), 0, OPT_TRY_OPTIMIZE);
  
/* function(int:void) */
  ADD_EFUN("exit",f_exit,tFuncV(tInt tOr(tVoid,tStr),tOr(tVoid,tMix),tVoid),
	   OPT_SIDE_EFFECT);
  
/* function(int:void) */
  ADD_EFUN("_exit",f__exit,tFunc(tInt,tVoid),OPT_SIDE_EFFECT);
  
/* function(mixed:int) */
  ADD_EFUN("floatp",  f_floatp,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);
  
/* function(mixed:int) */
  ADD_EFUN("functionp",  f_functionp,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);

/* function(mixed:int) */
  ADD_EFUN("callablep",  f_callablep,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);
  
/* function(string,string:int(0..1))|function(string,string*:array(string)) */
  ADD_EFUN("glob",f_glob,
           tOr(tFunc(tOr(tStr,tArr(tStr)) tStr,tInt01),tFunc(tOr(tStr,tArr(tStr)) tSetvar(1,tArr(tStr)),tVar(1))),
	   OPT_TRY_OPTIMIZE);
  
/* function(string,int|void:int) */
  ADD_EFUN("hash",f_hash,tFunc(tStr tOr(tInt,tVoid),tInt),OPT_TRY_OPTIMIZE);

  ADD_EFUN("hash_7_0",f_hash_7_0,
           tFunc(tStr tOr(tInt,tVoid),tInt),OPT_TRY_OPTIMIZE);

  ADD_EFUN("hash_7_4",f_hash_7_4,
           tFunc(tStr tOr(tInt,tVoid),tInt),OPT_TRY_OPTIMIZE);

  ADD_EFUN("hash_value",f_hash_value,tFunc(tMix,tInt),OPT_TRY_OPTIMIZE);

  ADD_EFUN2("indices",f_indices,
	    tOr3(tFunc(tArray,tArr(tIntPos)),
		 tFunc(tOr3(tMap(tSetvar(1,tMix),tMix),
			    tSet(tSetvar(1,tMix)),
			    tNStr(tSetvar(1,tInt))),
		       tArr(tVar(1))),
		 tFunc(tOr(tObj,tPrg(tObj)),tArr(tStr))),
	    OPT_TRY_OPTIMIZE,fix_indices_type,0);

  ADD_EFUN2("undefinedp", f_undefinedp, tFunc(tMix,tInt01), OPT_TRY_OPTIMIZE, 0, generate_undefinedp);
  ADD_EFUN2("destructedp", f_destructedp, tFunc(tMix,tInt01), OPT_TRY_OPTIMIZE,0, generate_destructedp);

/* function(mixed:int) */
  ADD_EFUN("intp", f_intp,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);

/* function(mixed:int) */
  ADD_EFUN("multisetp", f_multisetp,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);
  
/* function(string:string)|function(int:int) */
  ADD_EFUN("lower_case",f_lower_case,
	   tOr(tFunc(tStr,tStr), tFunc(tInt,tInt)),OPT_TRY_OPTIMIZE);
  
/* function(mixed:int) */
  ADD_EFUN("mappingp",f_mappingp,tFunc(tMix,tInt01),OPT_TRY_OPTIMIZE);
  
/* function(1=mixed,int:1) */
  ADD_EFUN("set_weak_flag",f_set_weak_flag,
	   tFunc(tSetvar(1,tMix) tInt,tVar(1)),OPT_SIDE_EFFECT);

  ADD_INT_CONSTANT("PIKE_WEAK_INDICES", PIKE_WEAK_INDICES, 0);
  ADD_INT_CONSTANT("PIKE_WEAK_VALUES", PIKE_WEAK_VALUES, 0);

/* function(void|object:object) */
  ADD_EFUN("next_object",f_next_object,
	   tFunc(tOr(tVoid,tObj),tObj),OPT_EXTERNAL_DEPEND);

  ADD_EFUN("_map_all_objects",f_map_all_objects,
           tFunc(tFunction,tIntPos),OPT_EXTERNAL_DEPEND);

  ADD_EFUN("_find_all_clones", f_find_all_clones,
	   tFunc(tPrg(tObj) tOr(tInt01,tVoid),tArr(tObj)), OPT_EXTERNAL_DEPEND);
  
/* function(string:string)|function(object:object)|function(mapping:mapping)|function(multiset:multiset)|function(program:program)|function(array:array) */
  ADD_EFUN("_next",f__next,
	   tOr6(tFunc(tStr,tStr),
		tFunc(tObj,tObj),
		tFunc(tMapping,tMapping),
		tFunc(tMultiset,tMultiset),
		tFunc(tPrg(tObj),tPrg(tObj)),
		tFunc(tArray,tArray)),OPT_EXTERNAL_DEPEND);
  
/* function(object:object)|function(mapping:mapping)|function(multiset:multiset)|function(program:program)|function(array:array) */
  ADD_EFUN("_prev",f__prev,
	   tOr5(tFunc(tObj,tObj),
		tFunc(tMapping,tMapping),
		tFunc(tMultiset,tMultiset),
		tFunc(tPrg(tObj),tPrg(tObj)),
		tFunc(tArray,tArray)),OPT_EXTERNAL_DEPEND);
  
  /* function(mixed:program|function) */
  ADD_EFUN2("object_program", f_object_program,
	    tFunc(tMix, tOr(tPrg(tObj),tFunction)),
	    OPT_TRY_OPTIMIZE, fix_object_program_type, 0);
  
/* function(mixed:int) */
  ADD_EFUN("objectp", f_objectp,tFunc(tMix,tInt01),0);
  
/* function(mixed:int) */
  ADD_EFUN("programp",f_programp,tFunc(tMix,tInt01),0);
  
/* function(:int) */
  ADD_EFUN("query_num_arg",f_query_num_arg,
	   tFunc(tNone,tInt),OPT_EXTERNAL_DEPEND);
  
/* function(int:void) */
  ADD_EFUN("random_seed",f_random_seed,
	   tFunc(tInt,tVoid),OPT_SIDE_EFFECT);

  ADD_EFUN("random_string",f_random_string,
	   tFunc(tInt,tStr8), OPT_EXTERNAL_DEPEND);
  
  ADD_EFUN2("replace", f_replace,
	    tOr5(tFunc(tStr tStr tStr,tStr),
		 tFunc(tStr tArr(tStr) tOr(tArr(tStr), tStr), tStr),
		 tFunc(tStr tMap(tStr,tStr),tStr),
		 tFunc(tSetvar(0,tArray) tMix tMix,tVar(0)),
		 tFunc(tSetvar(1,tMapping) tMix tMix,tVar(1))),
	    OPT_TRY_OPTIMIZE, optimize_replace, 0);
  
  ADD_EFUN("reverse",f_reverse,
	   tOr3(tFunc(tInt tOr(tVoid, tInt) tOr(tVoid, tInt), tInt),
		tFunc(tStr tOr(tVoid, tInt) tOr(tVoid, tInt), tStr),
		tFunc(tSetvar(0, tArray) tOr(tVoid, tInt) tOr(tVoid, tInt),
		      tVar(0))),0);
  
/* function(mixed,array:array) */
  ADD_EFUN("rows",f_rows,
	   tOr6(tFunc(tMap(tSetvar(0,tMix),tSetvar(1,tMix)) tArr(tVar(0)),
		      tArr(tVar(1))),
		tFunc(tSet(tSetvar(0,tMix)) tArr(tVar(0)), tArr(tInt01)),
		tFunc(tString tArr(tInt), tArr(tInt)),
		tFunc(tArr(tSetvar(0,tMix)) tArr(tInt), tArr(tVar(1))),
		tFunc(tArray tArr(tNot(tInt)), tArray),
		tFunc(tOr4(tObj,tFunction,tPrg(tObj),tInt) tArray, tArray)), 0);

  /* FIXME: Is the third arg a good idea when the first is a mapping? */
  ADD_EFUN("search",f_search,
	   tOr4(tFunc(tStr tOr(tStr,tInt) tOr(tVoid,tInt),
		      tInt),
		tFunc(tArr(tSetvar(0,tMix)) tVar(0) tOr(tVoid,tInt),
		      tInt),
		tFunc(tMap(tSetvar(1,tMix),tSetvar(2,tMix)) tVar(2) tOr(tVoid,tVar(1)),
		      tVar(1)),
		tFunc(tObj tMix tOr(tVoid, tSetvar(3, tMix)), tVar(3))),
	   0);
  
  ADD_EFUN2("has_prefix", f_has_prefix, tFunc(tOr(tStr,tObj) tStr,tInt01),
	    OPT_TRY_OPTIMIZE, 0, 0);

  ADD_EFUN2("has_suffix", f_has_suffix, tFunc(tStr tStr,tInt01),
	    OPT_TRY_OPTIMIZE, 0, 0);

  ADD_EFUN("has_index",f_has_index,
	   tOr5(tFunc(tStr tIntPos, tInt01),
		tFunc(tArray tIntPos, tInt01),
		tFunc(tSet(tSetvar(0,tMix)) tVar(0), tInt01),
		tFunc(tMap(tSetvar(1,tMix),tMix) tVar(1), tInt01),
		tFunc(tObj tMix, tInt01)),
	   OPT_TRY_OPTIMIZE);

  ADD_EFUN("has_value",f_has_value,
	   tOr5(tFunc(tStr tOr(tStr, tInt), tInt01),
		tFunc(tArr(tSetvar(0,tMix)) tVar(0), tInt01),
		tFunc(tMultiset tInt, tInt01),
		tFunc(tMap(tMix,tSetvar(1,tMix)) tVar(1), tInt01),
		tFunc(tObj tMix, tInt01)),
	   OPT_TRY_OPTIMIZE);

/* function(float|int,int|void:void) */
  ADD_EFUN("sleep", f_sleep,
	   tFunc(tOr(tFlt,tInt) tOr(tInt,tVoid),tVoid),OPT_SIDE_EFFECT);
  ADD_EFUN("delay", f_delay,
	   tFunc(tOr(tFlt,tInt) tOr(tInt,tVoid),tVoid),OPT_SIDE_EFFECT);
  
/* function(array(0=mixed),array(mixed)...:array(0)) */
  ADD_EFUN("sort",f_sort,
	   tFuncV(tArr(tSetvar(0,tMix)),tArr(tMix),tArr(tVar(0))),
	   OPT_SIDE_EFFECT);

  /* function(array(0=mixed)...:array(0)) */
  ADD_FUNCTION2("splice",f_splice,
		tFuncV(tNone,tArr(tSetvar(0,tMix)),tArr(tVar(0))), 0,
		OPT_TRY_OPTIMIZE);

  /* function(array:array) */
  ADD_FUNCTION2("uniq_array", f_uniq_array,
		tFunc(tArr(tSetvar(0,tMix)), tArr(tVar(0))), 0,
		OPT_TRY_OPTIMIZE);
  
/* function(mixed:int) */
  ADD_EFUN("stringp", f_stringp, tFunc(tMix,tInt01), 0);

  ADD_EFUN2("this_object", f_this_object,tFunc(tOr(tVoid,tIntPos),tObj),
	    OPT_EXTERNAL_DEPEND, optimize_this_object, generate_this_object);
  
/* function(mixed:void) */
  ADD_EFUN("throw",f_throw,tFunc(tMix,tOr(tMix,tVoid)),OPT_SIDE_EFFECT);
  
/* function(void|int(0..1):int(2..))|function(int(2..):float) */
  ADD_EFUN("time",f_time,
	   tOr(tFunc(tOr(tVoid,tInt01),tInt2Plus),
	       tFunc(tInt2Plus,tFlt)),
	   OPT_SIDE_EFFECT);
  
  /* function(array(0=mixed):array(0)) */
  ADD_FUNCTION2("transpose",f_transpose,
		tFunc(tArr(tSetvar(0,tMix)),tArr(tVar(0))), 0,
		OPT_TRY_OPTIMIZE);
  
/* function(string:string)|function(int:int) */
  ADD_EFUN("upper_case",f_upper_case,
	   tOr(tFunc(tStr,tStr),tFunc(tInt,tInt)),OPT_TRY_OPTIMIZE);

/* function(string|multiset:array(int))|function(array(0=mixed)|mapping(mixed:0=mixed)|object|program:array(0)) */
  ADD_EFUN2("values",f_values,
	   tOr(tFunc(tOr(tStr,tMultiset),tArr(tInt)),
	       tFunc(tOr4(tArr(tSetvar(0,tMix)),
			  tMap(tMix,tSetvar(0,tMix)),
			  tObj,tPrg(tObj)),
		     tArr(tVar(0)))),0,fix_values_type,0);
  
/* function(string|multiset:array(int))|function(array(0=mixed)|mapping(mixed:0=mixed)|object|program:array(0)) */
  ADD_EFUN2("types", f_types,
	    tOr3(tFunc(tOr3(tNStr(tSetvar(0,tInt)),
			    tArr(tSetvar(0,tMix)),
			    tMap(tMix,tSetvar(0,tMix))),
		       tArr(tType(tVar(0)))),
		 tFunc(tMultiset, tArr(tType(tInt1))),
		 tFunc(tOr(tObj,tPrg(tObj)), tArr(tType(tMix)))),0,NULL,0);
  
/* function(mixed:int) */
  ADD_EFUN2("zero_type",f_zero_type,tFunc(tMix,tInt01),0,0,generate_zero_type);
  
/* function(string,string:array) */
  ADD_EFUN("array_sscanf", f_sscanf,
	   tFunc(tStr tAttr("sscanf_format", tStr),
		 tArr(tAttr("sscanf_args", tMix))), OPT_TRY_OPTIMIZE);

/* function(string,string:array) */
  ADD_EFUN("array_sscanf_76", f_sscanf_76,
	   tFunc(tStr tAttr("sscanf_76_format", tStr),
		 tArr(tAttr("sscanf_args", tMix))), OPT_TRY_OPTIMIZE);

  ADD_EFUN("__handle_sscanf_format", f___handle_sscanf_format,
	   tFunc(tStr tStr tType(tMix) tType(tMix), tType(tMix)),
	   0);

  /* Some Wide-string stuff */

  /* function(string,int(0..2)|void:string(0..255)) */
  ADD_EFUN("string_to_unicode", f_string_to_unicode,
	   tFunc(tStr tOr(tInt02,tVoid),tStr8), OPT_TRY_OPTIMIZE);

  /* function(string(0..255),int(0..2)|void:string) */
  ADD_EFUN("unicode_to_string", f_unicode_to_string,
	   tFunc(tStr8 tOr(tInt02,tVoid),tStr), OPT_TRY_OPTIMIZE);

  /* function(string,int|void:string(0..255)) */
  ADD_EFUN("string_to_utf8", f_string_to_utf8,
	   tFunc(tStr tOr(tInt,tVoid),tStr8), OPT_TRY_OPTIMIZE);

  ADD_EFUN("string_filter_non_unicode", f_string_filter_non_unicode,
	   tFunc(tStr tOr(tInt,tVoid),tStr8), OPT_TRY_OPTIMIZE);
  
/* function(string(0..255),int|void:string) */
  ADD_EFUN("utf8_to_string", f_utf8_to_string,
	   tFunc(tStr8 tOr(tInt,tVoid),tStr), OPT_TRY_OPTIMIZE);


  ADD_EFUN("__parse_pike_type", f_parse_pike_type,
	   tFunc(tStr8,tStr8),OPT_TRY_OPTIMIZE);

  ADD_EFUN("__soft_cast", f___soft_cast,
	   tFunc(tSetvar(0, tType(tMix)) tSetvar(1, tType(tMix)),
		 tAnd(tVar(0), tVar(1))),
	   OPT_TRY_OPTIMIZE);

  ADD_EFUN("__low_check_call", f___low_check_call,
	   tFunc(tType(tCallable) tType(tMix) tOr(tInt,tVoid) tOr(tMix,tVoid),
		 tType(tCallable)),
	   OPT_TRY_OPTIMIZE);

  /* FIXME: Could have a stricter type. */
  ADD_EFUN("__get_return_type", f___get_return_type,
	   tFunc(tType(tCallable), tType(tMix)),
	   OPT_TRY_OPTIMIZE);

  /* FIXME: Could have a stricter type. */
  ADD_EFUN("__get_first_arg_type", f___get_first_arg_type,
	   tFunc(tType(tCallable), tType(tMix)),
	   OPT_TRY_OPTIMIZE);

  ADD_EFUN("__get_type_attributes", f___get_type_attributes,
	   tFunc(tType(tMix), tArr(tString)),
	   OPT_TRY_OPTIMIZE);

/* function(int:mapping(string:int)) */
  ADD_EFUN("localtime",f_localtime,
	   tFunc(tInt,tMap(tStr,tInt)),OPT_EXTERNAL_DEPEND);

/* function(int:mapping(string:int)) */
  ADD_EFUN("gmtime",f_gmtime,tFunc(tInt,tMap(tStr,tInt)),OPT_TRY_OPTIMIZE);

/* function(int,int,int,int,int,int,int,void|int:int)|function(object|mapping:int) */
  ADD_EFUN("mktime",f_mktime,
	   tOr(tFunc(tInt tInt tInt tInt tInt tInt
		     tOr(tVoid,tInt) tOr(tVoid,tInt),tInt),
	       tFunc(tOr(tObj,tMapping),tInt)),OPT_TRY_OPTIMIZE);

/* function(:void) */
  ADD_EFUN("_verify_internals",f__verify_internals,
	   tFunc(tNone,tVoid),OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);

#ifdef PIKE_DEBUG
  
/* function(int:int) */
  ADD_EFUN("_debug",f__debug,
	   tFunc(tIntPos,tIntPos),OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);

/* function(int:int) */
  ADD_EFUN("_optimizer_debug",f__optimizer_debug,
	   tFunc(tIntPos,tIntPos),OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);

/* function(int:int) */
  ADD_EFUN("_assembler_debug",f__assembler_debug,
	   tFunc(tInt,tIntPos), OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);

  ADD_EFUN("_dump_program_tables", f__dump_program_tables,
	   tFunc(tPrg(tObj) tOr(tIntPos, tVoid), tVoid),
	   OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);

#ifdef YYDEBUG
  
/* function(int:int) */
  ADD_EFUN("_compiler_trace",f__compiler_trace,
	   tFunc(tIntPos,tIntPos),OPT_SIDE_EFFECT|OPT_EXTERNAL_DEPEND);
#endif /* YYDEBUG */
#endif
  
/* function(:mapping(string:int)) */
  ADD_EFUN("_memory_usage",f__memory_usage,
	   tFunc(tNone,tMap(tStr,tInt)),OPT_EXTERNAL_DEPEND);

  ADD_EFUN("_size_object",f__size_object,
	   tFunc(tObj,tInt),OPT_EXTERNAL_DEPEND);


  /* function(:int) */
  ADD_EFUN("gc", f_gc, tFunc(tOr(tMix, tVoid), tInt), OPT_SIDE_EFFECT);

  /* function(:string) */
  ADD_EFUN("version", f_version,tFunc(tNone,tStr), OPT_TRY_OPTIMIZE);

  /* Note: The last argument to the encode and decode functions is
   * intentionally not part of the prototype, to keep it free for
   * other uses in the future. */

/* function(mixed,void|object:string) */
  ADD_EFUN("encode_value", f_encode_value,
	   tFunc(tMix tOr(tVoid,tObj),tStr8), OPT_TRY_OPTIMIZE);

  /* function(mixed,void|object:string) */
  ADD_EFUN("encode_value_canonic", f_encode_value_canonic,
	   tFunc(tMix tOr(tVoid,tObj),tStr8), OPT_TRY_OPTIMIZE);

/* function(string,void|object:mixed) */
  ADD_EFUN("decode_value", f_decode_value,
	   tFunc(tStr tOr3(tVoid,tObj,tInt_10),tMix), OPT_TRY_OPTIMIZE);
  
/* function(object,string:int) */
  ADD_EFUN("object_variablep", f_object_variablep,
	   tFunc(tObj tStr,tInt), OPT_EXTERNAL_DEPEND);

  /* function(array(mapping(int:mixed)):array(int)) */
  ADD_FUNCTION2("interleave_array", f_interleave_array,
		tFunc(tArr(tMap(tInt, tMix)), tArr(tInt)), 0,
		OPT_TRY_OPTIMIZE);
  /* function(array(0=mixed),array(1=mixed):array(array(array(0)|array(1))) */
  ADD_FUNCTION2("diff", f_diff,
		tFunc(tArr(tSetvar(0,tMix)) tArr(tSetvar(1,tMix)),
		      tArr(tArr(tOr(tArr(tVar(0)),tArr(tVar(1)))))), 0,
		OPT_TRY_OPTIMIZE);

  /* Generate the n:th permutation of the array given as the first argument */
  ADD_FUNCTION2("permute", f_permute, tFunc(tArray tIntPos,tArray), 0,
		OPT_TRY_OPTIMIZE);

  /* function(array,array:array(int)) */
  ADD_FUNCTION2("diff_longest_sequence", f_diff_longest_sequence,
		tFunc(tArray tArray,tArr(tInt)), 0, OPT_TRY_OPTIMIZE);
  /* function(array,array:array(int)) */
  ADD_FUNCTION2("diff_dyn_longest_sequence", f_diff_dyn_longest_sequence,
		tFunc(tArray tArray,tArr(tInt)), 0, OPT_TRY_OPTIMIZE);
  /* function(array,array:array(array)) */
  ADD_FUNCTION2("diff_compare_table", f_diff_compare_table,
		tFunc(tArray tArray, tArr(tArr(tInt))), 0, OPT_TRY_OPTIMIZE);
  /* function(array:array(int)) */
  ADD_FUNCTION2("longest_ordered_sequence", f_longest_ordered_sequence,
		tFunc(tArray,tArr(tInt)), 0, OPT_TRY_OPTIMIZE);

#define tMapStuff(IN,SUB,OUTFUN,OUTSET,OUTPROG,OUTMIX,OUTARR,OUTMAP) \
  tOr6( tFuncV(IN tFuncV(SUB,tSetvar(0,tAnd(tMix,tZero)),	     \
			 tSetvar(2,tAny)),tVar(0),		     \
	       OUTFUN),						     \
	tFuncV(IN tSet(tMix),tMix,OUTSET), \
	tFuncV(IN tMap(tMix, tSetvar(2,tMix)), tMix, OUTMAP), \
        tFuncV(IN tArray, tMix, OUTARR), \
	tIfnot(tFuncV(IN, tNot(tMix), tMix), \
	       tFuncV(IN, tMix, OUTMIX)), \
	tFuncV(IN, tVoid, OUTMIX) )

  ADD_EFUN2("map", f_map,
	    tOr7(tMapStuff(tArr(tSetvar(1,tMix)),tVar(1),
			   tArr(tVar(2)),
			   tArr(tInt01),
			   tArr(tObj),
			   tArr(tMix),
			   tArr(tArr(tMix)),
			   tArr(tOr(tInt0,tVar(2)))),

		 tMapStuff(tMap(tSetvar(3,tMix),tSetvar(1,tMix)),tVar(1),
			   tMap(tVar(3),tVar(2)),
			   tMap(tVar(3),tInt01),
			   tMap(tVar(3),tObj),
			   tMap(tVar(3),tMix),
			   tMap(tVar(3),tArr(tMix)),
			   tMap(tVar(3),tOr(tInt0,tVar(2)))),
		
 		 tMapStuff(tSet(tSetvar(1,tMix)),tVar(1),
			   tSet(tVar(2)),
			   tSet(tInt01),
			   tSet(tObj),
			   tSet(tMix),
			   tSet(tArr(tMix)),
			   tSet(tOr(tInt0,tVar(2)))),

		 tMapStuff(tAnd(tNot(tArray),tOr(tPrg(tObj),tFunction)),tMix,
			   tMap(tStr,tVar(2)),
			   tMap(tStr,tInt01),
			   tMap(tStr,tObj),
			   tMap(tStr,tMix),
			   tMap(tStr,tArr(tMix)),
			   tMap(tStr,tOr(tInt0,tVar(2)))),

		 tOr4( tFuncV(tString tFuncV(tInt,tMix,tInt),tMix,tString), 
		       tFuncV(tString tFuncV(tInt,tMix,tInt),tMix,tString),
		       tFuncV(tString tSet(tMix),tMix,tString),
		       tFuncV(tString tMap(tMix,tInt), tMix, tString) ),

		 tOr4 (tFuncV(tArr(tStringIndicable) tString,tMix,tArray),
		       tFuncV(tMap(tSetvar(3,tMix),tStringIndicable) tString,tMix,
			      tMap(tVar(3),tMix)),
		       tFuncV(tSet(tStringIndicable) tString,tMix,tSet(tMix)),
		       tFuncV(tOr(tPrg(tObj),tFunction) tString,tMix,tMapping)),

		 tFuncV(tObj,tMix,tMix) ),
	    OPT_TRY_OPTIMIZE, fix_map_node_info, 0);
  
#if 1
  ADD_EFUN2("filter", f_filter,
	    tOr3(tFuncV(tSetvar(1,tOr4(tArray,tMapping,tMultiset,tString)),
			tMixed,
			tVar(1)),
		 tFuncV(tOr(tPrg(tObj),tFunction),tMixed,tMap(tString,tMix)),
		 tFuncV(tObj,tMix,tMix) ) ,
	    OPT_TRY_OPTIMIZE, fix_map_node_info, 0);
#else
  ADD_EFUN2("filter", f_filter,
	    tOr3(tFuncV(tSetvar(1,tOr4(tArray,tMapping,tMultiset,tString)),
			tOr5(tFuncV(tMix, tMix, tAnd(tInt01,tNot(tVoid))),
			     tArray, tMapping, tMultiset, tString),
			tVar(1)),
		 tFuncV(tOr(tPrg(tObj),tFunction),tMixed,tMap(tString,tMix)),
		 tFuncV(tObj,tMix,tMix) ) ,
	    OPT_TRY_OPTIMIZE, fix_map_node_info, 0);
#endif /* 1 */

  ADD_EFUN("enumerate",f_enumerate,
	   tOr8(tFunc(tIntPos,tArr(tInt)),
		tFunc(tIntPos tInt,tArr(tInt)),
		tFunc(tIntPos tInt tOr(tVoid,tInt),tArr(tInt)),
		tFunc(tIntPos tFloat tOr3(tVoid,tInt,tFloat),tArr(tFloat)),
		tFunc(tIntPos tOr(tInt,tFloat) tFloat,tArr(tFloat)),
		tFunc(tIntPos tMix tObj,tArr(tVar(1))),
		tFunc(tIntPos tObj tOr(tVoid,tMix),tArr(tVar(1))),
		tFunc(tIntPos tMix tMix 
		      tFuncV(tNone,tMix,tSetvar(1,tMix)),tArr(tVar(1)))),
	   OPT_TRY_OPTIMIZE);
		
  ADD_FUNCTION2("inherit_list", f_inherit_list,
		tFunc(tOr(tObj,tPrg(tObj)),tArr(tPrg(tObj))), 0, OPT_TRY_OPTIMIZE);
  ADD_FUNCTION2("program_identifier_defined", f_program_identifier_defined,
               tFunc(tOr(tObj,tPrg(tObj)) tString,tString), 0, OPT_TRY_OPTIMIZE);
  ADD_FUNCTION2("function_defined", f_function_defined,
	       tFunc(tFunction,tString), 0, OPT_TRY_OPTIMIZE);

#ifdef DEBUG_MALLOC
  
/* function(void:void) */
  ADD_EFUN("_reset_dmalloc",f__reset_dmalloc,
	   tFunc(tVoid,tVoid),OPT_SIDE_EFFECT);
  ADD_EFUN("_dmalloc_set_name",f__dmalloc_set_name,
	   tOr(tFunc(tStr tIntPos,tVoid), tFunc(tVoid,tVoid)),OPT_SIDE_EFFECT);
  ADD_EFUN("_list_open_fds",f__list_open_fds,
	   tFunc(tVoid,tVoid),OPT_SIDE_EFFECT);
  ADD_EFUN("_dump_dmalloc_locations",f__dump_dmalloc_locations,
	   tFunc(tSetvar(1,tMix),tVar(1)),OPT_SIDE_EFFECT);
#endif
#ifdef PIKE_DEBUG
  
/* function(1=mixed:1) */
  ADD_EFUN("_locate_references",f__locate_references,
	   tFunc(tSetvar(1,tMix),tVar(1)),OPT_SIDE_EFFECT);
  ADD_EFUN("_describe",f__describe,
	   tFunc(tSetvar(1,tMix),tVar(1)),OPT_SIDE_EFFECT);
  ADD_EFUN("_gc_set_watch", f__gc_set_watch,
	   tFunc(tComplex,tVoid), OPT_SIDE_EFFECT);
  ADD_EFUN("_dump_backlog", f__dump_backlog,
	   tFunc(tNone,tVoid), OPT_SIDE_EFFECT);
  ADD_EFUN("_gdb_breakpoint", pike_gdb_breakpoint,
	   tFuncV(tNone,tMix,tVoid), OPT_SIDE_EFFECT);
#endif

  ADD_EFUN("_gc_status",f__gc_status,
	   tFunc(tNone,tMap(tString,tOr(tInt,tFloat))),
	   OPT_EXTERNAL_DEPEND);
  ADD_FUNCTION ("implicit_gc_real_time", f_implicit_gc_real_time,
		tFunc(tOr(tInt,tVoid),tInt), OPT_EXTERNAL_DEPEND);
  ADD_FUNCTION ("count_memory", f_count_memory,
		tFuncV(tOr(tInt,tMap(tString,tInt)),
		       tOr8(tArray,tMultiset,tMapping,tObj,tPrg(tObj),
			    tString,tType(tMix),tInt),
		       tInt), 0);
  ADD_FUNCTION("identify_cycle", f_identify_cycle,
	       tFunc(tOr7(tArray,tMultiset,tMapping,tObj,tPrg(tObj),
			  tString,tType(tMix)),
		     tArr(tOr7(tArray,tMultiset,tMapping,tObj,tPrg(tObj),
			       tString,tType(tMix)))), 0);

  ADD_INT_CONSTANT ("NATIVE_INT_MAX", MAX_INT_TYPE, 0);
  ADD_INT_CONSTANT ("NATIVE_INT_MIN", MIN_INT_TYPE, 0);

  /* Maybe make PIKEFLOAT_MANT_DIG, PIKEFLOAT_MIN_EXP and
   * PIKEFLOAT_MAX_EXP available, but do we have to export FLT_RADIX
   * too? It'd be nice to always assume it's 2 to save the pike
   * programmer from that headache. */
  ADD_INT_CONSTANT ("FLOAT_DIGITS_10", PIKEFLOAT_DIG, 0);
  ADD_INT_CONSTANT ("FLOAT_MIN_10_EXP", PIKEFLOAT_MIN_10_EXP, 0);
  ADD_INT_CONSTANT ("FLOAT_MAX_10_EXP", PIKEFLOAT_MAX_10_EXP, 0);
  ADD_FLOAT_CONSTANT ("FLOAT_MAX", PIKEFLOAT_MAX, 0);
  ADD_FLOAT_CONSTANT ("FLOAT_MIN", PIKEFLOAT_MIN, 0);
  ADD_FLOAT_CONSTANT ("FLOAT_EPSILON", PIKEFLOAT_EPSILON, 0);

#ifdef WITH_DOUBLE_PRECISION_SVALUE
  ADD_INT_CONSTANT("__DOUBLE_PRECISION_FLOAT__",1,0);
#else 
#ifdef WITH_LONG_DOUBLE_PRECISION_SVALUE
  ADD_INT_CONSTANT("__LONG_DOUBLE_PRECISION_FLOAT__",1,0);
#else
  ADD_INT_CONSTANT("__FLOAT_PRECISION_FLOAT__",1,0);
#endif
#endif

  ADD_INT_CONSTANT ("DESTRUCT_EXPLICIT", DESTRUCT_EXPLICIT, 0);
  ADD_INT_CONSTANT ("DESTRUCT_NO_REFS", DESTRUCT_NO_REFS, 0);
  ADD_INT_CONSTANT ("DESTRUCT_GC", DESTRUCT_GC, 0);
  ADD_INT_CONSTANT ("DESTRUCT_CLEANUP", DESTRUCT_CLEANUP, 0);

  ADD_INT_CONSTANT("LOWEST_COMPAT_MAJOR", LOWEST_COMPAT_MAJOR, 0);
  ADD_INT_CONSTANT("LOWEST_COMPAT_MINOR", LOWEST_COMPAT_MINOR, 0);
}

void exit_builtin_efuns(void)
{
  free_callback_list(&memory_usage_callback);
}
