(*
 * Produce intermediate code.
 * Also performs type checking.
 *
 * ----------------------------------------------------------------
 *
 * Copyright (C) 2000 Jason Hickey, Caltech
 *
 * This program 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
 * of the License, or (at your option) any later version.
 *
 * This program 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 this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * Author: Jason Hickey
 * jyh@cs.caltech.edu
 *)

open Symbol
open Fc_ir_type
open Fc_ir_exn
open Fc_ir_exn_type
open Fc_ir_env
open Fc_ir_check

(************************************************************************
 * UTILITIES
 ************************************************************************)

(*
 * Default exception.
 *)
let raise_exn pos v =
   SemException (pos, v)

let tenv_lookup = tenv_lookup raise_exn
let tenv_expand = tenv_expand raise_exn
let venv_lookup = venv_lookup raise_exn
let venv_lookup_expand = venv_lookup_expand raise_exn

let check_types = check_types raise_exn
let check_types_list = check_types_list raise_exn
let check_fields = check_fields raise_exn

(*
 * Atom pos labels the file.
 *)
let atom_pos pos =
   string_pos "Fc_ir_ast" (atom_pos pos)

(*
 * Temporary name for the type of the
 * return value.
 *)
let return_sym = new_symbol_string "return_type"

(*
 * Binary op conversion.
 *)
let binop_of_ast_binop = function
   Fc_ast_type.PlusOp -> PlusOp
 | Fc_ast_type.MinusOp -> MinusOp
 | Fc_ast_type.TimesOp -> MulOp
 | Fc_ast_type.DivideOp -> DivOp
 | Fc_ast_type.ModOp -> RemOp
 | Fc_ast_type.BAndOp -> BAndOp
 | Fc_ast_type.BOrOp -> BOrOp
 | Fc_ast_type.BXorOp -> XorOp
 | Fc_ast_type.LShiftOp -> LslOp
 | Fc_ast_type.RShiftOp -> AsrOp
 | Fc_ast_type.EqOp
 | Fc_ast_type.NotEqOp
 | Fc_ast_type.LeOp
 | Fc_ast_type.LtOp
 | Fc_ast_type.GtOp
 | Fc_ast_type.GeOp ->
      raise (Invalid_argument "Fc_ir_ast.binop_of_ast_binop")

let relop_of_ast_binop = function
   Fc_ast_type.PlusOp
 | Fc_ast_type.MinusOp
 | Fc_ast_type.TimesOp
 | Fc_ast_type.DivideOp
 | Fc_ast_type.ModOp
 | Fc_ast_type.BAndOp
 | Fc_ast_type.BOrOp
 | Fc_ast_type.BXorOp
 | Fc_ast_type.LShiftOp
 | Fc_ast_type.RShiftOp ->
      raise (Invalid_argument "Fc_ir_ast.relop_of_ast_binop")
 | Fc_ast_type.EqOp -> EqOp
 | Fc_ast_type.NotEqOp -> NEqOp
 | Fc_ast_type.LeOp -> LeOp
 | Fc_ast_type.LtOp -> LtOp
 | Fc_ast_type.GtOp -> GtOp
 | Fc_ast_type.GeOp -> GeOp

(*
 * Dereferenced pointer type.
 *)
let type_of_deref tenv pos ty =
   match tenv_expand tenv pos ty with
      TyArray (ty, _) ->
         ty
    | TyAny
    | TyChar
    | TyInt
    | TyFloat
    | TyStruct _
    | TyFun _ ->
         raise (SemException (pos, NotAPointer ty))
    | TyId _ ->
         raise (Invalid_argument "Fc_ir_ast.type_of_deref")

(*
 * Type classification.
 *)
let type_is_float tenv pos ty =
   tenv_expand tenv pos ty = TyFloat

let type_is_int tenv pos ty =
   match tenv_expand tenv pos ty with
      TyChar
    | TyInt ->
         true
    | TyAny
    | TyFloat
    | TyStruct _
    | TyArray _
    | TyFun _ ->
         false
    | TyId _ ->
         raise (Invalid_argument "Fc_ir_ast.type_is_int")

let type_is_ptr tenv pos ty =
   match tenv_expand tenv pos ty with
      TyArray _ ->
         true
    | TyAny
    | TyChar
    | TyInt
    | TyFloat
    | TyStruct _
    | TyFun _ ->
         false
    | TyId _ ->
         raise (Invalid_argument "Fc_ir_ast.type_is_ptr")

let type_is_ptr_int tenv pos ty =
   match tenv_expand tenv pos ty with
      TyChar
    | TyInt
    | TyArray _ ->
         true
    | TyAny
    | TyFloat
    | TyStruct _
    | TyFun _ ->
         false
    | TyId _ ->
         raise (Invalid_argument "Fc_ir_ast.type_is_ptr")

let type_of_ptr tenv pos ty =
   match tenv_expand tenv pos ty with
      TyArray (ty, _) ->
         TyArray (ty, None)
    | TyAny
    | TyChar
    | TyInt
    | TyFloat
    | TyStruct _
    | TyFun _
    | TyId _ ->
         raise (Invalid_argument "Fc_ir_ast.type_of_ptr")

(*
 * Get field offset and size.
 *)
let type_of_field tenv pos v ty =
   let ty = tenv_expand tenv pos ty in
      match ty with
         TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyArray _
       | TyFun _ ->
            raise (SemException (pos, NotAStruct ty))
       | TyStruct fields ->
            (try List.assoc v fields with
                Not_found ->
                   raise (SemException (pos, UnboundLabel v)))
       | TyId v ->
            raise (Invalid_argument "Fc_ir_ast.type_of_field")

(*
 * Expand a function type.
 *)
let dest_fun_type tenv pos ty =
   match tenv_expand tenv pos ty with
      TyFun (ty_vars, ty_res) -> Some (ty_vars, ty_res)
    | _ -> None

(************************************************************************
 * COERCIONS
 ************************************************************************)

(*
 * Test a value.
 *)
let coerce_bool tenv venv pos v cont =
   let pos = string_pos "coerce_bool" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
   let v' = new_symbol_string "coerce_bool" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
   let exp =
      match ty' with
         TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyArray _ ->
            LetUnop (v', TyInt, UToInt, AtomVar v, exp)
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAScalar ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_bool")
   in
      ty, exp

(*
 * Coerce to a character.
 *)
let coerce_char tenv venv pos v cont =
   let pos = string_pos "coerce_char" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
   let v' = new_symbol_string "coerce_char" in
   let venv = venv_add venv v' TyChar in
   let ty, exp = cont tenv venv v' in
   let exp =
      match ty' with
         TyAny
       | TyChar
       | TyInt
       | TyFloat ->
            LetUnop (v', TyChar, UToChar, AtomVar v, exp)
       | TyArray _
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAScalar ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_char")
   in
      ty, exp

(*
 * Coerce to an integer.
 *)
let coerce_int tenv venv pos v cont =
   let pos = string_pos "coerce_int" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
   let v' = new_symbol_string "coerce_int" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
   let exp =
      match ty' with
         TyAny
       | TyChar
       | TyInt
       | TyFloat ->
            LetUnop (v', TyInt, UToInt, AtomVar v, exp)
       | TyArray _
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAScalar ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_int")
   in
      ty, exp

(*
 * Coerce to a float.
 *)
let coerce_float tenv venv pos v cont =
   let pos = string_pos "coerce_float" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
   let v' = new_symbol_string "coerce_float" in
   let venv = venv_add venv v' TyFloat in
   let ty, exp = cont tenv venv v' in
   let exp =
      match ty' with
         TyAny
       | TyChar
       | TyInt
       | TyFloat ->
            LetUnop (v', TyFloat, UToFloat, AtomVar v, exp)
       | TyArray _
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAScalar ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_float")
   in
      ty, exp

(*
 * Coerce to a pointer type.
 *)
let coerce_pointer tenv venv pos v cont =
   let pos = string_pos "coerce_pointer" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyArray _ ->
            cont tenv venv v
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAPointer ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_pointer")

(*
 * Must be a structure pointer.
 *)
let coerce_struct_pointer tenv venv pos v cont =
   let pos = string_pos "coerce_struct_pointer" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyArray (ty, _) ->
            (match tenv_expand tenv pos ty with
                TyStruct _ ->
                   cont tenv venv ty v
              | TyArray _
              | TyAny
              | TyChar
              | TyInt
              | TyFloat
              | TyFun _ ->
                   raise (SemException (pos, NotAStructPointer ty'))
              | TyId _ ->
                   raise (Invalid_argument "Fc_ir_ast.coerce_struct_pointer"))
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAStructPointer ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_struct_pointer")

(*
 * Specific type of pointer.
 *)
let coerce_pointer_typed tenv venv pos ty v cont =
   let pos = string_pos "coerce_pointer_typed" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyArray (ty', _) ->
            check_types tenv pos ty ty';
            cont tenv venv v
       | TyFun _ ->
            check_types tenv pos ty ty';
            let v' = new_symbol v in
            let ty = TyArray (ty, None) in
            let venv = venv_add venv v ty in
            let ty', e = cont tenv venv v' in
               ty', LetUnop (v', ty, UToFunPointer, AtomVar v, e)
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyStruct _ ->
            raise (SemException (pos, NotAPointer ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_pointer_typed")

(*
 * Coerce to an integer.
 *)
let coerce_ptr_int tenv venv pos v cont =
   let pos = string_pos "coerce_ptr_int" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
   let v' = new_symbol_string "coerce_ptr_int" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
      match ty' with
         TyAny
       | TyChar
       | TyInt
       | TyFloat ->
            ty, LetUnop (v', TyInt, UToInt, AtomVar v, exp)
       | TyArray _ ->
            cont tenv venv v
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAScalar ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_ptr_int")

(*
 * Structures have to be exactly the same.
 *)
let coerce_struct tenv venv pos fields v cont =
   let pos = string_pos "coerce_struct" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyStruct fields' ->
            check_fields tenv pos fields fields';
            cont tenv venv v
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyFun _
       | TyArray _ ->
            raise (SemException (pos, TypeError (TyStruct fields, ty')))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_struct")

(*
 * Check the function type.
 *)
let coerce_fun tenv venv pos v cont =
   let pos = string_pos "coerce_fun" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyFun (ty_vars, ty_res) ->
            cont tenv venv v ty_vars ty_res
       | TyArray ((TyFun (ty_vars, ty_res)) as f_ty, _) ->
            let v' = new_symbol v in
            let venv = venv_add venv v' f_ty in
            let ty, e = cont tenv venv v' ty_vars ty_res in
            let e = LetUnop (v', f_ty, UToFun, AtomVar v, e) in
               ty, e
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyArray _
       | TyStruct _ ->
            raise (SemException (pos, NotAFunction ty'))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_fun")

let coerce_fun_typed tenv venv pos ty_vars ty_res v cont =
   let pos = string_pos "coerce_fun_typed" pos in
   let ty' = venv_lookup_expand tenv venv pos v in
      match ty' with
         TyFun (ty_vars', ty_res') ->
            check_types_list tenv pos ty_vars ty_vars';
            check_types tenv pos ty_res ty_res';
            cont tenv venv v
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyArray _
       | TyStruct _ ->
            raise (SemException (pos, TypeError (TyFun (ty_vars, ty_res), ty')))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_fun_typed")

(*
 * Coerce the arguments to a function.
 *)
let coerce_arg tenv venv pos v ty cont =
   let pos = string_pos "coerce_arg" pos in
      match tenv_expand tenv pos ty with
         TyChar ->
            coerce_char tenv venv pos v cont
       | TyInt ->
            coerce_int tenv venv pos v cont
       | TyFloat ->
            coerce_float tenv venv pos v cont
       | TyArray (ty, _) ->
            coerce_pointer_typed tenv venv pos ty v cont
       | TyStruct fields ->
            coerce_struct tenv venv pos fields v cont
       | TyFun (ty_vars, ty_res) ->
            coerce_fun_typed tenv venv pos ty_vars ty_res v cont
       | TyAny
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.coerce_arg")

let coerce_args tenv venv pos args types cont =
   let pos = string_pos "coerce_args" pos in
   let len1 = List.length types in
   let len2 = List.length args in
   let rec loop tenv venv vars args types =
      match args, types with
         arg :: args, ty :: types ->
            coerce_arg tenv venv pos arg ty (fun tenv venv v ->
                  loop tenv venv (v :: vars) args types)
       | [], [] ->
            cont tenv venv (List.rev vars)
       | _ ->
            raise (SemException (pos, ArityMismatch (len1, len2)))
   in
      loop tenv venv [] args types

(*
 * Remove size from array type.
 *)
let squash_array_type tenv pos ty =
   let ty = tenv_expand tenv pos ty in
      match ty with
         TyArray (ty, Some _) -> TyArray (ty, None)
       | TyArray (_, None) -> ty
       | TyAny
       | TyChar
       | TyInt
       | TyFloat
       | TyStruct _
       | TyFun _ ->
            raise (SemException (pos, NotAPointer ty))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.squash_array")

(************************************************************************
 * TYPE CONVERSION
 ************************************************************************)

(*
 * Make a IR type from an AST type.
 *)
let rec make_type squash tenv = function
   Fc_ast_type.TypeBool  _ ->
      TyInt
 | Fc_ast_type.TypeChar  _ ->
      TyChar
 | Fc_ast_type.TypeInt   _ ->
      TyInt
 | Fc_ast_type.TypeFloat _ ->
      TyFloat
 | Fc_ast_type.TypeId (v, pos) ->
      if squash then
         match tenv_lookup tenv (atom_pos pos) v with
            TyArray (ty, Some _) -> TyArray (ty, None)
          | _ -> TyId v
      else
         TyId v
 | Fc_ast_type.TypeArray (ty, len, pos) ->
      (* Length should be a constant *)
      let len =
         match len with
            Some expr ->
               let i =
                  try Fc_ast_eval.eval_int expr with
                     Fc_ast_eval.EvalException _ ->
                        raise (SemException (atom_pos pos, NotAConstant expr))
               in
                  Some i
          | None ->
               None
      in
      let len =
         if squash then
            None
         else
            len
      in
         TyArray (make_type squash tenv ty, len)
 | Fc_ast_type.TypeStruct (fields, _) ->
      TyStruct (make_type_fields tenv fields)
 | Fc_ast_type.TypeFun (ty_vars, ty_res, _) ->
      TyFun (List.map (make_type true tenv) ty_vars, make_type true tenv ty_res)

and make_type_fields tenv = function
   (v, ty, _) :: fields ->
      (v, make_type false tenv ty) :: make_type_fields tenv fields
 | [] ->
      []

(*
 * Default versions.
 *)
let make_nosquash_type = make_type false
let make_type = make_type true

(************************************************************************
 * SIMPLE FIR
 ************************************************************************)

(*
 * Scalar operations.
 *)
let make_scalar op ty tenv venv e cont =
   let v = new_symbol_string "make_scalar" in
   let venv = venv_add venv v ty in
   let ty', exp = cont tenv venv v in
   let exp = LetAtom (v, ty, op e, exp) in
      ty', exp

let make_int = make_scalar (fun i -> AtomInt i) TyInt
let make_char = make_scalar (fun c -> AtomChar c) TyChar
let make_float = make_scalar (fun x -> AtomFloat x) TyFloat

(*
 * String allocation.
 *)
let make_string tenv venv s cont =
   let v = new_symbol_string "make_string" in
   let ty = TyArray (TyChar, None) in
   let venv = venv_add venv v ty in
   let ty, exp = cont tenv venv v in
   let exp = LetString (v, s, exp) in
      ty, exp

(************************************************************************
 * ADDRESS-OF
 ************************************************************************)

(*
 * Simple variable.
 *)
let make_addr_of_var tenv venv pos v cont =
   let pos = string_pos "make_addr_of_var" pos in
   let ty' = TyArray (venv_lookup venv pos v, None) in
   let v' = new_symbol_string "make_addr_of_var" in
   let venv = venv_add venv v' ty' in
   let ty, exp = cont tenv venv v' in
   let exp = LetAddrOfVar (v', ty', v, exp) in
      ty, exp

(*
 * Projection.
 *)
let make_addr_of_project tenv venv pos v l cont =
   let pos = string_pos "make_addr_of_project" pos in
      coerce_struct_pointer tenv venv pos v (fun tenv venv ty_struct v ->
            let ty_field = type_of_field tenv pos l ty_struct in
            let v' = new_symbol_string "make_addr_of_project" in
            let ty_ptr = TyArray (ty_field, None) in
            let venv = venv_add venv v' ty_ptr in
            let ty, exp = cont tenv venv v' in
            let exp = LetAddrOfProject (v', ty_ptr, AtomVar v, l, exp) in
               ty, exp)

(*
 * Subscript.
 *)
let make_addr_of_subscript tenv venv pos v1 v2 cont =
   let pos = string_pos "make_addr_of_subscript" pos in
      coerce_pointer tenv venv pos v1 (fun tenv venv v1 ->
            coerce_int tenv venv pos v2 (fun tenv venv v2 ->
                  let v' = new_symbol_string "make_addr_of_subscript" in
                  let ty' = squash_array_type tenv pos (venv_lookup venv pos v1) in
                  let venv = venv_add venv v' ty' in
                  let ty, exp = cont tenv venv v' in
                  let exp =
                     LetBinop (v', ty', PlusOp, AtomVar v1, AtomVar v2, exp)
                  in
                     ty, exp))

(************************************************************************
 * UNARY OPERATIONS
 ************************************************************************)

(*
 * Unary minus.
 *)
let make_uminus_expr tenv venv pos v cont =
   let pos = string_pos "make_uminus_expr" pos in
      match venv_lookup_expand tenv venv pos v with
         TyAny
       | TyChar
       | TyInt ->
            coerce_int tenv venv pos v (fun tenv venv v ->
                  let v' = new_symbol_string "make_uminus_expr_int" in
                  let venv = venv_add venv v' TyInt in
                  let ty, exp = cont tenv venv v' in
                  let exp = LetUnop (v', TyInt, UMinusOp, AtomVar v, exp) in
                     ty, exp)
       | TyFloat ->
            let v' = new_symbol_string "make_uminus_expr_float" in
            let venv = venv_add venv v' TyFloat in
            let ty, exp = cont tenv venv v' in
            let exp = LetUnop (v', TyFloat, UMinusOp, AtomVar v, exp) in
               ty, exp
       | TyArray _
       | TyStruct _
       | TyFun _ as ty ->
            raise (SemException (pos, TypeError (TyInt, ty)))
       | TyId _ ->
            raise (Invalid_argument "Fc_ir_ast.make_uminus_expr")

(*
 * Unary negation.
 *)
let make_unot_expr tenv venv pos v cont =
   let pos = string_pos "make_unot_expr" pos in
      coerce_bool tenv venv pos v (fun tenv venv v ->
            let v' = new_symbol_string "make_unot_expr" in
            let venv = venv_add venv v' TyInt in
            let ty, exp = cont tenv venv v' in
            let exp = LetUnop (v', TyInt, UNotOp, AtomVar v, exp) in
               ty, exp)

(*
 * Dereference.
 *)
let make_deref_expr tenv venv pos v cont =
   let pos = string_pos "make_deref_expr" pos in
      coerce_pointer tenv venv pos v (fun tenv venv v ->
            let v' = new_symbol_string "make_deref_expr" in
            let ty = venv_lookup venv pos v in
            let venv = venv_add venv v' (type_of_deref tenv pos ty) in
            let ty, exp = cont tenv venv v' in
            let exp = LetSubscript (v', ty, AtomVar v, AtomInt 0, exp) in
               ty, exp)

(************************************************************************
 * BINARY OPERATIONS
 ************************************************************************)

(*
 * Pointer arithmetic.
 *)
let make_ptr_arith tenv venv pos op v1 ty1 v2 ty2 cont =
   if type_is_ptr tenv pos ty2 then
      begin
         (*
          * If both are pointers, they should have the same type.
          * The op must be a subtraction, and the value is TyInt.
          *)
         check_types tenv pos ty1 ty2;
         if op <> Fc_ast_type.MinusOp then
            raise (SemException (pos, TypeError (TyInt, ty2)));
         let v' = new_symbol_string "sub_pointer" in
         let venv = venv_add venv v' TyInt in
         let ty', exp = cont tenv venv v' in
         let exp =
            LetBinop (v', TyInt, MinusOp, AtomVar v1, AtomVar v2, exp)
         in
            TyInt, exp
      end
   else if op = Fc_ast_type.PlusOp then
      (*
       * PlusOp supports addition of a integer to a pointer.
       *)
      coerce_int tenv venv pos v2 (fun tenv venv v2 ->
               let v' = new_symbol_string "make_arith_int" in
               let ty = type_of_ptr tenv pos ty1 in
               let venv = venv_add venv v' ty in
               let ty', exp = cont tenv venv v' in
               let exp =
                  LetBinop (v', ty, PlusOp, AtomVar v1, AtomVar v2, exp)
               in
                  ty', exp)
   else
      raise (SemException (pos, TypeError (TyInt, ty1)))

(*
 * Normal int/float arithmetic.
 *)
let make_arith tenv venv pos op v1 v2 cont =
   let pos = string_pos "make_arith" pos in
   let ty1 = venv_lookup_expand tenv venv pos v1 in
   let ty2 = venv_lookup_expand tenv venv pos v2 in
      if type_is_float tenv pos ty1 then
         coerce_float tenv venv pos v2 (fun tenv venv v2 ->
               let v' = new_symbol_string "make_arith_float1" in
               let venv = venv_add venv v' TyFloat in
               let ty', exp = cont tenv venv v' in
               let exp =
                  LetBinop (v', TyFloat, binop_of_ast_binop op, AtomVar v1, AtomVar v2, exp)
               in
                  ty', exp)
      else if type_is_float tenv pos ty2 then
         coerce_float tenv venv pos v1 (fun tenv venv v1 ->
               let v' = new_symbol_string "make_arith_float2" in
               let venv = venv_add venv v' TyFloat in
               let ty', exp = cont tenv venv v' in
               let exp =
                  LetBinop (v', TyFloat, binop_of_ast_binop op, AtomVar v1, AtomVar v2, exp)
               in
                  ty', exp)
      else if type_is_int tenv pos ty1 then
         coerce_int tenv venv pos v2 (fun tenv venv v2 ->
               let v' = new_symbol_string "make_arith_int" in
               let venv = venv_add venv v' TyInt in
               let ty', exp = cont tenv venv v' in
               let exp =
                  LetBinop (v', TyInt, binop_of_ast_binop op, AtomVar v1, AtomVar v2, exp)
               in
                  ty', exp)
      else if type_is_ptr tenv pos ty1 then
         make_ptr_arith tenv venv pos op v1 ty1 v2 ty2 cont
      else
         raise (SemException (pos, TypeError (ty1, ty2)))

(*
 * Integer-only arithmetic.
 *)
let make_int_arith tenv venv pos op v1 v2 cont =
   let pos = string_pos "make_int_arith" pos in
      coerce_int tenv venv pos v1 (fun tenv venv v1 ->
            coerce_int tenv venv pos v2 (fun tenv venv v2 ->
                  let v' = new_symbol_string "make_int_arith" in
                  let venv = venv_add venv v' TyInt in
                  let ty, exp = cont tenv venv v' in
                  let exp =
                     LetBinop (v', TyInt, binop_of_ast_binop op, AtomVar v1, AtomVar v2, exp)
                  in
                     ty, exp))

(*
 * Relation.
 *)
let make_relation tenv venv pos op v1 v2 cont =
   let pos = string_pos "make_relation" pos in

   (* Wrap the continuation in a function *)
   let v = new_symbol_string "make_relation_arg" in
   let ty, body =
      let venv = venv_add venv v TyInt in
         cont tenv venv v
   in
   let f = new_symbol_string "make_relation_fun" in
   let f_ty = TyFun ([TyInt], ty) in
   let venv = venv_add venv f f_ty in

   (* Do the analysis *)
   let ty1 = venv_lookup_expand tenv venv pos v1 in
   let ty2 = venv_lookup_expand tenv venv pos v2 in
   let op = relop_of_ast_binop op in
   let case0 = TailCall (f, [AtomInt 0]) in
   let case1 = TailCall (f, [AtomInt 1]) in
   let _, exp =
      if type_is_float tenv pos ty1 then
         coerce_float tenv venv pos v2 (fun tenv venv v2 ->
               ty, IfThenElse (op, AtomVar v1, AtomVar v2, case1, case0))
      else if type_is_float tenv pos ty2 then
         coerce_float tenv venv pos v1 (fun tenv venv v1 ->
               ty, IfThenElse (op, AtomVar v1, AtomVar v2, case1, case0))
      else if type_is_ptr_int tenv pos ty1 then
         coerce_ptr_int tenv venv pos v2 (fun tenv venv v2 ->
               check_types tenv pos ty1 ty2;
               ty, IfThenElse (op, AtomVar v1, AtomVar v2, case1, case0))
      else
         raise (SemException (pos, TypeError (ty1, ty2)))
   in
   let exp = LetFuns ([f, false, f_ty, [v], body], exp) in
      ty, exp

(************************************************************************
 * FIR PRODUCTION
 ************************************************************************)

(*
 * Address-of.
 *)
let rec make_addr_of_expr tenv venv pos e cont =
   let pos = string_pos "make_addr_of_expr" pos in
   let atom_pos pos = string_pos "make_addr_of" (atom_pos pos) in
      match e with
         Fc_ast_type.VarExpr (v, pos) ->
            make_addr_of_var tenv venv (atom_pos pos) v cont
       | Fc_ast_type.UnOpExpr (Fc_ast_type.UStarOp, e, pos) ->
            make_expr tenv venv e (fun tenv venv v ->
                  coerce_pointer tenv venv (atom_pos pos) v (fun tenv venv v ->
                        cont tenv venv v))
       | Fc_ast_type.SubscriptExpr (e1, e2, pos) ->
            make_expr tenv venv e1 (fun tenv venv v1 ->
                  make_expr tenv venv e2 (fun tenv venv v2 ->
                        make_addr_of_subscript tenv venv (atom_pos pos) v1 v2 cont))
       | Fc_ast_type.ProjectExpr (e, l, pos) ->
            let pos = atom_pos pos in
               make_addr_of_expr tenv venv pos e (fun tenv venv v ->
                     make_addr_of_project tenv venv pos v l cont)
       | _ ->
            raise (SemException (pos, NotAddressible e))

(*
 * Unary operations.
 *)
and make_unop_expr tenv venv pos op e cont =
   let pos = string_pos "make_unop_expr" pos in
      make_expr tenv venv e (fun tenv venv v ->
            match op with
               Fc_ast_type.UMinusOp ->
                  make_uminus_expr tenv venv pos v cont
             | Fc_ast_type.UNotOp ->
                  make_unot_expr tenv venv pos v cont
             | Fc_ast_type.UStarOp ->
                  make_deref_expr tenv venv pos v cont)

(*
 * Pre- and postfix operations.
 *)
and make_uarith_expr tenv venv pos op e cont =
   let pos = string_pos "make_uarith_expr" pos in
      match e with
         Fc_ast_type.VarExpr (v, pos) ->
            let pos = string_pos "make_uarith1" (atom_pos pos) in
               make_var_uarith_expr tenv venv pos op v cont
       | _ ->
            make_any_uarith_expr tenv venv pos op e cont

(*
 * Var arith.
 *)
and make_var_uarith_expr' tenv venv pos op v ty' cont =
   let pos = string_pos "make_var_uarith_aux" pos in
   let v1 = new_symbol_string "make_var_uarith1" in
   let v2 = new_symbol_string "make_var_uarith2" in
   let v3 = new_symbol_string "make_var_uarith3" in
   let venv = venv_add venv v1 ty' in
   let venv = venv_add venv v2 ty' in
   let venv = venv_add venv v3 ty' in
   let ty' = tenv_expand tenv pos ty' in
   let v', op =
      match op with
         Fc_ast_type.PreIncrOp ->
            v2, PlusOp
       | Fc_ast_type.PostIncrOp ->
            v1, PlusOp
       | Fc_ast_type.PreDecrOp ->
            v2, MinusOp
       | Fc_ast_type.PostDecrOp ->
            v1, MinusOp
   in
   let i =
      if type_is_float tenv pos ty' then
         AtomFloat 1.0
      else if type_is_ptr_int tenv pos ty' then
         AtomInt 1
      else
         raise (SemException (pos, NotAPrefixValue ty'))
   in
      cont tenv venv op i v' v1 v2 v3

and make_var_uarith_expr tenv venv pos op v cont =
   let pos = string_pos "make_var_uarith" pos in
   let ty' = venv_lookup venv pos v in
      make_var_uarith_expr' tenv venv pos op v ty' (fun tenv venv op i v' v1 v2 v3 ->
            let ty, exp = cont tenv venv v' in
            let exp =
               LetAtom (v1, ty', AtomVar v,
                        LetBinop (v3, ty', op, AtomVar v1, i,
                                  SetVar (v, ty', AtomVar v3,
                                          LetAtom (v2, ty', AtomVar v3, exp))))
            in
               ty, exp)

(*
 * Other arith requires a pointer.
 *)
and make_any_uarith_expr tenv venv pos op e cont =
   let pos = string_pos "make_any_uarith" pos in
      make_addr_of_expr tenv venv pos e (fun tenv venv v ->
            let ty' = venv_lookup venv pos v in
            let ty' = type_of_deref tenv pos ty' in
               make_var_uarith_expr' tenv venv pos op v ty' (fun tenv venv op i v' v1 v2 v3 ->
                     let ty, exp = cont tenv venv v' in
                     let exp =
                        LetSubscript (v1, ty', AtomVar v, AtomInt 0,
                                      LetBinop (v3, ty', op, AtomVar v1, i,
                                                SetSubscript (AtomVar v, ty', AtomInt 0, AtomVar v3,
                                                              LetAtom (v2, ty', AtomVar v3, exp))))
                     in
                        ty, exp))

(*
 * Binary operations.
 *)
and make_binop_val tenv venv pos op v1 v2 cont =
   let pos = string_pos "make_binop_val" pos in
      match op with
         Fc_ast_type.PlusOp
       | Fc_ast_type.MinusOp
       | Fc_ast_type.TimesOp
       | Fc_ast_type.DivideOp ->
            make_arith tenv venv pos op v1 v2 cont
       | Fc_ast_type.ModOp
       | Fc_ast_type.BAndOp
       | Fc_ast_type.BOrOp
       | Fc_ast_type.BXorOp
       | Fc_ast_type.LShiftOp
       | Fc_ast_type.RShiftOp ->
            make_int_arith tenv venv pos op v1 v2 cont
       | Fc_ast_type.EqOp
       | Fc_ast_type.NotEqOp
       | Fc_ast_type.LeOp
       | Fc_ast_type.LtOp
       | Fc_ast_type.GeOp
       | Fc_ast_type.GtOp ->
            make_relation tenv venv pos op v1 v2 cont

and make_binop_expr tenv venv pos op e1 e2 cont =
   let pos = string_pos "make_binop_expr" pos in
      make_expr tenv venv e1 (fun tenv venv v1 ->
            make_expr tenv venv e2 (fun tenv venv v2 ->
                  make_binop_val tenv venv pos op v1 v2 cont))

(*
 * Boolean relations are short-circuit.
 *)
and make_boolop_expr tenv venv pos op e1 e2 cont =
   let pos = string_pos "make_boolop_expr" pos in
      make_expr tenv venv e1 (fun tenv venv v1 ->
            match op with
               Fc_ast_type.LAndOp ->
                  make_bool_relation tenv venv pos true v1 e2 cont
             | Fc_ast_type.LOrOp ->
                  make_bool_relation tenv venv pos false v1 e2 cont)

and make_bool_relation tenv venv pos andp v1 e2 cont =
   let pos = string_pos "make_bool_relation" pos in

   (* Wrap the continuation in a function *)
   let v = new_symbol_string "make_bool_relation_arg" in
   let ty, body =
      let venv = venv_add venv v TyInt in
         cont tenv venv v
   in
   let f = new_symbol_string "make_bool_relation_fun" in
   let f_ty = TyFun ([TyInt], ty) in
   let venv = venv_add venv f f_ty in

   (* Do the analysis *)
   let _, rest =
      coerce_int tenv venv pos v1 (fun tenv venv v1 ->
            let case0 = TailCall (f, [AtomInt 0]) in
            let case1 = TailCall (f, [AtomInt 1]) in
            let _, case2 =
               make_expr tenv venv e2 (fun _ _ v -> ty, TailCall (f, [AtomVar v]))
            in
            let false_case, true_case =
               if andp then
                  case0, case2
               else
                  case2, case1
            in
               ty, IfThenElse (EqOp, AtomVar v1, AtomInt 0, false_case, true_case))
   in
      ty, LetFuns ([f, false, f_ty, [v], body], rest)

(*
 * Subscript.
 *)
and make_subscript_expr tenv venv pos e1 e2 cont =
   let pos = string_pos "make_subscript_expr" pos in
      make_expr tenv venv e1 (fun tenv venv v1 ->
            make_expr tenv venv e2 (fun tenv venv v2 ->
                  coerce_pointer tenv venv pos v1 (fun tenv venv v1 ->
                        coerce_int tenv venv pos v2 (fun tenv venv v2 ->
                              let v' = new_symbol_string "make_subscript1" in
                              let ty' = squash_array_type tenv pos (venv_lookup venv pos v1) in
                              let venv = venv_add venv v' ty' in
                              let v'' = new_symbol_string "make_subscript2" in
                              let ty'' = type_of_deref tenv pos ty' in
                              let venv = venv_add venv v'' ty'' in
                              let ty, exp = cont tenv venv v'' in
                              let exp =
                                 LetBinop (v', ty', PlusOp, AtomVar v1, AtomVar v2,
                                           LetSubscript (v'', ty'', AtomVar v', AtomInt 0, exp))
                              in
                                 ty, exp))))

(*
 * Struct projection.
 *)
and make_project_expr tenv venv pos e1 label cont =
   let pos = string_pos "make_project_expr" pos in
      make_addr_of_expr tenv venv pos e1 (fun tenv venv v1 ->
            let ty_struct = type_of_deref tenv pos (venv_lookup venv pos v1) in
            let ty_field = type_of_field tenv pos label ty_struct in
            let v' = new_symbol_string "make_project" in
            let venv = venv_add venv v' ty_field in
            let ty, exp = cont tenv venv v' in
               match tenv_expand tenv pos ty_field with
                  TyArray (ty, Some _) ->
                     ty, LetAddrOfProject (v', TyArray (ty, None), AtomVar v1, label, exp)
                | _ ->
                     ty, LetProject (v', ty_field, AtomVar v1, label, exp))

(*
 * Function application.
 *)
and make_apply_expr tenv venv pos f args cont =
   let pos = string_pos "make_apply_expr" pos in
      make_expr tenv venv f (fun tenv venv f ->
            make_list_expr tenv venv args (fun tenv venv args ->
                  coerce_fun tenv venv pos f (fun tenv venv f ty_vars ty_res ->
                        coerce_args tenv venv pos args ty_vars (fun tenv venv args ->
                              let v' = new_symbol_string "make_apply" in
                              let venv = venv_add venv v' ty_res in
                              let args = List.map (fun v -> AtomVar v) args in
                              let ty, exp = cont tenv venv v' in
                              let exp = LetApply (v', ty_res, f, args, exp) in
                                 ty, exp))))

(*
 * Assignment.
 *)
and make_assign_expr tenv venv pos op e1 e2 cont =
   let pos = string_pos "make_assign_expr" pos in
      match e1 with
         Fc_ast_type.VarExpr (v1, pos) ->
            let pos = string_pos "make_assign1" (atom_pos pos) in
               make_assign_var_expr tenv venv pos op v1 e1 e2 cont
       | _ ->
            let pos = string_pos "make_assign2" pos in
               make_assign_nonvar_expr tenv venv pos op e1 e2 cont

(*
 * Assign a value to a variable.
 *)
and make_assign_var_expr tenv venv pos op v1 e1 e2 cont =
   let pos = string_pos "make_assign" pos in
   let ty, exp = cont tenv venv v1 in
      match op with
         None ->
            make_expr tenv venv e2 (fun tenv venv v2 ->
                  let ty1 = venv_lookup venv pos v1 in
                  let ty2 = venv_lookup venv pos v2 in
                  let _ = check_types tenv pos ty1 ty2 in
                  let exp = SetVar (v1, ty1, AtomVar v2, exp) in
                     ty, exp)
       | Some op ->
            make_binop_expr tenv venv pos op e1 e2 (fun tenv venv v ->
                  let ty' = venv_lookup venv pos v in
                  let exp = SetVar (v1, ty', AtomVar v, exp) in
                     ty, exp)

(*
 * Assign a value to a non-variable.
 *)
and make_assign_nonvar_expr tenv venv pos op e1 e2 cont =
   let pos = string_pos "make_assign_nonvar_expr" pos in
      make_addr_of_expr tenv venv pos e1 (fun tenv venv v1 ->
            make_expr tenv venv e2 (fun tenv venv v2 ->
                  let ty1 = venv_lookup venv pos v1 in
                  let ty1 = type_of_deref tenv pos ty1 in

                  (* v_final is the value of v1 after assignment *)
                  let v_final = new_symbol_string "make_assign_nonvar1" in
                  let venv = venv_add venv v_final ty1 in
                  let ty, exp = cont tenv venv v_final in
                  let exp =
                     match op with
                        Some op ->
                           (* v_init is the initial value of v1 *)
                           let v_init = new_symbol_string "make_assign_nonvar2" in
                           let venv = venv_add venv v_init ty1 in
                              LetSubscript (v_init, ty1, AtomVar v1, AtomInt 0,
                                            snd (make_binop_val tenv venv pos op v_init v2 (fun tenv venv v3 ->
                                                       ty, SetSubscript (AtomVar v1, ty1, AtomInt 0, AtomVar v3,
                                                                         LetAtom (v_final, ty1, AtomVar v3, exp)))))
                      | None ->
                           SetSubscript (AtomVar v1, ty1, AtomInt 0, AtomVar v2,
                                         LetAtom (v_final, ty1, AtomVar v2, exp))
                  in
                     ty, exp))

(*
 * Conditional.
 *)
and make_if_expr tenv venv pos e1 e2 e3 cont =
   (* Wrap the continuation in a function call *)
   let pos = string_pos "make_if_expr" pos in
   let f = new_symbol_string "make_if_cont_fun" in
   let v = new_symbol_string "make_if_cont_arg" in

   (* Get type and expression for true case *)
   let true_ty, true_exp =
      make_expr tenv venv e2 (fun tenv venv v2 ->
            let ty = venv_lookup venv (int_pos 1 pos) v2 in
            let exp = TailCall (f, [AtomVar v2]) in
               ty, exp)
   in

   (* Get type and expression for false case *)
   let false_ty, false_exp =
      match e3 with
         Some e3 ->
            make_expr tenv venv e3 (fun tenv venv v3 ->
                  let ty = venv_lookup venv (int_pos 2 pos) v3 in
                  let exp = TailCall (f, [AtomVar v3]) in
                     ty, exp)
       | None ->
            TyInt, TailCall (f, [AtomInt 0])
   in

   (* Make sure types of both cases are the same *)
   let _ = check_types tenv (int_pos 3 pos) true_ty false_ty in

   (* Build the function body *)
   let ty, body =
      let venv = venv_add venv v true_ty in
         cont tenv venv v
   in
   let fun_ty = TyFun ([true_ty], ty) in
      (* Build the expression *)
      make_expr tenv venv e1 (fun tenv venv v1 ->
            coerce_bool tenv venv (int_pos 4 pos) v1 (fun tenv venv v1 ->
                  let exp =
                     LetFuns ([f, false, fun_ty, [v], body],
                              IfThenElse (EqOp, AtomVar v1, AtomInt 0, false_exp, true_exp))
                  in
                     ty, exp))

(*
 * For loop.  Just transform it into a while loop.
 *)
and make_for_expr tenv venv pos e1 e2 e3 e4 cont =
   let e =
      Fc_ast_type.SeqExpr (**)
         ([e1; Fc_ast_type.WhileExpr (**)
              (e2, Fc_ast_type.SeqExpr ([e4; e3; Fc_ast_type.IntExpr (0, pos)], pos), pos)], pos)
   in
      make_expr tenv venv e cont

(*
 * While loop.
 * This becomes a recursive function.
 *)
and make_while_expr tenv venv pos e1 e2 cont =
   (* Put the rest of the program in a function called "break" *)
   let pos = string_pos "make_while_expr" pos in
   let v = new_symbol_string "make_while1" in
   let venv' = venv_add venv v TyInt in
   let ty, exp = cont tenv venv' v in
   let f_break = Symbol.add "break" in
   let f_cont = new_symbol f_break in
   let f_cont_ty = TyFun ([], ty) in
   let venv = venv_add venv f_cont f_cont_ty in
   let venv = venv_add venv f_break f_cont_ty in

   (* Loop is also wrapped in a function *)
   let f_loop = new_symbol_string "make_while2" in
   let f_loop_ty = TyFun ([], ty) in
   let venv = venv_add venv f_loop f_loop_ty in
   let _, loop_exp =
      make_expr tenv venv e1 (fun tenv venv v1 ->
            coerce_bool tenv venv pos v1 (fun tenv venv v1 ->
                  ty, IfThenElse (EqOp, AtomVar v1, AtomInt 0,
                                  TailCall (f_cont, []),
                                  snd (make_expr tenv venv e2 (fun tenv venv _ ->
                                             ty, TailCall (f_loop, []))))))
   in
   let exp =
      LetFuns ([f_cont, false, f_cont_ty, [], LetAtom (v, TyInt, AtomInt 0, exp)],
               LetFuns ([f_break, false, f_cont_ty, [], TailCall (f_cont, []);
                         f_loop, false, f_loop_ty, [], loop_exp],
                        TailCall (f_loop, [])))
   in
      ty, exp

(*
 * Sequential execution.
 * Have to wrap the continuation in a function
 * so that environment will be correct.
 *)
and make_seq_expr tenv venv pos el cont =
   let pos = string_pos "make_seq_expr" pos in
   let f = new_symbol_string "make_seq_expr_fun" in
   let v = new_symbol_string "make_seq_expr_arg" in

   (*
    * Expand the block.  Perform a tailcall
    * once the block is finished.  We use a ref
    * cell to capture the value of the continuation
    * so that it can be wrapped in a function definition.
    * This is a little bogus, but the ref is localized to
    * this function, so it is unlikely to cause problems.
    *)
   let fund = ref None in
   let rec loop tenv venv' v_return = function
      e :: el ->
         make_expr tenv venv' e (fun tenv venv' v ->
               loop tenv venv' (Some v) el)
    | [] ->
         let ty_arg, a =
            match v_return with
               Some v ->
                  let ty = venv_lookup venv' pos v in
                  let a = AtomVar v in
                     ty, a
             | None ->
                  TyInt, AtomInt 0
         in
         let venv = venv_add venv v ty_arg in
         let ty_res, body = cont tenv venv v in
            fund := Some (ty_arg, ty_res, body);
            ty_res, TailCall (f, [a])
   in
   let ty_res, exp = loop tenv venv None el in

   (*
    * Expand the function block.
    *)
   let ty_arg, ty_res, body =
      match !fund with
         Some (ty_arg, ty_res, body) ->
            ty_arg, ty_res, body
       | None ->
            let venv = venv_add venv v TyAny in
            let ty_res, body = cont tenv venv v in
               TyAny, ty_res, body
   in
   let f_ty = TyFun ([ty_arg], ty_res) in
   let exp = LetFuns ([f, false, f_ty, [v], body], exp) in
      ty_res, exp

(*
 * Return from the current function.
 *)
and make_return_expr tenv venv pos e cont =
   let pos = string_pos "make_return_expr" pos in
      make_expr tenv venv e (fun tenv venv v ->
            let ty_res = venv_lookup venv pos return_sym in
               coerce_arg tenv venv pos v ty_res (fun tenv venv v ->
                     TyAny, Return (AtomVar v)))

(*
 * Break from the current loop.
 * Just passes control to the "break" function.
 *)
and make_break_expr tenv venv pos cont =
   let pos = string_pos "make_break_expr" pos in
   let f_break = Symbol.add "break" in
   let ty = venv_lookup venv pos f_break in
      ty, TailCall (f_break, [])

(*
 * Variable definitions.
 *)
and make_var_def_expr tenv venv (v, ty, e_opt, pos) cont =
   let pos = string_pos "make_var_def_expr" (atom_pos pos) in
      make_expr_opt tenv venv e_opt (fun tenv venv a ->
            let ty' = make_nosquash_type tenv ty in
            let venv = venv_add venv v ty' in
            let v'' = new_symbol v in
            let venv = venv_add venv v'' TyInt in
            let ty, exp = cont tenv venv v'' in
            let exp =
               match dest_fun_type tenv pos ty' with
                  Some (ty_vars, ty_res) ->
                     let vars = List.map (fun _ -> new_symbol_string "v") ty_vars in
                     let args = List.map (fun v -> AtomVar v) vars in
                     let v' = new_symbol v in
                     let f = Symbol.add ("%" ^ Symbol.to_string v) in
                        LetFuns ([v, true, ty', vars,
                                  LetExtCall (v', f, ty', args, Return (AtomVar v'))], exp)
                | None ->
                     LetCopy (v, ty', a, exp)
            in
            let exp = LetAtom (v'', TyInt, AtomInt 0, exp) in
               ty, exp)

and make_var_defs_expr tenv venv defs cont =
   match defs with
      def :: defs ->
         make_var_def_expr tenv venv def (fun tenv venv _ ->
               make_var_defs_expr tenv venv defs cont)
    | [] ->
         let v' = new_symbol_string "make_var_defs" in
         let venv = venv_add venv v' TyInt in
         let ty, exp = cont tenv venv v' in
         let exp = LetAtom (v', TyInt, AtomInt 0, exp) in
            ty, exp

(*
 * Function declaration just modifies the var environment.
 *)
and make_fun_decl_expr tenv venv pos f ty_vars ty_res cont =
   let pos = string_pos "make_fun_decl_expr" pos in
   let ty_vars = List.map (make_type tenv) ty_vars in
   let ty_res = make_type tenv ty_res in
   let ty = TyFun (ty_vars, ty_res) in
   let _ =
      (* Check type of fun if it is already defined *)
      try
         let ty' = venv_lookup venv pos f in
            check_types tenv pos ty ty';
            ()
      with
         Not_found ->
            ()
   in
   let venv = venv_add venv f ty in

   (* Default value is 0 *)
   let v' = new_symbol_string "make_fun_decl" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
   let exp = LetAtom (v', TyInt, AtomInt 0, exp) in
      ty, exp

(*
 * Function definition.
 *)
and make_fun_def_expr tenv venv pos f vars ty_res body cont =
   (* Function type *)
   let pos = string_pos "make_fun_def_expr" pos in
   let vars = List.map (fun (v, ty, _) -> v, make_type tenv ty) vars in
   let ty_vars = List.map snd vars in
   let ty_res = make_type tenv ty_res in
   let ty_fun = TyFun (ty_vars, ty_res) in
   let venv = venv_add venv f ty_fun in

   (* Compile the body *)
   let body =
      let venv = venv_add venv return_sym ty_res in
      let venv = List.fold_left (fun venv (v, ty) -> venv_add venv v ty) venv vars in
      let ty_res', exp =
         make_expr tenv venv body (fun tenv venv v ->
               let ty_res' = venv_lookup venv (int_pos 1 pos) v in
                  ty_res', Return (AtomVar v))
      in
         check_types tenv (int_pos 2 pos) ty_res ty_res';
         exp
   in

   (*
    * Define the function.
    *)
   let v' = new_symbol_string "make_fun_def" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
   let exp =
      LetAtom (v', TyInt, AtomInt 0,
               LetFuns ([f, true, ty_fun, List.map fst vars, body], exp))
   in
      ty, exp

(*
 * Type definitions.
 *)
and make_type_defs_expr tenv venv types cont =
   let types = List.map (fun (v, ty, _) -> v, make_type tenv ty) types in
   let tenv = List.fold_left (fun tenv (v, ty) -> tenv_add tenv v ty) tenv types in
   let v' = new_symbol_string "make_type_defs" in
   let venv = venv_add venv v' TyInt in
   let ty, exp = cont tenv venv v' in
   let exp = LetTypes (types, LetAtom (v', TyInt, AtomInt 0, exp)) in
      ty, exp

(*
 * Produce the intermediate code.
 *)
and make_expr tenv venv e cont =
   match e with
      Fc_ast_type.CharExpr (c, _) ->
         make_char tenv venv c cont
    | Fc_ast_type.IntExpr (i, _) ->
         make_int tenv venv i cont
    | Fc_ast_type.FloatExpr (x, _) ->
         make_float tenv venv x cont
    | Fc_ast_type.StringExpr (s, _) ->
         make_string tenv venv s cont
    | Fc_ast_type.VarExpr (v, _) ->
         cont tenv venv v
    | Fc_ast_type.AddrOfExpr (e, pos) ->
         make_addr_of_expr tenv venv (atom_pos pos) e cont
    | Fc_ast_type.UnOpExpr (op, e, pos) ->
         make_unop_expr tenv venv (atom_pos pos) op e cont
    | Fc_ast_type.UArithExpr (op, e, pos) ->
         make_uarith_expr tenv venv (atom_pos pos) op e cont
    | Fc_ast_type.BoolOpExpr (op, e1, e2, pos) ->
         make_boolop_expr tenv venv (atom_pos pos) op e1 e2 cont
    | Fc_ast_type.BinOpExpr (op, e1, e2, pos) ->
         make_binop_expr tenv venv (atom_pos pos) op e1 e2 cont
    | Fc_ast_type.SubscriptExpr (e1, e2, pos) ->
         make_subscript_expr tenv venv (atom_pos pos) e1 e2 cont
    | Fc_ast_type.ProjectExpr (e, v, pos) ->
         make_project_expr tenv venv (atom_pos pos) e v cont
    | Fc_ast_type.ApplyExpr (f, args, pos) ->
         make_apply_expr tenv venv (atom_pos pos) f args cont
    | Fc_ast_type.AssignExpr (op, e1, e2, pos) ->
         make_assign_expr tenv venv (atom_pos pos) op e1 e2 cont
    | Fc_ast_type.IfExpr (e1, e2, e3, pos) ->
         make_if_expr tenv venv (atom_pos pos) e1 e2 e3 cont
    | Fc_ast_type.ForExpr (e1, e2, e3, e4, pos) ->
         make_for_expr tenv venv pos e1 e2 e3 e4 cont
    | Fc_ast_type.WhileExpr (e1, e2, pos) ->
         make_while_expr tenv venv (atom_pos pos) e1 e2 cont
    | Fc_ast_type.SeqExpr (el, pos) ->
         make_seq_expr tenv venv (atom_pos pos) el cont
    | Fc_ast_type.ReturnExpr (e, pos) ->
         make_return_expr tenv venv (atom_pos pos) e cont
    | Fc_ast_type.BreakExpr pos ->
         make_break_expr tenv venv (atom_pos pos) cont
    | Fc_ast_type.VarDefs (defs, _) ->
         make_var_defs_expr tenv venv defs cont
    | Fc_ast_type.FunDecl (f, ty_vars, ty_res, pos) ->
         make_fun_decl_expr tenv venv (atom_pos pos) f ty_vars ty_res cont
    | Fc_ast_type.FunDef (f, vars, ty_res, body, pos) ->
         make_fun_def_expr tenv venv (atom_pos pos) f vars ty_res body cont
    | Fc_ast_type.TypeDefs (types, _) ->
         make_type_defs_expr tenv venv types cont

and make_list_expr tenv venv el cont =
   let rec loop tenv venv vars = function
      e :: el ->
         make_expr tenv venv e (fun tenv venv v ->
               loop tenv venv (v :: vars) el)
    | [] ->
         cont tenv venv (List.rev vars)
   in
      loop tenv venv [] el

and make_expr_opt tenv venv e_opt cont =
   match e_opt with
      None ->
         cont tenv venv None
    | Some e ->
         make_expr tenv venv e (fun tenv venv v ->
               cont tenv venv (Some (AtomVar v)))

(*
 * Apply to a program.
 *)
let make_prog tenv venv el =
   let tenv_ref = ref tenv in
   let venv_ref = ref venv in
   let rec loop tenv venv vars = function
      e :: el ->
         make_expr tenv venv e (fun tenv venv v ->
               loop tenv venv (v :: vars) el)
    | [] ->
         tenv_ref := tenv;
         venv_ref := venv;
         TyInt, Return (AtomInt 0)
   in
   let ty, exp = loop tenv venv [] el in
      !tenv_ref, !venv_ref, ty, exp

(*
 * Real make_expr with default continuation.
 *)
let make_expr tenv venv e =
   let ref_tenv = ref tenv in
   let ref_venv = ref venv in
   let ty, exp =
      make_expr tenv venv e (fun tenv venv v ->
            let pos = Fc_ast_util.pos_of_expr e in
            let pos = string_pos "make_expr_global" (atom_pos pos) in
            let ty = venv_lookup venv pos v in
               ref_tenv := tenv;
               ref_venv := venv;
               ty, Return (AtomVar v))
   in
      !ref_tenv, !ref_venv, ty, exp

(*
 * -*-
 * Local Variables:
 * Caml-master: "compile"
 * End:
 * -*-
 *)