238 lines
8.8 KiB
OCaml
Executable file
238 lines
8.8 KiB
OCaml
Executable file
(* 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
|