Permalink
Browse files

Parse and translate packages.

  • Loading branch information...
xlq committed Aug 26, 2012
1 parent 1575b91 commit 619434ec395d0d8d9f50ca139edb645c4b080921
Showing with 145 additions and 40 deletions.
  1. +1 −0 lexer.mll
  2. +2 −2 main.ml
  3. +15 −1 parse_tree.mli
  4. +27 −3 parser.mly
  5. +6 −2 symbols.ml
  6. +5 −1 symbols.mli
  7. +88 −30 translation.ml
  8. +1 −1 translation.mli
View
@@ -12,6 +12,7 @@ let keywords = create_hashtable 10 [
"and", AND;
"or", OR;
"end", END;
"package", PACKAGE;
"procedure", PROCEDURE;
"null", NULL;
"var", VAR;
View
@@ -20,5 +20,5 @@ let _ =
Lexing.pos_fname = filename
};
let sub = try_parse Parser.subprogram lexbuf in
Translation.translate sub
let translation_unit = try_parse Parser.translation_unit lexbuf in
Translation.translate translation_unit
View
@@ -8,7 +8,11 @@ type file_location = Lexing.position
type loc = file_location
type dotted_name = string list
type subprogram =
type translation_unit =
| Subprogram_unit of subprogram
| Package_unit of package
and subprogram =
{
sub_location : loc;
sub_name : dotted_name;
@@ -24,6 +28,16 @@ and parameter =
param_type : ttype;
}
and package =
{
pkg_location : loc;
pkg_name : dotted_name;
pkg_declarations : declaration list;
}
and declaration =
| Subprogram of subprogram
and ttype =
| Named_type of loc * dotted_name
View
@@ -23,7 +23,7 @@ let check_end (pos1, name1) (pos2, name2) =
%token <Big_int.big_int> INTEGER
/* Keywords */
%token PROCEDURE NULL END AND OR VAR IS IF THEN ELSE ELSIF
%token PACKAGE PROCEDURE NULL END AND OR VAR IS IF THEN ELSE ELSIF
%token WHILE LOOP TYPE RANGE GIVEN TRUE FALSE
%token INSPECT_TYPE STATIC_ASSERT
@@ -37,18 +37,42 @@ let check_end (pos1, name1) (pos2, name2) =
%nonassoc EQ NE LT LE GT GE
%start subprogram
%type <Parse_tree.subprogram> subprogram
%start translation_unit
%type <Parse_tree.translation_unit> translation_unit
%%
translation_unit:
| subprogram { Subprogram_unit $1 }
| package { Package_unit $1 }
dotted_name:
| IDENT { [$1] }
| IDENT DOT dotted_name { $1 :: $3 }
ttype:
| dotted_name { Named_type(pos(), $1) }
package:
| PACKAGE dotted_name IS
declarations
END dotted_name SEMICOLON
{
check_end (rhs_start_pos 2, $2) (rhs_start_pos 6, $6);
{
pkg_location = pos ();
pkg_name = $2;
pkg_declarations = $4;
}
}
declarations:
| /* empty */ { [] }
| declaration declarations { $1 :: $2 }
declaration:
| subprogram { Subprogram $1 }
subprogram:
| PROCEDURE dotted_name opt_parameters IS
ne_statements
View
@@ -38,10 +38,14 @@ and symbol = {
and symbol_info =
| Unfinished_sym
| Package_sym
| Subprogram_sym
| Subprogram_sym of subprogram_info
| Variable_sym
| Parameter_sym of ttype
and subprogram_info = {
mutable sub_preconditions : expr list;
}
let last_sym_id = ref 0
module Ordered = struct
@@ -102,7 +106,7 @@ let rec string_of_type = function
let describe_symbol sym =
(match sym.sym_info with
| Package_sym -> "package"
| Subprogram_sym -> "subprogram"
| Subprogram_sym _-> "subprogram"
| Variable_sym -> "variable"
| Parameter_sym _ -> "parameter"
) ^ " `" ^ full_name sym ^ "'"
View
@@ -45,10 +45,14 @@ and symbol = {
and symbol_info =
| Unfinished_sym (* symbol_info not yet set *)
| Package_sym
| Subprogram_sym
| Subprogram_sym of subprogram_info
| Variable_sym
| Parameter_sym of ttype
and subprogram_info = {
mutable sub_preconditions : expr list;
}
module Ordered : Map.OrderedType with type t = symbol
module Maps : Map.S with type key = symbol
module Sets : Set.S with type elt = symbol
View
@@ -18,7 +18,7 @@ exception Bail_out
type context =
{
(* Function that's being translated. *)
(* Entity that's being translated. *)
ctx_scope : symbol;
(* Block to "jump" to after current block. *)
ctx_after : block option;
@@ -28,6 +28,8 @@ type context =
type state =
{
mutable st_subprograms:
(symbol * Parse_tree.subprogram) list;
mutable st_blocks: block list;
}
@@ -221,24 +223,31 @@ and translate_block
make_block state context statement
(fun _ -> translate_statement state context statement)
let translate (sub: Parse_tree.subprogram): unit =
let state =
{
st_blocks = [];
}
in
let parameters_of_subprogram sym =
List.fold_left (fun result child ->
match child.sym_info with
| Parameter_sym(t) ->
Symbols.Maps.add child t result
| _ ->
result
) Symbols.Maps.empty sym.sym_children
let translate_subprogram_prototype state context sub =
match sub.Parse_tree.sub_name with [name] ->
let subprogram_sym = new_symbol root_symbol name Subprogram_sym in
let context =
{
ctx_scope = subprogram_sym;
ctx_after = None;
ctx_last_loc = sub.Parse_tree.sub_location;
}
let subprogram_info = {
sub_preconditions = [];
} in
let subprogram_sym = new_symbol context.ctx_scope name
(Subprogram_sym subprogram_info)
in
let context = {context with
ctx_scope = subprogram_sym;
ctx_after = None;
ctx_last_loc = sub.Parse_tree.sub_location;
} in
(* Translate parameters. *)
let parameters = List.fold_left
(fun parameters param ->
List.iter
(fun param ->
try
match Symbols.find_in
context.ctx_scope
@@ -259,30 +268,79 @@ let translate (sub: Parse_tree.subprogram): unit =
context
param.Parse_tree.param_type
in
sym.sym_info <- Parameter_sym(t);
Symbols.Maps.add sym t parameters
with Bail_out -> parameters
) Symbols.Maps.empty sub.Parse_tree.sub_parameters
in
sym.sym_info <- Parameter_sym(t)
with Bail_out -> ()
) sub.Parse_tree.sub_parameters;
(* Translate preconditions. *)
let preconditions =
subprogram_info.sub_preconditions <-
List.map
(translate_expr context)
sub.Parse_tree.sub_preconditions
sub.Parse_tree.sub_preconditions;
(* Translate the body later. *)
state.st_subprograms <-
(subprogram_sym, sub) :: state.st_subprograms
let translate_subprogram_body state subprogram_sym sub =
let subprogram_info = match subprogram_sym.sym_info with
| Subprogram_sym(info) -> info
in
(* Translate subprogram body. *)
let parameters = parameters_of_subprogram subprogram_sym in
let context = {
ctx_scope = subprogram_sym;
ctx_after = None;
ctx_last_loc = sub.Parse_tree.sub_location;
} in
assert (match state.st_blocks with [] -> true | _ -> false);
let entry_point =
translate_block state context
sub.Parse_tree.sub_body
in
entry_point.bl_preconditions <- preconditions;
entry_point.bl_preconditions <- subprogram_info.sub_preconditions;
calculate_free_names state.st_blocks;
let f = new_formatter () in
dump_blocks f state.st_blocks;
prerr_endline (get_fmt_str f);
Type_checking.type_check_blocks
state.st_blocks
entry_point
parameters
let translate_declarations state context declarations =
List.iter (function
| Parse_tree.Subprogram(sub) ->
translate_subprogram_prototype state context sub
) declarations
let finish_translation state =
let subs = state.st_subprograms in
state.st_subprograms <- [];
List.iter (fun (sym, sub) ->
translate_subprogram_body state sym sub) subs
let translate_package state pkg =
match pkg.Parse_tree.pkg_name with [name] ->
let package_sym = new_symbol root_symbol name Package_sym in
let context =
{
ctx_scope = package_sym;
ctx_after = None;
ctx_last_loc = pkg.Parse_tree.pkg_location;
}
in
translate_declarations state context
pkg.Parse_tree.pkg_declarations;
finish_translation state
let translate translation_unit =
let state = {
st_subprograms = [];
st_blocks = [];
} in
match translation_unit with
| Parse_tree.Subprogram_unit sub ->
let context = {
ctx_scope = root_symbol;
ctx_after = None;
ctx_last_loc = sub.Parse_tree.sub_location
} in
translate_subprogram_prototype state context sub;
finish_translation state
| Parse_tree.Package_unit pkg ->
translate_package state pkg
View
@@ -1 +1 @@
val translate : Parse_tree.subprogram -> unit
val translate : Parse_tree.translation_unit -> unit

0 comments on commit 619434e

Please sign in to comment.