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

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

/* Two passes might be needed.  The first to BLOCK complex tags and to
   expand macros; the second to expand into CORE.  The blocking can't
   be done by the parser because the complex tags can't be matched
   without knowning the tag's denotation (that is, if it denotes a
   complex tag).   */

/* Implementation note.  The order of evaluation in MetaHTML needs to be
   enforced.  Many function calls below perform multiple expansions - one
   for each argument.  In the current implementation, the order of
   evaluation is implicit and inherited from C.  This is not the correct
   convention.  */

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

#include "compile.h"

static void
bc_parse_fail (bc_parse_t parse,
	       bc_string_t message)
{
  printf (";; Parse Failure: %s\n", message);
  fail ();
}

static void
bc_exp_fail (bc_string_t message)
{
  printf (";; Expansion Failure: %s\n", message);
  fail ();
}

/**************************************************************************
 *
 * BC_ENV_T
 *
 * Static (Comptime) and Dynamic (runtime) Environments 
 *
 * Denotation for a local is always BC_UNKNOWN_TYPE
 */
typedef struct bc_env {

  bc_boolean_t global_p;
#define BC_ENV_GLOBAL_P( env )         ((env)->global_p)

  union {
    struct {
      bc_symbol_t    symbol;
      bc_type_t      type;
      struct bc_env *next;
    } lexical;
#define BC_ENV_LEXICAL_SYMBOL( env )    ((env)->u.lexical.symbol)
#define BC_ENV_LEXICAL_TYPE( env )      ((env)->u.lexical.type)
#define BC_ENV_LEXICAL_NEXT( env )      ((env)->u.lexical.next)

    bc_package_t global;
#define BC_ENV_GLOBAL_PACKAGE( env )       ((env)->u.global)
  } u;

} *bc_env_t;

/*
 * BC_ENV_EXTEND () 
 *
 * Extend ENV with a lexical environment containing SYMBOL of TYPE.  
 */
static bc_env_t 
bc_env_extend (bc_env_t    env,
	       bc_symbol_t symbol,
	       bc_type_t   type)
{
  bc_env_t new_env = (bc_env_t) xmalloc (sizeof (struct bc_env));
  if (! new_env)
    bc_exp_fail ("Out of memory - could not allocate lexical environment.");

  BC_ENV_LEXICAL_SYMBOL (new_env) = symbol;
  BC_ENV_LEXICAL_TYPE   (new_env) = type;
  BC_ENV_LEXICAL_NEXT   (new_env) = env;
  BC_ENV_GLOBAL_P       (new_env) = bc_false;

  return (new_env);
}

/*
 * BC_ENV_EXTEND_MANY ()
 *
 * Repeatedly extend ENV COUNT times from the SYMBOLS and TYPES arrays.
 */
static bc_env_t
bc_env_extend_many (bc_env_t env,
		    unsigned int count,
		    bc_symbol_t *symbols,
		    bc_type_t   *types)
{
  while (count--)
    env = bc_env_extend (env, *symbols++, *types++);
  return (env);
}

/*
 * BC_ENV_LOOKUP () 
 *
 * Return the type/denotation for SYMBOL in ENV
 */
static bc_type_t
bc_env_lookup (bc_env_t    env,
	       bc_symbol_t symbol)
{
  bc_type_t type;

  switch (BC_ENV_GLOBAL_P (env))
    {
    case bc_true:
      /* No shadowing so SYMBOL's TYPE is the actual denotation */
      type = BC_SYMBOL_TYPE (symbol);
      break;

    case bc_false:
      type = ((symbol == BC_ENV_LEXICAL_SYMBOL (env))
	      ? BC_ENV_LEXICAL_TYPE (env)
	      : bc_env_lookup (BC_ENV_LEXICAL_NEXT (env),
			       symbol));
      break;
    default:
      type = BC_UNBOUND_TYPE;
      break;
    }
  return (type);
}

/* Why?? */
extern bc_env_t bc_env;

static bc_core_t
bc_exp_error (bc_parse_t parse,
	      bc_env_t env)
{
  bc_parse_fail (parse, "Unimplemented expander");
  /* Data for a format */
  return (BC_CORE_NULL);
}


/**************************************************************************
 *
 * BC_SPECIAL_FORM_T
 *
 */
typedef bc_core_t
(*bc_exp_func_t) (bc_parse_t parse,
		  bc_env_t   env);

struct bc_special_form
{
  bc_string_t   name;		/* redundant (mostly) */
  bc_exp_func_t exp;
};

#define BC_SPECIAL_FORM_NAME( sf )  ((sf)->name)
#define BC_SPECIAL_FORM_EXP( sf )   ((sf)->exp)


static bc_special_form_t
bc_special_form_new (bc_string_t   name,
		     bc_exp_func_t exp)
{
  bc_special_form_t sf = (bc_special_form_t) xmalloc
    (sizeof (struct bc_special_form));
  if (! sf)
    bc_exp_fail ("Out of memory - trying to allocate a special-form");

  BC_SPECIAL_FORM_NAME (sf) = name;
  BC_SPECIAL_FORM_EXP  (sf) = exp;
  return (sf);
}

/*
 * BC_MACRO_T
 *
 */
struct bc_macro
{
  bc_string_t   name;		/* redundant (mostly) */
  bc_boolean_t  simple_p;
  union
  {
    /* tbd */
    int simple;
    int complex;
  } u;
};


/*
 * BC_HTML_T
 *
 */
struct bc_html
{
  bc_string_t name;		/* redundant (mostly) */
};



/*****************************************************************************
 *
 * PRIM-OPS
 *
 *
 * Define the PRIM-OPS table */
struct bc_prim_op_spec
bc_prim_op_spec_table [] =
{
#define BYTEOP( operator, name, length )
#define PRIMOP( operator, name, length, min, max ) \
  { name, min, max, BC_##operator##_OP },
#include "byte_ops.h"
#undef BYTEOP 
#undef PRIMOP
};

/* Count the number of PRIM-OPS */
enum {
#define BYTEOP( operator, name, length )
#define PRIMOP( operator, name, length, min, max )  PRIM_OP_##operator,
#include "byte_ops.h"
NUMBER_OF_PRIM_OP_SPECS
#undef BYTEOP 
#undef PRIMOP
};

/* Find and return the PRIM-OP-SPEC named NAME; otherwise return NULL */
static bc_prim_op_spec_t
bc_prim_op_spec_lookup (bc_string_t name)
{
  unsigned int index;

  for (index = 0; index < NUMBER_OF_PRIM_OP_SPECS; index++)
    {
      bc_prim_op_spec_t spec = & bc_prim_op_spec_table [index];
      if (0 == strcasecmp (name, BC_PRIM_OP_SPEC_NAME (spec)))
	return (spec);
    }
  return ((bc_prim_op_spec_t) NULL);
}

/* A prim-op is applicable if the ARG_COUNT falls within prim-op's min and
   max argument counts */
static bc_boolean_t
bc_prim_op_applicable_p (bc_prim_op_spec_t spec,
			 unsigned int arg_count)
{
  return (arg_count >= BC_PRIM_OP_SPEC_MIN_ARG_COUNT (spec)
	  && (-1 == BC_PRIM_OP_SPEC_MAX_ARG_COUNT (spec)
	      || arg_count <= BC_PRIM_OP_SPEC_MAX_ARG_COUNT (spec)));
}

	  
/*****************************************************************************
 *
 * SPECIAL FORMS
 *
 * Note that special-forms are fully processed in the compiler and
 * thus, unlike function calls, don't need to maintain the input format
 * string for possible output.  In case you don't know, function calls
 * need to hold the format string for the case where there is no
 * function at runtime - in which case the format string is used to
 * produce output 
 *
 * (Way) Forward declaration */
static bc_core_t
bc_exp (bc_parse_t parse,
	bc_env_t   env);


/* Expand OPERANDS (via BC_PARSE_NEXT) into a vector of cores.  The vector
   length is bc_parse_count (operands) */
static bc_core_t *
bc_exp_sequence (bc_parse_t tags,
		 bc_env_t   env)
{
  bc_core_t *cores = (bc_core_t *) xmalloc
    (bc_parse_count (tags) * sizeof (bc_core_t));
  bc_core_t *cores_result = cores;

  for (; tags; tags = BC_PARSE_NEXT (tags))
    *cores++ = bc_exp (tags, env);

  return (cores_result);
}

/* Expand TAGS for FORMAT */
static bc_core_t
bc_exp_format (bc_format_t format,
	       bc_parse_t  tags,
	       bc_env_t    env)
{
  return (bc_core_fmt_new (format,
			   bc_exp_sequence (tags, env),
			   bc_parse_count (tags)));
}



/*
 * BC_EXP_GET_VAR
 *
 * <get-var name> */
static bc_core_t
bc_exp_get_var (bc_parse_t tag,
		bc_env_t   env)
{
  /* Destructure the 'GET-VAR' parse - slowly*/
  bc_parse_t variable = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int parse_count =
    bc_parse_count (variable);

  /* Better late than never */
  assert (BC_PARSE_OP_TAG == BC_PARSE_OP (tag));

  switch (parse_count)
    {
    case 1:
      {
	bc_core_t var = bc_exp (variable, env);
	switch (BC_CORE_OP (var))
	  {
	  case BC_CORE_VAR:
	    return (var);
	  default:
	    /* Generate a primitive call as <get-var var> 
	       VAR ought to be a string */
	    return (bc_core_prim_new (BC_GET_VAR_OP, 
				      & var, /* well, maybe */
				      1));
	  }
      }
    default:
      /* <get-var>
	 <get-var exp1 exp2 ...> */

      /* Cannot possibly be a 'GET-VAR' expression, return a 'CAT' */
      return (bc_exp_format (BC_PARSE_TAG_FORMAT (tag),
			     BC_PARSE_TAG_OPERANDS (tag),
			     env));
    }
}

static bc_core_t
bc_exp_set_var (bc_parse_t tag,
		bc_env_t   env)
{
  bc_parse_t operands = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int operands_count =
    bc_parse_count (operands);

  /* Better late than never */
  assert (BC_PARSE_OP_TAG == BC_PARSE_OP (tag));

  switch (operands_count)
    {
    case 1:
      printf ("\n<set-var foo> :: missing value");
      return (bc_exp_format (BC_PARSE_TAG_FORMAT (tag), 
			     operands,
			     env));
    case 2:
      {
	bc_parse_t 
	  var = operands,
	  val = BC_PARSE_NEXT (operands);
	
	switch (BC_PARSE_OP (var))
	  {
	  case BC_PARSE_OP_SYMBOL:
	    /* <set-var name ...value...> */
	    return (bc_core_set_new (BC_PARSE_SYMBOL_SYMBOL (var),
				     bc_exp (val, env)));
	  default:
	    printf ("\n<set-var <name> <value>> :: 'name' not a symbol");
	    return (bc_exp_format (BC_PARSE_TAG_FORMAT (tag),
				   operands,
				   env));
	  }
	break;
      }

    default:
      printf ("\n<set-var <name> <value> ...> :: too many forms");
      return (bc_exp_format (BC_PARSE_TAG_FORMAT (tag),
			     operands,
			     env));
    }
}

/*
 * BC_EXP_IF
 *
 * <if predicate consequent alternate> */
static bc_core_t
bc_exp_if (bc_parse_t tag,
	   bc_env_t   env)
{
  /* Destructure the 'IF' parse - slowly*/
  bc_parse_t pred = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int parse_count =
    bc_parse_count (pred);

  /* Better late than never */
  assert (BC_PARSE_OP_TAG == BC_PARSE_OP (tag));

  switch (parse_count)
    {
    case 2:
    case 3:
      {
	bc_parse_t cons = BC_PARSE_NEXT (pred);

	/* Procude 'IF' core from each expansion */
	return (bc_core_if_new (bc_exp (pred, env),
				bc_exp (cons, env),
				(parse_count == 3
				 ? bc_exp (BC_PARSE_NEXT (cons), env)
				 /* sort of */
				 : bc_core_data_new (bc_object_false))));
      }

    default:
      /* <if foo>
	 <if foo bar baz bing bang> */

      /* Cannot possibly be an 'IF' expression, return a 'CAT' */
      bc_exp_fail ("Unimplemented - non-standard 'IF' expression");
      return (BC_CORE_NULL);
    }
}

/*
 * BC_EXP_AND
 *
 * <and exp ...> */
static bc_core_t
bc_exp_and_recurse (bc_parse_t   exp,
		    unsigned int exp_count,
		    bc_env_t     env)
{
  switch (exp_count)
    {
    case 0:
      /* <and> => "true" */
      return (bc_core_data_new (bc_object_true));
    case 1:
      /* <and exp> => exp */
      return (bc_exp (exp, env));
    default:
      /* <and exp1 exp2 ...> => <if exp1 <and exp2 ...> "false"> */
      return (bc_core_if_new (bc_exp (exp, env),
			      bc_exp_and_recurse (BC_PARSE_NEXT (exp), 
						  exp_count - 1,
						  env),
			      bc_core_data_new (bc_object_false)));
    }
}
  
static bc_core_t
bc_exp_and (bc_parse_t tag,
	    bc_env_t   env)
{
  bc_parse_t exp = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int exp_count =
    bc_parse_count (exp);

  return (bc_exp_and_recurse (exp, exp_count, env));
}

/*
 * BC_EXP_OR
 * 
 */
static bc_core_t
bc_exp_or (bc_parse_t tag,
	   bc_env_t   env)
{
  bc_parse_t exp = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int exp_count =
    bc_parse_count (exp);

  switch (exp_count)
    {
    case 0:
      /* <or> => "false" */
      return (bc_core_data_new (bc_object_false));
    case 1:
      /* <or exp> => exp */
      return (bc_exp (exp, env));
    default:
      /* <or exp ...> => CORE */
      return (bc_core_or_new (bc_exp_sequence (exp, env), exp_count));
    }
}

/*
 * BC_EXP_PROG
 *
 * <prog exp ...> */
static bc_core_t
bc_exp_prog (bc_parse_t tag,
	     bc_env_t   env)
{
  /* Destructure the 'PROGN' parse */
  bc_parse_t body = BC_PARSE_TAG_OPERANDS (tag);

  unsigned int body_count =
    bc_parse_count (body);

  /* Better late than never */
  assert (BC_PARSE_OP_TAG == BC_PARSE_OP (tag));

  return (bc_core_prog_new (bc_exp_sequence (body, env), body_count));
}

/*
 * BC_EXP_WHILE
 *
 * <while test> body ... </while> */
static bc_core_t
bc_exp_while (bc_parse_t blk,
	      bc_env_t   env)
{
  bc_parse_t body = BC_PARSE_BLK_BODY (blk);

  /* <while test> */
  bc_parse_t test = BC_PARSE_TAG_OPERANDS (BC_PARSE_BLK_TAG (blk));

  unsigned int test_count =
    bc_parse_count (test);
  
  if (test_count != 1)
    bc_parse_fail (test, "Improper WHILE test clause.");
  
  return (bc_core_while_new (bc_exp (test, env),
			     bc_exp (body, env)));
}

/* 
 * BC_EXP_WHEN
 *
 * <when test> body </when> */
static bc_core_t
bc_exp_when (bc_parse_t blk,
	     bc_env_t   env)
{
  /* An 'if' expression with a 'prog' consequent
     and an "" (empty) alternate */
  return (bc_core_if_new (bc_exp (BC_PARSE_BLK_TAG (blk), env),
			  bc_exp_prog (BC_PARSE_BLK_BODY (blk), env),
			  bc_core_empty));
}

/*
 * BC_EXP_DEFUN
 *
 * <defun NAME arg1 ...> body </defun> */
static bc_core_t
bc_exp_defun (bc_parse_t blk,
	      bc_env_t   env)
{
  bc_parse_t head = BC_PARSE_BLK_TAG  (blk);
  bc_parse_t body = BC_PARSE_BLK_BODY (blk);

  /* ENSURE at least NAME exists - and is a symbol*/
  bc_parse_t name = BC_PARSE_TAG_OPERANDS (head);

  /* Extract NAME and ARGS from DEFUN.  Ensure that ARGS are
     clean; that is, without numbers, strings, etc. */

  bc_parse_t   args_parse = BC_PARSE_NEXT (name);
  unsigned int arg_count  = bc_parse_count (args_parse);
  
  bc_symbol_t *args = (bc_symbol_t *)
    xmalloc (1 + arg_count * sizeof (bc_symbol_t));

  bc_type_t *types = (bc_type_t *)xmalloc (1 + arg_count * sizeof (bc_type_t));

  bc_env_t  body_env;
  bc_core_t body_core;
  bc_core_t func_core;
  
  {
    bc_parse_t   parse  = args_parse;
    bc_symbol_t *as  = args;
    bc_type_t   *ts  = types;
    for (; parse; parse = BC_PARSE_NEXT (parse))
      {
	switch (BC_PARSE_OP (parse))
	  {
	  case BC_PARSE_OP_SYMBOL:
	    *as++ = BC_PARSE_SYMBOL_SYMBOL (parse);
	    *ts++ = BC_UNBOUND_TYPE;
	    break;
	  default:
	    bc_exp_fail ("FUNCTION arglist not all symbols");
	    break;
	  }
      }
  }
  
  /* Build a new BODY_ENV by extending ENV with LOCALS */
  body_env = bc_env_extend_many (env, arg_count, args, types);

  /* Expand BODY in the context of BODY_ENV */
  body_core = bc_exp (body, body_env);

  /* Package into a function  */
  func_core = bc_core_func_new (BC_PARSE_SYMBOL_STRING (name), 
				args, arg_count,
				body_core);

  /* Return the core to represent the function */
  return (func_core);
}

/*
 * BC_EXP_DEFMACRO
 *
 * <defmacro NAME arg1 ...> body </defmacro> */
static bc_core_t
bc_exp_defmacro (bc_parse_t blk,
		 bc_env_t   env)
{
  bc_parse_t head = BC_PARSE_BLK_TAG  (blk);
  bc_parse_t body = BC_PARSE_BLK_BODY (blk);
  return (BC_CORE_NULL);
}

/*****************************************************************************
 *
 * Macros
 *
 */
static bc_core_t
bc_exp_macro (bc_parse_t parse,
	      bc_env_t   env)
{
  return (BC_CORE_NULL);
}

/*****************************************************************************
 *
 * Function Applications (Primitives and Calls)
 *
 */

/*
 * BC_EXP_PRIM
 *
 * <prim-op arg1 ...> */
static bc_core_t
bc_exp_prim (bc_prim_op_spec_t prim,
	     bc_parse_t operands,
	     bc_env_t   env)
{
  return (bc_core_prim_new (BC_PRIM_OP_SPEC_OPERATOR (prim),
			    bc_exp_sequence (operands, env),
			    bc_parse_count (operands)));
}

/*
 * BC_EXP_CALL
 *
 * <func arg1 ...> */
static bc_core_t
bc_exp_call (bc_format_t format,
	     bc_parse_t  operator,
	     bc_parse_t  operands,
	     bc_env_t    env)
{
  return (bc_core_app_new (format,
			   bc_exp (operator, env),
			   bc_exp_sequence (operands, env),
			   bc_parse_count (operands)));
}

/*
 * BC_EXP_APP(lication)
 *
 * Function Application (primitive or call) */
static bc_core_t
bc_exp_app (bc_format_t format,
	    bc_parse_t  operator,
	    bc_parse_t  operands,
	    bc_env_t    env)
{
  unsigned int operand_count =
    bc_parse_count (operands);

  /* Name for looking up the PRIM_OP itself */
  bc_string_t prim_name = (bc_string_t) NULL;

  /* The PRIM_OP spec */
  bc_prim_op_spec_t prim = (bc_prim_op_spec_t) NULL;

  /* Figure out what type of parse operator can be a primitive */
  switch (BC_PARSE_OP (operator))
    {
    case BC_PARSE_OP_SYMBOL:
      /* <foo ...> */
      prim_name = BC_PARSE_SYMBOL_STRING (operator);
      break;
    case BC_PARSE_OP_STRING:
      /* <"foo" ...> */
      prim_name = BC_PARSE_STRING (operator);
      break;
    case BC_PARSE_OP_NUMBER:
      /* <2.3 ...> */
      prim_name = BC_PARSE_NUMBER_STRING (operator);
      break;
    default:
      break;
    }

  if (prim_name != (bc_string_t) NULL)
    prim = bc_prim_op_spec_lookup (prim_name);
  
  if (prim && bc_prim_op_applicable_p (prim, operand_count))
    return (bc_exp_prim (prim, operands, env));
  else
    return (bc_exp_call (format, operator, operands, env));
}

/*****************************************************************************
 *
 * HTML
 *
 * Some implementations would like to predefine some HTML tags as constants
 * That then would forbid redefinition and allow those tags to be compiled
 * directly to strings. */
#if defined (NOT_DEFINED_YET)

typedef struct bc_html_op_spec
{
  bc_string_t name;
} *bc_html_op_spec_t;

struct bc_html_op_spec
bc_html_op_spec_table [] =
{
#define HTMLOP( name ) \
  { name },
#include "html_ops.h"
#undef HTMLOP
};

#endif /* NOT_DEFINED_YET */

/* 
 * bc_exp_html
 *
 * <href ...> */
static bc_core_t
bc_exp_html (bc_format_t format,
	     bc_parse_t  operator,
	     bc_parse_t  operands,
	     bc_env_t    env)
{
  bc_core_t core = (BC_CORE_NULL);

  return (core);
}

/*****************************************************************************
 *
 * PARSE OPS
 *
 */
static bc_core_t
bc_exp_symbol (bc_parse_t parse,
	    bc_env_t   env)
{
  assert (BC_PARSE_OP_SYMBOL == BC_PARSE_OP (parse));
  /* Core for a variable reference */
  return (bc_core_var_new (BC_PARSE_SYMBOL_SYMBOL (parse)));
}

static bc_core_t
bc_exp_string (bc_parse_t parse,
	    bc_env_t   env)
{
  assert (BC_PARSE_OP_STRING == BC_PARSE_OP (parse));
  return (bc_core_data_new ((bc_object_t) BC_PARSE_STRING (parse)));
}

static bc_core_t
bc_exp_number (bc_parse_t parse,
	       bc_env_t   env)
{
  assert (BC_PARSE_OP_NUMBER == BC_PARSE_OP (parse));
  return (bc_core_data_new ((bc_object_t) BC_PARSE_NUMBER_STRING (parse)));
}

static bc_core_t
bc_exp_text (bc_parse_t parse, 
	     bc_env_t   env)
{
  bc_format_t format = BC_PARSE_TEXT_FORMAT (parse);
  bc_parse_t  tags   = BC_PARSE_TEXT_TAGS   (parse);

  return (bc_core_fmt_new (format,
			   bc_exp_sequence (tags, env),
			   bc_parse_count (tags)));
}

static bc_core_t
bc_exp_key (bc_parse_t parse,
	      bc_env_t   env)
{
  return (bc_core_empty);
}

static bc_core_t
bc_exp_array (bc_parse_t parse,
	      bc_env_t   env)
{
  return (bc_core_empty);
}

static bc_core_t
bc_exp_blk (bc_parse_t blk,
	    bc_env_t   env)
{
  bc_parse_t body = BC_PARSE_BLK_BODY (blk);
  /* Every BLK_TAG operator is a 'special-form' */
  bc_parse_t tag  = BC_PARSE_BLK_TAG (blk);

  bc_symbol_t       operator;
  bc_special_form_t operator_special_form;
  
  assert (BC_PARSE_OP (tag) == BC_PARSE_OP_TAG);
  assert (BC_PARSE_OP (BC_PARSE_TAG_OPERATOR (tag)) == BC_PARSE_OP_SYMBOL);

  operator = BC_PARSE_SYMBOL_SYMBOL (BC_PARSE_TAG_OPERATOR (tag));
  operator_special_form = 
    BC_SYMBOL_VALUE (operator);
  
  return ((* BC_SPECIAL_FORM_EXP (operator_special_form)) (blk, env));
}

static bc_core_t
bc_exp_tag (bc_parse_t parse,
	    bc_env_t   env)
{
  bc_format_t format   = BC_PARSE_TAG_FORMAT (parse);
  bc_parse_t  operator = BC_PARSE_TAG_OPERATOR (parse);
  bc_parse_t  operands = BC_PARSE_TAG_OPERANDS (parse);

  /* Look up the PARSE_OP for OPERATOR - hopefully it is a symbol in
     which case we get to code a function call or expand a macro!  But
     it could be a number or string in which case we might have an
     error or, who knows, a function call anyway */
  switch (BC_PARSE_OP (operator))
    {
    case BC_PARSE_OP_SYMBOL:
      /* <foo ...> */
      {
	/* Find out what the symbol OPERATOR denotes in ENV   Usually
	   this is equivalent to finding out what type of value
	   OPERATOR's symbol is bound to in some package */
	bc_symbol_t symbol   = BC_PARSE_SYMBOL_SYMBOL (operator);
	bc_type_t denotation = bc_env_lookup (env, symbol);

	switch (denotation)
	  {
	  case BC_MACRO_TYPE:
	    /* Bound to a macro; do a macro expansion, reexpand */
	    return (bc_exp_macro (parse, env));

	  case BC_SPECIAL_FORM_TYPE:
	    /* Bound to a special-form - process */
	    {
	      bc_special_form_t sf =
		BC_SYMBOL_VALUE (symbol);

	      return ((* BC_SPECIAL_FORM_EXP (sf)) (parse, env));
	    }

	  case BC_HTML_TYPE:
	    /* Bound to an HTML tag - expand to HTML*/
	    return (bc_exp_html (format, operator, operands, env));
	    break;

	  default:
	    /* Bound to anything else - could be a function at runtime
	       so always code a function call.  */
	    return (bc_exp_app (format, operator, operands, env));
	  }
	break;
      }

    case BC_PARSE_OP_STRING:
      /* <"foo bar" ...>   => TEXT */
      return (bc_exp_format (format,
			     BC_PARSE_TAG_TAGS (parse),
			     env));

    case BC_PARSE_OP_NUMBER:
      /* <3.14 ...>    => TEXT*/
      return (bc_exp_format (format,
			     BC_PARSE_TAG_TAGS (parse),
			     env));

    case BC_PARSE_OP_TEXT:
      /* <"foo <get-var bar> baz" ...>  => ?? */
      bc_parse_fail (parse, "exp_tag() can't expand '<\"foo <bar>\" ...>'");
      break;

    case BC_PARSE_OP_TAG:
      /* <<foo ...> ...>   => ?? */
      bc_parse_fail (parse, "exp_tag() can't expand '<<foo ...> ...>'");
      break;

    case BC_PARSE_OP_KEY:
      /* <foo=bar ...>   => ?? */
    default:
      bc_parse_fail (parse, "exp_tag() can't expand '<foo=bar ...>'");
      break;
    }

  /* Never Here */
  return (BC_CORE_NULL);
}


/***************************************************************************
 *
 * BC_EXP - Top-Level, Recursive Expansion
 *
 *
 */
static bc_core_t
bc_exp (bc_parse_t parse,
	bc_env_t   env)
{
  /* Ordering must match bc_parse_op_t */
  static bc_exp_func_t bc_exp_funcs [BC_NUMBER_OF_PARSE_OPS] =
  {
    bc_exp_symbol,
    bc_exp_string,
    bc_exp_number,
    bc_exp_text,
    bc_exp_tag,
    bc_exp_key,
    bc_exp_array,
    bc_exp_blk
  };
  
  bc_core_t core =
    ((* bc_exp_funcs [BC_PARSE_OP (parse)])
     (parse, env));

  return (core);
}

/*
 * BC_EXPAND
 *
 * TOP-LEVEL, visible EXPAND function.  Always returns a THUNK
 * (function of no arguments) because METAHTML has a recursive
 * top-level and thus there is nothing to 'close over'.  We might
 * normally close over the values of the free variables but METAHTML
 * free variables are all global symbols - so we get a kind of
 * closure for free.  
 *
 * Convert PACKAGE into a GLOBAL-ENV and expand PARSE.  This is one of two
 * non-static functions in this file. */ 
static bc_string_t top_level_function_name = "TOP-LEVEL-FUNCTION";

bc_core_t 
bc_expand (bc_parse_t   parse,
	   bc_package_t package) /* 'global' environment */
{
  struct bc_env env_rec, *env = & env_rec;
  bc_core_t core;

  BC_ENV_GLOBAL_P       (env) = bc_true;
  BC_ENV_GLOBAL_PACKAGE (env) = package;

  core = bc_exp (parse, env);

  return (bc_core_func_new (top_level_function_name,
			    (bc_symbol_t *) NULL,
			    0,
			    core));
}

/*
 * BC_EXPAND_INSTALL
 *
 * Install the MetaHTML expansion code.  Amounts to mapping defining the
 * special forms and associating them with their expansion functions */ 
extern void
bc_expand_install (void)
{
  static struct bc_exp_func_table {
    bc_string_t string;
    bc_exp_func_t function;
  } bc_exp_func_table [] =
    {
      { "if",        bc_exp_if },
      { "and",       bc_exp_and },
      { "or",        bc_exp_or },
      { "prog",      bc_exp_prog },
      { "when",      bc_exp_when },
      { "while",     bc_exp_while },

      { "get-var",   bc_exp_get_var },
      { "set-var",   bc_exp_set_var },

      { "defun",     bc_exp_defun },

      /*      { "defmacro" },
	      { "defsubst" },

	      { "include" },
	      { "comment" },
	      { "verbatim" },

	      { "subst-in-page" }, */

      { (bc_string_t) NULL, (bc_exp_func_t) NULL }
    };

    /* Install these as the values on the symbol values */
    struct bc_exp_func_table *entry;

    for (entry = bc_exp_func_table;
	 entry->string != (bc_string_t) NULL;
	 entry++)
      {
	bc_symbol_t       symbol  = bc_symbol_intern (entry->string);
	bc_special_form_t special =
	  bc_special_form_new (entry->string,
			       entry->function);

	BC_SYMBOL_TYPE  (symbol) = BC_SPECIAL_FORM_TYPE;
	BC_SYMBOL_VALUE (symbol) = special;
      }
}
