ajout du TP1 (finis ?)

.gitignore

@@ -0,0 +1 @@
+_build/

Ast.ml

@@ -0,0 +1,82 @@
+(* Type des opérateurs binaires *)
+type binary = 
+  | Add 
+  | Substract 
+  | Or 
+  | Multiply 
+  | Divide 
+  | And 
+  | Equal 
+  | Different 
+  | Lesser 
+  | LesserEqual 
+  | Greater 
+  | GreaterEqual
+
+(*Type des opérateurs unaires *)
+type unary = 
+  | Negate
+
+(*Type pour la construction de l'arbre abstrait (Abstract Syntaxic Tree) *)
+type ast =
+  | FunctionNode of string * ast
+  | CallNode of ast * ast
+  | IfthenelseNode of ast * ast * ast
+  | LetNode of string * ast * ast
+  | LetrecNode of string * ast * ast
+  | AccessNode of string
+  | IntegerNode of int
+  | BinaryNode of binary * ast * ast
+  | UnaryNode of unary * ast
+  | TrueNode
+  | FalseNode
+
+(* string_of_binary : binary -> string *)
+(* Convertit un opérateur binaire en une chaine de caractères en vue de son affichage *)
+let string_of_binary op = match op with
+  | Equal -> " = "
+  | Different -> " != "
+  | Lesser -> " < "
+  | Greater -> " > "
+  | LesserEqual -> " <= "
+  | GreaterEqual -> " => "
+  | Add -> " + "
+  | Substract -> " - "
+  | Or -> " || "
+  | Multiply -> " * "
+  | Divide -> " / "
+  | And -> " && "
+
+(* string_of_unary : unary -> string *)
+(* Convertit un opérateur unaire en une chaine de caractères en vue de son affichage *)
+let string_of_unary op = match op with
+  | Negate -> "- "
+
+(* paren : string -> string *)
+(* Met une chaîne de charactères entre parenthèses *)
+let paren s = "(" ^ s ^ ")"
+
+(* string_of_ast : ast -> string *)
+(* Convertit un ast en une chaine de caractères en vue de son affichage *)
+let rec string_of_ast tree =
+  match tree with
+  | FunctionNode (par, body) ->
+    paren ("fun " ^ par ^ " -> " ^ string_of_ast body)
+  | CallNode (func, par) ->
+    paren (string_of_ast func ^ " " ^ string_of_ast par)
+  | IfthenelseNode (cond, bthen, belse) ->
+    paren ("if " ^ string_of_ast cond
+           ^ " then " ^ string_of_ast bthen
+           ^ " else " ^ string_of_ast belse)
+  | LetNode (id, blet, bin) ->
+    paren ("let " ^ id ^ " = " ^ string_of_ast blet ^ " in " ^ string_of_ast bin)
+  | LetrecNode (id, blet, bin) ->
+    paren ("let rec " ^ id ^ " = " ^ string_of_ast blet ^ " in " ^ string_of_ast bin)
+  | AccessNode name -> name
+  | IntegerNode value -> string_of_int value
+  | BinaryNode (op, left, right) ->
+     paren (string_of_ast left ^ string_of_binary op ^ string_of_ast right)
+  | UnaryNode (op, expr) ->
+     paren (string_of_unary op ^ string_of_ast expr)
+  | TrueNode -> "true"
+  | FalseNode -> "false"

Main.ml

@@ -0,0 +1,40 @@
+open Ast 
+open Lexing
+open Semantics
+
+let report_error filename lexbuf msg =
+ let (b,e) = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) in
+ let fc = b.pos_cnum - b.pos_bol + 1 in
+ let lc = e.pos_cnum - b.pos_bol + 1 in
+ Printf.eprintf "File \"%s\", line %d, characters %d-%d: %s\n" filename b.pos_lnum fc lc msg
+
+(* main : string -> valueType *)
+(* Analyse le contenu d'un fichier passé en paramètre *)
+(* Dans le cas où l'analyse syntaxique s'est bien passée, lance l'analyse sémantique avec un environement d'évaluation initial vide *)
+let main fichier =
+  let input = open_in fichier in
+  let filebuf = Lexing.from_channel input in
+  try
+    let ast = Parser.main Lexer.token filebuf in
+    let env = [] in 
+    value_of_expr ast env
+  with
+  | Lexer.Error s ->
+      report_error fichier filebuf ("lexical error (" ^ s ^ ").");
+      exit 2
+  | Parser.Error ->
+      report_error fichier filebuf "syntax error.";
+      exit 2
+
+let%test _ = ( (main "../../exemples/exemple-00.mml") = (IntegerValue 3))
+let%test _ = ( (main "../../exemples/exemple-01.mml") = (IntegerValue (-8)))
+let%test _ = ( (main "../../exemples/exemple-02.mml") = (IntegerValue 4))
+let%test _ = ( (main "../../exemples/exemple-03.mml") = (IntegerValue 5))
+let%test _ = ( (main "../../exemples/exemple-04.mml") = (IntegerValue 1))
+let%test _ = ( (main "../../exemples/exemple-05.mml") = (IntegerValue 2))
+let%test _ = ( (main "../../exemples/exemple-06.mml") = (IntegerValue 120))
+let%test _ = ( (main "../../exemples/exemple-07.mml") = (IntegerValue 10))
+let%test _ = ( (main "../../exemples/exemple-08.mml") = (IntegerValue 5))
+let%test _ = ( (main "../../exemples/exemple-09.mml") = (FrozenValue (FunctionNode ("x",AccessNode "x"),[])))
+let%test _ = ( (main "../../exemples/exemple-11.mml") = (IntegerValue 120))
+let%test _ = ( (main "../../exemples/exemple-12.mml") = (IntegerValue 120))

Semantics.ml

@@ -0,0 +1,237 @@
+(* Analyseur sémantique *)
+
+open Ast
+
+(* ========================================================*)
+(* Définition du type des erreurs *)
+type errorType =
+  | UnknownIdentError of string
+  | TypeMismatchError
+  | RuntimeError
+  | UndefinedExpressionError
+
+
+(* ========================================================*)
+(* Définition du type des valeurs renvoyées par l'interprète *)
+type valueType =
+  | FrozenValue of ast * environment
+  | FixPoint of ast * environment
+  | IntegerValue of int
+  | BooleanValue of bool
+  | ErrorValue of errorType
+and environment = (string * valueType) list
+
+
+(* ========================================================*)
+(* string_of_names : string list -> string *)
+(* Convertit une liste de chaînes de caractères en une seule chaîne de caractères *)
+let string_of_names names =
+  String.concat " " names
+
+(* string_of_env : environment -> string *)
+(* Convertit un environnement en une chaîne de caractères en vue de son affichage *)
+let rec string_of_env env =
+  "{"
+  ^ List.fold_left (fun s (key, value) ->
+      s ^ (if s = "" then "" else " ; ") ^ key ^ "," ^ string_of_value value)
+    "" env
+  ^ "}"
+
+(* string_of_value : valueType -> string *)
+(* Convertit une valueType en une chaîne de caractères en vue de son affichage *)
+and string_of_value value =
+  match value with
+  | FixPoint (expr, env) -> "fix(" ^ string_of_ast expr ^ string_of_env env ^ ")"
+  | FrozenValue (expr, env) -> string_of_ast expr ^ string_of_env env
+  | IntegerValue value -> string_of_int value
+  | BooleanValue value -> string_of_bool value
+  | ErrorValue error -> string_of_error error
+
+(* string_of_error : errorType -> string *)
+(* Convertit une erreur en une chaîne de caractères en vue de son affichage *)
+and string_of_error error =
+  match error with
+  | UnknownIdentError name -> "Unknown ident: " ^ name
+  | RuntimeError -> "Runtime error"
+  | TypeMismatchError -> "Type mismatch"
+  | UndefinedExpressionError -> "Undefined expression error"
+
+
+(* ========================================================*)
+type 'a searchResult = 
+  | NotFound 
+  | Found of 'a
+
+
+(* lookfor : string -> environment -> valueType searchResult *)
+(* Cherche un identifiant dans un environnement et renvoie la valeur associée le cas échéant *)
+let rec lookfor name env =
+  match env with
+  | [] -> NotFound
+  | (key, value) :: others ->
+    if key = name then Found value else lookfor name others
+
+
+(* ========================================================*)
+(* value_of_expr : ast -> environment -> valueType *)
+(* Fonction d'évaluation des expressions *)
+let rec value_of_expr expr env =
+  match expr with
+  | FunctionNode _ -> ruleFunction expr env
+  | CallNode (fexpr, pexpr) -> ruleCallByValue env fexpr pexpr
+  (*| CallNode (fexpr, pexpr) -> ruleCallByName env fexpr pexpr *)
+  | IfthenelseNode (cond, bthen, belse) -> ruleIf env cond bthen belse
+  | LetNode (ident, bvalue, bin) -> ruleLet env ident bvalue bin
+  | LetrecNode (ident, bvalue, bin) -> ruleLetrec env ident bvalue bin
+  | AccessNode name -> ruleName env name
+  | IntegerNode value -> ruleInteger value
+  | TrueNode -> ruleTrue
+  | FalseNode -> ruleFalse
+  | BinaryNode (op, left, right) -> ruleBinary env op left right
+  | UnaryNode (op, expr) -> ruleUnary env op expr
+
+(* ========================================================*)
+(* ruleName : environment -> string -> valueType *)
+(* Fonction d'évaluation d'un identificateur *)
+and ruleName env name =
+  match lookfor name env with
+  | NotFound -> ErrorValue (UnknownIdentError name)
+  | Found (FixPoint (e, gdef)) -> FrozenValue(e, (name, FixPoint(e,gdef))::gdef)
+  | Found value -> value
+
+(* ========================================================*)
+(* ruleLet : environment -> string -> ast -> ast -> valueType *)
+(* Fonction d'évaluation d'un let *)
+(* "let ident = bvalue in bin" *)
+and ruleLet env ident bvalue bin =
+  let bvalueV = value_of_expr bvalue env in
+  match bvalueV with
+  | ErrorValue _ as result -> result
+  | _ ->
+    let env2 = (ident, bvalueV)::env in
+    value_of_expr bin env2
+
+(* ========================================================*)
+(* ruleBinary : environment -> binary -> ast- > ast -> valueType *)
+(* Fonction d'évaluation d'un opérateur binaire *)
+and ruleBinary env op left right =
+  let leftvalue = value_of_expr left env in
+  match leftvalue with
+   | ErrorValue _ as result -> result
+   | _ ->
+     let rightvalue = value_of_expr right env in
+     (match rightvalue with
+      | ErrorValue _ as result -> result
+      | _ ->
+        (match leftvalue, rightvalue with
+         | IntegerValue leftvalue, IntegerValue rightvalue ->
+           (match op with
+            | Equal -> BooleanValue (leftvalue = rightvalue)
+            | Different -> BooleanValue (leftvalue <> rightvalue)
+            | Lesser -> BooleanValue (leftvalue < rightvalue)
+            | LesserEqual -> BooleanValue (leftvalue <= rightvalue)
+            | Greater -> BooleanValue (leftvalue > rightvalue)
+            | GreaterEqual -> BooleanValue (leftvalue >= rightvalue)
+            | Add -> IntegerValue (leftvalue + rightvalue)
+            | Substract -> IntegerValue (leftvalue - rightvalue)
+            | Multiply -> IntegerValue (leftvalue * rightvalue)
+            | Divide ->
+              if rightvalue = 0 then
+                 ErrorValue RuntimeError
+               else
+                 IntegerValue (leftvalue / rightvalue)
+            | _ -> ErrorValue TypeMismatchError)
+         | BooleanValue leftvalue, BooleanValue rightvalue ->
+           (match op with
+            | Or -> BooleanValue (leftvalue || rightvalue)
+            | And -> BooleanValue (leftvalue && rightvalue)
+            | _ -> ErrorValue TypeMismatchError)
+         | _ -> ErrorValue TypeMismatchError))
+
+(* ========================================================*)
+(* ruleUnary : environment -> unary -> ast- > valueType *)
+(* Fonction d'évaluation d'un opérateur unaire *)
+and ruleUnary env op exp =
+  let value = value_of_expr exp env in
+  match value with
+  | ErrorValue _ as result -> result
+  | IntegerValue value ->
+    (match op with
+     | Negate -> IntegerValue (- value))
+  | _ -> ErrorValue TypeMismatchError
+
+(* ========================================================*)
+(* ruleIf : environment -> ast -> ast -> ast -> valueType *)
+(* Fonction d'évaluation d'une conditionnelle *)
+(* "if cond then bthen else belse" *)
+and ruleIf env cond bthen belse =
+  let condV = value_of_expr cond env in
+  match condV with
+  | ErrorValue _ as result -> result
+  | (BooleanValue true) -> value_of_expr bthen env
+  | (BooleanValue false) -> value_of_expr belse env
+  | _ -> ErrorValue TypeMismatchError
+
+(* ========================================================*)
+(* ruleFunction : ast -> environment -> valueType *)
+(* Fonction d'évaluation d'une définition de fonction *)
+and ruleFunction expr env =
+  FrozenValue(expr, env)
+
+(* Appel par nom *)
+(* ========================================================*)
+(* ruleCallByName : environment -> ast -> ast -> valueType *)
+(* Fonction d'évaluation d'un appel de fonction avec passage de paramètre par nom *)
+and ruleCallByName env fexpr pexpr =
+  (* let fexprV = value_of_expr env fexpr in
+  match fexprV with
+  | ErrorValue _ as result -> result
+  | FixPoint _ ->
+    let exprV = value_of_expr env pexpr in
+    match exprV with
+     *)
+  ErrorValue UndefinedExpressionError
+
+(* ========================================================*)
+(* ruleCallByValue : environment -> ast -> ast -> valueType *)
+(* Fonction d'évaluation d'un appel de fonction avec passage de paramètre par valeur *)
+and ruleCallByValue env fexpr pexpr =
+  (* Appel par valeur *)
+  let fexprV = value_of_expr fexpr env in
+  match fexprV with
+  | ErrorValue _ as result -> result
+  | FrozenValue (func, env2) ->
+    let pexprV = value_of_expr pexpr env in
+    match pexprV with
+    | ErrorValue _ as result -> result
+    | _ ->
+      let FunctionNode(id, expr) = func in
+      value_of_expr expr ((id, pexprV)::env2)
+  | _ -> ErrorValue TypeMismatchError
+
+(* ========================================================*)
+(* ruleLetrec : environment -> string -> ast- > ast -> valueType *)
+(* Fonction d'évaluation d'un let rec*)
+(* "letrec ident = bvalue in bin" *)
+and ruleLetrec env ident bvalue bin =
+  let bvalueV = value_of_expr bvalue env in
+  match bvalueV with
+  | ErrorValue _ as result -> result
+  | _ ->
+    let env2 = ((ident, FixPoint(bvalue, env))::env) in
+    value_of_expr bin env2
+
+(* ========================================================*)
+(* ruleTrue : valueType *)
+(* Fonction d'évaluation de true *)
+and ruleTrue = BooleanValue true
+
+(* ========================================================*)
+(* ruleFalse : valueType *)
+(* Fonction d'évaluation de false *)
+and ruleFalse = BooleanValue false
+
+(* ========================================================*)
+  (* ruleInteger : int -> valueType *)
+  (* Fonction d'évaluation d'un entier *)
+and ruleInteger value = IntegerValue value

dune

@@ -0,0 +1,10 @@
+(ocamllex lexer)
+
+(menhir
+ (modules parser))
+
+(library
+ (name miniML)
+ (inline_tests)
+ (preprocess
+  (pps ppx_inline_test)))

dune-project

@@ -0,0 +1,2 @@
+(lang dune 2.9)
+(using menhir 2.1)

dune-workspace

@@ -0,0 +1,2 @@
+(lang dune 2.9)
+(env (dev (flags (:standard -warn-error -A))))

exemples/exemple-00.mml

@@ -0,0 +1 @@
+1+2

exemples/exemple-01.mml

@@ -0,0 +1 @@
+- 8

exemples/exemple-02.mml

@@ -0,0 +1 @@
+if 4 < 5 then 4 else 5

exemples/exemple-03.mml

@@ -0,0 +1 @@
+let x = 4 in x + 1

exemples/exemple-04.mml

@@ -0,0 +1 @@
+((fun x -> x) (1))

exemples/exemple-05.mml

@@ -0,0 +1 @@
+let add = (fun x -> x+1) in (add) 1

exemples/exemple-06.mml

@@ -0,0 +1,5 @@
+letrec fact = 
+ fun n -> if (n = 0 )
+          then 1
+          else n *((fact) (n-1))
+ in (fact) 5

exemples/exemple-07.mml

@@ -0,0 +1 @@
+let y = 5 in let x = 4 in let y = 6 in x +y

exemples/exemple-08.mml

@@ -0,0 +1 @@
+let x = 1 in let add = fun y -> x + y in (add) 4 

exemples/exemple-09.mml

@@ -0,0 +1 @@
+let id = fun x -> x in id

exemples/exemple-11.mml

@@ -0,0 +1,12 @@
+letrec loop = fun fcond -> fun fnext -> fun feval -> fun arg -> fun acc ->
+              if ((fcond) arg) then acc
+              else let iter = ((feval) arg) acc in
+                   let next = (fnext) arg  in
+                   ((((((loop) fcond) fnext) feval) next) iter)
+
+in 
+  let done = fun x -> (x = 0) in
+  let next = fun x -> (x - 1) in
+  let eval = fun x -> fun y -> x * y in
+  ((((((loop) done) next) eval) 5) 1)
+   

exemples/exemple-12.mml

@@ -0,0 +1,5 @@
+let fact =
+  (letrec f = fun n -> letrec g = fun x -> if (x = 0) then 1 else x*((f) (x-1))
+                        in if (n = 0) then 1 else n *((g) (n-1))
+   in f)
+ in (fact) 5

lexer.mll

@@ -0,0 +1,47 @@
+{
+  open Parser
+  open Lexing
+
+  exception Error of string
+}
+
+
+let digit = ['0'-'9']
+let id = ['a'-'z'] ['a'-'z' '0'-'9']*
+
+rule token = parse
+  | '\n'  (* ignore newlines but count them *)
+      { new_line lexbuf; token lexbuf }
+  | [' ' '\t'] (* ignore whitespaces and tabs *)
+      { token lexbuf }
+  | '('       {LeftParenthesisToken}
+  | ')'       {RightParenthesisToken}
+  | '='       {EqualToken}
+  | "!="      {DifferentToken}
+  | '='       {EqualToken}
+  | '<'       {LesserToken}
+  | '>'       {GreaterToken}
+  | "<="      {LesserEqualToken}
+  | ">="      {GreaterEqualToken}
+  | '+'       {PlusToken}
+  | '-'       {MinusToken}
+  | '*'       {StarToken}
+  | '/'       {SlashToken}
+  | "&&"      {AndToken}
+  | "||"      {OrToken}
+  | "->"      {BodyToken}
+  | "fun"     {FunctionToken}
+  | "if"      {IfToken}
+  | "then"    {ThenToken}
+  | "else"    {ElseToken}
+  | "let"     {LetToken}
+  | "in"      {InToken}
+  | "letrec"  {RecToken}
+  | "true"    {TrueToken}
+  | "false"   {FalseToken }
+  | digit+ as inum
+              {NumberToken (int_of_string inum)}
+  | id as text
+              {IdentToken text}
+  | eof       { EOF }
+| _           { raise (Error ("Unexpected char: "^(Lexing.lexeme lexbuf))) }

parser.mly

@@ -0,0 +1,100 @@
+%{
+open Ast
+%}
+
+
+%token <int> NumberToken
+%token <string> IdentToken
+%token FunctionToken
+%token BodyToken
+%token IfToken
+%token ThenToken
+%token ElseToken
+%token LetToken
+%token InToken
+%token TrueToken
+%token FalseToken
+%token RecToken
+%token LeftParenthesisToken
+%token RightParenthesisToken
+%token EOF
+%token OrToken, AndToken, DifferentToken, EqualToken
+%token LesserToken, GreaterToken, LesserEqualToken, GreaterEqualToken
+%token PlusToken, MinusToken
+%token StarToken, SlashToken
+%token UMinusToken
+
+(* priorité et associativité *)
+(* Plus faible priorité au début *)
+(* http://caml.inria.fr/pub/docs/manual-ocaml/expr.html#sec116 *)
+%nonassoc BodyToken, ElseToken, InToken, RightParenthesisToken
+(* %nonassoc IfToken *)
+%right OrToken
+%right AndToken
+%left DifferentToken, EqualToken
+%nonassoc LesserToken, GreaterToken, LesserEqualToken, GreaterEqualToken
+%left PlusToken, MinusToken
+%left StarToken, SlashToken
+%left UMinusToken
+
+
+
+(* Type de l'attribut synthétisé des non-terminaux *)
+%type <Ast.ast> expr
+
+(* Type et définition de l'axiome *)
+%start <Ast.ast> main
+
+%%
+(*
+La grammaire n'est pas LR , on joue avec les priorités
+
+  E -> fun ident -> E
+  E -> let ident = E in E
+  E -> letrec ident = E in E
+  E -> if E then E else E
+  E -> (E) E
+  E -> (E)
+  E -> - E
+  E -> E = E
+  E -> E != E
+  E -> E >= E
+  E -> E > E
+  E -> E <= E
+  E -> E < E
+  E -> E & E
+  E -> E | E
+  E -> E * E
+  E -> E / E
+  E -> E - E
+  E -> E + E
+  E -> Ident
+  E -> Const
+
+*)
+main : a = expr EOF   {a}
+
+expr :
+| FunctionToken n = IdentToken BodyToken e = expr                    {FunctionNode (n,e)}
+| LetToken n = IdentToken EqualToken e1 = expr InToken e2 = expr     {LetNode (n,e1,e2)}
+| RecToken n = IdentToken EqualToken e1 = expr InToken e2 = expr     {LetrecNode (n,e1,e2)}
+| IfToken c= expr ThenToken t = expr ElseToken e = expr              {IfthenelseNode (c,t,e)}
+| LeftParenthesisToken f = expr RightParenthesisToken  p =expr       {CallNode (f,p)}
+| LeftParenthesisToken e = expr RightParenthesisToken                {e}
+| MinusToken  e = expr            %prec UMinusToken                  {UnaryNode (Negate,e)}
+| e1 = expr EqualToken e2 = expr                                     {BinaryNode (Equal,e1,e2)}
+| e1 = expr DifferentToken e2 = expr                                 {BinaryNode (Different,e1,e2)}
+| e1 = expr LesserToken e2 = expr                                    {BinaryNode (Lesser,e1,e2)}
+| e1 = expr GreaterToken e2 = expr                                   {BinaryNode (Greater,e1,e2)}
+| e1 = expr LesserEqualToken e2 = expr                               {BinaryNode (LesserEqual,e1,e2)}
+| e1 = expr GreaterEqualToken e2 = expr                              {BinaryNode (GreaterEqual,e1,e2)}
+| e1 = expr AndToken e2 = expr                                       {BinaryNode (And,e1,e2)}
+| e1 = expr OrToken e2 = expr                                        {BinaryNode (Or,e1,e2)}
+| e1 = expr PlusToken e2 = expr                                      {BinaryNode (Add,e1,e2)}
+| e1 = expr MinusToken e2 = expr                                     {BinaryNode (Substract,e1,e2)}
+| e1 = expr StarToken e2 = expr                                      {BinaryNode (Multiply,e1,e2)}
+| e1 = expr SlashToken e2 = expr                                     {BinaryNode (Divide,e1,e2)}
+| n = IdentToken                                                     {AccessNode n}
+| i = NumberToken                                                    {IntegerNode i}
+| TrueToken                                                          {TrueNode}
+| FalseToken                                                         {FalseNode}