Commits

Paweł Wieczorek  committed 4d93945 Merge

merge, added WhileToyCompiler

  • Participants
  • Parent commits 9a9f6e5, 8546c1f

Comments (0)

Files changed (18)

File runtime/prostak/prostak.c

 
 extern void MANGLE_SYMBOL(main)(void);
 
+struct exception_handler {
+    void *addr;
+    const char *exception_name;
+    struct exception_handler *next;
+};
+
+
+struct exception_handler *exception_handler = 0;
+
+void
+PROSTAK_uncaught_exception(const char *exception_name)
+{
+    fprintf(stderr, "Uncaught exception: %s\n", exception_name);
+    abort();
+}
+
+void 
+PROSTAK_register_exception_handler(const char *exception_name, void *addr)
+{
+    struct exception_handler *eh = (struct exception_handler*) malloc(sizeof(*exception_handler));
+    eh->addr = addr;
+    eh->exception_name = exception_name;
+    eh->next = exception_handler;
+
+    exception_handler = eh;
+}
+
+void*
+PROSTAK_get_exception_handler(const char *exception_name)
+{
+    struct exception_handler *eh = exception_handler;
+    while (eh != NULL) {
+        if (eh->exception_name == exception_name) {
+            return eh->addr;
+        }
+        eh = eh->next;
+    }
+
+    PROSTAK_uncaught_exception(exception_name);
+    return NULL;
+}
+
 int
 PROSTAK_readint(void)
 {
     int r;
     do {
-        printf("> Type int.\n");
+        printf("> ");
+        fflush(stdout);
     } while (scanf("%i", &r) != 1);
     return r;
 }

File samples/WHILE/002_frac.while

 {
     read n;
     s := 1;
-    while (n > 0) {
+    while (0 < n) {
         s := s * n;
         n := n - 1;
     }

File samples/WHILE/006_call.while

+procedure fibaux()
+{
+    if (n = 1) {
+        result := fibaux1;
+        throw EXIT;
+    }
+    if (n = 0) {
+        result := fibaux2;
+        throw EXIT;
+    }
+    tmp := fibaux1;
+    fibaux1 := fibaux1 + fibaux2;
+    fibaux2 := tmp;
+    n := n - 1;
+    fibaux();
+}
+
+procedure fib()
+{
+    fibaux1 := 1;
+    fibaux2 := 0;
+    fibaux();
+}
+
+procedure main()
+{
+    read n;
+    try {
+        fib();
+    } catch EXIT {
+        write result;
+    }
+    
+}

File source/Command/ParserCommandMaker.ml

         try
             List.iter (handle_file true) args;
             0
-        with _ ->
+        with exc ->
+            Printf.printf "exception: %s%!\n" (Printexc.to_string exc);
             print_endline "error not handled";
             -1
 

File source/Command/WHILE_Commands.ml

         Tempfile.with_temp_file None ".s"
         begin fun tmp_filename tmp_channel_out ->
             if configuration.verbose then
-                Printf.printf "- compiling %s to %s\n" tmp_filename output_filename ;
+                Printf.printf "- compiling %s to %s%!\n" tmp_filename output_filename ;
             dump_assembly_to_channel tmp_channel_out assembly;
             Pervasives.close_out tmp_channel_out;
             Lib.Toolchain.Gcc.compile_assembly output_filename tmp_filename;

File source/Compiler/WhileX86Compiler.ml

 
     let write_procedure_symbol = make_symbol "PROSTAK_writeint"
 
+    let read_procedure_symbol = make_symbol "PROSTAK_readint"
+
+    let get_exception_handler_symbol = make_symbol "PROSTAK_get_exception_handler"
+
+    let register_exception_handler_symbol = make_symbol "PROSTAK_register_exception_handler"
+
 end
 
+
 (*********************************************************************************************************************
  * Collecting variables
  ********************************************************************************************************************)
                 [ collect_all_variables_from_arithmetic_expression expr
                 ]
 
+        | AST.AE_Call (identifier, arguments) ->
+            Util.concat_map
+                collect_all_variables_from_arithmetic_expression arguments 
+
         | AST.AE_BinaryOperator (_, expr1, expr2) ->
             List.concat
                 [ collect_all_variables_from_arithmetic_expression expr1
         | AST.BE_Constant _ ->
             []
 
-        | AST.BE_Variable variable ->
-            [variable]
-
         | AST.BE_UnaryOperator (_, expr) ->
             List.concat
                 [ collect_all_variables_from_boolean_expression expr
                 ; collect_all_variables_from_command body_command
                 ]
 
+        | AST.CMD_Return arithmetic_expression ->
+            collect_all_variables_from_arithmetic_expression arithmetic_expression
+
+        | AST.CMD_Call (routine, arguments) ->
+            Util.concat_map collect_all_variables_from_arithmetic_expression 
+                arguments
+
         | AST.CMD_Abort ->
             [
             ]
         | AST.CMD_Read variable ->
             [variable]
 
-    let collect_all_variables_from_declaration (AST.DECL_Procedure (identifier, command)) =
+    let collect_all_variables_from_declaration (AST.DECL_Procedure (identifier, formal_arguments, command)) =
         collect_all_variables_from_command command
 
+    let rec collect_all_exceptions_from_command = function
+        | AST.CMD_Skip ->
+            []
+
+        | AST.CMD_Compose (c1, c2) ->
+            List.concat
+                [ collect_all_exceptions_from_command c1
+                ; collect_all_exceptions_from_command c2
+                ]
+
+        | AST.CMD_While (boolean_expression, body_command) ->
+            List.concat
+                [ collect_all_exceptions_from_command body_command
+                ]
+
+        | AST.CMD_Throw exception_identifier ->
+            [ exception_identifier
+            ]
+
+        | AST.CMD_Try (command, exception_identifier, catch_command) ->
+            List.concat
+                [ collect_all_exceptions_from_command command
+                ; collect_all_exceptions_from_command catch_command
+                ; [exception_identifier]
+                ]
+
+        | AST.CMD_If (boolean_expression, then_command, else_command) ->
+            List.concat
+                [ collect_all_exceptions_from_command then_command
+                ; collect_all_exceptions_from_command else_command
+                ]
+
+        | _ ->
+            []
+
+    let collect_all_exceptions_from_declaration (AST.DECL_Procedure (identifier, formal_arguments, command)) =
+        collect_all_exceptions_from_command command
+
 end
 
 (*********************************************************************************************************************
     let create_symbol_for_variable variable =
         make_symbol ("WHILE_VAR_" ^ AST.string_of_variable variable)
 
-    let compute_memory_map declarations =
+    let create_symbol_for_exception identifier =
+        make_symbol ("WHILE_EXCEPTION_" ^ AST.string_of_identifier identifier)
+
+    let compute_global_variable_table declarations =
         let hashtbl = Hashtbl.create 7 in
 
         let handle_variable variable =
 
     let compute_symbol_table declarations =
         let hashtbl = Hashtbl.create 7 in
-        let from_declaration (AST.DECL_Procedure (identifier, command)) =
+        let from_declaration (AST.DECL_Procedure (identifier, formal_arguments, command)) =
             let symbol = create_symbol identifier in
             Hashtbl.replace hashtbl identifier symbol
             in
         List.iter from_declaration declarations;
         hashtbl
 
+    let compute_exception_symbol_table declarations=
+        let hashtbl = Hashtbl.create 7 in
+        let from_identifier identifier =
+            let symbol = create_symbol_for_exception identifier in
+            Hashtbl.replace hashtbl identifier symbol
+            in
 
-    let frame_wrap body = 
+        let exceptions = Util.concat_map Collectors.collect_all_exceptions_from_declaration declarations in
+        List.iter from_identifier exceptions;
+        hashtbl
+
+
+    let frame_wrap frame_leave_symbol body = 
         let frame_enter =
             [ emit_PUSHL (lv32_reg EBP) 
             ; emit_MOVL  (lv32_reg ESP) (loc32_reg EBP)
             ]
 
         and frame_leave =
-            [ emit_MOVL (lv32_reg EBP) (loc32_reg ESP)
+            [ emit_label frame_leave_symbol
+            ; emit_MOVL (lv32_reg EBP) (loc32_reg ESP)
             ; emit_POPL (loc32_reg EBP)
             ; emit_RET
             ]
  * Context
  ********************************************************************************************************************)
 
-module Context = struct
+
+module Context = struct 
+    
+    type frame =
+        { leave_symbol              : symbol
+        ; local_variable_map       : (AST.variable, memory_location) FrozenHashtbl.t
+        }
 
     type context =
-        { symbolnum     : int ref
-        ; symbol_table  : (AST.identifier, symbol) Hashtbl.t
-        ; memory_map    : (AST.variable, symbol) Hashtbl.t
+        { symbolnum                 : int ref
+        ; symbol_table              : (AST.identifier, symbol) FrozenHashtbl.t
+        ; global_variable_table     : (AST.variable,   symbol) FrozenHashtbl.t
+        ; exception_symbol_table    : (AST.identifier, symbol) FrozenHashtbl.t
+        ; current_frame             : frame option ref
         }
 
     let get_all_symbols_from_table context =
-        Hashtbl.fold (fun _ symbol acc -> symbol::acc) context.symbol_table [] 
+        FrozenHashtbl.fold (fun _ symbol acc -> symbol::acc) context.symbol_table [] 
 
     let get_all_symbols_from_mem context = 
-        Hashtbl.fold (fun _ symbol acc -> symbol::acc) context.memory_map [] 
+        FrozenHashtbl.fold (fun _ symbol acc -> symbol::acc) context.global_variable_table [] 
+
+    let get_all_exceptions context =
+        FrozenHashtbl.fold (fun identifier symbol acc -> (identifier,symbol)::acc) context.exception_symbol_table []
+
+    let get_frame_leave_symbol context =
+        match !(context.current_frame) with
+        | None ->
+            Error.internal_error "Getting frame description outside frame?"
+        | Some frame_description ->
+            frame_description.leave_symbol
 
     let lookup_for_symbol context identifier =
         try
-            Hashtbl.find context.symbol_table identifier
+            FrozenHashtbl.find context.symbol_table identifier
         with Not_found ->
             Error.internal_error "Invalid symbol table"
 
     let lookup_for_variable_symbol context variable =
         try
-            Hashtbl.find context.memory_map variable
+            FrozenHashtbl.find context.global_variable_table variable
         with Not_found ->
             Error.internal_error "Invalid memory map"
 
+    let lookup_for_exception_symbol context identifier =
+        try
+            FrozenHashtbl.find context.exception_symbol_table identifier
+        with Not_found ->
+            Error.internal_error "Invalid exception map"
 
     let make_context declarations =
-        { symbolnum    = ref 0
-        ; symbol_table = Helpers.compute_symbol_table declarations
-        ; memory_map   = Helpers.compute_memory_map declarations
+        { symbolnum                 = ref 0
+        ; symbol_table              = FrozenHashtbl.freeze (Helpers.compute_symbol_table declarations)
+        ; global_variable_table     = FrozenHashtbl.freeze (Helpers.compute_global_variable_table declarations)
+        ; exception_symbol_table    = FrozenHashtbl.freeze (Helpers.compute_exception_symbol_table declarations)
+        ; current_frame             = ref None
         } 
 
-    let create_fresh_local_symbol context = 
+    let create_fresh_local_symbol ?(suffix="") context = 
         let num = !(context.symbolnum) in
         incr context.symbolnum;
-        let symbol = make_symbol (Printf.sprintf "_L%04u" num) in
+        let symbol = make_symbol (Printf.sprintf "_L%04u%s" num suffix) in
         symbol
+
+    let compute_memory_locations_for_arguments formal_arguments =
+        let map = Hashtbl.create 7 in
+        let address_argument i argument =
+            let index   = Int32.of_int (8 + (4 * i)) in
+            let address = MEM_Address (index, Some EBP, None) in
+            Hashtbl.replace map argument address
+            in
+        List.iteri address_argument formal_arguments;
+        FrozenHashtbl.freeze map
+
+
+    let inside_frame context formal_arguments cont =
+        assert (Option.is_none !(context.current_frame));
+        let leave_symbol = create_fresh_local_symbol ~suffix:"_frame_leave"  context in
+        let frame = 
+            { local_variable_map = compute_memory_locations_for_arguments  formal_arguments 
+            ; leave_symbol       = leave_symbol
+            } in
+        context.current_frame := Some frame;
+        let r = cont leave_symbol in
+        context.current_frame := None;
+        r
+
+    let lookup_for_variable_memory_location context variable =
+        try match !(context.current_frame) with
+            | Some frame ->
+                FrozenHashtbl.find frame.local_variable_map variable
+            | None ->
+                raise Not_found
+        with Not_found ->
+            MEM_Symbol (lookup_for_variable_symbol context variable)
+
+    let lookup_for_variable_loc32 context variable =
+        LOC32_Memory (lookup_for_variable_memory_location context variable)
+
+    let lookup_for_variable_lv32 context variable =
+        LV32_Location (lookup_for_variable_loc32 context variable)
+
+end
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+module Shrinker = struct
+
+    let not_both a b =
+        not (a && b)
+
+    let rec shrink_emits ticks prev_emits next_emits = match prev_emits, next_emits with
+
+        (* Pushing and then poping *)
+        | EMIT_Instruction (PUSHL (LV32_Location loc32_1)) :: prev_emits
+        , EMIT_Instruction (POPL loc32_2)                  :: next_emits
+          when loc32_1 = loc32_2 ->
+            incr ticks;
+            shrink_emits ticks prev_emits next_emits
+
+        (* Indirect transfer *)
+        | EMIT_Instruction (MOVL (lv32_a, loc32_a))                     :: prev_emits
+        , EMIT_Instruction (MOVL ((LV32_Location loc32_b), loc32_c))    :: next_emits
+        when loc32_a = loc32_b && not_both (lv32_is_memref lv32_a) (loc32_is_memref loc32_c) && not (loc32_is_memref loc32_a)->
+            incr ticks;
+            let new_emit = emit_MOVL lv32_a loc32_c in
+            shrink_emits ticks prev_emits (new_emit::next_emits)
+
+        (* Silly pushing *)
+        | EMIT_Instruction (MOVL (lv32_a, loc32_a))         :: prev_emits
+        , EMIT_Instruction (PUSHL (LV32_Location loc32_b))  :: next_emits
+        when loc32_a = loc32_b && not (loc32_is_memref loc32_a) ->
+            incr ticks;
+            let new_emit = emit_PUSHL lv32_a in
+            shrink_emits ticks prev_emits (new_emit::next_emits)
+
+        (* Transfers before comparision *)
+        | EMIT_Instruction (MOVL (lv32_src_a, loc32_tmp_a))  
+            :: EMIT_Instruction (MOVL ((LV32_Location loc32_src_b), loc32_tmp_b))
+            :: prev_emits
+        , EMIT_Instruction (CMP ((LV32_Location loc32_dst_a), loc32_dst_b))
+            :: next_emits
+
+        | EMIT_Instruction (MOVL ((LV32_Location loc32_src_b), loc32_tmp_b))
+            :: EMIT_Instruction (MOVL (lv32_src_a, loc32_tmp_a))  
+            :: prev_emits
+        , EMIT_Instruction (CMP ((LV32_Location loc32_dst_a), loc32_dst_b))
+            :: next_emits
+        when loc32_tmp_a = loc32_dst_a && loc32_tmp_b = loc32_dst_b  ->
+            incr ticks;
+            let new_emit = emit_CMP lv32_src_a loc32_src_b in
+            shrink_emits ticks prev_emits (new_emit::next_emits)
+
+        (* Unreachable instruction *)
+(*        | EMIT_Instruction (JMP loc32_a) *)
+          | EMIT_Instruction _
+            :: (EMIT_Instruction (JMP loc32_b) as reachable_jmp)
+            :: prev_emits
+        , next_emits ->
+            incr ticks;
+            shrink_emits ticks prev_emits (reachable_jmp :: next_emits)
+            
+
+        (* Pushing two values and moving them to EAX,EBX *)
+        (* TODO guard *)
+        | EMIT_Instruction (PUSHL lv32_1)
+            :: EMIT_Instruction (PUSHL lv32_2)
+            :: prev_emits
+        , EMIT_Instruction (POPL (LOC32_Register EAX))
+            :: EMIT_Instruction (POPL (LOC32_Register EBX))
+            :: next_emits
+ 
+        when true ->
+            incr ticks;
+            let new_emit1 = emit_MOVL lv32_2 (LOC32_Register EBX) in
+            let new_emit2 = emit_MOVL lv32_1 (LOC32_Register EAX) in
+            shrink_emits ticks prev_emits (new_emit1 :: new_emit2 :: next_emits)
+        
+        (* Jump to next instruction *)
+        | EMIT_Instruction (JMP (LOC32_Memory (MEM_Symbol symbol_in_jump)))
+            :: prev_emits
+
+        , (EMIT_Label emited_label as current_emit)
+            :: next_emits
+        when emited_label = symbol_in_jump ->
+            incr ticks;
+            shrink_emits ticks (current_emit :: prev_emits) next_emits
+
+        (* Adding zero *)
+
+        | EMIT_Instruction (ADDL (LV32_Value (VAL32_Immediate 0l), loc32))
+            :: prev_emits
+        , next_emits ->
+            incr ticks;
+            shrink_emits ticks prev_emits next_emits
+
+
+        (* Going forward *)
+
+        |              prev_emits
+        , next_emit :: next_emits ->
+            shrink_emits ticks (next_emit :: prev_emits) next_emits
+
+        (* Restart or give up *)
+        | prev_emits
+        , [] ->
+            let final = List.rev prev_emits in
+            if !ticks <> 0 then
+                shrink_emits (ref 0) [] final
+            else
+                final
+
+    let shrink emits = 
+        shrink_emits (ref 0) [] emits
+
 end
 
 (*********************************************************************************************************************
 
 module AstCompiler = struct
 
+    (*----------------------------------------------------------------------------------------------------------------
+     * Helpers for calling runtime symbols with correct calling vonersion
+     *)
+
+    let call_routine_lv32_args loc32_routine lv32_args = 
+        let passing_arguments_code =
+            List.rev_map emit_PUSHL lv32_args
+            in
+
+        let calling_code = 
+            let allocated_stack_size = Int32.of_int (4 * List.length lv32_args) in
+            [ emit_CALL loc32_routine 
+            ; emit_ADDL (lv32_imm allocated_stack_size) (loc32_reg ESP)
+            ] in
+
+        List.concat
+            [ passing_arguments_code
+            ; calling_code
+            ]
+
+    let call_routine_symbol_lv32_args routine_symbol lv32_args = 
+        call_routine_lv32_args (loc32_symbol routine_symbol) lv32_args
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Arithmetic and boolean operators
+     *)
+
+    let compile_arithmetic_binary_operator reg1 reg2 aop =
+        let compile emit rreg =
+            let code = 
+                [ emit (lv32_reg reg1) (loc32_reg reg2)
+                ]
+                in
+            (code, rreg)
+            in
+        match aop with
+            | AST.AOP_ADD -> compile emit_ADDL reg2
+            | AST.AOP_SUB -> compile emit_SUBL reg2
+            | AST.AOP_MUL -> compile emit_IMULL reg2
+            | _ -> Error.not_yet_implemented "arith bin op"
+
+    let compile_boolean_arithmetic_binary_operator else_branch reg1 reg2 bop =
+        let compile emit_jump =
+            let code = 
+                [ emit_CMP (lv32_reg reg1) (loc32_reg reg2)
+                ; emit_jump (loc32_symbol else_branch)
+                ]
+                in
+            code
+            in
+        match bop with
+            | AST.BOP_LT -> compile emit_JNL
+            | AST.BOP_LEQ -> compile emit_JNLE
+            | AST.BOP_EQ -> compile emit_JNE
+            | AST.BOP_NEQ -> compile emit_JE
+            | AST.BOP_GT -> compile emit_JNG
+            | AST.BOP_GEQ -> compile emit_JNGE
+
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Calling program routines and translating arithmetic expression.
+     *)
+
+    let rec call_routine context loc32_routine arguments =
+
+        let pass_argument arithmetic_expression =
+            let (computing_code, result_reg) = compile_arithmetic_expression context arithmetic_expression in
+            List.concat
+                [ computing_code
+                ; [emit_PUSHL (lv32_reg result_reg)]
+                ] in
+
+        let passing_arguments_code =
+            List.rev_map pass_argument arguments
+            in
+        
+        let calling_code = 
+            let allocated_stack_size = Int32.of_int (4 * List.length arguments) in
+            [ emit_CALL loc32_routine 
+            ; emit_ADDL (lv32_imm allocated_stack_size) (loc32_reg ESP)
+            ] in
+
+        let code = List.concat
+            [ List.concat passing_arguments_code
+            ; calling_code
+            ] in
+
+        let result_reg = EAX in
+
+        (code, result_reg)
+
+    and call_routine_symbol context routine_symbol arguments =
+        call_routine context (loc32_symbol routine_symbol) arguments
+
+    and compile_arithmetic_expression context = function
+        | AST.AE_Constant i ->
+            let imm32 = Int32.of_int i in
+            let code = 
+                [ emit_MOVL (lv32_imm imm32) (loc32_reg EAX)
+                ] in
+            (code, EAX)
+
+        | AST.AE_Variable variable ->
+            let var_lv32 = Context.lookup_for_variable_lv32 context variable in
+            let code =
+                [ emit_MOVL var_lv32 (loc32_reg EAX)
+                ] in
+            (code, EAX)
+
+        | AST.AE_Call (routine, arguments) ->
+            let routine_symbol = Context.lookup_for_symbol context routine in
+            call_routine_symbol context routine_symbol arguments
+
+        | AST.AE_UnaryOperator (op, expr1) ->
+            let (computing_code, result_reg) = compile_arithmetic_expression context expr1 in
+
+            let code = List.concat
+                [ computing_code
+                ] in
+
+            (code, result_reg)
+
+
+        | AST.AE_BinaryOperator (op, expr1, expr2) ->
+            let (code1, reg1) = compile_arithmetic_expression context expr1 in
+            let (code2, reg2) = compile_arithmetic_expression context expr2 in
+            let (code3, reg3) = compile_arithmetic_binary_operator EAX EBX op in
+            let save_reg1_code = 
+                [ emit_PUSHL (lv32_reg reg1)
+                ] in
+
+            let save_reg2_code =
+                [ emit_PUSHL (lv32_reg reg2)
+                ; emit_POPL (loc32_reg EAX)
+                ; emit_POPL (loc32_reg EBX)
+                ] in
+
+            let code = List.concat
+                [ code1
+                ; save_reg1_code
+                ; code2
+                ; save_reg2_code
+                ; code3
+                ] in
+
+            (code, reg3)
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Translating boolean expression.
+     *)
+
+    let rec compile_boolean_expression context else_branch = function
+        | AST.BE_Constant c  ->
+            if c then
+                []
+            else
+                [ emit_JMP (loc32_symbol else_branch)
+                ] 
+
+        | AST.BE_UnaryOperator(AST.BOP_NOT, bexpr) ->
+            let symbol_not = Context.create_fresh_local_symbol ~suffix:"_boolean_not"   context in
+            let jumping_code = compile_boolean_expression context symbol_not bexpr in
+
+            List.concat
+                [ jumping_code
+                ; [emit_JMP (loc32_symbol else_branch)]
+                ; [emit_label symbol_not]
+                ]
+
+        | AST.BE_BinaryOperator(op, bexpr1, expr2) ->
+            [
+            ]
+
+        | AST.BE_ArithmeticBinaryOperator (op, expr1, expr2)  ->
+            let (code1, reg1) = compile_arithmetic_expression context expr1 in
+            let (code2, reg2) = compile_arithmetic_expression context expr2 in
+            let code3         = compile_boolean_arithmetic_binary_operator else_branch EAX EBX op in
+            let save_reg1_code = 
+                [ emit_PUSHL (lv32_reg reg1)
+                ] in
+
+            let save_reg2_code =
+                [ emit_PUSHL (lv32_reg reg2)
+                ; emit_POPL (loc32_reg EAX)
+                ; emit_POPL (loc32_reg EBX)
+                ] in
+
+            let code = List.concat
+                [ code1
+                ; save_reg1_code
+                ; code2
+                ; save_reg2_code
+                ; code3
+                ] in
+
+            code
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Translating command.
+     *)
+
     let rec compile_command context = function
         | AST.CMD_Skip ->
             [
             ]
 
-        | AST.CMD_Write variable ->
-            let variable_symbol = Context.lookup_for_variable_symbol context variable in
-            [ emit_PUSHL (lv32_symbol variable_symbol)
-            ; emit_CALL (loc32_symbol Runtime.write_procedure_symbol)
-            ; emit_ADDL (lv32_imm 4l) (loc32_reg ESP)
+        | AST.CMD_Return arithmetic_expression ->
+            let (code, reg) = compile_arithmetic_expression context arithmetic_expression in
+
+            let leaving_code = 
+                [ emit_MOVL (lv32_reg reg) (loc32_reg EAX)
+                ; emit_JMP (loc32_symbol (Context.get_frame_leave_symbol context))
+                ] in
+
+            List.concat
+                [ code
+                ; leaving_code
+                ]
+
+        | AST.CMD_Call (routine, arguments) ->
+            let routine_symbol = Context.lookup_for_symbol context routine in
+            let (code, _) = call_routine_symbol context routine_symbol arguments in
+            code
+
+        | AST.CMD_Assign (variable, arithmetic_expression) ->
+            let (expr_code, expr_reg)   = compile_arithmetic_expression context arithmetic_expression in
+            let var_loc32               = Context.lookup_for_variable_loc32 context variable in
+
+            let store_code =
+                [ emit_MOVL (lv32_reg expr_reg) var_loc32
+                ] in
+
+            List.concat
+                [ expr_code
+                ; store_code
+                ]
+
+        | AST.CMD_Read variable ->
+            let variable_loc32 = Context.lookup_for_variable_loc32 context variable in
+            [ emit_CALL (loc32_symbol Runtime.read_procedure_symbol)
+            ; emit_MOVL (lv32_reg EAX) variable_loc32
             ]
 
+        | AST.CMD_Write variable ->
+            let variable_lv32 = Context.lookup_for_variable_lv32 context variable in
+            call_routine_symbol_lv32_args Runtime.write_procedure_symbol [variable_lv32]
+
+        | AST.CMD_While (cond, body) ->
+            let symbol_loop_begin = Context.create_fresh_local_symbol ~suffix:"_loop_begin" context in
+            let symbol_loop_end   = Context.create_fresh_local_symbol ~suffix:"_loop_end"   context in
+            let comp_code = compile_boolean_expression context symbol_loop_end cond in
+
+            let loop_enter =
+                [ emit_label symbol_loop_begin ]
+                in
+
+            let loop_leave =
+                [ emit_JMP (loc32_symbol symbol_loop_begin)
+                ; emit_label symbol_loop_end
+                ] in
+
+            List.concat
+                [ loop_enter
+                ; comp_code
+                ; compile_command context body
+                ; loop_leave
+                ]
+
         | AST.CMD_Abort ->
-            [ emit_CALL (loc32_symbol Runtime.abort_procedure_symbol)
-            ]
+            call_routine_symbol_lv32_args Runtime.abort_procedure_symbol []
 
         | AST.CMD_Compose (c1, c2) ->
             List.concat
                 ; compile_command context c2
                 ]
 
-        | _ ->
-            [ emit_comment "Not implemented yet"
-            ]
+        | AST.CMD_If (cond, then_cmd, else_cmd) ->
+            let if_after  = Context.create_fresh_local_symbol ~suffix:"_if_after" context in
+            let if_else   = Context.create_fresh_local_symbol ~suffix:"_if_else"  context in
+            let comp_code = compile_boolean_expression context if_else cond in
 
-    let compile_procedure_command context symbol command =
-        let compiled_command = compile_command context command in
-        let compiled_body    = Helpers.frame_wrap compiled_command in
+
+            List.concat
+                [ comp_code
+                ; compile_command context then_cmd
+                ; [emit_JMP (loc32_symbol if_after)]
+                ; [emit_label if_else]
+                ; compile_command context else_cmd
+                ; [emit_label if_after]
+                ]
+
+        | AST.CMD_Throw (exception_identifier) ->
+            let exception_symbol = Context.lookup_for_exception_symbol context exception_identifier in
+                let calling_code =
+                    call_routine_symbol_lv32_args Runtime.get_exception_handler_symbol
+                        [lv32_symboladdr exception_symbol
+                        ]
+                    in
+
+                List.concat
+                    [ calling_code
+                    ; [emit_JMP (loc32_reg EAX)]
+                    ]
+
+        | AST.CMD_Try (tried_command, exception_identifier, catch_command) ->
+            let symbol_catch     = Context.create_fresh_local_symbol ~suffix:"_try_catch"  context in
+            let symbol_after     = Context.create_fresh_local_symbol ~suffix:"_try_after"  context in
+            let exception_symbol = Context.lookup_for_exception_symbol context exception_identifier in
+            
+            let try_open =
+                call_routine_symbol_lv32_args Runtime.register_exception_handler_symbol
+                    [ lv32_symboladdr exception_symbol
+                    ; lv32_symboladdr symbol_catch
+                    ]
+                in
+
+            let try_catch =
+                [ emit_JMP (loc32_symbol symbol_after)
+                ; emit_label symbol_catch
+                ] in
+
+            let try_after =
+                [ emit_label symbol_after
+                ] in
+
+            List.concat
+                [ try_open
+                ; compile_command context tried_command
+                ; try_catch
+                ; compile_command context catch_command
+                ; try_after
+                ]
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Translating program routine.
+     *)
+
+    let compile_procedure_command context frame_leave_symbol symbol command =
+        let compiled_command   = compile_command context command in
+        let compiled_body      = Helpers.frame_wrap frame_leave_symbol compiled_command in
         emit_label symbol :: compiled_body
 
-    let compile_declaration context (AST.DECL_Procedure (identifier, command)) =
-        let symbol           = Context.lookup_for_symbol context identifier in
-        let compiled_command = compile_procedure_command context symbol command in
-        compiled_command
+    let compile_declaration context (AST.DECL_Procedure (identifier, formal_arguments, command)) =
+        Context.inside_frame context formal_arguments begin fun frame_leave_symbol ->
+            let symbol           = Context.lookup_for_symbol context identifier in
+            let compiled_command = compile_procedure_command context frame_leave_symbol symbol command in
+            Shrinker.shrink compiled_command
+        end
 
-    let compile_program (AST.PROGRAM declarations) =
+    (*----------------------------------------------------------------------------------------------------------------
+     * Compiling text section.
+     *)
 
+    let compile_text_section context declarations =
+        let compiled_declarations = List.map (compile_declaration context) declarations in
+        let text_section          = Section (".text", compiled_declarations) in
+        text_section
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Compiling data section.
+     *)
+
+    let compile_data_section context declarations =
         let reserve_integer_for_symbol symbol = 
             [emit_memory_reservation symbol (Reservation_Int32 0l)]
             in
 
-        let context = Context.make_context declarations in
-
-        let compiled_declarations = List.map (compile_declaration context) declarations in
-        let text_section          = Section (".text", compiled_declarations) in
+        let emit_exception (identifier, symbol) =
+            [emit_memory_reservation symbol (Reservation_AsciiZ (AST.string_of_identifier identifier))]
+            in
 
         let symbols_for_globals   = Context.get_all_symbols_from_mem context in
+        let all_exceptions        = Context.get_all_exceptions context in
         let memory_for_globals    = List.map reserve_integer_for_symbol symbols_for_globals in
-        let data_section          = Section (".data", memory_for_globals) in
+        let memory_for_exceptions = List.map emit_exception all_exceptions in
 
-        let sections              = [text_section; data_section] in
+        let data_section          = Section (".data", memory_for_globals @ memory_for_exceptions) in
+
+        data_section
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * Compiling assembly.
+     *)
+
+    let compile_assembly context sections = 
         let symbols_to_export     = Context.get_all_symbols_from_table context in
         let header = 
             [ "Compiled by " ^ Predefined.opifex_ident
             ] in
 
         Assembly(header, sections, symbols_to_export)
+
+    let compile_program (AST.PROGRAM declarations) =
+
+        let context      = Context.make_context declarations in
+        let text_section = compile_text_section context declarations in
+        let data_section = compile_data_section context declarations in
+        let sections     = [text_section; data_section] in
+
+        compile_assembly context sections
 end
 
 

File source/Lang/While/AST.ml

 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_Variable of variable
     | 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
     | 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 * command
+    = DECL_Procedure of identifier * variable list * command
 
 type program
     = PROGRAM of declaration list

File source/Lang/While/Eval.ml

     let rec eval_program store io_driver = function
         | PROGRAM decls ->
             let analyze_declaration decls = function
-                | DECL_Procedure (ident, command) ->
+                | 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
         | 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

File source/Lang/While/Lexer.mll

         ; ("or", OP_OR)
         ; ("true", TRUE)
         ; ("false", FALSE)
+        ; ("return", RETURN)
 
         ; ("throw", THROW)
         ; ("try", TRY)
         ; (")", RPARENT)
 
         ; (";", SEMICOLON)
+        ; (",", COMA)
 
         ; (":=", ASSIGN)
 
     | ['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']* as lxm
     { compute_token_from_id lxm }
 
-    | ['{' '}' '(' ')' ';' '+' '-' '*' '/' '%' ] | ":=" | "&&" | "||" | "<" | "<=" | "=" | ">" | ">=" as lxm
+    | ['{' '}' '(' ')' ';' '+' '-' '*' '/' '%' ',' ] | ":=" | "&&" | "||" | "<" | "<=" | "=" | ">" | ">=" as lxm
     { compute_token_from_oper lxm }
 
     | ['0'-'9']+ as lxm

File source/Lang/While/Parser.mly

 %left ELSE
 %nonassoc OP_NOT        /* highest precedence */
 %nonassoc SEMICOLON
+%nonassoc COMA
 
 %start parse
 
 %token CURL_OPEN
 %token CURL_CLOSE
 %token SEMICOLON
+%token COMA
 
 %token ASSIGN
 %token OP_OR
 
 %token PROCEDURE
 
+%token RETURN
 %token SKIP
 %token IF
 %token ELSE
     { 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 }
     ;
     | FALSE
     { BE_Constant false }
 
-    | variable
-    { BE_Variable $1 }
-
-    | RPARENT boolean_expression LPARENT
+    | LPARENT boolean_expression RPARENT
     { $2 }
     ;
 
-arithmetic_expression
+multiplicative_arithmetic_expression
     : arithmetic_expression_basic
     { $1 }
 
-    | arithmetic_expression arithmetic_binary_operator arithmetic_expression_basic
+    | 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
     { BE_ArithmeticBinaryOperator ($2, $1, $3) }
     ;
 
-arithmetic_binary_operator
+additive_arithmetic_binary_operator
     : OP_ADD
     { AOP_ADD }
 
     | OP_SUB
     { AOP_SUB }
+    ;
 
-    | OP_MUL
+multiplicative_arithmetic_binary_operator
+    : OP_MUL
     { AOP_MUL }
 
     | OP_DIV 
     { BOP_OR }
     ;
 
-/*
+
 boolean_unary_operator
     : OP_NOT
     { BOP_NOT }
     ;
-*/
+
 
 boolean_arithmetic_binary_operator
     : OP_LT
     { $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 }
 
     | 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) }
     ;
 
-/*
-if_sequence
-    : IF guarded_commands
-      elif_sequence
-      ELSE commands 
-    { compute_ifs $5 ($2 :: $3) }
-    ;
+
+command_control
+    : command_basic
+    { $1 }
 
     | IF guarded_commands
-      elif_sequence
-    { compute_ifs CMD_Skip ($2 :: $3) }
-    ;
-
-elif_sequence
-    : ELIF guarded_commands
-      elif_sequence
-    { $2 :: $3 }
-
-    |
-    { [] }
-
-*/
-
-command_control
-    : IF guarded_commands
     {  let (cond, then_cmds) = $2
     in CMD_If (cond, then_cmds, CMD_Skip) }
 
     {  let (cond, then_cmds) = $2
     in CMD_If (cond, then_cmds, $4) }
 
-    | command_basic
-    { $1 }
 
     | 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) }
+    { DECL_Procedure ($2, [], $5) } 
+
+    | PROCEDURE identifier LPARENT variable_list RPARENT
+        commands 
+    { DECL_Procedure ($2, $4, $6) } 
+    ;
 
 declarations
     : declaration 
     : declarations 
     { PROGRAM $1 }
 
+
 parse
     : program EOF
     { $1 }
-
 %% 
 

File source/Lang/While/PrettyPrinter.ml

     | BE_Constant _ ->
         psp_max_priority
 
-    | BE_Variable _ ->
-        psp_max_priority
-
     | BE_BinaryOperator (operator, _, _) ->
         boolean_binary_operator_priority operator
 
     | AE_Constant constant ->
         psp_max_priority
 
+    | AE_Call (_, _) -> psp_max_priority
+
     | AE_Variable variable ->
         psp_max_priority
 
 
 let rec paint_program = function
     | PROGRAM decls ->
-        let paint_declaration decls = function
-            | DECL_Procedure (ident, command) ->
-                [ psp_keyword "procedure"
-                ; psp_identifier ident
-                ; psp_word "()"
-                ; psp_break
-                ; psp_syntax "{"
-                ; psp_break
-                ; psp_indent (paint_command command)
-                ; psp_syntax "}"
-                ; psp_break
-                ]
+        psp_group (List.map paint_declaration decls)
 
-        in psp_group (List.fold_left 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_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
         [ 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
         [ psp_value_bool constant
         ]
 
-    | BE_Variable variable ->  psp_group
-        [ psp_variable variable
-        ]
-
     | BE_BinaryOperator (boolean_operator, first_expression, second_expression) -> 
         psp_gen_infix
             boolean_binary_operator_associativity

File source/Machine/Common/Formatter.ml

  * String painters for types
  ********************************************************************************************************************)
 
-let paint_symbol = psp_label -| symbol_of_string
+let paint_symbol = psp_label -| string_of_symbol 
 
 

File source/Machine/Common/Types.ml

 
  let make_symbol x = Symbol x
 
- let symbol_of_string (Symbol x) = x
+ let string_of_symbol (Symbol x) = x

File source/Machine/X86/Assembler.ml

 
 type memory_reservation
     = Reservation_Int32 of immediate_byte32
+    | Reservation_AsciiZ of string
 
 (*********************************************************************************************************************
  * Emit and Assembly
 let emit_JNE x = EMIT_Instruction (JNE (x))
 let emit_JNZ x = EMIT_Instruction (JNZ (x))
 let emit_JZ x = EMIT_Instruction (JZ (x))
+let emit_JL x = EMIT_Instruction (JL (x))
+let emit_JLE x = EMIT_Instruction (JLE (x))
+let emit_JNL x = EMIT_Instruction (JNL (x))
+let emit_JNLE x = EMIT_Instruction (JNLE (x))
+let emit_JG x = EMIT_Instruction (JG (x))
+let emit_JGE x = EMIT_Instruction (JGE (x))
+let emit_JNG x = EMIT_Instruction (JNG (x))
+let emit_JNGE x = EMIT_Instruction (JNGE (x))
 let emit_CALL x = EMIT_Instruction (CALL (x))
 let emit_RET = EMIT_Instruction (RET )
 let emit_PUSHL x = EMIT_Instruction (PUSHL (x))
 let lv32_symbol symbol = LV32_Location (loc32_symbol symbol)
 let val32_imm imm32 = VAL32_Immediate imm32
 let lv32_imm imm32 = LV32_Value (val32_imm imm32)
+let lv32_symboladdr symbol = LV32_Value (VAL32_Symbol symbol)
+
+let loc32_is_memref = function
+    | LOC32_Register _ -> false
+    | LOC32_Memory _ -> true
+
+let lv32_is_memref = function
+    | LV32_Value _        -> false
+    | LV32_Location loc32 -> loc32_is_memref loc32

File source/Machine/X86/GasPrettyPrinter.ml

 
 let paint_value32 = function
     | VAL32_Immediate ib32 -> paint_immediate_byte32 ib32
-    | VAL32_Symbol symbol -> paint_symbol symbol
+    | VAL32_Symbol symbol -> psp_label ("$" ^ string_of_symbol symbol)
 
 let paint_scale_factor scale_factor =
     psp_value_int (int_of_scale_factor scale_factor)
     | PUSHL  _ -> "pushl"
     | POPL  _ -> "popl"
     | CMP  _ -> "cmp"
-                                        
+
+let paint_jump_location32 = function
+    | LOC32_Register reg -> psp_group
+        [ psp_operator "*"
+        ; paint_register32 reg
+        ]
+
+    | LOC32_Memory (MEM_Symbol symbol) -> psp_group
+        [ paint_symbol symbol
+        ]
+
+    | LOC32_Memory mem -> psp_group
+        [ psp_operator "*"
+        ; paint_memory_location mem
+        ]
+        
+
 let paint_instruction instr =
     let mnemonic = get_instruction_mnemonic instr in
     let psp_mnemonic = psp_operator in
         ]
 
 
-    | NOTL (l32)
-    | NEGL (l32)
     | JMP (l32)
     | JE (l32)
     | JNE (l32)
     | JGE (l32)
     | JNLE(l32)
     | JNGE(l32)
+    | CALL (l32) -> psp_group
+        [ psp_mnemonic mnemonic
+        ; paint_jump_location32 l32
+        ]
 
-    | POPL (l32)
-    | CALL (l32) -> psp_group
+
+    | NOTL (l32)
+    | NEGL (l32)
+    | POPL (l32) -> psp_group
+        [ psp_mnemonic mnemonic
+        ; paint_location32 l32
+        ]
+
+    | POPL (l32) -> psp_group
         [ psp_mnemonic mnemonic
         ; paint_location32 l32
         ]
         ; psp_break
         ]
 
+    | Reservation_AsciiZ str -> psp_group
+        [ psp_operator ".asciz"
+        ; psp_value ("\"" ^ str ^ "\"")
+        ; psp_break
+        ]
+
 let paint_command = function
     | EMIT_Instruction instr -> psp_indent_group
         [ paint_instruction instr

File source/Util.mllib

 Tty
 Util
 Tempfile
+FrozenHashtbl

File source/Util/FrozenHashtbl.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+type ('k, 'v) t = ('k, 'v) Hashtbl.t
+
+let freeze t = (Hashtbl.copy t)
+
+let find h k = Hashtbl.find h k
+
+let fold f h a = Hashtbl.fold f h a

File source/Util/FrozenHashtbl.mli

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+type ('k, 'v) t
+
+val freeze : ('k, 'v) Hashtbl.t -> ('k, 'v) t
+
+val find : ('k, 'v) t -> 'k -> 'v
+
+val fold : ('k -> 'v -> 'a -> 'a) -> ('k, 'v) t -> 'a -> 'a