/* ****************************************************************** * $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