/*=====================================================================*/
/*    serrano/prgm/project/bigloo/runtime/Include/bigloo.h             */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Thu Mar 16 18:48:21 1995                          */
/*    Last change :  Tue Apr 23 11:47:12 2002 (serrano)                */
/*    -------------------------------------------------------------    */
/*    Bigloo's stuff                                                   */
/*=====================================================================*/
#ifndef BIGLOO_H 
#define BIGLOO_H

/*---------------------------------------------------------------------*/
/*    Does someone really wants C++ here?                              */
/*---------------------------------------------------------------------*/
#ifdef __cplusplus
extern "C" {
#endif

/*---------------------------------------------------------------------*/
/*    The essential includes                                           */
/*---------------------------------------------------------------------*/
#include <stdio.h>
#include <setjmp.h>
#include <errno.h>
#include <stdlib.h>
#include <math.h>

#if defined( sony_news )
#   include <news/machparam.h>
#endif
#include <limits.h>
 
/*---------------------------------------------------------------------*/
/*    BIGLOO_MAIN ...                                                  */
/*    -------------------------------------------------------------    */
/*    In order to use a custom C `main' function, defines this         */
/*    macro to another value (e.g. bmain (don't use the _bigloo_main   */
/*    or bigloo_main because they are alread used)). Then in your      */
/*    own `main' function, invoke this one.                            */
/*---------------------------------------------------------------------*/
#if( !defined( BIGLOO_MAIN ) )
#   define BIGLOO_MAIN main
#endif

/*---------------------------------------------------------------------*/
/*    The BGL_HEAP_DEBUG requires the GC backpointers allocation       */
/*---------------------------------------------------------------------*/
#if(defined( BGL_HEAP_DEBUG ) )
       --> error "BGL_HEAP_DEBUG Deprecated. Should not be defined anylonger!"
#endif
   
#if( defined( KEEP_BACK_PTRS ) )
#   define BGL_HEAP_DEBUG_MARK_OBJ( x ) bgl_heap_debug_mark_obj( x )
#   define BGL_HEAP_DEBUG_MARK_STR( x ) bgl_heap_debug_mark_str( (char *)(x) )
#else
#   define BGL_HEAP_DEBUG_MARK_OBJ( x ) x
#   define BGL_HEAP_DEBUG_MARK_STR( x ) x
#endif

/*---------------------------------------------------------------------*/
/*    BDB_LIBRARY_MAGIC_NUMBER                                         */
/*    -------------------------------------------------------------    */
/*    This number is used to ensure the compatibility between the      */
/*    compiler and the blib library.                                   */
/*---------------------------------------------------------------------*/
#define BDB_LIBRARY_MAGIC_NUMBER ((char *)0x1024)
       
/*---------------------------------------------------------------------*/
/*    BIGLOO_EXIT                                                      */
/*---------------------------------------------------------------------*/
#if( !defined( BIGLOO_EXIT ) )
#   define BIGLOO_EXIT bigloo_exit
#endif

/*---------------------------------------------------------------------*/
/*    Global configuration                                             */
/*---------------------------------------------------------------------*/
#include <bigloo_config.h>

/*---------------------------------------------------------------------*/
/*    bfalse                                                           */
/*---------------------------------------------------------------------*/
#undef  BFALSE_AS_CFALSE
#define BFALSE_AS_CFALSE           1
#undef  BFALSE_AS_CFALSE

/*---------------------------------------------------------------------*/
/*    bcopy                                                            */
/*---------------------------------------------------------------------*/
#if( !HAVE_BCOPY )
#   define bcopy( _src_, _dst_, _len_ ) memcpy( _dst_, _src_, _len_ )
#   define bzero( _dest_, _len_ )       memset( _dest_, 0, _len_ )
#endif

/*---------------------------------------------------------------------*/
/*    sigsetmask                                                       */
/*---------------------------------------------------------------------*/
#if( !HAVE_SIGSETMASK )
#   if( HAVE_SIGPROCMASK )
#      define sigsetmask( _int_ )   \
                 sigprocmask( SIG_SETMASK, (const sigset_t *)(_int_), 0L )
#   else
#      define sigsetmask( _int_ )
#   endif
#endif

/*---------------------------------------------------------------------*/
/*    getcwd                                                           */
/*---------------------------------------------------------------------*/
#if( !HAVE_GETCWD )
#   if( HAVE_GETWD )
#      define getcwd( _path_, _int_ ) getwd( _path_ )
#   else
#      define getcwd( _path_, _int_ ) ((char *)getenv( "PWD" ))
#   endif
#endif

/*---------------------------------------------------------------------*/
/*    The Gc                                                           */
/*---------------------------------------------------------------------*/
#define NO_GC            1
#define BOEHM_GC         2

#define BOEHM_GC_VERSION 4

/* the default GC */
#if( !defined( THE_GC ) )
#   define THE_GC BOEHM_GC
#endif

/*---------------------------------------------------------------------*/
/*    Il y a plusieurs formes d'objets:                                */
/*    Les objets allouees:                                             */
/*            +--------+--------+--------+--------+                    */
/*            |....signed fixed point value.....??|                    */
/*            +--------+--------+--------+--------+                    */
/*                                                                     */
/*    Les objets immediats 30 bits:                                    */
/*            +--------+--------+--------+--------+                    */
/*            |....signed fixed point value.....??|                    */
/*            +--------+--------+--------+--------+                    */
/*                                                                     */
/*    Les objets immediats 6 bits:                                     */
/*            +--------+--------+--------+--------+                    */
/*            |..........................|xxxxxx??|                    */
/*            +--------+--------+--------+--------+                    */
/*                                                                     */
/*    Les objets immediats 8 bits:                                     */
/*            +--------+--------+--------+--------+                    */
/*            |.................|xxxxxxxx|......??|                    */
/*            +--------+--------+--------+--------+                    */
/*                                                                     */
/*---------------------------------------------------------------------*/

/*---------------------------------------------------------------------*/
/*    Ou sont les `tags' et quel `mask' cela represente.               */
/*---------------------------------------------------------------------*/
#define TAG_SHIFT        PTR_ALIGNMENT
#define ALIGNMENT_VALUE  (1 << PTR_ALIGNMENT)
#define TAG_MASK         (ALIGNMENT_VALUE - 1)

/*---------------------------------------------------------------------*/
/*    The tagged pointers ...                                          */
/*    -------------------------------------------------------------    */
/*    The flags KEEP_BACK_PTRS is a debugging GC flags that is not     */
/*    compatible with plain compilation mode. In that mode each        */
/*    object keeps informations about who's pointing to it. It is      */
/*    very useful for debugging but it has a strong constraint: we     */
/*    cannot use tagging anymore for typing object. Each object must   */
/*    have an header field holding the objet type.                     */
/*---------------------------------------------------------------------*/
#if( THE_GC == BOEHM_GC ) 
#   define TAG_STRUCT    0     /*  Pointers tagging         ....00     */
#   define TAG_INT       1     /*  Integers tagging         ....01     */
#   define TAG_CNST      2     /*  Constants tagging        ....10     */
#   if( !defined( KEEP_BACK_PTRS ) )
#      define TAG_PAIR   3     /*  Pairs tagging            ....11     */
#   endif
#else
#   if( THE_GC == NO_GC )
#      define TAG_STRUCT 0     /*  Pointers tagging         ....00     */
#      define TAG_INT    1     /*  Integers tagging         ....01     */
#      define TAG_CNST   2     /*  Constants tagging        ....10     */
#   if( !defined( KEEP_BACK_PTRS ) )
#         define TAG_PAIR   3  /*  Pairs tagging            ....11     */
#   endif
#   else
       --> error "Unknown garbage collector type"
#   endif
#endif

/*---------------------------------------------------------------------*/
/*    !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!!  */
/*    -------------------------------------------------------------    */
/*    Il faut faire tres attention quand on rajoute des tags pour des  */
/*    machines particulieres. En particulier, il faut s'assurer que    */
/*    les fonctions `string->obj' et `obj->string' restent correctes.  */
/*    Ces deux fonctions utilisent la representation des objets.       */
/*    Voir les macros d'internement dans ce fichier                    */
/*    (STRING_MARK_OFFSET, ...)                                        */
/*---------------------------------------------------------------------*/

/*---------------------------------------------------------------------*/
/*    64 bits architectures use 3 bits for tagging. We are thus able   */
/*    to add optimized configurations for those machines:              */
/*    -------------------------------------------------------------    */
/*    +--------+--------+--------+- ... -+--------+--------+--------+  */
/*    |..................signed fixed point value............... ???|  */
/*    +--------+--------+--------+- ... -+--------+--------+--------+  */
/*                                                                     */
/*    Les vecteurs:                                                    */
/*    +--------+--------+--------+- ... -+--------+--------+--------+  */
/*    |.................unsigned fixed point value.............. ???|  */
/*    +--------+--------+--------+- ... -+--------+--------+--------+  */
/*                                                                     */
/*---------------------------------------------------------------------*/

/*---------------------------------------------------------------------*/
/*    Les `tags' sur 3 bits.                                           */
/*---------------------------------------------------------------------*/
#if( (PTR_ALIGNMENT >= 3) && !(defined( KEEP_BACK_PTRS )) )
#   define TAG_VECTOR    4     /*  Vectors tagging          ...100     */
#   define TAG_CELL      5     /*  Cells tagging            ...101     */
#   define TAG_REAL      6     /*  Reals tagging            ...110     */
#   define TAG_STRING    7     /*  Strings tagging          ...111     */
#endif

/*---------------------------------------------------------------------*/
/*    Hash table sizes                                                 */
/*---------------------------------------------------------------------*/
#define SYMBOL_HASH_TABLE_SIZE_SHIFT  12
#define SYMBOL_HASH_TABLE_SIZE        (1 << SYMBOL_HASH_TABLE_SIZE_SHIFT)

#define KEYWORD_HASH_TABLE_SIZE_SHIFT 6
#define KEYWORD_HASH_TABLE_SIZE       (1 << KEYWORD_HASH_TABLE_SIZE_SHIFT)

/*---------------------------------------------------------------------*/
/*    Internal Bigloo's types.                                         */
/*---------------------------------------------------------------------*/
typedef long           int_t;
typedef int_t          header_t;
typedef int            bool_t;
typedef unsigned short ucs2_t;

typedef union scmobj {
   int_t              integer;   /*  Les entiers                       */
   
   header_t           header;    /*  Un champs un peu fictif mais      */
                                 /*  il est utile pour pouvoir acceder */
                                 /*  au header des objets sans savoir  */
                                 /*  quel est leur type. Tous les      */
                                 /*  headers sont en tete des struct   */
                                 /*  on peut donc le header global     */
                                 /*  plutot que les header locaux      */
   
   struct pair {                 /*  Les pairs.                        */
#if( !(defined( TAG_PAIR )) )
      header_t        header;    /*  Le header est facultatif, il      */
#endif      
      union scmobj   *car;       /*  depend du GC qu'on utilise.       */
      union scmobj   *cdr;       /*  Dans tous les cas, il y a biensur */
   } pair_t;                     /*  un `car' et un `cdr' :-)          */

   struct extended_pair {        /*  Les pairs etendues.               */
#if( !(defined( TAG_PAIR )) )
      header_t        header;    /*  Le header est facultatif, il      */
#endif                           /*  depend de l'utilisation des bits  */
      union scmobj   *car;       
      union scmobj   *cdr;
      union scmobj   *eheader;   /*  header pour la marque `extended'  */
      union scmobj   *cer;       /*  le slot supplementaire.           */
   } extended_pair_t;                     

   struct string {               /*  Les chaines de char, juste une    */
#if( !defined( TAG_STRING ) )
      header_t        header;    /*  longueur, la chaine C suit.       */
#endif		
      int             length;
      unsigned char   char0;
   } string_t;

   struct ucs2_string {          /*  Ucs2 strings:                     */
      header_t        header;    /*     - a header                     */
      int             length;    /*     - a length                     */
      ucs2_t          char0;     /*     - the first UCS-2 character    */
   } ucs2_string_t;

   struct vector {               /*  Les vecteurs, un header et une    */
#if( !defined( TAG_VECTOR ) )
      header_t        header;
#endif		
      int             length;    /*  taille (ATTENTION: sur 24 bits,   */
      union scmobj   *obj0;      /*  voir la macro vector-length).     */ 
   } vector_t;             

   struct tvector {              /*  typed vectors                     */
      header_t        header;    /*   - the header of tvector          */
      int             length;    /*   - a length                       */
      union scmobj   *descr;     /*   - a type descriptor (static)     */
   } tvector_t;
	
   struct procedure {            /*  Les fermetures                    */
      header_t        header;    
      union scmobj *(*entry)();
      union scmobj *(*va_entry)();
      int             arity;
      union scmobj   *obj0;
   } procedure_t;

   struct procedure_light {      /*  Les fermetures legeres            */
      union scmobj *(*entry)();
      union scmobj  *obj0;
#if( defined( __alpha ) )
      char dummy_to_prevent_bug_in_semantique_when_heap_size_is_4_megabyte;
#endif      
   } procedure_light_t;

   struct symbol {               /*  Symboles & keywords:              */
      header_t        header;    /*  - a type identifier               */
      union scmobj   *string;    /*  - the name of the symbol/keyword  */
      union scmobj   *cval;      /*  - a plist                         */
   } symbol_t;

   struct output_port {          /*  output_port                       */
      header_t        header;    /*  Just a pointer to the file,       */
      FILE           *file;      /*  the file_name, and a kind of file */
      char           *name;      /*  (e.g. file or pipe).              */
      union scmobj   *kindof;    
   } output_port_t;

   struct output_string_port {   /*  Les output_string_port            */
      header_t        header;    /*  Cette structure comporte:         */
      char           *buffer;    /*  - un buffer                       */
      long            size;      /*  - une taille                      */
      long            offset;    /*  - un offset                       */
   } output_string_port_t;
	
   struct input_port {           /*  an input_port :                   */
      header_t        header;    /*                                    */
      union scmobj   *kindof;    /*    - (console, file, pipe)         */
      char           *name;      /*    - the name of file              */
      FILE           *file;      /*    - the underlying C file         */
      long            filepos;   /*    - the position in the file      */
      int           (*sysread)();/*    - the system reader             */
      int           (*syseof)(); /*    - the system eof function       */
      long            bufsiz;    /*    - the size of the buffer        */
      bool_t          eof;       /*    - have we seen an end-of-file   */
      long            matchstart;/*    - the start of a match position */
      long            matchstop; /*    - the end of the match          */
      long            forward;   /*    - the position of READ-CHAR     */
      long            abufsiz;   /*    - the actual size of the buffer */
      unsigned char  *buffer;    /*    - the port buffer               */
      int             lastchar;  /*    - the last char before a fill   */
   } input_port_t;
      
   struct binary_port {          /*  Les binary_port                   */
      header_t        header;    /*  ces ports sont constitues de:     */
      char           *name;      /*    - un nom de fichier             */
      FILE           *file;      /*    - un pointeur sur un fichier    */
      bool_t            io;      /*    - 0 en entree 1 en sortie       */
   } binary_port_t;
	
#if( !defined( TAG_CELL ) )
   struct cell {                 /*  Les cellules. Ces objets sont     */
      header_t        header;    /*  utilisees quand il y a des var    */
      union scmobj   *val;        
   } cell_t;
#endif		

   struct structure {            /*  Les structures,                   */
#if( !defined( TAG_STRUCTURE ) )
      header_t        header;    /*  sont constituees de :             */
#endif		
      union scmobj   *key;       /*                      - une cle     */
      int             length;    /*                      - une long.   */
      union scmobj   *obj0;
   } struct_t;

   struct real {                 /*  Les nombres flottants             */
#if( !defined( TAG_REAL ) )
      header_t        header;    /*  ce champs est juste utile pour    */
#endif		
      double          real;      
   } real_t;                     

   struct stack {                /*  Les piles de `call/cc'            */
      header_t        header;    /*  sont:                             */
      union scmobj   *self;      /*        - un ptr sur soit meme      */
      union scmobj   *exitd_top; /*        - un ptr sur les exits      */
      union scmobj   *stamp;     /*        - an exitd stamp            */
      long            size;      /*        - une taille                */
      struct befored *before_top;/*        - un ptr sur les befores    */
      char           *stack_top; /*        - the top of the stack      */
      char           *stack_bot; /*        - the bottom of the stack   */
      struct dframe  *top_frame; /*        - the head of the traces    */
      void           *stack;     /*        - un espace memoire         */
   } stack_t;

   struct foreign {              /*  Les types etrangers               */
      header_t        header;    
      union scmobj   *id;
      void           *cobj;
   } foreign_t;

   struct elong {                /*  The `exact long' (or full long)   */
      header_t        header;
      long            elong;
   } elong_t;

   struct llong {                /* the long long Bigloo objects       */
      header_t        header;
#if( HAVE_LONGLONG )      
      long long       llong;
#else
      long            llong;
#endif      
   } llong_t;

   struct process {              /* First class processes:             */
      header_t      header;      /*   - a header for type checking     */
      int           pid;         /*   - the process id                 */
      int           index;       /*   - process index (see proc_table) */
      union scmobj *stream[ 3 ]; /*   - out, in and err streams        */
      int           exited;      /*   - process is completed           */
      int           exit_status; /*   - the exit status of the process */
   } process_t;

   struct socket {               /* First class sockets:               */
      header_t      header;      /*   - a header for type checking     */
      int           portnum;     /*   - a port number                  */
      union scmobj *hostname;    /*   - a host name                    */
      union scmobj *hostip;      /*   - a host ip                      */
      int           fd;          /*   - a file descriptor              */
      union scmobj *input;       /*   - a scheme input port or #unspec */
      union scmobj *output;      /*   - a scheme output port or #unspec*/
      int           stype;       /*   - socket type (client/server)    */
   } socket_t;

   struct custom {               /* Custom objects                     */
      header_t      header;      /*   - a header for type checking     */
      char         *identifier;  /*   - a identifier                   */
      int           (*final)();  /*   - a finalization function        */
      int           (*equal)();  /*   - an equality function           */
      long          (*hash)();   /*   - a hash function                */
      char         *(*to_string)();/* - an string converster           */
      union scmobj *(*output)(); /*   - an output function             */
   } custom_t;
} *obj_t;

typedef obj_t (*function_t)();

/* old name mangling framework */
typedef struct __object_bgl {
   header_t header;
   obj_t widening;
} *object_bglt;

/* bootstrap configuration */   
typedef struct __bgl__object_00_bgl {
   header_t header;
   obj_t widening;
} *bgl__object_00_bglt;
   
/* new name mangling framework */   
typedef struct BgL__object_00_bgl {
   header_t header;
   obj_t widening;
} *BgL__object_00_bglt;
typedef struct BgL_objectz00_bgl {
   header_t header;
   obj_t widening;
} *BgL_objectz00_bglt;

/*---------------------------------------------------------------------*/
/*    Type identifiers ...                                             */
/*---------------------------------------------------------------------*/
#define PAIR_TYPE                  0
#define STRING_TYPE                1
#define VECTOR_TYPE                2
#define PROCEDURE_TYPE             3
#define UCS2_STRING_TYPE           4
#define OPAQUE_TYPE                5
#define CUSTOM_TYPE                6
#define KEYWORD_TYPE               7
#define SYMBOL_TYPE                8
#define STACK_TYPE                 9
#define INPUT_PORT_TYPE            10
#define OUTPUT_PORT_TYPE           11
/* #define RGRAMMAR_TYPE              12                               */
#define CELL_TYPE                  13
#define SOCKET_TYPE                14
#define STRUCT_TYPE                15
#define REAL_TYPE                  16
#define PROCESS_TYPE               17
#define FOREIGN_TYPE               18
#define OUTPUT_STRING_PORT_TYPE    19
#define BINARY_PORT_TYPE           20
#define EXTENDED_PAIR_TYPE         21
#define TVECTOR_TYPE               22
#define TSTRUCT_TYPE               23
#define PROCEDURE_LIGHT_TYPE       24
#define ELONG_TYPE                 25
#define LLONG_TYPE                 26
/* OBJECT must be the last defined type because new classes   */
/* will be allocated TYPE number starting at OBJECT_TYPE + 1. */
#define OBJECT_TYPE                27 

/*---------------------------------------------------------------------*/
/*    Les procedures d'allocations                                     */
/*---------------------------------------------------------------------*/
#if( THE_GC == DELACOUR_GC )
#   define GC_MALLOC( size )
#   define GC_MALLOC_ATOMIC( size )
#   define INIT_ALLOCATION() 1
#   define FREE_ALLOCATION() 1
#else
#   if( THE_GC == BOEHM_GC )
#      if( !defined( GC_PRIVATE_H ) )
          extern obj_t GC_malloc();
          extern obj_t GC_malloc_atomic();
          extern obj_t GC_debug_malloc();
          extern obj_t GC_debug_malloc_atomic();
          extern int GC_gc_no;
          extern int GC_size();
          extern void GC_init();
          extern void GC_expand_hp( long );
          extern void GC_register_displacement( int );
          extern obj_t GC_debug_malloc();
          extern obj_t GC_debug_malloc_atomic();
          extern void GC_debug_register_displacement( int );
#      if( defined( PROFILE ) )
          extern void GC_profile_start();
#      endif
#      endif
#      undef GC_MALLOC
#      undef GC_MALLOC_ATOMIC
#      if( defined( KEEP_BACK_PTRS ) )
/* The casts from obj_t to char * in this two macros are not dangerous. */
/* The debug malloc machinery does not rely on that the symbol pointed  */
/* to by top_of_frame are held by the allocated object. Because these   */
/* are symbols, they won't be collected because they are pointed to by  */
/* the symbol table.                                                    */   
#         define GC_MALLOC( size )                                        \
             (obj_t)GC_debug_malloc( size,                                \
                                     (char *)top_of_frame->symbol,        \
                                     (GC_gc_no<<16) )
#         define GC_MALLOC_ATOMIC( size )                                 \
             (obj_t)GC_debug_malloc_atomic( size,                         \
                                            (char *)top_of_frame->symbol, \
                                            (GC_gc_no<<16) )
#      else
#         if( defined( BIGLOO_GC_MALLOC_PROFILE ) )
            extern void GC_profile_alloc( size_t, char *, int );
            extern void *GC_profile_malloc( size_t, char *, int );
            extern void *GC_profile_malloc_atomic( size_t, char *, int );
#           define GC_MALLOC( size ) \
                 ((obj_t)GC_profile_malloc( size, __FILE__, __LINE__ ))
#           define GC_MALLOC_ATOMIC( size ) \
                 ((obj_t)GC_profile_malloc_atomic( size, __FILE__, __LINE__ ))
#         else
#           define GC_MALLOC( size ) (obj_t)GC_malloc( size )
#           define GC_MALLOC_ATOMIC( size ) (obj_t)GC_malloc_atomic( size )
#         endif
#      endif
#      define GC_COLLECT() GC_gcollect()

/*  A supprimer des que Boehm aura corrige GC_register_displacement */
/*  dans son GC.                                                    */
#      if( !defined( GC_REGISTER_DISPLACEMENT ) )
#         if( defined( GC_DEBUG ) || defined( KEEP_BACK_PTRS ) )
#            define GC_REGISTER_DISPLACEMENT( o ) GC_debug_register_displacement( o )
#         else
#            define GC_REGISTER_DISPLACEMENT( o ) GC_register_displacement( o )
#         endif
#      endif

#      if( defined( TAG_STRUCT ) && ( TAG_STRUCT != 0) )
#         define STRUCT_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_STRUCT ) 
#      else
#         define STRUCT_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_PAIR ) && ( TAG_PAIR != 0) )
#         define PAIR_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_PAIR ) 
#      else
#         define PAIR_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_VECTOR ) && ( TAG_VECTOR != 0) )
#         define VECTOR_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_VECTOR ) 
#      else
#         define VECTOR_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_CELL ) && ( TAG_CELL != 0) )
#         define CELL_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_CELL ) 
#      else
#         define CELL_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_STRUCTURE ) && ( TAG_STRUCTURE != 0) )
#         define STRUCTURE_DISPLACEMENT() \
             GC_REGISTER_DISPLACEMENT( TAG_STRUCTURE ) 
#      else
#         define STRUCTURE_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_STRING ) && ( TAG_STRING != 0) )
#         define STRING_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_STRING ) 
#      else
#         define STRING_DISPLACEMENT() 0
#      endif
#      if( defined( TAG_REAL ) && ( TAG_REAL != 0) )
#         define REAL_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_REAL ) 
#      else
#         define REAL_DISPLACEMENT() 0
#      endif

#      define INIT_ALLOCATION( size )                               \
          ( GC_init(),                                              \
            GC_expand_hp( size ),                                   \
   	    STRUCT_DISPLACEMENT(),                                  \
      	    PAIR_DISPLACEMENT(),                                    \
      	    VECTOR_DISPLACEMENT(),                                  \
   	    CELL_DISPLACEMENT(),                                    \
   	    STRUCTURE_DISPLACEMENT(),                               \
   	    STRING_DISPLACEMENT(),                                  \
   	    REAL_DISPLACEMENT(),                                    \
            1 )

#      define FREE_ALLOCATION();
#   else
#      if( THE_GC == NO_GC )
          extern obj_t heap_alloc();
#         define GC_MALLOC( size ) heap_alloc( size )
#         define GC_MALLOC_ATOMIC( size ) GC_MALLOC( size )
#         define INIT_ALLOCATION( size ) init_heap( size )
#         define FREE_ALLOCATION() free_heap()
#         define GC_COLLECT() 
#      else
          --> error "Unknown garbage collector type"
#      endif                
#  endif          
#endif

/*---------------------------------------------------------------------*/
/*    The allocations.                                                 */
/*---------------------------------------------------------------------*/
#if( HAVE_ALLOCA )
#   if( !defined( alloca ) )
extern obj_t alloca();
#   endif
#else
#   define alloca( sz ) GC_MALLOC( sz )
#endif

#if( !defined( __GNUC__ ) || (THE_GC != BOEHM_GC) )
      extern obj_t an_object;
#   define AN_OBJECT obj_t an_object;
#else
#   define AN_OBJECT 
#endif

/*---------------------------------------------------------------------*/
/*    equivalences                                                     */
/*---------------------------------------------------------------------*/
#define EQP( o1, o2 ) ((long)o1 == (long)o2)

#define BOOLEANP( o ) (((long)o == (long)BTRUE) || ((long)o == (long)BFALSE))

#define NOT( o ) (!o)   

/*---------------------------------------------------------------------*/
/*    Les macros qui servent a taguer/detaguer                         */
/*---------------------------------------------------------------------*/
#define TAG( val, shift, tag )   ((long)(((long)(val) << shift) | tag))
#define UNTAG( val, shift, tag ) ((long)((long)(val) >> shift))

#define OBJ_SIZE                 ((long)(sizeof( obj_t )))
#define TYPE( o )                HEADER_TYPE( (CREF( o )->header) )

#if( TAG_STRUCT != 0 )
#   define POINTERP( o )         ((((long)o) & TAG_MASK) == TAG_STRUCT)
#else
#   define POINTERP( o )         (((((long)o) & TAG_MASK) == TAG_STRUCT) && o)
#endif

#if( TAG_CNST != 0 )
#   define CNSTP( o )            ((((long)o) & TAG_MASK) == TAG_CNST)
#else
#   define CNSTP( o )            ((o) && ((((long)o) & TAG_MASK) == TAG_CNST))
#endif

/*---------------------------------------------------------------------*/
/*    Header managment                                                 */
/*---------------------------------------------------------------------*/
#define MAKE_HEADER( i, sz )     ((header_t)TAG( i, TYPE_SHIFT, 0 ))

#define HEADER_NB_BIT            3 /* The number of reserved bit per   */
                                   /* header. This currenct 3 value is */
                                   /* meaningless. None of this three  */
                                   /* bit (values 1, 2 and 4) is used  */
                                   /* but header manager suppose they  */
                                   /* are.                             */

#define SIZE_BIT_SIZE            4
#define SIZE_MASK                ((1 << SIZE_BIT_SIZE) - 1)

#define TYPE_SHIFT               (HEADER_NB_BIT + SIZE_BIT_SIZE + 1)
#define HEADER_TYPE( i )         (long)UNTAG( i, TYPE_SHIFT, 0 )

#define HEADER_SIZE( h )         ((h >> HEADER_NB_BIT) & SIZE_MASK)

/*---------------------------------------------------------------------*/
/*    Les macros de conversions utilisees par `Sqic'                   */
/*    -------------------------------------------------------------    */
/*    Attention, il est normal que pour faire la conversion `bigloo->c'*/
/*    j'utilise une soustraction et non pas un `and'. En faisant comme */
/*    ca, le compilateur C peut bien optimiser les access aux          */
/*    differents champs.                                               */
/*---------------------------------------------------------------------*/
#define BINT( i )          (obj_t)TAG( i, TAG_SHIFT, TAG_INT )
#define CINT( i )          (long)UNTAG( i, TAG_SHIFT, TAG_INT )

#if( TAG_STRUCT == 0 )
#   define BREF( r )       ((obj_t)(r))
#   define CREF( r )       ((obj_t)(r))
#else
#   define BREF( r )       ((obj_t)((long)r + TAG_STRUCT))
#   define CREF( r )       ((obj_t)((long)r - TAG_STRUCT))
#endif

#define BLIGHT( l )        BPAIR( l )
#define CLIGHT( l )        CPAIR( l )

#if( defined( TAG_PAIR ) )
#   define BPAIR( p )      ((obj_t)((long)p | TAG_PAIR))
#   define CPAIR( p )      ((obj_t)((long)p - TAG_PAIR))
#else
#   define BPAIR( p )      BREF( p )
#   define CPAIR( p )      CREF( p )
#endif

#if( defined( TAG_CELL ) )
#   define BCELL( p )      ((obj_t)((long)p | TAG_CELL))
#   define CCELL( p )      ((obj_t)((long)p - TAG_CELL))
#else
#   define BCELL( p )      BREF( p )
#   define CCELL( p )      CREF( p )
#endif

#if( defined( TAG_VECTOR ) )
#   define BVECTOR( p )    ((obj_t)((long)p | TAG_VECTOR))
#   define CVECTOR( p )    ((obj_t)((long)p - TAG_VECTOR))
#else
#   define BVECTOR( p )    BREF( p )
#   define CVECTOR( p )    CREF( p )
#endif

#if( defined( TAG_STRUCTURE ) )
#   define BSTRUCTURE( r ) ((obj_t)((long)p | TAG_STRUCTURE))
#   define CSTRUCTURE( p ) ((obj_t)((long)p - TAG_STRUCTURE))
#else
#   define BSTRUCTURE( p ) BREF( p )
#   define CSTRUCTURE( p ) CREF( p )
#endif

/*---------------------------------------------------------------------*/
/*    !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!!  */
/*    -------------------------------------------------------------    */
/*    We can't use for the two macro `TAG_STRING' and `TAG_REAL'       */
/*    a C or `|` but an addition. Otherwise, gcc, produces the         */
/*    error: `initializer element is not computable at load time'.     */
/*    If someone could explain to me what does it means...             */
/*---------------------------------------------------------------------*/
#if( defined( TAG_STRING ) )
#   define BSTRING( p )    ((obj_t)((long)p + TAG_STRING))
#   define CSTRING( p )    ((obj_t)((long)p - TAG_STRING))
#else
#   define BSTRING( p )    BREF( p )
#   define CSTRING( p )    CREF( p )
#endif

#define BUCS2STRING( p )   BREF( p )
#define CUCS2STRING( p )   CREF( p )

#if( defined( TAG_REAL ) )
#   define BREAL( p )      ((obj_t)((long)p + TAG_REAL))
#   define CREAL( p )      ((obj_t)((long)p - TAG_REAL))
#else
#   define BREAL( p )      BREF( p )
#   define CREAL( p )      CREF( p )
#endif

#define BFUN( f )          ((obj_t)(f))
#define CFUN( f )          ((obj_t (*)())(f))

#define BCNST( c )         (obj_t)TAG( c, TAG_SHIFT, TAG_CNST )
#define CCNST( c )         (long)UNTAG( c, TAG_SHIFT, TAG_CNST )

#define BCONT( c )         ((obj_t)(c))
#define CCONT( c )         (c)

#define TRUEP( c )         ((bool_t)(c != BFALSE))

#define CHAR_SHIFT         (TAG_SHIFT + 6)
#define UCS2_SHIFT         CHAR_SHIFT

#define BCHAR( i )         ((obj_t)((long)BCHARH + \
				  ((long)((unsigned char)(i) << CHAR_SHIFT))))
#define CCHAR( i )         ((unsigned char)((unsigned long)(i)>>CHAR_SHIFT))

#define BBOOL( i )         (i ? BTRUE : BFALSE)
#if( defined( BFALSE_AS_CFALSE ) )
#   define CBOOL( o )      ((bool_t)((long)o))
#else
#   define CBOOL( o )      (o != BFALSE)
#endif

/*---------------------------------------------------------------------*/
/*    Constants                                                        */
/*---------------------------------------------------------------------*/
#define BNIL          ((obj_t)BCNST( 0 ))
#if( defined( BFALSE_AS_CFALSE ) )
#   define BFALSE     ((obj_t)0)
#else
#   define BFALSE     ((obj_t)BCNST( 1 ))
#endif
#define BTRUE         ((obj_t)BCNST( 2 ))
#define BUNSPEC       ((obj_t)BCNST( 3 ))
#define BUCS2H        ((obj_t)BCNST( 4 ))
#define BCHARH        ((obj_t)BCNST( 5 ))
#define BEOF          ((obj_t)BCNST( 0x100 ))
#define BEOA          ((obj_t)BCNST( 0x101 ))
/* any change to these values must be reported in comptime/dsssl.scm */
#define BOPTIONAL     ((obj_t)BCNST( 0x102 ))
#define BREST         ((obj_t)BCNST( 0x103 ))
#define BKEY          ((obj_t)BCNST( 0x106 ))

/*---------------------------------------------------------------------*/
/*    Array bound checking                                             */
/*---------------------------------------------------------------------*/
#if( TAG_SHIFT <= LONG_MAX )
#   define BOUND_CHECK( o, v ) ((unsigned long)o < (unsigned long)v)
#else
#   define BOUND_CHECK( o, v ) (((long)o >= 0) && ((long)o < (long)v))
#endif

/*---------------------------------------------------------------------*/
/*    Le tableau des constantes (pour l'initialisation des modules).   */
/*    -------------------------------------------------------------    */
/*    Ces deux macros servent a l'initialisation des constantes. C'est */
/*    un peu astucieux la facon dont c'est fait. Il faut regarder le   */
/*    fichier `comptime/Cnst/read-alloc.scm' pour comprendre comment   */
/*    ca marche.                                                       */
/*---------------------------------------------------------------------*/
#define CNST_TABLE_SET( offset, value )             \
   ( __cnst[ offset ] = value,                      \
     BUNSPEC )

#define CNST_TABLE_REF( offset ) __cnst[ offset ]

/*---------------------------------------------------------------------*/
/*    constant alignment                                               */
/*---------------------------------------------------------------------*/
#if( defined( CONSTANT_ALIGNED ) && !CONSTANT_ALIGNED )
#   if( defined( __GNUC__ ) )
       /* this require gcc at least version 2.7.2 */
#      define __CNST_ALIGN __attribute__ ((aligned (ALIGNMENT_VALUE)))
#   else
       --> error "Enable to enforce alignment"
#   endif
#else
#   define __CNST_ALIGN
#endif

/*---------------------------------------------------------------------*/
/*    Static allocations.                                              */
/*---------------------------------------------------------------------*/
#if( !defined( TAG_STRING ) )
#   define DEFINE_STRING( name, aux, str, len )               \
      static struct { header_t header;                        \
                      int      length;                        \
                      char     string[len+1]; } __CNST_ALIGN  \
         aux = { MAKE_HEADER( STRING_TYPE, 0 ), len, str };   \
         static obj_t name = BSTRING( &aux )
#else
#   define DEFINE_STRING( name, aux, str, len )               \
      static struct { int      length;                        \
                      char     string[len+1]; } __CNST_ALIGN  \
         aux = { len, str };                                  \
         static obj_t name = BSTRING( &aux )
#endif

#if( !defined( TAG_REAL ) )
#   define DEFINE_REAL( name, aux, flonum )                   \
      static struct { header_t header;                        \
		      double   real; } __CNST_ALIGN           \
         aux = { MAKE_HEADER( REAL_TYPE, 0 ), flonum };       \
         obj_t name = BREAL( &aux )
#else
#   define DEFINE_REAL( name, aux, flonum )                   \
      static struct { double   real; } __CNST_ALIGN           \
         aux = { flonum };                                    \
         obj_t name = BREAL( &aux )
#endif

#define DEFINE_EXPORT_PROCEDURE( n, na, p, vp, nb_args )      \
   static struct { header_t header;                           \
                   obj_t    (*entry)();                       \
                   obj_t    (*va_entry)();                    \
                   int      arity; } __CNST_ALIGN             \
      na = { MAKE_HEADER( PROCEDURE_TYPE, 0 ),                \
	     (obj_t (*)())p,                                  \
	     (obj_t (*)())vp,                                 \
	     nb_args };                                       \
      obj_t n = BREF( &na )

#define DEFINE_STATIC_PROCEDURE( n, na, p, vp, nb_args )      \
   static struct { header_t header;                           \
                   obj_t    (*entry)();                       \
                   obj_t    (*va_entry)();                    \
                   int      arity; } __CNST_ALIGN             \
      na = { MAKE_HEADER( PROCEDURE_TYPE, 0 ),                \
             (obj_t (*)())p,                                  \
	     (obj_t (*)())vp,                                 \
	     nb_args };                                       \
      static obj_t n = BREF( &na )

#define DEFINE_EXPORT_GENERIC( n, na, p, vp, nb_args )        \
   static struct { header_t header;                           \
                   obj_t    (*entry)();                       \
                   obj_t    (*va_entry)();                    \
                   int      arity;                            \
		   obj_t    env0;                             \
		   obj_t    env1;                             \
		   obj_t    env2; } __CNST_ALIGN              \
      na = { MAKE_HEADER( PROCEDURE_TYPE, 0 ),                \
	     (obj_t (*)())p,                                  \
	     (obj_t (*)())vp,                                 \
	     nb_args,                                         \
	     BFALSE,                                          \
	     BFALSE,                                          \
	     BUNSPEC};                                        \
      obj_t n = BREF( &na )

#define DEFINE_STATIC_GENERIC( n, na, p, vp, nb_args )        \
   static struct { header_t header;                           \
                   obj_t    (*entry)();                       \
                   obj_t    (*va_entry)();                    \
                   int      arity;                            \
		   obj_t    env0;                             \
		   obj_t    env1;                             \
		   obj_t    env2; } __CNST_ALIGN              \
      na = { MAKE_HEADER( PROCEDURE_TYPE, 0 ),                \
             (obj_t (*)())p,                                  \
	     (obj_t (*)())vp,                                 \
	     nb_args,                                         \
	     BFALSE,                                          \
	     BFALSE,                                          \
	     BUNSPEC};                                        \
      static obj_t n = BREF( &na )

#define DEFINE_TVECTOR_START( aux, len, itype )               \
   static struct { header_t header;                           \
		   int      length;                           \
		   obj_t    descr;                            \
		   itype    items[ len ]; } __CNST_ALIGN      \
      aux = { MAKE_HEADER( TVECTOR_TYPE, 0 ), len, 0L,
	      
#define DEFINE_TVECTOR_STOP( name, aux )   	              \
	   }; static obj_t name = BREF( &aux )

/*---------------------------------------------------------------------*/
/*    Stack allocations                                                */
/*---------------------------------------------------------------------*/
#if( defined( __GNUC__ ) )
#   define ALLOCATE_TVECTOR_MALLOC( MALLOC, _item_type, _len, _descr ) \
      ( { obj_t an_object;                                             \
	  an_object = MALLOC(sizeof(struct { header_t        header;   \
		                             int             length;   \
		                             obj_t           descr;    \
		                             _item_type      el0; })   \
			      +                                        \
			      ((_len-1) * sizeof(_item_type)));        \
	  (an_object->tvector_t).header   =                            \
	                               MAKE_HEADER( TVECTOR_TYPE, 0 ); \
	  (an_object->tvector_t).length   = _len;                      \
	  (an_object->tvector_t).descr    = _descr;                    \
          BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ); } )
#else
#   define ALLOCATE_TVECTOR_MALLOC( MALLOC, _item_type, _len, _descr ) \
      (   an_object = MALLOC(sizeof(struct { header_t        header;   \
		                             int             length;   \
		                             obj_t           descr;    \
		                             _item_type      el0; })   \
			      +                                        \
			      ((_len-1) * sizeof(_item_type))),        \
	  (an_object->tvector_t).header   =                            \
	                               MAKE_HEADER( TVECTOR_TYPE, 0 ), \
	  (an_object->tvector_t).length   = _len,                      \
	  (an_object->tvector_t).descr    = _descr,                    \
          BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ) )
#endif

#define ALLOCATE_TVECTOR( _item_type, _len, _descr )   \
   ALLOCATE_TVECTOR_MALLOC( GC_MALLOC, _item_type, _len, _descr )
#define ALLOCATE_ATOMIC_TVECTOR( _item_type, _len, _descr )   \
   ALLOCATE_TVECTOR_MALLOC( GC_MALLOC_ATOMIC, _item_type, _len, _descr )

/*---------------------------------------------------------------------*/
/*    The debugging strack traces                                      */
/*---------------------------------------------------------------------*/
struct dframe {
   obj_t          symbol;
   struct dframe *link;  
};

#define PUSH_TRACE( name )                         \
   struct dframe  frame;                           \
   struct dframe *link;                            \
                                                   \
   frame.symbol = name;                            \
   frame.link   = top_of_frame;                    \
   link         = top_of_frame;                    \
   top_of_frame = &frame;            

#define POP_TRACE()                                \
   top_of_frame = link;

#define EVAL_PUSH_TRACE( name ) { PUSH_TRACE( name )
#define EVAL_POP_TRACE()          POP_TRACE() }

#define GET_TRACE() BREF( top_of_frame )

/* after a bind-exit, we must reset the current trace */
#define RESTORE_TRACE()                            \
   top_of_frame = &frame;

extern struct dframe frame;
extern struct dframe *top_of_frame;

/*---------------------------------------------------------------------*/
/*    Failures                                                         */
/*---------------------------------------------------------------------*/
#define FAILURE( proc, msg, obj ) bigloo_exit( BINT( bigloo_abort( CINT( the_failure( proc, msg, obj ) ) ) ) )

#define C_FAILURE( proc, msg, obj ) FAILURE( string_to_bstring( proc ), \
					     string_to_bstring( msg ),  \
					     obj )

extern obj_t bigloo_error_handler;
   
#define GET_ERROR_HANDLER() bigloo_error_handler
#define SET_ERROR_HANDLER( _hdl ) (bigloo_error_handler = (_hdl))
   
/*---------------------------------------------------------------------*/
/*    Cells                                                            */
/*---------------------------------------------------------------------*/
#if( !(defined( TAG_CELL ) ) ) 
#   define CELL_SIZE (sizeof( struct cell ))
#endif
#if( !defined( TAG_CELL ) )
#   define CELLP( c ) (POINTERP( c ) && (TYPE( c ) == CELL_TYPE))
#else
#   define CELLP( c ) ((c && ((((long)c)&TAG_MASK) == TAG_CELL)))
#endif


#define CELL( o ) CCELL( o )->cell_t

#if( defined( TAG_CELL ) )
#   if( defined( __GNUC__ ) )
#      define MAKE_CELL( _val_ )                                        \
       ( { obj_t *an_object;                                            \
	   an_object  = (obj_t *)GC_MALLOC( sizeof( obj_t ) );          \
	   *an_object = (_val_);                                        \
	   BGL_HEAP_DEBUG_MARK_OBJ( BCELL( an_object ) ); } )
#   else
#      define MAKE_CELL( _val_ )                                        \
       ( an_object = (obj_t)GC_MALLOC( sizeof( obj_t ) ),               \
	 *((obj_t *)an_object) = (_val_),                               \
	 BGL_HEAP_DEBUG_MARK_OBJ( BCELL( an_object ) ) )
#   endif

#   define CELL_REF( c ) (*(obj_t *)CCELL( c ))
#else
#   if( defined( __GNUC__ ) )
#      define MAKE_CELL( _val_ )                                        \
       ( { obj_t an_object;                                             \
	   an_object = GC_MALLOC( CELL_SIZE );                          \
	   an_object->cell_t.header = MAKE_HEADER( CELL_TYPE, 0 );      \
	   an_object->cell_t.val    = (_val_);                          \
	   BGL_HEAP_DEBUG_MARK_OBJ( BCELL( an_object ) ); } )
#   else
#      define MAKE_CELL( _val_ )                                        \
       ( an_object = GC_MALLOC( CELL_SIZE ),                            \
	 an_object->cell_t.header = MAKE_HEADER( CELL_TYPE, 0 ),        \
         an_object->cell_t.val    = (_val_),                            \
	 BGL_HEAP_DEBUG_MARK_OBJ( BCELL( an_object ) ) )
#   endif

#   define CELL_REF( c ) ((CCELL( c )->cell_t).val)
#endif

#define CELL_SET( c, v ) \
   (CELL_REF( c ) = v, BUNSPEC)

/*---------------------------------------------------------------------*/
/*    Peek & Poke                                                      */
/*---------------------------------------------------------------------*/
#define PEEK( v, i ) ((obj_t *)(CREF( v )))[ i ]
#define POKE( var, i, val ) (PEEK( var, i ) = val, var)

/*---------------------------------------------------------------------*/
/*    Pairs                                                            */
/*---------------------------------------------------------------------*/
#define PAIR_SIZE          (sizeof( struct pair ))
#define EXTENDED_PAIR_SIZE (sizeof( struct extended_pair ))

#define PAIR( o )          (CPAIR( o )->pair_t)
#define EPAIR( o )         (CPAIR( o )->extended_pair_t)

#if( (THE_GC == BOEHM_GC) && TAG_PAIR )
#   define MAKE_PAIR( a, d ) make_pair( a, d )
#else
#   if( defined( TAG_PAIR ) )
#     if( defined( __GNUC__ ) )
#      define MAKE_PAIR( a, d )                                           \
        ({ obj_t an_object;                                               \
           an_object = GC_MALLOC( PAIR_SIZE );                            \
	   an_object->pair_t.car = a;                                     \
	   an_object->pair_t.cdr = d;                                     \
           BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ); })
#     else
#      define MAKE_PAIR( a, d )                                           \
        (an_object = GC_MALLOC( PAIR_SIZE ),                              \
	 an_object->pair_t.car = a,                                       \
	 an_object->pair_t.cdr = d,                                       \
         BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ) )
#     endif
#   else
#     if( defined( __GNUC__ ) )
#      define MAKE_PAIR( a, d )                                           \
        ({ obj_t an_object;                                               \
           an_object = GC_MALLOC( PAIR_SIZE );                            \
   	   an_object->pair_t.header = MAKE_HEADER( PAIR_TYPE, 0 );        \
	   an_object->pair_t.car    = a;                                  \
	   an_object->pair_t.cdr    = d;                                  \
           BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ); }) 
#     else
#      define MAKE_PAIR( a, d )                                           \
        (an_object = GC_MALLOC( PAIR_SIZE ),                              \
	 an_object->pair_t.header = MAKE_HEADER( PAIR_TYPE, 0 ),          \
	 an_object->pair_t.car    = a,                                    \
	 an_object->pair_t.cdr    = d,                                    \
         BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ) )
#     endif
#   endif
#endif

#if( defined( TAG_PAIR ) )
#if( defined( __GNUC__ ) )
#   define MAKE_EXTENDED_PAIR( a, d, e )                                  \
      ( { obj_t an_object;                                                \
	  an_object = GC_MALLOC( EXTENDED_PAIR_SIZE );                    \
	  an_object->extended_pair_t.car     = a;                         \
	  an_object->extended_pair_t.cdr     = d;                         \
	  an_object->extended_pair_t.cer     = e;                         \
	  an_object->extended_pair_t.eheader = BINT( EXTENDED_PAIR_TYPE );\
	  BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ); } )
#else
#   define MAKE_EXTENDED_PAIR( a, d, e )                                  \
      (  an_object = GC_MALLOC( EXTENDED_PAIR_SIZE ),                     \
	 an_object->extended_pair_t.car     = a,                          \
	 an_object->extended_pair_t.cdr     = d,                          \
	 an_object->extended_pair_t.cer     = e,                          \
	 an_object->extended_pair_t.eheader = BINT( EXTENDED_PAIR_TYPE ), \
         BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ) )
#endif
#else
#if( defined( __GNUC__ ) )
#   define MAKE_EXTENDED_PAIR( a, d, e )                                  \
      ( { obj_t an_object;                                                \
	  an_object = GC_MALLOC( EXTENDED_PAIR_SIZE );                    \
	  an_object->extended_pair_t.header  = MAKE_HEADER( PAIR_TYPE,0 );\
	  an_object->extended_pair_t.car     = a;                         \
	  an_object->extended_pair_t.cdr     = d;                         \
	  an_object->extended_pair_t.cer     = e;                         \
	  an_object->extended_pair_t.eheader = BINT( EXTENDED_PAIR_TYPE );\
	  BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ); } )
#else
#   define MAKE_EXTENDED_PAIR( a, d, e )                                  \
      (  an_object = GC_MALLOC( EXTENDED_PAIR_SIZE ),                     \
	 an_object->extended_pair_t.header  = MAKE_HEADER( PAIR_TYPE,0 ), \
	 an_object->extended_pair_t.car     = a,                          \
	 an_object->extended_pair_t.cdr     = d,                          \
	 an_object->extended_pair_t.cer     = e,                          \
	 an_object->extended_pair_t.eheader = BINT( EXTENDED_PAIR_TYPE ), \
         BGL_HEAP_DEBUG_MARK_OBJ( BPAIR( an_object ) ) )
#endif
#endif

#if( !(defined( TAG_PAIR ) ) )
#   define PAIRP( c ) (POINTERP( c ) && (TYPE( c ) == PAIR_TYPE))
#else
#   if( !TAG_PAIR )
#      define PAIRP( c ) ((c && ((((long)c) & TAG_MASK) == TAG_PAIR)))
#else
#      define PAIRP( c ) ((((long)c) & TAG_MASK) == TAG_PAIR)
#   endif
#endif

#if( THE_GC == BOEHM_GC )
#   define EXTENDED_PAIRP( c )                                         \
      ( PAIRP( c ) &&                                                  \
        (((long)GC_size( BPAIR( c ) )) >= EXTENDED_PAIR_SIZE) &&       \
        (EPAIR( c ).eheader == BINT( EXTENDED_PAIR_TYPE ) ) )
#else
#   if( THE_GC == NO_GC )
#      define EXTENDED_PAIRP( c ) (0)
#   else
#      define EXTENDED_PAIRP( c )                                      \
         ( PAIRP( c ) && (EPAIR( c ).eheader == BINT( EXTENDED_PAIR_TYPE ) ) )
#   endif
#endif

#define NULLP( c ) ((long)(c) == (long)BNIL)

#define CAR( c )        (PAIR( c ).car)
#define CDR( c )        (PAIR( c ).cdr)
#define CER( c )        (EPAIR( c ).cer)

#define SET_CAR( c, v ) ((CAR(c) = v), BUNSPEC)
#define SET_CDR( c, v ) ((CDR(c) = v), BUNSPEC)
#define SET_CER( c, v ) ((CER(c) = v), BUNSPEC)

/*---------------------------------------------------------------------*/
/*    Strings                                                          */
/*---------------------------------------------------------------------*/
#if( !(defined( TAG_STRING ) ) )
#   define STRINGP( c ) (POINTERP( c ) && (TYPE( c ) == STRING_TYPE))
#else
#   define STRINGP( c ) ((c && ((((long)c)&TAG_MASK) == TAG_STRING)))
#endif

#define STRING( o )  (CSTRING( o )->string_t)

#define STRING_SIZE (sizeof( struct string ))

#define STRING_LENGTH( s ) STRING( s ).length
#define INVERSE_STRING_LENGTH( s ) \
   ((STRING_LENGTH( s ) = (-STRING_LENGTH( s ))), BUNSPEC)
   
#define MARK_INTEXT_STRING( s ) \
   INVERSE_STRING_LENGTH( s )
#define UNMARK_INTEXT_STRING( s ) \
   INVERSE_STRING_LENGTH( s )
#define INTEXT_STRING_MARKED_P( s ) \
   (STRING_LENGTH( s ) < 0)

#define BSTRING_TO_STRING( s ) ((char *)(&(STRING( s ).char0)))

#define STRING_REF( v, i ) (BSTRING_TO_STRING( v )[ i ])
#define STRING_SET( s, i, c ) (STRING_REF( s, i ) = c, BUNSPEC)
#define STRING_PTR_NULL( _p ) (_p == 0)
   
/*---------------------------------------------------------------------*/
/*    UCS-2 characters                                                 */
/*---------------------------------------------------------------------*/
#define UCS2_ISOLATIN1P( ch ) ((ch) < (ucs2_t)256)

/*---------------------------------------------------------------------*/
/*    UCS-2 strings                                                    */
/*---------------------------------------------------------------------*/
#define UCS2_STRINGP( c ) (POINTERP( c ) && (TYPE( c ) == UCS2_STRING_TYPE))

#define UCS2_STRING( o )  (CUCS2STRING( o )->ucs2_string_t)

#define UCS2_STRING_SIZE (sizeof( struct ucs2_string ))

#define UCS2_STRING_LENGTH( s ) UCS2_STRING( s ).length
#define INVERSE_UCS2_STRING_LENGTH( s ) \
   ((UCS2_STRING_LENGTH( s ) = (-UCS2_STRING_LENGTH( s ))), BUNSPEC)

#define MARK_INTEXT_UCS2_STRING( s ) \
   INVERSE_UCS2_STRING_LENGTH( s )
#define UNMARK_INTEXT_UCS2_STRING( s ) \
   INVERSE_UCS2_STRING_LENGTH( s )
#define INTEXT_UCS2_STRING_MARKED_P( s ) \
   (UCS2_STRING_LENGTH( s ) < 0)

#define BUCS2_STRING_TO_UCS2_STRING( s ) (&(UCS2_STRING( s ).char0))

#define UCS2_STRING_REF( v, i ) (BUCS2_STRING_TO_UCS2_STRING( v )[ i ])
#define UCS2_STRING_SET( s, i, c ) (UCS2_STRING_REF( s, i ) = c, BUNSPEC)

#define INT_TO_UCS2( i ) ((ucs2_t)i)
   
/*---------------------------------------------------------------------*/
/*    Procedures                                                       */
/*---------------------------------------------------------------------*/
#define PROCEDURE_SIZE (sizeof( struct procedure ))

#define PROCEDURE( o ) CREF( o )->procedure_t

#define PROCEDURE_ENTRY( fun ) (obj_t)(PROCEDURE( fun ).entry)
#define PROCEDURE_VA_ENTRY( fun ) (obj_t)(PROCEDURE( fun ).va_entry)

#define PROCEDUREP( fun ) \
   (POINTERP( fun ) && (TYPE( fun ) == PROCEDURE_TYPE))

#define PROCEDURE_ARITY( fun ) (PROCEDURE( fun ).arity)

#define VA_PROCEDUREP( fun ) ( PROCEDURE_ARITY( fun ) < 0 )
   
#define PROCEDURE_CORRECT_ARITYP( fun, num )           \
        ( (PROCEDURE_ARITY( fun ) == num) ||           \
	  (VA_PROCEDUREP( fun ) &&                     \
	   ((-num - 1) <= (PROCEDURE_ARITY( fun )))) )
		  
#define PROCEDURE_ENV( p ) (&(PROCEDURE( p ).obj0))

#define PROCEDURE_REF( p, i )    (PROCEDURE_ENV( p ))[ i ]
#define PROCEDURE_SET( p, i, o ) (PROCEDURE_REF( p, i ) = o, BUNSPEC)

/*---------------------------------------------------------------------*/
/*    Light procedures                                                 */
/*---------------------------------------------------------------------*/
#define PROCEDURE_L_SIZE (sizeof( struct procedure_light ))

#define PROCEDURE_L( _o_ ) (CLIGHT( _o_ )->procedure_light_t)

#define PROCEDURE_L_ENTRY( fun ) (obj_t)(PROCEDURE_L( fun ).entry)

#define PROCEDURE_L_ENV( fun ) (&(PROCEDURE_L( fun ).obj0))

#define PROCEDURE_L_REF( p, _i )    PROCEDURE_L_ENV( p )[ _i ] 
#define PROCEDURE_L_SET( p, _i, o ) (PROCEDURE_L_REF( p, _i ) = o, BUNSPEC)

#if( defined( __GNUC__ ) )
#   define MAKE_L_PROCEDURE_ALLOC( ALLOC, _entry, _size )                    \
      ( { obj_t an_object;                                                   \
	  an_object = ALLOC( PROCEDURE_L_SIZE + ((_size-1) * OBJ_SIZE) );    \
	  (an_object->procedure_light_t).entry = _entry;                     \
          BGL_HEAP_DEBUG_MARK_OBJ( BLIGHT( an_object ) ); } )
#else
#   define MAKE_L_PROCEDURE_ALLOC( ALLOC, _entry, _size )                    \
      (   an_object = ALLOC( PROCEDURE_L_SIZE + ((_size-1) * OBJ_SIZE) ),    \
	  (an_object->procedure_light_t).entry = _entry,                     \
          BGL_HEAP_DEBUG_MARK_OBJ( BLIGHT( an_object ) ) )
#endif

#define MAKE_L_PROCEDURE( _entry, _size )   \
   MAKE_L_PROCEDURE_ALLOC( GC_MALLOC, _entry, _size )

/*---------------------------------------------------------------------*/
/*    Extra-light procedures                                           */
/*---------------------------------------------------------------------*/
#define MAKE_EL_PROCEDURE( size )   GC_MALLOC( size * OBJ_SIZE )

#define PROCEDURE_EL_REF( p, i )    ((obj_t *)p)[ i ]
#define PROCEDURE_EL_SET( p, i, o ) (PROCEDURE_EL_REF( p, i ) = o, BUNSPEC)


#define MAKE_EL_PROCEDURE_1( size )   BUNSPEC

#define PROCEDURE_1_EL_REF( p, i )    p
#define PROCEDURE_1_EL_SET( p, i, o ) (PROCEDURE_1_EL_REF( p, i ) = o, BUNSPEC)

/*---------------------------------------------------------------------*/
/*    Global ports                                                     */
/*---------------------------------------------------------------------*/
extern obj_t (*bgl_get_current_output_port)();
extern obj_t (*bgl_set_current_output_port)( obj_t );
extern obj_t (*bgl_get_current_error_port)();
extern obj_t (*bgl_set_current_error_port)( obj_t );
extern obj_t (*bgl_get_current_input_port)();
extern obj_t (*bgl_set_current_input_port)( obj_t );
   
#define GET_CURRENT_OUTPUT_PORT() bgl_get_current_output_port()
#define SET_CURRENT_OUTPUT_PORT( _p ) (bgl_set_current_output_port(_p))

#define GET_CURRENT_INPUT_PORT() bgl_get_current_input_port()
#define SET_CURRENT_INPUT_PORT( _p ) (bgl_set_current_input_port (_p))

#define GET_CURRENT_ERROR_PORT() bgl_get_current_error_port()
#define SET_CURRENT_ERROR_PORT( _p ) (bgl_set_current_error_port(_p))

/*---------------------------------------------------------------------*/
/*    Output-ports                                                     */
/*---------------------------------------------------------------------*/
#define OUTPUT_PORT_SIZE (sizeof( struct output_port ))

#define OUTPUT_PORT( o ) CREF( o )->output_port_t

#define OUTPUT_PORTP( o )                                  \
   ( POINTERP( o ) && ( (TYPE( o ) == OUTPUT_PORT_TYPE) || \
		        (TYPE( o ) == OUTPUT_STRING_PORT_TYPE) ) )

#define FLUSH_OUTPUT_PORT( o )  \
   ( OUTPUT_STRING_PORTP( o ) ? \
	  strport_flush( o ) : (fflush( OUTPUT_PORT( o ).file ), o) )

#define OUTPUT_PORT_TO_FILE( o ) \
   ( OUTPUT_STRING_PORTP( o ) ? \
	  FAILURE( string_to_bstring( "output-port-to-file" ), \
		   string_to_bstring( "argument can't be a string port"), \
		   o ), \
	  stdout \
	  : OUTPUT_PORT( o ).file )

#define FILE_TO_OUTPUT_PORT( f ) \
   (make_output_port( "<c-port>", f, KINDOF_FILE))

#define BGL_OUTPUT_CHAR( p, c ) \
   (fputc( (c), BINARY_PORT( (p) ).file ), BUNSPEC)

#define BGL_INPUT_CHAR( p ) \
   (fgetc( BINARY_PORT( (p) ).file))

#define BGL_INT_EOFP( i ) \
   ((i) == EOF)
   
/*---------------------------------------------------------------------*/
/*    Les OUTPUT_STRING_PORTs                                          */
/*---------------------------------------------------------------------*/
#define OUTPUT_STRING_PORT_SIZE (sizeof( struct output_string_port ))

#define OUTPUT_STRING_PORT( o ) CREF( o )->output_string_port_t

#define OUTPUT_STRING_PORTP( o ) ( TYPE( o ) == OUTPUT_STRING_PORT_TYPE )

#define OUTPUT_STRING_PORT_BUFFER_SIZE 1024

#define END_OF_STRING_PORTP( o ) \
   ( OUTPUT_STRING_PORT( o ).offset == OUTPUT_STRING_PORT( o ).size )

/*---------------------------------------------------------------------*/
/*    Binary ports                                                     */
/*---------------------------------------------------------------------*/
#define BINARY_PORT_SIZE (sizeof( struct binary_port ))

#define BINARY_PORT( o ) CREF( o )->binary_port_t

#define BINARY_PORTP( o ) \
   ( POINTERP( o ) && (TYPE( o ) == BINARY_PORT_TYPE) )

#define BINARY_PORT_IN   ((bool_t)0)
#define BINARY_PORT_OUT  ((bool_t)1)

#define BINARY_PORT_INP( p ) (BINARY_PORT( o ).io == BINARY_PORT_IN)

#define BINARY_PORT_TO_FILE( p ) (BINARY_PORT( p ).file)

/*---------------------------------------------------------------------*/
/*    RGC ports                                                        */
/*---------------------------------------------------------------------*/
#define KINDOF_FILE     BINT( 0 )
#define KINDOF_CONSOLE  BINT( 1 )
#define KINDOF_STRING   BINT( 2 )
#define KINDOF_PIPE     BINT( 3 )
#define KINDOF_SOCKET   BINT( 4 )
#define KINDOF_CLOSED   BINT( 6 )
#define KINDOF_PROCPIPE BINT( 7 )

#define INPUT_PORT_SIZE (sizeof( struct input_port ))

#define INPUT_PORT( o ) CREF( o )->input_port_t

#define INPUT_PORTP( o ) (POINTERP( o ) && (TYPE( o ) == INPUT_PORT_TYPE))

#define EOF_OBJECTP( o ) ( o == BEOF )

#define INPUT_PORT_NAME( o ) (INPUT_PORT( o ).name)

#define INPUT_PORT_FILEPOS( o ) (INPUT_PORT( o ).filepos)

#define INPUT_PORT_ON_FILEP( o ) (INPUT_PORT( o ).kindof == KINDOF_FILE)

#define INPUT_PORT_ON_STRINGP( o ) (INPUT_PORT( o ).kindof == KINDOF_STRING)

#define INPUT_PORT_BUFSIZ( o ) (INPUT_PORT( o ).bufsiz)

/*---------------------------------------------------------------------*/
/*    RGC macros                                                       */
/*---------------------------------------------------------------------*/
#define RGC_DEBUG 2
#undef RGC_DEBUG

#if defined( RGC_DEBUG )
#   include <assert.h>
#else
#   define assert( exp ) ;
#endif

#define RGC_BUFFER( p )                                                 \
   (INPUT_PORT( p ).buffer)

#if defined( RGC_DEBUG ) && (RGC_DEBUG > 1)
#define RGC_BUFFER_GET_CHAR( i )                                        \
   (printf( "get_char: %d %c\n",                                        \
	    (unsigned int)(RGC_BUFFER( i )[ INPUT_PORT( i ).forward ]), \
	    RGC_BUFFER( i )[ INPUT_PORT( i ).forward ] ),               \
   (unsigned int)(RGC_BUFFER( i )[ INPUT_PORT( i ).forward++ ]))
#else
#define RGC_BUFFER_GET_CHAR( i )                                        \
   ((unsigned int)(RGC_BUFFER( i )[ INPUT_PORT( i ).forward++ ]))
#endif

#define RGC_BUFFER_CHARACTER( i ) \
   ((char)(RGC_BUFFER( i )[ INPUT_PORT( i ).matchstart ]))
   
#define RGC_START_MATCH( p ) \
   (INPUT_PORT( p ).forward = \
     INPUT_PORT( p ).matchstart = \
      INPUT_PORT( p ).matchstop)

#define RGC_SET_FILEPOS( p ) \
   (INPUT_PORT( p ).filepos += RGC_BUFFER_LENGTH( p ))
   
#define RGC_STOP_MATCH( p ) \
   (INPUT_PORT( p ).matchstop = INPUT_PORT( p ).forward)


#if defined( RGC_DEBUG )
#define RGC_BUFFER_EMPTY( p )                                           \
   (assert( INPUT_PORT( p ).forward <= INPUT_PORT( p ).abufsiz),        \
    assert( INPUT_PORT( p ).abufsiz <= INPUT_PORT( p ).bufsiz),         \
    printf( "RGC_BUFFER_EMPTY: forward: %d  abufsiz: %d  mstart: %d  mstop: %d --> %d\n" ,    \
            INPUT_PORT( p ).forward, INPUT_PORT( p ).abufsiz,           \
            INPUT_PORT( p ).matchstart, INPUT_PORT( p ).matchstop,      \
            INPUT_PORT( p ).forward == INPUT_PORT( p ).abufsiz),        \
    INPUT_PORT( p ).forward == INPUT_PORT( p ).abufsiz)
#else
#define RGC_BUFFER_EMPTY( p )                                           \
   (INPUT_PORT( p ).forward == INPUT_PORT( p ).abufsiz)
#endif

#define RGC_MATCH_FAIL( p )                                             \
   (INPUT_PORT( p ).matchstart++)

#define RGC_FAILING_CHAR( p )                                           \
   ((unsigned int)(RGC_BUFFER( p )[ INPUT_PORT( p ).matchstart ]))

#define RGC_BUFFER_LENGTH( p )                                          \
   (INPUT_PORT( p ).matchstop - INPUT_PORT( p ).matchstart)

#define RGC_BUFFER_POSITION( p )                                        \
   (INPUT_PORT( p ).forward - INPUT_PORT( p ).matchstart)

#define RGC_MATCHSTOP( p )                                              \
   (INPUT_PORT( p ).matchstop)

/*---------------------------------------------------------------------*/
/*    Vectors                                                          */
/*---------------------------------------------------------------------*/
#define VECTOR_SIZE (sizeof( struct vector ))

/* Le nombre de bit accordes aux tag des vecteurs (pour caml) */
#define VECTOR_TAG_NB_BIT 8
#define VECTOR_TAG_SIZE ((unsigned int)(1<<VECTOR_TAG_NB_BIT))

#define VECTOR_LENGTH_SHIFT ((sizeof( int ) << 3) - VECTOR_TAG_NB_BIT)

#define VECTOR_LENGTH_MASK \
   (~(unsigned int)((VECTOR_TAG_SIZE -1) << VECTOR_LENGTH_SHIFT))

#define VECTOR( o ) CVECTOR( o )->vector_t

#if( !(defined( TAG_VECTOR ) ) )
#   define VECTORP( c ) (POINTERP( c ) && (TYPE( c ) == VECTOR_TYPE))
#else
#   define VECTORP( c ) ((c && ((((long)c)&TAG_MASK) == TAG_VECTOR)))
#endif

#define VECTOR_REF( v, i )    (&(VECTOR( v ).obj0))[ i ]
#define VECTOR_SET( v, i, o ) (VECTOR_REF( v, i ) = o, BUNSPEC)

/*---------------------------------------------------------------------*/
/*    !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!!  */
/*    -------------------------------------------------------------    */
/*    Pour pouvoir coder une information supplementaire sur les        */
/*    vecteurs, je limite leur taille a 2^22. Cela signifie que        */
/*    l'info peut-etre codee sur les 8 bits de poids fort.             */
/*---------------------------------------------------------------------*/
#define VECTOR_LENGTH( v ) \
   ((unsigned int)VECTOR( v ).length & VECTOR_LENGTH_MASK)

#define VECTOR_TAG_SET( v, tag )                       \
    ( VECTOR( v ).length =                             \
     ((unsigned int)VECTOR_LENGTH( v ) |               \
       (((unsigned int) tag) << VECTOR_LENGTH_SHIFT)), \
       BUNSPEC )

#define VECTOR_TAG( v )                                \
( ((unsigned int)(VECTOR( v ).length) & ~VECTOR_LENGTH_MASK) >> VECTOR_LENGTH_SHIFT )

/*---------------------------------------------------------------------*/
/*    Numbers                                                          */
/*---------------------------------------------------------------------*/
#define INTEGERP( o ) ((((long)o) & TAG_MASK) == TAG_INT)

#define REAL_SIZE  (sizeof( struct real ))
#if( !(defined( TAG_REAL ) ) )
#   define REALP( c ) (POINTERP( c ) && (TYPE( c ) == REAL_TYPE))
#else
#   define REALP( c ) ((c && ((((long)c)&TAG_MASK) == TAG_REAL)))
#endif

#define REAL( o )  CREAL( o )->real_t

#define NEG( x ) (- x)

#if( !defined( KEEP_BACK_PTRS ) )
#   define DOUBLE_TO_REAL( d ) (make_real( d ))
#else
/* when compiling for debug, REAL are not allocated using GC_MALLOC_ATOMIC */
/* in order to maintain type information for real inside the debugger      */
#     if( defined( __GNUC__ ) )
#      define DOUBLE_TO_REAL( d )                                         \
        ({ obj_t an_object;                                               \
           an_object = GC_MALLOC( REAL_SIZE );                            \
           an_object->real_t.header = MAKE_HEADER( REAL_TYPE, REAL_SIZE );\
	   an_object->real_t.real = (d);                                  \
           BGL_HEAP_DEBUG_MARK_OBJ( BREAL( an_object ) ); })
#     else
#      define MAKE_PAIR( d )                                              \
        (an_object = GC_MALLOC( REAL_SIZE ),                              \
           an_object->real_t.header = MAKE_HEADER( REAL_TYPE, REAL_SIZE ),\
           an_object->real_t.real = (d),                                  \
           BGL_HEAP_DEBUG_MARK_OBJ( BREAL( an_object ) ))
#     endif
#endif
   
#define REAL_TO_DOUBLE( r ) (REAL( r ).real)

#define FLOAT_TO_REAL( d ) (DOUBLE_TO_REAL( (double)(d) ))
#define REAL_TO_FLOAT( r ) ((float)(REAL( r ).real))

#define ODDP_FX( x )  ( x  & 0x1 )
#define EVENP_FX( x ) (!ODDP_FX( x ))

/*---------------------------------------------------------------------*/
/*    Long long                                                        */
/*---------------------------------------------------------------------*/
#define LLONG_SIZE (sizeof( struct llong ))

#define LLONGP( o ) (POINTERP( o ) && (TYPE( o ) == LLONG_TYPE))

#define LLONG( o ) CREF( o )->llong_t

#if( defined( __GNUC__ ) )
#   define LLONG_TO_BLLONG( l )                                          \
           ( { obj_t an_object;                                          \
	       an_object = GC_MALLOC( LLONG_SIZE );                      \
	       an_object->llong_t.header = MAKE_HEADER( LLONG_TYPE, 0 ); \
	       an_object->llong_t.llong = l;                             \
	       BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ); } )
#else
#   define LLONG_TO_BLLONG( l )                                         \
           (   an_object = GC_MALLOC( LLONG_SIZE ),                     \
	       an_object->llong_t.header = MAKE_HEADER( LLONG_TYPE, 0), \
	       an_object->llong_t.llong = l,                            \
	       BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ) )
#endif
	    
#define BLLONG_TO_LLONG( l ) (LLONG( l ).llong)
#if( HAVE_LONGLONG )      
#  define LONG_TO_LLONG( l ) ((long long)l)   
#else
#  define LONG_TO_LLONG( l ) ((long)l)
#endif
   
/*---------------------------------------------------------------------*/
/*    exact long                                                       */
/*---------------------------------------------------------------------*/
#define ELONG_SIZE (sizeof( struct elong ))

#define ELONGP( o ) (POINTERP( o ) && (TYPE( o ) == ELONG_TYPE))

#define ELONG( o ) CREF( o )->elong_t

#if( defined( __GNUC__ ) )
#   define LONG_TO_BELONG( l )                                           \
           ( { obj_t an_object;                                          \
	       an_object = GC_MALLOC( ELONG_SIZE );                      \
	       an_object->elong_t.header = MAKE_HEADER( ELONG_TYPE, 0 ); \
	       an_object->elong_t.elong = l;                             \
	       BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ); } )
#else
#   define LONG_TO_BELONG( l )                                           \
           (   an_object = GC_MALLOC( ELONG_SIZE ),                      \
	       an_object->elong_t.header = MAKE_HEADER( ELONG_TYPE, 0 ), \
	       an_object->elong_t.elong = l,                             \
	       BGL_HEAP_DEBUG_MARK_OBJ( BREF( an_object ) ) )
#endif
	    
#define BELONG_TO_LONG( l ) (ELONG( l ).elong)

/*---------------------------------------------------------------------*/
/*    Symbols                                                          */
/*---------------------------------------------------------------------*/
#define SYMBOLP( o ) (POINTERP( o ) && (TYPE( o ) == SYMBOL_TYPE))

#define SYMBOL( o )  (CREF( o )->symbol_t)
   
#define SYMBOL_SIZE (sizeof( struct symbol ))

#define SYMBOL_TO_STRING( o ) SYMBOL( o ).string

#define GET_SYMBOL_PLIST( o )    (SYMBOL( o ).cval)

#define SET_SYMBOL_PLIST( o, v ) (GET_SYMBOL_PLIST( o ) = v, BUNSPEC)

#define SYMBOL_CASE_SENSTIVE_P( obj ) ((obj)->header & (1 << HEADER_NB_BIT))
   
/*---------------------------------------------------------------------*/
/*    Keywords                                                          */
/*---------------------------------------------------------------------*/
#define KEYWORDP( o ) (POINTERP( o ) && (TYPE( o ) == KEYWORD_TYPE))

#define KEYWORD( o )  (CREF( o )->symbol_t)
   
#define KEYWORD_SIZE (sizeof( struct symbol ))

#define KEYWORD_TO_STRING( o ) KEYWORD( o ).string

#define GET_KEYWORD_PLIST( o )   (KEYWORD( o ).cval)

#define SET_KEYWORD_PLIST( o, v ) (GET_KEYWORD_PLIST( o ) = v, BUNSPEC)
   
/*---------------------------------------------------------------------*/
/*    Structures                                                       */
/*---------------------------------------------------------------------*/
#define STRUCT_SIZE (sizeof( struct structure ))

#define STRUCT( o ) CSTRUCTURE( o )->struct_t

#if( !(defined( TAG_STRUCTURE ) ) )
#   define STRUCTP( c ) (POINTERP( c ) && (TYPE( c ) == STRUCT_TYPE))
#else
#   define STRUCTP( c ) ((c && ((((long)c)&TAG_MASK) == TAG_STRUCTURE)))
#endif

#define STRUCT_KEY( c )        STRUCT( c ).key
#define STRUCT_KEY_SET( c, k ) (STRUCT_KEY( c ) = k, BUNSPEC)

#define STRUCT_LENGTH( c ) STRUCT( c ).length
   
#define STRUCT_REF( c, i )    (&(STRUCT(c).obj0))[ i ]
#define STRUCT_SET( c, i, o ) (STRUCT_REF( c, i ) = o, BUNSPEC)

extern obj_t fill_struct();
extern obj_t set_struct();

/*---------------------------------------------------------------------*/
/*    Typed structures                                                 */
/*---------------------------------------------------------------------*/
#define TSTRUCTP( o ) (POINTERP( o ) && (TYPE( o ) == TSTRUCT_TYPE))

#define TSTRUCT_SIZE (sizeof( struct tstructure ))

#define TSTRUCT( tv ) CREF( tv )->tstruct_t

#define TSTRUCT_ID( c ) TSTRUCT( c ).id
#define TSTRUCT_TO_VECTOR( c )               \
   (PROCEDURE_ENTRY( TSTRUCT( c ).to_vector )\
    ( TSTRUCT( c ).to_vector, c, BEOA ))

#define TSTRUCT_REF( _u_struct, _st, _u_slot )     \
      (((struct { header_t      header;            \
		  obj_t         id;                \
		  obj_t         to_v;              \
		  _u_struct     dummy;} *)CREF( _st ))->dummy._u_slot)

#define TSTRUCT_SET( _u_struct, _st, _u_slot, _v )                  \
      (TSTRUCT_REF( _u_struct, _st, _u_slot ) = _v,                 \
       BUNSPEC )
		 
/*---------------------------------------------------------------------*/
/*    characters                                                       */
/*---------------------------------------------------------------------*/
#define CHARP( o ) \
   (((long)(o) & (long)((1 << (CHAR_SHIFT)) -1)) == (long)BCHARH)

/*---------------------------------------------------------------------*/
/*    Output                                                           */
/*---------------------------------------------------------------------*/
#define WRITE_CHAR( c_char, p )                    \
   ( (OUTPUT_STRING_PORTP( p ) ?                   \
     (char)strputc( c_char, p ) :                  \
     (char)fputc( c_char, OUTPUT_PORT( p ).file )) \
     , c_char )

/*---------------------------------------------------------------------*/
/*    Ucs2 handling.                                                   */
/*    -------------------------------------------------------------    */
/*    Tagged, a UCS2 character is represented as:                      */
/*            +--------+--------+--------+--------+                    */
/*            |xxxxxxxxxxxxxxxxx|........|BUCS2H??|                    */
/*            +--------+--------+--------+--------+                    */
/*---------------------------------------------------------------------*/
#define UCS2P( o ) \
   (((long)(o) & (long)((1 << (UCS2_SHIFT)) -1)) == (long)BUCS2H)


#define BUCS2( o ) ((obj_t)((long)BUCS2H + \
			    ((long)((ucs2_t)(o) << UCS2_SHIFT))))
#define CUCS2( o ) ((ucs2_t)((unsigned long)o >> UCS2_SHIFT))

/*---------------------------------------------------------------------*/
/*    Typed vectors                                                    */
/*---------------------------------------------------------------------*/
#define TVECTORP( o ) (POINTERP( o ) && (TYPE( o ) == TVECTOR_TYPE))

#define TVECTOR_SIZE (sizeof( struct tvector ))

#define TVECTOR( tv ) CREF( tv )->tvector_t

#define TVECTOR_ID( tv )             TVECTOR( tv ).id
#define TVECTOR_ID_SET( tv, _id_ )   (TVECTOR_ID( tv ) = _id_, BUNSPEC)

#define TVECTOR_LENGTH( tv )         TVECTOR( tv ).length
#define TVECTOR_DESCR( tv )          TVECTOR( tv ).descr
#define TVECTOR_DESCR_SET( tv, _d_ ) (TVECTOR_DESCR( tv ) = _d_, BUNSPEC)

#define TVECTOR_REF( it, tv, o )                  \
      (&(((struct { header_t        header;       \
		    int             length;       \
		    obj_t           descr;        \
		    it              el0; } *)     \
       CREF( tv ))->el0))[ o ]

#define TVECTOR_SET( it, tv, o, v )               \
   (TVECTOR_REF( it, tv, o ) = ((it)v),           \
    BUNSPEC)

/*---------------------------------------------------------------------*/
/*    `exit' machinery                                                 */
/*---------------------------------------------------------------------*/
extern obj_t _exit_value_;

#define SET_EXIT( exit )       SETJMP( jmpbuf )
#define JUMP_EXIT( exit, val ) _exit_value_ = val, LONGJMP( ((void *)exit), 1 )

/*---------------------------------------------------------------------*/
/*    the `bind-exit' linking.                                         */
/*---------------------------------------------------------------------*/
struct exitd {
   obj_t         exit;
   bool_t        userp;
   obj_t         stamp;
   struct exitd *prev;
};

extern obj_t (*bgl_get_exitd_top)();
extern obj_t (*bgl_set_exitd_top)( obj_t );
extern obj_t bgl_get_exitd_stamp();
   
#define PUSH_EXIT( _xit, _ser ) \
   struct exitd exitd; \
   exitd.exit  = _xit; \
   exitd.userp = _ser; \
   exitd.prev  = ((struct exitd *)BGL_GET_EXITD_TOP()); \
   exitd.stamp = bgl_get_exitd_stamp(); \
   bgl_set_exitd_top( (obj_t)(&exitd) );

#define POP_EXIT() \
   BGL_SET_EXITD_TOP( (obj_t)(((struct exitd *)BGL_GET_EXITD_TOP())->prev) )

#define EXITD_TO_EXIT( ptr ) \
   ((struct exitd *)(ptr))->exit

#define EXITD_USERP( ptr ) \
   ((struct exitd *)(ptr))->userp

#define EXITD_STAMP( ptr ) \
   (((struct exitd *)(ptr))->stamp)

#define BGL_GET_EXITD_TOP() \
   (bgl_get_exitd_top())
#define BGL_SET_EXITD_TOP( val ) \
   (bgl_set_exitd_top(val))
   
/*---------------------------------------------------------------------*/
/*    `dynamic-wind' before thunk linking.                             */
/*---------------------------------------------------------------------*/
struct befored {
   obj_t           before;
   struct befored *prev;
};

extern struct befored * (*bgl_get_befored_top)();
extern void (*bgl_set_befored_top)( struct befored * );

#define PUSH_BEFORE( _bfr ) \
   struct befored befored; \
   befored.before = _bfr; \
   befored.prev = bgl_get_befored_top(); \
   bgl_set_befored_top( &befored );

#define POP_BEFORE() \
   bgl_set_befored_top( bgl_get_befored_top()->prev )

/*---------------------------------------------------------------------*/
/*    The interperter locations                                        */
/*---------------------------------------------------------------------*/
#define __EVMEANING_ADDRESS( x )        \
   BREF( &x )
#define __EVMEANING_ADDRESS_REF( x )    \
   (*((obj_t *)CREF( x )))
#define __EVMEANING_ADDRESS_SET( x, y ) \
   (__EVMEANING_ADDRESS_REF( x ) = (obj_t)y, BUNSPEC)

/*---------------------------------------------------------------------*/
/*    Call/cc stuff.                                                   */
/*---------------------------------------------------------------------*/
#define STACK_SIZE  (sizeof( struct stack ))
   
#define STACK( _o_ ) CREF( _o_ )->stack_t

#define STACKP( _s_ ) (POINTERP( _s_ ) && (TYPE( _s_ ) == STACK_TYPE))

#define MAKE_STACK( _size_, aux )                  \
   ( aux = GC_MALLOC( STACK_SIZE + (long)_size_ ), \
     aux->header = MAKE_HEADER( STACK_TYPE, 0 ),   \
     BGL_HEAP_DEBUG_MARK_OBJ( BREF( aux ) ) )

extern char *(*bgl_get_stack_bottom)();
extern void (*bgl_set_stack_bottom)( char * );

/*---------------------------------------------------------------------*/
/*    Intern/extern macros.                                            */
/*---------------------------------------------------------------------*/
#if( defined( TAG_STRING ) )
#   define STRING_MARK_OFFSET 0
#else
#   define STRING_MARK_OFFSET 1
#endif

#if( defined( TAG_STRUCTURE ) )
#   define STRUCTURE_MARK_OFFSET 0
#else
#   define STRUCTURE_MARK_OFFSET 1
#endif

/*---------------------------------------------------------------------*/
/*    Object macros                                                    */
/*---------------------------------------------------------------------*/
#define BGL_OBJECTP( _obj ) \
   ((POINTERP( _obj ) && (TYPE( _obj ) >= OBJECT_TYPE)))

#define BGL_OBJECT_CLASS_NUM( _obj ) \
   (TYPE( _obj ))

#define BGL_OBJECT_CLASS_NUM_SET( _1, _2 ) \
   (((obj_t)CREF(_1))->header = MAKE_HEADER( _2, 0 ), BUNSPEC)
   
#define BGL_OBJECT_WIDENING( _obj )          \
   (((object_bglt)(CREF(_obj)))->widening)

#define BGL_OBJECT_WIDENING_SET( _obj, _str ) \
   (((((object_bglt)(CREF(_obj)))->widening) = _str), BUNSPEC)
/* To be removed after a bootstrap */
#define OBJECT_WIDENING_SET BGL_OBJECT_WIDENING_SET

/*---------------------------------------------------------------------*/
/*    Process handling                                                 */
/*---------------------------------------------------------------------*/
#define PROCESSP( o )            (POINTERP( o ) && (TYPE( o ) == PROCESS_TYPE))
#define PROCESS_SIZE             (sizeof( struct process ))
#define PROCESS( o )             (CREF( o )->process_t)
#define PROCESS_PID( o )         (PROCESS( o ).pid)
#define PROCESS_INPUT_PORT( o )  (PROCESS( o ).stream[ 0 ])
#define PROCESS_OUTPUT_PORT( o ) (PROCESS( o ).stream[ 1 ])
#define PROCESS_ERROR_PORT( o )  (PROCESS( o ).stream[ 2 ])

/*---------------------------------------------------------------------*/
/*    Socket handling                                                  */
/*---------------------------------------------------------------------*/
#define SOCKETP( o )             (POINTERP( o ) && (TYPE( o ) == SOCKET_TYPE))
#define SOCKET_SIZE              (sizeof( struct socket ))
#define SOCKET( o )              (CREF( o )->socket_t)
#define SOCKET_HOSTNAME( o )     (SOCKET( o ).hostname)
#define SOCKET_HOSTIP( o )       (SOCKET( o ).hostip)
#define SOCKET_PORT( o )         (SOCKET( o ).portnum)
#define SOCKET_INPUT( o )        (SOCKET( o ).input)
#define SOCKET_OUTPUT( o )       (SOCKET( o ).output)
#define SOCKET_DOWNP( o )        (SOCKET( o ).fd == -1)
   
#define SOCKET_SERVER            22
#define SOCKET_CLIENT            23

#define SOCKET_SERVERP( o )      (SOCKETP( o ) && (SOCKET( o ).stype == SOCKER_SERVER))
#define SOCKET_CLIENTP( o )      (SOCKETP( o ) && (SOCKET( o ).stype == SOCKER_CLIENT))

/*---------------------------------------------------------------------*/
/*    opaque                                                           */
/*---------------------------------------------------------------------*/
#define OPAQUEP( o ) (POINTERP( o ) && (TYPE( o ) == OPAQUE_TYPE))
#define OPAQUE( f ) CREF( f )

/*---------------------------------------------------------------------*/
/*    Custom management                                                */
/*---------------------------------------------------------------------*/
#define CUSTOMP( o ) (POINTERP( o ) && (TYPE( o ) == CUSTOM_TYPE))

#define CUSTOM_SIZE (sizeof( struct custom ))
#define CUSTOM( f ) CREF( f )->custom_t

#define CUSTOM_FINAL( f ) CUSTOM( f ).final
#define CUSTOM_SERIAL( f ) CUSTOM( f ).serial
#define CUSTOM_EQUAL( f ) CUSTOM( f ).equal
#define CUSTOM_HASH( f ) CUSTOM( f ).hash
#define CUSTOM_TO_STRING( f ) CUSTOM( f ).to_string
#define CUSTOM_OUTPUT( f ) CUSTOM( f ).output

#define CUSTOM_CMP( c1, c2 ) CUSTOM_EQUAL( c1 )( c1, c2 )

#define CUSTOM_IDENTIFIER( f ) CUSTOM( f ).identifier
#define CUSTOM_IDENTIFIER_SET( f, v ) (CUSTOM( f ).identifier = v, BUNSPEC)
#define CUSTOM_HASH_NUMBER( f ) (CUSTOM_HASH( f )( f ))

/*---------------------------------------------------------------------*/
/*    Foreign management                                               */
/*---------------------------------------------------------------------*/
#define FOREIGNP( o ) (POINTERP( o ) && (TYPE( o ) == FOREIGN_TYPE))

#define FOREIGN_TYPE_NAME( o ) "_"
   
#define FOREIGN_SIZE (sizeof( struct foreign ))
#define FOREIGN( f ) CREF( f )->foreign_t

#define FOREIGN_NULL( obj ) ((obj == BFALSE) ? 0L : obj)
#define FOREIGN_TO_COBJ( f ) (FOREIGN( f ).cobj)
#define FOREIGN_NULLP( f )   ((bool_t)(!FOREIGN_TO_COBJ( f )))
#define FOREIGN_EQP( o1,o2 ) \
  ((bool_t)(FOREIGN_TO_COBJ( o1 ) == (FOREIGN_TO_COBJ( o2 ))))
#define FOREIGN_PTR_NULL( _p ) (_p == 0)
   
#define FOREIGN_ID( f ) FOREIGN( f ).id

#define C_STRUCT_REF( o, type, slot )             \
   (((type)o)->slot)
#define C_STRUCT_SET( o, type, slot, value )      \
   (C_STRUCT_REF( o, type, slot ) = value, BUNSPEC)

#define C_STRUCT_REF_ADDR( o, type, slot )        \
   (&(((type)o)->slot))
#define C_STRUCT_SET_ADDR( o, type, slot, value ) \
   (((type)o)->slot = *value, BUNSPEC)

#define C_POINTER_REF( o, type, i )               \
   (((type *)o)[ i ])
#define C_POINTER_SET( o, type, i, v )            \
   (C_POINTER_REF( o, type, i ) = v, BUNSPEC)

#define C_POINTER_REF_ADDR( o, type, i )          \
   (&(o)[ i ])
#define C_POINTER_SET_ADDR( o, type, i, v )       \
   (o[ i ] = *v, BUNSPEC)

#define C_FUNCTION_CALL_0( F ) \
   F()
#define C_FUNCTION_CALL_1( F,a ) \
   F( a )
#define C_FUNCTION_CALL_2( F,a,b ) \
   F( a,b )
#define C_FUNCTION_CALL_3( F,a,b,c ) \
   F( a,b,c )
#define C_FUNCTION_CALL_4( F,a,b,c,d ) \
   F( a,b,c,d )
#define C_FUNCTION_CALL_5( F,a,b,c,d,e ) \
   F( a,b,c,d,e )
#define C_FUNCTION_CALL_6( F,a,b,c,d,e,f ) \
   F( a,b,c,d,e,f )
#define C_FUNCTION_CALL_7( F,a,b,c,d,e,f,h ) \
   F( a,b,c,d,e,f,h )
#define C_FUNCTION_CALL_8( F,a,b,c,d,e,f,h,i ) \
   F( a,b,c,d,e,f,h,i )
#define C_FUNCTION_CALL_9( F,a,b,c,d,e,f,h,i,j ) \
   F( a,b,c,d,e,f,h,i,j )
#define C_FUNCTION_CALL_10( F,a,b,c,d,e,f,h,i,j,k ) \
   F( a,b,c,d,e,f,h,i,j,k )
#define C_FUNCTION_CALL_11( F,a,b,c,d,e,f,h,i,j,k,l ) \
   F( a,b,c,d,e,f,h,i,j,k,l )
#define C_FUNCTION_CALL_12( F,a,b,c,d,e,f,h,i,j,k,l,m ) \
   F( a,b,c,d,e,f,h,i,j,k,l,m )
#define C_FUNCTION_CALL_13( F,a,b,c,d,e,f,h,i,j,k,l,m,n ) \
   F( a,b,c,d,e,f,h,i,j,k,l,m,n )
#define C_FUNCTION_CALL_14( F,a,b,c,d,e,f,h,i,j,k,l,m,n,o ) \
   F( a,b,c,d,e,f,h,i,j,k,l,m,n,o )
#define C_FUNCTION_CALL_15( F,a,b,c,d,e,f,h,i,j,k,l,m,n,o,p ) \
   F( a,b,c,d,e,f,h,i,j,k,l,m,n,o,p )
#define C_FUNCTION_CALL_16( F,a,b,c,d,e,f,h,i,j,k,l,m,n,o,p,q ) \
   F( a,b,c,d,e,f,h,i,j,k,l,m,n,o,p,q )

#define CENUM_TO_FOREIGN( _1, _2 ) cobj_to_foreign( _1, (void *)_2 )

/*---------------------------------------------------------------------*/
/*    Dynamic loading default entry init symbol.                       */
/*---------------------------------------------------------------------*/
#define BGL_DYNAMIC_LOAD_INIT "bigloo_dlopen_init"

/*---------------------------------------------------------------------*/
/*    The external declarations                                        */
/*---------------------------------------------------------------------*/
extern obj_t bigloo_exit( obj_t );

extern obj_t va_generic_entry();
extern obj_t apply( obj_t, obj_t );
		  
extern obj_t the_failure( obj_t, obj_t, obj_t );

extern obj_t make_fx_procedure( function_t, int, int );
extern obj_t make_va_procedure( function_t, int, int );

extern obj_t make_pair( obj_t, obj_t );
extern obj_t strport_flush( obj_t );
extern obj_t make_output_port( char *, FILE*, obj_t );
extern obj_t create_vector( int );

extern obj_t string_to_bstring( char * );
extern obj_t string_to_bstring_len( char *, int );
extern obj_t close_init_string();

extern obj_t cobj_to_foreign( obj_t, void * );
extern int _bigloo_main(int argc, char *argv[], char *env[], obj_t (*)() );
//   extern int _bigloo_main(int argc, char *argv[], char *env[] );
extern int bigloo_abort( long );

extern obj_t make_real( double );

extern obj_t string_to_symbol( char * );

extern char strputc( char, obj_t );
   
#if( defined( KEEP_BACK_PTRS ) )
extern obj_t bgl_heap_debug_mark_obj( obj_t );
extern char *bgl_heap_debug_mark_str( char * );
#endif

#ifdef __cplusplus
}
#endif

#endif

