← Back to branch summary

~ubuntu-branches/ubuntu/hardy/ocaml-doc/hardy

« back to all changes in this revision

Viewing changes to examples/pascal/compil.ml

  • Committer: Bazaar Package Importer
  • Author(s): Samuel Mimram
  • Date: 2007-09-08 01:49:22 UTC
  • mfrom: (0.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070908014922-lvihyehz0ndq7suu
Tags: 3.10-1
* New upstream release.
* Removed camlp4 documentation since it is not up-to-date.
* Updated to standards version 3.7.2, no changes needed.
* Updated my email address.

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/pascal/compil.ml
1
 
(***********************************************************************)
2
 
(*                                                                     *)
3
 
(*                           Objective Caml                            *)
4
 
(*                                                                     *)
5
 
(*               Pierre Weis, projet Cristal, INRIA Rocquencourt       *)
6
 
(*                                                                     *)
7
 
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
8
 
(*  en Automatique.  All rights reserved.  This file is distributed    *)
9
 
(*  only by permission.                                                *)
10
 
(*                                                                     *)
11
 
(***********************************************************************)
12
 
open Syntaxe;;
13
 
open Envir;;
14
 
open Printf;;
15
 
 
16
 
let taille_du_mot = 4;;            (* un mot = quatre octets *)
17
 
 
18
 
let rec taille_du_type = function
19
 
  | Integer | Boolean -> taille_du_mot
20
 
  | Array(inf, sup, ty) -> (sup - inf + 1) * taille_du_type ty;;
21
 
 
22
 
let val_const = function
23
 
  | Enti�re n -> n
24
 
  | Bool�enne b -> if b then 1 else 0;;
25
 
 
26
 
type info_variable =
27
 
  { typ : expr_type;
28
 
    emplacement : emplacement_variable }
29
 
 
30
 
and emplacement_variable =
31
 
  | Global_indirect of int
32
 
  | Global_direct of int
33
 
  | Local_indirect of int
34
 
  | Local_direct of int;;
35
 
 
36
 
let profondeur_pile = ref 0;;
37
 
 
38
 
let r�serve_pile n =
39
 
  printf "sub sp, %d, sp\n" (n * taille_du_mot);
40
 
  profondeur_pile := !profondeur_pile + n * taille_du_mot
41
 
 
42
 
and lib�re_pile n =
43
 
  printf "add sp, %d, sp\n" (n * taille_du_mot);
44
 
  profondeur_pile := !profondeur_pile - n * taille_du_mot;;
45
 
 
46
 
let rec type_de env = function
47
 
  | Constante(Enti�re n) -> Integer
48
 
  | Constante(Bool�enne b) -> Boolean
49
 
  | Variable nom -> (cherche_variable nom env).typ
50
 
  | Application(fonc, args) ->
51
 
      (cherche_fonction fonc env).fonc_type_r�sultat
52
 
  | Op_unaire(op, arg) ->
53
 
      let (type_arg, type_res) =
54
 
        Typage.type_op_unaire op
55
 
      in type_res
56
 
  | Op_binaire(op, arg1, arg2) ->
57
 
      let (type_arg1, type_arg2, type_res) =
58
 
        Typage.type_op_binaire op
59
 
      in type_res
60
 
  | Acc�s_tableau(arg1, arg2) ->
61
 
      match type_de env arg1 with
62
 
      | Array(inf, sup, ty) -> ty
63
 
      | _ -> failwith "type de tableau erron�";;
64
 
 
65
 
let rec sans_interf�rences env = function
66
 
  | Constante c -> true
67
 
  | Variable nom ->
68
 
      let var = cherche_variable nom env in
69
 
      begin match var.emplacement with
70
 
      | Global_indirect _ | Global_direct _ -> false
71
 
      | Local_indirect _  | Local_direct _  -> true
72
 
      end
73
 
  | Application(fonc, args) -> false
74
 
  | Op_unaire(op, arg) ->
75
 
      sans_interf�rences env arg
76
 
  | Op_binaire(op, arg1, arg2) ->
77
 
      sans_interf�rences env arg1 && sans_interf�rences env arg2
78
 
  | Acc�s_tableau(arg1, arg2)  ->
79
 
      sans_interf�rences env arg1 && sans_interf�rences env arg2;;
80
 
 
81
 
let dernier_registre = 24;;
82
 
 
83
 
let rec besoins env = function
84
 
  | Constante c -> 0
85
 
  | Variable nom -> 0
86
 
  | Application(fonc, args) -> dernier_registre
87
 
  | Op_unaire(op, arg) -> besoins env arg
88
 
  | Op_binaire(op, arg1, arg2) -> besoins_op_binaire env arg1 arg2
89
 
  | Acc�s_tableau(arg1, arg2) -> besoins_op_binaire env arg1 arg2
90
 
 
91
 
and besoins_op_binaire env arg1 arg2 =
92
 
  let b1 = besoins env arg1 and b2 = besoins env arg2 in
93
 
  if b1 < b2 && (sans_interf�rences env arg1 || sans_interf�rences env arg2)
94
 
  then max b2 (b1 + 1)
95
 
  else max b1 (b2 + 1);;
96
 
 
97
 
let instr_pour_op = function
98
 
  | "+"   -> "add"     | "-"   -> "sub"
99
 
  | "*"   -> "mult"    | "/"   -> "div"
100
 
  | "="   -> "seq"     | "<>"  -> "sne"
101
 
  | "<"   -> "slt"     | ">"   -> "sgt"
102
 
  | "<="  -> "sle"     | ">="  -> "sge"
103
 
  | "and" -> "and"     | "or"  -> "or"
104
 
  | _ -> failwith "op�rateur inconnu";;
105
 
 
106
 
let rec compile_expr env expr reg =
107
 
  match expr with
108
 
  | Constante cst ->
109
 
      printf "add r 0, %d, r %d\n" (val_const cst) reg
110
 
  | Variable nom ->
111
 
      let var = cherche_variable nom env in
112
 
      begin match var.emplacement with
113
 
      | Global_indirect n ->
114
 
          printf "load r 0, %d, r %d  # %s \n" n reg nom
115
 
      | Global_direct n ->
116
 
          printf "add r 0, %d, r %d  # %s \n" n reg nom
117
 
      | Local_indirect n ->
118
 
          printf "load sp, %d, r %d  # %s \n"
119
 
                 (!profondeur_pile - n) reg nom
120
 
      | Local_direct n ->
121
 
          printf "add sp, %d, r %d  # %s \n"
122
 
                 (!profondeur_pile - n) reg nom
123
 
      end
124
 
  | Application(fonc, arguments) ->
125
 
      let nbr_args = List.length arguments in
126
 
      r�serve_pile nbr_args;
127
 
      let position = ref 0 in
128
 
      List.iter
129
 
       (function arg ->
130
 
          compile_expr env arg 1;
131
 
          printf "store sp, %d, r 1\n" !position;
132
 
          position := !position + taille_du_mot)
133
 
       arguments;
134
 
      printf "jmp F%s, ra\n" fonc;
135
 
      lib�re_pile nbr_args;
136
 
      if reg <> 1 then printf "add r 1, r 0, r %d\n" reg
137
 
  | Op_unaire(op, arg) ->
138
 
      compile_expr env arg reg;
139
 
      begin match op with
140
 
      | "-" -> printf "sub r 0, r %d, r %d\n" reg reg
141
 
      | "not" -> printf "seq r 0, r %d, r %d\n"  reg reg
142
 
      | _ -> failwith "op�rateur uniaire inconnu"
143
 
      end
144
 
  | Op_binaire(op, arg1, Constante cst2) ->
145
 
      compile_expr env arg1 reg;
146
 
      printf "%s r %d, %d, r %d\n"
147
 
             (instr_pour_op op) reg (val_const cst2) reg
148
 
  | Op_binaire(("+" | "*" | "=" | "<>" | "and" | "or") as op,
149
 
               Constante cst1, arg2) ->
150
 
      compile_expr env arg2 reg;
151
 
      printf "%s r %d, %d, r %d\n"
152
 
             (instr_pour_op op) reg (val_const cst1) reg
153
 
  | Op_binaire(op, arg1, arg2) ->
154
 
      let (reg1, reg2) = compile_arguments env arg1 arg2 reg in      
155
 
      printf "%s r %d, r %d, r %d\n" (instr_pour_op op) reg1 reg2 reg
156
 
  | Acc�s_tableau(arg1, Constante cst) ->
157
 
      begin match type_de env arg1 with
158
 
      | Array(inf, sup, type_�l�ments) ->
159
 
         compile_expr env arg1 reg;
160
 
         begin match type_�l�ments with
161
 
         | Integer | Boolean ->
162
 
             printf "load r %d, %d, r %d\n" reg
163
 
                    ((val_const cst - inf) * taille_du_mot) reg
164
 
         | Array(_, _, _) ->
165
 
             let taille = taille_du_type type_�l�ments in
166
 
             printf "add r %d, %d, r %d\n"
167
 
                    reg ((val_const cst - inf) * taille) reg
168
 
         end
169
 
      | _ -> failwith "Erreur dans le contr�leur de types" end
170
 
  | Acc�s_tableau(arg1, arg2) ->
171
 
      begin match type_de env arg1 with
172
 
      | Array(inf, sup, type_�l�ments) ->
173
 
         let (reg1, reg2) = compile_arguments env arg1 arg2 reg in
174
 
         if inf <> 0 then printf "sub r %d, %d, r %d\n" reg2 inf reg2;
175
 
         begin match type_�l�ments with
176
 
         | Integer | Boolean ->
177
 
             printf "mult r %d, %d, r %d\n" reg2 taille_du_mot reg2;
178
 
             printf "load r %d, r %d, r %d\n" reg1 reg2 reg
179
 
         | Array(_, _, typ) ->
180
 
             let taille = taille_du_type type_�l�ments in
181
 
             printf "mult r %d, %d, r %d\n" reg2 taille reg2;
182
 
             printf "add r %d, r %d, r %d\n" reg1 reg2 reg
183
 
         end
184
 
      | _ -> failwith "Erreur dans le contr�leur de types" end
185
 
 
186
 
and compile_arguments env arg1 arg2 reg_libre =
187
 
  let b1 = besoins env arg1 and b2 = besoins env arg2 in
188
 
  if b1 < b2 && (sans_interf�rences env arg1 || sans_interf�rences env arg2)
189
 
  then begin
190
 
    let (reg2, reg1) = compile_arguments env arg2 arg1 reg_libre in
191
 
    (reg1, reg2)
192
 
  end else begin
193
 
    compile_expr env arg1 reg_libre;
194
 
    if b2 < dernier_registre - reg_libre then begin
195
 
      compile_expr env arg2 (reg_libre + 1);
196
 
      (reg_libre, reg_libre + 1)
197
 
    end else begin
198
 
      r�serve_pile 1;
199
 
      printf "store sp, 0, r %d\n" reg_libre;
200
 
      compile_expr env arg2 reg_libre;
201
 
      printf "load sp, 0, r 29\n";
202
 
      lib�re_pile 1;
203
 
      (29, reg_libre)
204
 
    end
205
 
  end;;
206
 
 
207
 
let compteur_d'�tiquettes = ref 0;;
208
 
 
209
 
let nouvelle_�tiq () =
210
 
  incr compteur_d'�tiquettes; !compteur_d'�tiquettes;;
211
 
 
212
 
let rec compile_instr env = function
213
 
  | Affectation_var(nom_var,
214
 
                    Constante(Enti�re 0 | Bool�enne false)) ->
215
 
      affecte_var env nom_var 0
216
 
  | Affectation_var(nom_var, expr) ->
217
 
      compile_expr env expr 1;
218
 
      affecte_var env nom_var 1
219
 
  | Affectation_tableau(expr1, Constante cst2, expr3) ->
220
 
      begin match type_de env expr1 with
221
 
      | Array(inf, sup, type_�l�ments) ->
222
 
         let (reg3, reg1) = compile_arguments env expr3 expr1 1 in
223
 
         printf "store r %d, %d, r %d\n"
224
 
                reg1 ((val_const cst2 - inf) * taille_du_mot) reg3
225
 
      | _ -> failwith "Erreur dans le contr�leur de types" end
226
 
  | Affectation_tableau(expr1, expr2, expr3) ->
227
 
      begin match type_de env expr1 with
228
 
      | Array(inf, sup, type_�l�ments) ->
229
 
         compile_expr env expr3 1;
230
 
         let (reg1, reg2) = compile_arguments env expr1 expr2 2 in
231
 
         if inf <> 0 then printf "sub r %d, %d, r %d\n" reg2 inf reg2;
232
 
         printf "mult r %d, %d, r %d\n" reg2 taille_du_mot reg2;
233
 
         printf "store r %d, r %d, r %d\n" reg1 reg2 1
234
 
      | _ -> failwith "Erreur dans le contr�leur de types" end
235
 
  | Appel(proc, arguments) ->
236
 
      let nbr_args = List.length arguments in
237
 
      r�serve_pile nbr_args;
238
 
      let position = ref 0 in
239
 
      List.iter
240
 
        (function arg ->
241
 
           compile_expr env arg 1;
242
 
           printf "store sp, %d, r 1\n" !position;
243
 
           position := !position + taille_du_mot)
244
 
        arguments;
245
 
      printf "jmp P%s, ra\n" proc;
246
 
      lib�re_pile nbr_args
247
 
  | If(condition, branche_oui, Bloc []) ->
248
 
      let �tiq_fin = nouvelle_�tiq() in
249
 
      compile_expr env condition 1;
250
 
      printf "braz r 1, L%d\n" �tiq_fin;
251
 
      compile_instr env branche_oui;
252
 
      printf "L%d:\n" �tiq_fin
253
 
  | If(condition, Bloc [], branche_non) ->
254
 
      let �tiq_fin = nouvelle_�tiq() in
255
 
      compile_expr env condition 1;
256
 
      printf "branz r 1, L%d\n" �tiq_fin;
257
 
      compile_instr env branche_non;
258
 
      printf "L%d:\n" �tiq_fin
259
 
  | If(Op_unaire("not", condition), branche_oui, branche_non) ->
260
 
      compile_instr env (If(condition, branche_non, branche_oui))
261
 
  | If(condition, branche_oui, branche_non) ->
262
 
      let �tiq_non = nouvelle_�tiq() and �tiq_fin = nouvelle_�tiq() in
263
 
      compile_expr env condition 1;
264
 
      printf "braz r 1, L%d\n" �tiq_non;
265
 
      compile_instr env branche_oui;
266
 
      printf "braz r 0, L%d\n" �tiq_fin;
267
 
      printf "L%d:\n" �tiq_non;
268
 
      compile_instr env branche_non;
269
 
      printf "L%d:\n" �tiq_fin
270
 
  | While(condition, corps) ->
271
 
      let �tiq_corps = nouvelle_�tiq()
272
 
      and �tiq_test = nouvelle_�tiq() in
273
 
      printf "braz r 0, L%d\n" �tiq_test;
274
 
      printf "L%d:\n" �tiq_corps;
275
 
      compile_instr env corps;
276
 
      printf "L%d:\n" �tiq_test;
277
 
      compile_expr env condition 1;
278
 
      printf "branz r 1, L%d\n" �tiq_corps
279
 
  | Write expr ->
280
 
      compile_expr env expr 1;
281
 
      printf "write\n"
282
 
  | Read nom_var ->
283
 
      printf "read\n";
284
 
      affecte_var env nom_var 1
285
 
  | Bloc liste_instr ->
286
 
      List.iter (compile_instr env) liste_instr
287
 
 
288
 
and affecte_var env nom reg =
289
 
  let var = cherche_variable nom env in
290
 
  match var.emplacement with
291
 
  | Global_indirect n ->
292
 
      printf "store r 0, %d, r %d  # %s \n" n reg nom
293
 
  | Local_indirect n ->
294
 
      printf "store sp, %d, r %d  # %s \n"
295
 
             (!profondeur_pile - n) reg nom
296
 
  | _ -> failwith "mauvaise gestion des emplacements de variables";;
297
 
 
298
 
let alloue_variable_locale (nom, typ) env =
299
 
  profondeur_pile := !profondeur_pile + taille_du_type typ;
300
 
  let emplacement =
301
 
    match typ with
302
 
    | Integer | Boolean ->
303
 
        Local_indirect(!profondeur_pile)
304
 
    | Array(_, _, _) ->
305
 
        Local_direct(!profondeur_pile) in
306
 
  ajoute_variable nom {typ = typ; emplacement = emplacement} env;;
307
 
 
308
 
let alloue_param�tres liste_des_param�tres environnement =
309
 
  let prof = ref 0 in
310
 
  let env = ref environnement in
311
 
  List.iter
312
 
    (function (nom,typ) ->
313
 
       env :=
314
 
         ajoute_variable nom
315
 
          {typ = typ; emplacement = Local_indirect !prof}
316
 
          !env;
317
 
       prof := !prof - taille_du_mot)
318
 
    liste_des_param�tres;
319
 
  !env;;
320
 
 
321
 
let compile_proc�dure env (nom, d�cl) =
322
 
  let env1 = alloue_param�tres d�cl.proc_param�tres env in
323
 
  profondeur_pile := taille_du_mot;
324
 
  let env2 = List.fold_right alloue_variable_locale d�cl.proc_variables env1 in
325
 
  printf "P%s:\n" nom;
326
 
  printf "sub sp, %d, sp\n" !profondeur_pile;
327
 
  printf "store sp, %d, ra\n" (!profondeur_pile - taille_du_mot);
328
 
  compile_instr env2 d�cl.proc_corps;
329
 
  printf "load sp, %d, ra\n" (!profondeur_pile - taille_du_mot);
330
 
  printf "add sp, %d, sp\n" !profondeur_pile;
331
 
  printf "jmp ra, r 0\n";;
332
 
 
333
 
let compile_fonction env (nom, d�cl) =
334
 
  let env1 = alloue_param�tres d�cl.fonc_param�tres env in
335
 
  profondeur_pile := taille_du_mot;
336
 
  let env2 = List.fold_right alloue_variable_locale d�cl.fonc_variables env1 in
337
 
  let env3 = alloue_variable_locale (nom, d�cl.fonc_type_r�sultat) env2 in
338
 
  printf "F%s:\n" nom;
339
 
  printf "sub sp, %d, sp\n" !profondeur_pile;
340
 
  printf "store sp, %d, ra\n" (!profondeur_pile - taille_du_mot);
341
 
  compile_instr env3 d�cl.fonc_corps;
342
 
  printf "load sp, 0, r 1\n";
343
 
  printf "load sp, %d, ra\n" (!profondeur_pile - taille_du_mot);
344
 
  printf "add sp, %d, sp\n" !profondeur_pile;
345
 
  printf "jmp ra, r 0\n";;
346
 
 
347
 
let adresse_donn�e = ref 0;;
348
 
 
349
 
let alloue_variable_globale (nom, typ) env =
350
 
  let emplacement =
351
 
    match typ with
352
 
    | Integer | Boolean -> Global_indirect(!adresse_donn�e)
353
 
    | Array(_, _, _)    -> Global_direct(!adresse_donn�e) in
354
 
  adresse_donn�e := !adresse_donn�e + taille_du_type typ;
355
 
  ajoute_variable nom {typ=typ; emplacement=emplacement} env;;
356
 
 
357
 
let compile_programme prog =
358
 
  adresse_donn�e := 0;
359
 
  let env_global =
360
 
    List.fold_right alloue_variable_globale prog.prog_variables
361
 
      (environnement_initial prog.prog_proc�dures prog.prog_fonctions) in
362
 
  compile_instr env_global prog.prog_corps;
363
 
  printf "stop\n";
364
 
  List.iter (compile_proc�dure env_global) prog.prog_proc�dures;
365
 
  List.iter (compile_fonction env_global) prog.prog_fonctions;;