Source

Opifex / src / Language / While / While_Eval.ml

Full commit
(*
 * Opifex
 *
 * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
 *)

open While_AST

type value
    = VAL_Integer of int
    | VAL_Boolean of bool

let show_value = function
    | VAL_Integer v -> [ Formatter.psp_value_int v ]
    | VAL_Boolean v -> [ Formatter.psp_value_bool v ]

type input_func = unit -> value
type output_func = value -> unit
type input_output_driver = input_func * output_func

let io_read io_driver = fst io_driver ()
let io_write io_driver value = snd io_driver value
(*type store = value Store.t*)
type decls = (identifier, command) Hashtbl.t

let standard_io_driver = 
    let _read () = VAL_Integer (print_string "> "; read_int ()) in
    let _write = function
        | VAL_Integer v ->
            print_int v; print_newline ()
        | VAL_Boolean v ->
            print_string "b"
        in
    (_read, _write)

exception Invalid_value of variable
exception Unknown_variable of variable
exception Division_by_zero
exception Aborted of (value Store.t)
exception Throwed_exception of identifier * (value Store.t)

let store_get_value for_arithmetic for_boolean store variable =
    try
        match (Store.fetch_variable store variable) with
            | VAL_Integer v -> for_arithmetic variable v
            | VAL_Boolean v -> for_boolean variable v
    with 
        Not_found -> raise (Unknown_variable variable)

let store_get_arithmetic_value =
    store_get_value
        (fun _ v -> v)
        (fun var _ -> raise (Invalid_value var))

let store_get_boolean_value =
    store_get_value
        (fun var _ -> raise (Invalid_value var))
        (fun _ v -> v)

let rec eval_program store io_driver = function
    | PROGRAM decls ->
        let analyze_declaration decls = function
            | DECL_Procedure (ident, command) ->
                Hashtbl.replace decls ident command; decls

        in let analyzed_declarations = List.fold_left analyze_declaration (Hashtbl.create 128) decls

        in let main_command = Hashtbl.find analyzed_declarations (Identifier "main")

        in eval_command io_driver store main_command; ()

and eval_command io_driver store = function
    | CMD_Skip ->
        ()

    | CMD_Assign (variable, arithmetic_expression) ->
        let value = eval_arithmetic_expression store arithmetic_expression in
        Store.store_variable store variable (VAL_Integer value)

    | CMD_Read variable ->
        let value = io_read io_driver
        in Store.store_variable store variable value

    | CMD_Write variable ->
        io_write io_driver (Store.fetch_variable store variable)

    | CMD_Throw identifier ->
        raise (Throwed_exception (identifier, store))

    | CMD_Try (command, exception_identifier, catch_command) ->
        begin try
            eval_command io_driver store command
        with
            | Throwed_exception (e, _) when e = exception_identifier ->
                eval_command io_driver store catch_command
        end

    | CMD_If (boolean_expression, then_command, else_command) ->
        if eval_boolean_expression store boolean_expression
            then eval_command io_driver store then_command
            else eval_command io_driver store else_command

    | CMD_While (boolean_expression, body_command) as while_command ->
        let positive_command = CMD_Compose (body_command, while_command)
        in let equivalent_command = CMD_If (boolean_expression, positive_command, CMD_Skip)
        in eval_command io_driver store equivalent_command

    | CMD_Compose (first_command, second_command) ->
        eval_command io_driver store first_command;
        eval_command io_driver store second_command

    | CMD_Abort ->
        raise (Aborted store)


and eval_boolean_expression store = function
    | BE_Constant constant ->
        constant

    | BE_Variable variable ->
        store_get_boolean_value store variable 

    | BE_BinaryOperator (boolean_op, first_expression, second_expression) ->
        let     first_value = eval_boolean_expression store first_expression
        in let second_value = eval_boolean_expression store second_expression
        in let         func = eval_boolean_binary_operator boolean_op
        in func first_value second_value

    | BE_UnaryOperator (boolean_op, expression) ->
        let     value   = eval_boolean_expression store expression
        in let func     = eval_boolean_unary_operator boolean_op
        in func value

    | BE_ArithmeticBinaryOperator (boolean_op, first_expression, second_expression) ->
        let     first_value = eval_arithmetic_expression store first_expression
        in let second_value = eval_arithmetic_expression store second_expression
        in let         func = eval_boolean_arithmetic_binary_operator boolean_op
        in func first_value second_value

and eval_arithmetic_expression store = function
    | AE_Constant constant ->
        constant

    | AE_Variable variable ->
        store_get_arithmetic_value store variable

    | AE_BinaryOperator (arithmetic_op, first_expression, second_expression) ->
        let     first_value = eval_arithmetic_expression store first_expression
        in let second_value = eval_arithmetic_expression store second_expression
        in let         func = eval_arithmetic_binary_operator arithmetic_op
        in func first_value second_value

    | AE_UnaryOperator (arithmetic_op, expression) ->
        let     value   = eval_arithmetic_expression store expression
        in let func     = eval_arithmetic_unary_operator arithmetic_op
        in func value

and eval_boolean_binary_operator = function
    | BOP_AND -> (&&)
    | BOP_OR  -> (||)

and eval_boolean_unary_operator = function
    | BOP_NOT -> (not)

and eval_boolean_arithmetic_binary_operator = function
    | BOP_LT -> (<)
    | BOP_LEQ -> (<=)
    | BOP_EQ -> (=)
    | BOP_GT -> (>)
    | BOP_GEQ -> (>=)
    | BOP_NEQ -> (!=)

and eval_arithmetic_binary_operator = function
    | AOP_ADD -> (+)
    | AOP_SUB -> (-)
    | AOP_MUL -> (fun a b -> a*b)
    | AOP_DIV -> (fun a b -> if b = 0 then raise Division_by_zero else a / b)
    | AOP_MOD -> (fun a b -> a mod b)

and eval_arithmetic_unary_operator = function
    | AOP_NEG -> (fun a -> -a)