Commits

Paweł Wieczorek  committed 610424c

Lang.While -> Lang_While

  • Participants
  • Parent commits c1616d2
  • Branches 2014_03_16_cleaning

Comments (0)

Files changed (16)

File source/Bin/Opifex/Main.ml

 open CWCPS_NaiveClosureConversion
 open CWACM_PrettyPrinter
 *)
-open Lang.While
+open Lang_While
 open Lang.CWCPS
 open CommandTree.Executor
 

File source/Command/WHILE_Commands.ml

 
 open Batteries
 open CommandTree.Type
-open Lang.While
+open Lang_While
 
 let lang_name = "while"
 

File source/Compiler/WhileX86Compiler.ml

 
 open Batteries
 
-module AST = Lang.While.AST
+module AST = Lang_While.AST
 open Machine.X86.Assembler
 
 (*********************************************************************************************************************

File source/Lang.mlpack

-While
 CWCPS
 TAC
 MiniML

File source/Lang/While.mlpack

-AST
-Eval
-PrettyPrinter
-Parser
-Lexer

File source/Lang/While/AST.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-include Lang_Common.AST
-
-(*********************************************************************************************************************
- * Abstract Syntax Tree
- *)
-
-type arithmetic_expression
-    = AE_Constant of int
-    | AE_Variable of variable
-    | AE_Call of identifier * arithmetic_expression list
-    | AE_BinaryOperator of arithmetic_binary_operator * arithmetic_expression * arithmetic_expression
-    | AE_UnaryOperator of arithmetic_unary_operator * arithmetic_expression
-
-
-type boolean_expression
-    = BE_Constant of bool
-    | BE_BinaryOperator of boolean_binary_operator * boolean_expression * boolean_expression
-    | BE_UnaryOperator of boolean_unary_operator * boolean_expression
-    | BE_ArithmeticBinaryOperator of boolean_arithmetic_binary_operator * arithmetic_expression * arithmetic_expression
-
-type type_expression
-    = TP_Int
-    | TP_Bool
-
-type command
-    = CMD_Skip
-    | CMD_Assign of variable * arithmetic_expression
-    | CMD_Compose of command * command
-    | CMD_If of boolean_expression * command * command
-    | CMD_While of boolean_expression * command
-    | CMD_Read of variable
-    | CMD_Write of variable
-    | CMD_Abort 
-    | CMD_Call of identifier * arithmetic_expression list
-    | CMD_Return of arithmetic_expression
-    | CMD_Throw of identifier
-    | CMD_Try of command * identifier * command
-
-type declaration
-    = DECL_Procedure of identifier * variable list * command
-
-type program
-    = PROGRAM of declaration list
-
-
-let eq_declaration decl1 decl2 = decl1 = decl2
-
-let eq_declarations decls1 decls2 =
-    let decls1 = List.sort compare decls1 in
-    let decls2 = List.sort compare decls2 in
-    if List.length decls1 = List.length decls2 then
-        List.for_all2 (eq_declaration) decls1 decls2
-    else
-        false
-
-
-let eq_program prog1 prog2 = match prog1, prog2 with
-    | PROGRAM decls1, PROGRAM decls2
-      when eq_declarations decls1 decls2 ->
-        true
-    | _ ->
-        false

File source/Lang/While/Eval.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Lang_Common
-
-(*********************************************************************************************************************
- * Value 
- ********************************************************************************************************************)
-
-type value
-    = VAL_Integer of int
-    | VAL_Boolean of bool
-
-let paint_value = function
-    | VAL_Integer v -> [ Formatter.psp_value_int v ]
-    | VAL_Boolean v -> [ Formatter.psp_value_bool v ]
-
-(*********************************************************************************************************************
- * Junk
- ********************************************************************************************************************)
-
-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)
-
-(*********************************************************************************************************************
- * Internal exceptions.
- ********************************************************************************************************************)
-
-exception Throwed_exception of identifier * (value Store.t)
-
-(*********************************************************************************************************************
- * Helpers.
- ********************************************************************************************************************)
-
-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 ->
-            EvalError.unknown_variable variable
-
-let store_get_arithmetic_value =
-    store_get_value
-        (fun _ v -> v)
-        (fun var _ -> EvalError.invalid_operation "expected an arithmetic value")
-
-let store_get_boolean_value =
-    store_get_value
-        (fun var _ -> EvalError.invalid_operation "expected a boolean value")
-        (fun _ v -> v)
-
-let wrap_exception2 f a1 a2 = 
-    try 
-        f a1 a2
-    with Throwed_exception(excid, _) ->
-        EvalError.uncaught_excepion excid None
-
-let wrap_exception3 f a1 a2 a3 = 
-    try 
-        f a1 a2 a3
-    with Throwed_exception(excid, _) ->
-        EvalError.uncaught_excepion excid None
-
-(*********************************************************************************************************************
- * Evaluator.
- ********************************************************************************************************************)
-
-module Evaluator = struct
-
-    (*------------------------------------------------------------------------------------------------
-     * Evaluate program.
-     *)
-
-    let rec eval_program store io_driver = function
-        | PROGRAM decls ->
-            let analyze_declaration decls = function
-                | DECL_Procedure (ident, formal_arguments, 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; ()
-
-    (*------------------------------------------------------------------------------------------------
-     * Evaluate 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 ->
-            EvalError.abnormal_termination "Abort command called"
-
-
-    (*------------------------------------------------------------------------------------------------
-     * Evaluate boolean expression.
-     *)
-
-    and eval_boolean_expression store = function
-        | BE_Constant constant ->
-            constant
-
-        | 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
-
-    (*------------------------------------------------------------------------------------------------
-     * Evaluate arithmetic expression.
-     *)
-    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
-
-    (*------------------------------------------------------------------------------------------------
-     * Evaluators operators.
-     *)
-    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 EvalError.invalid_operation "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)
-
-end
-
-(*------------------------------------------------------------------------------------------------
- * Wrappers.
- *)
-
-let eval_program = wrap_exception3
-    Evaluator.eval_program
-
-let eval_command = wrap_exception3
-    Evaluator.eval_command
-
-let eval_arithmetic_expression = wrap_exception2
-    Evaluator.eval_arithmetic_expression
-
-let eval_boolean_expression = wrap_exception2
-    Evaluator.eval_boolean_expression
-

File source/Lang/While/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
-        [ ("while", WHILE)
-        ; ("if", IF)
-        ; ("else", ELSE)
-        ; ("skip", SKIP)
-        ; ("read", READ)
-        ; ("write", WRITE)
-        ; ("abort", ABORT)
-        ; ("procedure", PROCEDURE)
-        ; ("not", OP_NOT)
-        ; ("and", OP_AND)
-        ; ("or", OP_OR)
-        ; ("true", TRUE)
-        ; ("false", FALSE)
-        ; ("return", RETURN)
-
-        ; ("throw", THROW)
-        ; ("try", TRY)
-        ; ("catch", CATCH)
-
-        ; ("Int", TP_INT)
-        ; ("Bool", TP_BOOL)
-        ]
-
-let operators = create_dictionary
-        [ ("{", CURL_OPEN)
-        ; ("}", CURL_CLOSE)
-        ; ("(", LPARENT)
-        ; (")", RPARENT)
-
-        ; (";", SEMICOLON)
-        ; (",", COMA)
-
-        ; (":=", ASSIGN)
-
-        ; ("+", OP_ADD)
-        ; ("-", OP_SUB)
-        ; ("*", OP_MUL)
-        ; ("/", OP_DIV)
-        ; ("%", OP_MOD)
-
-        ; ("<", OP_LT)
-        ; ("<=", OP_LEQ)
-        ; ("=", OP_EQ)
-        ; (">", OP_GT)
-        ; (">=", OP_GEQ)
-
-
-        ; ("&&", OP_AND)
-        ; ("||", OP_OR)
-        ]
-
-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 *)
-
-    | ['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 }

File source/Lang/While/Parser.mly

-%{
-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-
-
-let rec compute_ifs else_command = function
-    | [] ->
-        else_command
-
-    | x::xs ->
-        let (guard, then_command) = x in
-        let rest = compute_ifs else_command xs in
-        CMD_If (guard, then_command, rest)
-;;
-
-%}
-
-%token <int>    INT
-
-%start parse
-
-%type <AST.program> parse
-
-%token LPARENT
-%token RPARENT
-
-%token CURL_OPEN
-%token CURL_CLOSE
-%token SEMICOLON
-%token COMA
-
-%token ASSIGN
-%token OP_OR
-%token OP_AND
-%token OP_NOT
-
-%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 EOF
-
-%token PROCEDURE
-
-%token RETURN
-%token SKIP
-%token IF
-%token ELSE
-%token WHILE
-%token ABORT
-%token READ
-%token WRITE
-
-%token THROW
-%token TRY
-%token CATCH
-
-%token TRUE
-%token FALSE
-
-%token <string> STR
-
-%token TP_INT
-%token TP_BOOL
-
-%%
-
-identifier:
-    STR
-    { Identifier $1 }
-    ;
-
-variable:
-    identifier
-    { Variable $1 }
-    ;
-
-routine_call
-    : identifier LPARENT RPARENT
-    { ($1, [] ) }
-
-    | identifier LPARENT argument_list RPARENT
-    { ($1, $3 ) }
-    ;
-
-arithmetic_expression_basic
-    : INT
-    { AE_Constant $1 }
-
-    | variable
-    { AE_Variable $1 }
-
-    | routine_call
-    { AE_Call (fst $1, snd $1) }
-
-    | LPARENT arithmetic_expression RPARENT
-    { $2 }
-    ;
-
-boolean_expression_basic
-    : TRUE
-    { BE_Constant true }
-
-    | FALSE
-    { BE_Constant false }
-
-    | LPARENT boolean_expression RPARENT
-    { $2 }
-    ;
-
-multiplicative_arithmetic_expression
-    : arithmetic_expression_basic
-    { $1 }
-
-    | multiplicative_arithmetic_expression multiplicative_arithmetic_binary_operator arithmetic_expression_basic
-    { AE_BinaryOperator ($2, $1, $3) }
-    ;
-
-additive_arithmetic_expression
-    : multiplicative_arithmetic_expression 
-    { $1 }
-
-
-    | additive_arithmetic_expression additive_arithmetic_binary_operator multiplicative_arithmetic_expression
-    { AE_BinaryOperator ($2, $1, $3) }
-    ;
-
-arithmetic_expression
-    : additive_arithmetic_expression {$1}
-    ;
-
-boolean_expression
-    : boolean_expression_basic
-    { $1 }
-
-    | boolean_expression boolean_binary_operator boolean_expression_basic
-    { BE_BinaryOperator ($2, $1, $3) }
-
-    | arithmetic_expression boolean_arithmetic_binary_operator arithmetic_expression
-    { BE_ArithmeticBinaryOperator ($2, $1, $3) }
-    ;
-
-additive_arithmetic_binary_operator
-    : OP_ADD
-    { AOP_ADD }
-
-    | OP_SUB
-    { AOP_SUB }
-    ;
-
-multiplicative_arithmetic_binary_operator
-    : OP_MUL
-    { AOP_MUL }
-
-    | OP_DIV 
-    { AOP_DIV }
-
-    | OP_MOD
-    { AOP_MOD }
-
-    ;
-
-boolean_binary_operator
-    : OP_AND
-    { BOP_AND }
-
-    | OP_OR
-    { BOP_OR }
-    ;
-
-
-boolean_unary_operator
-    : OP_NOT
-    { BOP_NOT }
-    ;
-
-
-boolean_arithmetic_binary_operator
-    : OP_LT
-    { BOP_LT }
-
-    | OP_LEQ
-    { BOP_LEQ }
-
-    | OP_EQ
-    { BOP_EQ }
-
-    | OP_GT 
-    { BOP_GT }
-
-    | OP_GEQ
-    { BOP_GEQ }
-
-    | OP_NEQ
-    { BOP_NEQ }
-    ;
-
-type_expression
-    : TP_INT
-    { () }
-
-    | TP_BOOL
-    { () }
-    ;
-
-variable_declaration
-    : type_expression variable
-    { () }
-    ;
-
-commands
-    : CURL_OPEN command_list CURL_CLOSE
-    { $2 }
-    ;
-
-command
-    : command_basic SEMICOLON
-    { $1 }
-
-    | command_control 
-    { $1 }
-    ;
-
-    | variable_declaration SEMICOLON command
-    { $3 }
-    ;
-
-command_list
-    : command command_list 
-    { CMD_Compose ($1, $2) }
-
-    | command
-    { $1 }
-    ;
-
-variable_list
-    : variable COMA variable_list
-    { $1 :: $3 }
-
-    | variable
-    { [$1] }
-    ;
-
-
-argument_list
-    : arithmetic_expression COMA argument_list
-    { $1 :: $3 }
-
-    | arithmetic_expression
-    { [$1] }
-    ;
-
-command_basic
-    : SKIP 
-    { CMD_Skip }
-
-    | variable ASSIGN arithmetic_expression
-    { CMD_Assign ($1, $3) }
-
-    | type_expression variable ASSIGN arithmetic_expression
-    { CMD_Assign ($2, $4) }
-
-    | READ variable
-    { CMD_Read $2 }
-
-    | WRITE variable
-    { CMD_Write $2 }
-
-    | ABORT
-    { CMD_Abort }
-
-    | THROW identifier
-    { CMD_Throw $2 }
-
-    | routine_call
-    { CMD_Call (fst $1, snd $1) }
-
-    | RETURN arithmetic_expression
-    { CMD_Return $2 }
-    ;
-
-guarded_commands
-    : LPARENT boolean_expression RPARENT
-        commands
-    { ($2, $4) }
-    ;
-
-
-command_control
-    : command_basic
-    { $1 }
-
-    | IF guarded_commands
-    {  let (cond, then_cmds) = $2
-    in CMD_If (cond, then_cmds, CMD_Skip) }
-
-    | IF guarded_commands
-      ELSE commands
-    {  let (cond, then_cmds) = $2
-    in CMD_If (cond, then_cmds, $4) }
-
-
-    | WHILE LPARENT boolean_expression RPARENT
-        commands
-    { CMD_While ($3, $5) }
-
-    | TRY commands CATCH identifier commands
-    { CMD_Try ($2, $4, $5) }
-    ;
-
-
-declaration
-    : PROCEDURE identifier LPARENT RPARENT
-        commands 
-    { DECL_Procedure ($2, [], $5) } 
-
-    | PROCEDURE identifier LPARENT variable_list RPARENT
-        commands 
-    { DECL_Procedure ($2, $4, $6) } 
-    ;
-
-declarations
-    : declaration 
-    { [ $1 ] }
-
-    | declaration declarations
-    { $1 :: $2  }
-    ;
-
-program
-    : declarations 
-    { PROGRAM $1 }
-
-
-parse
-    : program EOF
-    { $1 }
-%% 
-

File source/Lang/While/PrettyPrinter.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open Lang_Common
-open Formatter
-open Batteries
-open Formatter
-
-(*********************************************************************************************************************
- * Priorities for string painter
- *)
-
-(* Arithmetic binary operator *)
-
-let arithmetic_binary_operator_priority = function
-    | AOP_ADD -> 6
-    | AOP_SUB -> 6
-    | AOP_MUL -> 7
-    | AOP_DIV -> 7
-    | AOP_MOD -> 7
-
-let arithmetic_binary_operator_associativity = function
-    | _ -> LeftAssociative
-
-
-(* Arithmetic unary operator *)
-
-let arithmetic_unary_operator_priority = function
-    | _ -> 5
-
-(* Boolean binary operator *)
-let boolean_arithmetic_binary_operator_priority = function
-    | _       -> 5
-
-let boolean_arithmetic_binary_operator_associativity = function
-    | _ -> LeftAssociative
-
-(* Boolean binary operator *)
-
-let boolean_binary_operator_priority = function
-    | BOP_AND -> 4
-    | BOP_OR  -> 3
-
-let boolean_binary_operator_associativity = function
-    | _ -> LeftAssociative
-
-
-(* Boolean binary operator *)
-let boolean_unary_operator_priority = function
-    | _       -> 2
-
-(*********************************************************************************************************************
- * Priorities for string painter
- *)
-
-let boolean_expression_priority = function
-    | BE_Constant _ ->
-        psp_max_priority
-
-    | BE_BinaryOperator (operator, _, _) ->
-        boolean_binary_operator_priority operator
-
-    | BE_UnaryOperator (operator, _) ->
-        boolean_unary_operator_priority operator
-
-    | BE_ArithmeticBinaryOperator (operator, _, _) ->
-        boolean_arithmetic_binary_operator_priority operator
-
-
-let arithmetic_expression_priority = function
-    | AE_Constant constant ->
-        psp_max_priority
-
-    | AE_Call (_, _) -> psp_max_priority
-
-    | AE_Variable variable ->
-        psp_max_priority
-
-    | AE_BinaryOperator (arithmetic_operator, first_expression, second_expression) ->
-        arithmetic_binary_operator_priority arithmetic_operator
-
-    | AE_UnaryOperator (arithmetic_operator, expression) ->
-        arithmetic_unary_operator_priority arithmetic_operator
-
-
-(*********************************************************************************************************************
- * Painters
- *)
-
-let rec paint_program = function
-    | PROGRAM decls ->
-        psp_group (List.map paint_declaration decls)
-
-and paint_declaration = function
-    | DECL_Procedure (ident, formal_arguments, command) -> psp_group
-        [ psp_keyword "procedure"
-        ; psp_identifier ident
-        ; psp_list_map psp_std_bracket (psp_syntax ",") psp_variable formal_arguments
-        ; psp_break
-        ; psp_syntax "{"
-        ; psp_break
-        ; psp_indent (paint_command command)
-        ; psp_syntax "}"
-        ; psp_break
-        ]
-
-and paint_call (identifier, arguments) = psp_group
-        [ psp_identifier identifier
-        ; psp_list_map psp_std_bracket (psp_syntax ",") paint_arithmetic_expression arguments
-        ]
-
-
-and paint_command = function
-    | CMD_Skip -> psp_group
-        [ psp_keyword "skip"
-        ; psp_syntax ";"
-        ]
-
-    | CMD_Assign (variable, arithmetic_expression) -> psp_group
-        [ psp_variable variable
-        ; psp_operator ":="
-        ; paint_arithmetic_expression arithmetic_expression
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Return arithmetic_expression -> psp_group
-        [ psp_keyword "return"
-        ; paint_arithmetic_expression arithmetic_expression
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Call (identifier, arguments) -> psp_group
-        [ paint_call (identifier, arguments)
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Compose (first_command, second_command) -> psp_group
-        [ paint_command first_command
-        ; paint_command second_command
-        ]
-
-    | CMD_If (condition_expression, then_command, CMD_Skip ) -> psp_group
-        [ psp_keyword "if"
-        ; psp_syntax "("
-        ; paint_boolean_expression condition_expression
-        ; psp_syntax ")"
-        ; psp_syntax "{"
-        ; psp_indent (paint_command then_command)
-        ; psp_syntax "}"
-        ; psp_break
-        ]
-
-    | CMD_If (condition_expression, then_command, else_command) -> psp_group
-        [ psp_keyword "if"
-        ; psp_syntax "("
-        ; paint_boolean_expression condition_expression
-        ; psp_syntax ")"
-        ; psp_syntax "{"
-        ; psp_indent (paint_command then_command)
-        ; psp_syntax "}"
-        ; psp_keyword "else"
-        ; psp_syntax "{"
-        ; psp_indent (paint_command else_command)
-        ; psp_syntax "}"
-        ; psp_break
-        ]
-
-    | CMD_While (condition_expression, body_command) -> psp_group
-        [ psp_keyword "while"
-        ; psp_syntax "("
-        ; paint_boolean_expression condition_expression
-        ; psp_syntax ")"
-        ; psp_syntax "{"
-        ; psp_indent (paint_command body_command)
-        ; psp_syntax "}"
-        ; psp_break
-        ]
-
-    | CMD_Read variable -> psp_group
-        [ psp_keyword "read"
-        ; psp_variable variable
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Write variable -> psp_group
-        [ psp_keyword "write"
-        ; psp_variable variable
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Abort -> psp_group
-        [ psp_keyword "abort"
-        ; psp_syntax ";"
-        ; psp_break
-        ]
-
-    | CMD_Throw exception_identifier -> psp_group
-        [ psp_keyword "throw"
-        ; psp_label (string_of_identifier exception_identifier)
-        ; psp_syntax ";"
-        ]
-
-    | CMD_Try (try_command, catched_exception, catch_command) -> psp_group
-        [ psp_keyword "try"
-        ; psp_syntax "{"
-        ; psp_indent (paint_command try_command)
-        ; psp_syntax "}"
-        ; psp_keyword "catch"
-        ; psp_label (string_of_identifier catched_exception)
-        ; psp_syntax "{"
-        ; psp_indent (paint_command catch_command)
-        ; psp_syntax "}"
-        ; psp_break;
-        ]
-
-and paint_arithmetic_expression expr = 
-    psp_correct_priority_after arithmetic_expression_priority _paint_arithmetic_expression expr
-
-and _paint_arithmetic_expression = function
-    | AE_Constant constant -> psp_group
-        [ psp_value_int constant
-        ]
-
-    | AE_Variable variable -> psp_group
-        [ psp_variable variable
-        ]
-
-    | AE_Call (identifier, arguments) -> psp_group
-        [ paint_call (identifier, arguments)
-        ]
-
-    | AE_BinaryOperator (arithmetic_operator, first_expression, second_expression) ->
-        psp_gen_infix
-            arithmetic_binary_operator_associativity
-            arithmetic_binary_operator_priority
-            psp_arithmetic_binary_operator 
-            arithmetic_operator
-            (paint_arithmetic_expression first_expression)
-            (paint_arithmetic_expression second_expression)
-
-    | AE_UnaryOperator (arithmetic_operator, expression) -> psp_group
-        [ psp_arithmetic_unary_operator arithmetic_operator
-        ; paint_arithmetic_expression expression
-        ]
-
-and paint_boolean_expression expr =
-    psp_correct_priority_after boolean_expression_priority _paint_boolean_expression expr
-
-and _paint_boolean_expression = function
-    | BE_Constant constant -> psp_group
-        [ psp_value_bool constant
-        ]
-
-    | BE_BinaryOperator (boolean_operator, first_expression, second_expression) -> 
-        psp_gen_infix
-            boolean_binary_operator_associativity
-            boolean_binary_operator_priority
-            psp_boolean_binary_operator 
-            boolean_operator
-            (paint_boolean_expression first_expression)
-            (paint_boolean_expression second_expression)
-
-    | BE_UnaryOperator (boolean_operator, expression) -> psp_group
-        [ psp_boolean_unary_operator boolean_operator
-        ; paint_boolean_expression expression
-        ]
-
-    | BE_ArithmeticBinaryOperator (boolean_operator, first_expression, second_expression) -> 
-        psp_gen_infix
-            boolean_arithmetic_binary_operator_associativity
-            boolean_arithmetic_binary_operator_priority
-            psp_boolean_arithmetic_binary_operator 
-            boolean_operator
-            (paint_arithmetic_expression first_expression)
-            (paint_arithmetic_expression second_expression)
-

File source/Lang_While.mlpack

+AST
+Eval
+PrettyPrinter
+Parser
+Lexer

File source/Lang_While/AST.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+include Lang_Common.AST
+
+(*********************************************************************************************************************
+ * Abstract Syntax Tree
+ *)
+
+type arithmetic_expression
+    = AE_Constant of int
+    | AE_Variable of variable
+    | AE_Call of identifier * arithmetic_expression list
+    | AE_BinaryOperator of arithmetic_binary_operator * arithmetic_expression * arithmetic_expression
+    | AE_UnaryOperator of arithmetic_unary_operator * arithmetic_expression
+
+
+type boolean_expression
+    = BE_Constant of bool
+    | BE_BinaryOperator of boolean_binary_operator * boolean_expression * boolean_expression
+    | BE_UnaryOperator of boolean_unary_operator * boolean_expression
+    | BE_ArithmeticBinaryOperator of boolean_arithmetic_binary_operator * arithmetic_expression * arithmetic_expression
+
+type type_expression
+    = TP_Int
+    | TP_Bool
+
+type command
+    = CMD_Skip
+    | CMD_Assign of variable * arithmetic_expression
+    | CMD_Compose of command * command
+    | CMD_If of boolean_expression * command * command
+    | CMD_While of boolean_expression * command
+    | CMD_Read of variable
+    | CMD_Write of variable
+    | CMD_Abort 
+    | CMD_Call of identifier * arithmetic_expression list
+    | CMD_Return of arithmetic_expression
+    | CMD_Throw of identifier
+    | CMD_Try of command * identifier * command
+
+type declaration
+    = DECL_Procedure of identifier * variable list * command
+
+type program
+    = PROGRAM of declaration list
+
+
+let eq_declaration decl1 decl2 = decl1 = decl2
+
+let eq_declarations decls1 decls2 =
+    let decls1 = List.sort compare decls1 in
+    let decls2 = List.sort compare decls2 in
+    if List.length decls1 = List.length decls2 then
+        List.for_all2 (eq_declaration) decls1 decls2
+    else
+        false
+
+
+let eq_program prog1 prog2 = match prog1, prog2 with
+    | PROGRAM decls1, PROGRAM decls2
+      when eq_declarations decls1 decls2 ->
+        true
+    | _ ->
+        false

File source/Lang_While/Eval.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open AST
+open Lang_Common
+
+(*********************************************************************************************************************
+ * Value 
+ ********************************************************************************************************************)
+
+type value
+    = VAL_Integer of int
+    | VAL_Boolean of bool
+
+let paint_value = function
+    | VAL_Integer v -> [ Formatter.psp_value_int v ]
+    | VAL_Boolean v -> [ Formatter.psp_value_bool v ]
+
+(*********************************************************************************************************************
+ * Junk
+ ********************************************************************************************************************)
+
+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)
+
+(*********************************************************************************************************************
+ * Internal exceptions.
+ ********************************************************************************************************************)
+
+exception Throwed_exception of identifier * (value Store.t)
+
+(*********************************************************************************************************************
+ * Helpers.
+ ********************************************************************************************************************)
+
+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 ->
+            EvalError.unknown_variable variable
+
+let store_get_arithmetic_value =
+    store_get_value
+        (fun _ v -> v)
+        (fun var _ -> EvalError.invalid_operation "expected an arithmetic value")
+
+let store_get_boolean_value =
+    store_get_value
+        (fun var _ -> EvalError.invalid_operation "expected a boolean value")
+        (fun _ v -> v)
+
+let wrap_exception2 f a1 a2 = 
+    try 
+        f a1 a2
+    with Throwed_exception(excid, _) ->
+        EvalError.uncaught_excepion excid None
+
+let wrap_exception3 f a1 a2 a3 = 
+    try 
+        f a1 a2 a3
+    with Throwed_exception(excid, _) ->
+        EvalError.uncaught_excepion excid None
+
+(*********************************************************************************************************************
+ * Evaluator.
+ ********************************************************************************************************************)
+
+module Evaluator = struct
+
+    (*------------------------------------------------------------------------------------------------
+     * Evaluate program.
+     *)
+
+    let rec eval_program store io_driver = function
+        | PROGRAM decls ->
+            let analyze_declaration decls = function
+                | DECL_Procedure (ident, formal_arguments, 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; ()
+
+    (*------------------------------------------------------------------------------------------------
+     * Evaluate 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 ->
+            EvalError.abnormal_termination "Abort command called"
+
+
+    (*------------------------------------------------------------------------------------------------
+     * Evaluate boolean expression.
+     *)
+
+    and eval_boolean_expression store = function
+        | BE_Constant constant ->
+            constant
+
+        | 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
+
+    (*------------------------------------------------------------------------------------------------
+     * Evaluate arithmetic expression.
+     *)
+    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
+
+    (*------------------------------------------------------------------------------------------------
+     * Evaluators operators.
+     *)
+    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 EvalError.invalid_operation "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)
+
+end
+
+(*------------------------------------------------------------------------------------------------
+ * Wrappers.
+ *)
+
+let eval_program = wrap_exception3
+    Evaluator.eval_program
+
+let eval_command = wrap_exception3
+    Evaluator.eval_command
+
+let eval_arithmetic_expression = wrap_exception2
+    Evaluator.eval_arithmetic_expression
+
+let eval_boolean_expression = wrap_exception2
+    Evaluator.eval_boolean_expression
+

File source/Lang_While/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
+        [ ("while", WHILE)
+        ; ("if", IF)
+        ; ("else", ELSE)
+        ; ("skip", SKIP)
+        ; ("read", READ)
+        ; ("write", WRITE)
+        ; ("abort", ABORT)
+        ; ("procedure", PROCEDURE)
+        ; ("not", OP_NOT)
+        ; ("and", OP_AND)
+        ; ("or", OP_OR)
+        ; ("true", TRUE)
+        ; ("false", FALSE)
+        ; ("return", RETURN)
+
+        ; ("throw", THROW)
+        ; ("try", TRY)
+        ; ("catch", CATCH)
+
+        ; ("Int", TP_INT)
+        ; ("Bool", TP_BOOL)
+        ]
+
+let operators = create_dictionary
+        [ ("{", CURL_OPEN)
+        ; ("}", CURL_CLOSE)
+        ; ("(", LPARENT)
+        ; (")", RPARENT)
+
+        ; (";", SEMICOLON)
+        ; (",", COMA)
+
+        ; (":=", ASSIGN)
+
+        ; ("+", OP_ADD)
+        ; ("-", OP_SUB)
+        ; ("*", OP_MUL)
+        ; ("/", OP_DIV)
+        ; ("%", OP_MOD)
+
+        ; ("<", OP_LT)
+        ; ("<=", OP_LEQ)
+        ; ("=", OP_EQ)
+        ; (">", OP_GT)
+        ; (">=", OP_GEQ)
+
+
+        ; ("&&", OP_AND)
+        ; ("||", OP_OR)
+        ]
+
+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 *)
+
+    | ['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 }

File source/Lang_While/Parser.mly

+%{
+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open AST
+
+
+let rec compute_ifs else_command = function
+    | [] ->
+        else_command
+
+    | x::xs ->
+        let (guard, then_command) = x in
+        let rest = compute_ifs else_command xs in
+        CMD_If (guard, then_command, rest)
+;;
+
+%}
+
+%token <int>    INT
+
+%start parse
+
+%type <AST.program> parse
+
+%token LPARENT
+%token RPARENT
+
+%token CURL_OPEN
+%token CURL_CLOSE
+%token SEMICOLON
+%token COMA
+
+%token ASSIGN
+%token OP_OR
+%token OP_AND
+%token OP_NOT
+
+%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 EOF
+
+%token PROCEDURE
+
+%token RETURN
+%token SKIP
+%token IF
+%token ELSE
+%token WHILE
+%token ABORT
+%token READ
+%token WRITE
+
+%token THROW
+%token TRY
+%token CATCH
+
+%token TRUE
+%token FALSE
+
+%token <string> STR
+
+%token TP_INT
+%token TP_BOOL
+
+%%
+
+identifier:
+    STR
+    { Identifier $1 }
+    ;
+
+variable:
+    identifier
+    { Variable $1 }
+    ;
+
+routine_call
+    : identifier LPARENT RPARENT
+    { ($1, [] ) }
+
+    | identifier LPARENT argument_list RPARENT
+    { ($1, $3 ) }
+    ;
+
+arithmetic_expression_basic
+    : INT
+    { AE_Constant $1 }
+
+    | variable
+    { AE_Variable $1 }
+
+    | routine_call
+    { AE_Call (fst $1, snd $1) }
+
+    | LPARENT arithmetic_expression RPARENT
+    { $2 }
+    ;
+
+boolean_expression_basic
+    : TRUE
+    { BE_Constant true }
+
+    | FALSE
+    { BE_Constant false }
+
+    | LPARENT boolean_expression RPARENT
+    { $2 }
+    ;
+
+multiplicative_arithmetic_expression
+    : arithmetic_expression_basic
+    { $1 }
+
+    | multiplicative_arithmetic_expression multiplicative_arithmetic_binary_operator arithmetic_expression_basic
+    { AE_BinaryOperator ($2, $1, $3) }
+    ;
+
+additive_arithmetic_expression
+    : multiplicative_arithmetic_expression 
+    { $1 }
+
+
+    | additive_arithmetic_expression additive_arithmetic_binary_operator multiplicative_arithmetic_expression
+    { AE_BinaryOperator ($2, $1, $3) }
+    ;
+
+arithmetic_expression
+    : additive_arithmetic_expression {$1}
+    ;
+
+boolean_expression
+    : boolean_expression_basic
+    { $1 }
+
+    | boolean_expression boolean_binary_operator boolean_expression_basic
+    { BE_BinaryOperator ($2, $1, $3) }
+
+    | arithmetic_expression boolean_arithmetic_binary_operator arithmetic_expression
+    { BE_ArithmeticBinaryOperator ($2, $1, $3) }
+    ;
+
+additive_arithmetic_binary_operator
+    : OP_ADD
+    { AOP_ADD }
+
+    | OP_SUB
+    { AOP_SUB }
+    ;
+
+multiplicative_arithmetic_binary_operator
+    : OP_MUL
+    { AOP_MUL }
+
+    | OP_DIV 
+    { AOP_DIV }
+
+    | OP_MOD
+    { AOP_MOD }
+
+    ;
+
+boolean_binary_operator
+    : OP_AND
+    { BOP_AND }
+
+    | OP_OR
+    { BOP_OR }
+    ;
+
+
+boolean_unary_operator
+    : OP_NOT
+    { BOP_NOT }
+    ;
+
+
+boolean_arithmetic_binary_operator
+    : OP_LT
+    { BOP_LT }
+
+    | OP_LEQ
+    { BOP_LEQ }
+
+    | OP_EQ
+    { BOP_EQ }
+
+    | OP_GT 
+    { BOP_GT }
+
+    | OP_GEQ
+    { BOP_GEQ }
+
+    | OP_NEQ
+    { BOP_NEQ }
+    ;
+
+type_expression
+    : TP_INT
+    { () }
+
+    | TP_BOOL
+    { () }
+    ;
+
+variable_declaration
+    : type_expression variable
+    { () }
+    ;
+
+commands
+    : CURL_OPEN command_list CURL_CLOSE
+    { $2 }
+    ;
+
+command
+    : command_basic SEMICOLON
+    { $1 }
+
+    | command_control 
+    { $1 }
+    ;
+
+    | variable_declaration SEMICOLON command
+    { $3 }
+    ;
+
+command_list
+    : command command_list 
+    { CMD_Compose ($1, $2) }
+
+    | command
+    { $1 }
+    ;
+
+variable_list
+    : variable COMA variable_list
+    { $1 :: $3 }
+
+    | variable
+    { [$1] }
+    ;
+
+
+argument_list
+    : arithmetic_expression COMA argument_list
+    { $1 :: $3 }
+
+    | arithmetic_expression
+    { [$1] }
+    ;
+
+command_basic
+    : SKIP 
+    { CMD_Skip }
+
+    | variable ASSIGN arithmetic_expression
+    { CMD_Assign ($1, $3) }
+
+    | type_expression variable ASSIGN arithmetic_expression
+    { CMD_Assign ($2, $4) }
+
+    | READ variable
+    { CMD_Read $2 }
+
+    | WRITE variable
+    { CMD_Write $2 }
+
+    | ABORT
+    { CMD_Abort }
+
+    | THROW identifier
+    { CMD_Throw $2 }
+
+    | routine_call
+    { CMD_Call (fst $1, snd $1) }
+
+    | RETURN arithmetic_expression
+    { CMD_Return $2 }
+    ;
+
+guarded_commands
+    : LPARENT boolean_expression RPARENT
+        commands
+    { ($2, $4) }
+    ;
+
+
+command_control
+    : command_basic
+    { $1 }
+
+    | IF guarded_commands
+    {  let (cond, then_cmds) = $2
+    in CMD_If (cond, then_cmds, CMD_Skip) }
+
+    | IF guarded_commands
+      ELSE commands
+    {  let (cond, then_cmds) = $2
+    in CMD_If (cond, then_cmds, $4) }
+
+
+    | WHILE LPARENT boolean_expression RPARENT
+        commands
+    { CMD_While ($3, $5) }
+
+    | TRY commands CATCH identifier commands
+    { CMD_Try ($2, $4, $5) }
+    ;
+
+
+declaration
+    : PROCEDURE identifier LPARENT RPARENT
+        commands 
+    { DECL_Procedure ($2, [], $5) } 
+
+    | PROCEDURE identifier LPARENT variable_list RPARENT
+        commands 
+    { DECL_Procedure ($2, $4, $6) } 
+    ;
+
+declarations
+    : declaration 
+    { [ $1 ] }
+
+    | declaration declarations
+    { $1 :: $2  }
+    ;
+
+program
+    : declarations 
+    { PROGRAM $1 }
+
+
+parse
+    : program EOF
+    { $1 }
+%% 
+

File source/Lang_While/PrettyPrinter.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open AST
+open Lang_Common
+open Formatter
+open Batteries
+open Formatter
+
+(*********************************************************************************************************************
+ * Priorities for string painter
+ *)
+
+(* Arithmetic binary operator *)
+
+let arithmetic_binary_operator_priority = function
+    | AOP_ADD -> 6
+    | AOP_SUB -> 6
+    | AOP_MUL -> 7
+    | AOP_DIV -> 7
+    | AOP_MOD -> 7
+
+let arithmetic_binary_operator_associativity = function
+    | _ -> LeftAssociative
+
+
+(* Arithmetic unary operator *)
+
+let arithmetic_unary_operator_priority = function
+    | _ -> 5
+
+(* Boolean binary operator *)
+let boolean_arithmetic_binary_operator_priority = function
+    | _       -> 5
+
+let boolean_arithmetic_binary_operator_associativity = function
+    | _ -> LeftAssociative
+
+(* Boolean binary operator *)
+
+let boolean_binary_operator_priority = function
+    | BOP_AND -> 4
+    | BOP_OR  -> 3
+
+let boolean_binary_operator_associativity = function
+    | _ -> LeftAssociative
+
+
+(* Boolean binary operator *)
+let boolean_unary_operator_priority = function
+    | _       -> 2
+
+(*********************************************************************************************************************
+ * Priorities for string painter
+ *)
+
+let boolean_expression_priority = function
+    | BE_Constant _ ->
+        psp_max_priority
+
+    | BE_BinaryOperator (operator, _, _) ->
+        boolean_binary_operator_priority operator
+
+    | BE_UnaryOperator (operator, _) ->
+        boolean_unary_operator_priority operator
+
+    | BE_ArithmeticBinaryOperator (operator, _, _) ->
+        boolean_arithmetic_binary_operator_priority operator
+
+
+let arithmetic_expression_priority = function
+    | AE_Constant constant ->
+        psp_max_priority
+
+    | AE_Call (_, _) -> psp_max_priority
+
+    | AE_Variable variable ->
+        psp_max_priority
+
+    | AE_BinaryOperator (arithmetic_operator, first_expression, second_expression) ->
+        arithmetic_binary_operator_priority arithmetic_operator
+
+    | AE_UnaryOperator (arithmetic_operator, expression) ->
+        arithmetic_unary_operator_priority arithmetic_operator
+
+
+(*********************************************************************************************************************
+ * Painters
+ *)
+
+let rec paint_program = function
+    | PROGRAM decls ->
+        psp_group (List.map paint_declaration decls)
+
+and paint_declaration = function
+    | DECL_Procedure (ident, formal_arguments, command) -> psp_group
+        [ psp_keyword "procedure"
+        ; psp_identifier ident
+        ; psp_list_map psp_std_bracket (psp_syntax ",") psp_variable formal_arguments
+        ; psp_break
+        ; psp_syntax "{"
+        ; psp_break
+        ; psp_indent (paint_command command)
+        ; psp_syntax "}"
+        ; psp_break
+        ]
+
+and paint_call (identifier, arguments) = psp_group
+        [ psp_identifier identifier
+        ; psp_list_map psp_std_bracket (psp_syntax ",") paint_arithmetic_expression arguments
+        ]
+
+
+and paint_command = function
+    | CMD_Skip -> psp_group
+        [ psp_keyword "skip"
+        ; psp_syntax ";"
+        ]
+
+    | CMD_Assign (variable, arithmetic_expression) -> psp_group
+        [ psp_variable variable
+        ; psp_operator ":="
+        ; paint_arithmetic_expression arithmetic_expression
+        ; psp_syntax ";"
+        ; psp_break
+        ]
+
+    | CMD_Return arithmetic_expression -> psp_group
+        [ psp_keyword "return"
+        ; paint_arithmetic_expression arithmetic_expression
+        ; psp_syntax ";"
+        ; psp_break
+        ]
+
+    | CMD_Call (identifier, arguments) -> psp_group
+        [ paint_call (identifier, arguments)
+        ; psp_syntax ";"
+        ; psp_break
+        ]
+
+    | CMD_Compose (first_command, second_command) -> psp_group
+        [ paint_command first_command
+        ; paint_command second_command
+        ]
+
+    | CMD_If (condition_expression, then_command, CMD_Skip ) -> psp_group
+        [ psp_keyword "if"
+        ; psp_syntax "("
+        ; paint_boolean_expression condition_expression
+        ; psp_syntax ")"
+        ; psp_syntax "{"
+        ; psp_indent (paint_command then_command)
+        ; psp_syntax "}"
+        ; psp_break
+        ]
+
+    | CMD_If (condition_expression, then_command, else_command) -> psp_group
+        [ psp_keyword "if"
+        ; psp_syntax "("
+        ; paint_boolean_expression condition_expression
+        ; psp_syntax ")"
+        ; psp_syntax "{"
+        ; psp_indent (paint_command then_command)
+        ; psp_syntax "}"
+        ; psp_keyword "else"
+        ; psp_syntax "{"
+        ; psp_indent (paint_command else_command)
+        ; psp_syntax "}"
+        ; psp_break
+        ]
+
+    | CMD_While (condition_expression, body_command) -> psp_group
+        [ psp_keyword "while"
+        ; psp_syntax "("
+        ; paint_boolean_expression condition_expression
+        ; psp_syntax ")"
+        ; psp_syntax "{"
+        ; psp_indent (paint_command body_command)
+        ; psp_syntax "}"
+        ; psp_break
+        ]
+
+    | CMD_Read variable -> psp_group
+        [ psp_keyword "read"
+        ; psp_variable variable