path: root/gcc/melt-runtime.h

/**
   MELT header melt-runtime.h
   [[middle end lisp translator, see http://gcc.gnu.org/wiki/MELT or
   www.gcc-melt.org ]]
   Copyright (C)  2008, 2009, 2010 Free Software Foundation, Inc.
   Contributed by Basile Starynkevitch <basile@starynkevitch.net>

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.   If not see
<http://www.gnu.org/licenses/>.
**/

#ifndef MELT_INCLUDED_
#define MELT_INCLUDED_


/* we need PPL because some static inline functions use it below
   (e.g. melt_raw_new_ppl_empty_constraint_system). This is notably
   true for gtype-desc.c which is generated by gengtype and won't
   compile without this include.  */
#include "ppl_c.h"

/* DYNAMIC_OBJSTRUCT is a cute hack to "dynamically" compute field
   positions; this is only used to compile warmelt-*-0.c files notably
   when new fields have been added in warmelt-first.melt. When
   enabled, slows down significantly MELT. */
#ifndef MELTGCC_DYNAMIC_OBJSTRUCT
#define MELTGCC_DYNAMIC_OBJSTRUCT 0
#endif

/***** 
       if GGC-collected data, e.g. tree-s, edge-s, ... is computed by
       melt/MELT routines and is referenced only by the
       melt/MELT call frames, it should be carefully handled by
       full GC.

       This is done by specially generated code chunk in each MELT
       generated routines which mark such GGC data outside on full
       garbage collections. This code is invoked by calling the
       closure routine with a magic incantation, i.e. with the
       xargdescr_ set to (char*)-1

 *****/

#include "gcc-plugin.h"

/* we include toplev.h for the error routines */
#include "toplev.h"

extern const char melt_runtime_build_date[];

extern void melt_fatal_info (const char*filename, int lineno);

#define melt_fatal_error(Fmt,...) do{ melt_fatal_info (__FILE__,__LINE__); \
    fatal_error ((Fmt),##__VA_ARGS__); }while(0)

#define dbgprintf_raw(Fmt,...) do{if (dump_file) \
      {fprintf(dump_file, Fmt, ##__VA_ARGS__); fflush(dump_file);}}while(0)
#define dbgprintf(Fmt,...) dbgprintf_raw("@%s:%d: " Fmt "\n", \
 basename(__FILE__), __LINE__, ##__VA_ARGS__)

/* the version string of GCC when MELT was initialized */
extern char* melt_gccversionstr;


extern long melt_dbgcounter;
extern long melt_debugskipcount;

extern long melt_error_counter;


/* the MELT debug depth for debug_msg ... can be set with -fmelt-debug-depth= */
int melt_debug_depth(void);

#ifdef MELT_IS_PLUGIN
extern int flag_melt_debug;
#endif

#define debugeprintf_raw(Fmt,...) do{if (flag_melt_debug) \
      {fprintf(stderr, Fmt, ##__VA_ARGS__); fflush(stderr);}}while(0)
#define debugeprintf(Fmt,...) debugeprintf_raw("!@%s:%d:\n@! " Fmt "\n", \
      basename(__FILE__), __LINE__, ##__VA_ARGS__)
#define debugeprintfnonl(Fmt,...) debugeprintf_raw("!@%s:%d:\n@! " Fmt, \
      basename(__FILE__), __LINE__, ##__VA_ARGS__)
#define debugeprintvalue(Msg,Val) do{if (flag_melt_debug){	\
      void* __val = (Val);					\
      fprintf(stderr,"!@%s:%d:\n@! %s @%p= ",			\
              basename(__FILE__), __LINE__, (Msg), __val);	\
      melt_dbgeprint(__val); }} while(0)
#define debugebacktrace(Msg,Depth)  do{if (flag_melt_debug){	\
      void* __val = (Val);					\
      fprintf(stderr,"!@%s:%d: %s **backtrace** ",		\
              basename(__FILE__), __LINE__, (Msg));		\
      melt_dbgbacktrace((Depth)); }} while(0)
/* the maximal debug depth - should be a parameter */
#define MELTDBG_MAXDEPTH 7

/* unspecified flexible dimension in structure */
#if defined(__STDC__) &&  __STDC__VERSION >= 199901L
#define FLEXIBLE_DIM		/*flexible */
#define HAVE_FLEXIBLE_DIM 1
#elsif __GNUC__>=4
#define FLEXIBLE_DIM /*gcc flexible*/
#define HAVE_FLEXIBLE_DIM 1
#else
#define  FLEXIBLE_DIM /*flexibly*/1
#define HAVE_FLEXIBLE_DIM 0
#endif

/* array of (at least 100, increasing order but non consecutive)
   primes, zero terminated. Each prime is at least 1/8-th bigger than
   previous */
extern const long melt_primtab[256];


/* function to retrieve a MELT program -or plugin- argument; return
   NULL if not found */
const char* melt_argument(const char* argname);

/* naming convention: all struct melt*_st are inside the
   melt_un */

typedef union melt_un *melt_ptr_t;
typedef struct meltobject_st *meltobject_ptr_t;
typedef struct meltmapobjects_st *meltmapobjects_ptr_t;
typedef struct meltclosure_st *meltclosure_ptr_t;
typedef struct meltroutine_st *meltroutine_ptr_t;
typedef struct meltmultiple_st *meltmultiple_ptr_t;
typedef struct meltbox_st *meltbox_ptr_t;
typedef struct meltpair_st *meltpair_ptr_t;
typedef struct meltlist_st *meltlist_ptr_t;

struct debugprint_melt_st
{
  FILE *dfil;
  int dmaxdepth;
  int dcount;
};

void melt_debug_out (struct debugprint_melt_st *dp, melt_ptr_t ptr,
			int depth);
void melt_dbgeprint (void *p);
void melt_dbgbacktrace (int depth);

#ifdef ENABLE_CHECKING
extern int melt_debug_garbcoll;
#define melt_debuggc_eprintf(Fmt,...) do {if (melt_debug_garbcoll > 0) \
      fprintf (stderr, "%s:%d:@$*" Fmt "\n",			       \
	       lbasename(__FILE__), __LINE__, ##__VA_ARGS__);} while(0)
#else
#define melt_debuggc_eprintf(Fmt,...) do{}while(0)
#endif


/******************* closures, routines ************************/

/* when the argdescr string of a closure routine is MELTPAR_MARKGGC
   the routine just marks the frame passed as first argument */
#define MELTPAR_MARKGGC ((char*)(-1L))

union meltparam_un
{
  /* for melt value pointers, we pass the address of a local, to be
     compatible with our copying garbage collector */
  melt_ptr_t *bp_aptr;	/* letter p */
#define BPAR_PTR          'p'
#define BPARSTR_PTR       "p"

/* we no longer have BPAR_RESTPTR as 'R' */

  tree bp_tree;			/* letter t */
  tree *bp_treeptr;		/* for extra results */
#define BPAR_TREE         't'
#define BPARSTR_TREE      "t"

  gimple bp_gimple;			/* letter g */
  gimple *bp_gimpleptr;		/* for extra results */
#define BPAR_GIMPLE       'g'
#define BPARSTR_GIMPLE    "g"

  gimple_seq bp_gimpleseq;			/* letter g */
  gimple_seq *bp_gimpleseqptr;		/* for extra results */
#define BPAR_GIMPLESEQ       'G'
#define BPARSTR_GIMPLESEQ    "G"

  long bp_long;			/* letter l */
  long *bp_longptr;		/* for results */
#define BPAR_LONG         'l'
#define BPARSTR_LONG      "l"

  edge bp_edge;			/* letter e */
  edge *bp_edgeptr;		/* for results */
#define BPAR_EDGE         'e'
#define BPARSTR_EDGE      "e"

  basic_block bp_bb;		/* letter b */
  basic_block *bp_bbptr;	/* for results */
#define BPAR_BB           'b'
#define BPARSTR_BB        "b"

  /* readonly constant strings - not in GP nor in heap */
  const char *bp_cstring;			/* letter s */
  const char **bp_cstringptr;		/* for results */
#define BPAR_CSTRING         's'
#define BPARSTR_CSTRING      "s"

  /* PPL and special stuff are getting the upper case letters */
  /* PPL coefficients */
  ppl_Coefficient_t bp_ppl_coefficient;
  ppl_Coefficient_t* bp_ppl_coefficientptr;
#define BPAR_PPL_COEFFICIENT 'A'
#define BPARSTR_PPL_COEFFICIENT "A"

  /* PPL constraints */
  ppl_Constraint_t bp_ppl_constraint;
  ppl_Constraint_t* bp_ppl_constraintptr;
#define BPAR_PPL_CONSTRAINT 'B'
#define BPARSTR_PPL_CONSTRAINT "B"

  /* PPL constraint systems */
  ppl_Constraint_System_t bp_ppl_constraint_system;
  ppl_Constraint_System_t* bp_ppl_constraint_systemptr;
#define BPAR_PPL_CONSTRAINT_SYSTEM 'C'
#define BPARSTR_PPL_CONSTRAINT_SYSTEM "C"

  /* PPL linear expressions */
  ppl_Linear_Expression_t bp_ppl_linear_expression;
  ppl_Linear_Expression_t* bp_ppl_linear_expressionptr;
#define BPAR_PPL_LINEAR_EXPRESSION 'D'
#define BPARSTR_PPL_LINEAR_EXPRESSION "D"

  /* PPL polyhedrons */
  ppl_Polyhedron_t bl_ppl_polyhedron;
  ppl_Polyhedron_t* bp_ppl_polyhedronptr;
#define BPAR_PPL_POLYHEDRON            'E'
#define BPARSTR_PPL_POLYHEDRON         "E"

  /* bitmap-s */
  bitmap bp_bitmap;			/* letter I */
  bitmap *bp_bitmapptr;		/* for results */
#define BPAR_BITMAP         'I'
#define BPARSTR_BITMAP      "I"

  /* loop-s */
  struct loop *bp_loop;			/* letter L */
  struct loop **bp_loopptr;		/* for results */
#define BPAR_LOOP         'L'
#define BPARSTR_LOOP      "L"

  /* rtx-s */
  rtx bp_rtx;			/* letter X */
  rtx* bp_rtxptr;
#define BPAR_RTX         'X'
#define BPARSTR_RTX      "X"


  /* rtvec-s */
  rtvec bp_rtvec;			/* letter Y */
  rtvec* bp_rtvecptr;
#define BPAR_RTVEC         'Y'
#define BPARSTR_RTVEC      "Y"
};

/*** the closures contain routines which are called by applying
     closures; each routine is called with:

     + the called closure
     + this first pointer argument
     + a (non null, can be empty) constant string describing the extra arguments
       (eg "ppt" for two value pointers and one tree)
     + the array of union meltparam_un for extra arguments
     + a (non null, can be empty) constant string describing the extra results
     + the array of union meltparam_un for extra results

     and the result of the call is a pointer (the main result)

BTW, on AMD64 or x86_64 processors [a very common host at time of
writing], http://www.x86-64.org/documentation/abi.pdf the first six
arguments are passed thru registers; on POWERPC eight arguments are
passed thru registers
*/


typedef melt_ptr_t meltroutfun_t (meltclosure_ptr_t closp_,
					melt_ptr_t firstargp_,
					const char xargdescr_[],
					union meltparam_un *xargtab_,
					const char xresdescr_[],
					union meltparam_un *xrestab_);

/* the application routine does not call the GC; of course, the
   applied closure can call the GC! */
melt_ptr_t melt_apply (meltclosure_ptr_t clos_p,
			       melt_ptr_t firstarg,
			       const char xargdescr_[],
			       union meltparam_un *xargtab_,
			       const char xresdescr_[],
			       union meltparam_un *xrestab_);

/* Depth and counter of MELT applications are only significant when
   checking is enabled by ENABLE_CHECKING.  */
extern long melt_application_count (void);
extern long melt_application_depth (void);

/* gnu indent has some trouble with GTY hence */
/* *INDENT-OFF* */

DEF_VEC_P (melt_ptr_t);
DEF_VEC_ALLOC_P (melt_ptr_t, gc);



DEF_VEC_P (meltobject_ptr_t);
DEF_VEC_ALLOC_P (meltobject_ptr_t, gc);


/* sadly we cannot use these types in GTY-ed structure because
   gengtype don't follow typedefs but these typedef-s are still
   useful */

typedef
VEC (meltobject_ptr_t, gc)
  melt_objectvec_t;
     
typedef VEC (melt_ptr_t, gc) melt_valvec_t;

enum meltobmag_en    {
  MELTOBMAG__NONE = 0,
  MELTOBMAG_OBJECT = 30000,
  
  /* keep these in alphabetical order */
  MELTOBMAG_BASICBLOCK,
  MELTOBMAG_BITMAP,
  MELTOBMAG_BOX,
  MELTOBMAG_CLOSURE,
  MELTOBMAG_DECAY,
  MELTOBMAG_EDGE,
  MELTOBMAG_GIMPLE,
  MELTOBMAG_GIMPLESEQ,
  MELTOBMAG_INT,
  MELTOBMAG_LIST,
  MELTOBMAG_LOOP,
  MELTOBMAG_MAPBASICBLOCKS,
  MELTOBMAG_MAPBITMAPS,
  MELTOBMAG_MAPEDGES,
  MELTOBMAG_MAPGIMPLES,
  MELTOBMAG_MAPGIMPLESEQS,
  MELTOBMAG_MAPLOOPS,
  MELTOBMAG_MAPOBJECTS,
  MELTOBMAG_MAPRTVECS,
  MELTOBMAG_MAPRTXS,
  MELTOBMAG_MAPSTRINGS,
  MELTOBMAG_MAPTREES,
  MELTOBMAG_MIXBIGINT,
  MELTOBMAG_MIXINT,
  MELTOBMAG_MIXLOC,
  MELTOBMAG_MULTIPLE,
  MELTOBMAG_PAIR,
  MELTOBMAG_REAL,
  MELTOBMAG_ROUTINE,
  MELTOBMAG_RTVEC,
  MELTOBMAG_RTX,
  MELTOBMAG_STRBUF,
  MELTOBMAG_STRING,
  MELTOBMAG_TREE,

  /* extra spare slots */
  MELTOBMAG__SPARE1,
  MELTOBMAG__SPARE2,
  MELTOBMAG__SPARE3,
  MELTOBMAG__SPARE4,
  MELTOBMAG__SPARE5,
  MELTOBMAG__SPARE6,
  MELTOBMAG__SPARE7,
  MELTOBMAG__SPARE8,
  MELTOBMAG__SPARE9,
  MELTOBMAG__SPARE10,
  MELTOBMAG__SPARE11,
  MELTOBMAG__SPARE12,
  MELTOBMAG__SPARE13,
  MELTOBMAG__SPARE14,
  MELTOBMAG__SPARE15,
  MELTOBMAG__SPARE16,
  MELTOBMAG__SPARE17,
  MELTOBMAG__SPARE18,
  MELTOBMAG__SPARE19,
  MELTOBMAG__SPARE20,
  MELTOBMAG__SPARE21,
  MELTOBMAG__SPARE22,
  MELTOBMAG__SPARE23,
  MELTOBMAG__SPARE24,
  MELTOBMAG__SPARE25,
  MELTOBMAG__SPARE26,
  MELTOBMAG__SPARE27,
  MELTOBMAG__SPARE28,
  MELTOBMAG__SPARE29,
  MELTOBMAG__SPARE30,
  MELTOBMAG__SPARE31,

  /* special, explicitly destroyed */
  MELTOBMAG_SPEC_FILE,		/* closed when deleted */
  MELTOBMAG_SPEC_RAWFILE,		/* not closed when deleted */
  MELTOBMAG_SPEC_MPFR,
  MELTOBMAG_SPECPPL_COEFFICIENT,
  MELTOBMAG_SPECPPL_LINEAR_EXPRESSION,
  MELTOBMAG_SPECPPL_CONSTRAINT,
  MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM,
  MELTOBMAG_SPECPPL_GENERATOR,
  MELTOBMAG_SPECPPL_GENERATOR_SYSTEM,
  MELTOBMAG_SPECPPL_POLYHEDRON,
 
  MELTOBMAG__LAST
};


/* Gives the constant string corresponding to a given object magic
   above.  */
const char* melt_obmag_string(int i);

/* maxhash can also be used as a bit mask */
#define MELT_MAXHASH 0x3fffffff

/* maxlen can also be used as a bit mask */
#define MELT_MAXLEN 0x1fffffff


/***
    objects are a la ObjVlisp, single-inheritance with a root class, 
    the discr of an object is its class
    each object has its hashcode, its magic (used to discriminate non-object values),
    its number of slots or instance variables object_arity, and an array of slots called vartab[] 

    objects should be allocated in young region, hence discr should be
    forwarded in the garbage collector



*/

/* *INDENT-ON* */

/* when MELTOBMAG_OBJECT -- */

/* GCC 4.6 gengtype introducted the variable_size GTY attribute. But
   GCC 4.5 don't have it. So every usage of variable_size is marked by
   a comment on the same line as the 'GTY' and 'variable_size' words
   with @@ followed by MELTGTY to help an external shell script to
   convert and backport this melt-runtime.h to 4.5 habits. */

struct 
GTY ((variable_size)) /*@@MELTGTY@@*/
meltobject_st
{
  /* for objects, the discriminant is their class */
  meltobject_ptr_t obj_class;
  unsigned obj_hash;		/* hash code of the object */
  unsigned short obj_num;
/* discriminate the melt_un containing it as discr */
#define object_magic obj_num
  unsigned short obj_len;
  melt_ptr_t GTY ((length ("%h.obj_len"))) obj_vartab[FLEXIBLE_DIM];
};


#define MELT_OBJECT_STRUCT(N) {			\
  meltobject_ptr_t obj_class;			\
  unsigned obj_hash;				\
  unsigned short obj_num;			\
  unsigned short obj_len;			\
  melt_ptr_t* obj_vartab[N];			\
  long _gap; }

/* set serial is an obsolete  nop */
static inline void melt_object_set_serial(meltobject_ptr_t ob ATTRIBUTE_UNUSED) {}


/* some types, including objects, strbuf, stringmaps, objectmaps, all
   the other *maps, contain a pointer to a non value; this pointer
   should be carefully updated in the forwarding step (and checked if
   young) */

/* forwarded pointers; nobody see them except the melt copying
   garbage collector */
struct 
GTY (())
meltforward_st
{
  meltobject_ptr_t discr;	/* actually always (void*)1 for forwarded */
  melt_ptr_t forward;
};

/* when MELTOBMAG_DECAY  */
struct 
GTY ((mark_hook ("melt_mark_decay")))
meltdecay_st
{
  meltobject_ptr_t discr;
  melt_ptr_t val;
  unsigned remain;		/* remaining number of marking */
};


/* when MELTOBMAG_BOX  */
struct 
GTY (())
meltbox_st
{
  meltobject_ptr_t discr;
  melt_ptr_t val;
};

/* when MELTOBMAG_MULTIPLE  */
struct 
GTY ((variable_size)) /*@@MELTGTY@@*/
meltmultiple_st
{
  meltobject_ptr_t discr;
  unsigned nbval;
  melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
};

#define MELT_MULTIPLE_STRUCT(N) {		\
  meltobject_ptr_t discr;			\
  unsigned nbval;				\
  melt_ptr_t tabval[N];				\
  long _gap; }

/* when MELTOBMAG_CLOSURE */
struct 
GTY ((variable_size)) /*@@MELTGTY@@*/
meltclosure_st
{
  meltobject_ptr_t discr;
  meltroutine_ptr_t rout;
  unsigned nbval;
  melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
};

#define MELT_CLOSURE_STRUCT(N) {		\
  meltobject_ptr_t discr;			\
  meltroutine_ptr_t rout;			\
  unsigned nbval;				\
  melt_ptr_t tabval[N];				\
  long _gap; }

/* when MELTOBMAG_ROUTINE */
#define MELT_ROUTDESCR_LEN 96

struct 
GTY ((variable_size)) /*@@MELTGTY@@*/
meltroutine_st 
{
  meltobject_ptr_t discr;
  char routdescr[MELT_ROUTDESCR_LEN];
  meltroutfun_t* GTY ((skip)) routfunad;
  melt_ptr_t routdata;
  unsigned nbval;
  melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
};

/* unsafely set inside the meltroutine_st pointed by Rptr the
   routine function pointer to Rout */
#define MELT_ROUTINE_SET_ROUTCODE(Rptr,Rout) do {	\
  ((struct meltroutine_st*)(Rptr))->routfunad		\
     = (Rout);						\
} while(0)




#define MELT_ROUTINE_STRUCT(N) {		\
  meltobject_ptr_t discr;			\
  char routdescr[MELT_ROUTDESCR_LEN];		\
  meltroutfun_t* routfunad;			\
  melt_ptr_t routdata;				\
  unsigned nbval;				\
  melt_ptr_t tabval[N];				\
  long _gap; }


/* when MELTOBMAG_PAIR */
struct 
GTY ((chain_next ("%h.tl")))
meltpair_st
{
  meltobject_ptr_t discr;
  melt_ptr_t hd;
  struct meltpair_st *tl;
};


/* when MELTOBMAG_LIST   */
struct 
GTY (())
meltlist_st
{
  meltobject_ptr_t discr;
  struct meltpair_st *first;
  struct meltpair_st *last;
};





/* when MELTOBMAG_INT -  */
struct 
GTY (())
meltint_st
{
  meltobject_ptr_t discr;
  long val;
};

/* when MELTOBMAG_MIXINT -  */
struct 
GTY (())
meltmixint_st
{
  meltobject_ptr_t discr;
  melt_ptr_t ptrval;
  long intval;
};

/* when MELTOBMAG_MIXLOC -  */
struct 
GTY (())
meltmixloc_st
{
  meltobject_ptr_t discr;
  melt_ptr_t ptrval;
  long intval;
  location_t locval;
};


/* when MELTOBMAG_MIXBIGINT - an exported array mpz compatible; since we
   use an exported mpz format, the value can be copied and trashed by
   MELT garbage collector without harm. */
struct
GTY ((variable_size))  /*@@MELTGTY@@*/
meltmixbigint_st
{
  meltobject_ptr_t discr;
  melt_ptr_t ptrval;
  bool negative;
  unsigned biglen;
  long GTY ((length ("%h.biglen"))) tabig[FLEXIBLE_DIM];			/* of length LEN */
};


/* when MELTOBMAG_REAL   */
struct 
GTY (())
meltreal_st
{
  meltobject_ptr_t discr;
  REAL_VALUE_TYPE val;
};


/* a union of special pointers which have to be explicitly deleted */
union special_melt_un
{
  /* all the pointers here have to be pointers to struct or to void,
     because the generated gtype-desc.c don't include all the files
     which define mpfr_ptr ppl_Coefficient_t etc... */
  /* generic pointer */ void *sp_pointer;
  /* stdio file */ FILE *sp_file;
  /*mpfr_ptr= */ void *sp_mpfr;
  /* malloced pointer to mpfr_t */
  ppl_Coefficient_t sp_coefficient;
  ppl_Linear_Expression_t sp_linear_expression;
  ppl_Constraint_t sp_constraint;
  ppl_Constraint_System_t sp_constraint_system;
  ppl_Generator_t sp_generator;
  ppl_Generator_System_t sp_generator_system;
  ppl_Polyhedron_t sp_polyhedron;
};

/* PPL special have to be explicitly deleted; hence we need a hook
   to mark them, an inside mark, and to maintain lists of existing
   such PPL special boxes -which we scan to delete the unmarked
   ones */
/* when MELTOBMAG_SPEC* eg MELTOBMAG_SPEC_MPFR, MELTOBMAG_SPECPPL_COEFFICIENT; etc.
    */
struct 
GTY ((mark_hook ("melt_mark_special")))
meltspecial_st
{
  meltobject_ptr_t discr;
  int mark;
  struct meltspecial_st *GTY ((skip)) nextspec;
  union special_melt_un GTY ((skip)) val;
};


static inline void
melt_mark_special (struct meltspecial_st *p)
{
  p->mark = 1;
  melt_debuggc_eprintf ("marked special %p of magic %d %s", 
			(void*)p, p->discr->object_magic, 
			melt_obmag_string (p->discr->object_magic));
}

static inline void
melt_mark_decay (struct meltdecay_st *p)
{
  /* this is tricky since it actually changes the marked data; however,
     changing pointers to NULL is ok! */
  if (p->remain <= 0)
    p->val = NULL;
  else
    p->remain--;
}

/* make a special value; return NULL if the discriminant is not
   special; all special values should be made thru this */
struct meltspecial_st* meltgc_make_special(melt_ptr_t discr);


/* when MELTOBMAG_STRING -  */
struct 
GTY ((variable_size)) /*@@MELTGTY@@*/
meltstring_st
{
  meltobject_ptr_t discr;
  char val[FLEXIBLE_DIM];	/* null terminated */
};

#define MELT_STRING_STRUCT(N) {			\
  meltobject_ptr_t discr;			\
  char val[(N)+1];	/* null terminated */	\
  long _gap; }



/* when MELTOBMAG_STRBUF - string buffers  */
struct 
GTY (())
meltstrbuf_st
{
  meltobject_ptr_t discr;
  char *GTY ((length ("1+melt_primtab[%h.buflenix]"))) bufzn;
  unsigned char buflenix;	/* allocated length index of
				   buffer */
  unsigned bufstart;
  unsigned bufend;		/* start & end useful positions */
  /* the following field is usually the value of buf (for
     objects in the young zone), to allocate the object and its fields
     at once; hence its GTY-ed length is zero */
  char GTY ((length ("0"))) buf_space[FLEXIBLE_DIM];
};

/* when MELTOBMAG_TREE - boxed tree-s  */
struct 
GTY (())
melttree_st
{
  meltobject_ptr_t discr;
  tree val;
};


/* when MELTOBMAG_GIMPLE - boxed gimple-s */
struct 
GTY (())
meltgimple_st
{
  meltobject_ptr_t discr;
  gimple val;
};


/* when MELTOBMAG_GIMPLESEQ - boxed gimple_seq-s */
struct 
GTY (())
meltgimpleseq_st
{
  meltobject_ptr_t discr;
  gimple_seq val;
};



/* when MELTOBMAG_BASICBLOCK  - boxed basic_block-s */
struct
GTY (())
meltbasicblock_st
{
  meltobject_ptr_t discr;
  basic_block val;
};

/* when MELTOBMAG_EDGE   */
struct
GTY (())
meltedge_st
{
  meltobject_ptr_t discr;
  edge val;
};


/* when MELTOBMAG_LOOP - boxed loop-s */
struct 
GTY (())
meltloop_st
{
  meltobject_ptr_t discr;
  loop_p val;
};



/* when MELTOBMAG_RTX - boxed rtx-s */
struct 
GTY (())
meltrtx_st
{
  meltobject_ptr_t discr;
  rtx val;
};


/* when MELTOBMAG_BITMAP - boxed bitmap-s */
struct 
GTY (())
meltbitmap_st
{
  meltobject_ptr_t discr;
  bitmap val;
};


/* when MELTOBMAG_RTVEC - boxed rtvec-s */
struct 
GTY (())
meltrtvec_st
{
  meltobject_ptr_t discr;
  rtvec val;
};




/*** hashed maps of objects to melt ***/
struct 
GTY (())
entryobjectsmelt_st
{
  meltobject_ptr_t e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPOBJECTS */
struct 
GTY (())
meltmapobjects_st
{
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entryobjectsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
  /* the following field is usually the value of entab (for
     objects in the young zone), to allocate the object and its fields
     at once; hence its GTY-ed length is zero */
  struct entryobjectsmelt_st GTY ((length ("0"))) map_space[FLEXIBLE_DIM];
};

/*** hashed maps of trees to melt ***/
struct
GTY (()) 
entrytreesmelt_st
{
  tree e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPTREES */
struct
GTY (())
meltmaptrees_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrytreesmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};



/*** hashed maps of gimples to melt ***/
struct
GTY (()) 
entrygimplesmelt_st
{
  gimple e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPGIMPLES */
struct
GTY (())
meltmapgimples_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrygimplesmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};


/*** hashed maps of gimpleseqs to melt ***/
struct
GTY (()) 
entrygimpleseqsmelt_st
{
  gimple_seq e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPGIMPLESEQS */
struct
GTY (()) 
meltmapgimpleseqs_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrygimpleseqsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};



/*** hashed maps of loop_p-s to melt values ***/
struct
GTY (()) 
entryloopsmelt_st
{
  loop_p e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPLOOPS */
struct
GTY (()) 
meltmaploops_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entryloopsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};



/*** hashed maps of bitmap-s to melt values ***/
struct
GTY (()) 
entrybitmapsmelt_st
{
  bitmap e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPBITMAPS */
struct
GTY (()) 
meltmapbitmaps_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrybitmapsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};




/*** hashed maps of rtx-s to melt values ***/
struct
GTY (()) 
entryrtxsmelt_st
{
  rtx e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPRTXS */
struct
GTY (()) 
meltmaprtxs_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entryrtxsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};



/*** hashed maps of rtvec-s to melt values ***/
struct
GTY (()) 
entryrtvecsmelt_st
{
  rtvec e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPRTVECS */
struct
GTY (()) 
meltmaprtvecs_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entryrtvecsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};



/*** hashed maps of strings to melt ***/
struct
GTY (()) 
entrystringsmelt_st
{
  const char *GTY (()) e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPSTRINGS */
struct
GTY (()) 
meltmapstrings_st
{
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrystringsmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};


/*** hashed maps of basicblocks to melt ***/

struct
GTY (()) 
entrybasicblocksmelt_st
{
  basic_block e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPBASICBLOCKS */
struct
GTY (())
meltmapbasicblocks_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entrybasicblocksmelt_st
    *GTY ((length ("melt_primtab[%h.lenix]"))) entab;
};

/*** hashed maps of edges to melt ***/
struct
GTY (())
entryedgesmelt_st
{
  edge e_at;
  melt_ptr_t e_va;
};

/* when MELTOBMAG_MAPEDGES */
struct
GTY (()) 
meltmapedges_st
{
  /* change meltmappointers_st when changing this structure */
  meltobject_ptr_t discr;
  unsigned count;
  unsigned char lenix;
  struct entryedgesmelt_st *GTY ((length ("melt_primtab[%h.lenix]")))
    entab;
};


/**** our union for everything ***/
/* never use an array of melt_un, only array of pointers melt_ptr_t */
typedef union
GTY ((desc ("%0.u_discr->object_magic"))) 
melt_un
{
  meltobject_ptr_t GTY ((skip)) u_discr;
  struct meltforward_st GTY ((skip)) u_forward;
  struct meltobject_st GTY ((tag ("MELTOBMAG_OBJECT"))) u_object;
  struct meltbox_st GTY ((tag ("MELTOBMAG_BOX"))) u_box;
  struct meltdecay_st GTY ((tag ("MELTOBMAG_DECAY"))) u_decay;
  struct meltmultiple_st GTY ((tag ("MELTOBMAG_MULTIPLE"))) u_multiple;
  struct meltclosure_st GTY ((tag ("MELTOBMAG_CLOSURE"))) u_closure;
  struct meltroutine_st GTY ((tag ("MELTOBMAG_ROUTINE"))) u_routine;
  struct meltlist_st GTY ((tag ("MELTOBMAG_LIST"))) u_list;
  struct meltint_st GTY ((tag ("MELTOBMAG_INT"))) u_int;
  struct meltmixint_st GTY ((tag ("MELTOBMAG_MIXINT"))) u_mixint;
  struct meltmixloc_st GTY ((tag ("MELTOBMAG_MIXLOC"))) u_mixloc;
  struct meltmixbigint_st GTY ((tag ("MELTOBMAG_MIXBIGINT"))) u_mixbigint;
  struct meltreal_st GTY ((tag ("MELTOBMAG_REAL"))) u_real;
  struct meltpair_st GTY ((tag ("MELTOBMAG_PAIR"))) u_pair;
  /* The struct meltspecial_st share several GTY tag-s, but gengtype
     need to have one case per tag!  See
     http://gcc.gnu.org/ml/gcc/2010-07/msg00061.html for more. */
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPEC_FILE"))) u_special_file;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPEC_RAWFILE"))) u_special_rawfile;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPEC_MPFR"))) u_special_mpfr;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_COEFFICIENT"))) u_special_ppl_coefficient;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_LINEAR_EXPRESSION"))) u_special_ppl_linear_expression;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_CONSTRAINT"))) u_special_ppl_constraint;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM"))) u_special_ppl_constraint_system;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_GENERATOR"))) u_special_ppl_generator;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_GENERATOR_SYSTEM"))) u_special_ppl_generator_system;
  struct meltspecial_st GTY ((tag ("MELTOBMAG_SPECPPL_POLYHEDRON"))) u_special_ppl_polyhedron;
  /* for simplicity and compatibility with previous code, we can just write u_special! */
  struct meltspecial_st  GTY ((skip)) u_special;
  struct meltstring_st GTY ((tag ("MELTOBMAG_STRING"))) u_string;
  struct meltstrbuf_st GTY ((tag ("MELTOBMAG_STRBUF"))) u_strbuf;
  struct melttree_st GTY ((tag ("MELTOBMAG_TREE"))) u_tree;
  struct meltgimple_st GTY ((tag ("MELTOBMAG_GIMPLE"))) u_gimple;
  struct meltgimpleseq_st GTY ((tag ("MELTOBMAG_GIMPLESEQ"))) u_gimpleseq;
  struct meltbasicblock_st GTY ((tag ("MELTOBMAG_BASICBLOCK"))) u_basicblock;
  struct meltedge_st GTY ((tag ("MELTOBMAG_EDGE"))) u_edge;
  struct meltloop_st GTY ((tag ("MELTOBMAG_LOOP"))) u_loop;
  struct meltbitmap_st GTY ((tag ("MELTOBMAG_BITMAP"))) u_bitmap;
  struct meltrtx_st GTY ((tag ("MELTOBMAG_RTX"))) u_rtx;
  struct meltrtvec_st GTY ((tag ("MELTOBMAG_RTVEC"))) u_rtvec;
  struct meltmapobjects_st GTY ((tag ("MELTOBMAG_MAPOBJECTS"))) u_mapobjects;
  struct meltmapstrings_st GTY ((tag ("MELTOBMAG_MAPSTRINGS"))) u_mapstrings;
  struct meltmaptrees_st GTY ((tag ("MELTOBMAG_MAPTREES"))) u_maptrees;
  struct meltmapgimples_st GTY ((tag ("MELTOBMAG_MAPGIMPLES"))) u_mapgimples;
  struct meltmapgimpleseqs_st GTY ((tag ("MELTOBMAG_MAPGIMPLESEQS"))) u_mapgimpleseqs;
  struct meltmapbasicblocks_st GTY ((tag ("MELTOBMAG_MAPBASICBLOCKS"))) u_mapbasicblocks;
  struct meltmapedges_st GTY ((tag ("MELTOBMAG_MAPEDGES"))) u_mapedges;
  struct meltmaploops_st GTY ((tag ("MELTOBMAG_MAPLOOPS"))) u_maploops;
  struct meltmapbitmaps_st GTY ((tag ("MELTOBMAG_MAPBITMAPS"))) u_mapbitmaps;
  struct meltmaprtxs_st GTY ((tag ("MELTOBMAG_MAPRTXS"))) u_maprtxs;
  struct meltmaprtvecs_st GTY ((tag ("MELTOBMAG_MAPRTVECS"))) u_maprtvecs;
} melt_un_t;

/* return the magic of the discriminant or 0 */
static inline int
melt_magic_discr (melt_ptr_t p)
{
  if (!p ||  !p->u_discr)
    return 0;
  return p->u_discr->object_magic;
}

/* likewise, but without testing for null */
static inline int
melt_unsafe_magic_discr (melt_ptr_t p)
{
  return p->u_discr->object_magic;
}

/* test if a pointer is an output - either a string buffer or a file */
static inline bool
melt_is_out (melt_ptr_t p)
{
  int d = melt_magic_discr(p);
  return d == MELTOBMAG_STRBUF || d == MELTOBMAG_SPEC_FILE || d == MELTOBMAG_SPEC_RAWFILE;
}

/* test if a pointer is a file */
static inline bool
melt_is_file (melt_ptr_t p)
{
  int d = melt_magic_discr(p);
  return d == MELTOBMAG_SPEC_FILE || d == MELTOBMAG_SPEC_RAWFILE;
}


/* return the nth of a multiple (starting from 0) */
static inline melt_ptr_t
melt_multiple_nth (melt_ptr_t mul, int n)
{
  if (!mul || ((meltmultiple_ptr_t)mul)->discr->object_magic != MELTOBMAG_MULTIPLE)
    return NULL;
  if (n >= 0 && n < (int) ((meltmultiple_ptr_t)mul)->nbval)
    return ((meltmultiple_ptr_t)mul)->tabval[n];
  else if (n < 0 && n + (int) ((meltmultiple_ptr_t)mul)->nbval >= 0)
    return ((meltmultiple_ptr_t)mul)->tabval[n + ((meltmultiple_ptr_t)mul)->nbval];
  return NULL;
}

/* set the nth of a multiple (but beware of circularities!) */
void meltgc_multiple_put_nth (melt_ptr_t mul, int n,
				 melt_ptr_t val);

/* return the length of a multiple */
static inline int
melt_multiple_length (melt_ptr_t mul)
{
  if (!mul || ((meltmultiple_ptr_t)mul)->discr->object_magic != MELTOBMAG_MULTIPLE)
    return 0;
  return ((meltmultiple_ptr_t)mul)->nbval;
}

/* test if something is a tuple of a given length or bigger */
static inline bool
melt_is_multiple_at_least(melt_ptr_t mul, int ln)
{
  if (!mul || ln<0 || ((meltmultiple_ptr_t)mul)->discr->object_magic != MELTOBMAG_MULTIPLE) return 0;
  return  (int)((meltmultiple_ptr_t)mul)->nbval >= (int)ln;
}

/* test if something is a tuple of an exactly given length */
static inline bool
melt_is_multiple_of_length(melt_ptr_t mul, int ln)
{
  if (!mul || ln<0 || ((meltmultiple_ptr_t)mul)->discr->object_magic != MELTOBMAG_MULTIPLE) return 0;
  return  (int)((meltmultiple_ptr_t)mul)->nbval == (int)ln;
}

/* sort a multiple MUL using as compare function the closure CMPCLO
   which should return a boxed integer (0 for equality, <0 for less
   than, >0 for greater than), when applied to two values to
   compare. If the closure does not return an integer the whole sort
   returns null; otherwise it returns a new multiple value of
   discriminant DISCRM */
melt_ptr_t
meltgc_sort_multiple(melt_ptr_t mult_p, melt_ptr_t clo_p, melt_ptr_t discrm_p); 


/* allocate a new box of given DISCR & content VAL */
melt_ptr_t meltgc_new_box (meltobject_ptr_t discr_p,
				 melt_ptr_t val_p);

/* return the content of a box */
static inline melt_ptr_t
melt_box_content (meltbox_ptr_t box)
{
  if (!box || box->discr->object_magic != MELTOBMAG_BOX)
    return NULL;
  return box->val;
}

void meltgc_box_put (melt_ptr_t box, melt_ptr_t val);

/* safely return the calue inside a container - instance of CLASS_CONTAINER */
melt_ptr_t
melt_container_value  (melt_ptr_t cont);


void *meltgc_raw_new_mappointers (meltobject_ptr_t discr_p,
				     unsigned len);

void
meltgc_raw_put_mappointers (void *mappointer_p,
			       const void *attr, melt_ptr_t valu_p);

melt_ptr_t
melt_raw_get_mappointers (void *mappointer_p, const void *attr);

melt_ptr_t
meltgc_raw_remove_mappointers (void *mappointer_p, const void *attr);


/* big macro to implement a mapFOOs */
#define MELT_DEFINE_MAPTR(Meltobmag,Ptyp,Mapstruct,Newf,Getf,Putf,Removef,Countf,Sizef,Nthattrf,Nthvalf) \
									\
static inline melt_ptr_t						\
Newf (meltobject_ptr_t discr, unsigned len)				\
{									\
  if (melt_magic_discr ((melt_ptr_t) discr) != MELTOBMAG_OBJECT)		\
    return NULL;							\
  if (discr->object_magic != Meltobmag)					\
    return NULL;							\
  return (melt_ptr_t) meltgc_raw_new_mappointers (discr, len);		\
}									\
									\
static inline melt_ptr_t						\
Getf (melt_ptr_t map_p, Ptyp attr)					\
{									\
  if (melt_magic_discr ((melt_ptr_t) map_p) != Meltobmag || !attr)		\
    return NULL;							\
  return melt_raw_get_mappointers (map_p, attr);			\
}									\
									\
static inline void							\
Putf (struct Mapstruct *map_p,						\
	Ptyp attr, melt_ptr_t valu_p)					\
{									\
  if (melt_magic_discr ((melt_ptr_t) map_p) != Meltobmag			\
      || !attr || !valu_p)						\
    return;								\
  meltgc_raw_put_mappointers (map_p, attr, valu_p);			\
}									\
									\
static inline melt_ptr_t						\
Removef (struct Mapstruct *map, Ptyp attr)				\
{									\
  if (melt_magic_discr ((melt_ptr_t) map) != Meltobmag || !attr)		\
    return NULL;							\
  return meltgc_raw_remove_mappointers (map, attr);			\
}									\
									\
static inline unsigned							\
Countf (struct Mapstruct* map_p)					\
{									\
  if (!map_p || map_p->discr->obj_num != Meltobmag)				\
    return 0;								\
  return map_p->count;							\
}									\
									\
static inline int							\
Sizef (struct Mapstruct* map_p)						\
{									\
  if (!map_p || map_p->discr->obj_num != Meltobmag)				\
    return 0;								\
  return melt_primtab[map_p->lenix];					\
}									\
									\
static inline Ptyp							\
Nthattrf(struct Mapstruct* map_p, int ix)				\
{									\
  Ptyp at = 0;								\
  if (!map_p || map_p->discr->obj_num != Meltobmag)				\
    return 0;								\
  if (ix < 0 || ix >= melt_primtab[map_p->lenix])			\
    return 0;								\
  at = map_p->entab[ix].e_at;						\
  if ((void *) at == (void *) HTAB_DELETED_ENTRY)			\
    return 0;								\
  return at;								\
}									\
									\
static inline melt_ptr_t						\
Nthvalf(struct Mapstruct* map_p, int ix)				\
{									\
  Ptyp at = 0;								\
  if (!map_p || map_p->discr->obj_num != Meltobmag)				\
    return 0;								\
  if (ix < 0 || ix >= melt_primtab[map_p->lenix])			\
    return 0;								\
  at = map_p->entab[ix].e_at;						\
  if (!at || (void *) at == (void *) HTAB_DELETED_ENTRY)		\
    return 0;								\
  return map_p->entab[ix].e_va;					        \
}

/* end of MELT_DEFINE_MAPTR macro */

MELT_DEFINE_MAPTR(MELTOBMAG_MAPTREES, tree, meltmaptrees_st,
		      meltgc_new_maptrees,
		      melt_get_maptrees,
		      melt_put_maptrees,
		      melt_remove_maptrees,
		      melt_count_maptrees,
		      melt_size_maptrees,
		      melt_nthattr_maptrees,
		      melt_nthval_maptrees)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPGIMPLES, gimple, meltmapgimples_st,
		      meltgc_new_mapgimples,
		      melt_get_mapgimples,
		      melt_put_mapgimples,
		      melt_remove_mapgimples,
		      melt_count_mapgimples,
		      melt_size_mapgimples,
		      melt_nthattr_mapgimples,
		      melt_nthval_mapgimples)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPGIMPLESEQS, gimple_seq, meltmapgimpleseqs_st,
		      meltgc_new_mapgimpleseqs,
		      melt_get_mapgimpleseqs,
		      melt_put_mapgimpleseqs,
		      melt_remove_mapgimpleseqs,
		      melt_count_mapgimpleseqs,
		      melt_size_mapgimpleseqs,
		      melt_nthattr_mapgimpleseqs,
		      melt_nthval_mapgimpleseqs)


MELT_DEFINE_MAPTR(MELTOBMAG_MAPEDGES, edge, meltmapedges_st,
		      meltgc_new_mapedges,
		      melt_get_mapedges,
		      melt_put_mapedges,
		      melt_remove_mapedges,
		      melt_count_mapedges,
		      melt_size_mapedges,
		      melt_nthattr_mapedges,
		      melt_nthval_mapedges)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPBASICBLOCKS, basic_block, meltmapbasicblocks_st,
		      meltgc_new_mapbasicblocks,
		      melt_get_mapbasicblocks,
		      melt_put_mapbasicblocks,
		      melt_remove_mapbasicblocks,
		      melt_count_mapbasicblocks,
		      melt_size_mapbasicblocks,
		      melt_nthattr_mapbasicblocks,
		      melt_nthval_mapbasicblocks)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPLOOPS, loop_p, meltmaploops_st,
		      meltgc_new_maploops,
		      melt_get_maploops,
		      melt_put_maploops,
		      melt_remove_maploops,
		      melt_count_maploops,
		      melt_size_maploops,
		      melt_nthattr_maploops,
		      melt_nthval_maploops)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPRTXS, rtx, meltmaprtxs_st,
		      meltgc_new_maprtxs,
		      melt_get_maprtxs,
		      melt_put_maprtxs,
		      melt_remove_maprtxs,
		      melt_count_maprtxs,
		      melt_size_maprtxs,
		      melt_nthattr_maprtxs,
		      melt_nthval_maprtxs)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPRTVECS, rtvec, meltmaprtvecs_st,
		      meltgc_new_maprtvecs,
		      melt_get_maprtvecs,
		      melt_put_maprtvecs,
		      melt_remove_maprtvecs,
		      melt_count_maprtvecs,
		      melt_size_maprtvecs,
		      melt_nthattr_maprtvecs,
		      melt_nthval_maprtvecs)

MELT_DEFINE_MAPTR(MELTOBMAG_MAPBITMAPS, bitmap, meltmapbitmaps_st,
		      meltgc_new_mapbitmaps,
		      melt_get_mapbitmaps,
		      melt_put_mapbitmaps,
		      melt_remove_mapbitmaps,
		      melt_count_mapbitmaps,
		      melt_size_mapbitmaps,
		      melt_nthattr_mapbitmaps,
		      melt_nthval_mapbitmaps)


/* do not use MELT_DEFINE_MAPTR elsewhere */
#undef MELT_DEFINE_MAPTR

/* allocate a new boxed tree of given DISCR [DISCR_TREE if null] &
   content VAL */
melt_ptr_t meltgc_new_tree (meltobject_ptr_t discr_p,
				 tree val);

/* return the content of a boxed tree */
static inline tree
melt_tree_content (melt_ptr_t box)
{
  struct melttree_st* tr = (struct melttree_st*)box;
  if (!tr || tr->discr->object_magic != MELTOBMAG_TREE)
    return NULL;
  return tr->val;
}

/* allocate a new boxed gimple of given DISCR [DISCR_GIMPLE if null] &
   content VAL */
melt_ptr_t meltgc_new_gimple (meltobject_ptr_t discr_p,
				    gimple val);

/* return the content of a boxed gimple */
static inline gimple
melt_gimple_content (melt_ptr_t box)
{
  struct meltgimple_st* g = (struct meltgimple_st*)box;
  if (!g || g->discr->object_magic != MELTOBMAG_GIMPLE)
    return NULL;
  return g->val;
}

/* allocate a new boxed gimpleseq of given DISCR [DISCR_GIMPLESEQ if null] &
   content VAL */
melt_ptr_t meltgc_new_gimpleseq (meltobject_ptr_t discr_p,
				    gimple_seq val);

/* return the content of a boxed gimple_seq */
static inline gimple_seq
melt_gimpleseq_content (melt_ptr_t box)
{
  struct meltgimpleseq_st* g = (struct meltgimpleseq_st*)box;
  if (!g || g->discr->object_magic != MELTOBMAG_GIMPLESEQ)
    return NULL;
  return g->val;
}




/* allocate a new boxed basicblock of given DISCR [DISCR_BASICBLOCK if null] &
   content VAL */
melt_ptr_t meltgc_new_basicblock (meltobject_ptr_t discr_p,
					basic_block val);

/* return the content of a boxed gimple */
static inline basic_block
melt_basicblock_content (melt_ptr_t box)
{
  struct meltbasicblock_st* b = (struct meltbasicblock_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_BASICBLOCK)
    return NULL;
  return b->val;
}

/* return the seq of a boxed basicblock */
static inline gimple_seq
melt_basicblock_gimpleseq(melt_ptr_t box)
{
  struct meltbasicblock_st* b = (struct meltbasicblock_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_BASICBLOCK || !b->val)
    return NULL;
  return bb_seq(b->val);
}

/* return the phinodes of a boxed basicblock */
static inline gimple_seq
melt_basicblock_phinodes(melt_ptr_t box)
{
  struct meltbasicblock_st* b = (struct meltbasicblock_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_BASICBLOCK || !b->val)
    return NULL;
  return phi_nodes(b->val);
}


/***** basic support of loops ****/
/* allocate a new boxed loop of given DISCR [DISCR_LOOP if null] &
   content VAL */
melt_ptr_t meltgc_new_loop (meltobject_ptr_t discr_p,
			    loop_p val);

/* return the content of a boxed loop */
static inline loop_p
melt_loop_content (melt_ptr_t box)
{
  struct meltloop_st* b = (struct meltloop_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_LOOP)
    return NULL;
  return b->val;
}


/***** basic support of bitmaps ****/
/* allocate a new boxed bitmap of given DISCR [DISCR_BITMAP if null] &
   content VAL */
melt_ptr_t meltgc_new_bitmap (meltobject_ptr_t discr_p,
			      bitmap val);

/* return the content of a boxed bitmap */
static inline bitmap
melt_bitmap_content (melt_ptr_t box)
{
  struct meltbitmap_st* b = (struct meltbitmap_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_BITMAP)
    return NULL;
  return b->val;
}



/***** basic support of rtxs ****/
/* allocate a new boxed rtx of given DISCR [DISCR_RTX if null] &
   content VAL */
melt_ptr_t meltgc_new_rtx (meltobject_ptr_t discr_p,
			    rtx val);

/* return the content of a boxed rtx */
static inline rtx
melt_rtx_content (melt_ptr_t box)
{
  struct meltrtx_st* b = (struct meltrtx_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_RTX)
    return NULL;
  return b->val;
}


/***** basic support of rtvecs ****/
/* allocate a new boxed rtvec of given DISCR [DISCR_RTVEC if null] &
   content VAL */
melt_ptr_t meltgc_new_rtvec (meltobject_ptr_t discr_p,
			    rtvec val);

/* return the content of a boxed rtvec */
static inline rtvec
melt_rtvec_content (melt_ptr_t box)
{
  struct meltrtvec_st* b = (struct meltrtvec_st*)box;
  if (!b || b->discr->object_magic != MELTOBMAG_RTVEC)
    return NULL;
  return b->val;
}




/*************************************************************
 * young generation copying garbage collector 
 *
 * the young generation is managed specifically by an additional
 * copying garbage collector, which copies melt_ptr_t data into the
 * GGC heap from a young region.  This requires that every local
 * variable is known to our copying melt GC. For that purpose,
 * locals are copied (or used) inside a chain of callframe_melt_st
 * structures. Since our copying GC change pointers, every allocation
 * or call may change all the frames. Also stores inside data should
 * be explicitly managed in a store list
 *
 * the young allocation zone is typically of a few megabytes when it
 * is full, a minor garbage collection occur (and possibly a full GGC
 * collection afterwards) which changes all the locals
 *************************************************************/

/* start and end of young allocation zone */
extern void *melt_startalz;
extern void *melt_endalz;
/* current allocation pointer aligned */
extern char *melt_curalz;
/* the store vector grows downward */
extern void **melt_storalz;
/* list of specials in the allocation zone */
extern struct meltspecial_st *melt_newspeclist;
/* list of specials in the heap */
extern struct meltspecial_st *melt_oldspeclist;
/* kilowords allocated since last full collection */
extern unsigned long melt_kilowords_sincefull;
/* number of full & any melt garbage collections */
extern unsigned long melt_nb_full_garbcoll;
extern unsigned long melt_nb_garbcoll;

extern bool melt_prohibit_garbcoll;

extern bool melt_is_forwarding;

#define MELT_FORWARDED_DISCR (meltobject_ptr_t)1
melt_ptr_t melt_forwarded_copy (melt_ptr_t);


static inline bool
melt_is_young (const void *const p)
{
  return (const char * const) p >= (const char * const) melt_startalz
    && (const char * const) p < (const char * const) melt_endalz;
}

static inline void *
melt_forwarded (void *ptr)
{
  melt_ptr_t p = (melt_ptr_t) ptr;
  if (p && melt_is_young (p))
    {
      if (p->u_discr == MELT_FORWARDED_DISCR)
	p = ((struct meltforward_st *) p)->forward;
      else
	p = melt_forwarded_copy (p);
    }
  return p;
}

#if GCC_VERSION > 4000
#define MELT_FORWARDED(P) do {if (P) { \
  (P) = (__typeof__(P))melt_forwarded((void*)(P));} } while(0)
#else
#define MELT_FORWARDED(P) do {if (P) { 		       		\
  (P) = (melt_ptr_t)melt_forwarded((melt_ptr_t)(P));} }  while(0)
#endif /*GCC_VERSION*/

/* the MELT copying garbage collector routine - moves all locals on
   the stack!  Minor GC is only moving, Minor or Full chooses either
   minor or full appropriately, and Full GC is the minor one followed by
   GCC garbage collector Ggc. */
enum melt_gckind_en
  { MELT_ONLY_MINOR= 0, MELT_MINOR_OR_FULL = 1, MELT_NEED_FULL = 2};
void melt_garbcoll (size_t wanted, enum melt_gckind_en gckd);

/* the alignment */
#if defined(__GNUC__) && !defined(__STRICT_ANSI__)
#define MELT_ALIGN (__alignof__(union melt_un))
#define MELT_LIKELY(P) __builtin_expect((P),1)
#define MELT_UNLIKELY(P) __builtin_expect((P),0)
#else
#define MELT_ALIGN (2*sizeof(void*))
#define MELT_LIKELY(P) (P)
#define MELT_UNLIKELY(P) (P)
#endif



#if ENABLE_CHECKING
/* to ease debugging we sometimes want to know when some pointer is
   allocated: set these variables in the debugger */
static void* tracedptr1;
static void* tracedptr2;

#endif

/* the allocator routine allocates a zone of BASESZ with extra GAP */
static inline void *
meltgc_allocate (size_t basesz, size_t gap)
{
  size_t wanted;
  void *ptr;
  if (basesz < sizeof (struct meltforward_st))
    basesz = sizeof (struct meltforward_st);
  if ((basesz % MELT_ALIGN) != 0)
    basesz += (MELT_ALIGN - (basesz % MELT_ALIGN));
  if ((gap % MELT_ALIGN) != 0)
    gap += (MELT_ALIGN - (gap % MELT_ALIGN));
  wanted = basesz + gap;
  gcc_assert (wanted >= sizeof (struct meltforward_st));
  if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN
			>= (char *) melt_storalz))
    melt_garbcoll (wanted, MELT_MINOR_OR_FULL);
  ptr = melt_curalz;
#if ENABLE_CHECKING
  if (ptr == tracedptr1)
    debugeprintf("allocated tracedptr1 %p", ptr);
  else if (ptr == tracedptr2)
    debugeprintf("allocated tracedptr2 %p", ptr);
#endif
  melt_curalz += wanted;
  return ptr;
}

/* we need sometimes to reserve some wanted size in the allocation
   zone without actaully using it now; this is needed for the few
   melt data structures, e.g. meltstrbuf_st, which have some
   content (e.g. the buffer zone itself bufzn) which should be kept
   young if the datastructure is young, and should become old (ie. GGC
   allocated) when it becomes old */
static inline void
meltgc_reserve(size_t wanted) 
{
  if (wanted < 100*sizeof(void*) + sizeof(struct meltforward_st))
    wanted = 100*sizeof(void*) + sizeof(struct meltforward_st);
  if ((wanted  % MELT_ALIGN) != 0)
    wanted += (MELT_ALIGN - (wanted % MELT_ALIGN));
  if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN
			>= (char *) melt_storalz))
    melt_garbcoll (wanted, MELT_MINOR_OR_FULL);
}

/* we need a function to detect failure in reserved allocation; this
   melt_reserved_allocation_failure function should never be
   called; we do not want to use fatal_error which requires toplev.h
   inclusion; never call this function outside of
   melt_allocatereserved */
void melt_reserved_allocation_failure(long siz);

/*  allocates a previously reserved zone of BASESZ with extra GAP;
    this should never trigger the GC, because space was reserved
    earlier */
static inline void *
melt_allocatereserved (size_t basesz, size_t gap)
{
  size_t wanted;
  void *ptr;
  if (basesz < sizeof (struct meltforward_st))
    basesz = sizeof (struct meltforward_st);
  if ((basesz % MELT_ALIGN) != 0)
    basesz += (MELT_ALIGN - (basesz % MELT_ALIGN));
  if ((gap % MELT_ALIGN) != 0)
    gap += (MELT_ALIGN - (gap % MELT_ALIGN));
  wanted = basesz + gap;
  gcc_assert (wanted >= sizeof (struct meltforward_st));
  if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN
			>= (char *) melt_storalz))
    /* this should never happen */
    melt_reserved_allocation_failure((long) wanted);
  ptr = melt_curalz;
#if ENABLE_CHECKING
  if (ptr == tracedptr1)
    debugeprintf("allocated tracedptr1 %p", ptr);
  else if (ptr == tracedptr2)
    debugeprintf("allocated tracedptr2 %p", ptr);
#endif
  melt_curalz += wanted;
  return ptr;
}

/* we maintain a small cache hasharray of touched values - the touched
   cache size should be a small prime */
#define MELT_TOUCHED_CACHE_SIZE 17
extern void *melt_touched_cache[MELT_TOUCHED_CACHE_SIZE];
/* the touching routine should be called on every melt value which
   has been touched (by mutating one of its internal pointers) - it
   may add the touched value to the store "array" and may trigger our
   melt copying garbage collector */
static inline void
meltgc_touch (void *touchedptr)
{
  /* we know that this may loose -eg on some 64bits hosts- some
     highend bits of the pointer but we don't care, since the 32
     lowest bits are enough (as hash); we need a double cast to avoid
     a warning */
  unsigned pad = (unsigned) (HOST_WIDE_INT) touchedptr;
  if ((char *) touchedptr >= (char *) melt_startalz
      && (char *) touchedptr <= (char *) melt_endalz)
    return;
  pad = pad % (unsigned) MELT_TOUCHED_CACHE_SIZE;
  if (melt_touched_cache[pad] == touchedptr)
    return;
  *melt_storalz = touchedptr;
  melt_storalz--;
  melt_touched_cache[pad] = touchedptr;
  if (MELT_UNLIKELY
      ((char *) ((void **) melt_storalz - 3) <= (char *) melt_curalz))
    melt_garbcoll (1024 * sizeof (void *) +
		      ((char *) melt_endalz - (char *) melt_storalz),
		      MELT_MINOR_OR_FULL);
}

/* we can avoid the hassle of adding a touched pointer to the store
   list if we know that the newly added pointer inside does not point
   into the new allocation zone; TOUCHEDPTR is the mutated value and
   DSTPTR is the newly added pointer insided */
static inline void
meltgc_touch_dest (void *touchedptr, void *destptr)
{
  /* if we add an old pointer we don't care */
  if (!melt_is_young(destptr))
    return;
  meltgc_touch (touchedptr);
}






/* low level map routines */


/***
 * allocation routines that may trigger a garbage collection 
 * (their name starts with meltgc)
 ***/

/* allocate a boxed long integer (or null if bad DISCR) fillen with NUM */
melt_ptr_t meltgc_new_int (meltobject_ptr_t discr, long num);

/* Retrieve an integer from a boxed integer or mixnumbers.  */
static inline long
melt_get_int (melt_ptr_t v)
{
  switch (melt_magic_discr (v))
    {
    case MELTOBMAG_INT:
      return ((struct meltint_st *) (v))->val;
    case MELTOBMAG_MIXINT:
      return ((struct meltmixint_st *) (v))->intval;
    case MELTOBMAG_MIXLOC:
      return ((struct meltmixloc_st *) (v))->intval;
    case MELTOBMAG_OBJECT:
      return ((meltobject_ptr_t) (v))->obj_num;
    default:
      return 0;
    }
}


/* Make a boxed real from a real value.  If discr is NULL, use DISCR_REAL.  */
melt_ptr_t meltgc_new_real(meltobject_ptr_t discr, REAL_VALUE_TYPE r);

/* Unbox real value. It returns 0 if not a boxed real.  */
static inline REAL_VALUE_TYPE
melt_get_real (melt_ptr_t v)
{
    if (melt_magic_discr (v) == MELTOBMAG_REAL)
       return ((struct meltreal_st*) v)->val;
    return dconst0;
}
 

static inline long
melt_obj_hash (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_OBJECT)
    return ((meltobject_ptr_t) (v))->obj_hash;
  return 0;
}

/* obsolete function */
static inline unsigned long
melt_obj_serial (melt_ptr_t v ATTRIBUTE_UNUSED)
{
  return 0;
}


static inline long
melt_obj_len (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_OBJECT)
    return ((meltobject_ptr_t) (v))->obj_len;
  return 0;
}

static inline long
melt_obj_num (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_OBJECT)
    return ((meltobject_ptr_t) (v))->obj_num;
  return 0;
}

/* safe integer div & mod */
static inline long
melt_idiv (long i, long j)
{
  return (j != 0) ? (i / j) : 0;
}
static inline long
melt_imod (long i, long j)
{
  return (j != 0) ? (i % j) : 0;
}



/* allocate a boxed mixed integer & value) */
melt_ptr_t
meltgc_new_mixint (meltobject_ptr_t discr_p, melt_ptr_t val_p,
		      long num);
/* allocate a boxed mixed location */
melt_ptr_t
meltgc_new_mixloc (meltobject_ptr_t discr_p, melt_ptr_t val_p,
		      long num, location_t loc);

/* get the boxed value of a mixint */
static inline melt_ptr_t
melt_val_mixint (melt_ptr_t mix)
{
  struct meltmixint_st *smix = (struct meltmixint_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXINT)
    return smix->ptrval;
  return NULL;
}
/* get the boxed value of a mixbigint */
static inline melt_ptr_t
melt_val_mixbigint (melt_ptr_t mix)
{
  struct meltmixbigint_st *smix = (struct meltmixbigint_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXBIGINT)
    return smix->ptrval;
  return NULL;
}

static inline long
melt_num_mixint (melt_ptr_t mix)
{
  struct meltmixint_st *smix = (struct meltmixint_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXINT)
    return smix->intval;
  return 0;
}

static inline long
melt_num_mixloc (melt_ptr_t mix)
{
  struct meltmixloc_st *smix = (struct meltmixloc_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXLOC)
    return smix->intval;
  return 0;
}

static inline melt_ptr_t
melt_val_mixloc (melt_ptr_t mix)
{
  struct meltmixloc_st *smix = (struct meltmixloc_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXLOC)
    return smix->ptrval;
  return NULL;
}


static inline location_t
melt_location_mixloc (melt_ptr_t mix)
{
  struct meltmixloc_st *smix = (struct meltmixloc_st *) mix;
  if (melt_magic_discr (mix) == MELTOBMAG_MIXLOC)
    return smix->locval;
  return (location_t)UNKNOWN_LOCATION;
}

/* allocate a mixbigint from a GMP biginteger */
melt_ptr_t meltgc_new_mixbigint_mpz (meltobject_ptr_t discr_p,
					   melt_ptr_t val_p, mpz_t mp);

/* fill an mpz from a mixbigint and return true iff ok */
static inline bool 
melt_fill_mpz_from_mixbigint(melt_ptr_t mix, mpz_t mp)
{
  struct meltmixbigint_st *bmix = (struct meltmixbigint_st *) mix;
  if (!bmix || !mp || melt_magic_discr (mix) != MELTOBMAG_MIXBIGINT)
    return false;
  mpz_import (mp, bmix->biglen,
	      /*most significant word first*/ 1, 
	      sizeof(bmix->tabig[0]), 
	      /*native endian*/ 0, 
	      /*no nails bits*/0, 
	      bmix->tabig);
  return true;
}

/* get (safely) the nth (counting from 0) field of an object */
static inline melt_ptr_t
melt_field_object (melt_ptr_t ob, unsigned off)
{
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (off < pob->obj_len)
	return pob->obj_vartab[off];
    };
  return NULL;
}

/* allocate a new raw object of given KLASS (unchecked) with LEN slots */
meltobject_ptr_t meltgc_new_raw_object (meltobject_ptr_t klass_p,
					      unsigned len);


/* melt diagnostic routine */
void melt_error_str(melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p);
void melt_warning_str(int opt, melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p);
void melt_inform_str(melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p);

int* melt_dynobjstruct_fieldoffset_at(const char*fldnam, const char*fil, int lin);
int* melt_dynobjstruct_classlength_at(const char*clanam, const char* fil, int lin);

#if MELTGCC_DYNAMIC_OBJSTRUCT

static inline melt_ptr_t
melt_dynobjstruct_getfield_object_at (melt_ptr_t ob, unsigned off, const char*fldnam, const char*fil, int lin, int**poff)
{
  unsigned origoff = off;
  if (poff && !*poff) 
    *poff = melt_dynobjstruct_fieldoffset_at(fldnam, fil, lin);
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (poff && *poff) off = **poff;
      if (off < pob->obj_len)
	return pob->obj_vartab[off];
      error ("checked dynamic field access failed (bad offset %d/%d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, (int)origoff, fil, lin, fldnam?fldnam:"...");
      return NULL;
    }
  error ("checked dynamic field access failed (not object [%s:%d]) - %s", fil, lin, fldnam?fldnam:"...");
  return NULL;
}

#define melt_object_get_field_at(Slot,Obj,Off,Fldnam,Fil,Lin) do {	\
  static int *offptr_##Lin;						\
  Slot =								\
    melt_dynobjstruct_getfield_object_at((melt_ptr_t)(Obj),	\
					    (Off),Fldnam,Fil,Lin,	\
					    &offptr_##Lin);		\
} while(0)

#define melt_object_get_field(Slot,Obj,Off,Fldnam) \
  melt_object_get_field_at(Slot,Obj,Off,Fldnam,__FILE__,__LINE__)

#define melt_getfield_object(Obj,Off,Fldnam)				\
    melt_dynobjstruct_getfield_object_at((melt_ptr_t)(Obj),	\
					    (Off),Fldnam,__FILE__,	\
                                            __LINE__,			\
					    (int**)0)

static inline void 
melt_dynobjstruct_putfield_object_at(melt_ptr_t ob, unsigned off, melt_ptr_t val, const char*fldnam, const char*fil, int lin, int**poff)
{
  unsigned origoff = off;
  if (poff && !*poff) 
    *poff = melt_dynobjstruct_fieldoffset_at(fldnam, fil, lin);
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (poff && *poff) off = **poff;
      if (off < pob->obj_len) {
	pob->obj_vartab[off] = val;
	return;
      }
      error ("checked dynamic field put failed (bad offset %d/%d/%d [%s:%d]) - %s",
	     (int)off, (int)pob->obj_len, (int)origoff, fil, lin, fldnam?fldnam:"...");
      return;
    }
  error ("checked dynamic field put failed (not object [%s:%d]) - %s", fil, lin, fldnam?fldnam:"...");
}

#define melt_putfield_object_at(Obj,Off,Val,Fldnam,Fil,Lin) do {	\
  static int* ptroff_##Lin;						\
  melt_dynobjstruct_putfield_object_at((melt_ptr_t)(Obj),		\
					  (Off),			\
					  (melt_ptr_t)(Val),Fldnam,  \
					  Fil,Lin,			\
					  &ptroff_##Lin); } while(0)
#define melt_putfield_object(Obj,Off,Val,Fldnam) \
  melt_putfield_object_at(Obj,Off,Val,Fldnam,__FILE__,__LINE__)


static inline melt_ptr_t
melt_dynobjstruct_make_raw_object(melt_ptr_t klas, int len, 
				     const char*clanam, const char*fil, int lin, int**pptr) {
  if (pptr && !*pptr) 
    *pptr = melt_dynobjstruct_classlength_at(clanam,fil,lin);
  if (pptr && *pptr) 
    len = **pptr;
  return (melt_ptr_t)meltgc_new_raw_object((meltobject_ptr_t)klas,len);
}

#define melt_raw_object_create_at(Newobj,Klas,Len,Clanam,Fil,Lin) do { \
  static int* ptrlen_##Lin;						\
  Newobj =								\
    melt_dynobjstruct_make_raw_object((Klas),(Len),			\
					 Clanam,Fil,Lin,		\
					 &ptrlen_##Lin); } while(0)

#define melt_raw_object_create(Newobj,Klas,Len,Clanam) \
  melt_raw_object_create_at(Newobj,Klas,Len,Clanam,__FILE__,__LINE__)

#define melt_make_raw_object(Klas,Len,Clanam)			\
    melt_dynobjstruct_make_raw_object((Klas),(Len),			\
					 Clanam, __FILE__, __LINE__,	\
					 (int**)0)

#elif ENABLE_CHECKING
static inline melt_ptr_t
melt_getfield_object_at (melt_ptr_t ob, unsigned off, const char*msg, const char*fil, int lin)
{
  unsigned origoff = off;
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (off < pob->obj_len)
	return pob->obj_vartab[off];
      error ("checked field access failed (bad offset %d/%d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, (int)origoff, fil, lin, msg?msg:"...");
      return NULL;
    }
  error ("checked field access failed (not object [%s:%d]) - %s", fil, lin, msg?msg:"...");
  return NULL;
}

static inline void
melt_putfield_object_at(melt_ptr_t ob, unsigned off, melt_ptr_t val, const char*msg, const char*fil, int lin)
{
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (off < pob->obj_len) {
	pob->obj_vartab[off] = val;
	return;
      }
      melt_fatal_error("checked field put failed (bad offset %d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, fil, lin, msg?msg:"...");
    }
  melt_fatal_error("checked field put failed (not object [%s:%d]) - %s", fil, lin, msg?msg:"...");
}

static inline melt_ptr_t
melt_make_raw_object(melt_ptr_t klas, int len, const char*clanam) {
  gcc_assert(clanam != NULL);
  return (melt_ptr_t)meltgc_new_raw_object((meltobject_ptr_t)klas,len);
}

#define melt_raw_object_create(Newobj,Klas,Len,Clanam) do {	\
  Newobj = melt_make_raw_object(Klas,Len,Clanam); } while(0)
#define melt_getfield_object(Obj,Off,Fldnam) melt_getfield_object_at((melt_ptr_t)(Obj),(Off),(Fldnam),__FILE__,__LINE__)
#define melt_object_get_field(Slot,Obj,Off,Fldnam) do {	\
  Slot = melt_getfield_object(Obj,Off,Fldnam);} while(0)
#define melt_putfield_object(Obj,Off,Val,Fldnam) melt_putfield_object_at((melt_ptr_t)(Obj),(Off),(melt_ptr_t)(Val),(Fldnam),__FILE__,__LINE__)
#else
#define melt_getfield_object(Obj,Off,Fldnam) (((meltobject_ptr_t)(Obj))->obj_vartab[Off])
#define melt_object_get_field(Slot,Obj,Off,Fldnam) do {	\
  Slot = melt_getfield_object(Obj,Off,Fldnam);} while(0)
#define melt_putfield_object(Obj,Off,Val,Fldnam) do {		\
((meltobject_ptr_t)(Obj))->obj_vartab[Off] = (melt_ptr_t)(Val);	\
}while(0)
#define melt_make_raw_object(Klas,Len,Clanam) \
  ((melt_ptr_t)meltgc_new_raw_object((meltobject_ptr_t)(Klas),Len))
#define melt_raw_object_create(Newobj,Klas,Len,Clanam) do { \
  Newobj = melt_make_raw_object(Klas,Len,Clanam); } while(0)
#endif

/* get (safely) the length of an object */
static inline int
melt_object_length (melt_ptr_t ob)
{
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      return pob->obj_len;
    }
  return 0;
}

/* get safely the nth field of an object or NULL */
static inline melt_ptr_t
melt_object_nth_field(melt_ptr_t ob, int rk) 
{
  if (melt_magic_discr (ob) == MELTOBMAG_OBJECT)
    {
      meltobject_ptr_t pob = (meltobject_ptr_t) ob;
      if (rk<0) 
	rk += pob->obj_len;
      if (rk>=0 && rk<pob->obj_len) 
	return (melt_ptr_t)(pob->obj_vartab[rk]);
    }
  return NULL;
}

/* allocate a new string (or null if bad DISCR or null STR) initialized from
   _static_ (non gc-ed) memory STR with len SLEN or strlen(STR) if <0  */
melt_ptr_t meltgc_new_string_raw_len (meltobject_ptr_t discr,
					    const char *str, int slen);

/* allocate a new string (or null if bad DISCR or null STR) initialized from
   _static_ (non gc-ed) memory STR  */
melt_ptr_t meltgc_new_string (meltobject_ptr_t discr,
				    const char *str);

/* allocate a new string (or null if bad DISCR or null STR) initialized from
   a memory STR which is temporarily duplicated (so can be in gc-ed) */
melt_ptr_t meltgc_new_stringdup (meltobject_ptr_t discr,
				       const char *str);

/* get the naked basename of a path, ie from "/foo/bar.gyz" return
   "bar"; argument is duplicated */
melt_ptr_t meltgc_new_string_nakedbasename (meltobject_ptr_t discr,
						  const char *str);
/* get the basename of a path inside the temporary directory with an optional suffix */
melt_ptr_t meltgc_new_string_tempname_suffixed (meltobject_ptr_t discr,
						const char *namstr, const char*suffix);

/* Return as string value the name of a generated C file; if dirname
   is given and non-empty, it is used as the directory name using the
   basename of basepath, otherwise basepath is used. Any .melt or .so
   or .c suffix is removed, and if the num is positive it is
   appended. The result string is dirpath/basename+num.c, eg
   /foo/dir/mybase+3.c if dirpath is /foo/dir and basepath is
   /bar/mybase.c or mybase.melt etc...  and num is 3. If num is
   non-positive it is ignored. */
melt_ptr_t meltgc_new_string_generated_c_filename  (meltobject_ptr_t discr_p,
						    const char* basepath,
						    const char* dirpath,
						    int num);

/* Return true if we don't want to generate several C files for a
   given MELT module */
bool melt_wants_single_c_file (void);

/* split a [raw] string into a list of strings using a seperator. */
melt_ptr_t meltgc_new_split_string (const char*str, int sep, melt_ptr_t discr);


static inline const char *
melt_string_str (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_STRING)
    return ((struct meltstring_st *) v)->val;
  return 0;
}

static inline int
melt_string_length (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_STRING)
    return strlen(((struct meltstring_st *) v)->val);
  return 0;
}

static inline bool
melt_string_same (melt_ptr_t v1, melt_ptr_t v2)
{
  if (melt_magic_discr (v1) == MELTOBMAG_STRING
      && melt_magic_discr (v2) == MELTOBMAG_STRING)
    {
      return 0 == strcmp (((struct meltstring_st *) v1)->val,
			  ((struct meltstring_st *) v2)->val);
    }
  return 0;
}

static inline bool
melt_string_less (melt_ptr_t v1, melt_ptr_t v2)
{
  if (melt_magic_discr (v1) == MELTOBMAG_STRING
      && melt_magic_discr (v2) == MELTOBMAG_STRING)
    {
      return strcmp (((struct meltstring_st *) v1)->val,
		     ((struct meltstring_st *) v2)->val) < 0;
    }
  return 0;
}

static inline bool
melt_is_string_const (melt_ptr_t v, const char *s) {
  if (s && melt_magic_discr (v) == MELTOBMAG_STRING)
    return 0 == strcmp (((struct meltstring_st *) v)->val, s);
  return 0;
}

static inline const char *
melt_strbuf_str (melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_STRBUF)
    {
      struct meltstrbuf_st *sb = (struct meltstrbuf_st*) v;
      if (sb->bufend >= sb->bufstart)
	return sb->bufzn + sb->bufstart;
    }
  return 0;
}

static inline int
melt_strbuf_usedlength(melt_ptr_t v)
{
  if (melt_magic_discr (v) == MELTOBMAG_STRBUF)
    {
      struct meltstrbuf_st *sb = (struct meltstrbuf_st *) v;
      if (sb->bufend >= sb->bufstart)
	return sb->bufend - sb->bufstart;
    }
  return 0;
}

/* return the length of an output, i.e. the used length of strbuf or
   the current file position of a file */
long melt_output_length (melt_ptr_t out_p);

/* output an strbuf into a file */
void melt_output_strbuf_to_file (melt_ptr_t sbuf, const char*filnam);


/* allocate a pair of given head and tail */
melt_ptr_t meltgc_new_pair (meltobject_ptr_t discr,
				  void *head, void *tail);

/* change the head of a pair */
void meltgc_pair_set_head(melt_ptr_t pair, void* head);

/* allocate a new multiple of given DISCR & length LEN */
melt_ptr_t meltgc_new_multiple (meltobject_ptr_t discr_p,
				      unsigned len);

/* make a subsequence of a given multiple OLDMUL_P from STARTIX to
   ENDIX; if either index is negative, take it from last.  return null
   if arguments are incorrect, or a fresh subsequence of same
   discriminant as source otherwise */
melt_ptr_t meltgc_new_subseq_multiple (melt_ptr_t oldmul_p, 
					     int startix, int endix);

/* allocate a multiple of arity 1 */
melt_ptr_t meltgc_new_mult1 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p);
/* allocate a multiple of arity 2 */
melt_ptr_t meltgc_new_mult2 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p);
/* allocate a multiple of arity 3 */
melt_ptr_t meltgc_new_mult3 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p,
				   melt_ptr_t v2_p);
/* allocate a multiple of arity 4 */
melt_ptr_t meltgc_new_mult4 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p,
				   melt_ptr_t v2_p, melt_ptr_t v3_p);
/* allocate a multiple of arity 5 */
melt_ptr_t meltgc_new_mult5 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p,
				   melt_ptr_t v2_p, melt_ptr_t v3_p,
				   melt_ptr_t v4_p);
/* allocate a multiple of arity 6 */
melt_ptr_t meltgc_new_mult6 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p,
				   melt_ptr_t v2_p, melt_ptr_t v3_p,
				   melt_ptr_t v4_p, melt_ptr_t v5_p);
/* allocate a multiple of arity 7 */
melt_ptr_t meltgc_new_mult7 (meltobject_ptr_t discr_p,
				   melt_ptr_t v0_p, melt_ptr_t v1_p,
				   melt_ptr_t v2_p, melt_ptr_t v3_p,
				   melt_ptr_t v4_p, melt_ptr_t v5_p,
				   melt_ptr_t v6_p);


/* allocate a new (empty) list */
melt_ptr_t meltgc_new_list (meltobject_ptr_t discr_p);
/* append to the tail of a list */
void meltgc_append_list (melt_ptr_t list_p, melt_ptr_t val_p);
/* prepend to the head of a list */
void meltgc_prepend_list (melt_ptr_t list_p, melt_ptr_t val_p);
/* pop from head of list (and remove) */
melt_ptr_t meltgc_popfirst_list (melt_ptr_t list_p);

/* return the length of a list, 0 for nil, or -1 iff non list */
int melt_list_length (melt_ptr_t list_p);

/* allocate e new empty mapobjects */
melt_ptr_t meltgc_new_mapobjects (meltobject_ptr_t discr_p,
					unsigned len);

/* put into a mapobjects */
void meltgc_put_mapobjects (meltmapobjects_ptr_t mapobject_p,
			       meltobject_ptr_t attrobject_p,
			       melt_ptr_t valu_p);

/* get from a mapobject */
melt_ptr_t melt_get_mapobjects (meltmapobjects_ptr_t mapobject_p,
				      meltobject_ptr_t attrobject_p);

/* remove from a mapobject (return the removed value) */
melt_ptr_t meltgc_remove_mapobjects (meltmapobjects_ptr_t
					   mapobject_p,
					   meltobject_ptr_t attrobject_p);

static inline int
melt_size_mapobjects (meltmapobjects_ptr_t mapobject_p)
{
  if (!mapobject_p || mapobject_p->discr->obj_num != MELTOBMAG_MAPOBJECTS)
    return 0;
  return melt_primtab[mapobject_p->lenix];
}

static inline unsigned
melt_count_mapobjects (meltmapobjects_ptr_t mapobject_p)
{
  if (!mapobject_p || mapobject_p->discr->obj_num != MELTOBMAG_MAPOBJECTS)
    return 0;
  return mapobject_p->count;
}

static inline meltobject_ptr_t
melt_nthattr_mapobjects (meltmapobjects_ptr_t mapobject_p, int ix)
{
  meltobject_ptr_t at = 0;
  if (!mapobject_p || mapobject_p->discr->obj_num != MELTOBMAG_MAPOBJECTS)
    return 0;
  if (ix < 0 || ix >= melt_primtab[mapobject_p->lenix])
    return 0;
  at = mapobject_p->entab[ix].e_at;
  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
    return 0;
  return at;
}

static inline melt_ptr_t
melt_nthval_mapobjects (meltmapobjects_ptr_t mapobject_p, int ix)
{
  meltobject_ptr_t at = 0;
  if (!mapobject_p || mapobject_p->discr->obj_num != MELTOBMAG_MAPOBJECTS)
    return 0;
  if (ix < 0 || ix >= melt_primtab[mapobject_p->lenix])
    return 0;
  at = mapobject_p->entab[ix].e_at;
  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
    return 0;
  return mapobject_p->entab[ix].e_va;
}

/* allocate a new empty mapstrings */
melt_ptr_t meltgc_new_mapstrings (meltobject_ptr_t discr_p,
					unsigned len);

/* put into a mapstrings, the string is copied so can be in the gc-ed heap */
void meltgc_put_mapstrings (struct meltmapstrings_st *mapstring_p,
			       const char *str, melt_ptr_t valu_p);

/* get from a mapstring */
melt_ptr_t melt_get_mapstrings (struct meltmapstrings_st
				      *mapstring_p, const char *attr);


/* remove from a mapstring (return the removed value) */
melt_ptr_t meltgc_remove_mapstrings (struct meltmapstrings_st
					   *mapstring_p, const char *str);

static inline int
melt_size_mapstrings (struct meltmapstrings_st *mapstring_p)
{
  if (!mapstring_p || mapstring_p->discr->obj_num != MELTOBMAG_MAPSTRINGS)
    return 0;
  return melt_primtab[mapstring_p->lenix];
}

static inline unsigned
melt_count_mapstrings (struct meltmapstrings_st *mapstring_p)
{
  if (!mapstring_p || mapstring_p->discr->obj_num != MELTOBMAG_MAPSTRINGS)
    return 0;
  return mapstring_p->count;
}

static inline const char *
melt_nthattrraw_mapstrings (struct meltmapstrings_st *mapstring_p,
			       int ix)
{
  const char *at = 0;
  if (!mapstring_p || mapstring_p->discr->obj_num != MELTOBMAG_MAPSTRINGS)
    return 0;
  if (ix < 0 || ix >= melt_primtab[mapstring_p->lenix])
    return 0;
  at = mapstring_p->entab[ix].e_at;
  if ((const void *) at == (const void *) HTAB_DELETED_ENTRY)
    return 0;
  return at;
}

static inline melt_ptr_t
melt_nthval_mapstrings (struct meltmapstrings_st *mapstring_p, int ix)
{
  const char *at = 0;
  if (!mapstring_p || mapstring_p->discr->obj_num != MELTOBMAG_MAPSTRINGS)
    return 0;
  if (ix < 0 || ix >= melt_primtab[mapstring_p->lenix])
    return 0;
  at = mapstring_p->entab[ix].e_at;
  if ((const void *) at == (const void *) HTAB_DELETED_ENTRY)
    return 0;
  return mapstring_p->entab[ix].e_va;
}

/* allocate a new routine object of given DISCR and of length LEN,
   with a DESCR-iptive string a a PROC-edure */
meltroutine_ptr_t meltgc_new_routine (meltobject_ptr_t discr_p,
					    unsigned len, const char *descr,
					    meltroutfun_t * proc);


void meltgc_set_routine_data(melt_ptr_t rout_p, melt_ptr_t data_p);

static inline melt_ptr_t 
melt_routine_data(melt_ptr_t rout)
{
  if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == MELTOBMAG_ROUTINE)
    return ((meltroutine_ptr_t) rout)->routdata;
  return NULL;
}

static inline char *
melt_routine_descrstr (melt_ptr_t rout)
{
  if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == MELTOBMAG_ROUTINE)
    return ((meltroutine_ptr_t) rout)->routdescr;
  return (char *) 0;
}

static inline int
melt_routine_size (melt_ptr_t rout)
{
  if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == MELTOBMAG_ROUTINE)
    return ((meltroutine_ptr_t) rout)->nbval;
  return 0;
}

static inline melt_ptr_t
melt_routine_nth (melt_ptr_t rout, int ix)
{
  if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == MELTOBMAG_ROUTINE)
    if (ix >= 0 && ix < (int) ((meltroutine_ptr_t) rout)->nbval)
      return ((meltroutine_ptr_t) rout)->tabval[ix];
  return 0;
}

/*********/
/* allocate a new closure of given DISCR with a given ROUT,  and of length LEN
 */
meltclosure_ptr_t meltgc_new_closure (meltobject_ptr_t discr_p,
					    meltroutine_ptr_t rout_p,
					    unsigned len);

static inline int
melt_closure_size (melt_ptr_t clo)
{
  if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == MELTOBMAG_CLOSURE)
    return ((meltclosure_ptr_t) clo)->nbval;
  return 0;
}

static inline melt_ptr_t
melt_closure_routine (melt_ptr_t clo)
{
  if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == MELTOBMAG_CLOSURE)
    return (melt_ptr_t) (((meltclosure_ptr_t) clo)->rout);
  return 0;
}

static inline melt_ptr_t
melt_closure_nth (melt_ptr_t clo, int ix)
{
  if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == MELTOBMAG_CLOSURE
      && ix >= 0 && ix < (int) (((meltclosure_ptr_t) clo)->nbval))
    return (melt_ptr_t) (((meltclosure_ptr_t) clo)->tabval[ix]);
  return 0;
}


/***** list and pairs accessors ****/
/* safe pair head & tail accessors */
static inline melt_ptr_t
melt_pair_head (melt_ptr_t pair)
{
  if (pair && ((struct meltpair_st *) pair)->discr->obj_num == MELTOBMAG_PAIR)
    return ((struct meltpair_st *) pair)->hd;
  return 0;
}

static inline melt_ptr_t
melt_pair_tail (melt_ptr_t pair)
{
  if (pair && ((struct meltpair_st *) pair)->discr->obj_num == MELTOBMAG_PAIR)
    return (melt_ptr_t) (((struct meltpair_st *) pair)->tl);
  return 0;
}

/* compute the length of a pairlist */
static inline long
melt_pair_listlength (melt_ptr_t pair)
{
  long l = 0;
  while (pair
	 && ((struct meltpair_st *) pair)->discr->obj_num == MELTOBMAG_PAIR)
    {
      l++;
      pair = (melt_ptr_t) (((struct meltpair_st *) pair)->tl);
    };
  return l;
}

static inline melt_ptr_t
melt_list_first (melt_ptr_t lis)
{
  if (lis && ((struct meltlist_st *) lis)->discr->obj_num == MELTOBMAG_LIST)
    return (melt_ptr_t) (((struct meltlist_st *) lis)->first);
  return NULL;
}

static inline melt_ptr_t
melt_list_last (melt_ptr_t lis)
{
  if (lis && ((struct meltlist_st *) lis)->discr->obj_num == MELTOBMAG_LIST)
    return (melt_ptr_t) (((struct meltlist_st *) lis)->last);
  return NULL;
}



/***** STRBUF ie string buffers *****/

/* allocate a new strbuf of given DISCR with initial content STR */
struct meltstrbuf_st *meltgc_new_strbuf (meltobject_ptr_t discr_p,
					       const char *str);


/**** 
      Output routines can go into a boxed strbuf or a boxed file 
****/

/* add into OUT (a boxed STRBUF or a boxed FILE) the static string STR
   (which is not in the melt heap) */
void meltgc_add_out_raw (melt_ptr_t outbuf_p,
			       const char *str);

#define meltgc_add_strbuf_raw(Out,Str) meltgc_add_out_raw((Out),(Str))

/*  add into OUT (a boxed STRBUF or a boxed FILE) the static string
   STR (which is not in the melt heap) of length SLEN or
   strlen(STR) if SLEN<0 */
void meltgc_add_out_raw_len (melt_ptr_t outbuf_p,
				   const char *str, int slen);
#define meltgc_add_strbuf_raw_len(Out,Str,Len) meltgc_add_out_raw_len((Out),(Str),(Len))

/* add safely into OUTBUF the string STR (which is first copied, so
   can be in the melt heap) */
void meltgc_add_out (melt_ptr_t outbuf_p,
			   const char *str);
#define meltgc_add_strbuf(Out,Str) meltgc_add_out((Out),(Str))

/* add safely into OUTBUF the string STR encoded as a C string with
   backslash escapes */
void meltgc_add_out_cstr (melt_ptr_t outbuf_p,
				const char *str);
#define meltgc_add_strbuf_cstr(Out,Str) meltgc_add_out_cstr(Out,Str)

/* add safely into OUTBUF the string STR encoded as the interior of a
   C comment with slash star and star slash replaced by slash plus and
   plus slash */
void meltgc_add_out_ccomment (melt_ptr_t outbuf_p,
				    const char *str);
#define meltgc_add_strbuf_ccomment(Out,Str) meltgc_add_out_ccomment((Out),(Str))

/* add safely into OUTBUF the string STR (which is copied at first)
   encoded as a C identifier; ie non-alphanum begine encoded as an
   underscore */
void meltgc_add_out_cident (melt_ptr_t outbuf_p,
				  const char *str);
#define meltgc_add_strbuf_cident(Out,Str) meltgc_add_out_cident((Out),(Str))

/* add safely into OUTBUF the initial prefix of string STR (which is
   copied at first), with a length of at most PREFLEN encoded as a C
   identifier; ie non-alphanum begine encoded as an underscore */
void
meltgc_add_out_cidentprefix (melt_ptr_t strbuf_p, const char *str, int preflen);
#define meltgc_add_strbuf_cidentprefix(Out,Str,Pln) meltgc_add_out_cidentprefix((Out),(Str),(Pln))

/* add safely into OUTBUF the hex encoded number L */
void meltgc_add_out_hex (melt_ptr_t outbuf_p,
			       unsigned long l);
#define meltgc_add_strbuf_hex(Out,L) meltgc_add_out_hex((Out),(L))

/* add safely into OUTBUF the decimal encoded number L */
void meltgc_add_out_dec (melt_ptr_t outbuf_p, long l);
#define meltgc_add_strbuf_dec(Out,L) meltgc_add_out_dec((Out),(L))

/* add safely into OUTBUF a printf like stuff with FMT */
void
meltgc_out_printf (melt_ptr_t outbuf_p, const char *fmt,
			 ...) ATTRIBUTE_PRINTF (2, 3);
/* don't bother using CPP varargs */
#define meltgc_strbuf_printf meltgc_out_printf

/* add safely into OUTBUF either a space or an indented newline if the current line is bigger than the threshold */
void meltgc_out_add_indent (melt_ptr_t strbuf_p,
			       int indeptn, int linethresh);
#define meltgc_strbuf_add_indent(Out,I,L) meltgc_out_add_indent ((Out),(I),(L))

/* pretty print into OUTBUF a gimple */
void meltgc_ppout_gimple(melt_ptr_t outbuf_p, int indentsp, gimple gstmt);
#define meltgc_ppstrbuf_gimple(Out,I,G) meltgc_ppout_gimple ((Out), (I), (G))

/* pretty print into an OUTBUF a gimple seq */
void meltgc_ppout_gimple_seq(melt_ptr_t outbuf_p, int indentsp, gimple_seq gseq);
#define meltgc_ppstrbuf_gimple_seq(Out,I,G) meltgc_ppout_gimple_seq ((Out), (I), (G))

/* pretty print into an OUTBUF a tree */
void meltgc_ppout_tree(melt_ptr_t outbuf_p, int indentsp, tree tr);
#define meltgc_ppstrbuf_tree(Out,I,T) meltgc_ppout_tree  ((Out), (I), (T))

/* pretty print into an outbuf a basic_block */
void meltgc_ppout_basicblock(melt_ptr_t out_p, int indentsp, basic_block bb);
#define meltgc_ppstrbuf_basicblock(Out,I,BB) meltgc_ppout_basicblock ((Out),(I),(BB))

/* pretty print into an outbuf a multiprecision integer */
void meltgc_ppout_mpz(melt_ptr_t out_p, int indentsp, mpz_t mp);
#define meltgc_ppstrbuf_mpz(O,I,M) meltgc_ppout_mpz((O), (I), (M))

/* pretty print into an outbuf the mpz of a MELT bigint; do nothing if
   big_p is not a MELT bigint */
void meltgc_ppout_mixbigint(melt_ptr_t out_p, int indentsp, melt_ptr_t big_p);
#define meltgc_ppstrbuf_mixbigint(O,I,B) meltgc_ppout_mixbigint ((O), (I), (B))


/***************** PASS MANAGEMENT ****************/
/* register a Melt pass PASS; there is no way to unregister it, and the
   opt_pass and plugin_pass used internally are never deallocated.
   The POSITIONING is one of the strings "after" "before" "replace"
   The REFPASSNAME is the name of the existing reference pass
   The REFPASSNUMBER is the number of the reference pass or 0 for all.
   Non-simple IPA passes are not yet implemented! 
*/
void
meltgc_register_pass (melt_ptr_t pass_p, const char* positioning, 
			 const char*refpassname,
			 int refpassnum);

/*** allocate a boxed file ***/
melt_ptr_t meltgc_new_file(melt_ptr_t discr_p, FILE* fil);

/***************** PARMA POLYHEDRA LIBRARY ****************/

enum { 
  MELT_PPL_EMPTY_CONSTRAINT_SYSTEM=0,
  MELT_PPL_UNSATISFIABLE_CONSTRAINT_SYSTEM
};
/* create a new boxed PPL constraint system */
melt_ptr_t meltgc_new_ppl_constraint_system(melt_ptr_t discr_p, 
						  bool unsatisfiable);
/* box clone an existing PPL constraint system */
melt_ptr_t meltgc_clone_ppl_constraint_system (melt_ptr_t ppl_p);

/* make a new boxed PPL linear expression  */
melt_ptr_t meltgc_new_ppl_linear_expression(melt_ptr_t discr_p);

/* clear any boxed special by appropriately deleting inside */
void melt_clear_special(melt_ptr_t val_p);

/** pretty print into a strbuf SBUF_P with indentation INDENTSP the
    pplvalue PPL_P using the variable name tuple VARNAMVECT_P **/
void
meltgc_ppstrbuf_ppl_varnamvect (melt_ptr_t sbuf_p, int indentsp, melt_ptr_t ppl_p, melt_ptr_t varnamvect_p);

/* create a new PPL empty constraint system raw stuff */
static inline ppl_Constraint_System_t 
melt_raw_new_ppl_empty_constraint_system (void) {
  ppl_Constraint_System_t consys= NULL;
  int err=0;
  if ((err=ppl_new_Constraint_System(&consys))!=0)
    melt_fatal_error("melt_raw_new_ppl_empty_constraint_system failed (%d)", err);
  return consys;
}

/* create a new PPL unsatisfiable constraint system raw stuff */
static inline ppl_Constraint_System_t 
melt_raw_new_ppl_unsatisfiable_constraint_system (void) {
  ppl_Constraint_System_t consys= NULL;
  int err=0;
  if ((err=ppl_new_Constraint_System_zero_dim_empty(&consys))!=0)
    melt_fatal_error("melt_raw_new_ppl_unsatisfiable_constraint_system failed (%d)", err);
  return consys;
}

/* create a new PPL empty constraint system raw stuff */
static inline ppl_Constraint_System_t 
melt_raw_clone_ppl_consstraint_system (ppl_Constraint_System_t oldconsys) {
  ppl_Constraint_System_t consys= NULL;
  int err=0;
  if ((err=ppl_new_Constraint_System_from_Constraint_System(&consys, oldconsys))!=0)
    melt_fatal_error("melt_raw_clone_ppl_consstraint_system failed (%d)", err);
  return consys;
}

/* utility to make a ppl_Coefficient_t out of a constant tree */
ppl_Coefficient_t melt_make_ppl_coefficient_from_tree (tree tr);

/* utility to make a ppl_Coefficient_t from a long number */
ppl_Coefficient_t melt_make_ppl_coefficient_from_long (long l);

/* utility to make a ppl_Linear_Expression_t */
ppl_Linear_Expression_t melt_make_ppl_linear_expression (void);

/* utility to make a ppl_Constraint ; the constraint type is a string
   "==" or ">" "<" ">=" "<=" because we don't want enums in
   MELT... */
ppl_Constraint_t melt_make_ppl_constraint_cstrtype (ppl_Linear_Expression_t liex, const char*constyp);

/* insert a raw PPL constraint into a boxed constraint system */
void
melt_insert_ppl_constraint_in_boxed_system (ppl_Constraint_t cons, melt_ptr_t ppl_p);

/* utility to make a NNC [=not necessarily closed] ppl_Polyhedron_t
   out of a constraint system */
ppl_Polyhedron_t melt_make_ppl_NNC_Polyhedron_from_Constraint_System (ppl_Constraint_System_t consys);

/* make a new boxed PPL polyhedron; if cloned is true, the poly is
   copied otherwise taken as is */
melt_ptr_t
meltgc_new_ppl_polyhedron (melt_ptr_t discr_p, ppl_Polyhedron_t poly, bool cloned);
enum { SAME_PPL_POLHYEDRON=0, CLONED_PPL_POLHYEDRON=1 };

/* get the content of a boxed PPL coefficient */
static inline ppl_Coefficient_t 
melt_ppl_coefficient_content (melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_COEFFICIENT) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_coefficient;
}

/* put the content of a boxed PPL coefficient */
static inline void
melt_ppl_coefficient_put_content(melt_ptr_t ppl_p, ppl_Coefficient_t coef)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_COEFFICIENT) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_coefficient = coef;
}

/* get the content of a boxed PPL linear expression */
static inline ppl_Linear_Expression_t 
melt_ppl_linear_expression_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_LINEAR_EXPRESSION) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_linear_expression;
}

/* put the content of a boxed PPL linear expression */
static inline void 
melt_ppl_linear_expression_put_content(melt_ptr_t ppl_p, ppl_Linear_Expression_t liex)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_LINEAR_EXPRESSION) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_linear_expression = liex;
}

/* get the content of a boxed PPL constraint */
static inline ppl_Constraint_t 
melt_ppl_constraint_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_CONSTRAINT) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_constraint;
}

/* putt the content of a boxed PPL constraint */
static inline void
melt_ppl_constraint_put_content(melt_ptr_t ppl_p, ppl_Constraint_t cons)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_CONSTRAINT) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_constraint = cons;
}

/* get the content of a boxed PPL constraint system */
static inline ppl_Constraint_System_t 
melt_ppl_constraint_system_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_constraint_system;
}

/* put the content of a boxed PPL constraint system */
static inline void
melt_ppl_constraint_system_put_content(melt_ptr_t ppl_p, ppl_Constraint_System_t consys)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_constraint_system = consys;
}


/* get the content of a boxed PPL generator */
static inline ppl_Generator_t 
melt_ppl_generator_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_GENERATOR) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_generator;
}


/* put the content of a boxed PPL generator */
static inline void 
melt_ppl_generator_put_content(melt_ptr_t ppl_p,  ppl_Generator_t gen)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_GENERATOR) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_generator = gen;
}


/* get the content of a boxed PPL generator system */
static inline ppl_Generator_System_t 
melt_ppl_generator_system_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_GENERATOR_SYSTEM) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_generator_system;
}

/* put the content of a boxed PPL generator system */
static inline void
melt_ppl_generator_system_put_content(melt_ptr_t ppl_p, ppl_Generator_System_t gensys)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_GENERATOR_SYSTEM) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_generator_system = gensys;
}


/* get the content of a boxed PPL polyhedron */
static inline ppl_Polyhedron_t
melt_ppl_polyhedron_content(melt_ptr_t ppl_p)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_POLYHEDRON) 
    return NULL;
  return ((struct meltspecial_st *)ppl_p)->val.sp_polyhedron;
}

/* put the content of a boxed PPL polyhedron */
static inline void
melt_ppl_polyhedron_put_content(melt_ptr_t ppl_p, ppl_Polyhedron_t poly)
{
  if (melt_magic_discr(ppl_p) != MELTOBMAG_SPECPPL_POLYHEDRON) 
    return;
  ((struct meltspecial_st *)ppl_p)->val.sp_polyhedron = poly;
}


/**************************** misc *****************************/
/* a random generator */
static inline long melt_lrand (void) 
{
  /* we used to call lrand48_r using some randata filled at init time,
     but lrand48_r is less portable than lrand48 */
  return lrand48();
}


static inline unsigned melt_nonzerohash (void)
{
  unsigned h;
  do
    {
      h = melt_lrand () & MELT_MAXHASH;
    }
  while (h == 0);
  return h;
}

/* initialize all - don't do anything when called more than once */
void melt_initialize (void);
/* finalize all */
void melt_finalize (void);

/* find a symbol in all the loaded modules */
void* melt_dlsym_all (const char*nam);

/* returns malloc-ed path inside a temporary directory, with a given basename & suffix  */
char* melt_tempdir_path (const char* basnam, const char* suffix);


/***
    Load a MELT module by its name, which is only made of letters,
    digit, underscores, and + or - chars. 
   
    If the module does not exist in binary form (or if the binary form
    is not in sync with the C source code), find its C source and
    compile it, passing maketarget to the make utility. See file
    melt-module.mk for the acceptable maketargets, often "melt_module".

    Then, load the module as a shared object and invoke its
    start_module_melt function with the given module data, usually
    an environment, which returns the new module environment.
***/
melt_ptr_t
meltgc_make_load_melt_module (melt_ptr_t modata_p, const char *modulnam, 
			      const char*maketarget);



/* Generate a loadable module from a MELT generated C source file; the
   out is the dynloaded module without any *.so suffix. The maketarget
   is for melt-module.mk and by default is "melt_module".  */
void
meltgc_make_melt_module (melt_ptr_t src_p, melt_ptr_t out_p, const char*maketarget);


/* load a list of modules from a file whose basename MODLISTBASE is
   given without its suffix '.modlis' */
melt_ptr_t
meltgc_load_modulelist(melt_ptr_t modata_p, const char *modlistbase);

/* first_module_melt is the function start_module_melt in first-melt.c */
melt_ptr_t first_module_melt (melt_ptr_t);


/* get (or create) the symbol of a given name, using the INITIAL_SYSTEM_DATA
   global; the NAM string can be in the GC-allocated heap since it is
   copied */
enum
{				/* a meningful enum for the create flag below */
  MELT_GET = 0,
  MELT_CREATE
};

melt_ptr_t meltgc_named_symbol (const char *nam, int create);

/* get (or create) the keyword of a given name (without the colon),
   using the INITIAL_SYSTEM_DATA global; the NAM string can be in the
   GC-allocated heap since it is copied */
melt_ptr_t meltgc_named_keyword (const char *nam, int create);

/* intern a symbol, ie add it into the global name map; if the symbol
   is new, return it otherwise return the older homonymous symnol */
melt_ptr_t meltgc_intern_symbol (melt_ptr_t symb);

/* intern a keyword, ie add it into the global name map; if the symbol
   is new, return it otherwise return the older homonymous symnol */
melt_ptr_t meltgc_intern_keyword (melt_ptr_t symb);

/* read a list of sexpressions from a file; if the second argument is non-empty and non-null, it is used for locations; otherwise the basename of the filnam is used */
melt_ptr_t meltgc_read_file (const char *filnam, const char* locnam);

/* read a list of sexpressions from a raw string [which should not be
   in the melt heap] using a raw location name and a location in source */
melt_ptr_t meltgc_read_from_rawstring(const char* rawstr, const char* rawlocnam, location_t loch);

/* read a list of sexpressions from a string or strbuf value or named
   object; if the second argument is non-empty and non-null, it is
   used for locations */
melt_ptr_t meltgc_read_from_val(melt_ptr_t strv_p, melt_ptr_t locnam_p);

/***** low level routines for infix file parsing *****/
/* open an infix filepath */
void meltgc_open_infix_file (const char*filpath);
/* close an infix file */
void meltgc_close_infix_file (void);
/* get a lexeme, giving the location file name value and the delimiter
   hashtable */
melt_ptr_t meltgc_infix_lexeme (melt_ptr_t locnam_p, melt_ptr_t delimtab_p);


/* called from c-common.c in handle_melt_attribute */
void melt_handle_melt_attribute(tree decl, tree name, const char* attrstr, location_t loch);

/* Use melt_assert(MESSAGE,EXPR) to test invariants.  The MESSAGE
   should be a constant string displayed when asserted EXPR is
   false */
#if ENABLE_ASSERT_CHECKING
void
melt_assert_failed (const char *msg, const char *filnam, int lineno,
		       const char *fun)
  ATTRIBUTE_NORETURN;
void
melt_check_failed (const char *msg, const char *filnam, int lineno,
		      const char *fun);
enum { MELT_ANYWHERE=0, MELT_NOYOUNG };
void  melt_check_call_frames_at(int youngflag, const char*msg, const char*filenam, int lineno);
#define melt_assertmsg(MSG,EXPR)  do { if (MELT_UNLIKELY(!(EXPR))) \
      melt_assert_failed ((MSG),__FILE__,__LINE__,__FUNCTION__);   \
  } while(0)
#define melt_checkmsg(MSG,EXPR)   do { if (MELT_UNLIKELY(!(EXPR))) \
      melt_check_failed ((MSG),__FILE__,__LINE__,__FUNCTION__);	   \
  } while(0)
#define melt_check_call_frames(YNG,MSG)				\
  ((void)(melt_check_call_frames_at((YNG),(MSG),__FILE__,__LINE__)))
#else
/* Include EXPR, so that unused variable warnings do not occur.  */
#define melt_assertmsg(MSG,EXPR) ((void)(0 && (MSG) && (EXPR)))
#define melt_assert_failed(MSG,FIL,LIN,FUN) ((void)(0 && (MSG)))
#define melt_checkmsg(MSG,EXPR) ((void)(0 && (MSG) && (EXPR)))
#define melt_check_failed(MSG,FIL,LIN,FUN) ((void)(0 && (MSG)))
#define melt_check_call_frames(YNG,MSG) (void)(0)
#endif


/******************* method sending ************************/
melt_ptr_t meltgc_send (melt_ptr_t recv,
			      melt_ptr_t sel,
			      const char *xargdescr_,
			      union meltparam_un *xargtab_,
			      const char *xresdescr_,
			      union meltparam_un *xrestab_);

/**************************** globals **************************/

/* enumeration of predefined global object indexes inside
   melt_globvec; Most are wired predefined, in the sense that
   they are automagically allocated and partly filled before loading
   the melt file. Others are named, and are expected to be
   created by loading the melt files.  */
enum melt_globalix_en
{
  MELTGLOB__NONE,
  /************************* wired predefined */
#include "melt-predef.h"
  /**************************** placeholder for last wired */
  MELTGLOB__LASTWIRED,
  MELTGLOB___SPARE1,
  MELTGLOB___SPARE2,
  MELTGLOB___SPARE3,
  MELTGLOB___SPARE4,
  /*****/
  MELTGLOB__LASTGLOB
};
#define BGLOB__LASTGLOB MELTGLOB__LASTGLOB

/* *INDENT-OFF* */

/* the array of global values */
extern GTY (()) melt_ptr_t melt_globarr[MELTGLOB__LASTGLOB];

/* *INDENT-ON* */

/* fields inside container */
enum
{
  FCONTAINER_VALUE = 0,
  FCONTAINER__LAST
};
    
/* fields inside every proped object */
enum
{
  FPROPED_PROP = 0,
  FPROPED__LAST
};
/* fields inside every named object */
enum
{
  FNAMED_NAME = FPROPED__LAST,
  FNAMED__LAST
};

/* fields inside every discriminant */
enum
{
  FDISC_METHODICT = FNAMED__LAST,	/* a mapobjects for method mapping
					   selectors to closures */
  FDISC_SENDER,		/* the closure doing the send if a
				   selector is not in the method
				   dict */
  FDISC_SUPER,			/* the "superclass" or "parent discrim" */
  FDISC__LAST
};

/* fields inside every class */
enum
{
  FCLASS_ANCESTORS = FDISC__LAST,	/* a multiple for the class ancestors
					   (first being the CLASS:ROOT last
					   being the immediate superclass) */
  FCLASS_FIELDS,		/* a multiple for the class fields */
  FCLASS_DATA,			/* class variables */
  FCLASS__LAST
};


/* fields inside each symbol */
enum
{
  FSYMB_DATA = FNAMED__LAST,
  FSYMB__LAST
};

/* fields inside a source expression (sexpr) */
enum
{
  FSEXPR_LOCATION = FPROPED__LAST,
  FSEXPR_CONTENTS,		/* the contents of the sexpression (as a list) */
  FSEXPR__LAST
};

/* fields inside an infix lexeme */
enum
  { FSINFLEX_LOCATION = FSEXPR_LOCATION,
    FSINFLEX_DATA,
    FSINFLEX__LAST
  };

/* fields inside the system data - keep in sync with the
   class_system_data definition in MELT file warmelt-first.melt;
   needed because the predefined are immutable objects, and cannot be
   varying objects or non objects */
enum
{
  FSYSDAT_MODE_DICT = FNAMED__LAST,	/* the stringdict of modes */
  FSYSDAT_BOX_FRESH_ENV,			/* closure to make a fresh environment box */
  FSYSDAT_VALUE_EXPORTER,	       /* closure to export a value */
  FSYSDAT_MACRO_EXPORTER,	       /* closure to export a macro */
  FSYSDAT_SYMBOLDICT, 	       /* stringmap for symbols */
  FSYSDAT_KEYWDICT, 		       /* stringmap for keywords */
  FSYSDAT_ADDSYMBOL, 	       /* closure to add a symbol of given name */
  FSYSDAT_ADDKEYW,		/* closure to add a keyword of given name */
  FSYSDAT_INTERNSYMBOL,	       /* closure to intern a symbol */
  FSYSDAT_INTERNKEYW,		/* closure to intern a keyword */
  FSYSDAT_VALUE_IMPORTER,	/* closure to import a value */
  FSYSDAT_PASS_DICT,		/* dictionnary of passes */
  FSYSDAT_EXIT_FINALIZER,	/* closure to call at exit */
  FSYSDAT_MELTATTR_DEFINER,	/* closure for melt attributes */
  FSYSDAT_PATMACRO_EXPORTER,    /* closure to export patmacro */
  FSYSDAT_DEBUGMSG,		/* closure for debugmsg */
  FSYSDAT_STDOUT,		/* raw boxed file for stdout */
  FSYSDAT_STDERR,		/* raw boxed file for stderr */
  FSYSDAT_DUMPFILE,		/* raw boxed file for dump_file */
  FSYSDAT_UNIT_STARTER,		/* closure for start of compilation unit */
  FSYSDAT_UNIT_FINISHER,        /* closure for start of compilation unit */
  FSYSDAT_OPTION_SET,		/* closure to set options */
  FSYSDAT__LAST
};


/* fields inside GCC passes */
enum {
  FGCCPASS_GATE = FNAMED__LAST,	/* the gate closure */
  FGCCPASS_EXEC,		/* the execute closure */
  FGCCPASS_DATA,		/* extra data */
  FGCCPASS_PROPERTIES_REQUIRED,
  FGCCPASS_PROPERTIES_PROVIDED,
  FGCCPASS_PROPERTIES_DESTROYED,
  FGCCPASS_TODO_FLAGS_START,
  FGCCPASS_TODO_FLAGS_FINISH,
  FGCCPASS__LAST
};

/* fields inside MELT commands */
enum {
    FMELTCMD_HELP = FNAMED__LAST, /* the help string */
    FMELTCMD_FUN,		 /* the command closure */
    FMELTCMD_DATA,		 /* client data of command */
    FMELTCMD__LAST
};

/* currently each predefined is a GC root (so we have about two
   hundreds of them), scanned at every minor garbage collection. We
   might change that, e.g. by grouping the predefined set by 16 and
   scanning in minor GC only groups which have been changed */

static inline melt_ptr_t
melt_fetch_predefined(int ix)
{
  if (ix>0 && ix<MELTGLOB__LASTWIRED)
    return (melt_ptr_t)melt_globarr[ix];
  return NULL;
}

static inline void melt_store_predefined(int ix, melt_ptr_t p)
{
  gcc_assert (ix>0 && ix<MELTGLOB__LASTWIRED);
  gcc_assert (melt_globarr[ix] == NULL);
  melt_globarr[ix] = p;
}

#define melt_globpredef(Ix) ((void*)melt_fetch_predefined((Ix)))


/* access or set a predefined */
#define MELT_PREDEF(Glob)  melt_fetch_predefined(MELTGLOB_##Glob)
#define MELT_STORE_PREDEF(Glob,P) melt_store_predefined(MELTGLOB_##Glob, (P))

/* this is useful in generated MELT code */
#define MELTPREDEFIX(Tab,Glob) Tab[MELTGLOB_##Glob]


/* return the discriminant or class itself */
static inline meltobject_ptr_t
melt_discr (melt_ptr_t p)
{
  if (!p)
    return (meltobject_ptr_t) MELT_PREDEF (DISCR_NULL_RECEIVER);
  return p->u_discr;
}

bool melt_is_subclass_of (meltobject_ptr_t subclass_p,
			     meltobject_ptr_t superclass_p);

static inline bool
melt_is_instance_of (melt_ptr_t inst_p, melt_ptr_t class_p)
{
  unsigned mag_class = 0;
  unsigned mag_inst = 0;
  if (!inst_p)
    return FALSE;
  if (!class_p)
    return FALSE;
  gcc_assert(class_p->u_discr != NULL);
  gcc_assert(inst_p->u_discr != NULL);
  mag_class = class_p->u_discr->obj_num;
  mag_inst = inst_p->u_discr->obj_num;
  if (mag_class != MELTOBMAG_OBJECT || !mag_inst)
    return FALSE;
  if (((meltobject_ptr_t) inst_p)->obj_class ==
      (meltobject_ptr_t) class_p)
    return TRUE;
  if (mag_inst != ((meltobject_ptr_t) class_p)->object_magic)
    return FALSE;
  if (mag_inst == MELTOBMAG_OBJECT)
    return melt_is_subclass_of (((meltobject_ptr_t) inst_p)->obj_class,
				   ((meltobject_ptr_t) class_p));
  /* the instance is not an object but something else and it has the
     good magic */
  return TRUE;
}



/* since melt_put_int uses DISCR_CONSTANT_INTEGER it should be here */
static inline bool
melt_put_int (melt_ptr_t v, long x)
{
  if (!v)
    return FALSE;
  switch (melt_magic_discr (v))
    {
    case MELTOBMAG_INT:
      if (v->u_discr == (meltobject_ptr_t)MELT_PREDEF(DISCR_CONSTANT_INTEGER))
	return FALSE;
      ((struct meltint_st *) (v))->val = x;
      return TRUE;
    case MELTOBMAG_MIXINT:
      ((struct meltmixint_st *) (v))->intval = x;
      return TRUE;
    case MELTOBMAG_MIXLOC:
      ((struct meltmixloc_st *) (v))->intval = x;
      return TRUE;
    case MELTOBMAG_OBJECT:
      if (((meltobject_ptr_t) (v))->obj_num != 0)
	return FALSE;
      ((meltobject_ptr_t) (v))->obj_num = (unsigned short) x;
      return TRUE;
    default:
      return FALSE;
    }
}

/***
 * CALL FRAMES 
 ***/


/* call frames for our copying garbage collector cannot be GTY-ed
   because they are inside the C call stack; in reality, MELT call
   frames may also contain other GTY-ed data -like tree-s, gimple-s,
   ...-, and the MELT machinery generated code to mark each such
   frame. See http://gcc.gnu.org/wiki/memory%20management%20in%20MELT
   for more */
struct callframe_melt_st
{
  /* When mcfr_nbvar is positive or zero, it is the number of pointers
     in mcfr_varptr; when it is negative, the mcfr_forwmarkrout should
     be used for forwarding or marking the frame's pointers. */
  int mcfr_nbvar;
#if ENABLE_CHECKING
  const char* mcfr_flocs;
#endif
  union {
    struct meltclosure_st *mcfr_closp_; /* when mcfr_nbvar >= 0 */
    void (*mcfr_forwmarkrout_) (struct callframe_melt_st*, int); /* when mcfr_nbvar < 0 */
  } mcfr_un_;
#define mcfr_closp mcfr_un_.mcfr_closp_
#define mcfr_forwmarkrout mcfr_un_.mcfr_forwmarkrout_ 
  /* Interface: void mcfr_forwmarkrout (void* frame, int marking) */
  struct excepth_melt_st *mcfr_exh;	/* for our exceptions - not implemented yet */
  struct callframe_melt_st *mcfr_prev;
  melt_ptr_t mcfr_varptr[FLEXIBLE_DIM];
};

/* maximal number of local variables per frame */
#define MELT_MAXNBLOCALVAR 16384

/* the topmost call frame */
extern struct callframe_melt_st *melt_topframe;

static inline int melt_curframdepth (void) {
  int cnt = 0;
  struct callframe_melt_st* fr = melt_topframe;
  for (;fr;fr=fr->mcfr_prev) cnt++;
  return cnt;
}

#if 0
/* the jmpbuf for our catch & throw */
extern jmp_buf *melt_jmpbuf;
extern melt_ptr_t melt_jmpval;
#endif

/* declare the current callframe */
#if ENABLE_CHECKING
#define MELT_DECLFRAME(NBVAR) struct {		\
  int mcfr_nbvar;				\
  const char* mcfr_flocs;			\
  struct meltclosure_st* mcfr_clos;		\
  struct excepth_melt_st* mcfr_exh;		\
  struct callframe_melt_st* mcfr_prev;		\
  void*  /* a melt_ptr_t */ mcfr_varptr[NBVAR];	\
} meltfram__
/* initialize the current callframe and link it at top */
#define MELT_INITFRAME_AT(NBVAR,CLOS,FIL,LIN) do {			\
  static char locbuf_##LIN[84];						\
  if (!locbuf_##LIN[0])							\
    snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d",		\
	     basename(FIL), (int)LIN);					\
  memset(&meltfram__, 0, sizeof(meltfram__));				\
  meltfram__.mcfr_nbvar = (NBVAR);					\
  meltfram__.mcfr_flocs = locbuf_##LIN;					\
  meltfram__.mcfr_prev = (struct callframe_melt_st*) melt_topframe;	\
  meltfram__.mcfr_clos = (CLOS);					\
  melt_topframe = ((struct callframe_melt_st*)&meltfram__);		\
} while(0)
#define MELT_INITFRAME(NBVAR,CLOS) MELT_INITFRAME_AT(NBVAR,CLOS,__FILE__,__LINE__)
#define MELT_LOCATION(LOCS) do{meltfram__.mcfr_flocs= LOCS;}while(0)

#define MELT_LOCATION_HERE_AT(FIL,LIN,MSG) do {				\
  static char locbuf_##LIN[88];						\
  if (!locbuf_##LIN[0])							\
    snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d <%s>",	\
	     basename(FIL), (int)LIN, MSG);				\
  meltfram__.mcfr_flocs =  locbuf_##LIN;					\
} while(0)
#define MELT_LOCATION_HERE(MSG)  MELT_LOCATION_HERE_AT(__FILE__,__LINE__,MSG)
#else
#define MELT_DECLFRAME(NBVAR) struct {		\
  int mcfr_nbvar;				\
  struct meltclosure_st* mcfr_clos;		\
  struct excepth_melt_st* mcfr_exh;		\
  struct callframe_melt_st* mcfr_prev;		\
  void*  /* a melt_ptr_t */ mcfr_varptr[NBVAR];	\
} meltfram__
#define MELT_LOCATION(LOCS) do{}while(0)
#define MELT_LOCATION_HERE(MSG) do{}while(0)
/* initialize the current callframe and link it at top */
#define MELT_INITFRAME(NBVAR,CLOS) do {					\
  memset(&meltfram__, 0, sizeof(meltfram__));				\
  meltfram__.mcfr_nbvar = (NBVAR);					\
  meltfram__.mcfr_prev = (struct callframe_melt_st*)melt_topframe;	\
  meltfram__.mcfr_clos = (CLOS);					\
  melt_topframe = ((void*)&meltfram__);					\
} while(0)
#endif


/* declare and initialize the current callframe */
#define MELT_ENTERFRAME(NBVAR,CLOS) \
  MELT_DECLFRAME(NBVAR); MELT_INITFRAME(NBVAR,CLOS)

/* exit the current frame and return */
#define MELT_EXITFRAME() do {		\
    melt_topframe = (struct callframe_melt_st*)(meltfram__.mcfr_prev);	\
} while(0)

/****
#define MELT_CATCH(Vcod,Vptr) do {
  jmp_buf __jbuf;
  int __jcod;
  jmp_buf* __prevj = melt_jmpbuf;
  memset(&__jbuf, 0, sizeof(jmp_buf));
  melt_jmpbuf = &__jbuf;
  __jcod = setjmp(&__jbuf);
  Vcod = __jcod;
  if (__jcod) {
    melt_topframe = ((void*)&meltfram__);
    Vptr = melt_jmpval;
  };
} while(0)

#define MELT_THROW(Cod,Ptr) do {
} while(0)
***/


/* ====== safer output routines ===== */

/* output a string */
static inline void
melt_puts (FILE * f, const char *str)
{
  if (f && str)
    fputs (str, f);
}

/* output a number with a prefix & suffix message */
static inline void
melt_putnum(FILE* f, const char*pref, long l, const char*suff) {
  if (f)
    fprintf(f, "%s%ld%s", pref?pref:"", l, suff?suff:"");
}

/* safe flush */
static inline void
melt_flush (FILE * f)
{
  if (f)
    fflush (f);
}

/* safe newline and flush */
static inline void
melt_newlineflush (FILE * f)
{
  if (f)
    {
      putc ('\n', f);
      fflush (f);
    }
}

/* output a string value */
static inline void
melt_putstr (FILE * f, melt_ptr_t sv)
{
  if (f && sv && melt_magic_discr (sv) == MELTOBMAG_STRING)
    fputs (((struct meltstring_st *) sv)->val, f);
}

/* output a string buffer */
static inline void
melt_putstrbuf (FILE * f, melt_ptr_t sb)
{
  struct meltstrbuf_st *sbuf = (struct meltstrbuf_st *) sb;
  if (f && sbuf && melt_magic_discr ((melt_ptr_t) sbuf) == MELTOBMAG_STRBUF)
    {
      gcc_assert (sbuf->bufzn);
      if (!sbuf->bufzn || sbuf->bufend <= sbuf->bufstart)
	return;
      fwrite (sbuf->bufzn + sbuf->bufstart, sbuf->bufend - sbuf->bufstart, 1,
	      f);
    }
}


/* output the declaration and implementation buffers of a generated
   file with a secondary rank*/
void 
melt_output_cfile_decl_impl_secondary(melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf, int filrank);

/* likewise, for the primary file */
static inline void 
melt_output_cfile_decl_impl(melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf)
{
  melt_output_cfile_decl_impl_secondary (cfilnam, declbuf, implbuf, 0);
}

/* recursive function to output to a file.  Handle boxed integers,
   lists, tuples, strings, strbufs, but don't handle objects! */
void meltgc_output_file (FILE* fil, melt_ptr_t val_p);

#ifdef ENABLE_CHECKING
static inline void
debugeputs_at (const char *fil, int lin, const char *msg)
{
  debugeprintf_raw ("!@%s:%d:\n@! %s\n", basename (fil), lin, msg);
}

#define debugeputs(Msg) debugeputs_at(__FILE__,__LINE__,(Msg))
#endif /* ENABLE_CHECKING */

static inline void
debugvalue_at (const char *fil, int lin, const char *msg, void *val)
{
  if (flag_melt_debug)
    {
      fprintf (stderr, "!@%s:%d:\n@! %s @%p/%d= ",
	       basename (fil), lin, (msg), val, melt_magic_discr ((melt_ptr_t)val));
      melt_dbgeprint (val);
      fflush (stderr);
    }
}

#define debugvalue(Msg,Val) debugvalue_at(__FILE__, __LINE__, (Msg), (Val))

void meltgc_debugmsgval(void* val, const char*msg, long count);

static inline void
debugmsgval_at (const char*fil, int lin, const char* msg, void*val, long count) {
  if (flag_melt_debug)
    {
      fprintf (stderr, "!@%s:%d:\n",
	       basename (fil), lin);
      meltgc_debugmsgval(val, msg, count);
    }
}

#define debugmsgval(Msg,Val,Count) do {					\
    debugmsgval_at(__FILE__,__LINE__,(Msg),(Val),(Count)); } while(0)

static inline void
debugbacktrace_at (const char *fil, int lin, const char *msg, int depth)
{
  if (flag_melt_debug)
    {
      fprintf (stderr, "\n!@%s:%d: %s ** BACKTRACE** ",
	       basename (fil), lin, msg);
      melt_dbgbacktrace (depth);
      fflush (stderr);
    }
}

#define debugbacktrace(Msg,Depth) debugbacktrace_at(__FILE__, __LINE__, (Msg), (Depth))

static inline void
debugnum_at (const char *fil, int lin, const char *msg, long val)
{
  debugeprintf_raw ("!@%s:%d: %s =#= %ld\n", basename (fil), lin, msg, val);
}

#define debugnum(Msg,Val) debugnum_at(__FILE__, __LINE__, (Msg), (Val))


void melt_dbgshortbacktrace(const char* msg, int maxdepth);

#if ENABLE_CHECKING
extern void* melt_checkedp_ptr1;
extern void* melt_checkedp_ptr2;
extern FILE* melt_dbgtracefile;
void melt_caught_assign_at(void*ptr, const char*fil, int lin, const char*msg);
#define melt_checked_assignmsg_at(Assign,Fil,Lin,Msg) ({		\
      void* p_##Lin = (Assign);						\
      if (p_##Lin && !melt_discr(p_##Lin))				\
	melt_assert_failed("bad checked assign (in runtime)",Fil,Lin,__FUNCTION__); \
      if ( (p_##Lin == melt_checkedp_ptr1 && p_##Lin)		\
	   ||  (p_##Lin == melt_checkedp_ptr2 && p_##Lin))		\
	melt_caught_assign_at(p_##Lin,Fil,Lin,Msg); p_##Lin; })
#define melt_checked_assign(Assign) melt_checked_assignmsg_at((Assign),__FILE__,__LINE__,__FUNCTION__)
#define melt_checked_assignmsg(Assign,Msg) melt_checked_assignmsg_at((Assign),__FILE__,__LINE__,Msg)
void melt_cbreak_at(const char*msg, const char*fil, int lin);
#define melt_cbreak(Msg) melt_cbreak_at((Msg),__FILE__,__LINE__)
#define melt_trace_start(Msg,Cnt) do {if (melt_dbgtracefile) \
   fprintf(melt_dbgtracefile, "+%s %ld\n", Msg, (long)(Cnt));} while(0)
#define melt_trace_end(Msg,Cnt) do {if (melt_dbgtracefile) \
   fprintf(melt_dbgtracefile, "-%s %ld\n", Msg, (long)(Cnt));} while(0)
#else
#define melt_checked_assign(Assign) Assign
#define melt_checked_assignmsg(Assign,Msg) Assign
#define melt_cbreak(Msg) ((void)(Msg))
#define melt_trace_start(Msg,Cnt) do{}while(0)
#define melt_trace_end(Msg,Cnt) do{}while(0)
#define debugmsgval(Msg,Val,Count) do {}while(0)
#endif /*ENABLE_CHECKING*/



/* make a new boxed file - the discr should be for a file or a raw
   file */
melt_ptr_t meltgc_new_file(melt_ptr_t discr_p, FILE* fil);

/* get a file from a boxed file, may return NULL */
static inline FILE*
melt_get_file(melt_ptr_t file_p)
{
  int magic;
  if (!file_p)
    return NULL;
  magic = melt_magic_discr (file_p);
  if (magic == MELTOBMAG_SPEC_FILE || magic == MELTOBMAG_SPEC_RAWFILE)
    return ((struct meltspecial_st*)file_p)->val.sp_file;
  return NULL;
}

#if ENABLE_CHECKING
/* two useless routines in wich we can add a breakpoint from gdb. */
void melt_sparebreakpoint_1_at (const char*fil, int lin, void*ptr, const char*msg);
void melt_sparebreakpoint_2_at (const char*fil, int lin, void*ptr, const char*msg);
#define melt_sparebreakpoint_1(P,Msg) melt_sparebreakpoint_1_at(__FILE__,__LINE__,(void*)(P),(Msg))
#define melt_sparebreakpoint_2(P,Msg) melt_sparebreakpoint_2_at(__FILE__,__LINE__,(void*)(P),(Msg))
#else /*no ENABLE_CHECKING*/
#define melt_sparebreakpoint_1(P,Msg) do{(void)(0 && (P));}while(0)
#define melt_sparebreakpoint_2(P,Msg) do{(void)(0 && (P));}while(0)
#endif /*ENABLE_CHECKING*/

/* strangely, gcc/input.h don't define yet that macro. */
#define LOCATION_COLUMN(LOC) ((expand_location (LOC)).column)

extern const char melt_run_preprocessed_md5[]; /* defined in generated file melt-run-md5.h */

#endif /*MELT_INCLUDED_ */

/* eof $Id$ */