1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* only by permission. *)
(* *)
(***********************************************************************)
open Syntaxe;;
open Envir;;
type erreur_de_type =
| Indfini of string (* variable utilise mais non dfinie *)
| Conflit of string * expr_type * expr_type (* conflit de types *)
| Arit of string * int * int (* mauvais nombre d'arguments *)
| Tableau_attendu (* [..] appliqu un non-tableau *)
| Tableau_interdit of string;; (* tableau renvoy en rsultat *)
exception Erreur_typage of erreur_de_type;;
let vrifie_type message type_attendu type_rel =
if type_attendu <> type_rel then
raise(Erreur_typage(Conflit(message, type_attendu, type_rel)));;
let vrifie_tableau = function
| Array(inf, sup, lments) -> lments
| _ -> raise(Erreur_typage(Tableau_attendu));;
let vrifie_non_tableau message = function
| Array(inf, sup, lments) ->
raise(Erreur_typage(Tableau_interdit message))
| _ -> ();;
let rec type_expr env = function
| Constante(Entire n) -> Integer
| Constante(Boolenne b) -> Boolean
| Variable nom_var ->
cherche_variable nom_var env
| Application(nom_fonc, args) ->
let fonc = cherche_fonction nom_fonc env in
type_application env nom_fonc fonc.fonc_paramtres args;
fonc.fonc_type_rsultat
| Op_unaire(op, arg) ->
let (type_arg, type_res) = type_op_unaire op in
vrifie_type ("l'argument de " ^ op)
type_arg (type_expr env arg);
type_res
| Op_binaire(op, arg1, arg2) ->
let (type_arg1, type_arg2, type_res) = type_op_binaire op in
vrifie_type ("le premier argument de " ^ op)
type_arg1 (type_expr env arg1);
vrifie_type ("le deuxime argument de " ^ op)
type_arg2 (type_expr env arg2);
type_res
| Accs_tableau(expr1, expr2) ->
let type_lments = vrifie_tableau (type_expr env expr1) in
vrifie_type "l'indice de tableau"
Integer (type_expr env expr2);
type_lments
and type_application env nom paramtres arguments =
let nbr_paramtres = List.length paramtres
and nbr_arguments = List.length arguments in
if nbr_paramtres <> nbr_arguments then
raise(Erreur_typage(Arit(nom, nbr_paramtres, nbr_arguments)));
let type_paramtre (nom_param, type_param) argument =
vrifie_type ("le paramtre " ^ nom_param ^ " de " ^ nom)
type_param (type_expr env argument) in
List.iter2 type_paramtre paramtres arguments
and type_op_unaire = function
| "-" -> (Integer, Integer)
| "not" -> (Boolean, Boolean)
| _ -> failwith "oprateur unaire inconnu"
and type_op_binaire = function
| "*" | "/" | "+" | "-" -> (Integer,Integer,Integer)
| "=" | "<>" | "<" | ">" | "<=" | ">=" -> (Integer,Integer,Boolean)
| "and" | "or" -> (Boolean,Boolean,Boolean)
| _ -> failwith "oprateur binaire inconnu";;
let rec type_instr env = function
| Affectation_var(nom_var, expr) ->
let type_var = cherche_variable nom_var env in
vrifie_non_tableau ("affectation de " ^ nom_var) type_var;
vrifie_type ("la variable " ^ nom_var)
type_var (type_expr env expr)
| Affectation_tableau(expr1, expr2, expr3) ->
let type_lments = vrifie_tableau (type_expr env expr1) in
vrifie_non_tableau "affectation de tableau" type_lments;
vrifie_type "l'indice de tableau"
Integer (type_expr env expr2);
vrifie_type "affectation de tableau"
type_lments (type_expr env expr3)
| Appel(nom_proc, args) ->
let proc = cherche_procdure nom_proc env in
type_application env nom_proc proc.proc_paramtres args
| If(condition, branche_oui, branche_non) ->
vrifie_type "la condition de IF"
Boolean (type_expr env condition);
type_instr env branche_oui;
type_instr env branche_non
| While(condition, corps) ->
vrifie_type "la condition de WHILE"
Boolean (type_expr env condition);
type_instr env corps
| Write expr ->
vrifie_type "l'argument de WRITE"
Integer (type_expr env expr)
| Read nom_var ->
vrifie_type "l'argument de READ"
Integer (cherche_variable nom_var env)
| Bloc liste ->
List.iter (type_instr env) liste;;
let ajoute_var (nom, typ) env = ajoute_variable nom typ env;;
let type_procdure env_global (nom, dcl) =
let env =
List.fold_right ajoute_var
(dcl.proc_variables @ dcl.proc_paramtres)
env_global in
type_instr env dcl.proc_corps;;
let type_fonction env_global (nom, dcl) =
vrifie_non_tableau
("passage comme rsultat de la fonction " ^ nom)
dcl.fonc_type_rsultat;
let env =
List.fold_right ajoute_var
((nom, dcl.fonc_type_rsultat) ::
dcl.fonc_variables @ dcl.fonc_paramtres)
env_global in
type_instr env dcl.fonc_corps;;
let type_programme prog =
let env_global =
List.fold_right ajoute_var prog.prog_variables
(environnement_initial prog.prog_procdures
prog.prog_fonctions) in
try
List.iter (type_procdure env_global) prog.prog_procdures;
List.iter (type_fonction env_global) prog.prog_fonctions;
type_instr env_global prog.prog_corps
with Pas_trouv nom ->
raise(Erreur_typage(Indfini nom));;
let rec affiche_type = function
| Integer -> prerr_string "integer"
| Boolean -> prerr_string "boolean"
| Array(inf, sup, ty) ->
prerr_string "array ["; prerr_int inf; prerr_string "..";
prerr_int sup; prerr_string "] of "; affiche_type ty;;
let affiche_erreur = function
| Indfini nom ->
prerr_string "Nom inconnu: "; prerr_string nom;
prerr_endline "."
| Conflit(message, type_attendu, type_rel) ->
prerr_string "Conflit de types: "; prerr_string message;
prerr_string " devrait avoir le type ";
affiche_type type_attendu;
prerr_string " mais a le type "; affiche_type type_rel;
prerr_endline "."
| Arit(nom, nbr_paramtres, nbr_arguments) ->
prerr_string "Mauvais nombre d'arguments: "; prerr_string nom;
prerr_string " attend "; prerr_int nbr_paramtres;
prerr_string " paramtre(s), mais est appele avec ";
prerr_int nbr_arguments; prerr_endline " argument(s)."
| Tableau_attendu ->
prerr_endline "Accs dans un objet qui n'est pas un tableau."
| Tableau_interdit message ->
prerr_string "Opration interdite sur les tableaux: ";
prerr_string message; prerr_endline ".";;
|
