sem.ml

用ocaml编写的pascal编译程序

(* ------------------------------------------------------------------------ *)

type a_btype = A_int | A_bool
and  a_call  = A_adr | A_val                   (* par adresse ou par valeur *)
and  a_type  = A_bty of a_btype                (* type de base              *) 
             | A_arr of a_btype                (* type tableau de ...       *)
and  a_name  = A_var of a_type*a_call          (* variable ou parametre     *)
             | A_proc of (a_type*a_call) list  (* procedure                 *)
             ;;

type s_sem   = A_btype of a_btype
             | A_name  of a_name
             | A_none;;
 
(* ------------------------------------------------------------------------ *)

type s_ident   = string
and  s_ident_s = s_ident*s_sem;;

type s_number   = int
and  s_number_s = s_number*s_sem;;

type s_cst   = S_num of s_number | S_true | S_false;;
type s_unop  = S_minus | S_not;;
type s_binop = S_add | S_sub | S_mul | S_div | S_and | S_or
             | S_leq | S_les | S_geq | S_grt | S_eq  | S_neq;; 

type s_expr    = S_cst of s_cst
               | S_una of s_unop*s_expr_s
               | S_bin of s_binop*s_expr_s*s_expr_s
               | S_der of s_deref
and  s_deref   = s_ident_s*(s_expr_s option)
and  s_expr_s  = s_expr*s_sem;;

type s_instr  = S_aff of s_deref*s_expr_s                (* affectations  *)
              | S_ite of s_expr_s*s_instr*s_instr          (* if then else  *)
              | S_whi of s_expr_s*s_instr                  (* while do      *)
              | S_lst of s_instr list                      (* begin end     *)
              | S_cal of s_ident_s*(s_expr_s list)         (* appel proc.   *)
              ;;

type s_btype   = S_int | S_bool;;

type s_tdecl   = S_dbty of s_btype 
               | S_darr of s_expr_s*s_expr_s*s_btype;;
type s_vdecl   = s_ident*s_tdecl;;

type s_call    = S_value | S_addr;;
type s_tspec   = S_sbty of s_btype 
               | S_sarr of s_ident*s_ident*s_btype;;
type s_pspec   = s_call*s_ident*s_tspec;;

type s_block   = S_blk of (s_vdecl list)*(s_procd list)*(s_instr list)
and  s_procd   = s_ident*(s_pspec list)*s_block
and  s_program = s_ident*s_block;;

(* ------------------------------------------------------------------------ *)


exception Not_available of string;;
exception Type_error of string;;

let nenv (x:s_ident) = 
  let s = Printf.sprintf "%s is not defined" x
  in  raise (Type_error s);;
let sbst  e (x,v) y = if x=y then v else (e y);;
let rec subst e = function []   -> e
                        |  c::l -> subst (sbst e c) l;;

let type_unop  = function
  | S_minus -> (A_int,A_int)
  | S_not   -> (A_bool,A_bool);;

let type_binop = function
  | S_add -> (A_int,A_int)
  | S_sub -> (A_int,A_int)
  | S_mul -> (A_int,A_int)
  | S_div -> (A_int,A_int)
  | S_and -> (A_bool,A_bool)
  | S_or  -> (A_bool,A_bool)
  | _     -> (A_int, A_bool);;

let sem_null   = A_none;;

let sem_btype  = function 
  | A_btype t -> t
  | A_name (A_var (A_bty t,_)) -> t
  | _         -> raise (Not_available "not a basic type");;

let sem_var    = function
  | A_name (A_var (t,c)) -> (t,c)
  | _         -> raise (Not_available "not a variable name");;

let sem_proc   = function
  | A_name (A_proc l)   -> l
  | _         -> raise (Not_available "not a procedure name");;

let rec st_expr e k = match k with
  | S_cst (S_num x)   -> (k, A_btype A_int)
  | S_cst S_true      -> (k, A_btype A_bool)
  | S_cst S_false     -> (k, A_btype A_bool)
  | S_una (op,a) ->      let (_,sa) as a1 = st_expr_s e a in
                         let ta           = sem_btype sa  in 
                         let (te,ts)      = type_unop op
                         in  if   (te=ta) 
                             then (S_una (op,a1),A_btype ts)
                             else raise (Type_error "unop")
  | S_bin (op,a,b)    -> let (_,sa) as a1 = st_expr_s e a
                         and (_,sb) as b1 = st_expr_s e b in
                         let ta           = sem_btype sa  in 
                         let tb           = sem_btype sb  in 
                         let (te,ts)      = type_binop op 
                         in  if (ta=tb) & (ta=te) 
                             then (S_bin (op,a1,b1),A_btype ts)
                             else raise (Type_error "binop")
  | S_der d           -> let (d1,sd) = st_deref e d
                         in  (S_der d1,sd)
and st_deref e = function
  | ((i,_),None) ->      let si    = A_name (e i)        in
                         let _     = sem_var si              (* Checks sem of i is variable name *)
                         in  (((i,si),None),si)
  | ((i,_),Some a) ->    let si           = A_name (e i)  in
                         let (t,c)        = sem_var si    in
                         let (_,sa) as a1 = st_expr_s e a in
                         let ta           = sem_btype sa  
                         in  begin
                               match (ta,t) with
                                 (A_int,A_arr x) -> (((i,si),Some a1),A_name (A_var (A_bty x,A_val)))
                               | _               -> raise (Type_error "deref array")
                             end
and st_expr_s e (a,_) = st_expr e a;;

let type_match = function
  | ((A_bty x,A_val),A_btype y)                  -> x=y
  | ((A_bty x,_    ),A_name (A_var (A_bty y,_))) -> x=y
  | ((A_arr x,_    ),A_name (A_var (A_arr y,_))) -> x=y
  | _                                            -> false;;

let rec st_instr e k = match k with
  | S_aff (d,a) ->      let (d1,sd) = st_deref  e d
                        and (a1,sa) = st_expr_s e a
                        in  if   sem_btype sd = sem_btype sa 
                            then S_aff (d1,(a1,sa))
                            else raise (Type_error "instr :=")
  | S_ite (c,a,b)   ->  let (c1,sc) = st_expr_s e c
                        and a1      = st_instr  e a
                        and b1      = st_instr  e b
                        in  if   A_bool = sem_btype sc
                            then S_ite ((c1,sc),a1,b1)
                            else raise (Type_error "instr if then else")
  | S_whi (c,a)     ->  let (c1,sc) = st_expr_s e c
                        and a1      = st_instr  e a
                        in  if   A_bool = sem_btype sc
                            then S_whi ((c1,sc),a1)
                            else raise (Type_error "instr while")
  | S_lst li        ->  S_lst (List.map (st_instr e) li)
  | S_cal ((i,_),l) ->  let si = A_name (e i)             in
                        let ti = sem_proc si              in 
                        let l1 = List.map (st_expr_s e) l in
                        let (_,tl) = List.split l1        in 
                        let l  = try  List.combine ti tl 
                                 with Invalid_argument _ -> raise (Type_error "wrong number of arguments")
                        in if   List.for_all type_match l
                           then S_cal ((i,si),l1)
                           else raise (Type_error "wrong set of arguments");;

let st_btype   = function 
  | S_int  -> A_int
  | S_bool -> A_bool;;

let st_tdecl e = function (S_dbty x) -> (S_dbty x,A_var (A_bty (st_btype x),A_val))
                        | (S_darr (a,b,x)) -> let a1 = st_expr_s e a
                                              and b1 = st_expr_s e b
                                              and x1 = st_btype x
                                              in (S_darr (a1,b1,x),A_var (A_arr x1,A_val));;

let st_vdecl e (i,t) = let (t1,x) = st_tdecl e t
                       in  ((i,t1),(i,x));;

let st_vdecll e l = List.split (List.map (st_vdecl e) l);;

let st_call    = function S_value -> A_val 
                        | S_addr  -> A_adr;;  

let st_tspec e (i,c) k = match k with
  | S_sbty x       ->   let tx = st_btype x 
                         in (k,A_bty tx,[(i,A_var (A_bty tx,c))])
  | S_sarr (a,b,t) ->    let tt = st_btype t
                         in (k,A_arr tt, 
                             [(i,A_var (A_arr tt,   c));
                              (a,A_var (A_bty A_int,A_val));
                              (b,A_var (A_bty A_int,A_val))]
                            );;

let sst_tspec         = function (S_sbty x)       -> A_bty (st_btype x)
                               | (S_sarr (_,_,t)) -> A_arr (st_btype t);;
let sst_pspec (c,i,s) = (sst_tspec s,st_call c);;
let sst_procd (i,l,b) = (i,A_proc (List.map sst_pspec l));;

let st_pspec e (c,i,s) = let c1         = st_call c            in
                         let (s1,t1,l1) = st_tspec e (i,c1) s 
                         in  (((c,i,s1),(t1,c1)),l1);;

let st_pspecl e l = let (cl1,ll2) = List.split (List.map (st_pspec e) l) in
                    let (l1,l2)   = List.split cl1 
                    in  (l1,l2,List.concat ll2);;
                    
let rec st_procd e (i,ls,b)       = let (ls1,lt1,as1) = st_pspecl e ls in
                                    let e1 = subst e as1 in
                                    let b1 = st_block e1 b 
                                    in  (i,ls1,b1)
and st_block e (S_blk (vl,pl,il)) = let (vl1,as1) = st_vdecll e vl      in
                                    let e1  = subst e as1               in
                                    let as2 = List.map sst_procd pl     in
                                    let e2  = subst e1 as2              in 
                                    let pl1 = List.map (st_procd e2) pl in
                                    let il1 = List.map (st_instr e2) il
                                    in  S_blk (vl1,pl1,il1);;

let st_program (i,bl) = ((i,st_block nenv bl):s_program);;
              
let sem_compute = st_program;;