(* interpréteur de mini-Pascal *)

open Ast

exception Error of string

let unbound_var s = raise (Error ("unbound variable " ^ s))
let unbound_procedure f = raise (Error ("unbound procedure " ^ f))
let bad_arity x = raise (Error ("bad arity for " ^ x))

(* primitives *)

open Graphics

let is_open = ref false

let drawline x1 y1 x2 y2 =
  if not !is_open then begin is_open := true; open_graph " 800x600" end;
  moveto x1 y1; lineto x2 y2

let writeln v =
  Format.printf "%d@." v

(* table des variables globales *)
let globals = Hashtbl.create 17

(* structure de données pour les variables locales *)
module Smap = Map.Make(String)

(* expressions arithmétiques *)

let binop = function
  | Add -> (+)
  | Sub -> (-)
  | Mul -> ( * ) (* :-) *)
  | Div -> (/)

let rec expr env = function
  | Econst n -> n
  | Evar x when Smap.mem x env -> Smap.find x env
  | Evar x when Hashtbl.mem globals x -> Hashtbl.find globals x
  | Evar x -> unbound_var x
  | Ebinop (op, e1, e2) -> binop op (expr env e1) (expr env e2)

(* expressions booléennes (conditions) *)

let cmp c = match c with
  | Eq -> (=)
  | Neq -> (<>)
  | Lt -> (<) 
  | Le -> (<=)
  | Gt -> (>)
  | Ge -> (>=)

let rec condition env = function
  | Bcmp (c, e1, e2) -> cmp c (expr env e1) (expr env e2)
  | Band (c1, c2) -> condition env c1 && condition env c2
  | Bor  (c1, c2) -> condition env c1 || condition env c2
  | Bnot c -> not (condition env c)

(* table des procédures *)
let procs = Hashtbl.create 17

(* instructions *)

let rec stmt env = function
  | Sassign (x, e) when Smap.mem x env -> (* variable locale *)
      Smap.add x (expr env e) env
  | Sassign (x, e) when Hashtbl.mem globals x -> (* variable globale *)
      Hashtbl.replace globals x (expr env e); env
  | Sassign (x, _) ->
      unbound_var x
  | Sif (c, s1, s2) -> 
      if condition env c then stmt env s1 else stmt env s2
  | Swhile (c, s1) as s -> 
      if condition env c then begin stmt (stmt env s1) s end else env
  | Sblock sl -> 
      List.fold_left stmt env sl
  | Scall ("writeln", [e]) -> 
      writeln (expr env e); env
  | Scall ("writeln", _) -> 
      bad_arity "writeln"
  | Scall ("drawline", [e1;e2;e3;e4]) -> 
      drawline (expr env e1) (expr env e2) (expr env e3) (expr env e4); env
  | Scall ("drawline", _) ->
      bad_arity "drawline"
  | Scall (x, el) ->
      let p = 
        try Hashtbl.find procs x with Not_found -> unbound_procedure x
      in
      let env' =
        try 
          List.fold_left2 (fun env' x e -> Smap.add x (expr env e) env') 
            Smap.empty p.formals el
        with Invalid_argument _ -> bad_arity x
      in
      let env' = 
        List.fold_left (fun env x -> Smap.add x 0 env) env' p.locals 
      in
      ignore (stmt env' p.body);
      env

let prog p = 
  List.iter (fun x -> Hashtbl.add globals x 0) p.globals;
  List.iter (fun p -> Hashtbl.add procs p.name p) p.procs;
  ignore (stmt Smap.empty p.main);
  if !is_open then begin ignore (read_key ()); close_graph () end

This document was generated using caml2html