Commits

Paweł Wieczorek committed db93072

merge

Comments (0)

Files changed (68)

source/Languages/CWCPS/Lang_CWCPS.mlpack

-AST
-Eval
-PrettyPrinter
-Helper
-AnalysisFramework
-Parser
-Lexer
-TransformationFramework

source/Languages/CWCPS/Lang_CWCPS/AST.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-include Lang_Common.AST
-open Batteries
-open Lang_Common.Enumerators
-
-(*********************************************************************************************************************
- * Abstract Syntax Tree
- ********************************************************************************************************************)
-
-type arithmetic_binary_primitive_operation
-    = PRIMOP_Add
-    | PRIMOP_Sub
-    | PRIMOP_Mul
-    | PRIMOP_Div
-    | PRIMOP_Mod
-    | PRIMOP_And
-    | PRIMOP_Or
-    | PRIMOP_Xor
-
-type arithmetic_unary_primitive_operation
-    = PRIMOP_Not
-    | PRIMOP_Neg
-
-type condition_primitive_operation
-    = PRIMOP_LT
-    | PRIMOP_LEQ
-    | PRIMOP_EQ
-    | PRIMOP_GT
-    | PRIMOP_GEQ
-    | PRIMOP_NEQ
-
-type value_expression
-    = VEXPR_Integer of int
-    | VEXPR_Unit
-    | VEXPR_Variable of variable
-    | VEXPR_TopContinuation
-
-type access_path
-    = OFFp of int
-    | SELp of int * access_path
-
-type record_field = value_expression * access_path
-
-type expression
-    = EXPR_App
-        of label * value_expression * value_expression list
-
-    | EXPR_Fix
-        of label * (label * variable * variable list * expression) list * expression
-
-    | EXPR_ArithmeticBinaryPrimOp
-        of label * arithmetic_binary_primitive_operation * value_expression * value_expression * variable * expression
-
-    | EXPR_ArithmeticUnaryPrimOp
-        of label * arithmetic_unary_primitive_operation * value_expression * variable * expression
-
-    | EXPR_ConditionPrimOp
-        of label * condition_primitive_operation * value_expression * value_expression * expression * expression
-
-    | EXPR_Switch
-        of label * value_expression * expression * expression list
-
-    | EXPR_Record
-        of label * record_field list * variable * expression
-
-    | EXPR_Offset
-        of label * int * value_expression * variable * expression
-
-    | EXPR_Select
-        of label * int * value_expression * variable * expression
-
-type declaration
-    = DECL_Fix of label * (label * variable * variable list * expression) list
-
-type program
-    = PROGRAM of declaration list
-
-(*********************************************************************************************************************
- * Get Label
- ********************************************************************************************************************)
-
-let get_label_from_expression = function
-    | EXPR_App (label, first_expression, second_expression) -> label
-    | EXPR_Fix (label, definitions, expression) -> label
-    | EXPR_ArithmeticBinaryPrimOp (label, _, _, _, _, _) -> label
-    | EXPR_ArithmeticUnaryPrimOp (label, _, _, _, _) -> label
-    | EXPR_ConditionPrimOp (label, _, _, _, _, _) -> label
-    | EXPR_Switch (label, _, _, _) -> label
-    | EXPR_Offset (label, _, _, _, _) -> label
-    | EXPR_Select (label, _, _, _, _) -> label
-    | EXPR_Record (label, _, _, _) -> label
-
-let get_label_from_declaration = function
-    | DECL_Fix (label, declarations)  -> label
-
-let eval_arithmetic_binary_primitive_operation = function
-    | PRIMOP_Add -> (+)
-    | PRIMOP_Sub -> (-)
-    | PRIMOP_Mul -> (fun a b -> a * b)
-    | PRIMOP_Div -> (/)
-    | PRIMOP_Mod -> (mod)
-    | PRIMOP_And -> (land)
-    | PRIMOP_Or  -> (lor)
-    | PRIMOP_Xor -> (lxor)
-
-let eval_arithmetic_unary_primitive_operation = function
-    | PRIMOP_Not -> (lnot)
-    | PRIMOP_Neg -> (fun a -> (-a))
-
-let eval_condition_primitive_operation = function
-    | PRIMOP_LT -> (<)
-    | PRIMOP_LEQ -> (<=)
-    | PRIMOP_EQ -> (=)
-    | PRIMOP_GT -> (>)
-    | PRIMOP_GEQ -> (>=)
-    | PRIMOP_NEQ -> (fun a b -> not (a = b))
-
-let is_variable = function
-    | VEXPR_Variable _ -> true
-    | _ -> false
-
-let get_variable = function
-    | VEXPR_Variable v -> Some v
-    | _ -> None
-
-let variable_to_vexpr v = VEXPR_Variable v
-
-let get_name_from_fixdef (deflabel, defname, defargs, defexpr) = defname
-let get_args_from_fixdef (deflabel, defname, defargs, defexpr) = defargs
-let get_vars_from_fixdef def = get_name_from_fixdef def :: get_args_from_fixdef def
-
-(*********************************************************************************************************************
- * Substitution
- ********************************************************************************************************************)
-
-let subst_in_value_expression from_var to_val = function
-    | VEXPR_Variable var when var = from_var ->
-        to_val
-
-    | vexpr ->
-        vexpr
-
-let rec subst_in_expression from_var to_val _expr = 
-    let vexpr__subst = subst_in_value_expression from_var to_val in
-    let expr__subst  = subst_in_expression from_var to_val in
-    match _expr with
-        | EXPR_App (label, fun_val, arg_vals) ->
-            let fun_val'  = vexpr__subst fun_val in
-            let arg_vals' = List.map vexpr__subst arg_vals in
-            EXPR_App (label, fun_val', arg_vals')
-            
-        | EXPR_Switch (label, sel_val, default_branch, branches) ->
-            let sel_val'        = vexpr__subst sel_val in
-            let default_branch' = expr__subst default_branch in
-            let branches'       = List.map expr__subst branches in
-            EXPR_Switch (label, sel_val', default_branch', branches')
-
-        | EXPR_Fix (fix_label, definitions, in_expr) ->
-            let subst_def (def_label, func_name, func_args, func_body) =
-                let func_body' = Util.until0 (List.mem from_var func_args) expr__subst func_body in
-                (def_label, func_name, func_args, func_body')
-                in
-
-            let definitions' = List.map subst_def definitions in
-            let in_expr'     = expr__subst in_expr in
-            EXPR_Fix (fix_label, definitions', in_expr')
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            let arg1'    = vexpr__subst arg1 in
-            let arg2'    = vexpr__subst arg2 in
-            let in_expr' = Util.until0 (result = from_var) expr__subst in_expr in
-            EXPR_ArithmeticBinaryPrimOp (label, primop, arg1', arg2', result, in_expr') 
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-            let arg'     = vexpr__subst arg in
-            let in_expr' = Util.until0 (result = from_var) expr__subst in_expr in
-            EXPR_ArithmeticUnaryPrimOp (label, primop, arg', result, in_expr') 
-
-        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-            let arg1'        = vexpr__subst arg1 in
-            let arg2'        = vexpr__subst arg2 in
-            let then_branch' = expr__subst then_branch in
-            let else_branch' = expr__subst else_branch in
-            EXPR_ConditionPrimOp (label, primop, arg1', arg2', then_branch', else_branch')
-
-        | EXPR_Offset (label, offset, value, result, in_expr) ->
-            let value'      = vexpr__subst value in
-            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
-            EXPR_Offset (label, offset, value', result, in_expr')
-
-        | EXPR_Select (label, offset, value, result, in_expr) ->
-            let value'      = vexpr__subst value in
-            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
-            EXPR_Select (label, offset, value', result, in_expr')
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let fields'     = List.map (Tuple2.map1 vexpr__subst) fields in
-            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
-            EXPR_Record (label, fields', result, in_expr')
-            
-
-let subst_vexpr xs expr =
-    List.fold_right (uncurry subst_in_value_expression) xs expr
-
-let subst xs expr =
-    List.fold_right (uncurry subst_in_expression) xs expr
-
-(*********************************************************************************************************************
- * Variable renaming
- ********************************************************************************************************************)
-
-let getvarname = function
-    | Variable (Identifier var) -> var
-
-let rename_variable from_var to_vexpr var =
-    if var = from_var
-        then to_vexpr
-        else var
-
-
-let rename_in_value_expression from_var to_var = function
-    | VEXPR_Variable var when var = from_var ->
-        VEXPR_Variable to_var
-
-    | vexpr ->
-        vexpr
-
-let rec rename_in_expression from_var to_var _expr = 
-    let vexpr_renamer = rename_in_value_expression from_var to_var in
-    let expr_renamer  = rename_in_expression from_var to_var in
-    match _expr with
-        | EXPR_App (label, fun_val, arg_vals) ->
-            let fun_val'  = vexpr_renamer fun_val in
-            let arg_vals' = List.map vexpr_renamer arg_vals in
-            EXPR_App (label, fun_val', arg_vals')
-            
-        | EXPR_Switch (label, sel_val, default_branch, branches) ->
-            let sel_val'        = vexpr_renamer sel_val in
-            let default_branch' = expr_renamer default_branch in
-            let branches'       = List.map expr_renamer branches in
-            EXPR_Switch (label, sel_val', default_branch', branches')
-
-        | EXPR_Fix (fix_label, definitions, in_expr) ->
-            let rename_def (def_label, func_name, func_args, func_body) =
-                let func_body' = Util.until0 (List.mem from_var (func_name::func_args)) expr_renamer func_body in
-                (def_label, func_name, func_args, func_body')
-                in
-
-            let definitions' = List.map rename_def definitions in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Fix (fix_label, definitions', in_expr')
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            let arg1'    = vexpr_renamer arg1 in
-            let arg2'    = vexpr_renamer arg2 in
-            let in_expr' = Util.until0 (result = from_var) expr_renamer in_expr in
-            EXPR_ArithmeticBinaryPrimOp (label, primop, arg1', arg2', result, in_expr') 
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-            let arg'     = vexpr_renamer arg in
-            let in_expr' = Util.until0 (result = from_var) expr_renamer in_expr in
-            EXPR_ArithmeticUnaryPrimOp (label, primop, arg', result, in_expr') 
-
-        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-            let arg1'        = vexpr_renamer arg1 in
-            let arg2'        = vexpr_renamer arg2 in
-            let then_branch' = expr_renamer then_branch in
-            let else_branch' = expr_renamer else_branch in
-            EXPR_ConditionPrimOp (label, primop, arg1', arg2', then_branch', else_branch')
-
-        | EXPR_Select (label, offset, arg, result, in_expr) ->
-            let arg'         = vexpr_renamer arg in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Select (label, offset, arg', result, in_expr')
-
-        | EXPR_Offset (label, offset, arg, result, in_expr) ->
-            let arg'         = vexpr_renamer arg in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Offset (label, offset, arg', result, in_expr')
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let fields'      = List.map (Tuple2.map1 vexpr_renamer) fields in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Record (label, fields', result, in_expr')
-
-
-(*********************************************************************************************************************
- * Variable renaming with map
- ********************************************************************************************************************)
-
-let rename_variable_map map variable =
-    try
-        VariableMap.find variable map
-    with _ ->
-        variable
-
-let rename_in_value_expression_map map = function
-    | VEXPR_Variable var ->
-        VEXPR_Variable (rename_variable_map map var)
-
-    | vexpr ->
-        vexpr
-
-
-let rec rename_in_expression_map map _expr = 
-    let vexpr_renamer = rename_in_value_expression_map map in
-    let expr_renamer  = rename_in_expression_map map in
-    match _expr with
-        | EXPR_App (label, fun_val, arg_vals) ->
-            let fun_val'  = vexpr_renamer fun_val in
-            let arg_vals' = List.map vexpr_renamer arg_vals in
-            EXPR_App (label, fun_val', arg_vals')
-            
-        | EXPR_Switch (label, sel_val, default_branch, branches) ->
-            let sel_val'        = vexpr_renamer sel_val in
-            let default_branch' = expr_renamer default_branch in
-            let branches'       = List.map expr_renamer branches in
-            EXPR_Switch (label, sel_val', default_branch', branches')
-
-        | EXPR_Fix (fix_label, definitions, in_expr) ->
-            let rename_def (def_label, func_name, func_args, func_body) =
-                let map'       = VariableMap.diff_list map (func_name::func_args) in
-                let func_body' = rename_in_expression_map map' func_body in
-                (def_label, func_name, func_args, func_body')
-                in
-
-            let definitions' = List.map rename_def definitions in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Fix (fix_label, definitions', in_expr')
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            let arg1'    = vexpr_renamer arg1 in
-            let arg2'    = vexpr_renamer arg2 in
-            let in_expr' = rename_in_expression_map (VariableMap.remove result map) in_expr in
-            EXPR_ArithmeticBinaryPrimOp (label, primop, arg1', arg2', result, in_expr') 
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-            let arg'     = vexpr_renamer arg in
-            let in_expr' = rename_in_expression_map (VariableMap.remove result map) in_expr in
-            EXPR_ArithmeticUnaryPrimOp (label, primop, arg', result, in_expr') 
-
-        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-            let arg1'        = vexpr_renamer arg1 in
-            let arg2'        = vexpr_renamer arg2 in
-            let then_branch' = expr_renamer then_branch in
-            let else_branch' = expr_renamer else_branch in
-            EXPR_ConditionPrimOp (label, primop, arg1', arg2', then_branch', else_branch')
-
-        | EXPR_Select (label, offset, arg, result, in_expr) ->
-            let arg'         = vexpr_renamer arg in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Select (label, offset, arg', result, in_expr')
-
-        | EXPR_Offset (label, offset, arg, result, in_expr) ->
-            let arg'         = vexpr_renamer arg in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Offset (label, offset, arg', result, in_expr')
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let fields'      = List.map (Tuple2.map1 vexpr_renamer) fields in
-            let in_expr'     = expr_renamer in_expr in
-            EXPR_Record (label, fields', result, in_expr')
-
-(*********************************************************************************************************************
- * Rebind
- ********************************************************************************************************************)
-
-
-let rec rebind variable_enumerator = function
-    | EXPR_App (label, fun_val, arg_vals) as expr ->
-        expr
-        
-    | EXPR_Switch (label, sel_val, default_branch, branches) ->
-        let new_default_branch = rebind variable_enumerator default_branch in
-        let new_branches       = List.map (rebind variable_enumerator) branches in
-        EXPR_Switch (label, sel_val, new_default_branch, new_branches) 
-
-    | EXPR_Fix (fix_label, definitions, in_expr) ->
-
-        let handle_definition (def_label, def_name, def_arguments, def_body) (map, defs) =
-            let new_name      = VariableEnumerator.get_next ~suffix:"f" variable_enumerator in
-            print_string "rebind fix ";
-            print_string (getvarname def_name);
-            print_string " -> ";
-            print_endline (getvarname new_name);
-
-            let (new_arguments, new_body) =
-                let f argument    = 
-                    let new_argument = VariableEnumerator.get_next ~suffix:"a" variable_enumerator in
-                    (argument, new_argument)
-                    in
-                let pairs         = List.map f def_arguments in
-                let enum          = List.enum pairs in
-                let mapping       = VariableMap.of_enum enum in
-                let new_body      = rebind variable_enumerator (rename_in_expression_map mapping def_body) in
-                (List.map snd pairs, new_body)
-                in
-
-            let new_map = VariableMap.add def_name new_name map in
-            let new_def = (def_label, new_name, new_arguments, new_body) in
-            (new_map, new_def :: defs)
-            in
-
-        let (renaming_map, new_definitions) = List.fold_right handle_definition definitions (VariableMap.empty, []) in 
-
-        let rename_in_definition (def_label, def_name, def_arguments, def_body) =
-            let new_body = rename_in_expression_map renaming_map def_body in
-            (def_label, def_name, def_arguments, new_body)
-            in
-
-        let new_definitions = List.map rename_in_definition new_definitions in
-        let new_in_expr     = rebind variable_enumerator in_expr in
-        let new_in_expr     = rename_in_expression_map renaming_map new_in_expr in
-        let new_expr        = EXPR_Fix (fix_label, new_definitions, new_in_expr) in
-        new_expr
-
-    | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-        let new_result  = VariableEnumerator.get_next ~suffix:"p" variable_enumerator in
-        let in_expr'    = rename_in_expression result new_result in_expr in
-        let new_in_expr = rebind variable_enumerator in_expr' in
-        EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, new_result, new_in_expr)
-
-    | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-        let new_result  = VariableEnumerator.get_next ~suffix:"p" variable_enumerator in
-        let in_expr'    = rename_in_expression result new_result in_expr in
-        let new_in_expr = rebind variable_enumerator in_expr' in
-        EXPR_ArithmeticUnaryPrimOp (label, primop, arg, new_result, new_in_expr)
-
-    | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-        let new_then_branch = rebind variable_enumerator then_branch in
-        let new_else_branch = rebind variable_enumerator else_branch in
-        EXPR_ConditionPrimOp (label, primop, arg1, arg2, new_then_branch, new_else_branch) 
-
-    | EXPR_Select (label, offset, arg, result, in_expr) ->
-        let new_result  = VariableEnumerator.get_next ~suffix:"s" variable_enumerator in
-        let in_expr'    = rename_in_expression result new_result in_expr in
-        let new_in_expr = rebind variable_enumerator in_expr' in
-        EXPR_Select (label, offset, arg, new_result, new_in_expr) 
-
-    | EXPR_Offset (label, offset, arg, result, in_expr) ->
-        let new_result  = VariableEnumerator.get_next ~suffix:"o" variable_enumerator in
-        let in_expr'    = rename_in_expression result new_result in_expr in
-        let new_in_expr = rebind variable_enumerator in_expr' in
-        EXPR_Offset (label, offset, arg, new_result, new_in_expr) 
-
-    | EXPR_Record (label, fields, result, in_expr) ->
-        let new_result  = VariableEnumerator.get_next ~suffix:"r" variable_enumerator in
-        let in_expr'    = rename_in_expression result new_result in_expr in
-        let new_in_expr = rebind variable_enumerator in_expr' in
-        EXPR_Record (label, fields, new_result, new_in_expr) 
-
-(*********************************************************************************************************************
- * Equality
- ********************************************************************************************************************)
-
-let __equal () =
-    let vmap = Hashtbl.create 513 in
-
-    let assume_eq var1 var2 cont =
-        Hashtbl.add vmap var1 var2;
-        let r = cont () in
-        Hashtbl.remove vmap var1;
-        r
-        in
-
-    let rec assume_eqs vars1 vars2 cont =
-        match (vars1, vars2) with
-            | (var1::rest1, var2::rest2) ->
-                let subcont () = assume_eqs rest1 rest2 cont in
-                assume_eq var1 var2 subcont
-            
-            | ([], []) ->
-                cont ()
-
-            | _ ->
-                false
-        in
-
-    let check_var var1 var2 =
-        try
-            let var1' = Hashtbl.find vmap var1 in
-            var1' = var2
-        with Not_found ->
-            false
-        in
-
-    let vexpr_equal = function 
-        | (VEXPR_Variable var1, VEXPR_Variable var2) ->
-            check_var var1 var2
-
-        | (ve1, ve2) ->
-            ve1 = ve2
-        in
-
-    let rec expr_equal = function
-        | (EXPR_App (_, func1, args1), EXPR_App (_, func2, args2)) ->
-            vexpr_equal (func1, func2) &&
-            List.for_all2 (Util.curry vexpr_equal) args1 args2
-
-        | (EXPR_Switch (_, sel_val1, def_branch1, branches1), EXPR_Switch (_, sel_val2, def_branch2, branches2)) ->
-            vexpr_equal (sel_val1, sel_val2) &&
-            expr_equal (def_branch1, def_branch2) &&
-            List.for_all2 (Util.curry expr_equal) branches1 branches2
-
-        | (EXPR_Fix (_, definitions1, in_expr1), EXPR_Fix (_, definitions2, in_expr2)) ->
-            raise Exit
-
-        | (EXPR_ArithmeticBinaryPrimOp (_, primop1, arg11, arg21, res1, in_expr1),
-           EXPR_ArithmeticBinaryPrimOp (_, primop2, arg12, arg22, res2, in_expr2)) ->
-
-            let cont () = expr_equal (in_expr1, in_expr2) in
-            primop1 = primop2 &&
-            vexpr_equal (arg11, arg12) &&
-            vexpr_equal (arg21, arg22) &&
-            assume_eq res1 res2 cont
-
-        | (EXPR_ArithmeticUnaryPrimOp (_, primop1, arg1, res1, in_expr1),
-           EXPR_ArithmeticUnaryPrimOp (_, primop2, arg2, res2, in_expr2)) ->
-            let cont () = expr_equal (in_expr1, in_expr2) in
-            primop1 = primop2 &&
-            vexpr_equal (arg1, arg2) &&
-            assume_eq res1 res2 cont
-
-        | (EXPR_ConditionPrimOp (_, primop1, arg11, arg21, then_branch1, else_branch1),
-           EXPR_ConditionPrimOp (_, primop2, arg12, arg22, then_branch2, else_branch2)) ->
-
-            primop1 = primop2 &&
-            vexpr_equal (arg11, arg12) &&
-            vexpr_equal (arg21, arg22) &&
-            expr_equal (then_branch1, then_branch2) &&
-            expr_equal (else_branch1, else_branch2)
-
-        | (EXPR_Select (_, offset1, arg1, result1, in_expr1),
-           EXPR_Select (_, offset2, arg2, result2, in_expr2)) ->
-
-            let cont () = expr_equal (in_expr1, in_expr2) in
-
-           offset1 = offset2 &&
-           vexpr_equal (arg1, arg2) &&
-           assume_eq result1 result2 cont
-
-        | (EXPR_Offset (_, offset1, arg1, result1, in_expr1),
-           EXPR_Offset (_, offset2, arg2, result2, in_expr2)) ->
-
-            let cont () = expr_equal (in_expr1, in_expr2) in
-
-           offset1 = offset2 &&
-           vexpr_equal (arg1, arg2) &&
-           assume_eq result1 result2 cont
-
-        | (EXPR_Record (_, fields1, result1, in_expr1),
-           EXPR_Record (_, fields2, result2, in_expr2)) ->
-
-           let cont () = expr_equal (in_expr1, in_expr2) in
-           List.for_all2 (fun (value1, _) (value2, _) -> vexpr_equal (value1, value2)) fields1 fields2 &&
-           assume_eq result1 result2 cont
-
-        (*
-         * I prefer this instead of "(_, _) -> false" because it allows compiler to generate
-         * warning when I add new construction into the language
-         *)
-
-        | (EXPR_App _, _) 
-        | (EXPR_Switch _, _) 
-        | (EXPR_Fix _, _) 
-        | (EXPR_ArithmeticBinaryPrimOp _, _)
-        | (EXPR_ArithmeticUnaryPrimOp _, _)
-        | (EXPR_ConditionPrimOp _, _)
-        | (EXPR_Record _, _)
-        | (EXPR_Select _, _)
-        | (EXPR_Offset _, _) ->
-            false
-
-        in
-
-    (expr_equal)
-
-let expr_equal expr1 expr2 = __equal () (expr1, expr2)
-
-(*********************************************************************************************************************
- * Set of free variables
- ********************************************************************************************************************)
-
-let free_variable_of_value_expression = function
-    | VEXPR_Variable v ->
-        VariableSet.singleton v
-
-    | _ ->
-        VariableSet.empty
-
-let add_variable_from_value_expression value set = match value with
-    | VEXPR_Variable var ->
-        VariableSet.add var set
-
-    | _ ->
-        set
-
-let rec free_variables_of_expression = function
-        | EXPR_App (label, fun_val, arg_vals) ->
-            fun_val :: arg_vals
-            |> List.fold_left
-                (fun set vexpr -> VariableSet.union set (free_variable_of_value_expression vexpr))
-                VariableSet.empty
-            
-        | EXPR_Switch (label, sel_val, default_branch, branches) ->
-            default_branch :: branches
-            |> List.fold_left
-                (fun set vexpr -> VariableSet.union set (free_variables_of_expression vexpr))
-                VariableSet.empty
-            |> add_variable_from_value_expression sel_val
-
-        | EXPR_Fix (fix_label, definitions, in_expr) ->
-            let from_def (_, _, formal_arguments, body_expr) =
-                let fv_body = free_variables_of_expression body_expr in
-                let fv_args = Util.container_from_list (VariableSet.add) (VariableSet.empty) formal_arguments in
-                VariableSet.diff fv_body fv_args
-                in
-
-            let def_name (_, name, _, _) = name
-                in
-
-            let fvs =
-                List.fold_left
-                    VariableSet.union 
-                    VariableSet.empty
-                    (free_variables_of_expression in_expr :: List.map from_def definitions)
-                in
-
-            let bvs = List.map def_name definitions
-                in
-
-            List.fold_left (fun set v -> VariableSet.remove v set) fvs bvs
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            in_expr
-            |> free_variables_of_expression
-            |> VariableSet.remove result
-            |> add_variable_from_value_expression arg1
-            |> add_variable_from_value_expression arg2
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-            in_expr
-            |> free_variables_of_expression
-            |> VariableSet.remove result
-            |> add_variable_from_value_expression arg
-
-        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-            (then_branch, else_branch)
-            |> Tuple2.mapn free_variables_of_expression
-            |> uncurry VariableSet.union
-            |> add_variable_from_value_expression arg1
-            |> add_variable_from_value_expression arg2
-
-        | EXPR_Offset (label, offset, value, result, in_expr) ->
-            in_expr
-            |> free_variables_of_expression
-            |> VariableSet.remove result
-            |> add_variable_from_value_expression value
-
-        | EXPR_Select (label, offset, value, result, in_expr) ->
-            in_expr
-            |> free_variables_of_expression
-            |> VariableSet.remove result
-            |> add_variable_from_value_expression value
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            in_expr
-            |> free_variables_of_expression
-            |> VariableSet.remove result
-
-(*********************************************************************************************************************
- * 
- ********************************************************************************************************************)
-
-let prepare_ast ast =
-    let enumerators =
-        { variable_enumerator = VariableEnumerator.make 0 
-        ; label_enumerator    = LabelEnumerator.make 0 
-        } in
-    (rebind enumerators.variable_enumerator ast, enumerators)
-

source/Languages/CWCPS/Lang_CWCPS/AnalysisFramework.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Lib_Algebra.Monoid
-open Batteries
-
-(*********************************************************************************************************************
- * Algebra.Monoid based 
- ********************************************************************************************************************)
-
-module MonoidBasedAnalysis (M : Monoid) = struct
-
-    module MH = MonoidUtils (M)
-
-    module Gather = struct
-
-        let gather_from_subexpr f = function
-            | EXPR_App (label, fun_val, arg_vals) ->
-                M.neutral
-
-            | EXPR_Switch (label, sel_val, default_branch, branches) ->
-                MH.oper_map f (default_branch::branches)
-
-            | EXPR_Fix (reclabel, definitions, in_expr) ->
-                let f' (deflabel, defname, defargs, defexpr) = f defexpr in
-                MH.opers [f in_expr; MH.oper_map f' definitions]
-
-            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-                f in_expr
-
-            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-                f in_expr
-
-            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-                MH.oper_map f [then_branch; else_branch]
-
-            | EXPR_Offset (label, offset, arg, result, in_expr)
-            | EXPR_Select (label, offset, arg, result, in_expr) ->
-                f in_expr
-
-            | EXPR_Record (label, fields, result, in_expr) ->
-                f in_expr
-
-
-        let rec gather f tm =
-            MH.opers [f tm; gather_from_subexpr (gather f) tm]
-
-    end
-
-    module GatherDep = struct
-
-        let gather_dep_from_subexpr f data = function
-            | EXPR_App (label, fun_val, arg_vals) ->
-                data
-
-            | EXPR_Switch (label, sel_val, default_branch, branches) ->
-                MH.oper_fold f data (default_branch::branches)
-
-            | EXPR_Fix (reclabel, definitions, in_expr) ->
-                let f' (deflabel, defname, defargs, defexpr) = defexpr in
-                List.map f' definitions
-                |> MH.oper_fold f (f data in_expr)
-
-            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-                MH.oper_fold f data [then_branch; else_branch]
-
-            | EXPR_Offset (label, offset, arg, result, in_expr)
-            | EXPR_Select (label, offset, arg, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_Record (label, fields, result, in_expr) ->
-                f data in_expr
-
-        let rec gather_topdown_ f data tm =
-            gather_dep_from_subexpr (gather_topdown_ f) (f data tm) tm
-
-        let rec gather_bottomup_ f data tm =
-            f (gather_dep_from_subexpr (gather_bottomup_ f) data tm) tm
-
-        let topdown f  = gather_topdown_ f M.neutral
-
-        let bottomup f = gather_bottomup_ f M.neutral
-
-    end
-
-end
-
-(*********************************************************************************************************************
- * Imperative based
- ********************************************************************************************************************)
-

source/Languages/CWCPS/Lang_CWCPS/Eval.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Batteries
-open Lang_Common
-
-(*********************************************************************************************************************
- * Value 
- ********************************************************************************************************************)
-
-type value
-    = VAL_Integer of int
-    | VAL_Closure of variable list * expression * environment
-    | VAL_Record of value list * int
-    | VAL_TopContinuation
-    | VAL_Unit
-
-and environment   = value Environment.t
-
-let is_topcontinuation = function
-    | VAL_TopContinuation -> true
-    | _                   -> false
-
-let force_integer = function
-    | VAL_Integer value ->
-        value
-
-    | _ ->
-        EvalError.invalid_operation "expected an integer value"
-
-let force_closure = function
-    | VAL_Closure (arguments, body_expression, closure_environment) ->
-        (arguments, body_expression, closure_environment)
-
-    | _ ->
-        EvalError.invalid_operation "expected a closure"
-
-(*********************************************************************************************************************
- * Access path accessor
- ********************************************************************************************************************)
-
-let rec resolve_access_path = function
-    | value, OFFp 0 ->
-        value
-
-    | VAL_Record (elems, shift), OFFp offset ->
-        VAL_Record (elems, shift+offset)
-
-    | VAL_Record (elems, shift), SELp (offset, path) ->
-        resolve_access_path (List.nth elems (shift + offset), path)
-
-    | _ ->
-        EvalError.invalid_operation "invalid record access path"
-
-(*********************************************************************************************************************
- * Parameters for the Evaluator
- ********************************************************************************************************************)
-
-module type Parameters = sig
-
-    val store : value Store.t
-
-    val environment : environment ref
-
-end
-
-(*********************************************************************************************************************
- * Utils
- ********************************************************************************************************************)
-
-module MakeUtils(Parameters : Parameters) = struct
-
-    include Parameters
-
-    (*----------------------------------------------------------------------------------------------------------------
-     * Store
-     *)
-
-    let get_value_from_store location =
-        try
-            Store.fetch_location store location
-        with
-            Not_found ->
-                EvalError.unknown_store_location location
-
-    let put_value_to_store location value =
-            Store.store_location store location value
-
-    let get_new_location () =
-        Store.alloc_location store
-
-    (*----------------------------------------------------------------------------------------------------------------
-     * Environment
-     *)
-
-    let get_value_from_environment variable = 
-        try
-            Environment.get !environment variable
-        with
-            Not_found ->
-                EvalError.unknown_variable variable
-
-
-    let with_extended_environment variable value continuation =
-        Environment.with_extended_environment !environment variable value continuation
-
-    let with_extended_environment_m _xs continuation =
-        Environment.with_extended_environment_m !environment _xs continuation
-
-    (*----------------------------------------------------------------------------------------------------------------
-     * Cloning
-     *)
-
-    let get_environment_clone () =
-        Environment.clone !environment
-
-    let change_environment env =
-        environment := Environment.clone env
-end
-
-(*********************************************************************************************************************
- * The implementation
- ********************************************************************************************************************)
-
-module Implementation(Parameters : Parameters) = struct
-
-    module Utils = MakeUtils(Parameters)
-
-    let eval_value_expression = function
-        | VEXPR_Integer i ->
-            VAL_Integer i
-
-        | VEXPR_Unit ->
-            VAL_Unit
-
-        | VEXPR_TopContinuation ->
-            VAL_TopContinuation
-
-        | VEXPR_Variable v ->
-            Utils.get_value_from_environment v
-
-    let rec eval_program = function
-        | expression ->
-            eval_expression expression
-
-    and eval_expression = function
-        | EXPR_App (_, function_vexpr, actual_arguments) ->
-            let function_value = eval_value_expression function_vexpr in
-            if is_topcontinuation function_value
-            then begin
-                List.map eval_value_expression actual_arguments
-            end else begin
-                let (formal_arguments, body_expression, closure_environment) = force_closure function_value in
-                let evaluated_arguments = List.map eval_value_expression actual_arguments in
-                let vs = List.combine formal_arguments evaluated_arguments in
-                Utils.change_environment closure_environment;
-                let cont () = eval_expression body_expression in
-
-                Utils.with_extended_environment_m vs cont
-            end
-
-        | EXPR_Fix (_, definitions, inexpression) ->
-            let environment = Utils.get_environment_clone () in
-            let handle_def (_, variable, argument_variables, expression) =
-                let value   = VAL_Closure (argument_variables, expression, environment) in
-                Environment.put environment variable value;
-                (variable, value) 
-                in
-
-            let cont () = eval_expression inexpression in
-            let bindings = List.map handle_def definitions in
-            Utils.with_extended_environment_m bindings cont
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, val1, val2, var, branch) ->
-            let value1 = force_integer (eval_value_expression val1) in
-            let value2 = force_integer (eval_value_expression val2) in
-            let func   = eval_arithmetic_binary_primitive_operation primop in
-            let result = VAL_Integer (func value1 value2) in
-            let cont () = eval_expression branch in
-            Utils.with_extended_environment var result cont
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, vale, var, branch) ->
-            let value  = force_integer (eval_value_expression vale) in
-            let func   = eval_arithmetic_unary_primitive_operation primop in
-            let result = VAL_Integer (func value) in
-            let cont () = eval_expression branch in
-            Utils.with_extended_environment var result cont
-
-        | EXPR_ConditionPrimOp (label, primop, val1, val2, branch1, branch2) ->
-            let value1 = force_integer (eval_value_expression val1) in
-            let value2 = force_integer (eval_value_expression val2) in
-            let func   = eval_condition_primitive_operation primop in
-            let result = func value1 value2 in
-            if result
-                then eval_expression branch1
-                else eval_expression branch2
-
-        | EXPR_Switch (label, selval, default_branch, branches) ->
-            let value = force_integer (eval_value_expression selval) in
-            begin try
-                let branch = List.nth branches value in
-                eval_expression branch
-            with Failure "nth" ->
-                eval_expression default_branch
-            end
-           
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let fields' = List.map (Tuple2.map1 (eval_value_expression )) fields in
-            let values  = List.map resolve_access_path fields' in
-            let vrecord = VAL_Record (values, 0) in
-            let cont () = eval_expression in_expr in
-            Utils.with_extended_environment result vrecord cont
-
-        | EXPR_Select (label, offset, value, result, in_expr) ->
-            let vrecord = eval_value_expression value in
-            let access  = SELp (offset, OFFp 0) in
-            let v       = resolve_access_path (vrecord, access) in
-            let cont () = eval_expression in_expr in
-            Utils.with_extended_environment result v cont
-
-        | EXPR_Offset (label, offset, value, result, in_expr) ->
-            let vrecord = eval_value_expression value in
-            let access  = OFFp offset in
-            let v       = resolve_access_path (vrecord, access) in
-            let cont () = eval_expression in_expr in
-            Utils.with_extended_environment result v cont
-
-end
-
-(*********************************************************************************************************************
- * Entry point
- ********************************************************************************************************************)
-
-(* arguments only for compatibility with old interface *)
-let eval_program store =
-    let module Utils : Parameters = 
-        struct
-            let environment = ref (Environment.create ())
-            let store       = store
-        end in
-    let module M = Implementation(Utils) in
-    M.eval_program 
-

source/Languages/CWCPS/Lang_CWCPS/Helper.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Batteries
-
-module ValuePrinter = struct
-
-open PrettyPrinter
-open Eval
-open Lang_Common
-
-let update_mem (ht,mpath) var = (ht, string_of_variable var :: mpath)
-
-let is_closure = function
-    | VAL_Closure _ -> true
-    | _ -> false
-
-
-let rec _paint_closure mem args body env =
-        [ Formatter.psp_value_keyword "closure"
-        ; Formatter.psp_group (List.map (fun x -> Formatter.psp_variable x) args)
-        ; Formatter.psp_operator "->"
-        ; Formatter.psp_break
-        ; Formatter.psp_indent (PrettyPrinter.paint_expression body)
-        ; Formatter.psp_indent_group (_paint_environment mem env)
-        ]
-
-and _paint_real_value mem = function
-    | VAL_Integer i ->
-        [ Formatter.psp_value_int i ]
-
-    | VAL_Unit ->
-        [ Formatter.psp_value "()" ]
-
-    | VAL_TopContinuation ->
-        [ Formatter.psp_value_keyword "TOPCONT" ]
-
-    | VAL_Closure (args,body,env) ->
-        _paint_closure mem args body env
-
-    | VAL_Record (elems, shift) ->
-        [ Formatter.psp_value_keyword "record"
-        ; Formatter.psp_value_int shift
-        ; Formatter.psp_list_map
-            Formatter.psp_std_bracket
-            (Formatter.psp_operator ",")
-            (Formatter.psp_group % _paint_real_value mem)
-            elems
-        ]
-
-and _paint_value (ht, mpath) v =
-    try
-
-        (* drity hack :-) *)
-        if not (is_closure v) then raise Not_found
-        else ();
-        let path = Hashtbl.find ht v in
-        [ Formatter.psp_identifier (Identifier (Util.concat_intersperse "." (List.rev path)))
-        ]
-    with
-        Not_found ->
-            Hashtbl.replace ht v mpath;
-            _paint_real_value (ht, mpath) v
-
-and _paint_environment mem environment =
-    Environment.PrettyPrinter.paint_environment _paint_value update_mem mem environment
-
-
-let paint_value v = _paint_value (Hashtbl.create 127, ["@"]) v
-let paint_environment e = _paint_environment (Hashtbl.create 127, ["@"]) e
-
-end
-
-

source/Languages/CWCPS/Lang_CWCPS/Lexer.mll

-{
-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-
-open Parser
-
-let create_dictionary xs =
-    let htable = Hashtbl.create 17 in
-    List.iter (fun (key,tok) -> Hashtbl.replace htable key tok) xs;
-    htable
-
-let keywords = create_dictionary
-        [ ("let", LET)
-        ; ("in", IN)
-        ; ("fix", FIX)
-
-
-        ; ("not", OP_NOT)
-        ; ("and", AND)
-        ; ("true", TRUE)
-        ; ("false", FALSE)
-
-        ; ("primop", PRIMOP)
-
-        ; ("throw", THROW)
-        ; ("try", TRY)
-        ; ("catch", CATCH)
-
-        ; ("Int", TP_INT)
-        ; ("Bool", TP_BOOL)
-
-        ; ("if", IF)
-        ; ("then", THEN)
-        ; ("else", ELSE)
-        
-        ; ("offset", OFFSET)
-        ; ("select", SELECT)
-        ; ("record", RECORD)
-        ; ("from", FROM)
-        ; ("at", AT)
-
-        ; ("TOPCONT", TOPCONT)
-        ]
-
-let operators = create_dictionary
-        [ ("{", CURL_OPEN)
-        ; ("}", CURL_CLOSE)
-        ; ("(", LPARENT)
-        ; (")", RPARENT)
-
-        ; ("[", SQ_LPARENT)
-        ; ("]", SQ_RPARENT)
-
-        ; (";", SEMICOLON)
-
-        ; (":=", ASSIGN)
-
-        ; ("+", OP_ADD)
-        ; ("-", OP_SUB)
-        ; ("*", OP_MUL)
-        ; ("/", OP_DIV)
-        ; ("%", OP_MOD)
-
-        ; ("|", OP_PIPE)
-
-        ; ("<", OP_LT)
-        ; ("<=", OP_LEQ)
-        ; ("=", OP_EQ)
-        ; (">", OP_GT)
-        ; (">=", OP_GEQ)
-
-
-        ; ("()", UNITVAL)
-
-        ; ("!", OP_EXCLAMATION)
-        ; ("->", OP_RIGHTARROW)
-
-        ; ("&&", OP_AND)
-        ; ("||", OP_OR)
-        ; ("@", OP_AT)
-        ; (".", OP_DOT)
-        ; (",", OP_COMMA)
-        ]
-
-let dictionary_lookup dict key =
-        try
-            let value = Hashtbl.find dict key in
-            value
-        with
-            Not_found ->
-                STR key
-
-exception Eof
-
-let compute_token_from_id = dictionary_lookup keywords
-
-let compute_token_from_oper = dictionary_lookup operators
-
-let compute_token_from_int str = INT (int_of_string str)
-
-}
-
-rule token = parse
-
-    [' ' '\t' '\n']
-    { token lexbuf }     (* skip blanks *)
-
-    | "(*"_*"*)"
-    { token lexbuf }
-
-    | ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''0'-'9''_']* as lxm
-    { compute_token_from_id lxm }
-
-    | ['{' '}' '(' ')' ';' '+' '-' '*' '/' '%' ] | ":=" | "&&" | "@" | "."
-    | "||" | "<" | "<=" | "=" | ">" | ">=" | "|" | "()" | "->" | "!" | ","
-    | "["  | "]"
-    as lxm
-    { compute_token_from_oper lxm }
-
-    | ['0'-'9']+ as lxm
-    { compute_token_from_int lxm }
-
-    | eof
-    { EOF }

source/Languages/CWCPS/Lang_CWCPS/Parser.mly

-%{
-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-
-%}
-
-%token <int>    INT
-%token <bool>    BOOL
-%token <string>    STRING
-%token <string> NEW DELETE
-
-%token PLUS MINUS TIMES DIV
-%token EOL
-
-%left OP_AND
-%left OP_OR
-
-%left ELSE
-%nonassoc OP_NOT        /* highest precedence */
-%right SEMICOLON
-
-%start parse
-
-%type <AST.expression> parse
-
-%token LPARENT
-%token RPARENT
-
-%token SQ_LPARENT
-%token SQ_RPARENT
-
-%token CURL_OPEN
-%token CURL_CLOSE
-%token SEMICOLON
-
-%token ASSIGN
-%token OP_OR
-%token OP_AND
-%token OP_NOT
-%token OP_RIGHTARROW
-%token OP_ADD
-%token OP_SUB
-%token OP_MUL
-%token OP_DIV
-%token OP_MOD
-
-%token OP_LT
-%token OP_LEQ
-%token OP_EQ
-%token OP_GT
-%token OP_GEQ
-%token OP_NEQ
-%token OP_PIPE
-%token OP_EXCLAMATION
-%token EOF
-%token AND
-
-%token OP_COMMA
-%token AT
-
-%token IF
-%token THEN
-%token ELSE
-%token ELIF
-%token FUN
-%token LET
-%token IN
-%token FIX
-%token END
-%token READ
-%token WRITE
-
-%token THROW
-%token TRY
-%token CATCH
-
-%token MATCH
-%token WITH
-
-%token ABORT
-
-%token TRUE
-%token FALSE
-%token PRIMOP
-%token UNITVAL
-%token REF
-%token TOPCONT
-
-%token SELECT
-%token OFFSET
-%token RECORD
-%token FROM
-%token SWITCH
-
-%token OP_DOT
-%token OP_AT
-
-%token <string> STR
-
-%token TP_INT
-%token TP_BOOL
-%token TP_UNIT
-
-%%
-
-/*********************************************************************************************************************
- * Fundamental constructs
- */
-
-identifier:
-    STR
-    { Identifier $1 }
-    ;
-
-variable:
-    identifier
-    { Variable $1 }
-    ;
-
-variables:
-    |
-    { [] }
-
-    | variable variables
-    { $1 :: $2 }
-    ;
-
-
-arithmetic_binary_primitive_operator:
-    | OP_ADD
-    { PRIMOP_Add }
-
-    | OP_SUB
-    { PRIMOP_Sub }
-
-    | OP_MUL
-    { PRIMOP_Mul }
-
-    | OP_DIV 
-    { PRIMOP_Div }
-
-    | OP_MOD
-    { PRIMOP_Mod }
-
-    | OP_AND
-    { PRIMOP_And }
-
-    | OP_OR
-    { PRIMOP_Or }
-    ;
-
-arithmetic_unary_operator:
-    | OP_NOT
-    { PRIMOP_Not }
-    ;
-
-condition_primitive_operator:
-    | OP_LT
-    { PRIMOP_LT }
-
-    | OP_LEQ
-    { PRIMOP_LEQ }
-
-    | OP_EQ
-    { PRIMOP_EQ }
-
-    | OP_GT 
-    { PRIMOP_GT }
-
-    | OP_GEQ
-    { PRIMOP_GEQ }
-
-    | OP_NEQ
-    { PRIMOP_NEQ }
-    ;
-
-/*********************************************************************************************************************
- * Various helpers
- */
-
-letrec_definition:
-    | variable variable variables OP_EQ expression
-    { (get_new_label (), $1, $2::$3, $5) }
-
-andletrec_sequence:
-    | AND letrec_definition andletrec_sequence
-    { $2 :: $3 }
-
-    | 
-    { [] }
-    ;
-
-letrec_sequence:
-    |
-    { [] }
-
-    | letrec_definition andletrec_sequence
-    { $1 :: $2 }
-    ;
-
-raw_access_path:
-    | INT
-    { OFFp $1 }
-
-    | INT OP_DOT raw_access_path
-    { SELp ($1, $3) }
-
-access_path:
-    | raw_access_path 
-    { $1 }
-
-record_field:
-    | value_expression AT access_path
-    { ($1, $3) }
-
-record_fields:
-    | record_field
-    { [$1] }
-
-    | record_field OP_COMMA record_fields
-    { $1 :: $3 }
-
-/*********************************************************************************************************************
- * Value expression
- */
-
-value_expression:
-    | INT
-    { VEXPR_Integer $1 }
-
-    | UNITVAL
-    { VEXPR_Unit }
-
-    | TOPCONT
-    { VEXPR_TopContinuation }
-
-    | variable
-    { VEXPR_Variable $1 }
-
-values:
-    |
-    { [] }
-
-    | value_expression values
-    { $1 :: $2 }
-
-values1:
-    | value_expression values
-    { $1 :: $2 }
-    ;
-
-/*********************************************************************************************************************
- * Expression
- */
-
-expression:
-    | value_expression values1
-    { EXPR_App (get_new_label (), $1, $2) }
-
-    | LET FIX letrec_sequence
-      IN expression
-    { EXPR_Fix (get_new_label (), $3, $5) }
-
-    | LET PRIMOP variable OP_EQ
-      value_expression arithmetic_binary_primitive_operator value_expression 
-      IN expression
-    { EXPR_ArithmeticBinaryPrimOp (get_new_label (), $6, $5, $7, $3, $9) }
-
-    | LET PRIMOP variable OP_EQ
-      arithmetic_unary_operator value_expression
-      IN expression
-    { EXPR_ArithmeticUnaryPrimOp(get_new_label (), $5, $6, $3, $8) }
-
-    | IF PRIMOP value_expression condition_primitive_operator value_expression
-      THEN expression
-      ELSE expression
-    { EXPR_ConditionPrimOp(get_new_label (), $4, $3, $5, $7, $9) }
-
-    | LET RECORD variable OP_EQ LPARENT record_fields RPARENT
-      IN expression
-    { EXPR_Record (get_new_label (), $6, $3, $9) }
-
-    | LET OFFSET variable OP_EQ INT FROM value_expression 
-      IN expression
-    { EXPR_Offset(get_new_label (), $5, $7, $3, $9) }
-
-    | LET SELECT variable OP_EQ INT FROM value_expression 
-      IN expression
-    { EXPR_Select(get_new_label (), $5, $7, $3, $9) }
-    ;
-
-/*********************************************************************************************************************
- * Program
- */
-
-
-parse:
-    | expression EOF
-    { $1 }
-
-%% 
-

source/Languages/CWCPS/Lang_CWCPS/PrettyPrinter.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Lang_Common
-open Formatter
-open Batteries
-
-(*********************************************************************************************************************
- ********************************************************************************************************************)
-
-let paint_type_expression () = ()
-
-(*********************************************************************************************************************
- * Pretty printers
- ********************************************************************************************************************)
-
-(*--------------------------------------------------------------------------------------------------------------------
- * Pretty printer for expression
- *)
-
-let paint_arithmetic_binary_primitive_operation = function
-    | PRIMOP_Add -> psp_operator "+"
-    | PRIMOP_Sub -> psp_operator "-"
-    | PRIMOP_Mul -> psp_operator "*"
-    | PRIMOP_Div -> psp_operator "/"
-    | PRIMOP_Mod -> psp_operator "mod"
-    | PRIMOP_And -> psp_operator "and"
-    | PRIMOP_Or  -> psp_operator "or"
-    | PRIMOP_Xor -> psp_operator "xor "
-
-let paint_arithmetic_unary_primitive_operation = function
-    | PRIMOP_Not -> psp_operator "not" 
-    | PRIMOP_Neg -> psp_operator "neg"
-
-let paint_condition_primitive_operation = function
-    | PRIMOP_LT ->  psp_operator "<" 
-    | PRIMOP_LEQ -> psp_operator "<=" 
-    | PRIMOP_EQ ->  psp_operator "=" 
-    | PRIMOP_GT ->  psp_operator ">" 
-    | PRIMOP_GEQ -> psp_operator ">=" 
-    | PRIMOP_NEQ -> psp_operator "<>" 
-
-(*--------------------------------------------------------------------------------------------------------------------
- *)
-
-let rec _paint_access_path = function
-    | OFFp offset ->
-        psp_value_int offset
-
-    | SELp (offset, ap) -> psp_group
-        [ psp_value_int offset
-        ; psp_operator "."
-        ; _paint_access_path ap
-        ]
-        
-let paint_access_path ap = _paint_access_path ap
-
-(*--------------------------------------------------------------------------------------------------------------------
- * Pretty printer for expression
- *)
-
-let rec paint_expression = function
-    | lambda_expression ->
-        paint_lambda_expression lambda_expression
-
-(*--------------------------------------------------------------------------------------------------------------------
- * Pretty printer for lambda_expression
- *)
-
-and paint_value_expression = function
-    | VEXPR_Integer i -> psp_group
-        [ psp_value_int i
-        ]
-
-    | VEXPR_Unit -> psp_group
-        [ psp_value "()"
-        ]
-
-    | VEXPR_TopContinuation -> psp_group
-        [ psp_keyword "TOPCONT"
-        ]
-
-    | VEXPR_Variable var -> psp_group
-        [ psp_variable var
-        ]
-
-and paint_lambda_expression = function
-
-    | EXPR_App (_, value_expression, argument_values) -> psp_group
-        [ paint_value_expression value_expression
-        ; psp_group (List.map paint_value_expression argument_values)
-        ]
-
-    | EXPR_Fix (_, definitions, expression) ->
-        let handle_def (_, variable, argument_variables, binded_expression) aux =
-            [ psp_variable variable
-            ; psp_group (List.map psp_variable argument_variables)
-            ; psp_operator "="
-            ; psp_indent_when_multiline (paint_expression binded_expression)
-            ; psp_break
-            ] :: aux in
-
-        let aux = List.fold_right handle_def definitions [] in
-
-        let result = Util.concat_intersperse' [psp_keyword "and"] aux in
-
-        psp_group
-        [ psp_keyword "let"
-        ; psp_indent_group_when_multiline
-            [ psp_keyword "fix"
-            ; psp_group result
-            ]
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression expression
-        ]
-
-    | EXPR_ArithmeticBinaryPrimOp (label, operator, val1, val2, res, branch) -> psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "primop"
-        ; psp_variable res
-        ; psp_operator "="
-        ; paint_value_expression val1
-        ; paint_arithmetic_binary_primitive_operation operator
-        ; paint_value_expression val2
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression branch
-        ]
-
-    | EXPR_ArithmeticUnaryPrimOp (label, operator, val1, res, branch) -> psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "primop"
-        ; psp_variable res
-        ; psp_operator "="
-        ; paint_arithmetic_unary_primitive_operation operator
-        ; paint_value_expression val1
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression branch
-        ]
-
-    | EXPR_ConditionPrimOp (label, operator, val1, val2, branch1, branch2) -> psp_group
-        [ psp_keyword "if"
-        ; psp_keyword "primop"
-        ; paint_value_expression val1
-        ; paint_condition_primitive_operation operator
-        ; paint_value_expression val2
-        ; psp_indent_group
-            [ psp_keyword "then"
-            ; psp_indent (paint_expression branch1)
-            ]
-        ; psp_indent_group
-            [ psp_keyword "else"
-            ; psp_indent (paint_expression branch2)
-            ]
-        ]
-
-    | EXPR_Switch (label, selval, default_branch, branches) ->
-        let f i expr = psp_group
-            [ psp_operator "|"
-            ; psp_value_int i
-            ; psp_operator "->"
-            ; psp_break
-            ; psp_indent (paint_expression expr)
-            ]
-            in
-        psp_group
-        [ psp_keyword "switch"
-        ; paint_value_expression selval
-        ; psp_break
-        ; psp_group
-            (BatList.mapi f branches)
-        ; psp_group
-            [ psp_operator "|"
-            ; psp_syntax "_"
-            ; psp_operator "->"
-            ; paint_expression default_branch
-            ]
-        ; psp_break
-        ; psp_keyword "end"
-        ; psp_break
-        ]
-
-    | EXPR_Select (label, offset, value, result, in_expr) -> psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "select"
-        ; psp_variable result
-        ; psp_operator "="
-        ; psp_value_int offset
-        ; psp_keyword "from"
-        ; paint_value_expression value
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression in_expr
-        ]
-
-    | EXPR_Offset (label, offset, value, result, in_expr) -> psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "offset"
-        ; psp_variable result
-        ; psp_operator "="
-        ; psp_value_int offset
-        ; psp_keyword "from"
-        ; paint_value_expression value
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression in_expr
-        ]
-
-    | EXPR_Record (label, fields, result, in_expr) -> 
-        let elem (value, access) = psp_group
-            [ paint_value_expression value
-            ; psp_keyword "at"
-            ; paint_access_path access
-            ] in
-        psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "record"
-        ; psp_variable result
-        ; psp_operator "="
-        ; psp_list_map psp_std_bracket (psp_syntax ",") elem fields
-        ; psp_keyword "in"
-        ; psp_break
-        ; paint_expression in_expr
-        ]
-
-(*--------------------------------------------------------------------------------------------------------------------
- * Pretty printer for declaration
- *)
-
-let paint_declaration = function
-    | DECL_Fix (_, declarations)  ->
-        let handle_def (_, name, argument_variables, expression) aux =
-            [ psp_variable name
-            ; psp_group (List.map psp_variable argument_variables)
-            ; psp_operator "="
-            ; psp_indent (paint_expression expression)
-            ; psp_break
-            ; psp_newline
-            ] :: aux in
-        let result = Util.concat_intersperse' [psp_keyword "and"]  (List.fold_right handle_def declarations []) in
-        psp_group
-        [ psp_keyword "let"
-        ; psp_keyword "fix"
-        ; psp_group result
-        ; psp_break
-        ]
-
-(*--------------------------------------------------------------------------------------------------------------------
- * Pretty printer for program
- *)
-
-let paint_program = function
-    | PROGRAM declarations -> psp_group
-       (List.map paint_declaration declarations)
-

source/Languages/CWCPS/Lang_CWCPS/TransformationFramework.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Lib_Algebra.Monoid
-open Lang_Common
-open Batteries
-
-
-(*********************************************************************************************************************
- * Transformation
- ********************************************************************************************************************)
-
-type transformation_result
-    = NoChange
-    | Substitute of (variable * value_expression) list
-    | Replace of expression
-
-(*********************************************************************************************************************
- * Transformation
- ********************************************************************************************************************)
-let apply_on_subexpr f = function
-    | EXPR_App (label, fun_val, arg_vals) as tm ->
-        tm
-
-    | EXPR_Switch (label, sel_val, default_branch, branches) ->
-        EXPR_Switch (label, sel_val, f default_branch, List.map f branches)
-
-    | EXPR_Fix (reclabel, definitions, in_expr) ->
-        let f' (deflabel, defname, defargs, defexpr) = (deflabel, defname, defargs, f defexpr) in
-        EXPR_Fix (reclabel, List.map f' definitions, f in_expr)
-
-    | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-        EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, f in_expr)  
-
-    | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-        EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, f in_expr)
-
-    | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-        EXPR_ConditionPrimOp (label, primop, arg1, arg2, f then_branch, f else_branch) 
-
-    | EXPR_Offset (label, offset, arg, result, in_expr) ->
-        EXPR_Offset (label, offset, arg, result, f in_expr)
-
-    | EXPR_Select (label, offset, arg, result, in_expr) ->
-        EXPR_Select (label, offset, arg, result, f in_expr)
-
-    | EXPR_Record (label, fields, result, in_expr) ->
-        EXPR_Record (label, fields, result, f in_expr)
-
-(*********************************************************************************************************************
- * Internal
- ********************************************************************************************************************)
-
-let rec apply_transforms fs tm = 
-    match fs with
-        | [] ->
-            tm
-        | f::fs ->
-            match f tm with
-                | NoChange ->
-                    apply_transforms fs tm
-                | Substitute sb' ->
-                    let s = (subst sb' ) in
-                    apply_transforms fs (apply_on_subexpr s tm