Commits

Paweł Wieczorek  committed a03c29f

Lang_MiniML_Transformations

  • Participants
  • Parent commits 2cd28f1
  • Branches 2014_03_16_cleaning

Comments (0)

Files changed (5)

File source/Languages/Lang_MiniML.mlpack

 TypeChecker
 Parser
 Lexer
-Transformation

File source/Languages/Lang_MiniML/Transformation.mlpack

-To_CWCPS

File source/Languages/Lang_MiniML/Transformation/To_CWCPS.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-(*********************************************************************************************************************
- * Transformation from MiniML to CWCPS
- *
- * See the Compiling With Contianutions book (Appel).
- ********************************************************************************************************************)
-
-open AST
-
-module CPS = Lang_CWCPS.AST
-
-(*********************************************************************************************************************
- * Context
- ********************************************************************************************************************)
-
-module Context = struct
-
-    (*-------------------------------------------------------------------------------------------
-     * Representation
-     *)
-
-    type t = int ref
-
-    let get_counter (counter) = counter
-
-    let create () : t = ref 0
-
-    (*-------------------------------------------------------------------------------------------
-     * Variable
-     *)
-
-    let get_next_identifier context prefix sufix = 
-        let counter = get_counter context in
-        let number  = Util.increment_ref counter in
-        Identifier ("_" ^ prefix ^ "var" ^ string_of_int number ^ sufix)
-
-    let get_next_variable context =
-        Variable (get_next_identifier context "" "")
-
-    let xget_next_variable context sufix =
-        Variable (get_next_identifier context "" ("_" ^ sufix))
-end
-
-
-type continuation = CPS.value_expression -> CPS.expression
-
-exception Not_implemented
-
-(*********************************************************************************************************************
- * Additional helpers
- ********************************************************************************************************************)
-
-let tail_cont_forwarder context cont = 
-    let retfun  = Context.xget_next_variable context "forwarder" in
-    let retvar  = Context.xget_next_variable context "retvar" in
-    let retbody = cont (CPS.VEXPR_Variable retvar) in
-    ((get_new_label (), retfun, [retvar], retbody), CPS.VEXPR_Variable retfun)
-
-(*********************************************************************************************************************
- * Transformation
- ********************************************************************************************************************)
-
-let transform_arithmetic_binary_operator = function
-    | AOP_ADD ->
-        CPS.PRIMOP_Add
-
-    | AOP_SUB ->
-        CPS.PRIMOP_Sub
-
-    | AOP_MUL ->
-        CPS.PRIMOP_Mul
-
-    | AOP_DIV ->
-        CPS.PRIMOP_Div
-
-    | AOP_MOD ->
-        CPS.PRIMOP_Mod
-
-let transform_arithmetic_unary_operator = function
-    | AOP_NEG ->
-        CPS.PRIMOP_Neg
-
-let transform_boolean_binary_operator = function
-    | BOP_AND ->
-        CPS.PRIMOP_And
-
-    | BOP_OR ->
-        CPS.PRIMOP_Or
-
-let transform_boolean_arithmetic_binary_operator = function
-    | BOP_LT ->
-        CPS.PRIMOP_LT
-
-    | BOP_LEQ ->
-        CPS.PRIMOP_LEQ
-
-    | BOP_EQ ->
-        CPS.PRIMOP_EQ
-
-    | BOP_GT ->
-        CPS.PRIMOP_GT
-
-    | BOP_GEQ ->
-        CPS.PRIMOP_GEQ
-
-    | BOP_NEQ ->
-        CPS.PRIMOP_NEQ
-
-let transform_boolean_unary_operator = function
-    | BOP_NOT ->
-        CPS.PRIMOP_Not
-
-(*------------------------------------------------------------------------------------------------
- * Transform expression
- *)
-
-let rec transform_expression (context : Context.t) (cont : continuation) = function
-    | EXPR_Lambda expr ->
-        transform_lambda_expression context cont expr
-
-    | EXPR_Arithmetic expr ->
-        transform_arithmetic_expression context cont expr
-
-    | EXPR_Boolean expr ->
-        transform_boolean_expression context cont expr
-
-    | EXPR_Control expr ->
-        transform_control_expression context cont expr
-
-    | EXPR_Store expr ->
-        transform_store_expression context cont expr
-
-(*------------------------------------------------------------------------------------------------
- * Various helpers.
- *)
-
-and transform_two_expressions_in_passing_order context cont expr1 expr2 =
-    let contval2 val1 = 
-        transform_expression context (fun val2 -> cont val1 val2) expr2
-        in
-    transform_expression context contval2 expr1
-
-(* Helper, to encode order of eager computation in one place *)
-and transform_two_expressions_in_correct_order context cont expr1 expr2 =
-    let cont' var2 var1 = cont var1 var2 in
-    transform_two_expressions_in_passing_order context cont' expr2 expr1
-
-and transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 = 
-    let subcont val1 val2 = 
-        let res    = Context.xget_next_variable context "arith" in
-        let branch = cont (CPS.VEXPR_Variable res) in
-        CPS.EXPR_ArithmeticBinaryPrimOp (get_new_label (), primop, val1, val2, res, branch)
-        in
-
-    transform_two_expressions_in_correct_order context subcont expr1 expr2
-
-and transform_arithprimop_a1_r1_b1_expression context cont primop expr1 = 
-    let subcont val1 = 
-        let res    = Context.xget_next_variable context "arith" in
-        let branch = cont (CPS.VEXPR_Variable res) in
-        CPS.EXPR_ArithmeticUnaryPrimOp (get_new_label (), primop, val1, res, branch)
-        in
-
-    transform_expression context subcont expr1
-
-and transform_condprimop_a2_r1_b1_expression context cont primop expr1 expr2 = 
-    let subcont val1 val2 = 
-        let (tailret, cont_val) = tail_cont_forwarder context cont in
-        let branch1 = CPS.EXPR_App (get_new_label (), cont_val, [CPS.VEXPR_Integer 1]) in
-        let branch2 = CPS.EXPR_App (get_new_label (), cont_val, [CPS.VEXPR_Integer 0]) in
-        let code    = CPS.EXPR_ConditionPrimOp (get_new_label (), primop, val1, val2, branch1, branch2) in
-        CPS.EXPR_Fix (get_new_label (), [tailret], code)
-        in
-
-    transform_two_expressions_in_correct_order context subcont expr1 expr2
-
-(* NOTE: see order of evaluation in MiniML_Eval *)
-and transform_application context cont fun_expr arg_expr = 
-    let subcont fun_val arg_val =
-        let (tailret, cont_val) = tail_cont_forwarder context cont in
-        let appcode = CPS.EXPR_App (get_new_label (), fun_val, [arg_val; cont_val]) in
-        CPS.EXPR_Fix (get_new_label(), [tailret], appcode)
-        in
-    transform_two_expressions_in_correct_order context subcont fun_expr arg_expr
-
-and transform_abstraction context (label, func_name, arg_var, body_expr) =
-    let contvar    = Context.xget_next_variable context "cont" in
-    let funcont rv = CPS.EXPR_App (get_new_label (), CPS.VEXPR_Variable contvar, [rv]) in
-    let body_cps   = transform_expression context funcont body_expr in
-    (get_new_label (), func_name, [arg_var; contvar], body_cps) 
-
-(*------------------------------------------------------------------------------------------------
- * Transform lambda expression
- *)
-
-and transform_lambda_expression context cont = function
-    | LEXPR_Variable (label, var) ->
-        cont (CPS.VEXPR_Variable var)
-
-    | LEXPR_App (label, fun_expr, arg_expr) ->
-        transform_application context cont fun_expr arg_expr
-
-    | LEXPR_Fun (label, argvar, body_expr) ->
-        let fname      = Context.xget_next_variable context "fun" in
-        let definition = transform_abstraction context (label, fname, argvar, body_expr) in
-        let rest       = cont (CPS.VEXPR_Variable fname) in
-        CPS.EXPR_Fix (get_new_label (), [definition], rest)
-
-    (* The expression:
-     *      let[label] v = e in expr
-     * is handled as:
-     *      (fun[label] v -> expr) e
-     *)
-    | LEXPR_Let (label, binded_var, def_expr, in_expr) ->
-        let fun_expr = EXPR_Lambda (LEXPR_Fun (label, binded_var, in_expr)) in
-        transform_application context cont fun_expr def_expr
-
-    | LEXPR_Rec (label, definitions, in_expr) ->
-        let transformed_definitions = List.map (transform_abstraction context) definitions in
-        let body = transform_expression context cont in_expr in
-        CPS.EXPR_Fix (get_new_label (), transformed_definitions, body)
-
-(*------------------------------------------------------------------------------------------------
- * Transform arithmetic expression
- *)
-
-and transform_arithmetic_expression context cont = function
-    | AEXPR_Constant (label, i) ->
-        cont (CPS.VEXPR_Integer i)
-
-    | AEXPR_BinaryOperator (label, operator, expr1, expr2) ->
-        let primop = transform_arithmetic_binary_operator operator in
-        transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 
-
-    | AEXPR_UnaryOperator (label, operator, expr1) ->
-        let primop = transform_arithmetic_unary_operator operator in
-        transform_arithprimop_a1_r1_b1_expression context cont primop expr1
-
-(*------------------------------------------------------------------------------------------------
- * Transform boolean expression
- *)
-
-and transform_boolean_expression context cont = function
-    | BEXPR_Constant (label, b) ->
-        cont (CPS.VEXPR_Integer (if b then 1 else 0))
-
-    | BEXPR_BinaryOperator (label, operator, expr1, expr2) ->
-        let primop = transform_boolean_binary_operator operator in
-        transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 
-
-    | BEXPR_UnaryOperator (label, operator, expr1) ->
-        let primop = transform_boolean_unary_operator operator in
-        transform_arithprimop_a1_r1_b1_expression context cont primop expr1
-
-    | BEXPR_ArithmeticBinaryOperator (label, operator, expr1, expr2) ->
-        let primop = transform_boolean_arithmetic_binary_operator operator in
-        transform_condprimop_a2_r1_b1_expression context cont primop expr1 expr2 
-
-(*------------------------------------------------------------------------------------------------
- * Transform control expression
- *)
-
-and transform_control_expression context cont = function
-    | CEXPR_Compose (label, expr1, expr2) ->
-        let subcont _ val2 = cont val2 in
-        transform_two_expressions_in_passing_order context subcont expr1 expr2
-
-    | CEXPR_Try _ ->
-        raise Not_implemented
-
-    | CEXPR_Throw _ ->
-        raise Not_implemented
-
-    | CEXPR_Unit _ ->
-        cont (CPS.VEXPR_Unit)
-
-    | CEXPR_If (label, cond_expr, then_expr, else_expr) ->
-        let (tailret, cont_val) = tail_cont_forwarder context cont in
-        let subcont res = CPS.EXPR_App (get_new_label (), cont_val, [res]) in
-
-        let then_branch = transform_expression context subcont then_expr in
-        let else_branch = transform_expression context subcont else_expr in
-
-        let condcont res = 
-            CPS.EXPR_Switch (get_new_label (), res, then_branch, [else_branch])
-            in
-
-        let body = transform_expression context condcont cond_expr in
-        CPS.EXPR_Fix (get_new_label (), [tailret], body)
-
-(*------------------------------------------------------------------------------------------------
- * Transform store expression
- *)
-
- and transform_store_expression context cont = function
-    | SEXPR_Ref _ ->
-        raise Not_implemented
-
-    | SEXPR_Deref _ ->
-        raise Not_implemented
-
-    | SEXPR_Assign _ ->
-        raise Not_implemented
-
-(*------------------------------------------------------------------------------------------------
- * Transform declaration
- *
- * NOT NEEDED !?
- *)
-
-(*------------------------------------------------------------------------------------------------
- * Transform program
- *
- * The program:
- *      let v1 = e1
- *      let v2 = e2
- *      ...
- *      let vn = en
- *
- *      let rec r1 x = b1
- *          ...
- *          and rn x = bn
- *
- *      let v1' = e1'
- *      let v2' = e2'
- *      ...
- *      let vn' = en'
- *
- *      let rec r1' x = b1'
- *          ...
- *          and rn' x = bn'
- *      ;;
- *      emain
- *
- * is handled as one expression:
- *      let v1 = e1
- *      in
- *      let v2 = e2
- i      in
- *      ...
- *      let vn = en
- *      in
- *      let rec r1 x = b1
- *          ...
- *          and rn x = bn
- *      in
- *      let v1' = e1'
- *      in
- *      ...
- *      let vn' = en'
- *      in
- *      let rec r1' x = b1'
- *          ...
- *          and rn' x = bn'
- *      in
- *      emain
- *)
-
-let rec build_main_expression emain = function
-    | DECL_Let (label, name, bind_expr) :: rest ->
-        let in_expr = build_main_expression emain rest in
-        EXPR_Lambda (LEXPR_Let (label, name, bind_expr, in_expr))
-
-    | DECL_Rec (label, definitions) :: rest ->
-        let in_expr = build_main_expression emain rest in
-        EXPR_Lambda (LEXPR_Rec (label, definitions, in_expr))
-
-    | [] ->
-        emain
-
-(*
-test :-)
-
-let rec build_main_expression emain _ =
-    let fbody = EXPR_Arithmetic (AEXPR_Constant (get_new_label (), 42)) in
-    let f     = EXPR_Lambda (LEXPR_Fun (get_new_label (), make_variable "x", fbody)) in
-    let a = EXPR_Arithmetic (AEXPR_Constant (get_new_label (), 43)) in
-    EXPR_Lambda (LEXPR_App (get_new_label (), fbody, a))
-*)
-
-let transform_program = function
-    | PROGRAM (declarations, main_expr) ->
-        let kexit = CPS.VEXPR_TopContinuation in
-        let main_expression = build_main_expression main_expr declarations in
-        let context = Context.create () in
-        let cont ret = CPS.EXPR_App (get_new_label (),  kexit,  [ret]) in
-        (main_expression, transform_expression context cont main_expression)
-

File source/Languages/Lang_MiniML_Transformations.mlpack

+To_CWCPS

File source/Languages/Lang_MiniML_Transformations/To_CWCPS.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+(*********************************************************************************************************************
+ * Transformation from MiniML to CWCPS
+ *
+ * See the Compiling With Contianutions book (Appel).
+ ********************************************************************************************************************)
+
+open AST
+
+module CPS = Lang_CWCPS.AST
+
+(*********************************************************************************************************************
+ * Context
+ ********************************************************************************************************************)
+
+module Context = struct
+
+    (*-------------------------------------------------------------------------------------------
+     * Representation
+     *)
+
+    type t = int ref
+
+    let get_counter (counter) = counter
+
+    let create () : t = ref 0
+
+    (*-------------------------------------------------------------------------------------------
+     * Variable
+     *)
+
+    let get_next_identifier context prefix sufix = 
+        let counter = get_counter context in
+        let number  = Util.increment_ref counter in
+        Identifier ("_" ^ prefix ^ "var" ^ string_of_int number ^ sufix)
+
+    let get_next_variable context =
+        Variable (get_next_identifier context "" "")
+
+    let xget_next_variable context sufix =
+        Variable (get_next_identifier context "" ("_" ^ sufix))
+end
+
+
+type continuation = CPS.value_expression -> CPS.expression
+
+exception Not_implemented
+
+(*********************************************************************************************************************
+ * Additional helpers
+ ********************************************************************************************************************)
+
+let tail_cont_forwarder context cont = 
+    let retfun  = Context.xget_next_variable context "forwarder" in
+    let retvar  = Context.xget_next_variable context "retvar" in
+    let retbody = cont (CPS.VEXPR_Variable retvar) in
+    ((get_new_label (), retfun, [retvar], retbody), CPS.VEXPR_Variable retfun)
+
+(*********************************************************************************************************************
+ * Transformation
+ ********************************************************************************************************************)
+
+let transform_arithmetic_binary_operator = function
+    | AOP_ADD ->
+        CPS.PRIMOP_Add
+
+    | AOP_SUB ->
+        CPS.PRIMOP_Sub
+
+    | AOP_MUL ->
+        CPS.PRIMOP_Mul
+
+    | AOP_DIV ->
+        CPS.PRIMOP_Div
+
+    | AOP_MOD ->
+        CPS.PRIMOP_Mod
+
+let transform_arithmetic_unary_operator = function
+    | AOP_NEG ->
+        CPS.PRIMOP_Neg
+
+let transform_boolean_binary_operator = function
+    | BOP_AND ->
+        CPS.PRIMOP_And
+
+    | BOP_OR ->
+        CPS.PRIMOP_Or
+
+let transform_boolean_arithmetic_binary_operator = function
+    | BOP_LT ->
+        CPS.PRIMOP_LT
+
+    | BOP_LEQ ->
+        CPS.PRIMOP_LEQ
+
+    | BOP_EQ ->
+        CPS.PRIMOP_EQ
+
+    | BOP_GT ->
+        CPS.PRIMOP_GT
+
+    | BOP_GEQ ->
+        CPS.PRIMOP_GEQ
+
+    | BOP_NEQ ->
+        CPS.PRIMOP_NEQ
+
+let transform_boolean_unary_operator = function
+    | BOP_NOT ->
+        CPS.PRIMOP_Not
+
+(*------------------------------------------------------------------------------------------------
+ * Transform expression
+ *)
+
+let rec transform_expression (context : Context.t) (cont : continuation) = function
+    | EXPR_Lambda expr ->
+        transform_lambda_expression context cont expr
+
+    | EXPR_Arithmetic expr ->
+        transform_arithmetic_expression context cont expr
+
+    | EXPR_Boolean expr ->
+        transform_boolean_expression context cont expr
+
+    | EXPR_Control expr ->
+        transform_control_expression context cont expr
+
+    | EXPR_Store expr ->
+        transform_store_expression context cont expr
+
+(*------------------------------------------------------------------------------------------------
+ * Various helpers.
+ *)
+
+and transform_two_expressions_in_passing_order context cont expr1 expr2 =
+    let contval2 val1 = 
+        transform_expression context (fun val2 -> cont val1 val2) expr2
+        in
+    transform_expression context contval2 expr1
+
+(* Helper, to encode order of eager computation in one place *)
+and transform_two_expressions_in_correct_order context cont expr1 expr2 =
+    let cont' var2 var1 = cont var1 var2 in
+    transform_two_expressions_in_passing_order context cont' expr2 expr1
+
+and transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 = 
+    let subcont val1 val2 = 
+        let res    = Context.xget_next_variable context "arith" in
+        let branch = cont (CPS.VEXPR_Variable res) in
+        CPS.EXPR_ArithmeticBinaryPrimOp (get_new_label (), primop, val1, val2, res, branch)
+        in
+
+    transform_two_expressions_in_correct_order context subcont expr1 expr2
+
+and transform_arithprimop_a1_r1_b1_expression context cont primop expr1 = 
+    let subcont val1 = 
+        let res    = Context.xget_next_variable context "arith" in
+        let branch = cont (CPS.VEXPR_Variable res) in
+        CPS.EXPR_ArithmeticUnaryPrimOp (get_new_label (), primop, val1, res, branch)
+        in
+
+    transform_expression context subcont expr1
+
+and transform_condprimop_a2_r1_b1_expression context cont primop expr1 expr2 = 
+    let subcont val1 val2 = 
+        let (tailret, cont_val) = tail_cont_forwarder context cont in
+        let branch1 = CPS.EXPR_App (get_new_label (), cont_val, [CPS.VEXPR_Integer 1]) in
+        let branch2 = CPS.EXPR_App (get_new_label (), cont_val, [CPS.VEXPR_Integer 0]) in
+        let code    = CPS.EXPR_ConditionPrimOp (get_new_label (), primop, val1, val2, branch1, branch2) in
+        CPS.EXPR_Fix (get_new_label (), [tailret], code)
+        in
+
+    transform_two_expressions_in_correct_order context subcont expr1 expr2
+
+(* NOTE: see order of evaluation in MiniML_Eval *)
+and transform_application context cont fun_expr arg_expr = 
+    let subcont fun_val arg_val =
+        let (tailret, cont_val) = tail_cont_forwarder context cont in
+        let appcode = CPS.EXPR_App (get_new_label (), fun_val, [arg_val; cont_val]) in
+        CPS.EXPR_Fix (get_new_label(), [tailret], appcode)
+        in
+    transform_two_expressions_in_correct_order context subcont fun_expr arg_expr
+
+and transform_abstraction context (label, func_name, arg_var, body_expr) =
+    let contvar    = Context.xget_next_variable context "cont" in
+    let funcont rv = CPS.EXPR_App (get_new_label (), CPS.VEXPR_Variable contvar, [rv]) in
+    let body_cps   = transform_expression context funcont body_expr in
+    (get_new_label (), func_name, [arg_var; contvar], body_cps) 
+
+(*------------------------------------------------------------------------------------------------
+ * Transform lambda expression
+ *)
+
+and transform_lambda_expression context cont = function
+    | LEXPR_Variable (label, var) ->
+        cont (CPS.VEXPR_Variable var)
+
+    | LEXPR_App (label, fun_expr, arg_expr) ->
+        transform_application context cont fun_expr arg_expr
+
+    | LEXPR_Fun (label, argvar, body_expr) ->
+        let fname      = Context.xget_next_variable context "fun" in
+        let definition = transform_abstraction context (label, fname, argvar, body_expr) in
+        let rest       = cont (CPS.VEXPR_Variable fname) in
+        CPS.EXPR_Fix (get_new_label (), [definition], rest)
+
+    (* The expression:
+     *      let[label] v = e in expr
+     * is handled as:
+     *      (fun[label] v -> expr) e
+     *)
+    | LEXPR_Let (label, binded_var, def_expr, in_expr) ->
+        let fun_expr = EXPR_Lambda (LEXPR_Fun (label, binded_var, in_expr)) in
+        transform_application context cont fun_expr def_expr
+
+    | LEXPR_Rec (label, definitions, in_expr) ->
+        let transformed_definitions = List.map (transform_abstraction context) definitions in
+        let body = transform_expression context cont in_expr in
+        CPS.EXPR_Fix (get_new_label (), transformed_definitions, body)
+
+(*------------------------------------------------------------------------------------------------
+ * Transform arithmetic expression
+ *)
+
+and transform_arithmetic_expression context cont = function
+    | AEXPR_Constant (label, i) ->
+        cont (CPS.VEXPR_Integer i)
+
+    | AEXPR_BinaryOperator (label, operator, expr1, expr2) ->
+        let primop = transform_arithmetic_binary_operator operator in
+        transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 
+
+    | AEXPR_UnaryOperator (label, operator, expr1) ->
+        let primop = transform_arithmetic_unary_operator operator in
+        transform_arithprimop_a1_r1_b1_expression context cont primop expr1
+
+(*------------------------------------------------------------------------------------------------
+ * Transform boolean expression
+ *)
+
+and transform_boolean_expression context cont = function
+    | BEXPR_Constant (label, b) ->
+        cont (CPS.VEXPR_Integer (if b then 1 else 0))
+
+    | BEXPR_BinaryOperator (label, operator, expr1, expr2) ->
+        let primop = transform_boolean_binary_operator operator in
+        transform_arithprimop_a2_r1_b1_expression context cont primop expr1 expr2 
+
+    | BEXPR_UnaryOperator (label, operator, expr1) ->
+        let primop = transform_boolean_unary_operator operator in
+        transform_arithprimop_a1_r1_b1_expression context cont primop expr1
+
+    | BEXPR_ArithmeticBinaryOperator (label, operator, expr1, expr2) ->
+        let primop = transform_boolean_arithmetic_binary_operator operator in
+        transform_condprimop_a2_r1_b1_expression context cont primop expr1 expr2 
+
+(*------------------------------------------------------------------------------------------------
+ * Transform control expression
+ *)
+
+and transform_control_expression context cont = function
+    | CEXPR_Compose (label, expr1, expr2) ->
+        let subcont _ val2 = cont val2 in
+        transform_two_expressions_in_passing_order context subcont expr1 expr2
+
+    | CEXPR_Try _ ->
+        raise Not_implemented
+
+    | CEXPR_Throw _ ->
+        raise Not_implemented
+
+    | CEXPR_Unit _ ->
+        cont (CPS.VEXPR_Unit)
+
+    | CEXPR_If (label, cond_expr, then_expr, else_expr) ->
+        let (tailret, cont_val) = tail_cont_forwarder context cont in
+        let subcont res = CPS.EXPR_App (get_new_label (), cont_val, [res]) in
+
+        let then_branch = transform_expression context subcont then_expr in
+        let else_branch = transform_expression context subcont else_expr in
+
+        let condcont res = 
+            CPS.EXPR_Switch (get_new_label (), res, then_branch, [else_branch])
+            in
+
+        let body = transform_expression context condcont cond_expr in
+        CPS.EXPR_Fix (get_new_label (), [tailret], body)
+
+(*------------------------------------------------------------------------------------------------
+ * Transform store expression
+ *)
+
+ and transform_store_expression context cont = function
+    | SEXPR_Ref _ ->
+        raise Not_implemented
+
+    | SEXPR_Deref _ ->
+        raise Not_implemented
+
+    | SEXPR_Assign _ ->
+        raise Not_implemented
+
+(*------------------------------------------------------------------------------------------------
+ * Transform declaration
+ *
+ * NOT NEEDED !?
+ *)
+
+(*------------------------------------------------------------------------------------------------
+ * Transform program
+ *
+ * The program:
+ *      let v1 = e1
+ *      let v2 = e2
+ *      ...
+ *      let vn = en
+ *
+ *      let rec r1 x = b1
+ *          ...
+ *          and rn x = bn
+ *
+ *      let v1' = e1'
+ *      let v2' = e2'
+ *      ...
+ *      let vn' = en'
+ *
+ *      let rec r1' x = b1'
+ *          ...
+ *          and rn' x = bn'
+ *      ;;
+ *      emain
+ *
+ * is handled as one expression:
+ *      let v1 = e1
+ *      in
+ *      let v2 = e2
+ i      in
+ *      ...
+ *      let vn = en
+ *      in
+ *      let rec r1 x = b1
+ *          ...
+ *          and rn x = bn
+ *      in
+ *      let v1' = e1'
+ *      in
+ *      ...
+ *      let vn' = en'
+ *      in
+ *      let rec r1' x = b1'
+ *          ...
+ *          and rn' x = bn'
+ *      in
+ *      emain
+ *)
+
+let rec build_main_expression emain = function
+    | DECL_Let (label, name, bind_expr) :: rest ->
+        let in_expr = build_main_expression emain rest in
+        EXPR_Lambda (LEXPR_Let (label, name, bind_expr, in_expr))
+
+    | DECL_Rec (label, definitions) :: rest ->
+        let in_expr = build_main_expression emain rest in
+        EXPR_Lambda (LEXPR_Rec (label, definitions, in_expr))
+
+    | [] ->
+        emain
+
+(*
+test :-)
+
+let rec build_main_expression emain _ =
+    let fbody = EXPR_Arithmetic (AEXPR_Constant (get_new_label (), 42)) in
+    let f     = EXPR_Lambda (LEXPR_Fun (get_new_label (), make_variable "x", fbody)) in
+    let a = EXPR_Arithmetic (AEXPR_Constant (get_new_label (), 43)) in
+    EXPR_Lambda (LEXPR_App (get_new_label (), fbody, a))
+*)
+
+let transform_program = function
+    | PROGRAM (declarations, main_expr) ->
+        let kexit = CPS.VEXPR_TopContinuation in
+        let main_expression = build_main_expression main_expr declarations in
+        let context = Context.create () in
+        let cont ret = CPS.EXPR_App (get_new_label (),  kexit,  [ret]) in
+        (main_expression, transform_expression context cont main_expression)
+