From f9f70e9fe519e1c3d1523aa573cb97ff8d1e05d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20Filli=C3=A2tre?= Date: Wed, 10 Feb 2010 08:19:34 +0000 Subject: [PATCH] typage des declarations de types --- Makefile.in | 2 +- lib/util.ml | 10 ++++++++++ lib/util.mli | 3 +++ src/lexer.mli | 2 +- src/lexer.mll | 8 ++++---- src/main.ml | 9 ++++++--- src/test.why | 5 +++-- src/typing.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/typing.mli | 21 +++++++++++++++++++++ 9 files changed, 100 insertions(+), 11 deletions(-) create mode 100644 lib/util.ml create mode 100644 lib/util.mli diff --git a/Makefile.in b/Makefile.in index a22fa032c..1005f6e44 100644 --- a/Makefile.in +++ b/Makefile.in @@ -88,7 +88,7 @@ check: $(BINARY) $(PRELUDE) # why ##### -LIBCMO = lib/pp.cmo lib/loc.cmo +LIBCMO = lib/pp.cmo lib/loc.cmo lib/util.cmo CMO = $(LIBCMO) src/name.cmo src/hashcons.cmo src/term.cmo src/pretty.cmo \ src/parser.cmo src/lexer.cmo src/typing.cmo src/main.cmo diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 000000000..c14168ff7 --- /dev/null +++ b/lib/util.ml @@ -0,0 +1,10 @@ + +let map_fold_left f acc l = + let acc, rev = + List.fold_left + (fun (acc, rev) e -> let acc, e = f acc e in acc, e :: rev) + (acc, []) l + in + acc, List.rev rev + + diff --git a/lib/util.mli b/lib/util.mli new file mode 100644 index 000000000..e59eba0fa --- /dev/null +++ b/lib/util.mli @@ -0,0 +1,3 @@ + +val map_fold_left : + ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list diff --git a/src/lexer.mli b/src/lexer.mli index ff8e5f9f8..c474fea3f 100644 --- a/src/lexer.mli +++ b/src/lexer.mli @@ -1,7 +1,7 @@ type error -exception Lexical_error of error +exception Error of error val report : Format.formatter -> error -> unit diff --git a/src/lexer.mll b/src/lexer.mll index 65d661510..461fffbe4 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -12,7 +12,7 @@ | UnterminatedComment | UnterminatedString - exception Lexical_error of error + exception Error of error let report fmt = function | IllegalCharacter c -> fprintf fmt "illegal character %c" c @@ -213,7 +213,7 @@ rule token = parse | eof { EOF } | _ as c - { raise (Lexical_error (IllegalCharacter c)) } + { raise (Error (IllegalCharacter c)) } and comment = parse | "*)" @@ -223,7 +223,7 @@ and comment = parse | newline { newline lexbuf; comment lexbuf } | eof - { raise (Lexical_error UnterminatedComment) } + { raise (Error UnterminatedComment) } | _ { comment lexbuf } @@ -235,7 +235,7 @@ and string = parse | newline { newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf } | eof - { raise (Lexical_error UnterminatedString) } + { raise (Error UnterminatedString) } | _ as c { Buffer.add_char string_buf c; string lexbuf } diff --git a/src/main.ml b/src/main.ml index ba184518c..26fe947cf 100644 --- a/src/main.ml +++ b/src/main.ml @@ -19,12 +19,14 @@ open Format let file = Sys.argv.(1) let rec report fmt = function - | Lexer.Lexical_error e -> + | Lexer.Error e -> fprintf fmt "lexical error: %a" Lexer.report e; | Loc.Located (loc, e) -> fprintf fmt "%a%a" Loc.report_position loc report e | Parsing.Parse_error -> fprintf fmt "syntax error" + | Typing.Error e -> + Typing.report fmt e | e -> fprintf fmt "anomaly: %s" (Printexc.to_string e) @@ -33,8 +35,9 @@ let () = let c = open_in file in let lb = Lexing.from_channel c in Loc.set_file file lb; - let _f = Lexer.parse_logic_file lb in - close_in c + let f = Lexer.parse_logic_file lb in + close_in c; + ignore (List.fold_left Typing.add Typing.empty f) with e -> eprintf "%a@." report e; exit 1 diff --git a/src/test.why b/src/test.why index d3e64fa67..1a813a92a 100644 --- a/src/test.why +++ b/src/test.why @@ -3,6 +3,7 @@ type 'a list -logic nil : 'a list -logic cons : 'a, 'a list -> 'a list +(* logic nil : 'a list *) +(* logic cons : 'a, 'a list -> 'a list *) + diff --git a/src/typing.ml b/src/typing.ml index ea20d19ad..b09b34ea7 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -1,6 +1,26 @@ +open Util +open Format open Term +(** errors *) + +type error = + | ClashType of string + | BadTypeArity of string + +exception Error of error + +let error ?loc e = match loc with + | None -> raise (Error e) + | Some loc -> raise (Loc.Located (loc, Error e)) + +let report fmt = function + | ClashType s -> + fprintf fmt "clash with previous type %s" s + | BadTypeArity s -> + fprintf fmt "duplicate type parameter %s" s + module M = Map.Make(String) type env = { @@ -19,3 +39,34 @@ let empty = { vars = M.empty; } +let find_tysymbol s env = M.find s env.tysymbols +let find_fsymbol s env = M.find s env.fsymbols +let find_psymbol s env = M.find s env.psymbols +let find_tyvar s env = M.find s env.tyvars +let find_var s env = M.find s env.vars + +(** typing *) + +let term env t = + assert false (*TODO*) + +(** building environments *) + +open Ptree + +let add_type loc ext sl s env = + if M.mem s env.tysymbols then error ~loc (ClashType s); + let add_ty_var env x = + if M.mem x env.tyvars then error ~loc (BadTypeArity x); + let v = Name.from_string x in + { env with tyvars = M.add x v env.tyvars}, v + in + let _, vl = map_fold_left add_ty_var env sl in + let ty = Ty.create_tysymbol (Name.from_string s) vl None in + { env with tysymbols = M.add s ty env.tysymbols } + +let add env = function + | TypeDecl (loc, ext, sl, s) -> + add_type loc ext sl s env + | _ -> + assert false (*TODO*) diff --git a/src/typing.mli b/src/typing.mli index b803962cb..78b719a96 100644 --- a/src/typing.mli +++ b/src/typing.mli @@ -7,3 +7,24 @@ type env val empty : env +val find_tysymbol : string -> env -> tysymbol +val find_fsymbol : string -> env -> fsymbol +val find_psymbol : string -> env -> psymbol +val find_tyvar : string -> env -> vsymbol +val find_var : string -> env -> vsymbol + +(** typing *) + +val term : env -> Ptree.lexpr -> term + +(** building environments *) + +val add : env -> Ptree.logic_decl ->env + +(** error reporting *) + +type error + +exception Error of error + +val report : Format.formatter -> error -> unit -- GitLab