/* generate.c: -*- C -*-  DESCRIPTIVE TEXT. */

/*  Copyright (c) 1996 Universal Access Inc.
    Author: E. B. Gamble Jr. (ebg@ai.mit.edu) Wed Nov  6 16:28:50 1996.  */

#include <stdio.h>
#include <unistd.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <assert.h>

#include "compile.h"
#include "code.h"

/*********************************************************************
 *
 *
 * BC_LAP_T
 *
 */
typedef struct bc_lap {
  bc_byte_code_t instr [BC_MAXIMUM_BYTEOP_LEN];
  struct bc_lap *next;
} *bc_lap_t;

#define BC_LAP_OPERATOR( lap )     ((lap)->instr[0])
#define BC_LAP_OPERAND( lap, n )   ((lap)->instr[(n)]) /* ONE based */
#define BC_LAP_NEXT( lap )         ((lap)->next)
#define BC_LAP_INSTR_LENGTH( lap ) \
  BC_BYTE_CODE_SPEC_LENGTH (& bc_byte_code_spec_table [ BC_LAP_OPERATOR (lap)])

#define FOR_LAP( lap, lap_head ) \
  for ( lap = (lap_head); lap ; lap = lap->next)

/* Could cache these allocations */

static bc_lap_t
bc_lap_new (void)
{
  return ((bc_lap_t) xmalloc (sizeof (struct bc_lap)));
}

#define bc_lap_free  free

static void
bc_lap_free_all (bc_lap_t lap)
{
  bc_lap_t next;
  for (; lap; lap = next)
    {
      next = BC_LAP_NEXT (lap);
      bc_lap_free (lap);
    }
}

/*****************************************************************************
 *
 * BC_LAP_QUEUE_T
 *
 * Record the head and tail of a lap sequence into the LAP_QUEUE.
 * This allows order (1) append operations.
 */
typedef struct bc_lap_queue {
  bc_lap_t head;
  bc_lap_t tail;
} bc_lap_queue_t;

static inline void
bc_lap_queue_init (bc_lap_queue_t *queue,
		   bc_lap_t head,
		   bc_lap_t tail)
{
  queue->head = head;
  queue->tail = tail;
}

static inline void
bc_lap_queue_clear (bc_lap_queue_t *queue)
{
  queue->head =
    queue->tail = (bc_lap_t) NULL;
}

static inline void
bc_lap_queue_explode (bc_lap_queue_t *queue,
		      bc_lap_t *head,
		      bc_lap_t *tail)
{
  *head = queue->head;
  *tail = queue->tail;
}

/* Need to handle NULL cases for TAIL and HEAD */

static void
bc_lap_queue_append_2 (bc_lap_queue_t *queue_1,
		       bc_lap_queue_t *queue_2)
{
  if (! queue_1->head)
    {
      queue_1->head = queue_2->head;
      queue_1->tail = queue_2->tail;
    }
  else
    {
      queue_1->tail->next = queue_2->head;
      queue_1->tail = queue_2->tail;
    }
}

static void
bc_lap_queue_append_3 (bc_lap_queue_t *queue_1,
		       bc_lap_queue_t *queue_2,
		       bc_lap_queue_t *queue_3)
{
  bc_lap_queue_append_2 (queue_2, queue_3);
  bc_lap_queue_append_2 (queue_1, queue_2);
}

static void
bc_lap_queue_append_4 (bc_lap_queue_t *queue_1,
		       bc_lap_queue_t *queue_2,
		       bc_lap_queue_t *queue_3,
		       bc_lap_queue_t *queue_4)
{
  bc_lap_queue_append_3 (queue_2, queue_3, queue_4);
  bc_lap_queue_append_2 (queue_1, queue_2);
}

static void
bc_lap_queue_extend (bc_lap_queue_t *queue,
		     bc_lap_t lap)
{
  if (lap) assert (lap->next == (bc_lap_t) NULL);

  if (! queue->head)
    queue->head =
      queue->tail = lap;
  else
    {
      queue->tail->next = lap;
      queue->tail = lap;
    }
}
				 


/*****************************************************************************
 *
 *
 * ASSEMBLE
 *
 * Remember JUMP targets can be ZERO */
static void
bc_assemble (bc_lap_t lap,
	     unsigned int jump_label,
	     bc_byte_code_t **code_ptr_addr,
	     unsigned int   *code_count_addr)
{
  bc_byte_code_t *code, *cp;
  bc_lap_t lap_save = lap;
  unsigned int count = 0;

  unsigned int *jump_table = (unsigned int *)xmalloc
    ((1 + jump_label) * sizeof (unsigned int));

  /* Construct the JUMP_TABLE and determine the overall
     length of the byte_code vector*/
  FOR_LAP (lap, lap_save)
    {
      if (BC_LAP_OPERATOR (lap) == BC_LABEL_OP)
	{
	  unsigned int index = 
	    BC_LAP_OPERAND (lap, 1) * 256 + BC_LAP_OPERAND (lap, 2);
	  jump_table [index] = count;

	  /* Implementation restriction, (< count (ash 1 16)) */

	}
      else
	count += BC_LAP_INSTR_LENGTH (lap);
    }

  /* Patch the JUMP byte_ops with values from JUMP_TABLE */
  FOR_LAP (lap, lap_save)
    switch (BC_LAP_OPERATOR (lap))
      {
      case BC_JUMP_OP:
      case BC_JUMP_IF_FALSE_OP:
      case BC_JUMP_IF_TRUE_OP:
      case BC_JUMP_IF_EQ_OP:
	{
	  unsigned int index = 
	    BC_LAP_OPERAND (lap, 1) * 256 + BC_LAP_OPERAND (lap, 2);
	  unsigned int count = jump_table [index];
	  BC_LAP_OPERAND (lap, 1) = count / 256;
	  BC_LAP_OPERAND (lap, 2) = count % 256;
	  break;
	}
      default:
	break;
      }

  free (jump_table);
  lap = lap_save;

  cp = code = (bc_byte_code_t *) malloc (count * sizeof (bc_byte_code_t));
  if (! code)
    fail ();

  /* Move the lap instructions into the byte_code vector */
  FOR_LAP (lap, lap_save)
    if (BC_LAP_OPERATOR (lap) != BC_LABEL_OP)
      {
	bc_byte_code_t *instr = lap->instr;
	unsigned int index, count;

	for (index = 0, count = BC_LAP_INSTR_LENGTH (lap);
	     index < count;
	     index++)
	  *cp++ = *instr++;
      }

  *code_ptr_addr   = code;
  *code_count_addr = count;
  return;
}

/********************************************************************
 * 
 * PEEPHLE OPTIMIZER
 *
 *
 */
static void bc_peephole (bc_lap_t *lap_ptr)
{
  return;
}

/***********************************************************************
 *
 * BC_MACHINE_T
 *
 *
 */
#define BC_MACHINE_DEFAULT_NUMBER_OF_CONSTANTS 256
#define BC_MACHINE_DEFAULT_NUMBER_OF_LOCALS    256

typedef struct bc_machine
{
  struct bc_tagged_object *constants;	/* constants */
  unsigned int constants_count;
  unsigned int constants_limit;

  /* Jump label - then functions have their own labels
     all starting at zero and easy to patch.  */
  unsigned int jump_label;

  /* ... */
  bc_object_t *stack_map;	/* locals to stack location */
  unsigned int stack_size;
  unsigned int stack_limit;

  /* Array of LOCAL variables - in a function call.  The array index
     determines the stack position. */

  /* WRONG - needs to associate a local with a current stack position */
  bc_symbol_t *locals;
  unsigned int locals_count;
  unsigned int locals_limit;
  
} *bc_machine_t;

static bc_machine_t
bc_machine_new (void)
{
  bc_machine_t machine = (bc_machine_t) xmalloc (sizeof (struct bc_machine));

  machine->constants_count = 
    machine->constants_limit = 0;

  machine->jump_label = 0;

  machine->stack_size =
    machine->stack_limit = 0;

  machine->locals_count = 
    machine->locals_limit = 0;
  
  return (machine);
}

static void
bc_machine_free (bc_machine_t machine)
{
  if (machine->constants)
    free (machine->constants);

  if (machine->locals)
    free (machine->locals);

  /* More ... */

  /* Clear */
  free (machine);
}

static unsigned int
bc_machine_new_label (bc_machine_t machine)
{
  return (machine->jump_label++);
}

static unsigned int
bc_machine_new_constant (bc_machine_t machine,
			 bc_object_t  constant,
			 bc_type_t    type)
{
  bc_tagged_object_t tagged;
  unsigned int offset = 0;

  for (; offset < machine->constants_count; offset++)
    {
      tagged = & machine->constants [offset];
      /* Compare in a meaningful way.  This is not it... */
      if (constant == BC_TAGGED_OBJECT_VALUE (tagged) &&
	  type     == BC_TAGGED_OBJECT_TYPE  (tagged))
	return (offset);
    }

  if (machine->constants_count == machine->constants_limit)
    {
      /* Increase the constants_limit */
      machine->constants_limit += BC_MACHINE_DEFAULT_NUMBER_OF_CONSTANTS;
      machine->constants =
	realloc (machine->constants, 
		 machine->constants_limit * 
		 sizeof (struct bc_tagged_object));

      if (! machine->constants)
	{
	  fail ();
	}
    }
  tagged = & machine->constants [machine->constants_count];
  BC_TAGGED_OBJECT_VALUE (tagged) = constant;
  BC_TAGGED_OBJECT_TYPE  (tagged) = type;
  return (machine->constants_count++);
}

static void
bc_machine_stack_adjust (bc_machine_t machine,
			 unsigned int count)
{
  machine->stack_size += count;
  if (machine->stack_size > machine->stack_limit)
    machine->stack_limit = machine->stack_size;
}

static unsigned int
bc_machine_find_local_index (bc_machine_t machine,
			     bc_symbol_t  local)
{
  /* Returns -1 if not a local */
  unsigned int index;

  for (index = 0; index < machine->locals_count; index++)
    if (local == machine->locals [index])
      return (index);
  return (-1);
}

static unsigned int
bc_machine_new_local (bc_machine_t machine,
		      bc_symbol_t  local)
{
  unsigned int index =
    bc_machine_find_local_index (machine, local);
  
  if (index != -1)
    return (index);

  if (machine->locals_count == machine->locals_limit)
    {
      /* Increase the constants_limit */
      machine->locals_limit += BC_MACHINE_DEFAULT_NUMBER_OF_CONSTANTS;
      machine->locals =
	realloc (machine->locals, 
		 machine->locals_limit * sizeof (bc_symbol_t));

      if (! machine->locals)
	{
	  fail ();
	}
    }
  machine->locals [machine->locals_count] = local;
  return (machine->locals_count++);
}

static void
bc_machine_new_locals (bc_machine_t machine,
		       bc_symbol_t *locals,
		       unsigned int locals_count)
{
  /* For understandability of generated code make sure the locals appear
     on the stack in the order provided in LOCALS */
  while (locals_count--)
    bc_machine_new_local (machine, locals [locals_count]);
}

    

/********************************************************************
 * 
 *
 *  GENERATE
 *
 * Need a way to compare constants (particularly of bc_object_t
 * includes things besides bc_string_t).  Or just put all the objects
 * into the constants vector and forget duplicates?  Don't we already
 * have functions somewhere...
 *
 * General Lap Generators - by OPERAND count
 *
 */
static bc_lap_t 
bc_gen_op_ZERO (bc_machine_t machine,
		int stack_offset,
		bc_byte_op_t operator)
{
  bc_lap_t lap = bc_lap_new ();
  BC_LAP_OPERATOR (lap) = operator;
  bc_machine_stack_adjust (machine, stack_offset);
  return (lap);
}

static bc_lap_t 
bc_gen_op_ONE (bc_machine_t machine,
	       int stack_offset,
	       bc_byte_op_t operator,
	       bc_byte_op_t operand1)
{
  bc_lap_t lap = bc_lap_new ();
  BC_LAP_OPERATOR (lap)    = operator;
  BC_LAP_OPERAND  (lap, 1) = operand1;
  bc_machine_stack_adjust (machine, stack_offset);
  return (lap);
}

static bc_lap_t 
bc_gen_op_TWO (bc_machine_t machine,
	       int stack_offset,
	       bc_byte_op_t operator,
	       bc_byte_op_t operand1,
	       bc_byte_op_t operand2)
{
  bc_lap_t lap = bc_lap_new ();
  BC_LAP_OPERATOR (lap)    = operator;
  BC_LAP_OPERAND  (lap, 1) = operand1;
  BC_LAP_OPERAND  (lap, 2) = operand2;
  bc_machine_stack_adjust (machine, stack_offset);
  return (lap);
}

static bc_lap_t
bc_gen_op_THREE (bc_machine_t machine,
		 int stack_offset,
		 bc_byte_op_t operator,
		 bc_byte_op_t operand1,
		 bc_byte_op_t operand2,
		 bc_byte_op_t operand3)
{
  bc_lap_t lap = bc_lap_new ();
  BC_LAP_OPERATOR (lap)    = operator;
  BC_LAP_OPERAND  (lap, 1) = operand1;
  BC_LAP_OPERAND  (lap, 2) = operand2;
  BC_LAP_OPERAND  (lap, 3) = operand3;
  bc_machine_stack_adjust (machine, stack_offset);
  return (lap);
}

/*
 *
 * Lap Generators for Byte Operators
 *
 */
static inline bc_lap_t 
bc_gen_op_LABEL (bc_machine_t machine,
		 unsigned long count)
{ 
  return (bc_gen_op_TWO (machine, 0, BC_LABEL_OP,
			 count / 256,
			 count % 256));
}

static inline bc_lap_t
bc_gen_op_CALL (bc_machine_t machine,
		unsigned int format_index,
		unsigned int operand_count)
{
  /* Return one value, pop COUNT arguments. */
  return (bc_gen_op_TWO (machine, 1 - operand_count, BC_CALL_OP, 
			 format_index,
			 operand_count));
}

static inline bc_lap_t
bc_gen_op_RETURN (bc_machine_t machine)
{ return (bc_gen_op_ZERO (machine, 0, BC_RETURN_OP)); }

static inline bc_lap_t
bc_gen_op_JUMPING (bc_machine_t machine,
		   int           stack_offset,
		   unsigned long count,
		   bc_byte_op_t operator)
{
  return (bc_gen_op_TWO (machine, stack_offset, operator,
			 count / 256,
			 count % 256));
}

static inline bc_lap_t
bc_gen_op_JUMP (bc_machine_t machine,
		unsigned long count)
{ return (bc_gen_op_JUMPING (machine, 0, count, BC_JUMP_OP)); }

static inline bc_lap_t
bc_gen_op_JUMP_IF_FALSE (bc_machine_t machine,
			 unsigned long count)
{ return (bc_gen_op_JUMPING (machine, -1, count, BC_JUMP_IF_FALSE_OP)); }

static inline bc_lap_t
bc_gen_op_JUMP_IF_TRUE (bc_machine_t machine,
			 unsigned long count)
{ return (bc_gen_op_JUMPING (machine, -1, count, BC_JUMP_IF_TRUE_OP)); }

static inline bc_lap_t
bc_gen_op_JUMP_IF_EQ (bc_machine_t machine,
		      unsigned long count)
{ return (bc_gen_op_JUMPING (machine, -2, count, BC_JUMP_IF_EQ_OP)); }
  
static inline bc_lap_t
bc_gen_op_POP (bc_machine_t machine)
{ return (bc_gen_op_ZERO (machine, -1, BC_POP_OP)); }

static inline bc_lap_t
bc_gen_op_DUP (bc_machine_t machine)
{ return (bc_gen_op_ZERO (machine, 1, BC_DUP_OP)); }

static inline bc_lap_t
bc_gen_op_DATA (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 1, BC_DATA_OP, offset)); }

static inline bc_lap_t
bc_gen_op_FMT (bc_machine_t machine,
	       unsigned int index,
	       unsigned int count)
{ return (bc_gen_op_TWO (machine, 1 - count, BC_FMT_OP, index, count)); }

static inline bc_lap_t
bc_gen_op_PROG (bc_machine_t machine,
		unsigned int count)
{
  /* Return one value, pop COUNT arguments. */
  return (bc_gen_op_ONE (machine, 1 - count, BC_PROG_OP, count));
}

/* Variable GET // Variable SET */
static inline bc_lap_t
bc_gen_op_VGET (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 1, BC_VGET_OP, offset)); }

static inline bc_lap_t
bc_gen_op_VSET (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 0, BC_VSET_OP, offset)); }

/* Function GET // Variable SET */
static inline bc_lap_t
bc_gen_op_FGET (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 1, BC_FGET_OP, offset)); }

static inline bc_lap_t
bc_gen_op_FSET (bc_machine_t machine,
		unsigned int index)
{ return (bc_gen_op_ONE (machine, 1, BC_FSET_OP, index)); }

/* Stack GET // Stack SET */
static inline bc_lap_t
bc_gen_op_SGET (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 1, BC_SGET_OP, offset)); }

static inline bc_lap_t
bc_gen_op_SSET (bc_machine_t machine,
		unsigned int offset)
{ return (bc_gen_op_ONE (machine, 0, BC_SSET_OP, offset)); }


/*
 *
 * Lap Queue Generators - Helpers for Byte Core Ops
 *
 *
 */
typedef enum {
  BC_USAGE_FOR_EFFECT,
  BC_USAGE_FOR_VALUE,
  BC_USAGE_FOR_RETURN
} bc_usage_t;

/* Forward Definition for recursive calls */
static void
bc_gen (bc_machine_t    machine,
	bc_lap_queue_t *queue,
	bc_core_t       core,
	bc_usage_t      usage);

static inline void
bc_gen_return (bc_machine_t    machine,
	       bc_lap_queue_t *queue)
{ bc_lap_queue_extend (queue, bc_gen_op_RETURN (machine)); }

static inline void
bc_gen_pop (bc_machine_t    machine,
	    bc_lap_queue_t *queue)
{ bc_lap_queue_extend (queue, bc_gen_op_POP (machine)); }

static void 
bc_gen_tail (bc_machine_t    machine,
	     bc_lap_queue_t *queue,
	     bc_usage_t      usage)
{
  switch (usage)
    {
    case BC_USAGE_FOR_RETURN:
      bc_gen_return (machine, queue);
      break;
    case BC_USAGE_FOR_VALUE:
      break;
    case BC_USAGE_FOR_EFFECT:
      bc_gen_pop (machine, queue); /* !! PUT !! */
      break;
    }
}

static void
bc_gen_constant (bc_machine_t    machine,
		 bc_lap_queue_t *queue,
		 bc_string_t     constant,
		 bc_usage_t      usage)
{
  if (usage != BC_USAGE_FOR_EFFECT) 
    {
      unsigned int offset = 
	bc_machine_new_constant (machine, constant, BC_STRING_TYPE);

      bc_lap_queue_extend (queue, bc_gen_op_DATA (machine, offset));
      bc_gen_tail (machine, queue, usage);
    }
}

static void
bc_gen_stacked (bc_machine_t    machine,
		bc_lap_queue_t *queue,
		bc_core_t      *cores,
		unsigned int    cores_count)
{
  for (; cores_count; cores_count--, cores++)
    bc_gen (machine, queue, *cores, BC_USAGE_FOR_VALUE);
}

static void
bc_gen_func (bc_machine_t    machine,
	     bc_lap_queue_t *queue,
	     bc_symbol_t     symbol,
	     bc_usage_t      usage)
{
  if (usage != BC_USAGE_FOR_EFFECT) 
    {
      unsigned int offset = 
	bc_machine_new_constant (machine, symbol, BC_SYMBOL_TYPE);

      bc_lap_queue_extend (queue, bc_gen_op_FGET (machine, offset));
      bc_gen_tail (machine, queue, usage);
    }
}

static void
bc_gen_ref (bc_machine_t    machine,
	    bc_lap_queue_t *queue,
	    bc_symbol_t     symbol,
	    bc_usage_t      usage)
{
  if (usage != BC_USAGE_FOR_EFFECT) 
    {
      /* Check for a local variable */
      unsigned int offset =
	bc_machine_find_local_index (machine, symbol);
      
      if (offset != -1)
	bc_lap_queue_extend (queue, bc_gen_op_SGET (machine, offset));
      else
	{
	  offset =  bc_machine_new_constant (machine, symbol, BC_SYMBOL_TYPE);
	  bc_lap_queue_extend (queue,  bc_gen_op_VGET (machine, offset));
	}
      bc_gen_tail (machine, queue, usage);
    }
}

static void
bc_gen_asgn (bc_machine_t    machine,
	     bc_lap_queue_t *queue,
	     bc_symbol_t     symbol,
	     bc_core_t       value,
	     bc_usage_t      usage)
{
  unsigned int offset = 
    bc_machine_new_constant (machine, symbol, BC_SYMBOL_TYPE);
  bc_gen (machine, queue, value, BC_USAGE_FOR_VALUE);
  bc_lap_queue_extend (queue, bc_gen_op_VSET (machine, offset));
  bc_gen_tail (machine, queue, usage);
}
  
/*
 * Lap Queue Generators for Byte Core Ops
 *
 */
static void
bc_gen_core_data (bc_machine_t    machine,
		  bc_lap_queue_t *queue,
		  bc_core_t       core,
		  bc_usage_t      usage)
{
  bc_gen_constant (machine, queue, 
		   BC_CORE_DATA_STRING (core),
		   usage);
}

static void
bc_gen_core_var (bc_machine_t    machine,
		 bc_lap_queue_t *queue,
		 bc_core_t       core,
		 bc_usage_t      usage)
{
  /* Generate VGET or SGET */
  bc_gen_ref (machine, queue, BC_CORE_VAR_SYMBOL (core), usage);
}

static void
bc_gen_core_set (bc_machine_t    machine,
		 bc_lap_queue_t *queue,
		 bc_core_t       core,
		 bc_usage_t      usage)
{
  bc_gen_asgn (machine, queue,
	       BC_CORE_SET_SYMBOL (core),
	       BC_CORE_SET_VALUE  (core),
	       usage);
}

static void
bc_gen_core_app (bc_machine_t    machine,
		 bc_lap_queue_t *queue,
		 bc_core_t       core,
		 bc_usage_t      usage)
{
  bc_format_t  format   = BC_CORE_APP_FORMAT   (core);
  bc_core_t    operator = BC_CORE_APP_OPERATOR (core);
  bc_core_t   *operands = BC_CORE_APP_OPERANDS (core);
  unsigned int operand_count =
    BC_CORE_APP_OPERAND_COUNT (core);

  /* OPERATOR must be a symbol as per MHTML and thus expand.c */
  /* Should code that into core.h */
  bc_symbol_t symbol = BC_CORE_VAR == BC_CORE_OP (operator)
    ? BC_CORE_VAR_SYMBOL (operator)
    : (fail(), NULL);

  unsigned int format_index = 
    bc_machine_new_constant (machine, format, BC_FORMAT_TYPE);

  bc_gen_func (machine, queue, symbol, BC_USAGE_FOR_VALUE);
  
  bc_gen_stacked (machine, queue, operands, operand_count);

  bc_lap_queue_extend
    (queue, bc_gen_op_CALL (machine, format_index, operand_count));

  /* Be willing to POP the result - or make a 'tail call' */
  bc_gen_tail (machine, queue, usage);
}

static void
bc_gen_core_if (bc_machine_t    machine,
		bc_lap_queue_t *queue,
		bc_core_t       core,
		bc_usage_t      usage)
{
  /* This is way too simple and wrong... but good enough for now 
     Standing errors: 
       failed to merge CONS and ALT stacks,
       failed to handle tail calls,
     */
  unsigned long 
    else_label = bc_machine_new_label (machine),
    exit_label = bc_machine_new_label (machine);

  /* pred */
  bc_gen (machine, queue,
	  BC_CORE_IF_PRED (core),
	  BC_USAGE_FOR_VALUE);

  /* (JUMP_IF_FALSE else) */
  bc_lap_queue_extend
    (queue, bc_gen_op_JUMP_IF_FALSE (machine, else_label));

  /* cons */
  bc_gen (machine, queue,
	  BC_CORE_IF_CONS (core),
	  BC_USAGE_FOR_VALUE);

  /* (JUMP exit) */
  bc_lap_queue_extend
    (queue, bc_gen_op_JUMP (machine, exit_label));

  /* (LABEL else) */
  bc_lap_queue_extend
    (queue, bc_gen_op_LABEL (machine, else_label));

  /* alt */
  bc_gen (machine, queue,
	  BC_CORE_IF_ALT (core),
	  BC_USAGE_FOR_VALUE);

  /* (LABEL exit) */
  bc_lap_queue_extend
    (queue, bc_gen_op_LABEL (machine, exit_label));
  
  bc_gen_tail (machine, queue, usage);
}

static void
bc_gen_core_or (bc_machine_t    machine,
		bc_lap_queue_t *queue,
		bc_core_t       core,
		bc_usage_t      usage)
{
  unsigned long 
    done_label = bc_machine_new_label (machine);

  bc_core_t   *cores       = BC_CORE_OR_CORES (core);
  unsigned int cores_count = BC_CORE_OR_CORE_COUNT (core);
  
  while (cores_count--)
    {
      /* exp */
      bc_gen (machine, queue, *cores++, BC_USAGE_FOR_VALUE);

      if (cores_count)
	{
	  /*  DUP */
	  bc_lap_queue_extend
	    (queue, bc_gen_op_DUP (machine));
      
	  /* (JUMP_IF_TRUE else) */
	  bc_lap_queue_extend
	    (queue, bc_gen_op_JUMP_IF_TRUE (machine, done_label));

	  /*  POP */
	  bc_lap_queue_extend
	    (queue, bc_gen_op_POP (machine));
	}
    }

  /* (LABEL else) */
  bc_lap_queue_extend
    (queue, bc_gen_op_LABEL (machine, done_label));

  bc_gen_tail (machine, queue, usage);
}

static void
bc_gen_core_prog (bc_machine_t    machine,
		  bc_lap_queue_t *queue,
		  bc_core_t       core,
		  bc_usage_t      usage)
{
  bc_core_t   *cores       = BC_CORE_PROG_CORES (core);
  unsigned int cores_count = BC_CORE_PROG_CORE_COUNT (core);

  /* The BC_PROG_OP byte-op will produce a vector on the stack.
     A vector being a string with some '\n' characters.
     
     <defun foo a b>
        "abc"
        <prog "def" "hij">
        "klm"
	</defun>

	*/

  /*  
  for (; cores_count; cores_count--, cores++)
    bc_gen (machine, queue, *cores,
	    (1 != cores_count
	     ? BC_USAGE_FOR_EFFECT
	     : usage));
	     */

  bc_gen_stacked (machine, queue, cores, cores_count);

  bc_lap_queue_extend
    (queue, bc_gen_op_PROG (machine, cores_count));

  /* Be willing to POP the result - or make a 'tail call' */
  bc_gen_tail (machine, queue, usage);

}

static void
bc_gen_core_fmt (bc_machine_t    machine,
		 bc_lap_queue_t *queue,
		 bc_core_t       core,
		 bc_usage_t      usage)
{
  unsigned int index = 
    bc_machine_new_constant (machine, 
			     BC_CORE_FMT_FORMAT (core),
			     BC_FORMAT_TYPE);

  bc_gen_stacked (machine, queue,
		  BC_CORE_FMT_CORES (core),
		  BC_CORE_FMT_CORE_COUNT (core));

  bc_lap_queue_extend
    (queue, bc_gen_op_FMT (machine, index, BC_CORE_FMT_CORE_COUNT (core)));

  bc_gen_tail (machine, queue, usage);
}

static void
bc_gen_core_while (bc_machine_t    machine,
		   bc_lap_queue_t *queue,
		   bc_core_t       core,
		   bc_usage_t      usage)
{
  unsigned long 
    entry_label = bc_machine_new_label (machine),
    exit_label  = bc_machine_new_label (machine);

  /* (LABEL entry) */
  bc_lap_queue_extend
    (queue, bc_gen_op_LABEL (machine, entry_label));

  /* test */
  bc_gen (machine, queue,
	  BC_CORE_WHILE_TEST (core),
	  BC_USAGE_FOR_VALUE);

  /* (JUMP_IF_FALSE exit) */
  bc_lap_queue_extend
    (queue, bc_gen_op_JUMP_IF_FALSE (machine, exit_label));

  /* body */
  bc_gen (machine, queue,
	  BC_CORE_WHILE_BODY (core),
	  BC_USAGE_FOR_EFFECT);

  /* (JUMP entry) */
  bc_lap_queue_extend
    (queue, bc_gen_op_JUMP (machine, entry_label));

  /* (LABEL exit) */
  bc_lap_queue_extend
    (queue, bc_gen_op_LABEL (machine, exit_label));

  bc_gen_tail (machine, queue, usage);
}

/* What is this generating?? FSET, FGET */
static void
bc_gen_core_func (bc_machine_t    machine,
		  bc_lap_queue_t *queue,
		  bc_core_t       core,
		  bc_usage_t      usage)
{
  /* Generate a 'top-level' function - core has been produces that way. */
  bc_function_t function =
    bc_generate (core, BC_CORE_FUNC_NAME (core));

  /* Add FUNCTION as a machine constant */
  unsigned int offset = 
    bc_machine_new_constant (machine, function, BC_FUNCTION_TYPE);

  /* And the FUNCTION'S name symbol */

  /* Do the fset */
  bc_lap_queue_extend
    (queue, bc_gen_op_FSET (machine, offset));

  bc_gen_tail (machine, queue, usage);
}

static void
bc_gen_core_prim (bc_machine_t    machine,
		  bc_lap_queue_t *queue,
		  bc_core_t       core,
		  bc_usage_t      usage)
{
  bc_gen_stacked (machine, queue,
		  BC_CORE_PRIM_OPERANDS (core),
		  BC_CORE_PRIM_OPERAND_COUNT (core));

  /* Generate the OPERATOR byte_op */
  bc_lap_queue_extend
    (queue, bc_gen_op_ZERO (machine,
			    1 - BC_CORE_PRIM_OPERAND_COUNT (core),
			    BC_CORE_PRIM_OPERATOR (core)));

  bc_gen_tail (machine, queue, usage);
}
/*
 *
 *
 *
 *
 */
  
static void
bc_gen (bc_machine_t    machine,
	bc_lap_queue_t *queue,
	bc_core_t       core,
	bc_usage_t      usage)
{
  typedef void (*bc_gen_core_func_t) (bc_machine_t    machine,
				      bc_lap_queue_t *queue,
				      bc_core_t       core,
				      bc_usage_t      usage);

  static bc_gen_core_func_t bc_gen_core_funcs [BC_NUMBER_OF_CORE_OPS] =
  {
    bc_gen_core_data,
    bc_gen_core_var,
    bc_gen_core_set,
    bc_gen_core_app,
    bc_gen_core_if,
    bc_gen_core_or,
    bc_gen_core_prog,
    bc_gen_core_fmt,
    bc_gen_core_while,
    bc_gen_core_func,
    bc_gen_core_prim
  };

  bc_lap_queue_t queue_2;
  bc_lap_queue_clear (& queue_2);

  (* bc_gen_core_funcs [BC_CORE_OP (core)])
    (machine, & queue_2, core, usage);

  bc_lap_queue_append_2 (queue, & queue_2);
  return;
}

bc_function_t 
bc_generate (bc_core_t core, bc_string_t name)
{
  bc_machine_t   machine = bc_machine_new ();
  bc_lap_queue_t queue;
  bc_function_t  function;
  
  bc_lap_queue_clear (& queue);

  /* Core had best be a function */
  assert (BC_CORE_FUNC == BC_CORE_OP (core));
  
  {
    bc_string_t  name      = BC_CORE_FUNC_NAME (core);
    bc_symbol_t *args      = BC_CORE_FUNC_ARGS (core);
    unsigned int arg_count = BC_CORE_FUNC_ARG_COUNT (core);
    bc_core_t    body      = BC_CORE_FUNC_BODY (core);
    
    /* Extend the machine with the ARGS */
    bc_machine_new_locals (machine, args, arg_count);

    /* Generate the code for body (in the context of ARGS */
    bc_gen (machine, & queue, body, BC_USAGE_FOR_RETURN);
  
    /* Build a function */
    {
      bc_lap_t lap = queue.head;

      bc_byte_code_t *code;
      unsigned int    code_count;

      /* Peephole optimization is a sign of a weak optimizer and it can be
	 dangerous (for example, [DUP POP] => [] reduces the stack
	 requirement by one but that one cannot be feed back to the
	 generator).

	 Destructively modify LAP */
      bc_peephole (& lap);
    
      /* Assemble LAP into the byte_code vector */
      bc_assemble (lap, machine->jump_label, & code, & code_count);

      /* Get the MACHINE constants into the functions.  Rather then
	 copying the constants we hack our way there.  */
      function =
	bc_function_new (name, code, code_count,
			 machine->constants,
			 machine->constants_count,
			 machine->stack_size);

      /* Prevent upcoming bc_machine_free from freeing the constants */
      machine->constants = 0;

      /* Lose the LAP and the MACHINE */
      bc_lap_free_all (lap);
      bc_machine_free (machine);
    }
  }
  return (function);
}
