/*
******************************************************************
* $Id: bigloo.h 566 2006-11-06 17:20:50Z clerger $
* Copyright (C) 2002, 2003, 2006 by INRIA
* Author: Eric de la Clergerie <Eric.De_La_Clergerie@inria.fr>
* ----------------------------------------------------------------
*
* bigloo.h -- type and gc macros
*
* ----------------------------------------------------------------
* Description
* An old list of macros coming from Bigloo (see below)
* ----------------------------------------------------------------
*/
/*=====================================================================*/
/* serrano/prgm/project/bigloo/runtime1.8/Include/bigloo.h */
/* ------------------------------------------------------------- */
/* Author : Manuel Serrano */
/* Creation : Thu Mar 16 18:48:21 1995 */
/* Last change : Tue Apr 9 17:20:52 1996 (serrano) */
/* ------------------------------------------------------------- */
/* Bigloo's stuff */
/*=====================================================================*/
#ifndef BIGLOO_H
#define BIGLOO_H
/*---------------------------------------------------------------------*/
/* The essential includes */
/*---------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include <math.h>
/*---------------------------------------------------------------------*/
/* System configurations */
/*---------------------------------------------------------------------*/
#undef PTR_ALIGNMENT
#define PTR_ALIGNMENT 2
/*---------------------------------------------------------------------*/
/* Il y a plusieurs formes d'objets: */
/* Les objets allouees: */
/* +--------+--------+--------+--------+ */
/* |....signed fixed point value.....??| */
/* +--------+--------+--------+--------+ */
/* */
/* Les objets immediats 30 bits: */
/* +--------+--------+--------+--------+ */
/* |....signed fixed point value.....??| */
/* +--------+--------+--------+--------+ */
/* */
/* Les objets immediats 6 bits: */
/* +--------+--------+--------+--------+ */
/* |..........................|xxxxxx??| */
/* +--------+--------+--------+--------+ */
/* */
/* Les objets immediats 8 bits: */
/* +--------+--------+--------+--------+ */
/* |.................|xxxxxxxx|......??| */
/* +--------+--------+--------+--------+ */
/* */
/*---------------------------------------------------------------------*/
/*---------------------------------------------------------------------*/
/* Ou sont les `tags' et quel `mask' cela represente. */
/*---------------------------------------------------------------------*/
#define TAG_SHIFT PTR_ALIGNMENT
#define ALIGNMENT_VALUE (1 << PTR_ALIGNMENT)
#define TAG_MASK (ALIGNMENT_VALUE - 1)
/*---------------------------------------------------------------------*/
/* Les `tags' des pointeurs ... */
/*---------------------------------------------------------------------*/
#define TAG_STRUCT 0 /* Les pointer sont tagues ....00 */
#define TAG_INT 1 /* Les integer sont tagues .....01 */
#define TAG_INT_SHIFT 2 /* INT sur 30 bits ; could move to 31 */
#define TAG_PAIR 2 /* Les pairs sont taguees ....10 */
#define TAG_CNST 3 /* Les cnsts sont taguees ....11 */
/*---------------------------------------------------------------------*/
/* Internal Bigloo's types. */
/*---------------------------------------------------------------------*/
typedef int Bool;
#ifndef TRUE
#define TRUE ((Bool) 1)
#define FALSE ((Bool) 0)
#endif /* TRUE */
typedef long int_t;
typedef int_t header_t;
typedef union object {
int_t integer; /* Les entiers */
header_t header; /* Un champs un peu fictif mais */
/* il est utile pour pouvoir acceder */
/* au header des objets sans savoir */
/* quel est leur type. Tous les */
/* headers sont en tete des struct */
/* on peut donc le header global */
/* plutot que les header locaux */
struct pair { /* Les pairs. */
union object *car; /* depend du GC qu'on utilise. */
union object *cdr; /* Dans tous les cas, il y a biensur */
} pair_t; /* un `car' et un `cdr' :-) */
struct procedure { /* Les fermetures */
header_t header;
union object *(*entry)();
union object *(*va_entry)();
long arity;
union object *obj0;
} procedure_t;
} *obj_t;
/*---------------------------------------------------------------------*/
/* Les `type' des structures ... */
/*---------------------------------------------------------------------*/
#define PAIR_TYPE 0
#define PROCEDURE_TYPE 3
/*---------------------------------------------------------------------*/
/* Les procedures d'allocations */
/*---------------------------------------------------------------------*/
#include <gc/gc.h>
# if( defined( TAG_PAIR ) && ( TAG_PAIR != 0) )
# define PAIR_DISPLACEMENT() GC_REGISTER_DISPLACEMENT( TAG_PAIR )
# else
# define PAIR_DISPLACEMENT() 0
# endif
# define INIT_ALLOCATION( size ) \
( GC_init(), \
GC_expand_hp( size ), \
PAIR_DISPLACEMENT(), \
1 )
# define FREE_ALLOCATION();
/*---------------------------------------------------------------------*/
/* Les macros qui servent a taguer/detaguer */
/*---------------------------------------------------------------------*/
#define TAG( val, shift, tag ) ((long)(((long)(val) << shift) | tag))
#define UNTAG( val, shift, tag ) ((long)((long)(val) >> shift))
// Unsigned versions
#define UTAG( val, shift, tag ) ((unsigned long)(((unsigned long)(val) << shift) | tag))
#define UUNTAG( val, shift, tag ) ((unsigned long)((unsigned long)(val) >> shift))
#define POINTERP( o ) (((((long)o) & TAG_MASK) == TAG_STRUCT) && o)
#define CNSTP( o ) ((((long)o) & TAG_MASK) == TAG_CNST)
/*---------------------------------------------------------------------*/
/* Header managment */
/*---------------------------------------------------------------------*/
#define MAKE_HEADER( i, sz ) ((header_t)TAG( i, TYPE_SHIFT, 0 ))
#define NB_BIT 3
#define SIZE_BIT_SIZE 4
#define SIZE_MASK ((1 << SIZE_BIT_SIZE) - 1)
#define TYPE_SHIFT (NB_BIT + SIZE_BIT_SIZE + 1)
/*---------------------------------------------------------------------*/
/* Les macros de conversions utilisees par `Sqic' */
/* ------------------------------------------------------------- */
/* Attention, il est normal que pour faire la conversion `bigloo->c'*/
/* j'utilise une soustraction et non pas un `and'. En faisant comme */
/* ca, le compilateur C peut bien optimiser les access aux */
/* differents champs. */
/*---------------------------------------------------------------------*/
#define BINT( i ) (obj_t)TAG( i, TAG_INT_SHIFT, TAG_INT )
#define CINT( i ) (long)UNTAG( i, TAG_INT_SHIFT, TAG_INT )
#define UBINT( i ) (obj_t)UTAG(i, TAG_INT_SHIFT, TAG_INT )
#define UCINT( i ) (unsigned long)UUNTAG( i, TAG_INT_SHIFT, TAG_INT )
#define BREF( r ) ((obj_t)(r))
#define CREF( r ) ((obj_t)(r))
#define BPAIR( p ) ((obj_t)((long)p | TAG_PAIR))
#define CPAIR( p ) ((obj_t)((long)p - TAG_PAIR))
#define BCNST( c ) (obj_t)TAG( c, TAG_SHIFT, TAG_CNST )
#define CCNST( c ) (long)UNTAG( c, TAG_SHIFT, TAG_CNST )
#define CHAR_SHIFT (TAG_SHIFT + 6)
#define BCHAR( i ) ((obj_t)((long)BCHARH + \
((long)((unsigned char)(i) << CHAR_SHIFT))))
#define CCHAR( i ) ((unsigned char)((unsigned long)(i)>>CHAR_SHIFT))
/*---------------------------------------------------------------------*/
/* Les `constantes' peuvent etre soit allouees soit constante. */
/*---------------------------------------------------------------------*/
#define BFLTH ((obj_t)BCNST(0))
/* require all other kinds of constants to have their weakest bit set to 1
this way we can use 29 bits to wrap floats in DyALog
*/
#define BNIL ((obj_t)BCNST( 1 ))
#define BFALSE ((obj_t)BCNST( 3 ))
#define BTRUE ((obj_t)BCNST( 5 ))
#define BUNSPEC ((obj_t)BCNST( 7 ))
#define BCHARH ((obj_t)BCNST( 9 ))
#define BEOA ((obj_t)BCNST( 0x101 ))
/*---------------------------------------------------------------------*/
/* Static allocations. */
/*---------------------------------------------------------------------*/
#define DEFINE_STATIC_PROCEDURE( n, na, p, vp, nb_args ) \
struct procedure na = { MAKE_HEADER( PROCEDURE_TYPE, 0 ), \
(obj_t (*)())p, \
(obj_t (*)())vp, \
nb_args }; \
static obj_t n = BREF( &na )
/*---------------------------------------------------------------------*/
/* Pairs */
/*---------------------------------------------------------------------*/
#define PAIR_SIZE (sizeof( struct pair ))
#define PAIR( o ) (CPAIR( o )->pair_t)
extern obj_t make_pair();
#define MAKE_PAIR( a, d ) make_pair( a, d )
#define PAIRP( c ) ((((long)c) & TAG_MASK) == TAG_PAIR)
#define NULLP( c ) ((long)(c) == (long)BNIL)
#define CAR( c ) (PAIR( c ).car)
#define CDR( c ) (PAIR( c ).cdr)
#define SET_CAR( c, v ) ((CAR(c) = v), BUNSPEC)
#define SET_CDR( c, v ) ((CDR(c) = v), BUNSPEC)
/*---------------------------------------------------------------------*/
/* Procedures */
/*---------------------------------------------------------------------*/
#define PROCEDURE_SIZE (sizeof( struct procedure ))
#define PROCEDURE( o ) CREF( o )->procedure_t
#define PROCEDURE_ENTRY( fun ) (obj_t)(PROCEDURE( fun ).entry)
/*---------------------------------------------------------------------*/
/* Numbers */
/*---------------------------------------------------------------------*/
#define INTEGERP( o ) ((((long)o) & TAG_MASK) == TAG_INT)
/*---------------------------------------------------------------------*/
/* characters */
/*---------------------------------------------------------------------*/
#define CHARP( o ) (((long)(o) & (long)((1 << (CHAR_SHIFT)) -1)) == (long)BCHARH)
/*---------------------------------------------------------------------*/
/* floats */
/*---------------------------------------------------------------------*/
#define FLT_SHIFT (TAG_SHIFT + 1)
#define FLT_MASK ((1 << FLT_SHIFT) - 1)
#define FLOATP(o) ((((long)o) & FLT_MASK) == (long) BFLTH)
#define BFLT( f ) bfloat(f)
#define CFLT( f ) cfloat(f)
typedef union
{
unsigned long i;
float f;
} flt;
static inline
obj_t bfloat (float f)
{
return (obj_t) ((((flt) { f : f }).i >> FLT_SHIFT) << FLT_SHIFT | ((long) BFLTH));
}
static inline
float cfloat (obj_t i)
{
return ((flt) { i : (((unsigned long) i) - ((long) BFLTH)) }).f;
}
static inline
long float2long(float f)
{
return ((flt){f:f}).i;
}
static inline
float long2float(long i)
{
return ((flt){i:i}).f;
}
#endif
