Logo Search packages:      
Sourcecode: malaga version File versions  Download package

values.c

/* Copyright (C) 1995 Bjoern Beutel. */

/* Description. =============================================================*/

/* This module defines the data type "value_t", and many
 * operations to build, modify, and print such values.
 * The first cell of a value, its type cell, is used to store the value's type
 * together with some type dependent information, which is an unsigned number
 * less than INFO_MAX.
 * Use the macro TYPE to get the type of a value, and INFO to get the type 
 * dependent information. Use TYPE_CELL to create a type-cell.
 * There are five different types of values:
 * symbol, string, list, record and number. */

/* Includes. ================================================================*/

#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include "basic.h"
#include "pools.h"
#include "hangul.h"
#include "values.h"

/* Constants. ===============================================================*/

#define CELL_BITS BITS_PER_BYTE * sizeof( cell_t )
#define TYPE_BITS 3
#define INFO_BITS (CELL_BITS - TYPE_BITS)
#define TYPE_MAX ((cell_t) 1 << TYPE_BITS)
#define INFO_MAX ((cell_t) 1 << INFO_BITS)
#define TYPE_MASK ((TYPE_MAX - 1) << INFO_BITS)
#define INFO_MASK (INFO_MAX - 1)

#define SYMBOL_TYPE ((cell_t) 0 << INFO_BITS) 
/* A value of type SYMBOL_TYPE consists only of a type cell. 
 * Its INFO-value is the code for the symbol. */

#define STRING_TYPE ((cell_t) 1 << INFO_BITS) 
/* A value of type STRING_TYPE consists of its type cell,
 * followed by the actual string. Its INFO-value is the
 * number of characters in the string. The actual string
 * is stored in the subsequent cells, two characters
 * paired in a cell, and terminated by one or two
 * NUL-characters, so that the total number of chars is
 * even. The NUL-chars are NOT part of the string. */

#define LIST_TYPE ((cell_t) 2 << INFO_BITS)
/* A value of type LIST_TYPE consists of its type cell and a subsequent cell,
 * which hold the type and the length of the value, followed by 0 or more
 * values of any type, namely the values that form the list. 
 * The length of a list VALUE, that is the number of cells needed to store 
 * all the list's values, is (INFO( value[0] ) << CELL_BITS) + value[1]. */

#define RECORD_TYPE ((cell_t) 3 << INFO_BITS)
/* A value of type RECORD_TYPE consists of its type cell and a subsequent cell,
 * which hold the type and the length of the value, followed by 0 or more 
 * pairs of values. 
 * In a pair of values, the first value must be a symbol and is considered as 
 * an attribute of that record. The second value is the value of that
 * attribute, and it can be of any type.
 * The length of a record VALUE, that is the number of cells
 * needed to store all the record's value pairs, is computed as
 * (INFO( value ) << CELL_BITS) + value[1]. */

#define NUMBER_TYPE ((cell_t) 4 << INFO_BITS)
/* A value of type NUMBER_TYPE consists of its type cell,
 * followed by a implementation-dependent number of cells
 * that contain a C "double" value.
 * Its INFO-value is 0. */

/* Macros. ==================================================================*/

#define TYPE(value) ((*(value)) & TYPE_MASK)
#define INFO(value) ((*(value)) & INFO_MASK)
#define TYPE_CELL(type,info) ((type) | (info))

/* Use one of the following predicates to test a value
 * against a specific type. */
#define IS_SYMBOL(value) (TYPE( value ) == SYMBOL_TYPE)
#define IS_STRING(value) (TYPE( value ) == STRING_TYPE)
#define IS_RECORD(value) (TYPE( value ) == RECORD_TYPE)
#define IS_LIST(value) (TYPE( value ) == LIST_TYPE)
#define IS_NUMBER(value) (TYPE( value ) == NUMBER_TYPE)

#define NEXT_VALUE(value) ((value) + length_of_value( value ))
/* Return end of VALUE.
 * This may also be the beginning of the next value in a list. */

#define NEXT_ATTRIB(attrib) ((attrib) + 1 + length_of_value( (attrib) + 1 ))
/* Return the next attribute in a record. */

#define CELLS_PER_NUMBER ((int_t) (sizeof( double ) / sizeof( cell_t )))
/* The number of cells needed to contain a number value.
 * sizeof( double ) _must_ be a multiple of sizeof( cell_t ). */

/* Types. ===================================================================*/

typedef struct /* An element in a list of hidden attributes. */
{
  list_node_t *next;
  symbol_t symbol;
} attribute_t;

/* Global variables. ========================================================*/

string_t (*values_get_symbol_name)( symbol_t symbol );
value_t (*values_get_atoms)( symbol_t symbol );
value_t *value_stack;
int_t top; 
attribute_order_t attribute_order;

/* Variables. ===============================================================*/

/* Two constant values. */
static cell_t empty_list[] = {TYPE_CELL( LIST_TYPE, 0 ), 0};
static cell_t empty_record[] = {TYPE_CELL( RECORD_TYPE, 0 ), 0};

static cell_t *value_heap; /* The actual heap. */
static cell_t *value_heap_end; /* Pointer to first free cell in heap. */
static int_t value_heap_size; /* Size of the value heap in cells. */

static int_t value_stack_size; /* Size of the value stack. */

static list_t hidden_attributes; /* The list of hidden attributes. */
static text_t *value_text; /* Buffer for conversion of values to text. */

/* Forward declarations. ====================================================*/

static void value_to_text( text_t *text, value_t value, bool_t full_value, 
                     int_t indent );

/* Support functions. =======================================================*/

static void 
copy_cells( value_t destination, value_t source, int_t n )
/* Copy N cells of value SOURCE to DESTINATION. */
{
  memcpy( destination, source, n * sizeof( cell_t ) );
}

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

static void 
copy_value( value_t destination, value_t source )
/* Copy all cells of value SOURCE to DESTINATION. */
{
  memcpy( destination, source, length_of_value( source ) * sizeof( cell_t ) );
}

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

static int 
compare_value_pointers( const void *key1, const void *key2 )
/* Return -1/0/1 when the value VALUE1_P points to is stored on a
 * lower/same/higher address than the value VALUE2_P points to. */
{
  value_t *value1_p;
  value_t *value2_p;

  value1_p = * (value_t **) key1;
  value2_p = * (value_t **) key2;

  if (*value1_p < *value2_p) 
    return -1;
  else if (*value1_p > *value2_p) 
    return 1;
  else
    return 0;
}

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

static void 
collect_garbage( void )
/* Make sure the value heap only contains values that are on the value stack.
 * Compactify the heap, i.e. move all values on the heap to the beginning. */
{
  int_t i, value_len;
  value_t old_value, new_value;
  value_t **value_pointer;

  new_value = value_heap;

  /* Copy values if there is at least one value to save. */
  if (top > 0) 
  { 
    /* Create a table of pointers to the values. */
    value_pointer = new_vector( sizeof( value_t * ), top );
    for (i = 0; i < top; i++) 
      value_pointer[i] = value_stack + i;

    /* Sort pointers according to the address of the value they point to. */
    qsort( value_pointer, top, sizeof( value_t * ), compare_value_pointers );

    /* Find the first index I whose value is on the heap. */
    for (i = 0; i < top; i++) 
    { 
      if (*value_pointer[i] >= value_heap) 
      break;
    }

    /* Work on all values on the heap. */
    while (i < top && *value_pointer[i] < value_heap_end) 
    { 
      /* Copy the value. */
      old_value = *value_pointer[i];
      value_len = length_of_value( old_value );
      memmove( new_value, old_value, value_len * sizeof( cell_t ) );

      /* Adjust the value address and the addresses of all values
       * that are part of that value. */
      while (i < top && *value_pointer[i] < old_value + value_len) 
      { 
      *value_pointer[i] -= (old_value - new_value);
        i++;
      }
      new_value += value_len;
    }
    free_mem( &value_pointer );
  }
  value_heap_end = new_value;
}

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

static value_t 
space_for_value( int_t size )
/* Get SIZE adjacent free cells on the value heap. */
{
  value_t pointer, old_heap, old_heap_end;
  int_t i;

  if ((value_heap_end - value_heap) + size > value_heap_size) 
  { 
    collect_garbage();
    if ((value_heap_end - value_heap) + size > value_heap_size) 
    { 
      old_heap = value_heap;
      old_heap_end = value_heap_end;

      /* Enlarge the value heap. */
      value_heap_size = renew_vector( &value_heap, sizeof( cell_t ),
                                      2 * (size + (old_heap_end - old_heap)) );
      value_heap_end = value_heap + (old_heap_end - old_heap);

      /* Adapt the value stack pointers. */
      for (i = 0; i < top; i++) 
      { 
      if (value_stack[i] >= old_heap && value_stack[i] < old_heap_end) 
        value_stack[i] = value_heap + (value_stack[i] - old_heap);
      }
    }
  }
  pointer = value_heap_end;
  value_heap_end += size;
  return pointer;
}

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

static value_t 
space_for_composed_value( int_t type, int_t length )
/* Allocate LENGTH cells for a composed value of TYPE, set its type cell
 * and return the value. */
{
  value_t value;
  int_t content_size;

  value = space_for_value( length );
  content_size = length - 2;
  if (content_size >= 1L << (INFO_BITS + CELL_BITS)) 
    complain( "Value too big." );
  value[0] = TYPE_CELL( type, content_size >> CELL_BITS );
  value[1] = content_size & ((1L << CELL_BITS) - 1);
  return value;
}

/* Module initialisation. ===================================================*/

void 
init_values( void )
/* Initialise this module. */
{
  value_text = new_text();
  value_heap_size = 1000;
  value_heap = new_vector( sizeof( cell_t ), value_heap_size );
  value_heap_end = value_heap;
  value_stack_size = 100;
  value_stack = new_vector( sizeof( value_t ), value_stack_size );
  top = 0;
  clear_list( &hidden_attributes );
}

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

void 
terminate_values( void )
/* Terminate this module. */
{
  free_mem( &value_heap );
  free_mem( &value_stack );
  free_text( &value_text );
  clear_hidden_attributes();
}

/* Value operations. ========================================================*/
 
value_t 
new_value( value_t value )
/* Allocate space for VALUE and copy it.
 * Free the value space after use. */
{
  value_t value2;

  value2 = new_vector( sizeof( cell_t ), length_of_value( value ) );
  copy_value( value2, value );
  return value2;
}

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

value_t 
copy_value_to_pool( pool_t value_pool, value_t value, int_t *index )
/* Copy VALUE to the pool VALUE_POOL and store its index in *INDEX. */
{
  value_t value2;

  value2 = get_pool_space( value_pool, length_of_value( value ), index );
  copy_value( value2, value );
  return value2;
}

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

int_t 
length_of_value( value_t value )
/* Return the length of VALUE in cells. */
{
  switch (TYPE( value )) 
  {
  case LIST_TYPE: 
  case RECORD_TYPE:
    return 2 + ((int_t) INFO( value ) << CELL_BITS) + value[1];
  case SYMBOL_TYPE: 
    return 1;
  case STRING_TYPE: 
    return 2 + INFO( value ) / sizeof( cell_t );
  case NUMBER_TYPE: 
    return 1 + CELLS_PER_NUMBER;
  default: 
    complain( "Internal error." );
  }
}

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

symbol_t 
get_value_type( value_t value )
/* Return the type of VALUE. Depending of the type, the result value may be
 * SYMBOL_SYMBOL, STRING_SYMBOL, NUMBER_SYMBOL, LIST_SYMBOL, RECORD_SYMBOL. */
{
  switch (TYPE( value )) 
  {
  case SYMBOL_TYPE: 
    return SYMBOL_SYMBOL;
  case STRING_TYPE: 
    return STRING_SYMBOL;
  case NUMBER_TYPE: 
    return NUMBER_SYMBOL;
  case LIST_TYPE: 
    return LIST_SYMBOL;
  case RECORD_TYPE: 
    return RECORD_SYMBOL;
  default: 
    complain( "Internal error." );
  }
}

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

void 
push_value( value_t value )
/* Stack effects: (nothing) -> VALUE. */
{
  if (top + 1 > value_stack_size) 
  { 
    value_stack_size = renew_vector( &value_stack, sizeof( value_t ), 
                             2 * (top + 1) );
  }
  value_stack[ top++ ] = value;
}

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

void 
insert_value( int_t n, value_t value )
/* Stack effects: VALUE1...VALUE_N -> VALUE VALUE1...VALUE_N. */
{
  int_t i;

  push_value( NULL );
  for (i = 0; i < n; i++) 
    value_stack[ top - i - 1 ] = value_stack[ top - i - 2 ];
  value_stack[ top - n - 1 ] = value;
}

/* Symbol operations. =======================================================*/

symbol_t 
value_to_symbol( value_t value )
/* Return VALUE as a symbol. It is an error if VALUE is no symbol. */
{
  if (! IS_SYMBOL( value )) 
    complain( "Value is no symbol." );
  return *value;
}

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

void 
push_symbol_value( symbol_t symbol )
/* Stack effects: (nothing) -> NEW_SYMBOL.
 * NEW_SYMBOL is SYMBOL converted to a Malaga value. */
{
  value_t value;

  value = space_for_value(1);
  *value = TYPE_CELL( SYMBOL_TYPE, symbol );
  push_value( value );
}

/* String operations. =======================================================*/

string_t 
value_to_string( value_t string )
/* Return the value of STRING as a C style string. */
{
  if (! IS_STRING( string )) 
    complain( "Value is no string." );
  return (string_t) (string + 1);
}

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

void 
push_string_value( string_t string_start, string_t string_end )
/* Stack effects: (nothing) -> NEW_STRING.
 * NEW_STRING is the string starting at STRING_START as a Malaga value.
 * If STRING_END != NULL, it marks the end of the string. */
{
  value_t value, value_end;
  int_t length;
  string_t target_p, source_p;

  if (string_end == NULL) 
    string_end = string_start + strlen( string_start );
  length = string_end - string_start;
  if (length > INFO_MAX - 1) 
    complain( "String too long to be a value." );
  value = space_for_value( 2 + length / sizeof( cell_t ) );
  *value = TYPE_CELL( STRING_TYPE, length );

  /* Copy the string content. */
  source_p = string_start;
  target_p = (string_t) (value + 1);
  value_end = NEXT_VALUE( value );
  while (source_p < string_end) 
    *target_p++ = *source_p++;

  /* Pad with EOS. */
  while (target_p < (string_t) value_end) 
    *target_p++ = EOS;

  push_value( value );
}

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

void 
concat_string_values( void )
/* Stack effects: STRING1 STRING2 -> NEW_STRING.
 * NEW_STRING is the concatenation of STRING1 and STRING2. */
{
  int_t new_length;
  string_t string, old_string, string_end;
  value_t string_value;

  if (! IS_STRING( value_stack[ top - 2 ] ) 
      || ! IS_STRING( value_stack[ top - 1 ] )) 
  { 
    complain( "Concatenation operands must be strings." ); 
  }
  new_length = ((int_t) INFO( value_stack[ top - 2 ] ) 
                + (int_t) INFO( value_stack[ top - 1 ] ));
  if (new_length > INFO_MAX - 1) 
    complain( "Strings too long for concatenation." );
  string_value = space_for_value( 2 + new_length / sizeof( cell_t ) );
  *string_value = TYPE_CELL( STRING_TYPE, new_length );

  /* Join the strings. We do it by hand so it's easier to align. */
  string = (string_t) (string_value + 1);
  old_string = (string_t) (value_stack[ top - 2 ] + 1);
  while (*old_string != '\0') 
    *string++ = *old_string++;
  old_string = (string_t) (value_stack[ top - 1 ] + 1);
  while (*old_string != '\0') 
    *string++ = *old_string++;
  string_end = (string_t) NEXT_VALUE( string_value );
  while (string < string_end) 
    *string++ = '\0';

  top--;
  value_stack[ top - 1 ] = string_value;
}

/* Record operations. =======================================================*/

value_t 
get_attribute( value_t record, symbol_t attribute )
/* Return the value of ATTRIBUTE in the record RECORD 
 * or NULL if it doesn't exist. */
{
  value_t record_end, v;
 
  /* No error when getting an attribute from "nil". */
  if (*record == NIL_SYMBOL) 
    return NULL;
  if (! IS_RECORD( record )) 
    complain( "Can get an attribute value of a record only." );
  record_end = NEXT_VALUE( record );
  for (v = record + 2; v < record_end; v = NEXT_ATTRIB(v)) 
  { 
    if (*v == attribute) 
      return v + 1;
  }
  return NULL;
}

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

void 
build_record( int_t n )
/* Stack effects: ATTR1 VALUE1 ... ATTR_N VALUE_N -> NEW_RECORD.
 * NEW_RECORD looks like [ATTR1: VALUE1, ..., ATTR_N: VALUE_N]. */
{
  value_t new_record, v;
  int_t i, j, new_record_length;
  value_t *values;

  values = value_stack + top - 2 * n;

  /* Check that all attributes are different. */
  for (i = 0; i < n; i++) 
  { 
    if (! IS_SYMBOL( values[ 2 * i ] )) 
      complain( "Attribute must be symbol." );
    for (j = 0; j < i; j++) 
    { 
      if (*values[ 2 * i ] == *values[ 2 * j ]) 
      complain( "Attribute twice in record." );
    }
  }

  /* Compute record length. */
  new_record_length = 2;
  for (i = 0; i < n; i++) 
    new_record_length += 1 + length_of_value( values[ 2 * i + 1 ] );

  /* Allocate new record and copy content. */
  new_record = space_for_composed_value( RECORD_TYPE, new_record_length );
  v = new_record + 2;
  for (i = 0; i < n; i++) 
  { 
    *v++ = *values[ 2 * i ];
    copy_value( v, values[ 2 * i + 1 ] );
    v = NEXT_VALUE(v);
  }

  top -= 2 * n;
  push_value( new_record );
}

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

void 
join_records( void )
/* Stack effects: RECORD1 RECORD2 -> NEW_RECORD.
 * NEW_RECORD contains all attributes of RECORD1 and RECORD2, and 
 * their associated values. If an attribute has different values in RECORD1
 * and RECORD2, the value in RECORD2 will be taken. */
{
  value_t record1, record2, record1_end, record2_end, new_record, v, v1, v2;
  int_t new_record_length;

  record1 = value_stack[ top - 2 ];
  record2 = value_stack[ top - 1 ];
  record1_end = NEXT_VALUE( record1 );
  record2_end = NEXT_VALUE( record2 );
  if (! IS_RECORD( record1 ) || ! IS_RECORD( record2 )) 
    complain( "Join operands must be records." );

  /* Calculate the space needed. This is the length of the
   * first record plus the length of the second record minus the
   * sum of the length of all attribute-value-pairs in RECORD1 whose
   * attributes are also in RECORD2. */
  new_record_length
    = length_of_value( record1 ) + length_of_value( record2 ) - 2;
  for (v1 = record1 + 2; v1 < record1_end; v1 = NEXT_ATTRIB( v1 )) 
  { 
    for (v2 = record2 + 2; v2 < record2_end; v2 = NEXT_ATTRIB( v2 )) 
    { 
      if (*v1 == *v2) /* We've discovered two identical attributes */
      { 
      new_record_length -= (1 + length_of_value( v1 + 1 ));
        break;
      }
    }
  }

  /* Allocate a new record value. */
  new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

  /* The values on stack may have moved if garbage collection was called. */
  record1 = value_stack[ top - 2 ];
  record2 = value_stack[ top - 1 ];
  record1_end = NEXT_VALUE( record1 );
  record2_end = NEXT_VALUE( record2 );

  /* Copy the attributes of the first record. If an attribut
   * belongs to both VALUE1 and VALUE2, don't copy its value. */
  v = new_record + 2;
  for (v1 = record1 + 2; v1 < record1_end; v1 = NEXT_ATTRIB( v1 )) 
  { 
    /* Go through RECORD2 until we reach end or find same attribute. */
    for (v2 = record2 + 2; v2 < record2_end; v2 = NEXT_ATTRIB( v2 )) 
    { 
      if (*v1 == *v2) 
      break;
    }
    if (v2 >= record2_end) 
    { 
      /* If attrib not in RECORD2, copy the value of RECORD1. */
      *v = *v1;
      copy_value( v + 1, v1 + 1 );
      v = NEXT_ATTRIB(v);
    }
  }

  /* Append the attributes of the second record. */
  copy_cells( v, record2 + 2, length_of_value( record2 ) - 2 );

  /* Push new record on stack. */
  top--;
  value_stack[ top - 1 ] = new_record;
}

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

void 
select_attribute( symbol_t attribute )
/* Stack effects: RECORD -> NEW_RECORD.
 * NEW_RECORD contains ATTRIBUTE and its value in RECORD. */
{
  value_t record, record_end, v, new_record;
  int_t new_record_length;

  record = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );
  if (! IS_RECORD( record )) 
    complain( "Can select attributes from record only." );
  for (v = record + 2; v < record_end; v = NEXT_ATTRIB(v)) 
  { 
    if (*v == attribute) 
      break;
  }
  if (v == record_end) 
    new_record = empty_record;
  else 
  { 
    new_record_length = 3 + length_of_value( v + 1 );
    new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

    record = value_stack[ top - 1 ];
    record_end = NEXT_VALUE( record );

    /* Find ATTRIBUTE in record. */
    for (v = record + 2; *v != attribute; v = NEXT_ATTRIB(v)) 
      /* empty */;
    new_record[2] = attribute;
    copy_value( new_record + 3, v + 1 );
  }

  value_stack[ top - 1 ] = new_record;
}

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

void 
select_attributes( void )
/* Stack effects: RECORD LIST -> NEW_RECORD.
 * NEW_RECORD contains all attribute-value pairs of RECORD whose attributes
 * are in LIST. */
{
  value_t record, list, record_end, list_end, v, v1, v2, new_record;
  int_t new_record_length;

  record = value_stack[ top - 2 ];
  list = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );
  list_end = NEXT_VALUE( list );

  if (! IS_RECORD( record )) 
    complain( "Can select attributes from record only." );
  if (! IS_LIST( list ))
    complain( "Attribute selection list must be a list." );

  /* Check that VALUE2 is a list with symbols only. */
  for (v2 = list + 2; v2 < list_end; v2 = NEXT_VALUE( v2 )) 
  { 
    if (! IS_SYMBOL( v2 )) 
      complain( "Attribute selection list must contain symbols only." );
  }
      
  /* Calculate size of new value */
  new_record_length = 2;
  for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
  { 
    for (v2 = list + 2; v2 < list_end; v2++) 
    { 
      if (*v1 == *v2) 
      { 
      new_record_length += 1 + length_of_value( v1 + 1 );
        break;
      }
    }
  }

  /* We don't create a new record if no attributes are deleted. */
  if (new_record_length == length_of_value( record )) 
    new_record = record;
  else 
  { 
    /* Allocate and copy new value. */
    new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

    record = value_stack[ top - 2 ];
    list = value_stack[ top - 1 ];
    record_end = NEXT_VALUE( record );
    list_end = NEXT_VALUE( list );

    v = new_record + 2;
    for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
    { 
      for (v2 = list + 2; v2 < list_end; v2++) 
      { 
      if (*v1 == *v2) 
        { 
        *v++ = *v1;
          copy_value( v, v1 + 1 );
          v = NEXT_VALUE(v);
          break;
        }
      }
    }
  }

  top--;
  value_stack[ top - 1 ] = new_record;
}

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

void 
remove_attribute( symbol_t attribute )
/* Stack effects: RECORD -> NEW_RECORD.
 * NEW_RECORD contains all attribute-value pairs of RECORD but the one with
 * attribute ATTRIBUTE. */
{
  value_t record, new_record, record_end, v, v1;
  int_t new_record_length;

  record = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );

  if (! IS_RECORD( record )) 
    complain( "Can remove attributes from record only." );

  /* Find the attribute that is to be deleted. */
  for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
  { 
    if (*v1 == attribute) 
      break;
  }

  /* Check if we have an attribute to delete. */
  if (v1 == record_end) 
    new_record = record;
  else 
  { 
    /* Compute its length and get space for the new record. */
    new_record_length 
      = length_of_value( record ) - (length_of_value( v1 + 1 ) + 1);
    new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

    /* Get the original record. */
    record = value_stack[ top - 1 ];
    record_end = NEXT_VALUE( record );

    /* Copy the record. */
    v = new_record + 2;
    for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
    { 
      if (*v1 != attribute) 
      { 
      *v = *v1;
        copy_value( v + 1, v1 + 1 );
        v = NEXT_ATTRIB(v);
      }
    }
  }
  value_stack[ top - 1 ] = new_record;
}

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

void 
remove_attributes( void )
/* Stack effects: RECORD LIST -> NEW_RECORD.
 * NEW_RECORD contains all attribute-value pairs of RECORD but the ones
 * whose attributes are in LIST. */
{
  value_t v, v1, v2, record, list, record_end, list_end, new_record;
  int_t new_record_length;

  record = value_stack[ top - 2 ];
  list = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );
  list_end = NEXT_VALUE( list );
  if (! IS_RECORD( record )) 
    complain( "Can remove attributes from record only." );
  if (! IS_LIST( list )) 
    complain( "Attribute list must be a list." );

  /* Check if the list consists of symbols only. */
  for (v2 = list + 2; v2 < list_end; v2++) 
  { 
    if (! IS_SYMBOL( v2 )) 
      complain( "Attribute list must contain symbols only." );
  }

  /* Compute the length of the new record. */
  new_record_length = 2;
  for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
  { 
    for (v2 = list + 2; v2 < list_end; v2++) 
    { 
      if (*v1 == *v2) 
      break;
    }
    if (v2 == list_end) 
      new_record_length += 1 + length_of_value( v1 + 1 );
  }

  /* We don't create a new record if no attributes will be deleted. */
  if (new_record_length == length_of_value( record )) 
    new_record = record;
  else 
  { 
    new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

    /* Get the values, since they may have moved by garbage collection. */
    record = value_stack[ top - 2 ];
    list = value_stack[ top - 1 ];
    record_end = NEXT_VALUE( record );
    list_end = NEXT_VALUE( list );

    /* Copy the other attributes. */
    v = new_record + 2;
    for (v1 = record + 2; v1 < record_end; v1 = NEXT_ATTRIB( v1 )) 
    { 
      for (v2 = list + 2; v2 < list_end; v2++) 
      { 
      if (*v1 == *v2) 
        break;
      }
      if (v2 == list_end) 
      { 
      *v = *v1;
      copy_value( v + 1, v1 + 1 );
      v = NEXT_ATTRIB(v);
      }
    }
  }
  top--;
  value_stack[top - 1] = new_record;
}

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

void 
replace_attribute( symbol_t attribute )
/* Stack effects: RECORD VALUE -> NEW_RECORD.
 * NEW_RECORD is equal to RECORD, only the value of ATTRIBUTE is replaced
 * by VALUE. RECORD must contain ATTRIBUTE. */
{
  value_t record, value, record_end, new_record, v, nv;
  int_t new_record_length;

  record = value_stack[ top - 2 ];
  value = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );
  if (! IS_RECORD( record )) 
    complain( "Value must be a record." );

  /* Find the attribute to replace. */
  for (v = record + 2; v < record_end; v = NEXT_ATTRIB(v)) 
  { 
    if (*v == attribute) 
      break;
  }
  if (v == record_end) 
    complain( "Missing attribute to replace." );

  new_record_length = (length_of_value( record ) 
                   + length_of_value( value ) - length_of_value( v + 1 ));
  new_record = space_for_composed_value( RECORD_TYPE, new_record_length );

  record = value_stack[ top - 2 ];
  value = value_stack[ top - 1 ];
  record_end = NEXT_VALUE( record );

  nv = new_record + 2;
  for (v = record + 2; v < record_end; v = NEXT_ATTRIB(v)) 
  { 
    *nv = *v;
    if (*v == attribute) 
      copy_value( nv + 1, value );
    else 
      copy_value( nv + 1, v + 1 );
    nv = NEXT_ATTRIB( nv );
  }

  top--;
  value_stack[ top - 1 ] = new_record;
}

/* List operations. =========================================================*/

int_t 
get_list_length( value_t list )
/* Return the number of elements in LIST. 
 * LIST must be a list. */
{
  int_t elements;
  value_t list_end, v;

  if (! IS_LIST( list )) 
    complain( "Can get length of a list only." );
  list_end = NEXT_VALUE( list );
  elements = 0;
  for (v = list + 2; v < list_end; v = NEXT_VALUE(v)) 
    elements++;
  return elements;
}

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

value_t 
get_element( value_t list, int_t n )
/* Return the N-th element of the list LIST,
 * or NULL, if that element doesn't exist.
 * If N is positive, elements will be counted from the left border.
 * If it's negative, elements will be counted from the right border. */
{
  value_t list_end, v;
  
  /* No error when getting an element from "nil". */
  if (*list == NIL_SYMBOL) 
    return NULL;

  if (! IS_LIST( list )) 
    complain( "Can get an element of a list only." );
  if (n < 0) 
    n = get_list_length( list ) + n + 1;
  if (n <= 0) 
    return NULL;
  list_end = NEXT_VALUE( list );
  for (v = list + 2; v < list_end; v = NEXT_VALUE(v)) 
  { 
    n--;
    if (n == 0) 
      return v;
  }
  return NULL;
}

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

void 
build_list( int_t n )
/* Stack effects: VALUE1 ... VALUE_N -> NEW_LIST.
 * NEW_LIST looks like <VALUE1, ..., VALUE_N>. */
{
  value_t new_list, v;
  int_t i, new_list_length;
  value_t *elements;

  elements = value_stack + top - n;
  new_list_length = 2;
  for (i = 0; i < n; i++) 
    new_list_length += length_of_value( elements[i] );
  new_list = space_for_composed_value( LIST_TYPE, new_list_length );
  v = new_list + 2;
  for (i = 0; i < n; i++) 
  { 
    copy_value( v, elements[i] );
    v = NEXT_VALUE( v );
  }
  top -= n;
  push_value( new_list );
}

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

int_t 
decompose_list( void )
/* Stack effects: LIST -> VALUE1 ... VALUE_N.
 * VALUE1 ... VALUE_N are the elements of LIST.
 * Return N. */
{
  int_t n;
  value_t list, list_end, element;

  list = value_stack[ top - 1 ];
  top--;
  list_end = NEXT_VALUE( list );
  if (! IS_LIST( list )) 
    complain( "Only lists can be decomposed." );
  n = 0;
  for (element = list + 2; element < list_end; element = NEXT_VALUE( element ))
  { 
    push_value( element );
    n++;
  }
  return n;
}

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

void 
concat_lists( void )
/* Stack effects: LIST1 LIST2 -> NEW_LIST.
 * NEW_LIST is the concatenation of LIST1 and LIST2. */
{
  int_t list1_length, list2_length, new_list_length;
  value_t list1, list2, new_list;

  list1 = value_stack[ top - 2 ];
  list2 = value_stack[ top - 1 ];

  if (! IS_LIST( list1 ) || ! IS_LIST( list2 )) 
    complain( "Concatenation operands must be lists." );
  list1_length = length_of_value( list1 );
  list2_length = length_of_value( list2 );
  new_list_length = list1_length + list2_length - 2;
  new_list = space_for_composed_value( LIST_TYPE, new_list_length );

  list1 = value_stack[ top - 2 ];
  list2 = value_stack[ top - 1 ];
    
  /* Copy all elements of the first and the second list. */
  copy_cells( new_list + 2, list1 + 2, list1_length - 2 );
  copy_cells( new_list + list1_length, list2 + 2, list2_length - 2 );

  top--;
  value_stack[ top - 1 ] = new_list;
}

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

void 
get_list_difference( void )
/* Stack effects: LIST1 LIST2 -> NEW_LIST.
 * NEW_LIST contains the list difference of LIST1 and LIST2:
 * An element that appears M times in LIST1 and N times in LIST2 
 * appears M - N times in NEW_LIST. */
{
  value_t list1, list2, list1_end, list2_end, new_list, v, v1, v2;
  int_t new_list_length, appearances;

  list1 = value_stack[ top - 2 ];
  list2 = value_stack[ top - 1 ];
  list1_end = NEXT_VALUE( list1 );
  list2_end = NEXT_VALUE( list2 );

  if (! IS_LIST( list1 ) || ! IS_LIST( list2 )) 
    complain( "List difference operands must be lists." );

  /* Calculate the size of the new value. */
  new_list_length = 2;
  for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
  { /* Check whether V1 will be included in the list.
     * It will be included if the ordinal number of its appearance is 
     * higher than the number of appearances in LIST2. */
    
    /* Count appearences in LIST1 up to (including) V1. */
    appearances = 1;
    for (v2 = list1 + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      appearances++;
    }
    
    /* Subtract appearences in VALUE2. */
    for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      appearances--;
    }
    
    if (appearances > 0) 
      new_list_length += length_of_value( v1 );
  }
  
  /* We don't create a new list if no elements will be deleted. */
  if (new_list_length == length_of_value( list1 )) 
    new_list = list1;
  else
  { 
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );

    list1 = value_stack[ top - 2 ];
    list2 = value_stack[ top - 1 ];
    list1_end = NEXT_VALUE( list1 );
    list2_end = NEXT_VALUE( list2 );
  
    v = new_list + 2;
    for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
    { /* Check whether V1 will be included in the list.
       * It will be included if the ordinal number of its appearance is 
       * higher than the number of appearances in VALUE2. */
      
      /* Count appearences in VALUE1 up to (including) V1. */
      appearances = 1;
      for (v2 = list1 + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        appearances++;
      }
      
      /* Subtract appearences in VALUE2. */
      for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        appearances--;
      }
      
      if (appearances > 0) 
      { 
      copy_value( v, v1 );
        v = NEXT_VALUE(v);
      }
    }
  }
  top--;
  value_stack[ top - 1 ] = new_list;
}

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

void 
get_set_difference( void )
/* Stack effects: LIST1 LIST2 -> NEW_LIST.
 * NEW_LIST contains the set difference of LIST1 and LIST2.
 * Each element of LIST1 is in NEW_LIST if it is not in LIST2. */
{
  value_t list1, list2, list1_end, list2_end, new_list, v, v1, v2;
  int_t new_list_length;

  list1 = value_stack[ top - 2 ];
  list2 = value_stack[ top - 1 ];
  list1_end = NEXT_VALUE( list1 );
  list2_end = NEXT_VALUE( list2 );

  if (! IS_LIST( list1 ) || ! IS_LIST( list2 )) 
    complain( "Set difference operands must be lists." );

  /* Compute the length of the new list. */
  new_list_length = 2;
  for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
  { 
    for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      break;
    }
    if (v2 == list2_end) 
      new_list_length += length_of_value( v1 );
  }
  
  /* No need to create a new list if no elements will be deleted. */
  if (new_list_length == length_of_value( list1 )) 
    new_list = list1;
  else
  { 
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );

    list1 = value_stack[ top - 2 ];
    list2 = value_stack[ top - 1 ];
    list1_end = NEXT_VALUE( list1 );
    list2_end = NEXT_VALUE( list2 );

    v = new_list + 2;
    for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
    { 
      for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        break;
      }
      if (v2 == list2_end) 
      {
      copy_value( v, v1 ); 
      v = NEXT_VALUE(v); 
      }
    }
  }
  
  top--;
  value_stack[ top - 1 ] = new_list;
}

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

void 
intersect_lists( void )
/* Stack effects: LIST1 LIST2 -> NEW_LIST.
 * NEW_LIST contains the list intersection of LIST1 and LIST2.
 * Each element that appears M times in LIST1 and N times in LIST2
 * appears min(M, N) times in NEW_LIST. */
{
  value_t new_list, list1, list2, list1_end, list2_end, v1, v2, v;
  int_t new_list_length, appearances;

  list1 = value_stack[ top - 2 ];
  list2 = value_stack[ top - 1 ];
  list1_end = NEXT_VALUE( list1 );
  list2_end = NEXT_VALUE( list2 );

  /* Check arguments. */
  if (! IS_LIST( list1 ) || ! IS_LIST( list2 )) 
    complain( "Operands for intersection must be lists." );

  /* Calculate the size of the new list. */
  new_list_length = 2;
  for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
  { 
    /* Count appearences in LIST1 up to (including) V1. */
    appearances = 1;
    for (v2 = list1 + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      appearances++;
    }

    /* Subtract appearences in LIST2. */
    for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      appearances--;
    }

    /* Add element size if included. */
    if (appearances <= 0) 
      new_list_length += length_of_value( v1 );
  }

  /* We don't create a new list if no elements will be deleted. */
  if (new_list_length == length_of_value( list1 )) 
    new_list = list1;
  else
  { 
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );

    /* Get arguments again: they may have been moved by garbage collection. */
    list1 = value_stack[ top - 2 ];
    list2 = value_stack[ top - 1 ];
    list1_end = NEXT_VALUE( list1 );
    list2_end = NEXT_VALUE( list2 );

    /* Copy the elements. */
    v = new_list + 2;
    for (v1 = list1 + 2; v1 < list1_end; v1 = NEXT_VALUE( v1 )) 
    { 
      /* Count appearences in VALUE1 up to (including) V1. */
      appearances = 1;
      for (v2 = list1 + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        appearances++;
      }

      /* Subtract appearences in VALUE2. */
      for (v2 = list2 + 2; v2 < list2_end; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        appearances--;
      }

      /* Copy value if included. */
      if (appearances <= 0) 
      { 
      copy_value( v, v1 );
        v = NEXT_VALUE(v);
      }
    }
  }

  /* Pop arguments and push result on stack. */
  top--;
  value_stack[ top - 1 ] = new_list;
}

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

void 
remove_element( int_t n )
/* Stack effects: LIST -> NEW_LIST.
 * NEW_LIST is LIST without element at index N.
 * If N is positive, the elements will be counted from the left border;
 * if N is negative, they will be counted from the right border.
 * If LIST contains less than abs(N) elements, then NEW_LIST = LIST. */
{
  value_t list, list_end, new_list, element, v;
  int_t new_list_length;

  list = value_stack[ top - 1 ];
  if (! IS_LIST( list )) 
    complain( "Can remove an element in a list only." );

  /* Find the first/last value in the list that will/won't be copied. */
  element = get_element( list, n );
  if (element == NULL) 
    new_list = list;
  else
  { 
    new_list_length = length_of_value( list ) - length_of_value( element );
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );

    /* Get the values again, since they may have moved. */
    list = value_stack[ top - 1 ];
    list_end = NEXT_VALUE( list );
    element = get_element( list, n );

    /* Copy the list. */
    v = new_list + 2;
    copy_cells( v, list + 2, element - (list + 2) );
    v += element - (list + 2);
    copy_cells( v, NEXT_VALUE( element ), list_end - NEXT_VALUE( element ) );
  }
  value_stack[ top - 1 ] = new_list;
}

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

void 
remove_elements( int_t n )
/* Stack effects: LIST -> NEW_LIST.
 * NEW_LIST is LIST without abs(N) elements.
 * If N is positive, the elements will be cut from the left border,
 * if N is negative, they will be cut from the list's right border.
 * If LIST contains less than abs(N) elements, then NEW_LIST = <>. */
{
  value_t new_list, list, list_end, border_value;
  int_t new_list_length;

  list = value_stack[ top - 1 ];
  if (! IS_LIST( list )) 
    complain( "Can delete an element in a list only." );

  /* Find the first/last value in the list that will/won't be copied. */
  if (n == 0) 
    return;
  border_value = get_element( list, n );
  if (border_value == NULL) 
    new_list = empty_list;
  else if (n > 0) 
  { 
    /* Copy all elements behind BORDER_VALUE to a new list. */
    new_list_length = 2 + NEXT_VALUE( list ) - NEXT_VALUE( border_value );
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );
    list = value_stack[ top - 1 ];
    list_end = NEXT_VALUE( list );
    copy_cells( new_list + 2, list_end - (new_list_length - 2),
                new_list_length - 2 );
  } 
  else 
  { 
    /* Copy all elements in front of BORDER_VALUE to a new list. */
    new_list_length = border_value - list;
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );
    list = value_stack[ top - 1 ];
    copy_cells( new_list + 2, list + 2, new_list_length - 2 );
  }
  value_stack[ top - 1 ] = new_list;
}

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

void 
extract_elements( int_t n )
/* Stack effects: LIST -> NEW_LIST.
 * NEW_LIST is LIST with only abs(N) elements.
 * If N is positive, the elements will be taken from the left border,
 * if N is negative, they will be taken from the list's right border.
 * If LIST contains less than abs(N) elements, then NEW_LIST = LIST. */
{
  value_t new_list, list, list_end, border_value;
  int_t new_list_length;

  list = value_stack[ top - 1 ];
  if (! IS_LIST( list )) 
    complain( "Can extract elements from a list only." );

  /* Find the first/last value in the list that will/won't be copied. */
  if (n == 0) 
    new_list = empty_list;
  else
  {
    border_value = get_element( list, n );
    if (border_value == NULL) 
      return;
    if (n > 0) 
    { 
      /* Copy all elements in front of BORDER_VALUE to a new list. */
      new_list_length = NEXT_VALUE( border_value ) - list;
      new_list = space_for_composed_value( LIST_TYPE, new_list_length );
      list = value_stack[ top - 1 ];
      copy_cells( new_list + 2, list + 2, new_list_length - 2 );
    } 
    else 
    { 
      /* Copy all elements behind BORDER_VALUE to a new list. */
      new_list_length = 2 + NEXT_VALUE( list ) - border_value;
      new_list = space_for_composed_value( LIST_TYPE, new_list_length );
      list = value_stack[ top - 1 ];
      list_end = NEXT_VALUE( list );
      copy_cells( new_list + 2, list_end - (new_list_length - 2),
              new_list_length - 2 );
    }
  }
  value_stack[ top - 1 ] = new_list;
}

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

void 
replace_element( int_t n )
/* Stack effects: LIST VALUE -> NEW_LIST.
 * NEW_LIST is LIST, but its N-th element is replaced by VALUE.
 * If N is negative, count from the right end.
 * LIST must contain at least N elements. */
{
  value_t list, value, new_list, element, nv;
  int_t new_list_length;

  /* Get arguments. */
  list = value_stack[ top - 2 ];
  value = value_stack[ top - 1 ];

  /* Check arguments. */
  if (! IS_LIST( list )) 
    complain( "Can only replace an element in a list." );
  element = get_element( list, n );
  if (element == NULL) 
    complain( "Missing element to replace." );
  new_list_length = (length_of_value( list ) +
                     length_of_value( value ) - length_of_value( element ));
  new_list = space_for_composed_value( LIST_TYPE, new_list_length );

  /* Get arguments again: they may have been moved by garbage collection. */
  list = value_stack[ top - 2 ];
  value = value_stack[ top - 1 ];
  element = get_element( list, n );

  /* Copy left part */
  nv = new_list + 2;
  copy_cells( nv, list + 2, element - (list + 2) );

  /* Copy changed element. */
  nv += element - (list + 2);
  copy_value( nv, value );

  /* Copy right part. */
  nv = NEXT_VALUE( nv );
  copy_cells( nv, NEXT_VALUE( element ), 
            NEXT_VALUE( list ) - NEXT_VALUE( element ) );

  /* Push result on stack. */
  top--;
  value_stack[ top - 1 ] = new_list;
}

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

void 
convert_list_to_set( void )
/* Stack effects: LIST -> NEW_LIST.
 * NEW_LIST contains all elements of LIST, but multiple appearances
 * of one value are reduced to a single appearance.
 * That means, NEW_LIST is LIST converted to a set. */
{
  value_t v1, v2, v, new_list, list, list_end;
  int_t new_list_length;

  list = value_stack[ top - 1 ];
  list_end = NEXT_VALUE( list );

  if (! IS_LIST( list )) 
    complain( "Can only convert a list to a set." );

  /* Compute the length of the new list. */
  new_list_length = 2;
  for (v1 = list + 2; v1 < list_end; v1 = NEXT_VALUE( v1 )) 
  { 
    /* Check if V1 already occurred in the list. */
    for (v2 = list + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      break;
    }
    if (v2 == v1) 
      new_list_length += length_of_value( v1 );
  }
  
  /* No need to create a new list if no elements will be deleted. */
  if (new_list_length == length_of_value( list )) 
    new_list = list;
  else
  { 
    new_list = space_for_composed_value( LIST_TYPE, new_list_length );

    list = value_stack[ top - 1 ];
    list_end = NEXT_VALUE( list );

    v = new_list + 2;
    for (v1 = list + 2; v1 < list_end; v1 = NEXT_VALUE( v1 )) 
    { 
      /* Check if V1 already occurred in the list. */
      for (v2 = list + 2; v2 < v1; v2 = NEXT_VALUE( v2 )) 
      { 
      if (values_equal( v1, v2 )) 
        break;
      }
      if (v2 == v1) 
      { 
      copy_value( v, v1 ); 
      v = NEXT_VALUE( v ); 
      }
    }
  }

  value_stack[ top - 1 ] = new_list;
}

/* Number operations. =======================================================*/

double 
value_to_double( value_t value )
/* Return the value of VALUE which must be a number value. */
{
  double number;
  value_t number_p;
  int_t i;

  if (! IS_NUMBER( value )) 
    complain( "Value is no number." );
  number_p = (value_t) &number;
  for (i = 0; i < CELLS_PER_NUMBER; i++) 
    number_p[i] = value[ i + 1 ];
  return number;
}

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

int_t 
value_to_int( value_t value )
/* Return the value of VALUE which must be an integral number value. */
{
  double number;
  int_t result;

  number = value_to_double( value );
  result = (int_t) number;
  if (result != number) 
    complain( "Number too big or not integral." );
  return result;
}

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

void 
push_number_value( double number )
/* Stack effects: (nothing) -> NEW_NUMBER.
 * NEW_NUMBER is NUMBER as a Malaga value. */
{
  int_t i;
  value_t value, number_p;

  number_p = (value_t) &number;
  value = space_for_value( 1 + CELLS_PER_NUMBER );
  *value = TYPE_CELL( NUMBER_TYPE, 0 );
  for (i = 0; i < CELLS_PER_NUMBER; i++) 
    value[ i + 1 ] = number_p[i];
  push_value( value );
}

/* Type dependent Malaga operations. ========================================*/

void 
dot_operation( void )
/* Stack effects: VALUE1 VALUE2 -> NEW_VALUE.
 * NEW_VALUE is VALUE1 "." VALUE2 or NULL, if that value doesn't exist.
 * The actual operation depends on the type of the values. */
{
  value_t value1, value2;

  value1 = value_stack[ top - 2 ];
  value2 = value_stack[ top - 1 ];
  switch (TYPE( value2 )) 
  {
  case SYMBOL_TYPE:
    top--;
    value_stack[ top - 1 ] = get_attribute( value1, 
                                  value_to_symbol( value2 ) );
    break;
  case NUMBER_TYPE:
    top--;
    value_stack[ top - 1 ] = get_element( value1, value_to_int( value2 ) );
    break;
  case LIST_TYPE:
    top--;
    value_stack[ top - 1 ] = get_value_part( value1, value2 );
    break;
  default:
    complain( "In \"V1 . V2\", V2 must be symbol, number or list." );
  }
}

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

void 
plus_operation( void )
/* Stack effects: VALUE1 VALUE2 -> NEW_VALUE.
 * NEW_VALUE is VALUE1 "+" VALUE2. 
 * The actual operation depends on the type of the values. */
{
  value_t value1, value2;

  value1 = value_stack[ top - 2 ];
  value2 = value_stack[ top - 1 ];
  switch (TYPE( value1 )) 
  {
  case STRING_TYPE:
    concat_string_values();
    break;
  case LIST_TYPE:
    concat_lists();
    break;
  case RECORD_TYPE:
    join_records();
    break;
  case NUMBER_TYPE:
    top -= 2;
    push_number_value( value_to_double( value1 ) + value_to_double( value2 ) );
    break;
  default:
    complain( "\"+\"-operands must be strings, lists, records, or numbers." );
  }
}

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

void 
minus_operation( void )
/* Stack effects: VALUE1 VALUE2 -> NEW_VALUE.
 * NEW_VALUE is VALUE1 "-" VALUE2. 
 * The actual operation depends on the type of the values. */
{
  value_t value1, value2;

  value1 = value_stack[ top - 2 ];
  value2 = value_stack[ top - 1 ];
  switch (TYPE( value1 )) 
  {
  case LIST_TYPE:
    switch (TYPE( value2 )) 
    {
    case NUMBER_TYPE:
      top--;
      remove_element( value_to_int( value2 ) ); 
      break;
    case LIST_TYPE:
      get_list_difference();
      break;
    default:
      complain( "In \"LIST - VALUE\", VALUE must be number or list." );
    }
    break;
  case RECORD_TYPE:
    switch (TYPE( value2 )) 
    {
    case SYMBOL_TYPE:
      top--;
      remove_attribute( value_to_symbol( value2 ) );
      break;
    case LIST_TYPE:
      remove_attributes();
      break;
    default: 
      complain( "In \"RECORD - VALUE\", VALUE must be symbol or list." );
    }
    break;
  case NUMBER_TYPE:
    top -= 2;
    push_number_value( value_to_double( value1 ) - value_to_double( value2 ) );
    break;
  default:
    complain( "In \"V1 - V2\", V1 must be list, record, or number." );
  }
}

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

void 
asterisk_operation( void )
/* Stack effects: VALUE1 VALUE2 -> NEW_VALUE.
 * NEW_VALUE is VALUE1 "*" VALUE2. 
 * The actual operation depends on the type of the values. */
{
  value_t value1, value2;

  value1 = value_stack[ top - 2 ];
  value2 = value_stack[ top - 1 ];
  switch (TYPE( value1 )) 
  {
  case LIST_TYPE:
    switch (TYPE( value2 ))
    {
    case LIST_TYPE:
      intersect_lists();
      break;
    case NUMBER_TYPE:
      top--;
      extract_elements( value_to_int( value2 ) );
      break;
    default:
      complain( "In \"LIST * VALUE\", VALUE must be list, or number." );
    }
    break;
  case RECORD_TYPE:
    switch (TYPE( value2 )) 
    {
    case SYMBOL_TYPE:
      top--;
      select_attribute( value_to_symbol( value2 ) );
      break;
    case LIST_TYPE:
      select_attributes();
      break;
    case RECORD_TYPE: /* Join records, but exchange arguments. */
      top--;
      insert_value( 1, value_stack[ top ] );
      join_records();
      break;
    default:
      complain( "In \"RECORD * VALUE\", "
            "VALUE must be symbol, list, or record." );
    }
    break;
  case NUMBER_TYPE:
    top -= 2;
    push_number_value( value_to_double( value1 ) * value_to_double( value2 ) );
    break;
  default:
    complain( "In \"V1 * V2\", V1 must be list, record, or number." );
  }
}

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

void 
slash_operation( void )
/* Stack effects: VALUE1 VALUE2 -> NEW_VALUE.
 * NEW_VALUE is VALUE1 "/" VALUE2. 
 * The actual operation depends on the type of the values. */
{
  value_t value1, value2;
  double divisor;

  value1 = value_stack[ top - 2 ];
  value2 = value_stack[ top - 1 ];

  switch (TYPE( value1 )) 
  {
  case LIST_TYPE:
    switch (TYPE( value2 )) 
    {
    case NUMBER_TYPE:
      top--;
      remove_elements( value_to_int( value2 ) );
      break;
    case LIST_TYPE:
      get_set_difference();
      break;
    default:
      complain( "In \"LIST / VALUE\", VALUE must be number or list." );
    }
    break;
  case NUMBER_TYPE:
    divisor = value_to_double( value2 );
    if (divisor == 0.0) 
      complain( "Division by zero." );
    top -= 2;
    push_number_value( value_to_double( value1 ) / divisor );
    break;
  default:
    complain( "\"/\"-operands must be lists or numbers." );
  }
}

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

void 
unary_minus_operation( void )
/* Stack effects: VALUE -> NEW_VALUE.
 * NEW_VALUE is "-" VALUE.
 * The actual operation depends on the type of the value. */
{
  push_number_value( -value_to_double( value_stack[ --top ] ) );
}

/* Attribute path functions. ================================================*/

value_t 
get_value_part( value_t value, value_t path )
/* Return the value part of VALUE that is specified by the path PATH. 
 * If that value part does not exist, return NULL. */
{
  value_t part, path_end;
  
  if (! IS_LIST( path )) 
    complain( "Path must be a list." );
  path_end = NEXT_VALUE( path );
  for (part = path + 2; part < path_end; part = NEXT_VALUE( part )) 
  { 
    if (IS_SYMBOL( part )) 
      value = get_attribute( value, *part );
    else if (IS_NUMBER( part )) 
      value = get_element( value, value_to_int( part ) );
    else 
      complain( "Path must contain symbols and numbers only." );
    if (value == NULL) 
      return NULL;
  }
  return value;
}

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

void 
build_path( int_t n )
/* Stack effects: VALUE1 ... VALUE_N -> NEW_LIST.
 * NEW_LIST is a path which contains VALUE1, ..., VALUE_N. 
 * VALUE1, ..., VALUE_N must be numbers, symbols or lists of numbers and 
 * symbols. If a value is a list, the elements of this list are inserted into
 * NEW_LIST instead of the value itself. */
{
  value_t new_list, v, element_end;
  int_t i, new_list_length;
  value_t *elements;

  elements = value_stack + top - n;
  new_list_length = 2;
  for (i = 0; i < n; i++) 
  { 
    switch (TYPE( elements[i] )) 
    {
    case LIST_TYPE:
      element_end = NEXT_VALUE( elements[i] );
      for (v = elements[i] + 2; v < element_end; v = NEXT_VALUE(v)) 
      { 
      if (! IS_SYMBOL(v) && ! IS_NUMBER(v)) 
        complain( "Sublist in path may contain symbols and numbers only." );
      }
      new_list_length += length_of_value( elements[i] ) - 2;
      break;
    case SYMBOL_TYPE:
    case NUMBER_TYPE:
      new_list_length += length_of_value( elements[i] );
      break;
    default: 
      complain( "Value path may contain symbols, numbers and lists only." );
    }
  }
  new_list = space_for_composed_value( LIST_TYPE, new_list_length );
  v = new_list + 2;
  for (i = 0; i < n; i++) 
  { 
    if (IS_LIST( elements[i] )) 
    { 
      copy_cells( v, elements[i] + 2, length_of_value( elements[i] ) - 2 );
      v += length_of_value( elements[i] ) - 2;
    } 
    else 
    { 
      copy_value( v, elements[i] );
      v = NEXT_VALUE(v);
    }
  }
  top -= n;
  push_value( new_list );
}

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

static void 
modify_value_part_local( void (*modifier)( void ), int_t value_index, 
                         int_t path_index )
/* Stack effects: VALUE PATH MOD_VALUE -> VALUE PATH NEW_VALUE.
 * NEW_VALUE is VALUE, but the part that is described by PATH is 
 * modified. PATH must be a list of symbols and numbers <E1, E2, .. , E_N>.
 * They will be used as nested attributes and indexes, so the part of VALUE
 * that is actually modified is OLD_VALUE := VALUE.E1.E2..E_N. 
 * If this part does not exist, an error will be reported. Else the function 
 * MODIFIER will be called on OLD_VALUE and MOD_VALUE. 
 * The value returned by MODIFIER will be entered in VALUE in place of
 * OLD_VALUE. */
{
  value_t value, subvalue, selector;
  int_t subvalue_index, index;
  symbol_t symbol;
  
  value = value_stack[ top - 3 ] + value_index;
  selector = get_element( value_stack[ top - 2 ], path_index );
  if (selector == NULL) /* No more selectors. */
  { 
    insert_value( 1, value );
    modifier();
  } 
  else /* Find attribute in VALUE. */
  { 
    if (IS_SYMBOL( selector ) ) 
    { 
      symbol = value_to_symbol( selector );
      subvalue = get_attribute( value, symbol );
      if (subvalue == NULL) 
      {
      complain( "No attribute \"%s\" in value.", 
              values_get_symbol_name( symbol ) );
      }
    } 
    else if (IS_NUMBER( selector )) 
    { 
      index = value_to_int( selector );
      subvalue = get_element( value, index );
      if (subvalue == NULL) 
      complain( "No element at index %d in value.", index );
    } 
    else 
      complain( "Path must consist of symbols and numbers." );
    subvalue_index = subvalue - value_stack[ top - 3 ];

    /* Go down recursively */
    modify_value_part_local( modifier, subvalue_index, path_index + 1 );
    subvalue = value_stack[ top - 3 ] + subvalue_index;
    value = value_stack[ top - 3 ] + value_index;
    selector = get_element( value_stack[ top - 2 ], path_index );
    if (value_stack[ top - 1 ] == subvalue) 
      value_stack[ top - 1 ] = value;
    else if (IS_SYMBOL( selector )) 
    { 
      insert_value( 1, value );
      replace_attribute( value_to_symbol( selector ) );
    } 
    else 
    { 
      insert_value( 1, value );
      replace_element( value_to_int( selector ) );
    }
  }
}

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

void 
modify_value_part( void (*modifier)( void ) )
/* Stack effects: VALUE PATH MOD_VALUE -> NEW_VALUE.
 * NEW_VALUE is VALUE, but the part that is described by PATH is 
 * modified. PATH must be a list of symbols and numbers <E1, E2, .. , E_N>.
 * They will be used as nested attributes and indexes, so the part of VALUE
 * that is actually modified is OLD_VALUE := VALUE.E1.E2..E_N. 
 * If this part does not exist, an error will be reported. Else the function 
 * MODIFIER will be called on OLD_VALUE and MOD_VALUE. 
 * The value returned by MODIFIER will be entered in VALUE in place of
 * OLD_VALUE. */
{
  modify_value_part_local( modifier, 0, 1 );
  value_stack[ top - 3 ] = value_stack[ top - 1 ];
  top -= 2;
}

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

void 
right_value( void )
/* Stack effects: LEFT_VALUE RIGHT_VALUE -> RIGHT_VALUE.
 * A modifier for "modify_value_part". */
{
  top--;
  value_stack[ top - 1 ] = value_stack[ top ];
}

/* Functions for list/record iteration. =====================================*/

value_t
get_first_item( value_t value )
/* If VALUE is a list, then return its first element (or NULL).
 * If VALUE is a record, then return its first attribute (or NULL). */
{
  if (! IS_LIST( value ) && ! IS_RECORD( value )) 
    complain( "Can only get first item in a record or a list." );
  if (length_of_value( value ) == 2) 
    return NULL;
  return value + 2;
}

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

value_t
get_next_item( value_t value, value_t item )
/* If VALUE is a list, and ELEMENT one of its elements,
 * then NEW_ELEMENT is the successor of ELEMENT (or NULL).
 * If VALUE is a record, and ELEMENT one of its attributes,
 * then NEW_ELEMENT is the next attribute in VALUE (or NULL). */
{
  value_t next_item;

  switch (TYPE( value )) 
  {
  case LIST_TYPE: 
    next_item = NEXT_VALUE( item ); 
    break;
  case RECORD_TYPE: 
    next_item = NEXT_ATTRIB( item ); 
    break;
  default: 
    complain( "Can only get next item in a list or record." );
  }
  if (next_item == NEXT_VALUE( value )) 
    return NULL;
  else
    return next_item;
}

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

void 
get_first_element( void )
/* Stack effects: VALUE -> NEW_VALUE.
 * If VALUE is a list, then NEW_VALUE is its first element (or NULL).
 * If VALUE is a record, then NEW_VALUE is its first attribute (or NULL).
 * If VALUE is a number, then NEW_VALUE is NULL (if VALUE == 0),
 * 1 (if VALUE > 0) or -1 (if VALUE < 0). */
{
  value_t value;
  int_t limit;

  value = value_stack[ top - 1 ];
  top--;
  if (*value == NIL_SYMBOL) 
    push_value( NULL );
  else 
  { 
    switch (TYPE( value )) 
    {
    case RECORD_TYPE: 
    case LIST_TYPE:
      /* Return NULL if list or record is empty. */
      if (length_of_value( value ) == 2) 
      push_value( NULL );
      else 
      push_value( value + 2 );
      break;
    case NUMBER_TYPE:
      limit = value_to_int( value );
      if (limit > 0) 
      push_number_value( 1.0 );
      else if (limit < 0) 
      push_number_value( -1.0 );
      else 
      push_value( NULL );
      break;
    default: 
      complain( "Can iterate on lists, records and numbers only." );
    }
  }
}

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

void 
get_next_element( int_t index )
/* Stack effects: (nothing) -> (nothing).
 * VALUE is VALUE_STACK[ INDEX - 1 ], ELEMENT is VALUE_STACK[ INDEX ].
 * VALUE_STACK[ INDEX ] will be set to NEW_ELEMENT.
 * ELEMENT must be the result of an application of "get_first_element()" or 
 * "get_next_element()" on VALUE.
 * If VALUE is a list, and ELEMENT one of its elements,
 * then NEW_ELEMENT is the successor of ELEMENT (or NULL).
 * If VALUE is a record, and ELEMENT one of its attributes,
 * then NEW_ELEMENT is the next attribute in VALUE (or NULL).
 * If VALUE is a positive number, and ELEMENT a number smaller than
 * VALUE, then NEW_ELEMENT is ELEMENT + 1.
 * If VALUE is a negative number, and ELEMENT a number greater than
 * VALUE, then NEW_ELEMENT is ELEMENT - 1. */
{
  value_t value, element;
  int_t number, limit;

  value = value_stack[ index - 1 ];
  element = value_stack[ index ];
  if (element == NULL) 
    return;
  switch (TYPE( value )) 
  {
  case RECORD_TYPE:
    element = NEXT_ATTRIB( element );
    if (element >= NEXT_VALUE( value )) 
      element = NULL;
    break;
  case LIST_TYPE:
    element = NEXT_VALUE( element );
    if (element >= NEXT_VALUE( value )) 
      element = NULL;
    break;
  case NUMBER_TYPE:
    limit = value_to_int( value );
    number = value_to_int( element );
    if (limit > 0 && number < limit) 
    { 
      push_number_value( number + 1 );
      element = value_stack[ --top ];
    } 
    else if (limit < 0 && number > limit) 
    { 
      push_number_value( number - 1 );
      element = value_stack[ --top ];
    } 
    else 
      element = NULL;
    break;
  default: 
    complain( "Can iterate on lists, records and numbers only." );
  }
  value_stack[ index ] = element;
}

/* Functions to compare values. =============================================*/

static void 
check_atom_list( value_t atoms )
/* Check if ATOMS is a list that contains of atoms only. */
{
  value_t v;
  value_t atoms_end;
  
  if (! IS_LIST( atoms )) 
    complain( "Atom list must be a list." );
  atoms_end = NEXT_VALUE( atoms );
  for (v = atoms + 2; v < atoms_end; v++) 
  { 
    if (! IS_SYMBOL(v)) 
      complain( "Atom list must consist of symbols." );
  }
}

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

static symbol_t 
next_symbol( value_t atoms, int_t lower_limit )
/* Return the smallest symbol in ATOMS that is greater than LOWER_LIMIT.
 * Return SYMBOL_MAX if no such symbol exists. */
{
  symbol_t symbol;
  value_t v;
  value_t atoms_end;
  
  atoms_end = NEXT_VALUE( atoms );
  symbol = SYMBOL_MAX;
  for (v = atoms + 2; v < atoms_end; v++) 
  { 
    if (*v > lower_limit && *v < symbol) 
      symbol = *v;
  }
  return symbol;
}

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

int_t 
compare_atom_lists( value_t atoms1, value_t atoms2 )
/* Compare atom lists ATOMS1 and ATOMS2.
 * Return -1 if ATOMS1 < ATOMS2.
 * Return 0 if ATOMS1 == ATOMS2.
 * Return 1 if ATOMS1 > ATOMS2. */
{
  int_t limit1, limit2;

  check_atom_list( atoms1 );
  check_atom_list( atoms2 );

  limit1 = limit2 = -1;
  while (TRUE) 
  { 
    limit1 = next_symbol( atoms1, limit1 );
    limit2 = next_symbol( atoms2, limit2 );
    if (limit1 < limit2) 
      return -1;
    if (limit1 > limit2) 
      return 1;
    if (limit1 == SYMBOL_MAX) 
      return 0;
  }
}

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

bool_t 
values_equal( value_t value1, value_t value2 )
/* Return a truth value indicating whether VALUE1 and VALUE2 are equal.
 * VALUE1 an VALUE2 must be of same type or one of them must be nil.
 * Refer to documentation to see what "equal" in Malaga really means. */
{
  value_t value1_end, value2_end, v1, v2;

  if (TYPE( value1 ) != TYPE( value2 )) 
  { 
    if (*value1 != NIL_SYMBOL && *value2 != NIL_SYMBOL) 
      complain( "Can compare values of same type only." );
    return FALSE;
  }
  switch (TYPE( value1 )) 
  {
  case SYMBOL_TYPE:
    return (*value1 == *value2);
  case STRING_TYPE:
    return (strcmp_no_case( (string_t) (value1 + 1), (string_t) (value2 + 1) ) 
          == 0);
  case LIST_TYPE:
    /* Look for each value pair if they are equal. */ 
    value1_end = NEXT_VALUE( value1 );
    value2_end = NEXT_VALUE( value2 );
    for (v1 = value1 + 2, v2 = value2 + 2; 
         v1 < value1_end && v2 < value2_end; 
         v1 = NEXT_VALUE( v1 ), v2 = NEXT_VALUE( v2 )) 
    { 
      if (! values_equal( v1, v2 )) 
      return FALSE;
    }
    return (v1 == value1_end && v2 == value2_end);
  case RECORD_TYPE:
    value1_end = NEXT_VALUE( value1 );
    value2_end = NEXT_VALUE( value2 );

    /* Do the records have the same length? */
    if (value1_end - value1 != value2_end - value2) 
      return FALSE;

    /* Check whether for every attribute in VALUE1, there is one
     * in VALUE2 and that their values are equal. */
    for (v1 = value1 + 2; v1 < value1_end; v1 = NEXT_ATTRIB( v1 )) 
    { 
      /* Look for the same attribute in VALUE2. */
      for (v2 = value2 + 2; v2 < value2_end; v2 = NEXT_ATTRIB( v2 )) 
      { 
      if (*v1 == *v2) 
        break;
      }

      /* Return if we looked 'till end of value2 and didn't the find attribute,
       * or if they don't have the same values. */
      if (v2 == value2_end || ! values_equal( v1 + 1, v2 + 1 )) 
      return FALSE;
    }
    return TRUE;
  case NUMBER_TYPE:
    return (value_to_double( value1 ) == value_to_double( value2 ));
  default:
    complain( "Internal error." );
  }
}

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

bool_t 
values_congruent( value_t value1, value_t value2 )
/* Return a truth value indicating whether VALUE1 and VALUE2 have
 * at least one element in common.
 * VALUE1 and VALUE2 must both be symbols or lists. */
{
  value_t value1_end, value2_end, v1, v2;
  
  if (TYPE( value1 ) != TYPE( value2 )) 
    complain( "For congruency test, values must be of same type." );
  if (IS_SYMBOL( value1 )) 
  {
    value1 = values_get_atoms( value_to_symbol( value1 ) );
    value2 = values_get_atoms( value_to_symbol( value2 ) );
  } 
  else if (! IS_LIST( value1 )) 
    complain( "For congruency test, values must be lists or symbols." );
  
  /* Look for a common element. */
  value1_end = NEXT_VALUE( value1 );
  value2_end = NEXT_VALUE( value2 );
  for (v1 = value1 + 2; v1 < value1_end; v1 = NEXT_VALUE( v1 )) 
  { 
    for (v2 = value2 + 2; v2 < value2_end; v2 = NEXT_VALUE( v2 )) 
    { 
      if (values_equal( v1, v2 )) 
      return TRUE;
    }
  }

  /* No common symbol found. */
  return FALSE;
}

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

bool_t 
value_in_value( value_t value1, value_t value2 )
/* Return bool value saying if VALUE1 is element or attribute of VALUE2.
 * VALUE2 must be a list or a record.
 * If VALUE2 is a record, then VALUE1 must be a symbol. */
{
  value_t value2_end;

  value2_end = NEXT_VALUE( value2 );
  if (IS_LIST( value2 )) 
  { 
    for (value2 += 2; value2 < value2_end; value2 = NEXT_VALUE( value2 )) 
    { 
      if (values_equal( value1, value2 )) 
      return TRUE;
    }
  } 
  else if (IS_RECORD( value2 )) 
  { 
    if (! IS_SYMBOL( value1 )) 
      complain( "Only attributes can be found in a record using \"in\"." );
    for (value2 += 2; value2 < value2_end; value2 = NEXT_ATTRIB( value2 )) 
    { 
      if (*value1 == *value2) 
      return TRUE;
    }
  } 
  else 
    complain( "Can use \"in\" with records and lists only." );
  return FALSE;
}

/* Functions to print values. ===============================================*/

static attribute_t *
find_hidden_attribute( symbol_t symbol )
/* Find a hidden attribute in the attribute list and return it.
 * Return NULL if there is none. */
{
  attribute_t *attr;

  FOREACH( attr, hidden_attributes ) 
  { 
    if (attr->symbol == symbol) 
      return attr;
  }
  return NULL;
}

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

symbol_t *
get_hidden_attributes( void )
/* Get a SYMBOL_MAX-terminated vector of the currently hidden attributes. 
 * The vector must be freed after use. */
{
  int_t i;
  attribute_t *attr;
  symbol_t *vector;

  /* Count the attributes. */
  i = 0;
  FOREACH( attr, hidden_attributes ) 
    i++;

  /* Create the new vector. */
  vector = new_vector( sizeof( symbol_t ), i + 1 );
  i = 0;
  FOREACH( attr, hidden_attributes )  
    vector[ i++ ] = attr->symbol;
  vector[ i++ ] = SYMBOL_MAX;

  return vector;
}

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

void 
add_hidden_attribute( symbol_t attribute )
/* Add ATTRIBUTE to the list of currently hidden attributes. */
{
  attribute_t *attr;

  attr = find_hidden_attribute( attribute );
  if (attr == NULL) 
  { 
    attr = new_node( &hidden_attributes, sizeof( attribute_t ), LIST_END );
    attr->symbol = attribute;
  }
}

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

void 
remove_hidden_attribute( symbol_t attribute )
/* Remove ATTRIBUTE from the list of currently hidden attributes. */
{
  attribute_t *attr;

  attr = find_hidden_attribute( attribute );
  if (attr != NULL) 
    free_node( &hidden_attributes, (list_node_t *) attr );
}

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

void 
clear_hidden_attributes( void )
/* Clear the list of currently hidden attributes. */
{
  attribute_t *attr;

  FOREACH_FREE( attr, hidden_attributes ) 
    /*empty*/;
}

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

static void 
attribute_to_text( text_t *text, 
               value_t attr, 
               bool_t full_value, 
               int_t indent )
/* Print the attribute and value of the attribute-value pair ATTR.
 * If ! FULL_VALUE and *ATTR is hidden, don't print its value. */
{
  string_t attr_name;

  attr_name = values_get_symbol_name( *attr );
  if (full_value || find_hidden_attribute( *attr ) == NULL) 
  { 
    add_to_text( text, attr_name );
    add_to_text( text, ": " );
    if (indent >= 0) 
      indent += strlen( attr_name ) + 2;
    value_to_text( text, attr + 1, full_value, indent );
  } 
  else 
  { 
    add_char_to_text( text, '(') ;
    add_to_text( text, attr_name );
    add_char_to_text( text, ')' );
  }
}

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

static void 
print_comma( text_t *text, int_t indent )
/* Print a comma separator.
 * If INDENT >= 0, break the line and indent to column INDENT. */
{
  int_t i;

  if (indent >= 0) 
  { 
    add_to_text( text, ",\n" );
    for (i = 0; i < indent; i++) 
      ADD_CHAR_TO_TEXT( text, ' ' );
  } 
  else 
    add_to_text( text, ", " );
}

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

static string_t 
simple_value_to_string( value_t value )
/* Return VALUE, which must be a simple value, as a string */
{
  string_t string;

  switch (TYPE( value )) 
  {
  case SYMBOL_TYPE:
    string = new_string( values_get_symbol_name( *value ), NULL );
    break;
  case STRING_TYPE:
    string = new_string_readable( (string_t) (value + 1), NULL );
    decode_hangul( &string );
    break;
  case NUMBER_TYPE:
    string = double_to_string( value_to_double( value ) );
    break;
  }
  return string;
}

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

static void 
value_to_text( text_t *text, value_t value, bool_t full_value, int_t indent )
/* Convert VALUE to a format readable for humans and add it to TEXT.
 * which extends to OUTPUT_END (this is a pointer to the first byte after
 * OUTPUT. The pointer returned points to the EOS of the built string.
 * If FULL_VALUE == TRUE, show all attributes, even those that are hidden. */
{
  value_t value_end;
  string_t string;
  value_t item;
  bool_t list_is_simple;
  int_t column;
  string_t item_string;
  value_t attr, last_attr, next_attr;
  string_t name, last_name = NULL, next_name = NULL;

  if (value == NULL) 
    return;
  value_end = NEXT_VALUE( value );
  switch (TYPE( value )) 
  {
  case SYMBOL_TYPE:
  case STRING_TYPE:
  case NUMBER_TYPE:
    string = simple_value_to_string( value );
    add_to_text( text, string );
    free_mem( &string );
    break;
  case LIST_TYPE:
    add_char_to_text( text, '<' );
    if (indent >= 0) 
      indent++;

    /* Check if all elements are simple. */
    list_is_simple = TRUE;
    for (item = value + 2; item < value_end; item = NEXT_VALUE( item )) 
    { 
      if (IS_LIST( item ) || IS_RECORD( item )) 
      { 
      list_is_simple = FALSE;
        break;
      }
    }

    if (indent >= 0 && list_is_simple) 
    { 
      /* Print multiple items on a line, break at column 80. */
      column = indent;
      for (item = value + 2; item < value_end; item = NEXT_VALUE( item )) 
      { 
      item_string = simple_value_to_string( item );
        if (item > value + 2) 
      { 
        if (column + 2 + strlen( item_string ) >= 80) 
        { 
          print_comma( text, indent );
            column = indent;
          } 
        else 
        { 
          print_comma( text, -1 ); 
          column += 2; 
        }
        }
        add_to_text( text, item_string );
        column += strlen( item_string );
        free_mem( &item_string );
      }
    } 
    else 
    { 
      /* Print each item on its own line or all items on one line. */
      for (item = value + 2; item < value_end; item = NEXT_VALUE( item )) 
      { 
      if (item > value + 2) 
        print_comma( text, indent );
        value_to_text( text, item, full_value, indent );
      }
    }
    add_char_to_text( text, '>' );
    break; 
  case RECORD_TYPE: 
    add_char_to_text( text, '[' );
    if (indent >= 0) 
      indent++;
    last_attr = NULL;
    while (TRUE) 
    { 
      /* Find the next attribute to be printed. */
      next_attr = NULL;
      for (attr = value + 2; attr < value_end; attr = NEXT_ATTRIB( attr )) 
      { 
      /* If ATTR comes after LAST_ATTR and before NEXT_ATTR,
         * then it's the new candidate to be printed this time. */
        switch (attribute_order) 
      {
        case ALPHABETIC_ORDER:
          name = values_get_symbol_name( *attr );
          if ((last_attr == NULL || strcmp_no_case( name, last_name ) > 0) &&
              (next_attr == NULL || strcmp_no_case( name, next_name ) < 0)) 
        { 
          next_attr = attr; 
          next_name = name;
          }
          break;
        case DEFINITION_ORDER:
          if ((last_attr == NULL || *attr > *last_attr)
              && (next_attr == NULL || *attr < *next_attr)) 
        { 
          next_attr = attr; 
        }
          break;
        case INTERNAL_ORDER:
          if ((last_attr == NULL || attr > last_attr)
              && (next_attr == NULL || attr < next_attr)) 
        { 
          next_attr = attr; 
        }
          break;
        }
      }         
      if (next_attr == NULL) 
      break;
      if (last_attr != NULL) 
      print_comma( text, indent );
      attribute_to_text( text, next_attr, full_value, indent );
      last_attr = next_attr; 
      last_name = next_name; 
    }
    add_char_to_text( text, ']' );
    break;  
  default: 
    complain( "Internal error." );
  }
}

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

string_t 
value_to_readable( value_t value, bool_t full_value, int_t indent )
/* Return VALUE in a format readable for humans. 
 * If FULL_VALUE == TRUE, show all attributes, even those that are hidden.
 * If INDENT >= 0, format value, i.e. print each element of a list or record
 * on a line of its own. Assume the value is indented by INDENT columns.
 * The result must be freed after use. */
{
  clear_text( value_text );
  value_to_text( value_text, value, full_value, indent );
  return new_string( value_text->buffer, NULL );
}

/* End of file. =============================================================*/

Generated by  Doxygen 1.6.0   Back to index