/*=====================================================================*/
/*    serrano/prgm/project/bigloo/runtime/Clib/ccontrol.c              */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Mon Apr 17 13:16:31 1995                          */
/*    Last change :  Fri Nov 14 17:33:33 2003 (serrano)                */
/*    -------------------------------------------------------------    */
/*    Closure allocations.                                             */
/*=====================================================================*/
#include <bigloo.h>
#include <stdarg.h>

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    make_fx_procedure ...                                            */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
make_fx_procedure( obj_t (*entry)(), int arity, int size ) {
   obj_t a_tproc;
   int  byte_size;
 
   byte_size = PROCEDURE_SIZE + ((size-1) * OBJ_SIZE);

   a_tproc = GC_MALLOC( byte_size );
	      
   a_tproc->procedure_t.header   = MAKE_HEADER( PROCEDURE_TYPE, byte_size );
   a_tproc->procedure_t.entry    = entry; 
   a_tproc->procedure_t.va_entry = 0L;
   a_tproc->procedure_t.arity    = arity;
	
   return BGL_HEAP_DEBUG_MARK_OBJ( BREF( a_tproc ) );
}

/*---------------------------------------------------------------------*/
/*    make_va_procedure ...                                            */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
make_va_procedure( obj_t (*entry)(), int arity, int size ) {
   obj_t a_tproc;
   int  byte_size;

   byte_size = PROCEDURE_SIZE + ((size-1) * OBJ_SIZE);

   a_tproc = GC_MALLOC( byte_size );

   a_tproc->procedure_t.header   = MAKE_HEADER( PROCEDURE_TYPE, byte_size );
   a_tproc->procedure_t.entry    = (obj_t (*)())va_generic_entry; 
   a_tproc->procedure_t.va_entry = entry;
   a_tproc->procedure_t.arity    = arity;
	
   return BGL_HEAP_DEBUG_MARK_OBJ( BREF( a_tproc ) );
}

/*---------------------------------------------------------------------*/
/*    va_generic_entry ...                                             */
/*    -------------------------------------------------------------    */
/*    Tous les tests d'arite ont ete expanses `inline'. On n'a plus    */
/*    qu'a faire l'appel.                                              */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
va_generic_entry( obj_t proc, ... ) {
   va_list argl;
   int     arity;
   int     require;
   obj_t   arg[ 16 ];
   obj_t   optional;
   obj_t   runner;
   long    i;
      
   va_start( argl, proc );
   
   arity  = PROCEDURE_ARITY( proc );
   require = -arity - 1;

   for( i = 0; i < require; i++ )
      arg[ i ] = va_arg( argl, obj_t );

   if( (runner = va_arg( argl, obj_t )) != BEOA )
   {
      obj_t tail;
      
      optional = tail = MAKE_PAIR( runner, BNIL );
      
      while( (runner = va_arg( argl, obj_t )) != BEOA )
      {
         SET_CDR( tail, MAKE_PAIR( runner, BNIL ) );
         tail = CDR( tail );
      } 
   }
   else
      optional = BNIL;

   va_end( argl );
   
#define CALL( proc ) ((obj_t (*)())PROCEDURE_VA_ENTRY( proc ))      
   switch( arity )
   {
      case -1  : return CALL( proc )(proc, optional);
      case -2  : return CALL( proc )(proc, arg[ 0 ], optional);
      case -3  : return CALL( proc )(proc, arg[ 0 ], arg[ 1 ], optional);
      case -4  : return CALL( proc )(proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                      optional);
      case -5  : return CALL( proc )(proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], optional);
      case -6  : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], optional);
      case -7  : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     optional);
      case -8  : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], optional);
      case -9  : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], optional);
      case -10 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     optional);
      case -11 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], optional);
      case -12 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], optional);
      case -13 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], arg[ 11 ],
                                     optional);
      case -14 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], arg[ 11 ],
                                     arg[ 12 ], optional);
      case -15 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], arg[ 11 ],
                                     arg[ 12 ], arg[ 13 ], optional);
      case -16 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], arg[ 11 ],
                                     arg[ 12 ], arg[ 13 ], arg[ 14 ],
                                     optional);
      case -17 : return CALL( proc )( proc, arg[ 0 ], arg[ 1 ], arg[ 2 ],
                                     arg[ 3 ], arg[ 4 ], arg[ 5 ],
                                     arg[ 6 ], arg[ 7 ], arg[ 8 ],
                                     arg[ 9 ], arg[ 10 ], arg[ 11 ],
                                     arg[ 12 ], arg[ 13 ], arg[ 14 ],
                                     arg[ 15 ], optional);
      
      default: FAILURE( string_to_bstring( "va_generic_entry" ),
		        string_to_bstring( "too many argument expected" ),
		        BINT( arity ) );
   }
   return BNIL;
}
