/* -*- c -*-
|| 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.
|| $Id: d79efee5888889904fc6fac54da2159705e2633f $
*/

#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_memory.h"
#include "threads.h"
#include "module_support.h"
#include "cyclic.h"
#include "bignum.h"
#include "main.h"
#include "operators.h"
#include "builtin_functions.h"
#include "fsort.h"
#include "port.h"
#include "gc.h"
#include "block_alloc.h"
#include "pikecode.h"

#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <math.h>

DECLARATIONS

/*! @decl array(array(int|string|type)) describe_program(program p)
 *! @belongs Debug
 *!
 *! Debug function for showing the symbol table of a program.
 *!
 *! @returns
 *!   Returns an array of arrays with the following information
 *!   for each symbol in @[p]:
 *!   @array
 *!     @elem int modifiers
 *!       Bitfield with the modifiers for the symbol.
 *!     @elem string symbol_name
 *!       Name of the symbol.
 *!     @elem type value_type
 *!       Value type for the symbol.
 *!     @elem int symbol_type
 *!       Type of symbol.
 *!     @elem int symbol_offset
 *!       Offset into the code or data area for the symbol.
 *!     @elem int inherit_offset
 *!       Offset in the inherit table to the inherit containing
 *!       the symbol.
 *!     @elem int inherit_level
 *!       Depth in the inherit tree for the inherit containing
 *!       the symbol.
 *!   @endarray
 *!
 *! @note
 *!   The API for this function is not fixed, and has changed
 *!   since Pike 7.6. In particular it would make sense to return
 *!   an array of objects instead, and more information about the
 *!   symbols might be added.
 */
PMOD_EXPORT
PIKEFUN array(array(int|string)) _describe_program(mixed x)
     efun;
{
  struct program *p;
  struct array *res;
  int i;

  if (!(p = program_from_svalue(Pike_sp - args)))
    SIMPLE_BAD_ARG_ERROR("_describe_program", 1, "program");

  for (i=0; i < (int)p->num_identifier_references;i++) {
    struct reference *ref = p->identifier_references + i;
    struct identifier *id = ID_FROM_PTR(p, ref);
    struct inherit *inh = INHERIT_FROM_PTR(p, ref);
    push_int(ref->id_flags);
    ref_push_string(id->name);
    ref_push_type_value(id->type);
    push_int(id->identifier_flags);
    if (IDENTIFIER_IS_C_FUNCTION(id->identifier_flags)) {
      push_int(-2);
    } else {
      push_int(id->func.offset);
    }
    push_int(ref->inherit_offset);
    push_int(inh->inherit_level);
    f_aggregate(7);
  }
  f_aggregate(p->num_identifier_references);
  dmalloc_touch_svalue(Pike_sp-1);
  res = Pike_sp[-1].u.array;
  Pike_sp--;
  pop_n_elems(args);
  push_array(res);
}

/*! @decl string basetype(mixed x)
 *!
 *! Same as sprintf("%t",x);
 *!
 *! @seealso
 *! @[sprintf()]
 */
PMOD_EXPORT
PIKEFUN string basetype(mixed x)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  int t=x->type;
  struct program *p;
  if(x->type == T_OBJECT && (p = x->u.object->prog))
  {
    ptrdiff_t fun = FIND_LFUN(p->inherits[x->subtype].prog, LFUN__SPRINTF);
    if(fun != -1)
    {
      push_int('t');
      f_aggregate_mapping(0);
      apply_low(x->u.object,
		fun + p->inherits[x->subtype].identifier_level, 2);
      if(Pike_sp[-1].type == T_STRING)
      {
	stack_swap();
	pop_stack();
	return;
      } else if (UNSAFE_IS_ZERO(Pike_sp-1)) {
	pop_n_elems(2);
	push_constant_text("object");
	return;
      } else {
	Pike_error("Non-string returned from _sprintf()\n");
      }
    }
  }
  pop_stack();
  switch(t)
  {
    case T_ARRAY: push_constant_text("array"); break;
    case T_FLOAT: push_constant_text("float"); break;
    case T_FUNCTION: push_constant_text("function"); break;
    case T_INT: push_constant_text("int"); break;
    case T_MAPPING: push_constant_text("mapping"); break;
    case T_MULTISET: push_constant_text("multiset"); break;
    case T_OBJECT: push_constant_text("object"); break;
    case T_PROGRAM: push_constant_text("program"); break;
    case T_STRING: push_constant_text("string"); break;
    case T_TYPE: push_constant_text("type"); break;
    case T_ZERO: push_constant_text("zero"); break;
    case T_VOID: push_constant_text("void"); break;
      /* The following are internal and shouldn't be applicable in normal use. */
    case T_SVALUE_PTR: push_constant_text("svalue_ptr"); break;
    case T_OBJ_INDEX: push_constant_text("obj_index"); break;
    case T_MAPPING_DATA: push_constant_text("mapping_data"); break;
    case T_PIKE_FRAME: push_constant_text("pike_frame"); break;
    case T_MULTISET_DATA: push_constant_text("multiset_data"); break;
    default: push_constant_text("unknown"); break;
  }
}


/*! @decl string int2char(int x)
 *! @appears String.int2char
 *!
 *! Same as sprintf("%c",x);
 *!
 *! @seealso
 *! @[sprintf()]
 */
PMOD_EXPORT
PIKEFUN string int2char(int|object x)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  int c;
  struct program *p;
  if(x->type == T_OBJECT && (p = x->u.object->prog))
  {
    ptrdiff_t fun = FIND_LFUN(p->inherits[x->subtype].prog, LFUN__SPRINTF);
    if(fun != -1)
    {
      push_int('c');
      f_aggregate_mapping(0);
      apply_low(x->u.object,
		fun + p->inherits[x->subtype].identifier_level, 2);
      if(Pike_sp[-1].type == T_STRING)
      {
	stack_swap();
	pop_stack();
	return;
      }
      Pike_error("Non-string returned from _sprintf()\n");
    }
  }
  if(x->type != T_INT)
    SIMPLE_BAD_ARG_ERROR("int2char", 1, "int");

  c=x->u.integer;

  if(c>=0 && c<256)
  {
    struct pike_string *s;
    s=begin_shared_string(1);
    s->str[0]=c;
    RETURN end_shared_string(s);
  }else{
    struct string_builder tmp;
    init_string_builder(&tmp,0);
    string_builder_putchar(&tmp, c);
    RETURN finish_string_builder(&tmp);
  }
}

/*! @decl string int2hex(int x)
 *! @appears String.int2hex
 *!
 *! Same as @expr{sprintf("%x",x);@}, i.e. returns the integer @[x] in
 *! hexadecimal base using lower cased symbols.
 *!
 *! @seealso
 *! @[sprintf()]
 */
PMOD_EXPORT
PIKEFUN string int2hex(int|object x)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  INT_TYPE c;
  unsigned INT_TYPE n;
  int len;
  struct pike_string *s;
  struct program *p;

  if(x->type == T_OBJECT && (p = x->u.object->prog))
  {
    ptrdiff_t fun = FIND_LFUN(p->inherits[x->subtype].prog, LFUN__SPRINTF);
    if(fun != -1)
    {
      push_int('x');
      f_aggregate_mapping(0);
      apply_low(x->u.object,
		fun + p->inherits[x->subtype].identifier_level, 2);
      if(Pike_sp[-1].type == T_STRING)
      {
	stack_swap();
	pop_stack();
	return;
      }
      Pike_error("Non-string returned from _sprintf()\n");
    }
  }
  if(x->type != T_INT)
    SIMPLE_BAD_ARG_ERROR("int2hex", 1, "int");

  c=x->u.integer;

  len=1;
  if(c<0) {
    len++;
    n=(-c)&((unsigned INT_TYPE)(-1));
  }else{
    n=c;
  }
  while(n>65535) { n>>=16; len+=4; }
  while(n>15) { n>>=4; len++; }
  
  s=begin_shared_string(len);
  if(!c)
  {
    s->str[0]='0';
  }else{
    if(c<0)
    {
      s->str[0]='-';
      n=(-c)&((unsigned INT_TYPE)(-1));
    }else{
      n=c;
    }
    while(len && n)
    {
      s->str[--len]="0123456789abcdef"[n&0xf];
      n>>=4;
    }
  }
  RETURN end_shared_string(s);
}


static INLINE int hexchar( int v )
{
  return v<10 ? v+'0' : (v-10)+'a';
}

/*! @decl string string2hex(string data)
 *! @appears String.string2hex
 *!
 *! Convert a string of binary data to a hexadecimal string.
 *!
 *! @seealso
 *!   @[hex2string()]
 */
PMOD_EXPORT
PIKEFUN string string2hex(string s)
  errname String.string2hex;
  optflags OPT_TRY_OPTIMIZE;
{
  struct pike_string *hex;
  unsigned char *st = (unsigned char *)s->str;
  int i;

  if (s->size_shift)
    Pike_error("Bad argument 1 to string2hex(), expected 8-bit string.\n");

  hex = begin_shared_string(2 * s->len);

  for (i=0; i<s->len; i++) {
    hex->str[i<<1] = hexchar(st[i]>>4);
    hex->str[i<<1|1] = hexchar(st[i]&15);
   }

  RETURN end_shared_string(hex);
}

/*! @decl string hex2string(string hex)
 *! @appears String.hex2string
 *!
 *! Convert a string of hexadecimal digits to binary data.
 *!
 *! @seealso
 *!   @[string2hex()]
 */
PMOD_EXPORT
PIKEFUN string hex2string(string hex)
  errname String.hex2string;
  optflags OPT_TRY_OPTIMIZE;
{
  struct pike_string *s;
  int i, o=0;
  unsigned char *q = (unsigned char *)hex->str;
  int l = hex->len>>1;
  if(hex->size_shift) Pike_error("Only hex digits allowed.\n");
  if(hex->len&1) Pike_error("Can't have odd number of digits.\n");

  s = begin_shared_string(l);
  for (i=0; i<l; i++)
  {
      s->str[i]  = (q[o]<='9' ? q[o]-'0' :((q[o]+9)&15))<<4; o++;
      s->str[i] |= (q[o]<='9' ? q[o]-'0': ((q[o]+9)&15));    o++;
  }
  RETURN end_shared_string(s);
}

/*! @decl array column(array data, mixed index)
 *!
 *! Extract a column from a two-dimensional array.
 *!
 *! This function is exactly equivalent to:
 *! @code
 *! map(@[data], lambda(mixed x,mixed y) { return x[y]; }, @[index])
 *! @endcode
 *!
 *! Except of course it is a lot shorter and faster.
 *! That is, it indices every index in the array data on the value of
 *! the argument index and returns an array with the results.
 *!
 *! @seealso
 *! @[rows()]
 */
PMOD_EXPORT
PIKEFUN array column(array data, mixed index)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  RETURN array_column (data, index, 1);
}

/*! @decl multiset mkmultiset(array a)
 *!
 *! This function creates a multiset from an array.
 *!
 *! @seealso
 *! @[aggregate_multiset()]
 *!
 */
PMOD_EXPORT
PIKEFUN multiset(1) mkmultiset(array(1=mixed) a)
  efun;
  optflags OPT_TRY_OPTIMIZE|OPT_EXTERNAL_DEPEND;
{
  RETURN mkmultiset(a);
}

/*! @decl int trace(int level, void|string facility, void|int all_threads)
 *!
 *! This function changes the trace level for the subsystem identified
 *! by @[facility] to @[level]. If @[facility] is zero or left out, it
 *! changes the global trace level which affects all subsystems.
 *!
 *! Enabling tracing causes messages to be printed to stderr. A higher
 *! trace level includes the output from all lower levels. The lowest
 *! level is zero which disables all trace messages.
 *!
 *! See the @tt{-t@} command-line option for more information.
 *!
 *! @param level
 *!   If @[facility] is specified then there is typically only one
 *!   trace level for it, i.e. it's an on-or-off toggle. The global
 *!   trace levels, when @[facility] isn't specified, are:
 *!
 *!   @int
 *!   @value 1
 *!  	Trace calls to Pike functions and garbage collector runs.
 *!   @value 2
 *!  	Trace calls to builtin functions.
 *!   @value 3
 *!  	Trace every interpreted opcode.
 *!   @value 4
 *!  	Also trace the opcode arguments.
 *!   @endint
 *!
 *! @param facility
 *!   Valid facilities are:
 *!
 *!   @string
 *!   @value "gc"
 *!     Trace the doings of the garbage collector. The setting is
 *!     never thread local. @[level] has two different meanings:
 *!     @dl
 *!     @item 1..2
 *!       Trace the start and end of each gc run.
 *!     @item 3..
 *!       Additionally show info about the collected garbage, to aid
 *!       hunting down garbage problems. This currently shows gc'd
 *!       trampolines. Note that the output can be very bulky and is
 *!       somewhat low-level technical. Also note that pike currently
 *!       has to be configured with @expr{--with-rtldebug@} to enable
 *!       this.
 *!     @enddl
 *!   @endstring
 *!
 *! @param all_threads
 *!   Trace levels are normally thread local, so changes affect only
 *!   the current thread. To change the level in all threads, pass a
 *!   nonzero value in this argument.
 *!
 *! @returns
 *!   The old trace level in the current thread is returned.
 */
PMOD_EXPORT
PIKEFUN int trace(int level, void|string facility, void|zero|int all_threads)
  efun;
  optflags OPT_SIDE_EFFECT;
{
  INT32 old_level;
  if (facility) {
    struct pike_string *gc_str;
    MAKE_CONST_STRING(gc_str, "gc");
    if (facility == gc_str) {
      old_level = gc_trace;
      gc_trace = level;
    }
    else {
      bad_arg_error("trace", Pike_sp-args, args, 2,
		   "trace facility identifier", Pike_sp-args+1,
                   "Bad argument 2 to trace(). Unknown trace facility.");
    }
  }
  else {
    old_level = Pike_interpreter.trace_level;
#ifdef PIKE_THREADS
    if (!all_threads)
      Pike_interpreter.trace_level = level;
    else {
      struct thread_state *s;
      FOR_EACH_THREAD(s, s->state.trace_level = level);
    }
#else
    Pike_interpreter.trace_level = level;
#endif
  }
  RETURN old_level;
}

/*! @decl mapping(string:float) gc_parameters (void|mapping(string:mixed) params)
 *! @belongs Pike
 *!
 *! Set and get various parameters that control the operation of the
 *! garbage collector. The passed mapping contains the parameters to
 *! set. If a parameter is missing from the mapping, the current value
 *! will be filled in instead. The same mapping is returned. Thus an
 *! empty mapping, or no argument at all, causes a mapping with all
 *! current settings to be returned.
 *!
 *! The following parameters are recognized:
 *!
 *! @mapping
 *! @member int "enabled"
 *!   If this is 1 then the gc is enabled as usual. If it's 0 then all
 *!   automatically scheduled gc runs are disabled and the parameters
 *!   below have no effect, but explicit runs through the @[gc]
 *!   function still works as usual. If it's -1 then the gc is
 *!   completely disabled so that even explicit @[gc] calls won't do
 *!   anything.
 *! @member float "garbage_ratio_low"
 *!   As long as the gc time is less than time_ratio below, aim to run
 *!   the gc approximately every time the ratio between the garbage
 *!   and the total amount of allocated things is this.
 *! @member float "time_ratio"
 *!   When more than this fraction of the time is spent in the gc, aim
 *!   for garbage_ratio_high instead of garbage_ratio_low.
 *! @member float "garbage_ratio_high"
 *!   Upper limit for the garbage ratio - run the gc as often as it
 *!   takes to keep it below this.
 *! @member float "min_gc_time_ratio"
 *!   This puts an upper limit on the gc interval, in addition to the
 *!   factors above. It is specified as the minimum amount of time
 *!   spent doing gc, as a factor of the total time. The reason for
 *!   this limit is that the current amount of garbage can only be
 *!   measured in a gc run, and if the gc starts to run very seldom
 *!   due to very little garbage, it might get too slow to react to an
 *!   increase in garbage generation. Set to 0.0 to turn this limit
 *!   off.
 *! @member float "average_slowness"
 *!   When predicting the next gc interval, use a decaying average
 *!   with this slowness factor. It should be a value between 0.0 and
 *!   1.0 that specifies the weight to give to the old average value.
 *!   The remaining weight up to 1.0 is given to the last reading.
 *! @member function(:void) "pre_cb"
 *!   This function is called when the gc starts.
 *! @member function(:void) "post_cb"
 *!   This function is called when the mark and sweep pass of the gc
 *!   is done.
 *! @member function(object:void) "destruct_cb"
 *!   This function is called once for each object that is part of
 *!   a cycle just before the gc will destruct it.
 *! @member function(int:void) "done_cb"
 *!   This function is called when the gc is done and about to exit.
 *!   The argument is the same value as will be returned by gc().
 *! @endmapping
 *!
 *! @seealso
 *!   @[gc], @[Debug.gc_status]
 */
PMOD_EXPORT
PIKEFUN mapping(string:mixed) gc_parameters (void|mapping(string:mixed) params)
  errname Pike.gc_parameters;
  optflags OPT_SIDE_EFFECT;
{
  struct pike_string *str;
  struct svalue *set;
  struct svalue get;

  if (!params) {
    push_mapping (allocate_mapping (6));
    params = Pike_sp[-1].u.mapping;
  }

#define HANDLE_PARAM(NAME, CHECK_AND_SET, GET) do {			\
    MAKE_CONST_STRING (str, NAME);					\
    if ((set = low_mapping_string_lookup (params, str))) {		\
      CHECK_AND_SET;							\
    }									\
    else {								\
      GET;								\
      mapping_string_insert (params, str, &get);			\
    }									\
  } while (0)

#define HANDLE_FLOAT_FACTOR(NAME, VAR)					\
  HANDLE_PARAM (NAME, {							\
      if (set->type != T_FLOAT ||					\
	  set->u.float_number < 0.0 || set->u.float_number > 1.0)	\
	SIMPLE_BAD_ARG_ERROR ("Pike.gc_parameters", 1,			\
			      "float between 0.0 and 1.0 for " NAME);	\
      VAR = DO_NOT_WARN ((double) set->u.float_number);			\
    }, {								\
      get.type = T_FLOAT;						\
      get.u.float_number = DO_NOT_WARN ((FLOAT_TYPE) VAR);		\
    });

  HANDLE_PARAM ("enabled", {
      if (set->type != T_INT || set->u.integer < -1 || set->u.integer > 1)
	SIMPLE_BAD_ARG_ERROR ("Pike.gc_parameters", 1,
			      "integer in the range -1..1 for 'enabled'");
      if (gc_enabled != set->u.integer) {
	if (gc_enabled > 0) {
	  /* Disabling automatic gc - save the old alloc_threshold and set it to
	   * the maximum value to avoid getting gc_evaluator_callback added. */
	  saved_alloc_threshold = alloc_threshold;
	  alloc_threshold = GC_MAX_ALLOC_THRESHOLD;
	}
	else if (set->u.integer > 0) {
	  /* Enabling automatic gc - restore the old alloc_threshold. If the
	   * gc interval has gotten longer than it should be then the
	   * multiplier calculation in do_gc should compensate. */
	  alloc_threshold = saved_alloc_threshold;
	}
	gc_enabled = set->u.integer;
      }
    }, {
      get.type = T_INT;
      get.subtype = NUMBER_NUMBER;
      get.u.integer = gc_enabled;
    });
  HANDLE_FLOAT_FACTOR ("garbage_ratio_low", gc_garbage_ratio_low);
  HANDLE_FLOAT_FACTOR ("time_ratio", gc_time_ratio);
  HANDLE_FLOAT_FACTOR ("garbage_ratio_high", gc_garbage_ratio_high);
  HANDLE_FLOAT_FACTOR ("min_gc_time_ratio", gc_min_time_ratio);
  HANDLE_FLOAT_FACTOR ("average_slowness", gc_average_slowness);

  HANDLE_PARAM("pre_cb", {
      assign_svalue(&gc_pre_cb, set);
    }, {
      assign_svalue(&get, &gc_pre_cb);
    });
  HANDLE_PARAM("post_cb", {
      assign_svalue(&gc_post_cb, set);
    }, {
      assign_svalue(&get, &gc_post_cb);
    });
  HANDLE_PARAM("destruct_cb", {
      assign_svalue(&gc_destruct_cb, set);
    }, {
      assign_svalue(&get, &gc_destruct_cb);
    });
  HANDLE_PARAM("done_cb", {
      assign_svalue(&gc_done_cb, set);
    }, {
      assign_svalue(&get, &gc_done_cb);
    });

#undef HANDLE_PARAM
#undef HANDLE_FLOAT_FACTOR

  REF_RETURN params;
}

/*! @decl string ctime(int timestamp)
 *!
 *! Convert the output from a previous call to @[time()] into a readable
 *! string containing the current year, month, day and time.
 *!
 *! Like @[localtime], this function might throw an error if the
 *! ctime(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].
 *!
 *! @seealso
 *! @[time()], @[localtime()], @[mktime()], @[gmtime()]
 */
PMOD_EXPORT
PIKEFUN string ctime(longest timestamp)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  time_t i;
  char *s;

#if SIZEOF_TIME_T < SIZEOF_LONGEST
  if (timestamp > MAX_TIME_T || timestamp < MIN_TIME_T)
    SIMPLE_ARG_ERROR ("ctime", 1, "Timestamp outside valid range.");
#endif

  i = (time_t) timestamp;
  s = ctime (&i);
  if (!s) Pike_error ("ctime() on this system cannot handle "
		      "the timestamp %ld.\n", (long) i);
  RETURN make_shared_string(s);
}

/*! @decl mapping mkmapping(array ind, array val)
 *!
 *! Make a mapping from two arrays.
 *!
 *! Makes a mapping @[ind[x]]:@[val[x]], @tt{0 <= x < sizeof(ind)@}.
 *!
 *! @[ind] and @[val] must have the same size.
 *!
 *! This is the inverse operation of @[indices()] and @[values()].
 *!
 *! @seealso
 *! @[indices()], @[values()]
 */
PMOD_EXPORT
PIKEFUN mapping(1:2) mkmapping(array(1=mixed) ind, array(2=mixed) val)
  efun;
  optflags OPT_TRY_OPTIMIZE|OPT_EXTERNAL_DEPEND;
{
  if(ind->size != val->size)
    bad_arg_error("mkmapping", Pike_sp-args, args, 2, "array", Pike_sp+1-args,
		  "mkmapping called on arrays of different sizes (%d != %d)\n",
		  ind->size, val->size);

  RETURN mkmapping(ind, val);
}

/*! @decl void secure(string str)
 *! @belongs String
 *!
 *! Marks the string as secure, which will clear the memory area
 *! before freeing the string.
 */
PIKEFUN string string_secure(string str)
  optflags OPT_SIDE_EFFECT;
  rawtype tFunc(tSetvar(0, tStr), tVar(0));
{
  str->flags |= STRING_CLEAR_ON_EXIT;
  REF_RETURN str;
}

/*! @decl int count(string haystack, string needle)
 *! @belongs String
 *!
 *! Count the number of non-overlapping times the string @[needle]
 *! occurs in the string @[haystack]. The special cases for the needle
 *! @expr{""@} is that it occurs one time in the empty string, zero
 *! times in a one character string and between every character
 *! (length-1) in any other string.
 *!
 *! @seealso
 *! @[search()], @[`/()]
 */
PMOD_EXPORT
PIKEFUN int string_count(string haystack, string needle)
  errname String.count;
  optflags OPT_TRY_OPTIMIZE;
{
   ptrdiff_t c = 0;
   ptrdiff_t i, j;

   switch (needle->len)
   {
     case 0:
       switch (haystack->len)
       {
	 case 0: c=1; break; /* "" appears one time in "" */
	 case 1: c=0; break; /* "" doesn't appear in "x" */
	 default: c=haystack->len-1; /* one time between each character */
       }
       break;
     case 1:
       /* maybe optimize? */
       /* It is already fairly optimized in pike_search_engine. */
     default:
       for (i=0; i<haystack->len; i++)
       {
	 j=string_search(haystack,needle,i);
	 if (j==-1) break;
	 i=j+needle->len-1;
	 c++;
       }
       break;
   }
   RETURN DO_NOT_WARN((INT_TYPE)c);
}

/*! @decl string trim_whites (string s)
 *! @belongs String
 *!
 *! Trim leading and trailing spaces and tabs from the string @[s].
 */
PMOD_EXPORT
PIKEFUN string string_trim_whites (string s)
  errname String.trim_whites;
  optflags OPT_TRY_OPTIMIZE;
{
  ptrdiff_t start = 0, end = s->len;
  int chr;
  switch (s->size_shift) {
#define DO_IT(TYPE)							\
    {									\
      for (; start < s->len; start++) {					\
	chr = ((TYPE *) s->str)[start];					\
	if (chr != ' ' && chr != '\t') break;				\
      }									\
      while (--end > start) {						\
	chr = ((TYPE *) s->str)[end];					\
	if (chr != ' ' && chr != '\t') break;				\
      }									\
    }
    case 0: DO_IT (p_wchar0); break;
    case 1: DO_IT (p_wchar1); break;
    case 2: DO_IT (p_wchar2); break;
#undef DO_IT
  }
  RETURN string_slice (s, start, end + 1 - start);
}

/*! @decl string normalize_space (string s, string|void whitespace)
 *! @belongs String
 *!
 *! @param s
 *! Is returned after white space in it has been normalised.
 *! White space is normalised by stripping leading and trailing white space
 *! and replacing sequences of white space characters with a single space.
 *!
 *! @param whitespace
 *! Defines what is considered to be white space eligible for normalisation.
 *! It has a default value that starts with @expr{" \t\r\n\v\f"@} and in
 *! addition to that contains all whitespace characters part of Unicode.
 *! The first character denotes the character for replacing whitespace
 *! sequences.
 *!
 *! @note
 *! Trailing and leading whitespace around \r and \n characters
 *! is stripped as well (only useful if they're not in the @[whitespace] set).
 *!
 *! @note
 *! This function is a lot faster with just one argument (i.e. the builtin
 *! whitespace set has an optimised code path).
 */
PMOD_EXPORT
PIKEFUN string string_normalize_space (string s, string|void whitespace)
  errname String.normalize_space;
  optflags OPT_TRY_OPTIMIZE;
{
  size_t len = s->len, wlen;
  const void *src = s->str;
  unsigned shift = s->size_shift, replspace;
  const void *ws;
  void *wstemp = 0;
  struct string_builder sb;
  unsigned foundspace = 0;

  wlen = replspace = 0;    /* useless, but suppresses silly compiler warning */

  {
    unsigned bshift = shift, wshift;
    if(whitespace)
      if(!(wlen = whitespace->len))
        REF_RETURN s;
      else {
        ws = whitespace->str; wshift = whitespace->size_shift;
        replspace = index_shared_string(whitespace, 0);
	if(replspace > 0xffff)
	  bshift = 2;
	else if(replspace > 0xff && !bshift)
	  bshift = 1;
	if(wshift!=shift) {	/* convert whitespace to shift of input */
	  PCHARP pcnws;
	  wstemp = xalloc(wlen<<shift);
	  pcnws = MKPCHARP(wstemp, shift);
	  if(wshift>shift) {
	    PCHARP pcows = MKPCHARP_STR(whitespace);
	    size_t clen = wlen, i;
	    i = wlen = 0;
	    do {
	      unsigned chr = INDEX_PCHARP(pcows, i++);
	      if (chr<=0xff || (chr<=0xffff && shift))	/* shift is 0 or 1 */
		SET_INDEX_PCHARP(pcnws, wlen++, chr);
	    } while(--clen);
	  } else
	    pike_string_cpy(pcnws, whitespace);
	  ws = wstemp;
	}
      }
    else
      ws = 0;

    init_string_builder_alloc (&sb, len, bshift);
    if(bshift == shift)
      sb.known_shift = bshift;
  }
#define SPACECASE8							\
       case ' ':case '\t':case '\r':case '\n':case '\v':case '\f':	\
       case 0x85:case 0xa0:
#include "whitespace.h"

  switch (shift) {
#define NORMALISE_TIGHT_LOOP(TYPE,CASE)					\
    {									\
      const TYPE *start = src, *end = start+len;			\
      if (!ws) {							\
        TYPE *dst = (void*)sb.s->str;					\
        for (; start < end; start++) {					\
	  switch(*start) {						\
	    CASE							\
	      continue;							\
          }								\
          break;							\
        }								\
        for (; start < end; start++) {					\
	  if(*start<=' ' || *start>=0x85)  /* optimise common case */	\
	    switch(*start) {						\
	      CASE							\
	        if (!foundspace)					\
	          *dst++ = ' ', foundspace=1;				\
	        continue;						\
	      default:goto found##TYPE;					\
	    }								\
	  else								\
found##TYPE:								\
	    foundspace=0;						\
	  *dst++ = *start;						\
	}								\
	sb.s->len = dst - (TYPE*)sb.s->str;				\
      } else {								\
	const TYPE*ps = (const TYPE*)ws+wlen;				\
        for (; start < end; start++) {					\
	  size_t clen = wlen;						\
          do {								\
            if (ps[0-clen] == *start)					\
              goto lead##TYPE;						\
          } while(--clen);						\
          break;							\
lead##TYPE:;								\
        }								\
        for (; start < end; start++) {					\
	  TYPE chr = *start;						\
	  size_t clen = wlen;						\
          do								\
            if (ps[0-clen] == chr) {					\
	      if (!foundspace)						\
	        string_builder_putchar(&sb, replspace), foundspace=1;	\
              goto skip##TYPE;						\
            }								\
          while(--clen);						\
	  if (foundspace && (chr=='\n' || chr=='\r')) {			\
	    sb.s->len--; string_builder_putchar(&sb, chr);		\
	    foundspace=0;						\
            goto lead##TYPE;						\
	  }								\
	  string_builder_putchar(&sb, chr); foundspace=0;		\
skip##TYPE:;								\
        }								\
      }									\
    }
    case 0: NORMALISE_TIGHT_LOOP (p_wchar0,SPACECASE8); break;
    case 1: NORMALISE_TIGHT_LOOP (p_wchar1,SPACECASE16); break;
    case 2: NORMALISE_TIGHT_LOOP (p_wchar2,SPACECASE16); break;
#undef NORMALISE_TIGHT_LOOP
#undef SPACECASE8
#undef SPACECASE16
  }
  if (wstemp)
    free(wstemp);
  if (foundspace)
    sb.s->len--;
  RETURN finish_string_builder (&sb);
}

/*! @decl string trim_all_whites (string s)
 *! @belongs String
 *!
 *! Trim leading and trailing white spaces characters (space, tab,
 *! newline, carriage return, form feed, vertical tab and all the
 *! white spaces defined in Unicode) from the string @[s].
 */
PMOD_EXPORT
PIKEFUN string string_trim_all_whites (string s)
  errname String.trim_all_whites;
  optflags OPT_TRY_OPTIMIZE;
{
  ptrdiff_t start = 0, end = s->len;
  int chr;
  switch (s->size_shift) {
#define SPACECASE8							\
       case ' ':case '\t':case '\r':case '\n':case '\v':case '\f':	\
       case 0x85:case 0xa0:
#include "whitespace.h"

#define DO_IT(TYPE,CASE)						\
    {									\
      for (; start < end; start++) {					\
	chr = ((TYPE *) s->str)[start];					\
	switch(chr) {							\
	  CASE								\
	    continue;							\
	}								\
	break;								\
      }									\
      while (--end > start) {						\
	chr = ((TYPE *) s->str)[end];					\
	switch(chr) {							\
	  CASE								\
	    continue;							\
	}								\
	break;								\
      }									\
    }
    case 0: DO_IT (p_wchar0,SPACECASE8); break;
    case 1: DO_IT (p_wchar1,SPACECASE16); break;
    case 2: DO_IT (p_wchar2,SPACECASE16); break;
#undef DO_IT
#undef SPACECASE8
#undef SPACECASE16
  }
  RETURN string_slice (s, start, end + 1 - start);
}

/*! @decl int implements(program prog, program api)
 *! @belongs Program
 *!
 *! Returns 1 if @[prog] implements @[api].
 */
PMOD_EXPORT
PIKEFUN int program_implements(program prog, program api)
  errname Program.implements;
  optflags OPT_TRY_OPTIMIZE;
{
  RETURN implements(prog, api);
}

/*! @decl int inherits(program child, program parent)
 *! @belongs Program
 *!
 *! Returns 1 if @[child] has inherited @[parent].
 */
PMOD_EXPORT
PIKEFUN int program_inherits(program parent, program child)
  errname Program.inherits;
  optflags OPT_TRY_OPTIMIZE;
{
  RETURN low_get_storage(parent, child) != -1;
}

/*! @decl string defined(program p)
 *! @belongs Program
 *!
 *! Returns a string with filename and linenumber describing where
 *! the program @[p] was defined.
 *!
 *! The returned string is of the format @expr{"filename:linenumber"@}.
 *!
 *! If it cannot be determined where the program was defined, @expr{0@}
 *! (zero) will be returned.
 */
PMOD_EXPORT
PIKEFUN string program_defined(program p)
  errname Program.defined;
  optflags OPT_TRY_OPTIMIZE;
{
  INT32 line;
  struct pike_string *tmp = low_get_program_line(p, &line);

  pop_n_elems(args);

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

/*! @decl int(8..8)|int(16..16)|int(32..32) width(string s)
 *! @belongs String
 *!
 *! Returns the width of a string.
 *!
 *! Three return values are possible:
 *! @int
 *!   @value 8
 *!     The string @[s] only contains characters <= 255.
 *!   @value 16
 *!     The string @[s] only contains characters <= 65535.
 *!   @value 32
 *!     The string @[s] contains characters >= 65536.
 *! @endint
 */
PMOD_EXPORT
PIKEFUN int(8 .. 8)|int(16 .. 16)|int(32 .. 32) string_width(string s)
  errname String.width;
  optflags OPT_TRY_OPTIMIZE;
{
  RETURN 8 * (1 << s->size_shift);
}

/*! @decl mixed m_delete(object|mapping map, mixed index)
 *!
 *! If @[map] is an object that implements @[lfun::_m_delete()],
 *! that function will be called with @[index] as its single argument.
 *!
 *! Otherwise if @[map] is a mapping the entry with index @[index]
 *! will be removed from @[map] destructively.
 *!
 *! If the mapping does not have an entry with index @[index], nothing is done.
 *!
 *! @returns
 *!   The value that was removed will be returned.
 *!
 *! @note
 *!   Note that @[m_delete()] changes @[map] destructively.
 *!
 *! @seealso
 *!   @[mappingp()]
 */
PMOD_EXPORT
PIKEFUN mixed m_delete(object|mapping map, mixed index)
  efun;
  optflags OPT_SIDE_EFFECT;
  rawtype tOr(tFunc(tMap(tSetvar(0,tMix),tSetvar(1,tMix)) tVar(0),tVar(1)),tFunc(tObj tMix,tMix))
{
  struct program *p;
  if( map->type == T_MAPPING )
  {
    struct svalue s;
    map_delete_no_free(map->u.mapping, index, &s);
    pop_n_elems(args);
    *Pike_sp=s;
    Pike_sp++;
    dmalloc_touch_svalue(Pike_sp-1);
  }
  else if (map->type == T_OBJECT && (p = map->u.object->prog))
  {
    int id = FIND_LFUN(p->inherits[map->subtype].prog, LFUN__M_DELETE);

    if( id == -1 )
      SIMPLE_BAD_ARG_ERROR("m_delete", 1, "object containing the _m_delete method");
    
    apply_low(map->u.object,
	      id + p->inherits[map->subtype].identifier_level, 1);
    stack_swap();
    pop_stack();
  } else {
    SIMPLE_BAD_ARG_ERROR("m_delete", 1, "object|mapping");
  }
}

/*! @decl int get_weak_flag(array|mapping|multiset m)
 *!
 *! Returns the weak flag settings for @[m]. It's a combination of
 *! @[Pike.WEAK_INDICES] and @[Pike.WEAK_VALUES].
 */
PMOD_EXPORT
PIKEFUN int get_weak_flag(array m)
  efun;
  optflags OPT_EXTERNAL_DEPEND;
{
  RETURN (m->flags & ARRAY_WEAK_FLAG) ? PIKE_WEAK_VALUES : 0;
}

PMOD_EXPORT
PIKEFUN int get_weak_flag(mapping m)
{
  RETURN  mapping_get_flags(m) & MAPPING_WEAK;
}

PMOD_EXPORT
PIKEFUN int get_weak_flag(multiset m)
{
  RETURN multiset_get_flags(m) & MULTISET_WEAK;
}

/*! @decl program __empty_program(int|void line, string|void file)
 */
PIKEFUN program __empty_program(int|zero|void line, string|void file)
  efun;
  optflags OPT_EXTERNAL_DEPEND;
{
  struct program *prog = low_allocate_program();
  if (file) ext_store_program_line (prog, line, file);
#if 0
  push_program (prog);
  safe_pike_fprintf (stderr, "Creating empty program %O (%x)\n",
		     Pike_sp - 1, Pike_sp[-1].u.program);
  Pike_sp--;
#endif
  RETURN prog;
}

/* Cut the string at the first NUL. */
static struct pike_string *delambda(struct pike_string *str)
{
  PCHARP pcharp = MKPCHARP_STR(str);
  ptrdiff_t len = pcharp_strlen(pcharp);
  if (len == str->len) {
    /* Common case. */
    add_ref(str);
    return str;
  }
  return make_shared_binary_pcharp(pcharp, len);
}

/*! @decl string function_name(function f)
 *!
 *! Return the name of the function @[f].
 *!
 *! If @[f] is a global function defined in the runtime @expr{0@}
 *! (zero) will be returned.
 *!
 *! @seealso
 *! @[function_object()]
 */
PMOD_EXPORT
PIKEFUN string function_name(program|function func)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  switch(func->type)
  {
    default:
      SIMPLE_BAD_ARG_ERROR("function_name", 1, "function|program");
      return; /* NOTREACHED */
	
    case PIKE_T_PROGRAM:
    {
      struct program *p=func->u.program;

      if(p->parent)
      {
	int e;
	p=p->parent;
	/* search constants in parent for this
	 * program...
	 */
	
	for(e = p->num_identifier_references; e--; )
	{
	  struct identifier *id;
	  if (p->identifier_references[e].id_flags & ID_HIDDEN)
	    continue;

	  id = ID_FROM_INT(p, e);
	  if (IDENTIFIER_IS_CONSTANT(id->identifier_flags) &&
	      (id->func.offset >= 0) &&
	      is_eq( & PROG_FROM_INT(p, e)->constants[id->func.offset].sval,
		     func))
	    REF_RETURN id->name;
	}
#ifdef PIKE_DEBUG
	if (d_flag>5) {
	  fprintf(stderr,
		  "Failed to find symbol for program %p\n"
		  "Parent program info:\n",
		  func->u.program);
	  dump_program_tables(func->u.program->parent, 0);
	}
#endif
      }
      break;
    }

    case PIKE_T_FUNCTION:
      if(func->subtype == FUNCTION_BUILTIN) break;
      if(!func->u.object->prog)
	bad_arg_error("function_name", Pike_sp-args, args, 1,
		      "function", Pike_sp-args,
		      "Destructed object.\n");
      if(func->u.object->prog == pike_trampoline_program)
      {
	struct pike_trampoline *t;
	t=((struct pike_trampoline *)func->u.object->storage);

	if(t->frame->current_object->prog)
	  RETURN delambda(ID_FROM_INT(t->frame->current_object->prog,
				      t->func)->name);
      }

      RETURN delambda(ID_FROM_INT(func->u.object->prog, func->subtype)->name);
  }
  pop_n_elems(args);
  push_int(0);
}

/*! @decl object function_object(function f)
 *!
 *!   Return the object the function @[f] is in.
 *!
 *!   If @[f] is a global function defined in the runtime @expr{0@}
 *!   (zero) will be returned.
 *!
 *!   Zero will also be returned if @[f] is a constant in the
 *!   parent class. In that case @[function_program()] can be
 *!   used to get the parent program.
 *!
 *! @seealso
 *!   @[function_name()], @[function_program()]
 */
PMOD_EXPORT
PIKEFUN object function_object(function|program func)
  efun;
  optflags OPT_TRY_OPTIMIZE;
  type function(function:object);
{
  switch(func->type)
  {
    case PIKE_T_PROGRAM:
      break;
      
    case PIKE_T_FUNCTION:
      if(func->subtype == FUNCTION_BUILTIN) break;
      if(func->u.object->prog == pike_trampoline_program)
      {
	struct object *o;
	o=((struct pike_trampoline *)func->u.object->storage)->frame->current_object;
	add_ref(o);
	pop_n_elems(args);
	push_object(o);
	return;
      }
      func->type=T_OBJECT;
      func->subtype = 0;
      return;


    default:
      SIMPLE_BAD_ARG_ERROR("function_object",1,"function");
  }
  pop_n_elems(args);
  push_int(0);
}

/*! @decl program function_program(function|program f)
 *!
 *!   Return the program the function @[f] is in.
 *!
 *!   If @[f] is a global function defined in the runtime @expr{0@}
 *!   (zero) will be returned.
 *!
 *! @seealso
 *!   @[function_name()], @[function_object()]
 */
PMOD_EXPORT
PIKEFUN program function_program(program|function func)
  efun;
  optflags OPT_TRY_OPTIMIZE;
{
  switch(func->type)
  {
    case PIKE_T_PROGRAM:
    {
      struct program *p;
      if(!(p=func->u.program->parent)) break;
      add_ref(p);
      free_program(func->u.program);
      func->u.program=p;
      return;
    }
      
    case PIKE_T_FUNCTION:
      {
	struct program *p;
	if(func->subtype == FUNCTION_BUILTIN)
	  p = func->u.efun->prog;
	else
	  p = func->u.object->prog;
	if(p == pike_trampoline_program)
	{
	  p = ((struct pike_trampoline *)func->u.object->storage)->
	    frame->current_object->prog;
	}
	if (p) {
	  ref_push_program(p);
	  stack_pop_n_elems_keep_top(args);
	  return;
	}
      }
      break;

    default:
      SIMPLE_BAD_ARG_ERROR("function_program", 1, "function");
  }
  pop_n_elems(args);
  push_int(0);
}


/*! @decl mixed random(object o)
 *!   If random is called with an object, @[lfun::random] will be
 *!   called in the object.
 *! @seealso
 *!  @[lfun::_random]
 */

/*! @decl mixed lfun::_random()
 *!   Called by @[random]. Typical uses is when the object implements
 *!   a ADT, then a call to this lfun should return a random member of
 *!   the ADT or range implied by the ADT.
 *! @seealso
 *!   @[predef::random()]
 */

PMOD_EXPORT
PIKEFUN mixed random(object o)
  efun;
  optflags OPT_TRY_OPTIMIZE|OPT_EXTERNAL_DEPEND;
{
  apply(o,"_random",0);
  stack_swap();
  pop_stack();
}

/*! @decl int random(int max)
 *! @decl float random(float max)
 *!
 *!   This function returns a random number in the range 0 - @[max]-1.
 *!
 *! @seealso
 *!   @[random_seed()]
 */

PMOD_EXPORT
PIKEFUN int random(int i)
{
  if(i <= 0) RETURN 0;
#ifdef AUTO_BIGNUM
  if(i >> 31) {
    unsigned INT_TYPE a = my_rand();
    unsigned INT_TYPE b = my_rand();
    RETURN (INT_TYPE)(((a<<32)|b) % i);
  }
#endif
  RETURN  my_rand() % i;
}      

PMOD_EXPORT
PIKEFUN float random(float f)
{
  if(f<=0.0) RETURN 0.0;
#define N 1048576
  RETURN f * (my_rand()%N/((float)N)) +
    f * (my_rand()%N/( ((float)N) * ((float)N) ));
		   
}

/*! @decl mixed random(array|multiset x)
 *!   Returns a random element from @[x].
 */

PMOD_EXPORT
PIKEFUN mixed random(array a)
     rawtype tFunc(tArr(tSetvar(0,tMix)),tVar(0));
{
  if(!a->size)
    SIMPLE_BAD_ARG_ERROR("random", 1, "array with elements in it");
  push_svalue(a->item + (my_rand() % a->size));
  stack_swap();
  pop_stack();
}

PMOD_EXPORT
PIKEFUN mixed random(multiset m)
     rawtype tFunc(tSet(tSetvar(1,tMix)),tVar(1));
{
  if(multiset_is_empty (m))
    SIMPLE_BAD_ARG_ERROR("random", 1, "multiset with elements in it");
  if (multiset_indval (m)) {
    ptrdiff_t nodepos = multiset_get_nth (m, my_rand() % multiset_sizeof (m));
    push_multiset_index (m, nodepos);
    push_multiset_value (m, nodepos);
    sub_msnode_ref (m);
    f_aggregate (2);
  }
  else {
    push_multiset_index (m, multiset_get_nth (m, my_rand() %
					      multiset_sizeof (m)));
    sub_msnode_ref (m);
  }
  stack_swap();
  pop_stack();
}

/*! @decl array random(mapping m)
 *!   Returns a random index-value pair from the mapping.
 */

PMOD_EXPORT
PIKEFUN array random(mapping m)
{
  struct mapping_data *md=m->data;
  size_t bucket, count;
  struct keypair *k;
  
  if(!m_sizeof(m))
    SIMPLE_BAD_ARG_ERROR("random", 1, "mapping with elements in it");
  
  /* Find a random, nonempty bucket */
  bucket=my_rand() % md->hashsize;
  while(! md->hash[bucket] )
    if(++bucket > (size_t)md->hashsize)
      bucket=0;
  
  /* Count entries in bucket */
  count=0;
  for(k=md->hash[bucket];k;k=k->next) count++;
  
  /* Select a random entry in this bucket */
  count = my_rand() % count;
  k=md->hash[bucket];
  while(count-- > 0) k=k->next;
  
  /* Push result and return */
  push_svalue(&k->ind);
  push_svalue(&k->val);
  f_aggregate(2);
  stack_swap();
  pop_stack();
}

#if defined(HAVE_SETENV) && defined(HAVE_UNSETENV)
#define USE_SETENV
#else
/* Used to hold refs to the strings that we feed to putenv. Indexed on
 * variable names, values are the "name=value" strings.
 *
 * This is not needed when using {,un}setenv(), since they maintain
 * their own corresponding table. */
static struct mapping *env_allocs = NULL;
#endif

/* Works exactly like the getenv efun defined in the master, but only
 * accesses the real environment. Everyone should use the caching
 * version in the master instead. */
PIKEFUN string|mapping _getenv (void|string var)
  rawtype tOr(tFunc(tStr, tString), tFunc(tVoid, tMap (tStr, tStr)));
{
  /* FIXME: Perhaps add the amigaos4 stuff from pike_push_env here too. */

  if (var) {
    if (var->size_shift)
      SIMPLE_ARG_TYPE_ERROR ("getenv", 1, "void|string(0..255)");

    if (string_has_null (var)) {
      /* Won't find a variable name like this. */
      pop_stack();
      push_int (0);
    }

    else {
      char *entry = getenv (var->str);
      pop_stack();
      if (!entry)
	push_int (0);
      else {
	char *eq = STRCHR (entry, '=');
	/* There should always be a '=' in the entry, but you never know.. */
	push_string (make_shared_string (eq ? eq + 1 : entry));
      }
    }
  }

  else {
#ifdef DECLARE_ENVIRON
    extern char **environ;
#endif
    struct mapping *m, *new_env_allocs;
    int n;

    /* Iterate the environment backwards below so that earlier
     * variables will override later ones in case the same variable
     * occur multiple times (which it shouldn't). That makes the
     * result similar to what getenv(3) commonly returns (at least the
     * one in gnu libc). */
    for (n = 0; environ[n]; n++) {}

    m = allocate_mapping (n);
#ifndef USE_SETENV
    if (env_allocs)
      new_env_allocs = allocate_mapping (m_sizeof (env_allocs));
#endif /* !USE_SETENV */

    while (--n >= 0) {
      char *entry = environ[n], *eq = STRCHR (entry, '=');
      if (eq) { /* gnu libc getenv ignores variables without '='. */
	struct pike_string *var = make_shared_binary_string (entry, eq - entry);
	struct pike_string *val = make_shared_string (eq + 1);
	mapping_string_insert_string (m, var, val);

#ifndef USE_SETENV
	/* Populate new_env_allocs with the env_allocs entries that
	 * are still in use. */
	if (env_allocs) {
	  struct svalue *ea_val = low_mapping_string_lookup (env_allocs, var);
	  if (ea_val && ea_val->u.string->str == entry)
	    mapping_string_insert (new_env_allocs, var, ea_val);
	}
#endif /* !USE_SETENV */

	free_string (var);
	free_string (val);
      }
    }

#ifndef USE_SETENV
    if (env_allocs) {
      free_mapping (env_allocs);
      env_allocs = new_env_allocs;
    }
#endif /* !USE_SETENV */

    push_mapping (m);
  }
}

/* Works exactly like the putenv efun defined in the master, but only
 * updates the real environment. Everyone should use the version in
 * the master instead so that the cache doesn't get stale. */
PIKEFUN void _putenv (string var, void|string val)
{
#ifndef USE_SETENV
  struct pike_string *putenv_str, *env_alloc_var;
#endif

  if (var->size_shift)
    SIMPLE_ARG_TYPE_ERROR ("putenv", 1, "string(0..255)");
  if (string_has_null (var) || STRCHR (var->str, '='))
    SIMPLE_ARG_ERROR ("putenv", 1, "Variable name cannot contain '=' or NUL.");

  if (val) {
#ifndef USE_SETENV
    struct string_builder sb;
#endif

    if (val->size_shift)
      SIMPLE_ARG_TYPE_ERROR ("putenv", 2, "void|string(0..255)");
    if (string_has_null (val))
      SIMPLE_ARG_ERROR ("putenv", 2, "Variable value cannot contain NUL.");

#ifdef USE_SETENV
    if (setenv(var->str, val->str, 1)) {
      if (errno == ENOMEM)
	SIMPLE_OUT_OF_MEMORY_ERROR ("putenv", 0);
      else
	Pike_error ("Error from setenv(3): %s\n", strerror (errno));
    }
#else /* !USE_SETENV */
    init_string_builder (&sb, 0);
    string_builder_shared_strcat (&sb, var);
    string_builder_putchar (&sb, '=');
    string_builder_shared_strcat (&sb, val);
    putenv_str = finish_string_builder (&sb);
    push_string (putenv_str); /* Let mega_apply pop. */
#endif /* USE_SETENV */
  }
  else {
#ifdef USE_SETENV
    /* Note: Some versions of glibc have a unsetenv(3) that returns void,
     *       thus no checking of the return value here.
     */
    unsetenv(var->str);
#else /* !USE_SETENV */
#ifdef PUTENV_ALWAYS_REQUIRES_EQUAL
    /* Windows can never get things quite right.. :P */
    struct string_builder sb;
    init_string_builder (&sb, 0);
    string_builder_shared_strcat (&sb, var);
    string_builder_putchar (&sb, '=');
    putenv_str = finish_string_builder (&sb);
    push_string (putenv_str); /* Let mega_apply pop. */
#else
    putenv_str = var;
#endif
#endif  /* USE_SETENV */
  }

#ifndef USE_SETENV
  if (putenv (putenv_str->str)) {
    if (errno == ENOMEM)
      SIMPLE_OUT_OF_MEMORY_ERROR ("putenv", 0);
    else
      Pike_error ("Error from putenv(3): %s\n", strerror (errno));
  }

#ifdef __NT__
  ref_push_string (var);
  f_lower_case (1);
  assert (Pike_sp[-1].type == T_STRING);
  env_alloc_var = Pike_sp[-1].u.string;
  /* Let mega_apply pop. */
#else
  env_alloc_var = var;
#endif

  if (!env_allocs) env_allocs = allocate_mapping (4);

  if (val)
    /* Must keep the string passed to putenv allocated (and we
     * assume no other entities are naughty enough to modify it). */
    mapping_string_insert_string (env_allocs, env_alloc_var, putenv_str);
  else {
    struct svalue key;
    key.type = T_STRING;
    key.u.string = env_alloc_var;
    map_delete (env_allocs, &key);
  }
#endif /* !USE_SETENV */
}

/*
 * Backtrace handling.
 */

/*! @module Pike
 */

/*! @class BacktraceFrame
 */

PIKECLASS backtrace_frame
{
  PIKEVAR mixed _fun flags ID_PROTECTED|ID_PRIVATE;
#ifdef PIKE_DEBUG
  PIKEVAR program oprog flags ID_PROTECTED|ID_PRIVATE;
#endif
  PIKEVAR array args;

  /* These are cleared when filename and lineno have been initialized
   * from them. */
  PIKEVAR program prog flags ID_PROTECTED|ID_PRIVATE;
  CVAR PIKE_OPCODE_T *pc;

  /* These two are considered to be uninitialized from prog, pc and
   * fun as long as lineno == -1. */
  CVAR struct pike_string *filename;
  CVAR INT32 lineno;

  INIT
  {
    THIS->pc = NULL;
    THIS->lineno = -1;
    THIS->filename = NULL;
  }

  EXIT
    gc_trivial;
  {
    if (THIS->filename) {
      free_string(THIS->filename);
      THIS->filename = NULL;
    }
    THIS->pc = NULL;
    THIS->lineno = -1;
  }

  /* NOTE: Use old-style getter/setter syntax for compatibility with
   *       old Parser.Pike.split() used by precompile.pike.
   */

  PIKEFUN mixed `->fun()
  {
    push_svalue(&THIS->_fun);
  }

  PIKEFUN void `->fun=(mixed val)
  {
    /* FIXME: Should we allow this at all?
     *        Linenumber info etc won't match.
     */
#ifdef PIKE_DEBUG
    if ((val->type == T_FUNCTION) && (val->subtype != FUNCTION_BUILTIN)) {
      assign_short_svalue((union anything *)&THIS->oprog,
			  (union anything *)&val->u.object->prog, T_PROGRAM);
    }
#endif
    assign_svalue(&THIS->_fun, val);
  }

  /*! @decl int(0..1) _is_type(string t)
   *! This object claims to be an array for backward compatibility.
   */
  PIKEFUN int(0..1) _is_type(string t)
  {
    INT_TYPE res = (t == findstring("array"));
    pop_n_elems(args);
    push_int(res);
  }

  static void fill_in_file_and_line()
  {
    struct pike_string *file = NULL;
    assert (THIS->lineno == -1);

    if (THIS->pc && THIS->prog) {
      file = low_get_line(THIS->pc, THIS->prog, &THIS->lineno);
      THIS->pc = NULL;
    }
    else if (THIS->_fun.type == PIKE_T_FUNCTION) {
#ifdef PIKE_DEBUG
      if (THIS->_fun.u.object->prog &&
	  THIS->_fun.u.object->prog != THIS->oprog) {
	struct identifier *id = ID_FROM_INT(THIS->oprog, THIS->_fun.subtype);
	/* FIXME: Dump dmalloc info for the object? */
	Pike_fatal("Lost track of function pointer! Function name was %s.\n",
		   id->name?id->name->str:"<no name>");
      }
#endif
      file = low_get_function_line (THIS->_fun.u.object, THIS->_fun.subtype,
				    &THIS->lineno);
    }
    else if (THIS->prog) {
      file = low_get_program_line (THIS->prog, &THIS->lineno);
    }

    if (file) {
      if (!THIS->filename) THIS->filename = file;
      else free_string (file);
    }

    if (THIS->prog) {
      free_program(THIS->prog);
      THIS->prog = NULL;
    }
  }

  /*! @decl string _sprintf(int c, mapping|void opts)
   */
  PIKEFUN string _sprintf(int c, mapping|void opts)
  {
    pop_n_elems(args);

    if (c != 'O') {
      push_undefined ();
      return;
    }

    push_text("backtrace_frame(");

    if (THIS->lineno == -1) fill_in_file_and_line();

    if (THIS->filename) {
      ref_push_string(THIS->filename);
      push_text(":");
      push_int(THIS->lineno);
      push_text(", ");
      f_add(4);
    } else {
      push_text("Unknown file, ");
    }
    if (THIS->_fun.type == PIKE_T_FUNCTION) {
      if (THIS->_fun.u.object->prog) {
#ifdef PIKE_DEBUG
	if (THIS->_fun.u.object->prog != THIS->oprog) {
	  struct identifier *id = ID_FROM_INT(THIS->oprog, THIS->_fun.subtype);
	  /* FIXME: Dump dmalloc info for the object? */
	  Pike_fatal("Lost track of function pointer! Function name was %s.\n",
		     id->name?id->name->str:"<no name>");
	}
#endif
	push_svalue(&THIS->_fun);
	f_function_name(1);
	push_text("(), ");
	f_add(2);
      } else {
	free_svalue(&THIS->_fun);
	THIS->_fun.type = PIKE_T_INT;
	THIS->_fun.u.integer = 0;
	THIS->_fun.subtype = NUMBER_DESTRUCTED;
	push_text("destructed_function(), ");	
      }
    } else {
      push_text("destructed_function(), ");
    }

    if (THIS->args) {
      push_text("Args: ");
      push_int(THIS->args->size);
      f_add(2);
    } else {
      push_text("No args");
    }
    push_text(")");
    f_add(5);
  }

  /*! @decl int(3..) _sizeof()
   */
  PIKEFUN int(3..) _sizeof()
  {
    if (THIS->args) {
      push_int(THIS->args->size + 3);
    } else {
      push_int(3);
    }
  }

  /*! @decl mixed `[](int index, int|void end_or_none)
   *! The BacktraceFrame object can be indexed as an array.
   */
  PIKEFUN mixed `[](int index, int|void end_or_none)
  {
    INT_TYPE end = index;
    INT32 numargs = 0;
    INT32 i;

    if (THIS->args) {
      numargs = THIS->args->size;
    }

    numargs += 3;

    if (!end_or_none) {
      if (index < 0) {
	index_error("pike_frame->`[]", Pike_sp-args, args, NULL, Pike_sp-args,
		    "Indexing with negative index (%"PRINTPIKEINT"d)\n", index);
      } else if (index >= numargs) {
	index_error("pike_frame->`[]", Pike_sp-args, args, NULL, Pike_sp-args,
		    "Indexing with too large index (%"PRINTPIKEINT"d)\n", index);
      }
    } else {
      if (end_or_none->type != PIKE_T_INT) {
	SIMPLE_BAD_ARG_ERROR("`[]",2,"int|void");
      }
      end = end_or_none->u.integer;
    }

    pop_n_elems(args);

    if (end_or_none) {
      if ((end < 0) || (end < index) || (index >= numargs)) {
	f_aggregate(0);
	return;
      }

      if (end >= numargs) {
	end = numargs-1;
      }
    }

    for (i = index; i <= end; i++) {
      switch(i) {
      case 0:	/* Filename */
	if (THIS->lineno == -1) fill_in_file_and_line();
	if (THIS->filename) {
	  ref_push_string(THIS->filename);
	} else {
	  push_int(0);
	}
	break;
      case 1:	/* Linenumber */
	if (THIS->lineno == -1) fill_in_file_and_line();
	push_int(THIS->lineno);
	break;
      case 2:	/* Function */
        push_svalue(&THIS->_fun);
        break;
      default:	/* Arguments */
        {
	  if ((i > 2) && (THIS->args) && (i-3 < THIS->args->size)) {
	    push_svalue(THIS->args->item + (i - 3));
	    break;
	  }
	  bad_arg_error("backtrace_frame->`[]", Pike_sp-args, args, 1,
			"int(0..)", Pike_sp-args,
			"Bad argument 1 to backtrace_frame->`[](): "
			"Expected int(0..%d)\n",
			numargs + 2);
	}
        /* NOT_REACHED */
        break;
      }
    }
    if (end_or_none) {
      f_aggregate(1 + end - index);
    }
  }

  /*! @decl mixed `[]=(int index, mixed value)
   */
  PIKEFUN mixed `[]=(int index, mixed value)
  {
    INT32 numargs = 0;

    if (THIS->args) {
      numargs = THIS->args->size;
    }

    numargs += 3;

    if ((index < -numargs) || (index >= numargs)) {
	index_error("pike_frame->`[]=", Pike_sp-args, args, NULL, Pike_sp-args,
		    "Index %"PRINTPIKEINT"d is out of array range 0..%d,\n",
		    index, numargs-1);
    } else if (index < 0) {
      index += numargs;
    }

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

    switch(index) {
    case 0:	/* Filename */
      if (THIS->lineno == -1) fill_in_file_and_line();
      if (value->type != PIKE_T_STRING) {
	if ((value->type != PIKE_T_INT) ||
	    (value->u.integer)) {
	  SIMPLE_BAD_ARG_ERROR("backtrace_frame->`[]=", 2,
			       "string|int(0..0)");
	}
	if (THIS->filename) {
	  free_string(THIS->filename);
	  THIS->filename = NULL;
	}
      } else {
	if (THIS->filename) {
	  free_string(THIS->filename);
	  THIS->filename = NULL;
	}
	copy_shared_string(THIS->filename, value->u.string);
      }
      break;

    case 1:	/* Linenumber */
      if (THIS->lineno == -1) fill_in_file_and_line();
      if (value->type != PIKE_T_INT) {
	SIMPLE_BAD_ARG_ERROR("backtrace_frame->`[]=", 2, "int(1..)");
      }
      THIS->lineno = value->u.integer;
      break;

    case 2:	/* Function */
      if (THIS->lineno == -1) fill_in_file_and_line();
      assign_svalue(&THIS->_fun, value);
      break;
    default:	/* Arguments */
      assign_svalue(THIS->args->item + index - 3, value);
      break;
    }
    stack_swap();
    pop_stack();
  }

};

/*! @endclass
 */

/*! @decl mapping(string:int|string) get_runtime_info()
 *!
 *! Get information about the Pike runtime.
 *!
 *! @returns
 *!   Returns a mapping with the following content:
 *!   @mapping
 *!     @member string "bytecode_method"
 *!       A string describing the bytecode method used by
 *!       the Pike interpreter.
 *!     @member int "abi"
 *!       The number of bits in the ABI. Usually @expr{32@} or @expr{64@}.
 *!     @member int "native_byteorder"
 *!       The byte order used by the native cpu.
 *!       Usually @expr{1234@} (aka little endian) or
 *!       @expr{4321@} (aka bigendian).
 *!     @member int "int_size"
 *!       The number of bits in the native integer type.
 *!       Usually @expr{32@} or @expr{64@}.
 *!     @member int "float_size"
 *!       The number of bits in the native floating point type.
 *!       Usually @expr{32@} or @expr{64@}.
 *!     @member int(0..1) "auto_bignum"
 *!       Present if integers larger than the native size are automatically
 *!       converted into bignums.
 *!   @endmapping
 */
PIKEFUN mapping(string:int|string) get_runtime_info()
  optflags OPT_TRY_OPTIMIZE;
{
  pop_n_elems(args);
  push_constant_text("bytecode_method");
  push_constant_text(PIKE_BYTECODE_METHOD_NAME);
  push_constant_text("abi");
  push_int(sizeof(void *) * 8);
  push_constant_text("native_byteorder");
  push_int(PIKE_BYTEORDER);
  push_constant_text("int_size");
  push_int(sizeof(INT_TYPE) * 8);
  push_constant_text("float_size");
  push_int(sizeof(FLOAT_TYPE) * 8);
#ifdef AUTO_BIGNUM
  push_constant_text("auto_bignum");
  push_int(1);
  f_aggregate_mapping(6*2);
#else
  f_aggregate_mapping(5*2);
#endif
}

/*! @endmodule
 */

void low_backtrace(struct Pike_interpreter *i)
{
  struct svalue *stack_top = i->stack_pointer;
  struct pike_frame *f, *of = 0;
  int size = 0;
  struct array *res = NULL;

  for (f = i->frame_pointer; f; f = f->next) {
    size++;
  }

  res = allocate_array_no_init(size, 0);
  push_array(res);

  for (f = i->frame_pointer; f && size; f = (of = f)->next) {
    struct object *o = low_clone(backtrace_frame_program);
    struct backtrace_frame_struct *bf;
    struct identifier *function = NULL;

    call_c_initializers(o);

    size--;

    res->item[size].u.object = o;
    res->item[size].type = PIKE_T_OBJECT;
    res->item[size].subtype = 0;

    bf = OBJ2_BACKTRACE_FRAME(o);

    if ((bf->prog = f->context->prog)) {
      add_ref(bf->prog);
      bf->pc = f->pc;
    }

    if ((bf->_fun.u.object = f->current_object) &&
	(bf->_fun.u.object->prog)) {
      add_ref(bf->_fun.u.object);
#ifdef PIKE_DEBUG
      add_ref(bf->oprog = bf->_fun.u.object->prog);
#endif
      bf->_fun.subtype = CHECK_IDREF_RANGE(f->fun, f->current_object->prog);
      bf->_fun.type = PIKE_T_FUNCTION;
      function = ID_FROM_INT(f->current_object->prog, f->fun);
    } else {
      bf->_fun.u.integer = 0;
      bf->_fun.subtype = NUMBER_DESTRUCTED;
      bf->_fun.type = PIKE_T_INT;
    }

    if (f->locals) {
      INT32 numargs = DO_NOT_WARN((INT32) MINIMUM(f->num_args,
						  stack_top - f->locals));
      INT32 varargs = 0;

      if(of && of->locals) {
	/* f->num_args can be too large, so this is necessary for some
	 * reason. I don't know why. /mast
	 *
	 * possibly because f->num_args was uninitialized for c_initializers
	 *  /arne
	 * */

	numargs = DO_NOT_WARN((INT32)MINIMUM(f->num_args,of->locals - f->locals));
      }

      numargs = MAXIMUM(numargs, 0);

      /* Handle varargs... */
      if (function && (function->identifier_flags & IDENTIFIER_VARARGS) &&
	  (f->locals + numargs < stack_top) &&
	  (f->locals[numargs].type == T_ARRAY)) {
	varargs = f->locals[numargs].u.array->size;
      }

      if (numargs + varargs) {
	bf->args = allocate_array_no_init(numargs + varargs, 0);
	bf->args->type_field =
	  assign_svalues_no_free(bf->args->item, f->locals, numargs, BIT_MIXED);
	if (varargs) {
	  bf->args->type_field |=
	    assign_svalues_no_free(bf->args->item + numargs,
				   f->locals[numargs].u.array->item,
				   varargs, BIT_MIXED);
	}
      }
    }
  }
  res->type_field = BIT_OBJECT;
  /* NOTE: res has already been pushed on the stack. */
}

/*! @decl array(Pike.BacktraceFrame) backtrace()
 *!
 *!   FIXME: This documentation is not up to date!
 *!
 *!   Get a description of the current call stack.
 *!
 *!   The description is returned as an array with one entry for each call
 *!   frame on the stack.
 *!
 *!   Each entry has this format:
 *!   @array
 *!     @elem string file
 *!       A string with the filename if known, else zero.
 *!     @elem int line
 *!       An integer containing the linenumber if known, else zero.
 *!     @elem function fun
 *!       The function that was called at this level.
 *!     @elem mixed|void ... args
 *!       The arguments that the function was called with.
 *!   @endarray
 *!
 *!   The current call frame will be last in the array.
 *!
 *! @note
 *!   Please note that the frame order may be reversed in a later version
 *!   (than 7.1) of Pike to accommodate for deferred backtraces.
 *!
 *!   Note that the arguments reported in the backtrace are the current
 *!   values of the variables, and not the ones that were at call-time.
 *!   This can be used to hide sensitive information from backtraces
 *!   (eg passwords).
 *!
 *! @seealso
 *!   @[catch()], @[throw()]
 */
PMOD_EXPORT
PIKEFUN array(mixed) backtrace()
     efun;
     optflags OPT_EXTERNAL_DEPEND;
{
  low_backtrace(& Pike_interpreter);
}

/*! @module String
 */

/*! @class Buffer
 *!    A buffer, used for building strings. It's
 *!    conceptually similar to a string, but you can only @[add]
 *!    strings to it, and you can only @[get] the value from it once.
 *!
 *!    There is a reason for those seemingly rather odd limitations,
 *!    it makes it possible to do some optimizations that really speed
 *!    things up.
 *!
 *!    You do not need to use this class unless you add very many
 *!    strings together, or very large strings.
 *!
 *! @example
 *!    For the fastest possible operation, write your code like this:
 *!
 *! @code
 *! String.Buffer b = String.Buffer( );
 *!
 *! function add = b->add;
 *!
 *! .. call add several times in code ...
 *!
 *! string result = b->get(); // also clears the buffer
 *! @endcode
 */
PIKECLASS Buffer
{
  CVAR struct string_builder str;
  CVAR int initial;
  
  void f_Buffer_get_copy( INT32 args );
  void f_Buffer_get( INT32 args );
  void f_Buffer_add( INT32 args );


  /*! @decl void create(int initial_size)
   *!
   *!   Initializes a new buffer.
   *!
   *!   If no @[initial_size] is specified, 256 is used. If you
   *!   know approximately how big the buffer will be, you can optimize
   *!   the operation of @[add()] (slightly) by passing the size to this
   *!   function.
   */
  PIKEFUN void create( int|void size )
  {
    struct Buffer_struct *str = THIS;
    if( args )
      str->initial = MAXIMUM( size->u.integer, 512 );
    else
      str->initial = 256;
  }

  /*! @decl string _sprintf( int flag, mapping flags )
   *! It is possible to @[sprintf] a String.Buffer object
   *! as @tt{%s@} just as if it was a string.
   */
  PIKEFUN string _sprintf( int flag, mapping flags )
  {
    switch( flag )
    {
      case 'O':
	{
	  struct pike_string *res;
	  struct Buffer_struct *str = THIS;
	  push_text( "Buffer(%d /* %d */)" );
	  if( str->str.s )
	  {
	    push_int(str->str.s->len);
	    push_int(str->str.malloced);
	  }
	  else
	  {
	    push_int( 0 );
	    push_int( 0 );
	  }
	  f_sprintf( 3 );
	  dmalloc_touch_svalue(Pike_sp-1);
	  res = Pike_sp[-1].u.string;
	  Pike_sp--;
	  RETURN res;
	}

      case 's':
	{
	  pop_n_elems( args );
	  if( Pike_fp->current_object->refs != 1 )
	    f_Buffer_get_copy( 0 );
	  else
	    f_Buffer_get( 0 );
	}
	return;
	
      case 't':
	RETURN make_shared_binary_string("Buffer",6);
    }
    pop_n_elems( args );
    push_int( 0 );
    Pike_sp[-1].subtype = 1;
  }

  /*! @decl mixed cast( string type )
   *! It is possible to cast a String.Buffer object to
   *! a @expr{string@} and an @expr{int@}.
   */
  PIKEFUN mixed cast( string type )
  {
    struct pike_string *string_t;
    struct pike_string *int_t;
    MAKE_CONST_STRING( string_t, "string" );
    MAKE_CONST_STRING( int_t, "int" );

    if( type == string_t )
    {
      pop_n_elems( args );
      if( Pike_fp->current_object->refs != 1 )
	f_Buffer_get_copy( 0 );
      else
	f_Buffer_get( 0 );
      return;
    }

    if( type == int_t )
    {
      struct Buffer_struct *str = THIS;
      pop_stack();
      if( Pike_fp->current_object->refs != 1 )
	f_Buffer_get_copy( 0 );
      else
	f_Buffer_get( 0 );
      o_cast_to_int( );
      return;
    }
    Pike_error("Cannot cast to %S\n", type);
  }
  
  /*! @decl String.Buffer `+( string what )
   */
  PIKEFUN object `+( string what )
  {
    struct Buffer_struct *str = THIS, *str2;
    struct object *res = fast_clone_object( Buffer_program );
    str2 = OBJ2_BUFFER( res );
    str2->initial = str->initial;
    if( str->str.s )
      init_string_builder_copy (&str2->str, &str->str);
    apply( res, "add", 1 );
    RETURN res;
  }

  /*! @decl String.Buffer `+=( string what )
   */
  PIKEFUN object `+=( string what )
  {
    f_Buffer_add( 1 );
    REF_RETURN Pike_fp->current_object;
  }

  /*! @decl int add(string ... data)
   *!
   *!   Adds @[data] to the buffer. Returns the size of the buffer.
   *!
   */
  PIKEFUN int add( string ... arg1 )
  {
    struct Buffer_struct *str = THIS;
    int init_from_arg0 = 0, j;

    if (!str->str.s && args) {
      ptrdiff_t sum = 0;
      int shift = 0;
      for (j=0; j < args; j++) {
	struct pike_string *a = Pike_sp[j-args].u.string;
	sum += a->len;
	shift |= a->size_shift;
      }
      if (sum < str->initial)
	sum = str->initial;
      else if (sum > str->initial)
	sum <<= 1;
      shift = shift & ~(shift >> 1);

      if (shift == Pike_sp[-args].u.string->size_shift &&
	  init_string_builder_with_string (&str->str, Pike_sp[-args].u.string)) {
	mark_free_svalue (Pike_sp - args);
	if (sum > str->str.s->len)
	  string_build_mkspace (&str->str, sum - str->str.s->len, shift);
	init_from_arg0 = 1;
      }
      else
	init_string_builder_alloc(&str->str, sum, shift);

      /* We know it will be a string that really is this wide. */
      str->str.known_shift = shift;
    }

    for( j = init_from_arg0; j<args; j++ )
    {
      struct pike_string *a = Pike_sp[j-args].u.string;
      string_builder_shared_strcat( &str->str, a );
    }

    if (str->str.s) {
      RETURN str->str.s->len;
    } else {
      RETURN 0;
    }
  }

  /*! @decl void putchar(int c)
   *! Appends the character @[c] at the end of the string.
   */
  PIKEFUN void putchar(int c) {
    struct Buffer_struct *str = THIS;
    if(!str->str.s)
      init_string_builder_alloc(&str->str, str->initial, 0);
    string_builder_putchar(&str->str, c);
  }

  /*! @decl string get_copy()
   *!
   *!   Get the data from the buffer. Significantly slower than @[get],
   *!   but does not clear the buffer.
   */
  PIKEFUN string get_copy()
  {
    struct pike_string *str = THIS->str.s;
    if( str )
    {
      ptrdiff_t len = str->len;
      if( len > 0 )
      {
	char *d = (char *)str->str;
	switch( str->size_shift )
	{
	  case 0:
	    RETURN make_shared_binary_string0((p_wchar0 *)d,len);
	    break;
	  case 1:
	    RETURN make_shared_binary_string1((p_wchar1 *)d,len);
	    break;
	  case 2:
	    RETURN make_shared_binary_string2((p_wchar2 *)d,len);
	    break;
	}
      }
    }
    push_empty_string();
    return;
  }

  /*! @decl string get()
   *!
   *!   Get the data from the buffer.
   *!
   *! @note
   *!   This will clear the data in the buffer
   */
  PIKEFUN string get( )
  {
    struct Buffer_struct *str = THIS;
    if( str->str.s )
    {
      struct pike_string *s = finish_string_builder( &str->str );
      str->str.malloced = 0;
      str->str.s = NULL;
      RETURN s;
    }
    pop_n_elems(args);
    push_empty_string();
    return;
  }

  /*! @decl int _sizeof()
   *!
   *!   Returns the size of the buffer.
   */
  PIKEFUN int _sizeof()
  {
    struct Buffer_struct *str = THIS;
    RETURN str->str.s ? str->str.s->len : 0;
  }

  INIT
    {
      struct Buffer_struct *str = THIS;
      MEMSET( str, 0, sizeof( *str ) );
    }

  EXIT
    gc_trivial;
    {
      struct Buffer_struct *str = THIS;
      if( str->str.s )
	free_string_builder( &str->str );
    }

  GC_RECURSE
  {
    if (mc_count_bytes (Pike_fp->current_object) && THIS->str.s)
      mc_counted_bytes += THIS->str.malloced;
  }
}

/*! @endclass
 */

/*! @class Replace
 *!
 *! This is a "compiled" version of the @[replace] function applied on
 *! a string, with more than one replace string. The replace strings
 *! are given to the create method as a @i{from@} and @i{to@} array
 *! and are then analyzed. The @expr{`()@} is then called with a
 *! string and the replace rules in the Replace object will be
 *! applied. The Replace object is used internally by the Pike
 *! optimizer and need not be used manually.
 */
PIKECLASS multi_string_replace
{
  CVAR struct replace_many_context ctx;
  /* NOTE: from and to are only kept for _encode()'s use. */
  PIKEVAR array from flags ID_PROTECTED;
  PIKEVAR array to flags ID_PROTECTED;

  /*! @decl void create(array(string)|mapping(string:string)|void from, @
   *!                   array(string)|string|void to)
   */
  PIKEFUN void create(array(string)|mapping(string:string)|void from_arg,
		      array(string)|string|void to_arg)
  {
    if (THIS->from) {
      free_array(THIS->from);
      THIS->from = NULL;
    }
    if (THIS->to) {
      free_array(THIS->to);
      THIS->to = NULL;
    }
    if (THIS->ctx.v)
      free_replace_many_context(&THIS->ctx);

    if (!args) {
      push_int(0);
      return;
    }
    if (from_arg && from_arg->type == T_MAPPING) {
      if (to_arg) {
	Pike_error("Bad number of arguments to create().\n");
      }
      THIS->from = mapping_indices(from_arg->u.mapping);
      THIS->to = mapping_values(from_arg->u.mapping);
      pop_n_elems(args);
      args = 0;
    } else {
      /* FIXME: Why is from declared |void, when it isn't allowed
       *        to be void?
       *        /grubba 2004-09-02
       *
       * It probably has to do with the "if (!args)" above: It should
       * be possible to create an empty instance. /mast
       */
      if (!from_arg || !to_arg) {
	Pike_error("Bad number of arguments to create().\n");
      }
      pop_n_elems(args-2);
      args = 2;
      if (from_arg->type != T_ARRAY) {
	SIMPLE_BAD_ARG_ERROR("Replace", 1,
			     "array(string)|mapping(string:string)");
      }
      if (to_arg->type == T_STRING) {
	push_int(from_arg->u.array->size);
	stack_swap();
	f_allocate(2);
      }
      if (to_arg->type != T_ARRAY) {
	SIMPLE_BAD_ARG_ERROR("Replace", 2, "array(string)|string");
      }
      if (from_arg->u.array->size != to_arg->u.array->size) {
	Pike_error("Replace must have equal-sized from and to arrays.\n");
      }
      add_ref(THIS->from = from_arg->u.array);
      add_ref(THIS->to = to_arg->u.array);
    }

    if (!THIS->from->size) {
      /* Enter no-op mode. */
      pop_n_elems(args);
      push_int(0);
      return;
    }

    if( (THIS->from->type_field & ~BIT_STRING) &&
	(array_fix_type_field(THIS->from) & ~BIT_STRING) )
      SIMPLE_BAD_ARG_ERROR("Replace", 1,
			   "array(string)|mapping(string:string)");

    if( (THIS->to->type_field & ~BIT_STRING) &&
	(array_fix_type_field(THIS->to) & ~BIT_STRING) )
      SIMPLE_BAD_ARG_ERROR("Replace", 2, "array(string)|string");

    compile_replace_many(&THIS->ctx, THIS->from, THIS->to, 1);

    pop_n_elems(args);
    push_int(0);
  }

  /*! @decl string `()(string str)
   */
  PIKEFUN string `()(string str)
  {
    if (!THIS->ctx.v) {
      /* The result is already on the stack in the correct place... */
      return;
    }

    RETURN execute_replace_many(&THIS->ctx, str);
  }

  /*! @decl array(array(string)) _encode()
   */
  PIKEFUN array(array(string)) _encode()
  {
    if (THIS->from) {
      ref_push_array(THIS->from);
    } else {
      push_undefined();
    }
    if (THIS->to) {
      ref_push_array(THIS->to);
    } else {
      push_undefined();
    }
    f_aggregate(2);
  }

  /*! @decl void _decode(array(array(string)) encoded)
   */
  PIKEFUN void _decode(array(array(string)) encoded)
  {
    INT32 i;
    for (i=0; i < encoded->size; i++) {
      push_svalue(encoded->item + i);
      stack_swap();
    }
    pop_stack();

    f_multi_string_replace_create(i);
  }

  INIT
  {
    MEMSET(&THIS->ctx, 0, sizeof(struct replace_many_context));
  }

  EXIT
    gc_trivial;
  {
    free_replace_many_context(&THIS->ctx);
  }
}

/*! @endclass
 */

/*! @class SingleReplace
 *!
 *! This is a "compiled" version of the @[replace] function applied on
 *! a string, with just one replace string. The replace strings are
 *! given to the create method as a @i{from@} and @i{tom@} string and
 *! are then analyzed. The @expr{`()@} is then called with a string
 *! and the replace rule in the Replace object will be applied. The
 *! Replace object is used internally by the Pike optimizer and need
 *! not be used manually.
 */
PIKECLASS single_string_replace
{
  CVAR SearchMojt mojt;
  PIKEVAR string del flags ID_PROTECTED|ID_PRIVATE;
  PIKEVAR string to flags ID_PROTECTED|ID_PRIVATE;

  EXTRA
  {
    MAP_VARIABLE ("o", tObj, ID_PROTECTED|ID_PRIVATE,
		  single_string_replace_storage_offset +
		  OFFSETOF (single_string_replace_struct, mojt.container),
		  T_OBJECT);
  }

  /*! @decl void create(string|void from, string|void to)
   *!
   *! @note
   *!   May be called with either zero or two arguments.
   */
  PIKEFUN void create(string|void del, string|void to)
  {
    if (THIS->del) {
      free_string(THIS->del);
      THIS->del = NULL;
    }
    if (THIS->to) {
      free_string(THIS->to);
      THIS->to = NULL;
    }

    if (!del) return;

    if (!to) {
      SIMPLE_BAD_ARG_ERROR("String.SingleReplace->create", 2, "string");
    }

    if (del == to) {
      /* No-op... */
      return;
    }

    copy_shared_string(THIS->del, del);
    copy_shared_string(THIS->to, to);

    if (del->len) {
      THIS->mojt = simple_compile_memsearcher(del);
    }
  }

  /*** replace function ***/
  typedef char *(* replace_searchfunc)(void *,void *,size_t);

  /*! @decl string `()(string str)
   */
  PIKEFUN string `()(string str)
  {
    int shift;
    struct pike_string *del = THIS->del;
    struct pike_string *to = THIS->to;
    struct pike_string *ret = NULL;

    if (!str->len || !del || !to) {
      /* The result is already on the stack in the correct place... */
      return;
    }

    shift = MAXIMUM(str->size_shift, to->size_shift);

    if (!del->len) {
      int e, pos;
      ret = begin_wide_shared_string(str->len + to->len * (str->len-1),
				     shift);
      low_set_index(ret, 0, index_shared_string(str, 0));
      for(pos=e=1;e<str->len;e++)
      {
	pike_string_cpy(MKPCHARP_STR_OFF(ret,pos), to);
	pos+=to->len;
	low_set_index(ret,pos++,index_shared_string(str,e));
      }
    } else {
      char *s, *end, *tmp;
      replace_searchfunc f = (replace_searchfunc)0;
      void *mojt_data = THIS->mojt.data;
      PCHARP r;

      end = str->str+(str->len<<str->size_shift);

      switch(str->size_shift)
      {
      case 0: f = (replace_searchfunc)THIS->mojt.vtab->func0; break;
      case 1: f = (replace_searchfunc)THIS->mojt.vtab->func1; break;
      case 2: f = (replace_searchfunc)THIS->mojt.vtab->func2; break;
#ifdef PIKE_DEBUG
      default: Pike_fatal("Illegal shift.\n");
#endif
      }

      if(del->len == to->len)
      {
	ret = begin_wide_shared_string(str->len, shift);
      } else {
	INT32 delimiters = 0;

	s = str->str;

	while((s = f(mojt_data, s, (end-s)>>str->size_shift)))
	{
	  delimiters++;
	  s += del->len << str->size_shift;
	}

	if (!delimiters) {
	  /* The result is already on the stack in the correct place... */
	  return;
	}

	ret = begin_wide_shared_string(str->len +
				       (to->len-del->len)*delimiters, shift);
      }

      s = str->str;
      r = MKPCHARP_STR(ret);

      while((tmp = f(mojt_data, s, (end-s)>>str->size_shift)))
      {
#ifdef PIKE_DEBUG
	if(tmp + (del->len << str->size_shift) > end)
	  Pike_fatal("SearchMojt found a match beyond end of string!\n");
#endif
	generic_memcpy(r,MKPCHARP(s,str->size_shift),(tmp-s)>>str->size_shift);
	INC_PCHARP(r,(tmp-s)>>str->size_shift);
	pike_string_cpy(r,to);
	INC_PCHARP(r,to->len);
	s=tmp+(del->len << str->size_shift);
      }
      generic_memcpy(r,MKPCHARP(s,str->size_shift),(end-s)>>str->size_shift);
    }
    RETURN end_shared_string(ret);
  }

  /*! @decl array(string) _encode()
   */
  PIKEFUN array(string) _encode()
  {
    if (THIS->del) {
      ref_push_string(THIS->del);
      ref_push_string(THIS->to);
      f_aggregate(2);
    } else {
      push_int(0);
    }
  }

  /*! @decl void _decode(array(string)|int(0..0) encoded)
   */
  PIKEFUN void _decode(array(string)|int(0..0) encoded_)
  {    
    INT32 i = 0;
    if (encoded_->type == PIKE_T_ARRAY) {
      struct array *encoded = encoded_->u.array;

      for (i=0; i < encoded->size; i++) {
	push_svalue(encoded->item + i);
	stack_swap();
      }
    }
    pop_stack();
      
    f_single_string_replace_create(i);
  }
}

/*! @endclass
 */

/*! @class Bootstring
 *!
 *! This class implements the "Bootstring" string transcoder described in
 *! @url{ftp://ftp.rfc-editor.org/in-notes/rfc3492.txt@}.
 */
PIKECLASS bootstring
{
  CVAR INT_TYPE base, tmin, tmax, skew, damp;
  CVAR INT_TYPE initial_bias, initial_n;
  CVAR p_wchar2 delim;
  PIKEVAR string digits flags ID_PROTECTED|ID_PRIVATE;

  static INT_TYPE bootstring_cp_to_digit(p_wchar2 ch)
  {
    ptrdiff_t digit = THIS->digits->len;
    PCHARP digits = MKPCHARP_STR( THIS->digits );
    while (digit>=0)
      if (INDEX_PCHARP( digits, digit ) == ch)
	return digit;
      else
	--digit;
    return -1;
  }

  static INT_TYPE bootstring_adapt(INT_TYPE delta, INT_TYPE numpoints,
				   int firsttime)
  {
    struct bootstring_struct *bs = THIS;
    INT_TYPE k = 0, b = bs->base;
    INT_TYPE a = b - bs->tmin;
    INT_TYPE limit = (a * bs->tmax) >> 1;
    if (firsttime)
      delta /= bs->damp;
    else
      delta >>= 1;
    delta += delta / numpoints;
    while (delta > limit) {
      delta /= a;
      k += b;
    }
    return k + (a + 1)*delta / (delta + bs->skew);
  }

  /*! @decl string decode(string s)
   *!
   *! Decodes a Bootstring encoded string of "basic" code points back
   *! to the original string space.
   */
  PIKEFUN string decode(string s)
  {
    struct bootstring_struct *bs = THIS;
    INT_TYPE n = bs->initial_n;
    INT_TYPE i = 0;
    INT_TYPE bias = bs->initial_bias;
    ptrdiff_t pos, input_left;
    PCHARP input;
    struct string_builder output;
    init_string_builder( &output,0 );
    input = MKPCHARP_STR( s );
    input_left = s->len;
    for (pos = input_left-1; pos > 0; --pos)
      if (INDEX_PCHARP( input, pos ) == bs->delim) {
	string_builder_append( &output, input, pos );
	INC_PCHARP( input, pos+1 );
	input_left -= pos+1;
	break;
      }

    while (input_left > 0) {
      INT_TYPE oldi = i;
      INT_TYPE w = 1;
      INT_TYPE k;
      for (k=bs->base; ; k+=bs->base) {
	INT_TYPE digit, t;
	if (input_left < 1 ||
	    (digit = bootstring_cp_to_digit( EXTRACT_PCHARP( input ) )) < 0) {
	  free_string_builder( &output );
	  Pike_error( "Invalid variable-length integer.\n" );
	}
	INC_PCHARP( input, 1 );
	--input_left;
	i += digit * w;	/* fail on overflow... */
	if (k <= bias + bs->tmin)
	  t = bs->tmin;
	else if (k >= bias + bs->tmax)
	  t = bs->tmax;
	else
	  t = k - bias;
	if (digit < t) break;
	w *= (bs->base - t);
      }
      bias = bootstring_adapt( i - oldi, output.s->len+1, !oldi );
      n += i / (output.s->len+1);
      i %= output.s->len+1;
      string_builder_putchar( &output, n );
      if (i != output.s->len-1)
	switch (output.s->size_shift) {
	case 0:
	  {
	    p_wchar0 *s = STR0(output.s);
	    INT_TYPE p = output.s->len;
	    while (--p>i)
	      s[p] = s[p-1];
	    s[p] = DO_NOT_WARN ((p_wchar0) n);
	  }
	  break;
	case 1:
	  {
	    p_wchar1 *s = STR1(output.s);
	    INT_TYPE p = output.s->len;
	    while (--p>i)
	      s[p] = s[p-1];
	    s[p] = DO_NOT_WARN ((p_wchar1) n);
	  }
	  break;
	case 2:
	  {
	    p_wchar2 *s = STR2(output.s);
	    INT_TYPE p = output.s->len;
	    while (--p>i)
	      s[p] = s[p-1];
	    s[p] = DO_NOT_WARN ((p_wchar2) n);
	  }
	  break;
#ifdef PIKE_DEBUG
	default:
	  Pike_fatal("Illegal shift size!\n");
#endif
	}
      i++;
    }

    RETURN finish_string_builder( &output );
  }

  /*! @decl string encode(string s)
   *!
   *! Encodes a string using Bootstring encoding into a string constisting
   *! only of "basic" code points (< initial_n).
   */
  PIKEFUN string encode(string s)
  {
    struct bootstring_struct *bs = THIS;
    INT_TYPE n = bs->initial_n;
    INT_TYPE delta = 0;
    INT_TYPE bias = bs->initial_bias;
    INT_TYPE c, h, b = 0;
    ptrdiff_t pos, input_left;
    PCHARP input;
    struct string_builder output;
    init_string_builder( &output,0 );
    input = MKPCHARP_STR( s );
    input_left = s->len;
    for (pos=0; pos<input_left; pos++)
      if ((c = INDEX_PCHARP( input, pos )) < n) {
	string_builder_putchar( &output, c );
	b++;
      }
    if ((h = b))
      string_builder_putchar( &output, bs->delim );
    while (h < input_left) {
      INT_TYPE m = -1;
      for (pos=0; pos<input_left; pos++)
	if ((c = INDEX_PCHARP( input, pos )) >= n &&
	    (m < 0 || c < m))
	  m = c;
      delta = delta + (m - n) * (h + 1); /* fail on overflow... */
      n = m;
      for (pos=0; pos<input_left; pos++)
	if ((c = INDEX_PCHARP( input, pos )) < n)
	  delta++;
	else if (c == n) {
	  INT_TYPE k, q = delta;
	  for (k=bs->base; ; k+=bs->base) {
	    INT_TYPE t, bt;
	    if (k <= bias + bs->tmin)
	      t = bs->tmin;
	    else if(k >= bias + bs->tmax)
	      t = bs->tmax;
	    else
	      t = k-bias;
	    if (q < t)
	      break;
	    bt = bs->base - t;
	    string_builder_putchar( &output,
				    index_shared_string( bs->digits,
							 t + (q-t)%bt ) );
	    q = (q-t) / bt;
	  }
	  string_builder_putchar( &output,
				  index_shared_string( bs->digits, q ) );
	  bias = bootstring_adapt( delta, h+1, h==b );
	  delta = 0;
	  h++;
	}
      delta++;
      n++;
    }

    RETURN finish_string_builder( &output );
  }

  /*! @decl void create(int base, int tmin, int tmax, int skew,		@
   *!                   int damp, int initial_bias, int initial_n,	@
   *!			int delim, string digits)
   *!
   *! Creates a Bootstring transcoder instance using the specified parameters.
   *!
   *! @param base
   *!   The base used by the variable-length integers.
   *! @param tmin
   *!   The minimum threshold digit value for the variable-length integers.
   *!   Must be >=0 and <= tmax.
   *! @param tmax
   *!   The maximum threshold digit value for the variable-length integers.
   *!   Must be <= base-1.
   *! @param skew
   *!   The skew term for the bias adapation.  Must be >= 1.
   *! @param damp
   *!   The damping factor for the bias adaption.  Must be >= 2.
   *! @param initial_bias
   *!   The initial bias for the variable-length integer thresholding.
   *!   initial_bias % base must be <= base - tmin.
   *! @param initial_n
   *!   The first code point outside the "basic" set of code points.
   *! @param delim
   *!   The "basic" code point used as the delimiter.
   *! @param digits
   *!   The "basic" code points used as digits.  The length of the string
   *!   should be the same as the base parameter.
   */
  PIKEFUN void create( int base, int tmin, int tmax,
		       int skew, int damp, 
		       int initial_bias, int initial_n,
		       int delim, string digits )
    flags ID_PROTECTED;
  {
    struct bootstring_struct *bs = THIS;
    if (base<2)
      Pike_error("Bogus base\n");
    if (tmin<0 || tmax<tmin || base-1<tmax)
      Pike_error("Parameters violate 0 <= tmin <= tmax <= base-1\n");
    if (skew < 1)
      Pike_error("Parameters violate skew >= 1\n");
    if (damp < 2)
      Pike_error("Parameters violate damp >= 2\n");
    if (initial_bias%base > base-tmin)
      Pike_error("Parameters violate initial_bias%%base <= base-tmin\n");
    if (digits->len != base)
      Pike_error("Length of digits string does not match base.\n");
    bs->base = base;  bs->tmin = tmin;  bs->tmax = tmax;
    bs->skew = skew;  bs->damp = damp;
    bs->initial_bias = initial_bias;  bs->initial_n = initial_n;
    bs->delim = delim;
    if (bs->digits) {
      free_string( bs->digits );
      bs->digits = NULL;
    }
    copy_shared_string( bs->digits, digits );
  }

}

/*! @endclass
 */

/*! @endmodule
 */

/*! @module System
 */

/*! @class Time
 *!
 *! The current time as a structure containing a sec and a usec
 *! member.
 */
PIKECLASS Time
{
  CVAR int hard_update;
  
  /*! @decl int sec;
   *! @decl int usec;
   *!
   *!   The number of seconds and microseconds since the epoch and the
   *!   last whole second, respectively. (See also @[predef::time()])
   *!
   *!   Please note that these variables will continually update when
   *!   they are requested, there is no need to create new Time()
   *!   objects.
   */

  /*! @decl int usec_full;
   *!
   *!   The number of microseconds since the epoch. Please note that
   *!   pike has to have been compiled with bignum support for this
   *!   variable to contain sensible values.
   */

  PIKEFUN int `->( string x )
  {
    extern struct timeval current_time;
    struct pike_string *usec;
    struct pike_string *sec, *usec_full;

    MAKE_CONST_STRING( sec, "sec" );
    MAKE_CONST_STRING( usec, "usec" );
    MAKE_CONST_STRING (usec_full, "usec_full");

    if( !x ) {
      push_undefined();
      return;
    }

    if( THIS->hard_update )
      GETTIMEOFDAY( &current_time );

    if( x == usec )
      RETURN current_time.tv_usec;
    if( x == sec )
      RETURN current_time.tv_sec;
    if (x != usec_full) {
      push_undefined();
      return;
    }

#ifdef AUTO_BIGNUM
    pop_stack();
    push_int( current_time.tv_sec );
    push_int( 1000000 );
    f_multiply( 2 );
    push_int( current_time.tv_usec );
    f_add( 2 );
    return;
#else
    RETURN (current_time.tv_sec * 1000000 + current_time.tv_usec);
#endif
  }
  
  PIKEFUN int `[]( string x )
  {
    f_Time_cq__backtick_2D_3E( args );
  }

  /*! @decl protected void create( int fast );
   *!
   *! If @[fast] is true, do not request a new time from the system,
   *! instead use the global current time variable.
   *!
   *! This will only work in callbacks, but can save significant amounts
   *! of CPU.
   */
  PIKEFUN void create( int|zero|void fast )
  {
    THIS->hard_update = !fast;
  }
}

/*! @endclass
 */

/*! @class Timer
 */
PIKECLASS Timer
{
  CVAR struct timeval last_time;
  CVAR int hard_update;
  
  /*! @decl float peek()
   *!   Return the time in seconds since the last time @[get] was called.
   */
  PIKEFUN float peek( )
  {
    extern struct timeval current_time;
    FLOAT_TYPE res;
    if( THIS->hard_update )
      GETTIMEOFDAY( &current_time );
    res = current_time.tv_sec-THIS->last_time.tv_sec +
      (current_time.tv_usec-THIS->last_time.tv_usec)/(FLOAT_TYPE) 1000000.0;
    RETURN res;
  }

  /*! @decl float get()
   *!   Return the time in seconds since the last time get was called.
   *!   The first time this method is called the time since the object
   *!   was created is returned instead.
   */
  PIKEFUN float get( )
  {
    extern struct timeval current_time;
    f_Timer_peek( 0 );
    THIS->last_time = current_time;
    return;
  }

  /*! @decl protected void create( int|void fast )
   *!   Create a new timer object. The timer keeps track of relative time
   *!   with sub-second precision.
   *!   
   *!   If @[fast] is specified, the timer will not do system calls to get
   *!   the current time but instead use the one maintained by pike. This
   *!   will result in faster but more or less inexact timekeeping.
   *!   The pike maintained time is only updated when a @[Pike.Backend]
   *!   object stops waiting and starts executing code.
   */
  PIKEFUN void create( int|zero|void fast )
  {
    extern struct timeval current_time;
    THIS->hard_update = !fast;
    if( THIS->hard_update )
      GETTIMEOFDAY( &current_time );
    THIS->last_time = current_time; 
  }
}

/*! @endclass
 */

/*! @endmodule
 */


PIKECLASS automap_marker
{
  PIKEVAR array arg;
  PIKEVAR int depth;

  PIKEFUN void create(array a, int d)
    {
      if(THIS->arg) free_array(THIS->arg);
      add_ref(THIS->arg=a);
      THIS->depth=d;
    }

  PIKEFUN string _sprintf(int mode, mapping flags)
    {
      pop_n_elems(args);
      if (mode != 'O') {
	push_undefined ();
	return;
      }
      push_text("%O%*'[*]'n");
      if(THIS->arg)
	ref_push_array(THIS->arg);
      else
	push_int(0);
      push_int(THIS->depth*3);
      f_sprintf(3);
    }
}


static void low_automap(int d,
			int depth,
			struct svalue *fun,
			struct svalue *real_args,
			INT32 args)
{
  INT32 x,e,tmp,size=0x7fffffff;
  struct svalue *tmpargs=Pike_sp - args;
  struct array *ret;
  TYPE_FIELD types;

  for(e=0;e<args;e++)
  {
    if(real_args[e].type==T_OBJECT &&
       real_args[e].u.object->prog == automap_marker_program &&
       OBJ2_AUTOMAP_MARKER(real_args[e].u.object)->depth >= d)
    {
      if(tmpargs[e].type != T_ARRAY)
	index_error("__automap__",
		    Pike_sp-args,
		    args,
		    tmpargs,
		    NULL,
		    "Automap on non-array.\n");
      tmp=tmpargs[e].u.array->size;
      if(tmp < size)
	size=tmp;
    }
  }

#ifdef PIKE_DEBUG
   if(size == 0x7fffffff)
    Pike_fatal("No automap markers found in low_automap\n");
#endif

  push_array(ret=allocate_array(size));
  types = 0;

  for(x=0;x<size;x++)
  {
    for(e=0;e<args;e++)
    {
      if(real_args[e].type==T_OBJECT &&
	 real_args[e].u.object->prog == automap_marker_program &&
	 OBJ2_AUTOMAP_MARKER(real_args[e].u.object)->depth >= d)
      {
#ifdef PIKE_DEBUG
	if(x >= tmpargs[e].u.array->size)
	  Pike_fatal("low_automap failed to determine size!\n");
#endif
	push_svalue(ITEM(tmpargs[e].u.array)+x);
      }else{
	push_svalue(tmpargs+e);
      }
    }
    
    if(d == depth)
      apply_svalue(fun,args);
    else
      low_automap(d+1,depth,fun,real_args,args);
    stack_pop_to_no_free (ITEM(ret) + x);
    types |= 1 << ITEM(ret)[x].type;
  }
  ret->type_field = types;
  stack_unlink(args);
}


PIKEFUN array __automap__(mixed fun, mixed ... tmpargs)
  efun;
{
  int e,depth=-1;
  check_stack(args);

  for(e=0;e<args-1;e++)
  {
    if(tmpargs[e].type==T_OBJECT &&
       tmpargs[e].u.object->prog == automap_marker_program)
    {
      int tmp=OBJ2_AUTOMAP_MARKER(tmpargs[e].u.object)->depth;
      if(tmp > depth) depth=tmp;
      ref_push_array(OBJ2_AUTOMAP_MARKER(tmpargs[e].u.object)->arg);
    }else{
      push_svalue(tmpargs+e);
    }
  }
  check_stack(depth * (args+1));
  low_automap(1,depth,fun,tmpargs,args-1);
  stack_unlink(args);
}

/* Linked list stuff.
 */
#undef INIT_BLOCK
#define INIT_BLOCK(NODE) do {				\
    (NODE)->next = (NODE)->prev = NULL;			\
    (NODE)->refs = 1;					\
    (NODE)->val.type = T_INT;				\
    (NODE)->val.subtype = NUMBER_UNDEFINED;		\
    (NODE)->val.u.integer = 0;				\
  } while(0) 

#undef EXIT_BLOCK
#define EXIT_BLOCK(NODE) do {				\
    if ((NODE)->prev) {					\
      free_list_node((NODE)->prev);			\
    }							\
    if ((NODE)->next) {					\
      free_list_node((NODE)->next);			\
    }							\
    free_svalue(&(NODE)->val);				\
  } while(0)

BLOCK_ALLOC_FILL_PAGES(pike_list_node, 4);

PMOD_EXPORT void free_list_node(struct pike_list_node *node)
{
  if (!sub_ref(node)) {
    really_free_pike_list_node(node);
  }
}

PMOD_EXPORT void unlink_list_node(struct pike_list_node *n)
{
#ifdef PIKE_DEBUG
  if (!n) {
    Pike_fatal("Unlinking NULL node.\n");
  }
  if (!n->next || !n->prev) {
    Pike_fatal("Unlinking unlinked node.\n");
  }
#endif /* PIKE_DEBUG */
  if (n->prev->next == n) {
#ifdef PIKE_DEBUG
    if (n->next->prev != n) {
      Pike_fatal("Partially detached node.\n");
    }
#endif /* PIKE_DEBUG */
    n->prev->next = n->next;
    n->next->prev = n->prev;
    n->next = n->prev = NULL;

    /* We've lost two references. */
    free_list_node(n);
    free_list_node(n);
  } else {
#ifdef PIKE_DEBUG
    if (n->next->prev == n) {
      Pike_fatal("Partially detached node.\n");
    }
#endif /* PIKE_DEBUG */
    /* The node is already detached. */
    n->next = n->prev = NULL;
  }
}

PMOD_EXPORT void detach_list_node(struct pike_list_node *n)
{
#ifdef PIKE_DEBUG
  if (!n) {
    Pike_fatal("Detaching NULL node.\n");
  }
  if (!n->next || !n->prev) {
    Pike_fatal("Detaching unlinked node.\n");
  }
#endif /* PIKE_DEBUG */
  if (n->prev->next == n) {
#ifdef PIKE_DEBUG
    if (n->next->prev != n) {
      Pike_fatal("Partially detached node.\n");
    }
#endif /* PIKE_DEBUG */
    n->prev->next = n->next;
    n->next->prev = n->prev;
    add_ref(n->next);
    add_ref(n->prev);

    /* We've lost two references. */
    free_list_node(n);
    free_list_node(n);
#ifdef PIKE_DEBUG
  } else if (n->next->prev == n) {
    Pike_fatal("Partially detached node.\n");
#endif /* PIKE_DEBUG */
  }
}

PMOD_EXPORT void prepend_list_node(struct pike_list_node *node,
				   struct pike_list_node *new_node)
{
#ifdef PIKE_DEBUG
  if (!node) {
    Pike_fatal("No node to prepend.\n");
  }
  if (!node->prev) {
    Pike_fatal("Prepending unhooked node.\n");
  }
  if (!new_node) {
    Pike_fatal("Prepending NULL node.\n");
  }
  if (new_node->next || new_node->prev) {
    Pike_fatal("Prepending hooked node.\n");
  }
#endif /* PIKE_DEBUG */
  new_node->next = node;
  new_node->prev = node->prev;
  new_node->prev->next = node->prev = new_node;
  add_ref(new_node);
  add_ref(new_node);
}

PMOD_EXPORT void append_list_node(struct pike_list_node *node,
				  struct pike_list_node *new_node)
{
#ifdef PIKE_DEBUG
  if (!node) {
    Pike_fatal("No node to append.\n");
  }
  if (!node->next) {
    Pike_fatal("Appending unhooked node.\n");
  }
  if (!new_node) {
    Pike_fatal("Appending NULL node.\n");
  }
  if (new_node->next || new_node->prev) {
    Pike_fatal("Appending hooked node.\n");
  }
#endif /* PIKE_DEBUG */
  new_node->next = node->next;
  new_node->prev = node;
  new_node->next->prev = node->next = new_node;
  add_ref(new_node);
  add_ref(new_node);
}

/*! @module Sql
 */

/*! @class Null
 *!
 *! This class is used to implement the SQL NULL value.
 *!
 *! @note
 *!   There's typically only one object of this class: @[Sql.NULL],
 *!   but some databases (eg Oracle) have multiple types of NULL,
 *!   in which case they all inherit this class.
 *!
 *! @deprecated Val.Null
 *!
 *! @seealso
 *!   @[Val.Null], @[Val.null], @[Sql.NULL]
 */
PIKECLASS SqlNull
{
  EXTRA {
    /*! @decl constant is_val_null = 1
     *!
     *! Nonzero recognition constant.
     */
    add_integer_constant("is_val_null", 1, 0);

    /*! @decl constant is_sql_null = 1
     *!
     *! SQL Null marker.
     *!
     *! @deprecated is_val_null
     */
    add_integer_constant("is_sql_null", 1, 0);
  }

  PIKEFUN int `!()
    flags ID_PROTECTED;
  {
    RETURN 1;
  }

  PIKEFUN string _sprintf(int fmt, mixed ... extras)
    flags ID_PROTECTED;
  {
    pop_n_elems(args);
    if (fmt == 'O') {
      push_constant_text("Sql.NULL");
    } else {
      push_undefined();
    }
  }

  PIKEFUN int __hash()
    flags ID_PROTECTED;
  {
    pop_n_elems(args);
    push_int(17);
  }
    
  PIKEFUN int `==(mixed other)
    flags ID_PROTECTED;
  {
    if (other->type != T_OBJECT) {
      pop_stack();
      push_int(0);
      return;
    }

    /* Look for the is_val_null constant directly in the program of
     * other, without going through its `[]. When this is called in a
     * codec, other can be a completely arbitrary object which may not
     * have a `[] that works in that context. */
    push_int (0);
    ref_push_program (other->u.object->prog);
    push_constant_text("is_sql_null");
    if (program_index_no_free (Pike_sp - 3, Pike_sp - 2, Pike_sp - 1) &&
	Pike_sp[-3].type == T_INT && Pike_sp[-3].u.integer) {
      pop_n_elems (4);
      push_int (1);
    }
    else {
      pop_n_elems (4);
      push_int (0);
    }
  }

  /*! @decl string encode_json()
   *!
   *! Defined for use with @[Standards.JSON.encode], so that it
   *! formats NULL as @expr{null@}.
   */
  PIKEFUN string encode_json(...)
  {
    push_constant_text ("null");
  }
}

/*! @endclass
 */

/*! @endmodule
 */

/*! @module ADT
 */

/*! @class List
 *!
 *!   Linked list of values.
 */
PIKECLASS List
{
  CVAR struct pike_list_node *head;
  CVAR INT32 head_sentinel_refs;
  CVAR struct pike_list_node *tail;		/* Always NULL. */
  CVAR INT32 tail_sentinel_refs;
  CVAR struct pike_list_node *tail_pred;
  CVAR INT32 num_elems;

#define HEAD_SENTINEL(this)	((struct pike_list_node *)(&this->head))
#define TAIL_SENTINEL(this)	((struct pike_list_node *)(&this->tail))

  /* Sentinel overlap description:
   *
   * List			Head sentinel		Tail sentinel
   *   head			  next
   *   head_sentinel_refs	  refs
   *   tail			  prev			  next
   *   tail_sentinel_refs				  refs
   *   tail_pred					  prev
   */

  /* Suggestions for future functionality:
   *
   *   o Pop tail
   *   o Join
   *   o Copy segment
   *   o Detach segment (requires new iterator implementation)
   *   o Iterator copy
   *   o _equal() for iterators and lists.
   *   o _values(), _search(), cast()
   *   o _sizeof()?, _indices()??
   *   o Support for reverse(), filter() and map().
   *   o Initialization from array.
   *   o Support for Pike.count_memory.
   */

  INIT
  {
    THIS->tail = NULL;
    THIS->head = TAIL_SENTINEL(THIS);
    THIS->tail_pred = HEAD_SENTINEL(THIS);
    THIS->head_sentinel_refs = THIS->tail_sentinel_refs = 2;
    THIS->num_elems = 0;
  }

  EXIT
    gc_trivial;
  {
    struct pike_list_node *node = THIS->head;
    struct pike_list_node *next;
    while ((next = node->next)) {
#ifdef PIKE_DEBUG
      if (node->refs != 2) {
	Pike_fatal("Unexpected number of references for node: %d\n",
		   node->refs);
      }
#endif /* PIKE_DEBUG */
      unlink_list_node(node);
      node = next;
    }
  }

  /* These two functions perform the same thing,
   * but are optimized to minimize recursion.
   */
  static void gc_check_list_node_backward(struct pike_list_node *node,
					  const char *msg);
  static void gc_check_list_node_forward(struct pike_list_node *node,
					 const char *msg)
  {
    while (node && !debug_gc_check(&node->refs, msg)) {
      if (node->next)
	debug_gc_check_svalues(&node->val, 1,  " as a list node value");
      gc_check_list_node_backward(node->prev, msg);
      node = node->next;
    }
  }

  static void gc_check_list_node_backward(struct pike_list_node *node,
					  const char *msg)
  {
    while (node && !debug_gc_check(&node->refs, msg)) {
      if (node->prev)
	debug_gc_check_svalues(&node->val, 1, " as a list node value");
      gc_check_list_node_forward(node->next, msg);
      node = node->prev;
    }
  }

  /* Called at gc_check time. */
  GC_CHECK
  {
    gc_check_list_node_backward(HEAD_SENTINEL(THIS), " as a list node");
    gc_check_list_node_forward(TAIL_SENTINEL(THIS), " as a list node");
  }

  /* Called at gc_mark time */
  GC_RECURSE
  {
    struct pike_list_node *node = THIS->head;
    struct pike_list_node *next;
    while ((next = node->next)) {
      gc_recurse_svalues(&node->val, 1);
      node = next;
    }
    /* FIXME: mc_count_bytes */
  }

  /*! @decl int(0..1) is_empty()
   *!
   *!   Check if the list is empty.
   *!
   *! @returns
   *!   Returns @expr{1@} if the list is empty,
   *!   and @expr{0@} (zero) if there are elements in the list.
   */
  PIKEFUN int(0..1) is_empty()
  {
    push_int(!THIS->head->next);
  }

  /*! @decl int(0..) _sizeof()
   *!
   *!   Returns the number of elements in the list.
   */
  PIKEFUN int(0..) _sizeof()
    flags ID_PROTECTED;
  {
    push_int(THIS->num_elems);
  }

  /*! @decl string _sprintf(int c, mapping(string:mixed)|void attr)
   *!
   *!   Describe the list.
   *!
   *! @seealso
   *!   @[sprintf()], @[lfun::_sprintf()]
   */
  PIKEFUN string _sprintf(int c, mapping(string:mixed)|void attr)
    flags ID_PROTECTED;
  {
    if (!THIS->num_elems) {
      push_constant_text("ADT.List(/* empty */)");
    } else if (c == 'O') {
      struct pike_list_node *node = THIS->head;
      if (THIS->num_elems == 1) {
	push_constant_text("ADT.List(/* 1 element */\n");
      } else {
	push_constant_text("ADT.List(/* %d elements */\n");
	push_int(THIS->num_elems);
	f_sprintf(2);
      }
      while (node->next) {
	if (node->next->next) {
	  push_constant_text("    %O,\n");
	} else {
	  push_constant_text("    %O\n");
	}
	push_svalue(&node->val);
	f_sprintf(2);
	node = node->next;
      }
      push_constant_text(")");
      f_add(THIS->num_elems + 2);
    } else {
      if (THIS->num_elems == 1) {
	push_constant_text("ADT.List(/* 1 element */)");
      } else {
	push_constant_text("ADT.List(/* %d elements */)");
	push_int(THIS->num_elems);
	f_sprintf(2);
      }
    }
    stack_pop_n_elems_keep_top(args);
  }

  /*! @decl mixed head()
   *!
   *!   Get the element at the head of the list.
   *!
   *! @throws
   *!   Throws an error if the list is empty.
   *!
   *! @seealso
   *!   @[is_empty()], @[tail()], @[pop()]
   */
  PIKEFUN mixed head()
  {
    if (THIS->head->next) {
      push_svalue(&THIS->head->val);
    } else {
      Pike_error("Empty list.\n");
    }
  }

  /*! @decl mixed tail()
   *!
   *!   Get the element at the tail of the list.
   *!
   *! @throws
   *!   Throws an error if the list is empty.
   *!
   *! @seealso
   *!   @[is_empty()], @[head()], @[pop()]
   */
  PIKEFUN mixed tail()
  {
    if (THIS->tail->prev) {
      push_svalue(&THIS->tail->val);
    } else {
      Pike_error("Empty list.\n");
    }
  }

  /*! @decl mixed pop()
   *!
   *!   Pop the element at the head of the list from the list.
   *!
   *! @throws
   *!   Throws an error if the list is empty.
   *!
   *! @seealso
   *!   @[is_empty()], @[head()], @[tail()]
   */
  PIKEFUN mixed pop()
  {
    if (THIS->head->next) {
      push_svalue(&THIS->head->val);
      if (THIS->head->refs == 2) {
	unlink_list_node(THIS->head);
      } else {
	detach_list_node(THIS->head);
      }
      THIS->num_elems--;
    } else {
      Pike_error("Empty list.\n");
    }
  }

  /*! @decl void append(mixed ... values)
   *!
   *!   Append @[values] to the end of the list.
   *!
   *! @seealso
   *!   @[insert()]
   */
  PIKEFUN void append(mixed ... values)
  {
    struct pike_list_node *node = TAIL_SENTINEL(THIS);
    while (args--) {
      struct pike_list_node *new_node = alloc_pike_list_node();
      new_node->val = *(--Pike_sp);
      prepend_list_node(node, new_node);
      free_list_node(node = new_node);
      THIS->num_elems++;
    }
    push_int(0);
  }

  /*! @decl void insert(mixed ... values)
   *!
   *!   Insert @[values] at the front of the list.
   *!
   *! @seealso
   *!   @[append()]
   */
  PIKEFUN void insert(mixed ... values)
  {
    struct pike_list_node *node = THIS->head;
    while (args--) {
      struct pike_list_node *new_node = alloc_pike_list_node();
      new_node->val = *(--Pike_sp);
      prepend_list_node(node, new_node);
      free_list_node(node = new_node);
      THIS->num_elems++;
    }
    push_int(0);
  }

  /*! @decl void create(mixed ... values)
   *!
   *!   Create a new @[List], and initialize it with @[values].
   *!
   *! @fixme
   *!   Ought to reset the @[List] if called multiple times.
   */
  PIKEFUN void create(mixed ... values)
    flags ID_PROTECTED;
  {
    /* FIXME: Reset the list? */
    apply_current(f_List_append_fun_num, args);
  }

  /*! @class _get_iterator
   *!
   *!   @[Iterator] that loops over the @[List].
   */
  PIKECLASS _get_iterator
    program_flags PROGRAM_USES_PARENT;
    flags ID_PROTECTED;
  {
    CVAR struct pike_list_node *cur;
    CVAR INT32 ind;		/* Not meaningful, but requred by the API. */

    /* NOTE: cur may never refer to an unlinked node.
     *       cur may however refer to a detached node, or to sentinels.
     */

    static struct List_struct *List__get_iterator_find_parent()
    {
      struct external_variable_context loc;

      loc.o = Pike_fp->current_object;
      loc.parent_identifier = Pike_fp->fun;
      loc.inherit = INHERIT_FROM_INT(loc.o->prog, loc.parent_identifier);
      find_external_context(&loc, 1);
      return (struct List_struct *)(loc.o->storage +
				    loc.inherit->storage_offset);
    }

    INIT
    {
      add_ref(THIS->cur = List__get_iterator_find_parent()->head);
      THIS->ind = 0;
    }

    EXIT
      gc_trivial;
    {
      if (THIS->cur) {
	free_list_node(THIS->cur);
	THIS->cur = NULL;
      }
    }

    /* Called at gc_check time. */
    GC_CHECK
    {
      gc_check_list_node_forward(THIS->cur, " held by an iterator");
    }  

    /* These two functions perform the same thing,
     * but are optimized to minimize recursion.
     */
    static void gc_recurse_list_node_tree_backward(struct pike_list_node *node,
						   struct pike_list_node *back);
    static void gc_recurse_list_node_tree_forward(struct pike_list_node *node,
						  struct pike_list_node *back)
    {
      if (!node || !node->next) return;
      if (node->next->prev == node) {
	/* List member. Recursed from the list recurse code. */
#ifdef PIKE_DEBUG
	if (node->prev->next != node) {
	  Pike_fatal("Partially detached node.\n");
	}
#endif /* PIKE_DEBUG */
	return;
      }
#ifdef PIKE_DEBUG
      if (node->prev->next == node) {
	Pike_fatal("Partially detached node.\n");
      }
#endif /* PIKE_DEBUG */
      while (1) {
	gc_recurse_svalues(&node->val, 1);
	if (node->prev != back)
	  gc_recurse_list_node_tree_backward(node->prev, node->next);
	back = node->prev;
	node = node->next;
	if (!node->next || (node->next->prev == node)) {
	  /* List member. Recursed from the list recurse code. */
#ifdef PIKE_DEBUG
	  if (node->prev->next != node) {
	    Pike_fatal("Partially detached node.\n");
	  }
#endif /* PIKE_DEBUG */
	  break;
	}
#ifdef PIKE_DEBUG
	if (node->prev->next == node) {
	  Pike_fatal("Partially detached node.\n");
	}
#endif /* PIKE_DEBUG */
      }
    }

    static void gc_recurse_list_node_tree_backward(struct pike_list_node *node,
						   struct pike_list_node *next)
    {
      if (!node || !node->prev) return;
      if (node->prev->next == node) {
	/* List member. Checked from the list check code. */
#ifdef PIKE_DEBUG
	if (node->next->prev != node) {
	  Pike_fatal("Partially detached node.\n");
	}
#endif /* PIKE_DEBUG */
	return;
      }
#ifdef PIKE_DEBUG
      if (node->next->prev == node) {
	Pike_fatal("Partially detached node.\n");
      }
#endif /* PIKE_DEBUG */
      while (1) {
	gc_recurse_svalues(&node->val, 1);
	if (node->next != next)
	  gc_recurse_list_node_tree_forward(node->next, node->prev);
	next = node->next;
	node = node->prev;
	if (!node->prev || (node->prev->next == node)) {
	  /* List member. Recursed from the list recurse code. */
#ifdef PIKE_DEBUG
	  if (node->next->prev != node) {
	    Pike_fatal("Partially detached node.\n");
	  }
#endif /* PIKE_DEBUG */
	  break;
	}
#ifdef PIKE_DEBUG
	if (node->next->prev == node) {
	  Pike_fatal("Partially detached node.\n");
	}
#endif /* PIKE_DEBUG */
      }
    }

    /* Called at gc_mark time */
    GC_RECURSE
    {
      if (!THIS->cur->next || !THIS->cur->prev) return;
      if (THIS->cur->next->prev == THIS->cur) {
#ifdef PIKE_DEBUG
	if (THIS->cur->prev->next != THIS->cur) {
	  Pike_fatal("Partially detached node.\n");
	}
#endif /* PIKE_DEBUG */
	return;
      }
#ifdef PIKE_DEBUG
      if (THIS->cur->prev->next == THIS->cur) {
	Pike_fatal("Partially detached node.\n");
      }
#endif /* PIKE_DEBUG */
      /* Detached node. */
      gc_recurse_svalues(&THIS->cur->val, 1);
      gc_recurse_list_node_tree_forward(THIS->cur->next, THIS->cur->prev);
      gc_recurse_list_node_tree_backward(THIS->cur->next, THIS->cur->prev);
    }

    PIKEFUN int(0..1) `!()
      flags ID_PROTECTED;
    {
      pop_n_elems(args);
      push_int(!THIS->cur->next || !THIS->cur->prev);
    }

    PIKEFUN int(0..) index()
    {
      pop_n_elems(args);
      if (THIS->cur->next && THIS->cur->prev) {
	push_int(THIS->ind);
      } else {
	push_undefined();
      }
    }

    /*! @decl mixed value()
     *!
     *! @returns
     *!   Returns the value at the current position.
     */
    PIKEFUN mixed value()
    {
      pop_n_elems(args);
      if (THIS->cur->next && THIS->cur->prev) {
	push_svalue(&THIS->cur->val);
      } else {
	push_undefined();
      }
    }

    /*! @decl int(0..1) first()
     *!
     *!   Reset the iterator to point to the first element in
     *!   the list.
     *!
     *! @returns
     *!   Returns @expr{1@} if there are elements in the list,
     *!   and @expr{0@} (zero) if the list is empty.
     */
    PIKEFUN int(0..1) first()
    {
      struct external_variable_context loc;
      struct List_struct *parent;
      pop_n_elems(args);

      /* Find our parent. */
      loc.o = Pike_fp->current_object;
      loc.parent_identifier = Pike_fp->fun;
      loc.inherit = INHERIT_FROM_INT(loc.o->prog, loc.parent_identifier);
      find_external_context(&loc, 1);
      parent = (struct List_struct *)(loc.o->storage +
				      loc.inherit->storage_offset);
      free_list_node(THIS->cur);
      add_ref(THIS->cur = parent->head);
      THIS->ind = 0;
      pop_n_elems(args);
      if (THIS->cur->next) {
	push_int(1);
      } else {
	push_undefined();
      }
    }

    /*! @decl int(0..1) next()
     *!
     *!   Advance to the next element in the list.
     *!
     *! @returns
     *!   Returns @expr{1@} on success, and @expr{0@} (zero)
     *!   at the end of the list.
     *!
     *! @seealso
     *!   @[prev()]
     */
    PIKEFUN int(0..1) next()
    {
      struct pike_list_node *next;
      if ((next = THIS->cur->next)) {
	free_list_node(THIS->cur);
	add_ref(THIS->cur = next);
	THIS->ind++;
	if (next->next) {
	  pop_n_elems(args);
	  push_int(1);
	  return;
	}
      }
      pop_n_elems(args);
      push_int(0);
    }

    /*! @decl int(0..1) prev()
     *!
     *!   Retrace to the previous element in the list.
     *!
     *! @returns
     *!   Returns @expr{1@} on success, and @expr{0@} (zero)
     *!   at the beginning of the list.
     *!
     *! @seealso
     *!   @[next()]
     */
    PIKEFUN int(0..1) prev()
    {
      struct pike_list_node *prev;
      if ((prev = THIS->cur->prev)) {
	free_list_node(THIS->cur);
	add_ref(THIS->cur = prev);
	THIS->ind--;
	if (prev->prev) {
	  pop_n_elems(args);
	  push_int(1);
	  return;
	}
      }
      pop_n_elems(args);
      push_int(0);
    }

    /*! @decl Iterator `+=(int steps)
     *!
     *!   Advance or retrace the specified number of @[steps].
     *!
     *! @seealso
     *!   @[next()], @[prev]
     */
    PIKEFUN Iterator `+=(int steps)
    {
      if (!steps) return;
      if (steps > 0) {
	while (steps--) {
	  apply_current(f_List_cq__get_iterator_next_fun_num, 0);
	  pop_stack();
	}
      } else {
	while (steps++) {
	  apply_current(f_List_cq__get_iterator_prev_fun_num, 0);
	  pop_stack();
	}
      }
      pop_n_elems(args);
      ref_push_object(Pike_fp->current_object);
    }

    /*! @decl void insert(mixed val)
     *!
     *!   Insert @[val] at the current position.
     *!
     *! @seealso
     *!   @[append()], @[delete()], @[set()]
     */
    PIKEFUN void insert(mixed val)
    {
      struct pike_list_node *new_node;
      if (!THIS->cur->prev) {
	Pike_error("Attempt to insert before the start sentinel.\n");
      }
      new_node = alloc_pike_list_node();
      assign_svalue_no_free(&new_node->val, val);
      prepend_list_node(THIS->cur, new_node);
      free_list_node(THIS->cur);
      THIS->cur = new_node;
      List__get_iterator_find_parent()->num_elems++;
      pop_n_elems(args);
      push_int(0);
    }

    /*! @decl void append(mixed val)
     *!
     *!   Append @[val] after the current position.
     *!
     *! @seealso
     *!   @[insert()], @[delete()], @[set()]
     */
    PIKEFUN void append(mixed val)
    {
      struct pike_list_node *new_node;
      if (!THIS->cur->next) {
	Pike_error("Attempt to append after the end sentinel.\n");
      }
      new_node = alloc_pike_list_node();
      assign_svalue_no_free(&new_node->val, val);
      append_list_node(THIS->cur, new_node);
      free_list_node(new_node);
      List__get_iterator_find_parent()->num_elems++;
      pop_n_elems(args);
      push_int(0);
    }

    /*! @decl void delete()
     *!
     *!   Delete the current node.
     *!
     *!   The current position will advance to the next node.
     *!   This function thus performes the reverse operation
     *!   of @[insert()].
     *!
     *! @seealso
     *!   @[insert()], @[append()], @[set()]
     */
    PIKEFUN void delete()
    {
      struct pike_list_node *next;
      if (!(next = THIS->cur->next) || !THIS->cur->prev) {
	Pike_error("Attempt to delete a sentinel.\n");
      }
      add_ref(next);
      if (next->prev == THIS->cur) {
	if (THIS->cur->refs == 3) {
	  unlink_list_node(THIS->cur);
	} else {
	  /* There's some other iterator holding references to this node. */
	  detach_list_node(THIS->cur);
	}
	List__get_iterator_find_parent()->num_elems--;
      }
      free_list_node(THIS->cur);
      THIS->cur = next;
      pop_n_elems(args);
      push_int(0);
    }

    /*! @decl void set(mixed val)
     *!
     *!   Set the value of the current position to @[val].
     *!
     *! @seealso
     *!   @[insert()], @[append()], @[delete()]
     */
    PIKEFUN void set(mixed val)
    {
      if (!THIS->cur->next || !THIS->cur->prev) {
	Pike_error("Attempt to set a sentinel.\n");
      }
      assign_svalue(&THIS->cur->val, val);
      pop_n_elems(args);
      push_int(0);
    }
  }
  /*! @endclass
   */
}
/*! @endclass
 */

/*! @endmodule
 */

/*! @module Pike
 */

/*! @class MasterCodec
 *!
 *! This is a bare-bones codec that is used when loading a dumped master.
 *!
 *! @seealso
 *!   @[Codec]
 */
PIKECLASS MasterCodec
  flags ID_PROTECTED;
{
  /*! @decl mixed functionof(mixed symbol)
   *! Look up a function in @[all_constants()].
   */
  PIKEFUN mixed functionof(mixed symbol)
  {
    mapping_index_no_free(Pike_sp, get_builtin_constants(), symbol);
    Pike_sp++;
    stack_pop_keep_top();
  }
  /*! @decl mixed objectof(mixed symbol)
   *! Look up an object in @[all_constants()].
   */
  PIKEFUN mixed objectof(mixed symbol)
  {
    mapping_index_no_free(Pike_sp, get_builtin_constants(), symbol);
    Pike_sp++;
    stack_pop_keep_top();
  }
  /*! @decl mixed programof(mixed symbol)
   *! Look up a program in @[all_constants()].
   */
  PIKEFUN mixed programof(mixed symbol)
  {
    mapping_index_no_free(Pike_sp, get_builtin_constants(), symbol);
    Pike_sp++;
    stack_pop_keep_top();
  }
  /*! @decl object decode_object(object obj, mixed data)
   *! Calls @expr{obj->_decode(@[data])@}.
   */
  PIKEFUN object decode_object(object obj, mixed data)
  {
    apply(obj, "_decode", 1);
    pop_stack();
  }
}

/*! @endclass
 */

/*! @endmodule
 */

static struct object *val_module;

static void get_val_module()
{
  assert (!val_module);
  push_constant_text ("Val");
  APPLY_MASTER ("resolv", 1);
  if (Pike_sp[-1].type != T_OBJECT)
    Pike_error ("\"Val\" didn't resolve to a module object.\n");
  val_module = (--Pike_sp)->u.object;
}

/* Always do the lookup in the Val module dynamically to allow the
 * values to be replaced. */
#define GET_VAL(NAME)							\
  PMOD_EXPORT struct object *PIKE_CONCAT (get_val_, NAME) (void)	\
  {									\
    struct svalue index, res;						\
    if (!val_module) get_val_module();					\
    index.type = T_STRING;						\
    index.subtype = 0;                                                  \
    MAKE_CONST_STRING (index.u.string, TOSTR (NAME));			\
    object_index_no_free (&res, val_module, 0, &index);			\
    if (res.type != T_OBJECT)						\
      Pike_error ("\"Val." TOSTR (NAME) "\" didn't resolve to an object.\n"); \
    return res.u.object;						\
  }

GET_VAL (true)
GET_VAL (false)
GET_VAL (null)

/* Kludge needed for the static null objects in the oracle module. It
 * ought to be fixed to use dynamic lookup of them instead. */
PMOD_EXPORT struct program *get_sql_null_prog(void)
{
  return SqlNull_program;
}

void init_builtin(void)
{
  init_pike_list_node_blocks();
  SET_SVAL(gc_pre_cb, PIKE_T_INT, NUMBER_NUMBER, integer, 0);
  SET_SVAL(gc_post_cb, PIKE_T_INT, NUMBER_NUMBER, integer, 0);
  SET_SVAL(gc_destruct_cb, PIKE_T_INT, NUMBER_NUMBER, integer, 0);
  SET_SVAL(gc_done_cb, PIKE_T_INT, NUMBER_NUMBER, integer, 0);
  INIT
}

void exit_builtin(void)
{
  struct svalue zero;
  if (val_module) free_object (val_module);
  EXIT
  SET_SVAL(zero, PIKE_T_INT, NUMBER_NUMBER, integer, 0);
  assign_svalue(&gc_pre_cb, &zero);
  assign_svalue(&gc_post_cb, &zero);
  assign_svalue(&gc_destruct_cb, &zero);
  assign_svalue(&gc_done_cb, &zero);
#ifndef DO_PIKE_CLEANUP
  /* This is performed by exit_builtin_modules() at a later point
   * in this case, so that the pike_list_node's are valid at cleanup
   * time, thus avoiding "got invalid pointer" fatals at exit.
   */
  free_all_pike_list_node_blocks();
#endif
#ifndef USE_SETENV
  if (env_allocs) free_mapping (env_allocs);
#endif
}
