Re: hacks using camlp4

[Thierry Bravier <thierry.bravier@dassault-aviation.fr>]

Daniel de Rauglaudre wrote:
> 
> > I lately checked the camlp4 preprocessor. I think this tool may have lots
> > of useful applications, since it allows especially custom syntaxes for the
> > input of certain kind of objects, in a more programmer-friendly fashion
> > than just inputting raw data structures into the source code.
> >
> 
> A solution is partial evaluation. I have implemented a syntax solution
> below (working with ocaml syntax, not righteous one). The idea is to
> automatically generate global declarations.
> 
(*
============================================================================
 *        File: camlp4/fold.ml
 *    Language: caml
 *      Author: Thierry Bravier
 *  Time-stamp: <97/12/02 17:41:28 tb>
 *     Created:  97/12/02 14:18:53 tb
 *
=========================================================================
*)
(*
  Dear ocaml users,
 
  Smart as Ocaml is, camlp4 makes it even smarter.
  
  Here is a small constant folding camlp4 module that can be useful to
  efficiently parse ocaml (standard syntax) code.
 
  This extension is adapted from [mkumin] in etc/pa_o.ml which can be
  seen as a minimal constant folding algorithm on its own.
 
  It is also a degenerated case of pre-compiled expressions as
  was discussed on the ocaml mailing list.
 
  In this precise case, the smart [partial.ml] module presented by
  Daniel de Rauglaudre is too powerful, since there is no need to
  store folded values in global variables, folded values are put in
  new literals instead.
 
  Example:
  ocamlc -pp "camlp4o pa_extend.cmo q_MLast.cmo" -I `camlp4 -where` -c
fold.ml
  cat foldable.ml
  let f x = "foo"^"bar"^"gee", 50 - 100 -10 * x + 4 * 8
  camlp4o pr_o.cmo ./fold.cmo foldable.ml
  let f x = "foobargee", -50 - 10 * x + 32;;
 
  Unfortunately, THIS MODULE IS NOT FULLY SAFE, since it relies on
  the dangerous assumption that ( + ) is the integer addition, ( ** )
  is the floating point power operator, etc.
  This is not always true:
  let (+) x y = y - x;;
  let x = 10 + 100;;
  x is 90, not 110 !
  Or even:
  let f (^) = "foo" ^ "bar"
  val f : (string -> string -> 'a) -> 'a

  So please, first check the lexical environment in which expressions
  are to be expanded.
 
  Thierry Bravier         Dassault Aviation - DGT / DTN / ELO / EAV
  78, Quai Marcel Dassault       F-92214 Saint-Cloud Cedex - France
  Telephone : (33) 01 47 11 53 07   Telecopie : (33) 01 47 11 52 83
  E-Mail :              mailto:thierry.bravier@dassault-aviation.fr
*)
(*
=========================================================================
*)
open Pcaml
;;
 
(*
=========================================================================
*)
type literal =
  | Int of int
  | Flo of float
  | Str of string
  | Chr of char
 
let get_literal loc = function
  | <:expr< $int:i$ >> -> Some (Int (int_of_string   i))
  | <:expr< $flo:f$ >> -> Some (Flo (float_of_string f))
  | <:expr< $str:s$ >> -> Some (Str s)
  | <:expr< $chr:c$ >> -> Some (Chr c)
  | _ -> None
and put_literal loc = function
  | Int i -> <:expr< $int:string_of_int   i$ >>
  | Flo f -> <:expr< $flo:string_of_float f$ >>
  | Str s -> <:expr< $str:s$ >>
  | Chr c -> <:expr< $chr:c$ >>
 
(*
=========================================================================
*)
let fold_1 (nop, fop) loc e1 =
  match get_literal loc e1 with
  | Some l1 -> <:expr< $fop l1$ >>
  | _ -> <:expr< $lid:nop$ $e1$ >>
and fold_2 (nop, fop) loc e1 e2 =
  match get_literal loc e1, get_literal loc e2 with
  | Some l1, Some l2 -> <:expr< $fop l1 l2$ >>
  | _ -> <:expr< $lid:nop$ $e1$ $e2$ >>
 
(*
=========================================================================
*)
let dont_fold_1 nop loc =
  fold_1
    (nop, (fun l1 -> <:expr< $lid:nop$ $put_literal loc l1$ >>))
    loc
and fold_int_1 (nop, fop) loc =
  fold_1
    (nop,
     (function
       | Int i1 -> put_literal loc (Int (fop i1))
       | l1 -> <:expr< $lid:nop$ $put_literal loc l1$ >>))
    loc
and fold_flo_1 (nop, fop) loc =
  fold_1
    (nop,
     (function
       | Flo f1 -> put_literal loc (Flo (fop f1))
       | l1 -> <:expr< $lid:nop$ $put_literal loc l1$ >>))
    loc
 
let fold_int_2 (nop, fop) loc =
  fold_2
    (nop,
     (fun l1 l2 ->
       match l1, l2 with
       | Int i1, Int i2 -> put_literal loc (Int (fop i1 i2))
       | _ -> <:expr< $lid:nop$ $put_literal loc l1$ $put_literal loc
l2$ >>))
    loc
and dont_fold_2 nop loc =
  fold_2
    (nop,
     (fun l1 l2 ->
       <:expr< $lid:nop$ $put_literal loc l1$ $put_literal loc l2$ >>))
    loc
and fold_flo_2 (nop, fop) loc =
  fold_2
    (nop,
     (fun l1 l2 ->
       match l1, l2 with
       | Flo f1, Flo f2 -> put_literal loc (Flo (fop f1 f2))
       | _ -> <:expr< $lid:nop$ $put_literal loc l1$ $put_literal loc
l2$ >>))
    loc
and fold_str_2 (nop, fop) loc =
  fold_2
    (nop,
     (fun l1 l2 ->
       match l1, l2 with
       | Str s1, Str s2 -> put_literal loc (Str (fop s1 s2))
       | _ -> <:expr< $lid:nop$ $put_literal loc l1$ $put_literal loc
l2$ >>))
    loc
 
(*
=========================================================================
*)
type folder_1 =
  | Dont_Fold_1
  | Fold_Int_1 of (int -> int)
  | Fold_Flo_1 of (float -> float)
and folder_2 =
  | Dont_Fold_2
  | Fold_Int_2 of (int -> int -> int)
  | Fold_Flo_2 of (float -> float -> float)
  | Fold_Str_2 of (string -> string -> string)
 
let make_folder_1 = function
  | nop, Dont_Fold_1     -> dont_fold_1 nop
  | nop, Fold_Int_1  fop -> fold_int_1  (nop, fop)
  | nop, Fold_Flo_1  fop -> fold_flo_1  (nop, fop)
and make_folder_2 = function
  | nop, Dont_Fold_2     -> dont_fold_2 nop
  | nop, Fold_Int_2  fop -> fold_int_2  (nop, fop)
  | nop, Fold_Flo_2  fop -> fold_flo_2  (nop, fop)
  | nop, Fold_Str_2  fop -> fold_str_2  (nop, fop)
;;
 
(*
=========================================================================
*)
EXTEND
        expr: LEVEL "^"
        [ [ e1 = SELF;
            f = [ op = "^" -> op, Fold_Str_2 ( ^ )
                | op = "@" -> op, Dont_Fold_2 ];
            e2 = SELF -> make_folder_2 f loc e1 e2 ] ]
        ;
      expr: LEVEL "+"
        [ [ e1 = SELF;
            f = [ op = "+"  -> op, Fold_Int_2 ( +  )
                | op = "-"  -> op, Fold_Int_2 ( -  )
                | op = "+." -> op, Fold_Flo_2 ( +. )
                | op = "-." -> op, Fold_Flo_2 ( -. ) ];
            e2 = SELF -> make_folder_2 f loc e1 e2 ] ]
        ;
      expr: LEVEL "*"
        [ [ e1 = SELF;
            f = [ op = "*"    -> op, Fold_Int_2 ( *    )
                | op = "/"    -> op, Fold_Int_2 ( /    )
                | op = "*."   -> op, Fold_Flo_2 ( *.   )
                | op = "/."   -> op, Fold_Flo_2 ( /.   )
                | op = "land" -> op, Fold_Int_2 ( land )
                | op = "lor"  -> op, Fold_Int_2 ( lor  )
                | op = "lxor" -> op, Fold_Int_2 ( lxor )
                | op = "mod"  -> op, Fold_Int_2 ( mod  ) ];
            e2 = SELF -> make_folder_2 f loc e1 e2 ] ]
        ;
      expr: LEVEL "**"
        [ [ e1 = SELF;
            f = [ op = "**"  -> op, Fold_Flo_2 ( **  )
                | op = "asr" -> op, Fold_Int_2 ( asr )
                | op = "lsl" -> op, Fold_Int_2 ( lsl )
                | op = "lsr" -> op, Fold_Int_2 ( lsr ) ];
            e2 = SELF -> make_folder_2 f loc e1 e2 ] ]
        ;
      expr: LEVEL "unary minus"
        [ [ f = [ op = "-"  -> "~-",  Fold_Int_1 ( ~-  )
                | op = "-." -> "~-.", Fold_Flo_1 ( ~-. ) ];
            e = SELF -> make_folder_1 f loc e ] ]
        ;
      expr: LEVEL "~-"
        [ [ f = [ op = "~-"  -> op, Fold_Int_1 ( ~-  )
                | op = "~-." -> op, Fold_Flo_1 ( ~-. ) ];
            e = SELF -> make_folder_1 f loc e ] ]
        ;
END
 
(*
=========================================================================
*)