ajout du TP1 (finis ?)
This commit is contained in:
commit
afed2675cb
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
|
@ -0,0 +1 @@
|
||||||
|
_build/
|
82
Ast.ml
Executable file
82
Ast.ml
Executable file
|
@ -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"
|
40
Main.ml
Executable file
40
Main.ml
Executable file
|
@ -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))
|
237
Semantics.ml
Executable file
237
Semantics.ml
Executable file
|
@ -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
|
10
dune
Executable file
10
dune
Executable file
|
@ -0,0 +1,10 @@
|
||||||
|
(ocamllex lexer)
|
||||||
|
|
||||||
|
(menhir
|
||||||
|
(modules parser))
|
||||||
|
|
||||||
|
(library
|
||||||
|
(name miniML)
|
||||||
|
(inline_tests)
|
||||||
|
(preprocess
|
||||||
|
(pps ppx_inline_test)))
|
2
dune-project
Executable file
2
dune-project
Executable file
|
@ -0,0 +1,2 @@
|
||||||
|
(lang dune 2.9)
|
||||||
|
(using menhir 2.1)
|
2
dune-workspace
Executable file
2
dune-workspace
Executable file
|
@ -0,0 +1,2 @@
|
||||||
|
(lang dune 2.9)
|
||||||
|
(env (dev (flags (:standard -warn-error -A))))
|
1
exemples/exemple-00.mml
Executable file
1
exemples/exemple-00.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
1+2
|
1
exemples/exemple-01.mml
Executable file
1
exemples/exemple-01.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
- 8
|
1
exemples/exemple-02.mml
Executable file
1
exemples/exemple-02.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
if 4 < 5 then 4 else 5
|
1
exemples/exemple-03.mml
Executable file
1
exemples/exemple-03.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
let x = 4 in x + 1
|
1
exemples/exemple-04.mml
Executable file
1
exemples/exemple-04.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
((fun x -> x) (1))
|
1
exemples/exemple-05.mml
Executable file
1
exemples/exemple-05.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
let add = (fun x -> x+1) in (add) 1
|
5
exemples/exemple-06.mml
Executable file
5
exemples/exemple-06.mml
Executable file
|
@ -0,0 +1,5 @@
|
||||||
|
letrec fact =
|
||||||
|
fun n -> if (n = 0 )
|
||||||
|
then 1
|
||||||
|
else n *((fact) (n-1))
|
||||||
|
in (fact) 5
|
1
exemples/exemple-07.mml
Executable file
1
exemples/exemple-07.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
let y = 5 in let x = 4 in let y = 6 in x +y
|
1
exemples/exemple-08.mml
Executable file
1
exemples/exemple-08.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
let x = 1 in let add = fun y -> x + y in (add) 4
|
1
exemples/exemple-09.mml
Executable file
1
exemples/exemple-09.mml
Executable file
|
@ -0,0 +1 @@
|
||||||
|
let id = fun x -> x in id
|
12
exemples/exemple-11.mml
Executable file
12
exemples/exemple-11.mml
Executable file
|
@ -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)
|
||||||
|
|
5
exemples/exemple-12.mml
Executable file
5
exemples/exemple-12.mml
Executable file
|
@ -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
|
47
lexer.mll
Executable file
47
lexer.mll
Executable file
|
@ -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))) }
|
100
parser.mly
Executable file
100
parser.mly
Executable file
|
@ -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}
|
Loading…
Reference in a new issue