instr.ml

用ocaml编写的pascal编译程序

type i_type  = 
  | I_int             (* donn閑s de type entier  *)
  | I_addr            (* donn閑s de type adresse *)
;;

type i_lab   = string (* labels *)
;;

type i_addr  = i_lab  (* adresse virtuelle  *)
;;

type i_instr =
  | I_add of i_type
  | I_sub of i_type
  | I_mul of i_type
  | I_div of i_type
  | I_neg of i_type

  | I_and
  | I_or
  | I_not

  | I_equ of i_type
  | I_geq of i_type
  | I_leq of i_type
  | I_les of i_type
  | I_grt of i_type
  | I_neq of i_type

  | I_ldo of i_type*int 
  | I_ldc of i_type*int
  | I_ind of i_type
  | I_sro of i_type*int
  | I_sto of i_type

  | I_ujp of i_addr
  | I_fjp of i_addr

  | I_ixa of int
  | I_inc of i_type*int
  | I_dec of i_type*int

  | I_dpl of i_type
  | I_ldd of int
  | I_sli of i_type

  | I_new

  | I_lod of i_type*int*int
  | I_lda of int*int
  | I_str of i_type*int*int

  | I_mst of int
  | I_cup of int*i_addr
  | I_ssp of int
  | I_sep of int

  | I_retp
  | I_stp

  | I_movs of int
  | I_movd of int
  | I_alcd of int
;;

let i_string e x = 
  let f = Printf.sprintf     in
  let g = function I_int  -> "I" | I_addr -> "A"
  and h l = f "%s (%s)" l (e l)
  in  match x with
        | I_add t -> f "add  %s" (g t)
        | I_sub t -> f "sub  %s" (g t)
        | I_mul t -> f "mul  %s" (g t)
        | I_div t -> f "div  %s" (g t)
        | I_neg t -> f "neg  %s" (g t)

        | I_and   -> "and"
        | I_or    -> "or"
        | I_not   -> "not"

        | I_equ t -> f "equ  %s" (g t)
        | I_geq t -> f "geq  %s" (g t)
        | I_leq t -> f "leq  %s" (g t)
        | I_les t -> f "les  %s" (g t)
        | I_grt t -> f "grt  %s" (g t)
        | I_neq t -> f "neq  %s" (g t)

        | I_ldo (t,i) -> f "ldo  %s %d" (g t) i
        | I_ldc (t,i) -> f "ldc  %s %d" (g t) i
        | I_ind t     -> f "ind  %s" (g t)
        | I_sro (t,i) -> f "sro  %s %d" (g t) i
        | I_sto t     -> f "sto  %s" (g t)

        | I_ujp l -> f "ujp  %s" (h l)
        | I_fjp l -> f "fjp  %s" (h l)

        | I_ixa i     -> f "ixa  %d" i
        | I_inc (t,i) -> f "inc  %s %d" (g t) i
        | I_dec (t,i) -> f "dec  %s %d" (g t) i

        | I_dpl t -> f "dpl  %s" (g t)
        | I_ldd i -> f "ldd  %d" i
        | I_sli t -> f "sli  %s" (g t)

        | I_new   -> "new"

        | I_lod (t,p,q) -> f "lod  %s %d %d" (g t) p q
        | I_lda (p,q)   -> f "lda  %d %d" p q
        | I_str (t,p,q) -> f "str  %s %d %d" (g t) p q

        | I_mst i     -> f "mst  %d" i
        | I_cup (i,l) -> f "cup  %d %s" i (h l)
        | I_ssp i     -> f "ssp  %d" i
        | I_sep i     -> f "sep  %d "i

        | I_retp -> "retp"
        | I_stp  -> "stp"

        | I_movs i -> f "movs %d" i
        | I_movd i -> f "movd %d" i
        | I_alcd i -> f "alcd %d" i
;;

type i_unit = I_ins of i_instr | I_lab of i_lab;;
type i_code = i_unit list;;
type i_link = i_lab -> int;;

type i_unitp = I_insp of i_instr | I_labp of i_lab list;;

let rec i_compact = function
      | []            -> []
      | (I_ins i)::xs -> (I_insp i)::(i_compact xs)
      | (I_lab l)::xs -> match i_compact xs with
          | (I_labp ll)::ys -> (I_labp (l::ll))::ys
          | ys  -> (I_labp [l])::ys;;

let i_insp_print e n i = 
  Printf.printf "%5d: %s\n" n (i_string e i);;

let i_labp_print =
  let rec loop = function
      | []    -> ()
      | [l]   -> Printf.printf "%s:\n" l
      | l::xs ->(Printf.printf "%s, " l;
                 loop xs )
  in loop;;

let i_solve l x = 
  let rec loop k e = function
    | []            -> e
    | (I_ins _)::il -> loop (k+1) e il
    | (I_lab l)::il -> loop k ((l,k)::e) il
  in List.assoc x (loop 0 [] l);;

let i_print l =
  let links = i_solve l in
  let e x = try  Printf.sprintf "%d" (links x)
            with Not_found -> "unsolved" in
  let rec loop k = function
    | []              -> ( )
    | (I_insp i)::il  -> ( i_insp_print e k i; loop (k+1) il )
    | (I_labp ll)::il -> ( i_labp_print ll;  loop  k    il )
  in  loop 0 (i_compact l);;