/* This file is part of cqual.
   Copyright (C) 2000-2002 The Regents of the University of California.

cqual is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

cqual is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with cqual; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */

#include "parser.h"
#include "AST_utils.h"
#include "expr.h"
#include "c-parse.h"
#include "unparse.h"
#include "constants.h"
#include "aloctypes.h"
#include "rinf_pam.h"
#include "rinf_analyze.h"

static effecttype global_effect = NULL;
static effecttype global_env = NULL;
static hash_table globals = NULL;
/*global*/ function_decl current_function_decl = NULL;
static aloctype current_function_ret = NULL;

typedef struct einfo {
  alocreftype tau;
  effecttype eff;
} einfo;

typedef struct sinfo {
  effecttype eff;
} sinfo;

typedef struct dinfo {
  effecttype eff;
  effecttype alocs;
} dinfo;

static char *alloc_names[] = {
  "yy_flex_alloc",
  "xalloc","malloc","calloc","realloc","valloc",
  "xmalloc","__builtin_alloca","alloca",
  "kmalloc", NULL};
/*
static char *alloc_names[] = {"malloc","calloc","realloc","valloc",
                              "xmalloc","__builtin_alloca","alloca",
			      "kmalloc", NULL};
*/
static char *free_names[] = {"free", NULL};
static char *memcpy_names[] = {"__builtin_memcpy", "memccpy", "memcpy",
			       "memmove", "strcat", "strncat", "strcpy",
			       "strncpy", NULL};

static einfo analyze_unary_expression(unary, effecttype env);
static einfo analyze_binary_expression(binary, effecttype env);
static einfo analyze_init(type t, expression rhs, effecttype env);
static dinfo analyze_declaration(declaration d, effecttype env);
static einfo analyze_expression(expression e, effecttype env);
static sinfo analyze_statement(statement s, effecttype env);
static einfo analyze_alloc_fun(void);
static einfo analyze_free_fun(void);
static einfo analyze_memcpy_fun(void);
bool is_void_parms(declaration);             /* semantics.c */

static bool is_alloc_fun(const char *name)
{
  int i;
  for (i = 0; alloc_names[i]; i++)
    {
      if (! strcmp(name,alloc_names[i]))
	return TRUE;
    }
  return FALSE;
}

static bool is_free_fun(const char *name)
{
  int i;
  for (i = 0; free_names[i]; i++)
    {
      if (! strcmp(name,free_names[i]))
	return TRUE;
    }
  return FALSE;
}

static bool is_memcpy_fun(const char *name)
{
  int i;
  for (i = 0; memcpy_names[i]; i++)
    {
      if (! strcmp(name,memcpy_names[i]))
	return TRUE;
    }
  return FALSE;
}

static inline einfo mkeinfo(alocreftype tau, effecttype eff)
{
  struct einfo result;

  result.tau = tau;
  result.eff = eff;
  return result;
}

static inline sinfo mksinfo(effecttype eff)
{
  struct sinfo result;

  result.eff = eff;
  return result;
}

static inline dinfo mkdinfo(effecttype eff, effecttype alocs)
{
  struct dinfo result;

  result.eff = eff;
  result.alocs = alocs;
  return result;
}

static void add_ddecl(data_declaration ddecl)
{
  data_declaration old_ddecl;
  ddecl = root_ddecl(ddecl);

  if (ddecl->alref)
    return;

  if (ddecl->isexternalscope)
    {
      if (hash_table_lookup(globals, (hash_key)ddecl->name, 
			(hash_data *) &old_ddecl))
	{
	  /* XXX Experiment! */
	  /*
	  if (old_ddecl->in_prelude)
	    {
	      ddecl->alref = alocreftype_ref(make_aloctype_fresh());
	      return;
	    }
	  */

	  ddecl->alref = old_ddecl->alref;

	  old_ddecl->defined = ddecl->defined =
	    (old_ddecl->defined || ddecl->defined);

	  old_ddecl->isused = ddecl->isused =
	    (old_ddecl->isused || ddecl->isused);
	}
      else
	{
	  ddecl->alref = alocreftype_ref(make_aloctype_fresh());
	  if (ddecl->in_prelude && !ddecl->defined)
	    ddecl->defined = TRUE;
	  insist(hash_table_insert(globals, (hash_key) ddecl->name, ddecl));
	}
    }
  else
    ddecl->alref = alocreftype_ref(make_aloctype_fresh());
}

static void add_declarator_overlay(declarator d, rinf_const c)
{
  identifier_declarator id = get_id_declarator(d);
  cstring name = id->cstring;
  pam_add_overlay_file_rinf(id->loc, name.data, c);

}

/* Report an error at location l */
static void vreport_error(location loc, severity sev, const char *format,
			  va_list args)
{
  if (flag_pam_mode)
    {
      if (current_function_decl)
	pam_add_error(root_ddecl(current_function_decl->ddecl)->name,
		      loc, sev, NULL, format, args);
      else
	pam_add_error("top level", loc, sev, NULL, format, args);
    }
  else
    {
      fflush(NULL);
      if (loc)
	fprintf(stderr, "%s:%ld ", loc->filename, loc->lineno);
      vfprintf(stderr, format, args);
      fprintf(stderr, "\n");
    }
}

/* Apply f to one ddecl for each global */
void rinf_traverse_globals(void (*f)(data_declaration, void *), void *arg)
{
  hash_table_scanner hts;
  data_declaration ddecl;

  hash_table_scan(globals, &hts);
  while (hash_table_next(&hts, NULL, (hash_data *) &ddecl))
    {
      assert(!ddecl->shadowed);
      f(ddecl, arg);
    }
}
/* Apply f to one ddecl for each global, in sorted order */
void rinf_traverse_globals_sorted(void (*f)(data_declaration, void *),
				  void *arg)
{
  hash_table_scanner_sorted htss;
  data_declaration ddecl;

  hash_table_scan_sorted(globals, (keycmp_fn) strcmp, &htss);
  while (hash_table_next_sorted(&htss, NULL, (hash_data *) &ddecl))
    {
      assert(!ddecl->shadowed);
      f(ddecl, arg);
    }
}

void report_rinf(location loc, severity sev, const char *format, ...)
{
  va_list args;

  va_start(args, format);
  vreport_error(loc, sev, format, args);
}

void rinf_init_analyze(void)
{
  global_effect = effecttype_var("<global>");
  global_env = effecttype_var("<global-alocs>");
  globals = make_string_hash_table(parse_region, 100);
}

void rinf_analyze(declaration program)
{
  declaration d;
  dinfo next_info;

  unparse_start(stdout);
  pam_add_file(program->loc->filename);
  AST_set_parents(CAST(node, program));
  scan_declaration(d, program) 
    {
      next_info = analyze_declaration(d, global_env);
      mkleq_effecttype(next_info.eff, global_effect);
      mkleq_effecttype(next_info.alocs, global_env);
    }
}

void rinf_finish_analyze(void)
{
  check_rinf_consts();
  rinf_traverse_globals_sorted((traverse_global_fn) warn_if_dangerous_global,
			       NULL);
}

static dinfo analyze_declaration(declaration d, effecttype env)
{
  switch (d->kind)
    {
    case kind_asm_decl:
      {
	/*	report_qerror(d->loc, sev_warn,
		"warning: ignoring in-line assembly code");*/
	return mkdinfo(effecttype_empty, effecttype_empty);
      }
      break;
    case kind_data_decl:
      {
	data_decl dd = CAST(data_decl, d);
	declaration decl;
	effecttype eff, local_env, alocs;

	eff = effecttype_empty;
	local_env = env;
	alocs = effecttype_empty;

	scan_declaration(decl, dd->decls) {
	  dinfo next;

	  next = analyze_declaration(decl, local_env);
	  local_env = effecttype_union(local_env, next.alocs);
	  alocs = effecttype_union(alocs, next.alocs);
	  eff = effecttype_union(eff, next.eff);
	}

	return mkdinfo(eff, alocs);
      }
      break;
    case kind_variable_decl:
      {
	variable_decl vd = CAST(variable_decl, d);
	data_declaration root;
	effecttype eff, alocs;
	bool isglobal;

	/* Ignore asm_stmt
	if (vd->asm_stmt)
	  fail_loc(vd->loc,
		   "Unimplemented: asm in variable_decl\n", 0);
	*/

	root = root_ddecl(vd->ddecl);

	if (root->kind == decl_typedef || root->kind == decl_error)
	  return mkdinfo(effecttype_empty, effecttype_empty);

	add_ddecl(root);

	eff = effecttype_empty;
	alocs = effecttype_empty;
	isglobal = (root->kind == decl_function ||
		    root->isexternalscope ||
		    root->vtype == variable_static);

	assert(root->alref);
	if (isglobal)
	  mkleq_effecttype(effecttype_any_reach(root->alref), global_env);
	else
	  alocs = effecttype_union(effecttype_any_reach(root->alref), alocs);

	/* Analyze initializer, if any */
	if (vd->arg1)
	  {
	    einfo arg1;

	    arg1 = analyze_init(root->type, vd->arg1, env);
	    
	    eff = effecttype_union(eff, effecttype_read(arg1.tau));
	    /* No write effect */
	    eff = effecttype_union(eff, arg1.eff);
	    mkleq_aloctype(deref(arg1.tau), deref(root->alref));
	  }

	return mkdinfo(eff, alocs);
      }
      break;
    case kind_function_decl:
      {
	int i, lastbodyeff;
	function_decl fd = CAST(function_decl, d), old_function_decl;
	data_declaration root;
	effecttype fneff, bodyeff, local_env;
	effecttype *bodyeffs;
	aloctype *params;
	aloctype ret, old_function_ret;

	/* Set up the function type */
	root = root_ddecl(fd->ddecl);
        add_ddecl(root);
	params = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS, aloctype);
	for (i=0; i < NUM_ALOCFN_PARAMS; i++)
	  params[i] = make_aloctype_fresh();
	fneff = effecttype_var(rstrcat(parse_region, root->name, "_eff"));
	ret = make_aloctype_fresh();
	unify_alocfntype(proj_lam(deref(root->alref)),
			 alocfntype_fn(params, fneff, ret));

	old_function_decl = current_function_decl;
	current_function_decl = fd;
	old_function_ret = current_function_ret;
	current_function_ret = ret;

	/* Add the function effect to global */
	mkleq_effecttype(fneff, global_effect);

	/* local_env = effecttype_var(rstrcat(parse_region, root->name, "_env")); */
	/* mkleq_effecttype(env, local_env); */
	local_env = env;
	bodyeff = 
	  effecttype_var(rstrcat(parse_region, root->name, "_body_eff0"));
	bodyeffs = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS+1, effecttype);
	bodyeffs[0] = bodyeff;
	for (i=1; i < NUM_ALOCFN_PARAMS+1; i++)
	  bodyeffs[i] = 
	    effecttype_var(rstrcat(parse_region, rstrcat(parse_region, root->name, "_body_eff"), inttostr(parse_region, i)));

	/*** Scan argument list ***/
	{
	  data_declaration root_vd;
	  variable_decl argvd;
	  oldidentifier_decl oid;
	  declaration arg;

	  lastbodyeff = i = 0;
	  if (!is_void_parms(fd->fdeclarator->parms))
	    scan_declaration(arg, fd->fdeclarator->parms)
	    {
	      if (is_ellipsis_decl(arg))
		break;

	      assert(i < NUM_ALOCFN_PARAMS);

	      /* Construct type of parameter */
	      if (arg->kind == kind_data_decl)
		{
		  data_decl argd = CAST(data_decl, arg);

		  argvd = CAST(variable_decl, argd->decls);
		  assert(!argvd->next);    /* Only var_decl per data_decl.
					      multi var_decls are for
					      things like int a, b. */
		  oid = NULL;
		  root_vd = root_ddecl(argvd->ddecl);
		}
	      else
		{
		  oid = CAST(oldidentifier_decl, arg);
		  argvd = NULL;
		  root_vd = root_ddecl(oid->ddecl);
		}

	      add_ddecl(root_vd);
	    
	      unify_aloctype(deref(root_vd->alref), params[i]);
	      /*
	      mkleq_effecttype(effecttype_any_reach(root_vd->alref),
			       local_env);
	      */

	      if (type_pointer(root_vd->type) && !root_vd->in_prelude)
		/* Try restrict */
		{
		  alocreftype top_al;
		  alocreftype r_al;
		  alocreftype old_al;
		  aloctype pointsto;
		  rinf_const c;
		  location loc;
		  
		  old_al = proj_tau(params[i]);
		  pointsto = deref(old_al);
		  r_al = alocreftype_ref(pointsto);
		  top_al = alocreftype_ref(make_aloctype(r_al,
							 proj_lam(params[i])));
		  /* unify_alocreftype(top_al, root_vd->alref); */
		  root_vd->alref = top_al;

		  loc = arg->kind == kind_data_decl ? argvd->loc : oid->loc;

		  /* Ignore library (prelude) files */
		  c = mk_rinf_const(loc, r_al, old_al, top_al,
				    effecttype_any_reach(proj_tau(ret)),
				    effecttype_any_reach(proj_tau(pointsto)),
				    bodyeffs[i], bodyeffs[i+1], local_env);

		  local_env = 
		    effecttype_union(local_env, 
				     effecttype_any_reach(root_vd->alref));

		  mkleq_effecttype(bodyeffs[i], bodyeffs[i+1]);
		  lastbodyeff = i+1;

		  if (flag_pam_mode)
		    {
		      if (arg->kind == kind_data_decl)
			add_declarator_overlay(argvd->declarator,
					       c);
		      else
			pam_add_overlay_file_rinf(oid->loc,
						  oid->cstring.data,
						  c);
		    }
		}
	      else
		local_env = 
		  effecttype_union(local_env, 
				   effecttype_any_reach(root_vd->alref));
	      
	      i++;
	    }
	}

	/*** Evaluate body ***/
	{
	  sinfo body;

	  assert(is_compound_stmt(fd->stmt));
	  body = analyze_statement(fd->stmt, local_env);
	  mkleq_effecttype(body.eff, bodyeff);
	}

	/* Apply (Down) once more to filter out locations neither in
	   parameters or return value */
	{
	  effecttype fn_rtype_alocs;
	  effecttype eff;
	  
	  fn_rtype_alocs = effecttype_any_reach(proj_tau(ret));
	  for (i=0; i < NUM_ALOCFN_PARAMS; i++)
	    fn_rtype_alocs = 
	      effecttype_union(fn_rtype_alocs, 
			       effecttype_any_reach(proj_tau(params[i])));

	  eff = effecttype_inter(bodyeffs[lastbodyeff], 
				 effecttype_union(env, fn_rtype_alocs));
	  mkleq_effecttype(eff, fneff);
	}

	current_function_decl = old_function_decl;
	current_function_ret = old_function_ret;

	return mkdinfo(effecttype_empty, effecttype_any_reach(root->alref));
      }
      break;
    case kind_extension_decl:
      {
	extension_decl ed = CAST(extension_decl, d);
	return analyze_declaration(ed->decl, env); /* Ignore __extension__ */
      };
    default:
      fail_loc(d->loc, "Unexpected decl kind 0x%x\n", d->kind);
    }
}

static einfo analyze_init(type t, expression rhs, effecttype env)
{
  if (rhs->kind == kind_init_list && type_array(t))
    {
      expression e;
      einfo init;
      aloctype al;
      alocreftype result;
      init_list il = CAST(init_list, rhs);
      effecttype eff;
      
      eff = effecttype_empty;
      al = make_aloctype_fresh();

      scan_expression(e, il->args)
	if (e->kind == kind_init_index)
	  {
	    init_index ii = CAST(init_index, e);
	    einfo arg1, arg2;
	    
	    arg1 = analyze_expression(ii->arg1, env);
	    eff = effecttype_union(eff, effecttype_read(arg1.tau));
	    eff = effecttype_union(eff, arg1.eff);
	    if (ii->arg2)
	      {
		arg2 = analyze_expression(ii->arg2, env);
		eff = effecttype_union(eff, effecttype_read(arg2.tau));
		eff = effecttype_union(eff, arg2.eff);
	      }
	    init = analyze_init(type_array_of(t), ii->init_expr, env);
	    eff = effecttype_union(eff, effecttype_read(init.tau));
	    eff = effecttype_union(eff, init.eff);
	    mkleq_aloctype(deref(init.tau), al);
	  }
	else
	  {
	    init = analyze_init(type_array_of(t), e, env);
	    eff = effecttype_union(eff, effecttype_read(init.tau));
	    eff = effecttype_union(eff, init.eff);
	    mkleq_aloctype(deref(init.tau), al);
	  }

      result = alocreftype_ref(make_aloctype(alocreftype_ref(al),
					     alocfntype_fresh()));

      return mkeinfo(result, eff);
     }
  else if (rhs->kind == kind_init_list && (type_struct(t) || type_union(t)))
    {
       init_list il = CAST(init_list, rhs);
       expression e;
       effecttype eff;
       aloctype al;
       field_declaration field = type_tag(t)->fieldlist;

       al = make_aloctype_fresh();
       eff = effecttype_empty;

       scan_expression(e, il->args)
	 {
	   expression init_expr;
	   einfo init;
	   
	   if (!field)
	     break;

	   if (e->kind == kind_init_field)
	     {
	       init_field ifd = CAST(init_field, e);
	       init_expr = ifd->init_expr;
	     }
	   else
	     init_expr = e;

	   init = analyze_init(field->type, init_expr, env);
	   eff = effecttype_union(eff, effecttype_read(init.tau));
	   eff = effecttype_union(eff, init.eff);
	   mkleq_aloctype(deref(init.tau), al);

	   field = field->next;
	 }
       return mkeinfo(alocreftype_ref(al), eff);
    }
  else
    return analyze_expression(rhs, env);
}

static sinfo analyze_statement(statement s, effecttype env)
{
  switch (s->kind)
    {
    case kind_asm_stmt:
      /*      report_qerror(s->loc, sev_warn,
	      "warning: ignoring in-line assembly code");*/
      return mksinfo(effecttype_empty);
      break;
    case kind_compound_stmt:
      {
	compound_stmt cs = CAST(compound_stmt, s);
	declaration decl;
	statement stmt;
	effecttype eff, local_env;

	eff = effecttype_empty;
	local_env = env;

	/* Analyze the declarations. */
	scan_declaration(decl, cs->decls)
	  {
	    dinfo next;

	    assert(decl->kind != kind_asm_decl); /*asm_decl only at toplevel */
	    next = analyze_declaration(decl, local_env);
	    eff = effecttype_union(eff, next.eff);
	    local_env = effecttype_union(local_env, next.alocs);
	  }

	/* Analyze the body, gathering up the effects. */
	scan_statement(stmt, cs->stmts)
	  {
	    sinfo next = analyze_statement(stmt, local_env);
	    eff = effecttype_union(eff, next.eff);
	  }

	/* Filter out non-escaping effects */
	eff = effecttype_inter(eff, env);

	return mksinfo(eff);
      };
      break;
    case kind_if_stmt:
      {
	if_stmt is = CAST(if_stmt, s);
	einfo guard;
	sinfo then;
	effecttype eff;

	guard = analyze_expression(is->condition, env);
      
	eff = effecttype_union(effecttype_read(guard.tau),
			       guard.eff);

	then = analyze_statement(is->stmt1, env);
	eff = effecttype_union(eff, then.eff);

	if (is->stmt2)
	  {
	    sinfo els;

	    els = analyze_statement(is->stmt2, env);
	    eff = effecttype_union(eff, els.eff);
	  }

	return mksinfo(eff);
      };
      break;
    case kind_labeled_stmt:
      {
	labeled_stmt ls = CAST(labeled_stmt, s);

	return analyze_statement(ls->stmt, env);
      };
      break;
    case kind_expression_stmt:
      {
	expression_stmt es = CAST(expression_stmt, s);
	einfo ei;

	ei = analyze_expression(es->arg1, env);

	/* No deref effect because the result gets thrown away */
	return mksinfo(ei.eff);
      };
      break;
    case kind_while_stmt:
      {
	while_stmt ws = CAST(while_stmt, s);
	einfo guard;
	sinfo body;
	effecttype eff;

	guard = analyze_expression(ws->condition, env);
	eff = effecttype_union(guard.eff, effecttype_read(guard.tau));
	body = analyze_statement(ws->stmt, env);
	eff = effecttype_union(eff, body.eff);
	return mksinfo(eff);
      };
      break;
    case kind_dowhile_stmt:
      {
	dowhile_stmt dws = CAST(dowhile_stmt, s);
	sinfo body;
	effecttype eff;

	body = analyze_statement(dws->stmt, env);
	eff = body.eff;

	if (!definite_zero(dws->condition))
	  {
	    /* Catch do { x } while(0); case -- used in macro expansions */
	    einfo guard;

	    guard = analyze_expression(dws->condition, env);
	    eff = effecttype_union(eff, effecttype_read(guard.tau));
	    eff = effecttype_union(eff, guard.eff);
	  }
	return mksinfo(eff);
      };
      break;
    case kind_switch_stmt:
      {
	switch_stmt ss = CAST(switch_stmt, s);
	einfo guard;
	sinfo body;
	effecttype eff;

	guard = analyze_expression(ss->condition, env);
	eff = effecttype_union(guard.eff, effecttype_read(guard.tau));
	body = analyze_statement(ss->stmt, env);
	eff = effecttype_union(eff, body.eff);

	return mksinfo(eff);
      };
      break;
    case kind_for_stmt:
      {
	for_stmt fs = CAST(for_stmt, s);
	sinfo body;
	effecttype eff;

	eff = effecttype_empty;

	if (fs->arg1)
	  {
	    einfo arg1;

	    arg1 = analyze_expression(fs->arg1, env);
	    eff = effecttype_union(eff, effecttype_read(arg1.tau));
	    eff = effecttype_union(eff, arg1.eff);
	  }

	if (fs->arg2)
	  {
	    einfo arg2;

	    arg2 = analyze_expression(fs->arg2, env);
	    eff = effecttype_union(eff, effecttype_read(arg2.tau));
	    eff = effecttype_union(eff, arg2.eff);
	  }

	body = analyze_statement(fs->stmt, env);
	eff = effecttype_union(eff, body.eff);

	if (fs->arg3)
	  {
	    einfo arg3;

	    arg3 = analyze_expression(fs->arg3, env);
	    eff = effecttype_union(eff, effecttype_read(arg3.tau));
	    eff = effecttype_union(eff, arg3.eff);
	  }

	return mksinfo(eff);
      };
      break;
    case kind_return_stmt:
      {
	return_stmt rs = CAST(return_stmt, s);
	effecttype eff;

	eff = effecttype_empty;
	if (rs->arg1)
	  {
	    einfo arg1;

	    arg1 = analyze_expression(rs->arg1, env);
	    eff = effecttype_union(eff, arg1.eff);
	    eff = effecttype_union(eff, effecttype_read(arg1.tau));

	    assert(current_function_ret);
	    mkleq_aloctype(deref(arg1.tau), current_function_ret);
	  }

	return mksinfo(eff);
      };
      break;
    case kind_computed_goto_stmt:
      {
	computed_goto_stmt cgs = CAST(computed_goto_stmt, s);
	einfo arg1;

	/* stmt is goto *arg1 */
	arg1 = analyze_expression(cgs->arg1, env);
	return mksinfo(effecttype_union(arg1.eff, effecttype_read(arg1.tau)));
      };
      break;
    case kind_break_stmt:
      {
	return mksinfo(effecttype_empty);
      }
    case kind_continue_stmt:
      {
	return mksinfo(effecttype_empty);
      }
    case kind_goto_stmt:
      {
	return mksinfo(effecttype_empty);
      }
    case kind_empty_stmt:
      return mksinfo(effecttype_empty);
    case kind_change_type_stmt:
      {
	change_type_stmt ct = CAST(change_type_stmt, s);
	einfo arg1;
	
	arg1 = analyze_expression(ct->arg1, env);
	return mksinfo(effecttype_union(arg1.eff, effecttype_write(arg1.tau)));
      }
      break;
    case kind_assert_type_stmt:
      {
	assert_type_stmt at = CAST(assert_type_stmt, s);
	einfo arg1;

	arg1 = analyze_expression(at->arg1, env);
	return mksinfo(effecttype_union(arg1.eff, effecttype_read(arg1.tau)));
      }
      break;
    default:
      fail_loc(s->loc, "Unexpected statement kind 0x%x\n", s->kind);
      break;
    }
}

static einfo analyze_expression(expression e, effecttype env)
{
  einfo result;

  switch(e->kind) {
  case kind_comma:
    {
      comma c = CAST(comma, e);
      expression e2;
      effecttype eff;

      /* shut up gcc4 warning about use of uninitialized value */
      result.tau = NULL;

      eff = effecttype_empty;
      scan_expression (e2, c->arg1)
	{
	  result = analyze_expression(e2, env);
	  eff = effecttype_union(eff, result.eff);
	  /* Do not add the read effects of throw away values */
	}
      
      result = mkeinfo(result.tau, eff);
    };
    break;
  case kind_sizeof_type:
    {
      result = mkeinfo(alocreftype_var("sizeof"), effecttype_empty);
    }
    break;
  case kind_alignof_type:
    {
      result = mkeinfo(alocreftype_var("alignof"), effecttype_empty);
    }
    break;
  case kind_label_address:
    {
      alocreftype alref;
      aloctype al;

      alref = alocreftype_ref(make_aloctype_fresh());
      mkleq_effecttype(effecttype_any_reach(alref), global_env);
      al = make_aloctype(alref, alocfntype_fresh());

      result = mkeinfo(alocreftype_ref(al), effecttype_empty);
    }
    break;
  case kind_cast:
    {
      cast c = CAST(cast, e);

      result = analyze_expression(c->arg1, env);
    };
    break;
  case kind_cast_list:
    {
      cast_list cl = CAST(cast_list, e);

      result = analyze_init(cl->type, cl->init_expr, env);
    };
    break;
  case kind_conditional:
    {
      conditional c = CAST(conditional, e);
      einfo cond, arg1, arg2;
      effecttype eff;

      cond = analyze_expression(c->condition, env);
      eff = effecttype_union(cond.eff, effecttype_read(cond.tau));

      if (c->arg1)
	{
	  arg1 = analyze_expression(c->arg1, env);
	  eff = effecttype_union(eff, arg1.eff);
	}
      else
	/* gcc extension:  if you omit the middle op, evaluates to
	   guard when guard is true, and guard is not reevaluated */
	arg1 = cond;

      arg2 = analyze_expression(c->arg2, env);
      eff = effecttype_union(eff, arg2.eff);

      unify_alocreftype(arg1.tau, arg2.tau);

      result = mkeinfo(arg1.tau, eff);
    };
    break;
  case kind_identifier:
    {
      identifier id = CAST(identifier, e);
      data_declaration root;

      if (is_alloc_fun(id->ddecl->name))
	result = analyze_alloc_fun();
      else if (is_free_fun(id->ddecl->name))
	result = analyze_free_fun();
      else if (is_memcpy_fun(id->ddecl->name))
	result = analyze_memcpy_fun();
      else
	{
	  root = root_ddecl(id->ddecl);

	  root->isused = TRUE;

	  if (!root->alref)
	    {
	      /* Only functions can be implicitly declared.  But there are also
		 some special gcc identifiers, notably __FUNCTION__ and
		 __PRETTY_FUNCTION__, that also don't need to be declared. */
	      /*
	      if ((type_function(id->ddecl->type) &&
		   id->ddecl->ftype == function_implicit) ||
		  !strcmp(id->ddecl->name, "__FUNCTION__") ||
		  !strcmp(id->ddecl->name, "__PRETTY_FUNCTION__") ||
		  !strcmp(id->ddecl->name, "=va_arg"))
		add_ddecl(root);
	      */
	      /* XXX Enums! */
	      /* fail_loc(id->loc, "Use before declaration\n", 0); */
	      add_ddecl(root);
	      assert(root->alref);
	    }
	  result = mkeinfo(root->alref, effecttype_empty);
	}
    };
    break;
  case kind_compound_expr:
    {
      compound_expr ce = CAST(compound_expr, e);
      compound_stmt cs = CAST(compound_stmt, ce->stmt);
      statement cur_stmt;
      declaration d;
      effecttype eff, local_env;
      alocreftype tau;

      if (cs->id_labels)
	fail_loc(cs->loc, "Unimplemented: id_labels\n", 0);

      eff = effecttype_empty;
      local_env = env;

      /* Analyze the declarations in the block */
      scan_declaration(d, cs->decls)
	{
	  dinfo next;

	  assert(d->kind != kind_asm_decl); /*asm_decl only at toplevel */
	  next = analyze_declaration(d, local_env);
	  eff = effecttype_union(eff, next.eff);
	  local_env = effecttype_union(local_env, next.alocs);
	}

      /* Analyze the statements in the block.  Analyze all but the
         last one. */
      cur_stmt = cs->stmts;
      while (cur_stmt && cur_stmt->next)
	{
	  sinfo next = analyze_statement(cur_stmt, local_env);
	  eff = effecttype_union(eff, next.eff);
	  cur_stmt = CAST(statement, cur_stmt->next);
	}

      /* Now analyze the last statement (if there is one), and
         compute the type of the expression. */
      if (cur_stmt && is_expression_stmt(cur_stmt))
	{
	  einfo next;

	  next = analyze_expression(CAST(expression_stmt, cur_stmt)->arg1,
				    local_env);

	  eff = effecttype_union(eff, next.eff);
	  tau = next.tau;
	}
      else
	{
	  /* Type is void */
	  if (cur_stmt)
	    {
	      sinfo next = analyze_statement(cur_stmt, local_env);
	      eff = effecttype_union(eff, next.eff);
	    }
	  tau = alocreftype_fresh();
	}

      /* Filter out non-escaping effects */
      /* XXX Should this be deref of tau? */
      eff = effecttype_inter(eff, 
			     effecttype_union(env, effecttype_any_reach(tau)));

      result = mkeinfo(tau, eff);
    };
    break;
  case kind_function_call:
    {
      function_call fc = CAST(function_call, e);
      einfo f_info;
      expression arg;
      int i;
      effecttype fneff, eff;
      aloctype* params;
      aloctype ret;

      /* Extract the function type of the expr in fun posn.  Note
         that arg1 must be a pointer to a function.  From C9X:

	 [#1]  The  expression  that  denotes  the called function
	 shall have  type  pointer  to  function  returning  void  or
	 returning an object type other than an array type. */

      f_info = analyze_expression(fc->arg1, env);
      params = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS, aloctype);
      for (i=0; i < NUM_ALOCFN_PARAMS; i++)
	params[i] = make_aloctype_fresh();
      fneff = effecttype_fresh();
      ret = make_aloctype_fresh();
      unify_alocfntype(proj_lam(deref(f_info.tau)),
      		       alocfntype_fn(params, fneff, ret));
      eff = effecttype_union(f_info.eff, fneff);
      eff = effecttype_union(eff, effecttype_read(f_info.tau));

      i = 0;
      scan_expression(arg, fc->args)
	{
	  einfo arg_info;

	  assert(i < NUM_ALOCFN_PARAMS);

	  arg_info = analyze_expression(arg, env);
	  eff = effecttype_union(eff, arg_info.eff);
	  eff = effecttype_union(eff, effecttype_read(arg_info.tau));

	  mkleq_aloctype(deref(arg_info.tau), params[i]);

	  i++;
	}

      result = mkeinfo(alocreftype_ref(ret), eff);
    };
    break;
  case kind_array_ref:
    {
      array_ref ar = CAST(array_ref, e);
      expression array, plus, star_plus;

      if (type_array(ar->arg1->type))
	array = ar->arg1;
      else
	array = ar->arg2;

      array->lvalue = TRUE; /* XXX: Hack to fix problem
				  w/default_conversion */
      array->cst = NULL; /* XXX: Hack to fix problem w/default_conversion */

      plus = make_binary(ar->loc, kind_plus, ar->arg1, ar->arg2);
      star_plus = make_dereference(ar->loc, plus);

      result = analyze_expression(star_plus, env);
    };
    break;
  case kind_field_ref:
    {
      /* We unify the qualifiers on the structure and the qualifiers
	 on the field.  For now.  See previous versions for other
	 approaches. */
      field_ref fr = CAST(field_ref, e);

      result = analyze_expression(fr->arg1, env);
    };
    break;
  case kind_init_list:
    {
      /*    init_list il = CAST(init_list, e);*/
      fail_loc(e->loc, "Unexpected init list\n", 0);
    };
    break;
  case kind_init_index:
    {
      /*    init_index ii = CAST(init_index, e);*/
      fail_loc(e->loc, "Unexpected init index\n", 0);
    };
    break;
  case kind_init_field:
    {
      fail_loc(e->loc, "Unexpected init field\n", 0);
    };
    break;
  case kind_lexical_cst:
    {
      result = mkeinfo(alocreftype_var("lexical_cst"), effecttype_empty);
    };
    break;
  case kind_string:
    {
      alocreftype alref;
      aloctype al;

      alref = alocreftype_ref(make_aloctype_fresh());
      mkleq_effecttype(effecttype_any_reach(alref), global_env);
      al = make_aloctype(alref, alocfntype_fresh());

      result = mkeinfo(alocreftype_ref(al), effecttype_empty);
    };
    break;
  default:
    if (is_unary(e))
      result = analyze_unary_expression(CAST(unary, e), env);
    else if (is_binary(e))
      result = analyze_binary_expression(CAST(binary, e), env);
    else
      fail_loc(e->loc, "Unexpected expr kind 0x%x\n", e->kind);
  }

  return result;
}

static einfo analyze_unary_expression(unary e, effecttype env)
{
  switch (e->kind)
    {
    case kind_dereference:
      {
	einfo arg1;

	arg1 = analyze_expression(e->arg1, env);
	
	/* XXX is this right? */
	if (type_function(e->arg1->type))
	  return arg1;
	else
	  {
	    effecttype eff;

	    eff = effecttype_union(arg1.eff, effecttype_read(arg1.tau));
	    return mkeinfo(proj_tau(deref(arg1.tau)), eff);
	  }
      }
      break;
    case kind_address_of:
      {
	einfo arg1;

	arg1 = analyze_expression(e->arg1, env);

	if (type_function(e->arg1->type))
	  return arg1;
	else
	  {
	    aloctype al;

	    al = make_aloctype(arg1.tau, alocfntype_fresh());
	    return mkeinfo(alocreftype_ref(al), arg1.eff);
	  }
      }
      break;
    case kind_extension_expr:
      {
	return analyze_expression(e->arg1, env);
      }
      break;
    case kind_sizeof_expr:
      {
	return mkeinfo(alocreftype_var("sizeof"), effecttype_empty);
      }
      break;
    case kind_alignof_expr:
      {
	return mkeinfo(alocreftype_var("alignof"), effecttype_empty);
      }
      break;
    case kind_realpart:
    case kind_imagpart:
      {
	/* XXX ??? */
	return analyze_expression(e->arg1, env);
      }
      break;
    case kind_unary_minus:
    case kind_unary_plus:
    case kind_conjugate:
    case kind_bitnot:
    case kind_not:
      {
	return analyze_expression(e->arg1, env);
      }
      break;
    case kind_preincrement:
    case kind_postincrement:
    case kind_predecrement:
    case kind_postdecrement:
      {
	einfo arg1;
	effecttype eff;

	arg1 = analyze_expression(e->arg1, env);

	eff = effecttype_union(arg1.eff, effecttype_write(arg1.tau));
	return mkeinfo(arg1.tau, eff);
      }
      break;
    default:
      fail_loc(e->loc, "Unexpected unary op kind 0x%x\n", e->kind);
    }
}

static einfo analyze_binary_expression(binary e, effecttype env)
{
  einfo arg1, arg2;
  effecttype eff;

  arg1 = analyze_expression(e->arg1, env);
  arg2 = analyze_expression(e->arg2, env);
  eff = effecttype_union(arg1.eff, arg2.eff);

  switch (e->kind)
    {
    case kind_plus:
    case kind_minus:
      {
	aloctype al;

	al = make_aloctype_fresh();

	mkleq_aloctype(deref(arg1.tau), al);
	mkleq_aloctype(deref(arg2.tau), al);
	eff = effecttype_union(eff, effecttype_read(arg1.tau));
	eff = effecttype_union(eff, effecttype_read(arg2.tau));

	return mkeinfo(alocreftype_ref(al), eff);
      }
      break;
    case kind_modulo:
    case kind_lshift:
    case kind_rshift:
    case kind_times:
    case kind_divide:
    case kind_bitand:
    case kind_bitor:
    case kind_bitxor:
    case kind_leq:
    case kind_geq:
    case kind_lt:
    case kind_gt:
    case kind_eq:
    case kind_ne:
    case kind_andand:
    case kind_oror:
      {
	/* Pointer destroying */
	return mkeinfo(alocreftype_var("ptr_destory"), eff);
      }
      break;
    case kind_modulo_assign:
    case kind_lshift_assign:
    case kind_rshift_assign:
    case kind_plus_assign:
    case kind_minus_assign:
    case kind_times_assign:
    case kind_divide_assign:
    case kind_bitand_assign:
    case kind_bitor_assign:
    case kind_bitxor_assign:
    case kind_assign:
      {
	aloctype al;

	al = make_aloctype_fresh();

	mkleq_aloctype(deref(arg2.tau), deref(arg1.tau));
	eff = effecttype_union(eff, effecttype_write(arg1.tau));
	eff = effecttype_union(eff, effecttype_read(arg2.tau));

	return mkeinfo(arg1.tau, eff);
      }
    default:
      fail_loc(e->loc, "Unexpected binary op kind 0x%x\n", e->kind);
    }
}

static einfo analyze_alloc_fun(void)
{
  int i;
  alocreftype pointsto;
  aloctype returns;
  aloctype *params;
  alocfntype alloc_fn;
  aloctype alloc;
  
  params = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS, aloctype);
  for (i=0; i < NUM_ALOCFN_PARAMS; i++)
    params[i] = make_aloctype_fresh();

  pointsto = alocreftype_ref(make_aloctype_fresh());
  returns = make_aloctype(pointsto, alocfntype_fresh());
  
  alloc_fn = alocfntype_fn(params, effecttype_fresh(), returns);
  alloc = make_aloctype(alocreftype_fresh(), alloc_fn); 

  return mkeinfo(alocreftype_ref(alloc), effecttype_empty);
}

static einfo analyze_free_fun(void)
{
  int i;
  aloctype returns;
  aloctype *params;
  alocfntype free_fn;
  aloctype free;
  
  params = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS, aloctype);
  for (i=0; i < NUM_ALOCFN_PARAMS; i++)
    params[i] = make_aloctype_fresh();

  returns = make_aloctype_fresh();
  
  free_fn = alocfntype_fn(params, effecttype_fresh(), returns);
  free = make_aloctype(alocreftype_fresh(), free_fn); 

  return mkeinfo(alocreftype_ref(free), effecttype_empty);
}

static einfo analyze_memcpy_fun(void)
{
  int i;
  aloctype returns;
  aloctype *params;
  alocfntype memcpy_fn;
  aloctype memcpy;
  effecttype fneff;
  
  params = rarrayalloc(parse_region, NUM_ALOCFN_PARAMS, aloctype);
  for (i=0; i < NUM_ALOCFN_PARAMS; i++)
    params[i] = make_aloctype_fresh();
  returns = make_aloctype_fresh();
 
  mkleq_aloctype(deref(proj_tau(params[1])), deref(proj_tau(params[0])));
  mkleq_aloctype(deref(proj_tau(params[1])), deref(proj_tau(params[0])));
  mkleq_aloctype(params[0], returns);

  fneff = effecttype_fresh();
  mkleq_effecttype(effecttype_read(proj_tau(params[1])), fneff);
  mkleq_effecttype(effecttype_write(proj_tau(params[0])), fneff);

  memcpy_fn = alocfntype_fn(params, effecttype_fresh(), returns);
  memcpy = make_aloctype(alocreftype_fresh(), memcpy_fn); 

  return mkeinfo(alocreftype_ref(memcpy), effecttype_empty);
}
