(* This is the old macro processor, gradually being cut down to something
 * saner and more manageable.
 *
 * It currently supports several special expansions including products and sums,
 * conversion of expressions to type expressions, constant folding,
 * val and foreach/val macros, and some weird specials including term generation
 * via Scheme, translation of expressions to strings for debugging, and some 
 * special code for managing tuples.
 **)

open Flx_ast
open Flx_mtypes2
open Flx_print
open Flx_exceptions
open Flx_constfld
open Flx_typing2
open Flx_util
open List

let mkstring sr x = 
  `EXPR_literal (sr, {Flx_literal.felix_type="string"; internal_value=x; 
   c_value="::std::string(" ^ Flx_string.c_quote_of_string x ^ ")" })

let dyphack (ls : ( 'a * string) list) : 'a =
  match ls with
  | [x,_] -> x
  | _ -> failwith "Dypgen parser failed"

exception Macro_return

let rec truthof x = match x with
  | `EXPR_typed_case (_,0,`TYP_unitsum 2) -> Some false
  | `EXPR_typed_case (_,1,`TYP_unitsum 2) -> Some true
  | `EXPR_likely (_,x) -> truthof x
  | `EXPR_unlikely (_,x) -> truthof x
  | `EXPR_not (_,x) -> 
    begin match truthof x with
    | Some true -> Some false
    | Some false -> Some true
    | None -> None
    end
  | _ -> None

(*
 There are no type macros: use typedef facility.
**)

type macro_t =
 | MVal of expr_t
 | MName of Flx_id.t

type macro_dfn_t = Flx_id.t * macro_t

let print_macros macros = 
  List.iter  (fun (id,x) -> print_endline (
   id ^ " = " ^ (match x with
   | MVal e -> string_of_expr e 
   | MName id -> id
   ) ^ ":"))
  macros

type macro_state_t = {
  recursion_limit: int;
  local_prefix: string;
  seq: int ref;
  reachable: bool ref;
  ref_macros: macro_dfn_t list ref;
  macros: macro_dfn_t list;
}

let get_macro_seq x = !(x.seq)

let string_of_statements sts =
  String.concat "\n" (List.map (string_of_statement 1) sts)

let scheme_eval s =
    let get_port = function
      | Ocs_types.Sport p -> p
      | _ -> failwith "expected port"
    in
    let env = Ocs_top.make_env () in
    let th = Ocs_top.make_thread () in
    let inp = Ocs_port.string_input_port s in
    let outp = get_port th.Ocs_types.th_stdout in
    let lex = Ocs_lex.make_lexer inp "" in
    let term = ref None in
    begin try
      match Ocs_read.read_expr lex with
      | Ocs_types.Seof -> print_endline "END OF FILE?"
      | v ->
         let c = Ocs_compile.compile env v in
         print_endline "COMPILED";
         Ocs_eval.eval th (function
           | Ocs_types.Sunspec -> print_endline "UNSPECIFIED"
           | r ->
             print_endline "EVALUATED";
             Ocs_print.print outp false r;
             Ocs_port.puts outp "\n";
             Ocs_port.flush outp;
             term := Some r
         ) c
    with
      | Ocs_error.Error err
      | Ocs_error.ErrorL (_,err)
      ->
        print_endline ("Error " ^ err)
    end
    ;
    match !term with
    | None -> failwith "Scheme term not returned!"
    | Some r ->
        let sex = Ocs2sex.ocs2sex r in
        print_endline "OCS scheme term converted to s-expression:";
        Sex_print.sex_print sex;
        sex

let upper =  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
let lower = "abcdefghijklmnopqrstuvwxyz"
let digits = "0123456789"

let idstart = upper ^ lower ^ "_"
let idmore = idstart ^ digits ^ "'"
let quotes =  "\"'`"

let starts_id ch = String.contains idstart ch
let continues_id ch = String.contains idmore ch
let is_quote ch = String.contains quotes ch

(* ident expansion: guarranteed to terminate,
  expansion of x given x -> x is just x
*)
let rec expand_ident sr macros noexpand id =
  try
    if List.mem id noexpand then id else
    match List.assoc id macros with
    | MName id2 -> expand_ident sr macros (id::noexpand) id2
    | _ -> id
  with Not_found -> id

(* Eliminates PAT_expr by replacing it with a variable and guard *)
let fix_pattern counter pat =
  let rec aux p = match p with
  | PAT_none _

  | PAT_literal _
  | PAT_range _

  | PAT_name _
  | PAT_any _
  | PAT_setform_any _
  | PAT_const_ctor _ 
  | PAT_const_variant _ 
    -> p

  | PAT_coercion (sr, p, t) -> PAT_coercion (sr, aux p, t)
  | PAT_tuple (sr,ps) -> PAT_tuple (sr,List.map aux ps)
  | PAT_tuple_cons (sr,a,b) -> PAT_tuple_cons (sr,aux a,aux b)
  | PAT_tuple_snoc (sr,a,b) -> PAT_tuple_snoc (sr,aux a,aux b)
  | PAT_nonconst_ctor (sr,qn,p) -> PAT_nonconst_ctor (sr,qn,aux p)
  | PAT_subtype (sr,typ,id) -> PAT_subtype (sr, typ, id)

  | PAT_ho_ctor (sr,qn,es,p) -> PAT_ho_ctor (sr,qn,es,aux p)
  | PAT_nonconst_variant (sr,s,p) -> PAT_nonconst_variant (sr,s,aux p)
  | PAT_as (sr,p,i) -> PAT_as (sr,aux p,i)
  | PAT_when (sr,p,e) -> PAT_when (sr,aux p,e)
  | PAT_with (sr,p,es) -> PAT_with (sr, aux p, es)
  | PAT_record (sr, ps) -> PAT_record (sr, List.map (fun (i,p) -> i,aux p) ps)
  | PAT_polyrecord (sr, ps,r) -> PAT_polyrecord (sr, List.map (fun (i,p) -> i,aux p) ps, r)

  | PAT_expr (sr,e) -> 
    let n = "_sypv_" ^ (string_of_int !counter) in 
    let v = `EXPR_name (sr,n,[]) in
    incr counter;
    let eq = `EXPR_name (sr,"==",[]) in
    let args = `EXPR_tuple (sr,[v;e]) in
    let test = `EXPR_apply (sr, (eq,args)) in
    PAT_when (sr,PAT_name (sr,n),test)

  | PAT_alt (sr,ps) ->  assert false
  in aux pat

(* Find variable names in patterns so as to protect them *)
let rec mac_get_pattern_vars pat =
  match pat with
  | PAT_name (_,v) -> [v]
  | PAT_as (_,p,v) -> v :: mac_get_pattern_vars p
  | PAT_when (_,p,_) -> mac_get_pattern_vars p
  | PAT_nonconst_ctor (_,_,p) -> mac_get_pattern_vars p
  | PAT_ho_ctor (_,_,_,p) -> mac_get_pattern_vars p
  | PAT_nonconst_variant (_,_,p) -> mac_get_pattern_vars p
  | PAT_tuple (_,ps) -> List.concat (List.map mac_get_pattern_vars ps)
  | PAT_tuple_cons (sr,a,b) -> mac_get_pattern_vars a @ mac_get_pattern_vars b
  | PAT_tuple_snoc (sr,a,b) -> mac_get_pattern_vars a @ mac_get_pattern_vars b
  | PAT_record (_,ps) -> List.concat(List.map mac_get_pattern_vars (List.map snd ps))
  | PAT_polyrecord (_,ps,r) -> r :: List.concat(List.map mac_get_pattern_vars (List.map snd ps))
  | PAT_with (_,p,asgns) -> List.map fst asgns @ mac_get_pattern_vars p
  | PAT_subtype (_,_,v) -> [v] 
  | PAT_alt _ -> assert false
  | _ -> []

(* cartesian product of two lists N x M is a single list of N x M pairs *)

let cart2j (join:'a ->'b -> 'c) (ps: 'a list) (qs:'b list) : 'c list =
  fold_left (fun acc a -> acc @ (map (fun b-> join a b) qs)) [] ps

let cart2 (ps: 'a list) (qs:'b list) : ('a * 'b) list =  
  cart2j (fun a b -> a,b) ps qs

type field_t = string * pattern_t
type record_t = field_t list
type field_pats = string * pattern_t list

(* let us suppose we have a list of record with all but the last
field to be added, and a list of field_pats to add to them 
Then for each pat, for each record we make a new record with
that field added.
*)

let add_fields_to_records (ps: field_pats) (rs: record_t list) =
  let field_name, pats = ps in
  concat (map (fun pat -> map (fun r -> (field_name,pat)::r) rs) pats)

(* to process a whole list, we just fold over it *)
let cartr (ps: field_pats list) : record_t list =
  fold_right add_fields_to_records  ps [[]]

type component_t = pattern_t
type tuple_t = component_t list
type component_pats = pattern_t list

let add_components_to_tuples (ps: component_pats) (rs: tuple_t list) =
  let pats = ps in
  concat (map (fun pat -> map (fun r -> (pat)::r) rs) pats)

let cartt (ps: component_pats list) : tuple_t list =
  fold_right add_components_to_tuples  ps [[]]

(* Eliminates PAT_alt by replacing match branches whose patterns contain alternatives
with multiple branches each selecting one alternative. Recursive so handles nested
alternatiives as well. Returns a list of patterns. Initially, apply to top level
pattern. Attach branch code to each pattern afterwards to get multiple branches.
*)

let expand_pattern_branches pes =
  let rec aux p = match p with
    | PAT_none _

    | PAT_literal _
    | PAT_range _

    | PAT_name _
    | PAT_any _
    | PAT_setform_any _
    | PAT_const_ctor _ 
    | PAT_const_variant _ 
    | PAT_expr _
    | PAT_subtype _
      -> [p]

    | PAT_coercion (sr, p, t) -> map (fun p-> PAT_coercion (sr, p, t)) (aux p)


    | PAT_tuple_cons (sr,a,b) ->  
      map (fun (a,b) -> PAT_tuple_cons (sr,a,b)) (cart2 (aux a) (aux b))

    | PAT_tuple_snoc (sr,a,b) ->  
      map (fun (a,b) -> PAT_tuple_snoc (sr,a,b)) (cart2 (aux a) (aux b))


    | PAT_nonconst_ctor (sr,qn,p) -> map (fun p->PAT_nonconst_ctor (sr,qn,p)) (aux p)
    | PAT_ho_ctor (sr,qn,es,p) -> map (fun p->PAT_ho_ctor (sr,qn,es,p)) (aux p)
    | PAT_nonconst_variant (sr,s,p) -> map (fun p->PAT_nonconst_variant (sr,s,p)) (aux p)
    | PAT_as (sr,p,i) -> map (fun p->PAT_as (sr,p,i)) (aux p)
    | PAT_when (sr,p,e) -> map (fun p-> PAT_when (sr,p,e)) (aux p)

    | PAT_with (sr,p, asgns) -> map (fun p-> PAT_with (sr,p,asgns)) (aux p)

    | PAT_tuple (sr,ps) -> 
      let pss = map aux ps in
      map (fun (p) -> PAT_tuple (sr, (p))) (cartt pss)

    | PAT_record (sr, ps) -> 
      let pss = map (fun (s,p) -> s,aux p) ps in
      map (fun rs -> PAT_record (sr, rs)) (cartr pss)

    | PAT_polyrecord (sr, ps,r) ->
      let pss = map (fun (s,p) -> s,aux p) ps in
      map (fun rs -> PAT_polyrecord (sr, rs, r)) (cartr pss)
   
    | PAT_alt (sr,ps) ->
      concat (map aux ps)

  in 
  let pss= map (fun (p,e) -> map (fun p ->p,e) (aux p)) pes in
  concat pss

  

let alpha_pat local_prefix seq fast_remap remap expand_expr pat = 
  let ren v = List.assoc v fast_remap in
  let rexp e = expand_expr 50 local_prefix seq remap e in 
  let rec aux pat = match pat with
  | PAT_name (sr,v) -> PAT_name (sr, ren v)
  | PAT_with (sr,p,es) ->
    let es = List.map (fun (s,e) -> ren s, rexp e) es in
    PAT_with (sr, aux p, es)
  | PAT_as (sr,p,v) -> PAT_as (sr,aux p, ren v)
  | PAT_when (sr,p,e) -> PAT_when (sr,aux p, rexp e)
  | PAT_nonconst_ctor (sr,n,p) -> PAT_nonconst_ctor (sr, n, aux p)
  | PAT_ho_ctor (sr,n,es,p) -> 
    let es = List.map rexp es in
    PAT_ho_ctor (sr, n, es, aux p)

  | PAT_nonconst_variant (sr,n,p) -> PAT_nonconst_variant (sr, n, aux p)
  | PAT_tuple (sr,ps) -> PAT_tuple (sr, List.map aux ps)
  | PAT_tuple_cons (sr,a,b) -> PAT_tuple_cons (sr, aux a, aux b)
  | PAT_tuple_snoc (sr,a,b) -> PAT_tuple_snoc (sr, aux a, aux b)
  | PAT_record (sr, ps) -> PAT_record (sr, List.map (fun (id,p) -> id, aux p) ps)
  | PAT_polyrecord (sr, ps, r) -> PAT_polyrecord (sr, List.map (fun (id,p) -> id, aux p) ps, ren r)
  | PAT_subtype (sr, t, id) -> PAT_subtype (sr,t, ren id)
  | p -> p
  in aux pat

(* protect parameter names, to prevent gratuitous substitions *)
let protect sr ps =
  let rec aux t macs =
    match t with
    | [] -> macs
    | h :: t ->
      let mac = h, MVal (`EXPR_noexpand (sr,`EXPR_name (sr,h,[]))) in
      aux t (mac::macs)
  in
    aux ps []

(* alpha convert parameter names *)
let rec alpha_expr sr local_prefix seq ps e =
  let psn, pst = List.split ps in
  let psn' =  (* new parameter names *)
    List.map begin fun _ ->
      let b = !seq in
      incr seq;
      Flx_id.of_string ("_eparam_"^local_prefix^"_" ^ string_of_int b)
    end psn
  in
  let remap =
    List.map2
    (fun x y -> (x,MName y))
    psn psn'
  in
    let e = expand_expr 50 local_prefix seq remap e in
    let ps = List.combine psn' pst in
    ps,e

and alpha_stmts sr local_prefix seq ps sts =
  let psn, pst = List.split ps in
  let psn' =  (* new parameter names *)
    List.map begin fun _ ->
      let b = !seq in
      incr seq;
      Flx_id.of_string ("_xparam_" ^ local_prefix ^ "_" ^ string_of_int b)
    end psn
  in
  let remap =
    List.map2
    (fun x y -> (x,MName y))
    psn psn'
  in
    let sts = subst_statements 500 local_prefix seq (ref true) remap sts in
    let ps = List.combine psn' pst in
    ps,sts

(* NOTE: this routine now ONLY replaces identifiers *)
and expand_type_expr sr recursion_limit local_prefix seq (macros:macro_dfn_t list) (t:typecode_t):typecode_t=
  if recursion_limit < 1
  then failwith "Recursion limit exceeded expanding macros";
  let recursion_limit = recursion_limit - 1 in
  let me e = expand_expr recursion_limit local_prefix seq macros e in
  let mt t : typecode_t = expand_type_expr sr recursion_limit local_prefix seq macros t in
  let mi sr i =
    let out = expand_ident sr macros [] i in
    out
  in
  match Flx_maps.map_type mt t with

(* FIXME??

  Expansion of macros in type expressions has to be disabled
  because by specification now, macro vals are expressions,
  not types. The syntax and AST forms are no longer unified.
 
  In particular the typecode_of_expr function is going
  to be deleted.


  (* Name expansion *)
  | `TYP_name (sr, name,[]) as t ->
    begin try
      match List.assoc name macros with
      | MVal b -> typecode_of_expr (me b)
      | MName _ -> `TYP_name (sr,mi sr name,[])
    with
    | Not_found -> t
    end
*)

  | `TYP_name (sr, name, ts) as t ->
    let ts = List.map mt ts in
    begin try
      match List.assoc name macros with
      | MName _ -> `TYP_name (sr,mi sr name,ts)
      | _ -> `TYP_name (sr,name,ts)
    with
    | Not_found -> t
    end

  | `TYP_typeof e -> `TYP_typeof (me e)

  | x -> x

(* expand expression *)
and expand_expr recursion_limit local_prefix seq (macros:macro_dfn_t list) (e:expr_t):expr_t =
  (*
  print_endline ("expand expr " ^ string_of_expr e);
  *)
  if recursion_limit < 1
  then failwith "Recursion limit exceeded expanding macros";
  let recursion_limit = recursion_limit - 1 in
  let me e = expand_expr recursion_limit local_prefix seq macros e in
  let mt sr e = expand_type_expr sr recursion_limit local_prefix seq macros e in
  let mi sr i =
    let out = expand_ident sr macros [] i in
    out
  in
  let cf e = const_fold e in
  let e = cf e in
  match e with
  (* This CAN happen: typecase is an ordinary expression
    with no meaning except as a proxy for a type, however
    at a macro level, it is an ordinary expression .. hmm
  *)
  | `EXPR_patvar _
  | `EXPR_patany _ -> print_endline "HACK.. AST_pat thing in expr"; e

  (* Expansion block: don't even fold constants *)
  | `EXPR_noexpand _ -> e
  | `EXPR_vsprintf _ -> e
  | `EXPR_interpolate _ -> e

  (* Name expansion *)
  | `EXPR_name (sr, name,[]) ->
    (*
    print_endline ("EXPANDING NAME " ^ name);
    *)
    let mac = try Some (List.assoc name macros) with Not_found -> None in
    begin match mac with
    | None -> e
    | Some mac -> match mac with
    | MVal b -> me b
    | MName _ -> `EXPR_name (sr,mi sr name,[])
    end

  | `EXPR_name (sr, name,ts) ->
    let ts = List.map (mt sr) ts in
    begin try
      match List.assoc name macros with
      | MName _ -> `EXPR_name (sr,mi sr name,ts)
      | _ -> `EXPR_name (sr,name,ts)
    with
    | Not_found -> e
    end


   (* builting function like things *)

   (* convert arbitrary expression to string for debugging
    * _str expr -> "expr"
    *)
  | `EXPR_apply (sr, (
      `EXPR_name (_,"range_check",[]),
      `EXPR_tuple (_,[e1;e2;e3])
    )) ->
    `EXPR_range_check (sr,me e1, me e2, me e3)

  | `EXPR_apply (sr,(`EXPR_name(_,"_str",[]),x)) ->
    let x = me x in
    let x = string_of_expr x in mkstring sr x

   (* artificially make singleton tuple 
    *   _tuple x 
    *)
  | `EXPR_apply (sr,(`EXPR_name(_,"_tuple",[]),x)) ->
    `EXPR_tuple (sr,[me x])

  (* _scheme string conversion to expression term *)
  | `EXPR_apply (sr,
      (`EXPR_name(srn,"_scheme", []),
      `EXPR_literal (srl, 
      {
        Flx_literal.felix_type=felix_type; 
        internal_value=s
      }))) -> 
    print_endline "DETECTED EXPR ENCODED AS SCHEME";
    let sex = scheme_eval s in
    let flx = Flx_sex2flx.xexpr_t sr sex in
    print_endline "s-expression converted to Felix!";
    print_endline (string_of_expr flx);
    flx

  (* general application *)
  | `EXPR_apply (sr, (e1, e2)) -> cf (`EXPR_apply (sr, (me e1, me e2)))

  (* optimise conditional with constant condition *)
  | `EXPR_cond (sr, (e1, e2, e3)) ->
    let cond = me e1 in
    begin match cond with
    | `EXPR_typed_case (_,c,`TYP_unitsum 2) ->
      if c=1 then me e2 else me e3
    | _ ->
      `EXPR_cond (sr,(cond,me e2,me e3))
    end

  | `EXPR_expr (sr,s,t,e) -> `EXPR_expr (sr,s,t,me e)

  (* Lambda hook *)
  | `EXPR_lambda (sr, (kind,vs,pss, t, sts)) ->
    let rec aux ps : string list =
      match ps with
      | Satom (sr,x,name,z,d)->[name] 
      | Slist ps -> List.concat (List.map aux ps)
    in
       
    let pr = List.concat (List.map (fun pc -> aux (fst pc)) pss) in
    let pr = protect sr pr in
    let sts =
      expand_statements recursion_limit local_prefix seq (ref true)
      (pr @ macros) sts
    in
    `EXPR_lambda (sr, (kind,vs,pss, t, sts))

  (* the name here is just for diagnostics *)
  | `EXPR_index (sr, n, i) -> `EXPR_index (sr,n,i)
  | `EXPR_intersect (sr, es) -> `EXPR_intersect (sr, List.map me es)
  | `EXPR_union (sr, es) -> `EXPR_union (sr, List.map me es)
  | `EXPR_isin (sr,(a,b)) -> `EXPR_isin (sr, (me a, me b))

  | `EXPR_get_tuple_tail (sr, e) -> `EXPR_get_tuple_tail (sr, me e)
  | `EXPR_get_tuple_head (sr, e) -> `EXPR_get_tuple_head (sr, me e)
  | `EXPR_get_tuple_body (sr, e) -> `EXPR_get_tuple_body (sr, me e)
  | `EXPR_get_tuple_last (sr, e) -> `EXPR_get_tuple_last (sr, me e)

  | `EXPR_lookup (sr, (e1, name,ts)) ->
      `EXPR_lookup (sr,(me e1, mi sr name, List.map (mt sr) ts))

  | `EXPR_case_tag (sr, i) -> e
  | `EXPR_typed_case (sr, i, t) ->`EXPR_typed_case (sr,i,mt sr t) 
  | `EXPR_projection (sr, i, t) -> `EXPR_projection (sr, i, mt sr t)
  | `EXPR_identity_function (sr, t) -> `EXPR_identity_function (sr, mt sr t)
  | `EXPR_array_projection (sr, e, t) -> `EXPR_array_projection (sr, me e, mt sr t)
  | `EXPR_ainj (sr, e, t) -> `EXPR_ainj (sr, me e, mt sr t)
  | `EXPR_rnprj (sr,name,seq,e) -> `EXPR_rnprj (sr,name,seq, me e)
  | `EXPR_case_index (sr,e) -> `EXPR_case_index (sr,me e)
  | `EXPR_rptsum_arg (sr,e) -> `EXPR_rptsum_arg (sr,me e)

  | `EXPR_tuple (sr, es) -> `EXPR_tuple (sr, List.map me es)
  | `EXPR_compacttuple (sr, es) -> `EXPR_compacttuple (sr, List.map me es)
  | `EXPR_tuple_cons (sr, eh, et) -> `EXPR_tuple_cons (sr, me eh, me et)
  | `EXPR_tuple_snoc (sr, eh, et) -> `EXPR_tuple_snoc (sr, me eh, me et)

  | `EXPR_record (sr, es) ->
    let all_blank = fold_left (fun acc (s,_) -> acc && s = "") true es in
    if all_blank then `EXPR_tuple (sr, List.map snd es) 
    else `EXPR_record (sr, List.map (fun (s,e)-> s, me e) es)

  | `EXPR_polyrecord (sr, es,e) ->
    `EXPR_polyrecord (sr, List.map (fun (s,e)-> s, me e) es, me e)

  | `EXPR_replace_fields (sr, e, es) ->
    `EXPR_replace_fields (sr, me e, List.map (fun (s,e) -> s, me e) es)

  | `EXPR_remove_fields (sr,e,ss) ->
    `EXPR_remove_fields (sr, me e, ss)

  | `EXPR_getall_field (sr,e,s) ->
    `EXPR_getall_field (sr, me e, s)
 
  | `EXPR_variant (sr, (s,e)) ->
    `EXPR_variant (sr, ( s, me e))

  | `EXPR_extension (sr, es,e) -> `EXPR_extension (sr, List.map me es, me e)

  | `EXPR_arrayof (sr, es) -> `EXPR_arrayof (sr, List.map me es)
  | `EXPR_coercion (sr, (e1, t)) -> `EXPR_coercion (sr, (me e1,mt sr t))
  | `EXPR_variant_subtype_match_coercion (sr, (e1, t)) -> `EXPR_variant_subtype_match_coercion (sr, (me e1,mt sr t))
  | `EXPR_suffix (sr, (qn, t)) ->
    let qn =
      match qualified_name_of_expr (me (expr_of_qualified_name qn)) with
      | Some x -> x
      | None -> assert false
    in
    `EXPR_suffix (sr, (qn,t))

  | `EXPR_callback (sr,qn) ->
    let qn =
      match qualified_name_of_expr (me (expr_of_qualified_name qn)) with
      | Some x -> x
      | None -> assert false
    in
    `EXPR_callback (sr, qn)

  | `EXPR_arrow (sr, (e1, e2)) ->  `EXPR_arrow (sr,(me e1, me e2))
  | `EXPR_effector (sr, (e1, e2, e3)) ->  `EXPR_effector (sr,(me e1, me e2, me e3))
  | `EXPR_longarrow (sr, (e1, e2)) ->  `EXPR_longarrow (sr,(me e1, me e2))
  | `EXPR_superscript (sr, (e1, e2)) ->  `EXPR_superscript (sr,(me e1, me e2))

  | `EXPR_literal (sr, literal) ->  e
  | `EXPR_map (sr, f, e) -> `EXPR_map (sr, me f, me e)
  | `EXPR_deref (sr, e1) -> `EXPR_deref (sr, me e1)
  | `EXPR_ref (sr, e1) ->  `EXPR_ref (sr, me e1)
  | `EXPR_rref (sr, e1) ->  `EXPR_rref (sr, me e1)
  | `EXPR_wref (sr, e1) ->  `EXPR_wref (sr, me e1)
  | `EXPR_uniq (sr, e1) ->  `EXPR_uniq (sr, me e1)
  | `EXPR_likely (sr, e1) ->  `EXPR_likely (sr, me e1)
  | `EXPR_unlikely (sr, e1) ->  `EXPR_unlikely (sr, me e1)
  | `EXPR_new (sr, e1) ->  `EXPR_new (sr, me e1)
  | `EXPR_match_ctor (sr, (qn, e1)) -> `EXPR_match_ctor (sr,(qn,me e1))
  | `EXPR_match_variant_subtype (sr, (e, t)) -> 
      `EXPR_match_variant_subtype (sr, (me e, mt sr t))

  | `EXPR_match_ho_ctor (sr, (qn, e1)) -> `EXPR_match_ho_ctor (sr,(qn,map me e1))
  | `EXPR_match_variant (sr, (s, e1)) -> `EXPR_match_variant (sr,(s,me e1))
  | `EXPR_match_case (sr, (i, e1)) ->  `EXPR_match_case (sr,(i, me e1))
  | `EXPR_ctor_arg (sr, (qn, e1)) -> `EXPR_ctor_arg (sr,(qn, me e1))
  | `EXPR_ho_ctor_arg (sr, (qn, e1)) -> `EXPR_ho_ctor_arg (sr,(qn, map me e1))
  | `EXPR_variant_arg (sr, (s, e1)) -> `EXPR_variant_arg (sr,(s, me e1))
  | `EXPR_case_arg (sr, (i, e1)) ->  `EXPR_case_arg (sr,(i,me e1))
  | `EXPR_letin (sr, (pat, e1, e2)) -> 
    let pes = [pat, e2] in
    let pes = expand_pattern_branches pes in
    let pes =
      List.map
      (fun (pat,e) ->
        let pat = fix_pattern seq pat in
        let pvs = mac_get_pattern_vars pat in
        let pvs' =  (* new parameter names *)
          List.map
          (fun s -> let b = !seq in incr seq; s^"_param_" ^ local_prefix ^ "_" ^ string_of_int b)
          pvs
        in
        let fast_remap = List.combine pvs pvs' in
        let remap = 
          List.map2
          (fun x y -> (x,MName y))
          pvs pvs'
        in
        (* alpha convert pattern variable names *)
        let pat' = alpha_pat local_prefix seq fast_remap (remap @ macros) expand_expr pat in
        (* let pr = protect sr pvs in *)
        let e' = expand_expr recursion_limit local_prefix seq (remap @ macros) e in
        pat',e'
      )
      pes
    in
    `EXPR_match (sr,(me e1, pes))


  | `EXPR_get_n (sr, (i, e1)) ->  `EXPR_get_n (sr,(i,me e1))
  | `EXPR_get_named_variable (sr, (i, e1)) ->  `EXPR_get_named_variable (sr,(i,me e1))
  | `EXPR_as (sr, (e1, id)) ->  `EXPR_as (sr,(me e1, mi sr id))
  | `EXPR_as_var (sr, (e1, id)) ->  `EXPR_as_var (sr,(me e1, mi sr id))

  | `EXPR_match (sr, (e1, pes)) ->
    let pes = expand_pattern_branches pes in
    let pes =
      List.map
      (fun (pat,e) ->
        let pat = fix_pattern seq pat in
        let pvs = mac_get_pattern_vars pat in
        let pvs' =  (* new parameter names *)
          List.map
          (fun s -> let b = !seq in incr seq; s^"_param_" ^ local_prefix ^ "_" ^ string_of_int b)
          pvs
        in
        let fast_remap = List.combine pvs pvs' in
        let remap = 
          List.map2
          (fun x y -> (x,MName y))
          pvs pvs'
        in
        (* alpha convert pattern variable names *)
        let pat' = alpha_pat local_prefix seq fast_remap (remap @ macros) expand_expr pat in
        (* let pr = protect sr pvs in *)
        let e' = expand_expr recursion_limit local_prefix seq (remap @ macros) e in
        pat',e'
      )
      pes
    in
    `EXPR_match (sr,(me e1, pes))

  | `EXPR_typecase_match (sr, (t,ps)) ->
    let ps = List.map (fun (t,e) -> mt sr t, me e) ps in
    `EXPR_typecase_match (sr,(mt sr t,ps))


  | `EXPR_range_check (sr, mi, v, mx) -> `EXPR_range_check (sr, me mi, me v, me mx)
  | `EXPR_not (sr,e) -> `EXPR_not (sr, me e)
  | `EXPR_label (sr,s) -> `EXPR_label (sr, mi sr s)

and rqmap me sr reqs =
  let r req = rqmap me sr req in
  match reqs with
  | RREQ_or (a,b) -> RREQ_or (r a, r b)
  | RREQ_and (RREQ_true,b) -> r b
  | RREQ_and (a,RREQ_true) -> r a
  | RREQ_and (a,b) -> RREQ_and (r a, r b)
  | RREQ_true -> RREQ_true
  | RREQ_false -> RREQ_false
  | RREQ_atom x ->
      match x with
      | Named_req qn ->
          let qn =
            match qualified_name_of_expr (me (expr_of_qualified_name qn)) with
            | Some x -> x
            | None -> assert false
          in
          RREQ_atom (Named_req qn)
      | Named_index_req s ->
        let x = me (`EXPR_name (sr,s,[])) in
(*
print_endline ("named req " ^ s ^ " expanded to " ^ string_of_expr x);
*)
        begin try
          match x with
          | `EXPR_literal (_,{Flx_literal.internal_value=v}) ->   
            let n = int_of_string v in
            RREQ_atom (Index_req n) 
          | _ -> raise Not_found
        with _ ->
        let err = "[Flx_reqs] rqmap: Named index requirement " ^ s ^ " not defined\n" ^
          "A macro with that name defined as an integer\n" ^
          "is required for the concordance which allows the compiler\n"  ^
          "to refer directly to symbols defined in the library\n"
        in 
          clierr sr err
        end


      | x -> RREQ_atom x

(* ---------------------------------------------------------------------
  do the common work of both subst_statement and expand_statement,
  recursion to the appropriate one as indicated by the argument 'recurse'

  The flag 'reachable' is set to false on exit if the instruction
  does not drop through. The flag may be true or false on entry.
  Whilst the flag is false, no code is generated. Once the flag
  is false, a label at the low level can cause subsequent code to become
  reachble.
*)

and subst_or_expand recurse recursion_limit local_prefix seq reachable macros (st:statement_t):statement_t list =
  (*
  print_endline ("Subst or expand: " ^ string_of_statement 0 st);
  *)
  (* NOTE: skips increment of recursion limit, only used unpacking if do elif .. chains *)
  let ms' reachable s = recurse recursion_limit local_prefix seq reachable macros s in
  let recursion_limit = recursion_limit - 1 in
  let mt sr e = expand_type_expr sr recursion_limit local_prefix seq macros e in
  let me e = expand_expr recursion_limit local_prefix seq macros e in
  let meopt e = match e with | None -> None | Some x -> Some (me x) in
  let mps sr ps =
     let rec aux ps = match ps with
     | Satom (sr,k,id,t,d) -> Satom (sr,k,id,mt sr t,meopt d)
     | Slist ps -> Slist (map aux ps)
     in
     aux ps 
  in
  let mpsp sr (ps,pre) = mps sr ps,meopt pre in
  let rqmap sr req = rqmap me sr req in
  let ms s = recurse recursion_limit local_prefix seq (ref true) macros s in
  let msp sr ps ss =
    let pr = protect sr ps in
    recurse recursion_limit local_prefix seq (ref true) (pr @ macros) ss
  in
  let mi sr id = expand_ident sr macros [] id in
  let mq qn =  match qn with
    | `AST_lookup (sr, (e1, name,ts)) ->
      `AST_lookup (sr,(me e1, mi sr name, List.map (mt sr) ts))
    | `AST_name (sr, name, ts) ->
      `AST_name (sr, mi sr name, List.map (mt sr) ts)
    | x -> x
  in
  let result = ref [] in
  let tack x = result := x :: !result in
  let ctack x = if !reachable then tack x in
  let cf e = const_fold e in

  begin match st with
  | STMT_static_assert (sr, typ) -> tack (STMT_static_assert (sr, mt sr typ))

  | STMT_virtual_type (sr, name) -> tack (STMT_virtual_type (sr, mi sr name))

  | STMT_circuit (sr,cs) -> tack st
    
  | STMT_try _ -> tack st
  | STMT_type_error _ -> tack st
  | STMT_type_assert _ -> tack st

  | STMT_endtry _ -> 
    reachable := true;
    tack st

  | STMT_catch (sr, s, t) -> 
    reachable := true;
    tack (STMT_catch (sr, s, mt sr t))

  | STMT_private (sr,st) ->
    List.iter (fun st -> tack (STMT_private (sr,st))) (ms [st])

  | STMT_seq (_,sts) ->
    List.iter tack (ms sts)

  | STMT_include (sr, s) -> tack st

  (* FIX TO SUPPORT IDENTIFIER RENAMING *)
  | STMT_open (sr, vs, qn) ->
    tack (STMT_open (sr, vs, mq qn))

  | STMT_inject_module (sr, vs, qn) -> 
    tack (STMT_inject_module (sr, vs, mq qn))

  (* FIX TO SUPPORT IDENTIFIER RENAMING *)
  | STMT_use (sr, id, qn) -> tack (STMT_use (sr,mi sr id,qn))

  | STMT_cassign (sr,l,r) -> tack (STMT_cassign (sr, me l, me r))
  | STMT_storeat (sr,l,r) -> tack (STMT_storeat (sr, me l, me r))

  | STMT_assign (sr,name,l,r) ->
    let l = match l with
      | `Expr (sr,e),t -> `Expr (sr,me e),t
      | l -> l
    in
    tack (STMT_assign (sr, name, l, me r))

  | STMT_comment _  ->  tack st

  | STMT_union (sr, id, vs, idts ) ->
    let idts = List.map (fun (id,v,vs,d,c) -> 
      id,v,vs,mt sr d, (match c with | None-> None | Some c -> Some (mt sr c))) 
      idts 
    in
    tack (STMT_union (sr, mi sr id, vs, idts))

  | STMT_struct (sr, id, vs, idts) ->
    let idts = List.map (fun (id,t) -> id,mt sr t) idts in
    tack (STMT_struct (sr, mi sr id, vs, idts))

  | STMT_cstruct (sr, id, vs, idts, reqs) ->
    let idts = List.map (fun (id,t) -> id,mt sr t) idts in
    tack (STMT_cstruct (sr, mi sr id, vs, idts, rqmap sr reqs))

  | STMT_typeclass (sr, id, vs, sts) ->
    tack (STMT_typeclass (sr, mi sr id, vs, ms sts))

  | STMT_begin_typeclass _ -> assert false

  | STMT_type_alias (sr, id, vs, t) ->
    tack (STMT_type_alias (sr,mi sr id,vs, mt sr t))

  | STMT_inherit (sr, id, vs, t) ->  tack st
  | STMT_inherit_fun (sr, id, vs, t) ->  tack st

  | STMT_ctypes (sr, ids, qs, reqs) ->
    List.iter
    (fun (sr,id) ->
      let id = mi sr id in
      let st = STMT_abs_decl (
        sr,
        id,
        dfltvs,
        qs,
        Flx_code_spec.Str ("::"^id),
        rqmap sr reqs)
      in
      tack st
    )
    ids

  | STMT_abs_decl (sr,id,vs,typs,v,rqs) ->
    tack (STMT_abs_decl (sr,mi sr id,vs,typs,v, rqmap sr rqs))

  | STMT_newtype (sr,id,vs,t) ->
    tack (STMT_newtype (sr,mi sr id,vs,mt sr t))

  | STMT_instance_type (sr,id,vs,t) ->
    tack (STMT_instance_type (sr,mi sr id,vs,mt sr t))

  | STMT_callback_decl (sr,id,args,ret,rqs) ->
    tack (STMT_callback_decl (sr,mi sr id, List.map (mt sr) args,mt sr ret,rqmap sr rqs))

  | STMT_const_decl (sr, id, vs, t, c, reqs) ->
     tack (STMT_const_decl (sr, mi sr id, vs, mt sr t, c, rqmap sr reqs))

  | STMT_fun_decl (sr, id, vs, ts, t, c, reqs,prec) ->
    tack (STMT_fun_decl (sr, mi sr id, vs, List.map (mt sr) ts, mt sr t, c, rqmap sr reqs,prec))

  | STMT_insert (sr, n, vs, s, ikind, reqs) ->
    tack (STMT_insert (sr,n,vs,s, ikind, rqmap sr reqs))

    (*
      NOTE: c code is embedded even  though it isn't
      reachable because it might contain declarations or
      even labels
    *)
  | STMT_code (sr, s, e) ->
    tack (STMT_code (sr,s,me e));
    reachable := true

  | STMT_noreturn_code (sr, s, e) ->
    tack (STMT_noreturn_code (sr,s,me e));
    reachable := false

  (* IDENTIFIER RENAMING NOT SUPPORTED IN EXPORT *)
  | STMT_export_python_fun (sr, sn, s) ->  tack st
  | STMT_export_fun (sr, sn, s) ->  tack st
  | STMT_export_cfun (sr, sn, s) ->  tack st
  | STMT_export_type (sr, sn, s) ->  tack st
  | STMT_export_struct (sr, s) ->  tack st
  | STMT_export_union (sr, sn, s) ->  tack st
  | STMT_export_requirement (sr,reqs) -> tack st
  | STMT_label (sr, id) ->
    reachable:=true;
    tack (STMT_label (sr, mi sr id))

  | STMT_goto (sr, id) ->
    ctack (STMT_goto (sr, mi sr id));
    reachable := false

  | STMT_cgoto (sr, e) ->
    ctack (STMT_cgoto (sr, me e));
    reachable := false

  | STMT_svc (sr, id) ->  ctack (STMT_svc (sr, mi sr id))
  | STMT_proc_return (sr)  ->  ctack st; reachable := false
  | STMT_proc_return_from (sr,s)  ->  ctack st; reachable := false
  | STMT_halt (sr,s)  ->  ctack st; reachable := false
  | STMT_trace (sr,v,s)  ->  ctack st
  | STMT_nop (sr, s) ->  ()

  | STMT_reduce (sr, id, reds) ->
    let reds = map (fun (vs, ps, e1, e2) -> 
      let ps = List.map (fun (s,t)-> s,mt sr t) ps in
      vs,ps,me e1, me e2)
    reds 
    in 
    tack(STMT_reduce (sr, mi sr id, reds))

  | STMT_axiom (sr, id, vs, psp, e1) ->
    let e1 = match e1 with
      | Predicate e -> Predicate (me e)
      | Equation (l,r) -> Equation (me l, me r)
    in
    tack(STMT_axiom (sr, mi sr id, vs, mpsp sr psp, e1))

  | STMT_lemma (sr, id, vs, psp, e1) ->
    let e1 = match e1 with
      | Predicate e -> Predicate (me e)
      | Equation (l,r) -> Equation (me l, me r)
    in
    tack(STMT_lemma (sr, mi sr id, vs, mpsp sr psp, e1))

  | STMT_function (sr, id, vs, psp, (t,post), effects, props, sts ) ->
    let rec aux ps : string list =
      match ps with
      | Satom (sr,x,name,z,d)->[name] 
      | Slist ps -> List.concat (List.map aux ps)
    in
    let pr = aux (fst psp) in       
    let post = meopt post in
    tack(STMT_function (sr, mi sr id, vs, mpsp sr psp, (mt sr t, post), mt sr effects, props, msp sr pr sts ))

  | STMT_curry (sr,id,vs,pss,(ret,post),effects,kind,adjs,sts) ->
    let rec aux ps : string list =
      match ps with
      | Satom (sr,x,name,z,d)->[name] 
      | Slist ps -> List.concat (List.map aux ps)
    in
       
    let pr = List.concat (List.map (fun pc -> aux (fst pc)) pss) in
    let post = match post with | None -> None | Some x -> Some (me x) in
    let pss = List.map (fun psp -> mpsp sr psp) pss in
    tack(STMT_curry(sr, mi sr id, vs, pss, (ret,post),effects,kind, adjs, msp sr pr sts ))

  | STMT_val_decl (sr, id, vs, optt, opte) ->
    let opte = match opte with
    | Some x -> Some (me x)
        (*
          this *will be* an error if unreachable,
          provided the containing function is used
        *)
    | None -> None
        (* this is actually a syntax error in a module,
          but not in an interface: unfortunately,
          we can't tell the difference here
        *)
    in
    let optt = match optt with
    | Some t -> Some (mt sr t)
    | None -> None
    in
      tack (STMT_val_decl (sr, mi sr id, vs, optt, opte))

  | STMT_once_decl (sr, id, vs, optt, opte) ->
    let opte = match opte with
    | Some x -> Some (me x)
        (*
          this *will be* an error if unreachable,
          provided the containing function is used
        *)
    | None -> None
        (* this is actually a syntax error in a module,
          but not in an interface: unfortunately,
          we can't tell the difference here
        *)
    in
    let optt = match optt with
    | Some t -> Some (mt sr t)
    | None -> None
    in
      tack (STMT_once_decl (sr, mi sr id, vs, optt, opte))


  | STMT_ref_decl (sr, id, vs, optt, opte) ->
    let opte = match opte with
    | Some x -> Some (me x)
        (*
          this *will be* an error if unreachable,
          provided the containing function is used
        *)
    | None -> None
        (* this is actually a syntax error in a module,
          but not in an interface: unfortunately,
          we can't tell the difference here
        *)
    in
    let optt = match optt with
    | Some t -> Some (mt sr t)
    | None -> None
    in
      tack (STMT_ref_decl (sr, mi sr id, vs, optt, opte))

  | STMT_lazy_decl (sr, id, vs, optt, opte) ->
    let opte = match opte with
    | Some x -> Some (me x)
        (*
          this *will be* an error if unreachable,
          provided the containing function is used
        *)
    | None -> None
        (* this is actually a syntax error in a module,
          but not in an interface: unfortunately,
          we can't tell the difference here
        *)
    in
    let optt = match optt with
    | Some t -> Some (mt sr t)
    | None -> None
    in
      tack (STMT_lazy_decl (sr, mi sr id, vs, optt, opte))

  | STMT_var_decl (sr, id, vs, optt, opte) ->
    let opte =
      match opte with
      | Some x -> Some (me x)
        (* unreachable var initialisations are legal *)

      | None -> None
        (* vars don't have to be initialised *)
    in
    let optt = match optt with
    | Some t -> Some (mt sr t)
    | None -> None
    in
      tack (STMT_var_decl (sr, mi sr id, vs, optt, opte))

  | STMT_untyped_module (sr, id, vs, sts) ->
    tack (STMT_untyped_module (sr, mi sr id, vs, ms sts))

  | STMT_library (sr, id, sts) ->
    tack (STMT_library (sr, mi sr id, ms sts))


  (* this gets called twice, pointlessly *)
  | STMT_stmt_match (sr, (e, pss)) ->
    (*
    print_endline "Handling statement match";
    *)
    (* as with other conditionals, it is possible to jump into the middle
     * of a branch, so even if the whole statement is unreachable,
     * some of the branch handling code may be if it contains a label.
     * The end of the statement is reachable if the end of any branch
     * is reachable.
     *
     * So, special handling: if the statement isn't reachable,
     * we can drop the matching entirely, and just emit the reachable
     * parts of each branch (from the first label). The inner call to subst_statements
     * should already have elided the unreachable heads of the branches.
     *)

    let start_reachable = !reachable in
    let case_end_reachable = ref false in
    let end_label = "_degen_stmt_match_end_" ^ local_prefix ^ "_" ^ string_of_int (let n = !seq in incr seq; n) in
    let pss = expand_pattern_branches pss in
    let pss = List.map (fun (pat,sts) ->
      let pat = fix_pattern seq pat in
      let pvs = mac_get_pattern_vars pat in
      let pvs' =  (* new parameter names *)
        List.map
        (fun s -> let b = !seq in incr seq; s^"_param_" ^ local_prefix ^ "_" ^ string_of_int b)
        pvs
      in
      let fast_remap = List.combine pvs pvs' in
      let remap = 
        List.map2
        (fun x y -> (x,MName y))
        pvs pvs'
      in
      (* alpha convert pattern variable names *)
      let pat' = alpha_pat local_prefix seq fast_remap remap expand_expr pat in
      (* alpha convert statements *)
      let branch_reachable = ref start_reachable in
      let sts' = subst_statements 50 local_prefix seq branch_reachable remap sts in
      case_end_reachable := !branch_reachable || !case_end_reachable;
      (*
      print_endline ("Statement match, original pattern: " ^ string_of_pattern pat);
      print_endline ("Statement match, original statements: " ^ string_of_statements sts);
      print_endline ("Statement match, new pattern: " ^ string_of_pattern pat');
      print_endline ("Statement match, new statements: " ^ string_of_statements sts');
      *)
      !branch_reachable, (pat', ms sts') (* no need for protection because pat vars are fresh *)
      )
      pss 
    in
    if start_reachable then
      tack (STMT_stmt_match (sr, (me e, List.map snd pss)))
    else begin
      List.iter (fun (r,(_,ss)) ->
        (List.iter tack ss);
        if r then tack (STMT_goto (sr,end_label))
      )
      pss
      ;
      if !case_end_reachable then tack (STMT_label (sr,end_label))
    end
    ;
    reachable := !case_end_reachable 
    
  | STMT_instance (sr, vs, qn, sts) ->
    tack (STMT_instance (sr, vs, mq qn, ms sts))

  | STMT_ifcgoto (sr, e1 , e2) ->
    let e1 = me e1 in
    let e1 = cf e1 in
    let e2 = me e2 in
    let e2 = cf e2 in
    begin match truthof e1 with
    | Some true ->
      ctack (STMT_cgoto (sr,e2));
      reachable := false

    | Some false -> ()
    | None ->
      ctack (STMT_ifcgoto (sr, e1, e2))
    end

  | STMT_ifgoto (sr, e , id) ->
    let e = me e in
    let e = cf e in
    begin match truthof e with
    | Some true ->
      ctack (STMT_goto (sr,mi sr id));
      reachable := false

    | Some false -> ()
    | None ->
      ctack (STMT_ifgoto (sr, e, mi sr id))
    end

  | STMT_init (sr,v,e) ->
    ctack (STMT_init (sr, mi sr v, me e))

  | STMT_assert (sr,e) ->
    let e = me e in
    begin match truthof e with
    | Some true -> () 
    (* check at run time: even if always fails, assert triggers only if control flows thru *)
    | _ -> 
      ctack (STMT_assert (sr,e))
    end

  | STMT_ifreturn (sr, e) ->
    let e = me e in
    begin match truthof e with
    | Some true ->
      ctack (STMT_proc_return sr);
      reachable := false
    | Some false -> ()
    | None ->
      let n = !seq in incr seq;
      let lab = "_ifret_" ^ local_prefix ^ "_" ^ string_of_int n in
      ctack (STMT_ifgoto (sr, `EXPR_not (sr,e) , lab));
      ctack (STMT_proc_return sr);
      ctack (STMT_label (sr,lab))
    end

  | STMT_invariant (sr, e) -> ctack (STMT_invariant (sr, me e))

  | STMT_ifdo (sr, e, sts1, sts2) ->
    let e = me e in
    let e = cf e in
    begin match truthof e with
    | Some true ->
      List.iter ctack (ms sts1)
    | Some false ->
      List.iter ctack (ms sts2)
    | None ->
      let n1 = !seq in incr seq;
      let n2 = !seq in incr seq;
      let lab1 = "_ifdoend_" ^ local_prefix ^ "_" ^ string_of_int n1 in
      let lab2 = "_ifdoelse_" ^ local_prefix ^ "_" ^ string_of_int n2 in
      (*
      print_endline ("Assigned labels " ^ lab1 ^ " and " ^ lab2);
      *)

      (* each branch has the initial reachability we start with.
         NOTE! Labels are allowed inside primitive conditionals!
         So even if the initial condition is 'unreachable',
         the end of a branch can still be reachable!!

         So we must tack, not ctack, the code of the inner
         compound statements, they're NOT blocks.

         BUT NOTE EXCEPTION IF THE EXPRESSION IS CONSTANT!
      *)
      begin match e with
      | `EXPR_not (_,e') ->
        ctack (STMT_ifgoto (sr, e', lab1))
      | _ ->
        ctack (STMT_ifgoto (sr, `EXPR_not (sr,e), lab1))
      end
      ;
      let r1 = ref !reachable in
      List.iter tack (ms' r1 sts1);
      if !r1 then tack (STMT_goto (sr,lab2));

      (* this is a ctack, because it can only be targetted by prior ifnotgoto *)
      ctack (STMT_label (sr,lab1));
      let r2 = ref !reachable in
      List.iter tack (ms' r2 sts2);
      if !r1 then tack (STMT_label (sr,lab2));
      reachable := !r1 || !r2
    end


  | STMT_call_with_trap (sr, e1, e2) ->
    ctack (STMT_call_with_trap (sr, me e1, me e2));

  | STMT_jump (sr, e1, e2) ->
    ctack (STMT_jump (sr, me e1, me e2));
    reachable := false

  | STMT_loop (sr, id, e2) ->
    ctack (STMT_loop (sr, mi sr id, me e2));
    reachable := false

  | STMT_fun_return (sr, e)  ->
    ctack (STMT_fun_return (sr, me e));
    reachable := false

  | STMT_yield (sr, e)  ->
    ctack (STMT_yield (sr, me e))

  | STMT_scheme_string _
  | STMT_call _
  | STMT_macro_forall _
  | STMT_macro_val _  -> assert false

  (*
  | st -> failwith ("[subst_or_expand] Unhandled case " ^ string_of_statement 0 st)
  *)
  end
  ;
  List.rev !result


(* ---------------------------------------------------------------------
  expand, without defining new macros
  this routine is used to replace parameters
  in statement macros with already expanded arguments
  prior to expansion, therefore neither the arguments
  nor context in which they're used need any expansion
*)
and subst_statement recursion_limit local_prefix seq reachable macros (st:statement_t):statement_t list =
  (*
  print_endline ("subst statement " ^ string_of_statement 0 st);
  print_endline ("Macro context length " ^ si (List.length macros));
  *)
  if recursion_limit < 1
  then failwith "Recursion limit exceeded expanding macros";
  let recursion_limit = recursion_limit - 1 in
  let me e = expand_expr recursion_limit local_prefix seq macros e in
  let ms ss = subst_statement recursion_limit local_prefix seq (ref true) macros ss in
  let mss ss = subst_statements recursion_limit local_prefix seq (ref true) macros ss in
  let mi sr id =
    let out = expand_ident sr macros [] id in
    out
  in
  let result = ref [] in
  let tack x = result := x :: !result in
  let ctack x = if !reachable then tack x in
  let cf e = const_fold e in

  begin match st with
  | STMT_macro_val (sr, ids, e) ->
    tack (STMT_macro_val (sr, List.map (mi sr) ids, me e))

  | STMT_macro_forall (sr,ids,e,sts) ->
    tack (STMT_macro_forall (sr, List.map (mi sr) ids,me e,mss sts))

  | STMT_call (sr, e1, e2) ->
    tack (STMT_call (sr, me e1, me e2))

  | st ->
    List.iter tack
    (
      subst_or_expand subst_statements recursion_limit local_prefix seq reachable macros st
    )
  end
  ;
  List.rev !result

and subst_statements recursion_limit local_prefix seq reachable macros (ss:statement_t list) =
  List.concat (List.map (subst_statement recursion_limit local_prefix seq reachable macros) ss)

(* ---------------------------------------------------------------------
  expand statement : process macros
*)
and expand_statement recursion_limit local_prefix seq reachable ref_macros macros (st:statement_t) =
  (*
  print_endline ("Expand statement " ^ string_of_statement 0 st);
  print_endline ("Macro context length " ^ si (List.length macros));
  *)
  if recursion_limit < 1
  then failwith "Recursion limit exceeded expanding macros";
  let recursion_limit = recursion_limit - 1 in
  let me e = expand_expr recursion_limit local_prefix seq (!ref_macros @ macros) e in
  let ms ss = expand_statements recursion_limit local_prefix seq (ref true) (!ref_macros @ macros) ss in
  let mi sr id =
    let out = expand_ident sr (!ref_macros @ macros) [] id  in
    out
  in
  let result = ref [] in
  let tack x = result := x :: !result in
  let ctack x = if !reachable then tack x in
  let rec expand_names sr (names:string list):string list =
    List.concat
    (
      List.map
      (fun name ->
        let name = mi sr name in
        let d =
          try Some (List.assoc name (!ref_macros @ macros))
          with Not_found -> None
        in
        match d with
        | Some (MName x) -> [x]
        | Some(_) -> [name] (* clierrx "[flx_desugar/flx_macro.ml:1291: E334] " sr "Name list required" *)
        | None -> [name]
      )
      names
    )
  in
  let rec expand_exprs sr (exprs: expr_t list):expr_t list =
    (*
    print_endline ("Expand exprs: [" ^ catmap ", " string_of_expr exprs ^ "]");
    *)
    List.concat
    (
      List.map
      (fun expr -> match expr with
      | `EXPR_name (sr',name,[]) ->
        print_endline ("Name " ^ name);
        let name = mi sr name in
        let d =
          try Some (List.assoc name (!ref_macros @ macros))
          with Not_found -> None
        in
        begin match d with
        | Some (MName x) ->
          expand_exprs sr [`EXPR_name(sr,x,[])]

        | Some(_) -> [expr]
        | None -> [expr]
        end

      | `EXPR_tuple (sr',xs) -> List.map me xs
      | x -> [me x]
      )
      exprs
    )
  in
  begin match st with
  | STMT_macro_val (sr, ids, e) ->
    let e = me e in
    let n = List.length ids in
    if n = 1 then
      ref_macros := (List.hd ids, MVal e) :: !ref_macros
    else begin
      let vs =
        match e with
        | `EXPR_tuple (_,ls) -> ls
        | _ -> clierrx "[flx_desugar/flx_macro.ml:1336: E335] " sr "Unpack non-tuple"
      in
      let m = List.length vs in
      if m <> n then
        clierrx "[flx_desugar/flx_macro.ml:1340: E336] " sr
        (
          "Tuple is wrong length, got " ^
          si n ^ " variables, only " ^
          si m ^ " values"
        )
      else
      let ides = List.combine ids vs in
      List.iter (fun (id,v) ->
        ref_macros := (id,MVal v) :: !ref_macros
      )
      ides
    end

  | STMT_macro_forall (sr, ids, e, sts) ->
    (*
    print_endline "Expanding forall";
    *)
    let e = me e in
    let vals = match e with
      | `EXPR_tuple (_,vals) -> vals
      | x -> [x]
    in
    List.iter (fun e ->
      let saved_macros = !ref_macros in
      begin
        let n = List.length ids in
        if n = 1 then begin
          (*
          print_endline ("Setting " ^ List.hd ids ^ " to " ^ string_of_expr e);
          *)
          ref_macros := (List.hd ids, MVal e) :: !ref_macros
        end else begin
          let vs =
            match e with
            | `EXPR_tuple (_,ls) -> ls
            | _ -> clierrx "[flx_desugar/flx_macro.ml:1376: E337] " sr ("Unpack non-tuple " ^ string_of_expr e)
          in
          let m = List.length vs in
          if m <> n then
            clierrx "[flx_desugar/flx_macro.ml:1380: E338] " sr
            (
              "Tuple is wrong length, got " ^
              si n ^ " variables, only " ^
              si m ^ " values"
            )
          else
          let ides = List.combine ids vs in
          List.iter (fun (id,v) ->
            (*
            print_endline ("Setting " ^ id ^ " to " ^ string_of_expr v);
            *)
            ref_macros := (id,MVal v) :: !ref_macros
          )
          ides
        end
      end
      ;
      List.iter tack (ms sts);
      ref_macros := saved_macros
    ) vals

  (* _scheme "(blah blah)" translates to an AST 
   * by compiling and evaluating the string argument as
   * scheme and then translating the resulting s-expression
   * into Felix using ocs2sex and then sex2flx, the same as 
   * the action code of a parse is handled.
   *)

  | STMT_call (sr,
      `EXPR_name(srn,"_scheme", []),
      `EXPR_literal (srl, {Flx_literal.felix_type="string"; internal_value=s})
    ) -> 
    print_endline "DETECTED STATEMENT ENCODED AS SCHEME";
    let sex = scheme_eval s in
    let flx = Flx_sex2flx.xstatement_t sr sex in
    print_endline "s-expression converted to Felix!";
    print_endline (string_of_statement 0 flx);
    ctack flx

  | STMT_call (sr, e1, e2) -> ctack (STMT_call (sr, me e1, me e2))

  | st ->
    List.iter tack
    (
      subst_or_expand expand_statements recursion_limit local_prefix seq reachable (!ref_macros @ macros) st
    )
  end
  ;
  List.rev !result

and expand_statements recursion_limit local_prefix seq reachable macros (ss:statement_t list) =
  let ref_macros = ref [] in
  List.rev
    (List.fold_left 
      (fun acc st ->
        let sts = expand_statement recursion_limit local_prefix seq reachable ref_macros macros st in
        List.fold_left (fun acc st -> st::acc) acc sts
      )
      []
      ss
    )
  
let expand_macros macro_state stmts =
  (* translate class X; ... into class X { ...  *)
  let rec grab stmts res =
    match stmts with
    | [] -> List.rev res,[]
    | STMT_begin_typeclass _ :: _ -> List.rev res, stmts
    | h :: t -> grab t (h :: res) 
  in
  let rec aux stmts res =
    match stmts with
    | [] -> List.rev res
    | STMT_begin_typeclass (sr,name,vs) :: stmts ->
      let nested,rest = grab stmts [] in
      aux rest (STMT_typeclass (sr,name,vs,nested) :: res)

    | h :: t ->
      aux t (h::res)
  in 
  let stmts = aux stmts [] in

  expand_statements
    macro_state.recursion_limit
    macro_state.local_prefix
    macro_state.seq
    macro_state.reachable
    macro_state.macros
    stmts


let make_macro_state ?(recursion_limit=5000) local_prefix seq =
  {
    recursion_limit = recursion_limit;
    local_prefix = local_prefix;
    seq = seq;
    reachable = ref true;
    ref_macros = ref [];
    macros = [];
  }