← Back to branch summary

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

« back to all changes in this revision

Viewing changes to examples/minicaml/caml.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/minicaml/caml.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 Eval;;
14
 
open Types;;
15
 
open Synthese;;
16
 
 
17
 
(* L'environnement d'�valuation *)
18
 
 
19
 
let code_nombre n =
20
 
    Val_nombre n
21
 
and d�code_nombre = function
22
 
  | Val_nombre n -> n
23
 
  | _ -> raise(Erreur "entier attendu")
24
 
and code_bool�en b =
25
 
    Val_bool�enne b
26
 
and d�code_bool�en = function
27
 
  | Val_bool�enne b -> b
28
 
  | _ -> raise(Erreur "bool�en attendu");;
29
 
 
30
 
(* Pour transformer une fonction Caml en valeur fonctionnelle *)
31
 
 
32
 
let prim1 codeur calcul d�codeur =
33
 
  Val_primitive(function v -> codeur (calcul (d�codeur v)))
34
 
and prim2 codeur calcul d�codeur1 d�codeur2 =
35
 
  Val_primitive(function
36
 
   | Val_paire (v1, v2) ->
37
 
       codeur (calcul (d�codeur1 v1) (d�codeur2 v2))
38
 
   | _ -> raise (Erreur "paire attendue"));;
39
 
 
40
 
(* L'environnement initial *)
41
 
 
42
 
let env_�val_initial =
43
 
  ["+",  prim2 code_nombre  ( + ) d�code_nombre d�code_nombre;
44
 
   "-",  prim2 code_nombre  ( - ) d�code_nombre d�code_nombre;
45
 
   "*",  prim2 code_nombre  ( * ) d�code_nombre d�code_nombre;
46
 
   "/",  prim2 code_nombre  ( / ) d�code_nombre d�code_nombre;
47
 
   "=",  prim2 code_bool�en ( = ) d�code_nombre d�code_nombre;
48
 
   "<>", prim2 code_bool�en ( <> ) d�code_nombre d�code_nombre;
49
 
   "<",  prim2 code_bool�en ( < ) d�code_nombre d�code_nombre;
50
 
   ">",  prim2 code_bool�en ( > ) d�code_nombre d�code_nombre;
51
 
   "<=", prim2 code_bool�en ( <= ) d�code_nombre d�code_nombre;
52
 
   ">=", prim2 code_bool�en ( >= ) d�code_nombre d�code_nombre;
53
 
   "not", prim1 code_bool�en ( not ) d�code_bool�en;
54
 
   "read_int", prim1 code_nombre (fun x -> read_int ()) d�code_nombre;
55
 
   "write_int", prim1 code_nombre
56
 
                      (fun x -> print_int x; print_newline (); 0)
57
 
                      d�code_nombre];;
58
 
 
59
 
(* L'environnement de typage *)
60
 
 
61
 
let type_arithm�tique = sch�ma_trivial
62
 
  (type_fl�che (type_produit type_int type_int) type_int)
63
 
and type_comparaison = sch�ma_trivial
64
 
  (type_fl�che (type_produit type_int type_int) type_bool);;
65
 
 
66
 
let env_typage_initial =
67
 
  ["+",  type_arithm�tique; "-",  type_arithm�tique;
68
 
   "*",  type_arithm�tique; "/",  type_arithm�tique;
69
 
   "=",  type_comparaison; "<>", type_comparaison;
70
 
   "<",  type_comparaison; ">",  type_comparaison;
71
 
   "<=", type_comparaison; ">=", type_comparaison;
72
 
   "not", sch�ma_trivial(type_fl�che type_bool type_bool);
73
 
   "read_int", sch�ma_trivial(type_fl�che type_int type_int);
74
 
   "write_int", sch�ma_trivial(type_fl�che type_int type_int)];;
75
 
 
76
 
(* La boucle principale *)
77
 
 
78
 
let boucle () =
79
 
  let env_typage = ref env_typage_initial
80
 
  and env_�val = ref env_�val_initial in
81
 
  let flux_d'entr�e = Stream.of_channel stdin in
82
 
  try
83
 
    while true do
84
 
      print_string "# "; flush stdout;
85
 
      try
86
 
        match lire_phrase flux_d'entr�e with
87
 
        | Expression expr ->
88
 
            let ty = type_exp !env_typage expr in
89
 
            let r�s = �value !env_�val expr in
90
 
            print_string "- : "; imprime_type ty;
91
 
            print_string " = "; imprime_valeur r�s;
92
 
            print_newline ()
93
 
        | D�finition d�f ->
94
 
            let nouvel_env_typage = type_d�f !env_typage d�f in
95
 
            let nouvel_env_�val = �value_d�finition !env_�val d�f in
96
 
            begin match (nouvel_env_typage, nouvel_env_�val) with
97
 
            | (nom, sch�ma) :: _, (_, v) :: _ ->
98
 
                print_string nom; print_string " : ";
99
 
                imprime_sch�ma sch�ma; print_string " = ";
100
 
                imprime_valeur v; print_newline ()
101
 
            | _ -> failwith "traitement incorrect des d�finitions"
102
 
            end;
103
 
            env_typage := nouvel_env_typage;
104
 
            env_�val := nouvel_env_�val
105
 
      with
106
 
      | Stream.Error s ->
107
 
          print_string ("Erreur de syntaxe: " ^ s); print_newline ()
108
 
      | Stream.Failure -> raise Sys.Break
109
 
      | Conflit(ty1, ty2) ->
110
 
          print_string "Incompatibilit� de types entre ";
111
 
          imprime_type ty1; print_string " et ";
112
 
          imprime_type ty2; print_newline ()
113
 
      | Circularit�(var, ty) ->
114
 
          print_string "Impossible d'identifier ";
115
 
          imprime_type var; print_string " et ";
116
 
          imprime_type ty; print_newline ()
117
 
      | Eval.Erreur msg ->
118
 
          print_string "Erreur � l'�valuation: "; print_string msg;
119
 
          print_newline ()
120
 
      | Synthese.Erreur msg ->
121
 
          print_string "Erreur de typage: "; print_string msg;
122
 
          print_newline ()
123
 
    done
124
 
  with Sys.Break -> ();;
125
 
 
126
 
if !Sys.interactive then () else boucle ();;