Message-Id: <34843F79.15C2@dassault-aviation.fr>
Date: Tue, 02 Dec 1997 18:03:53 +0100
From: Thierry Bravier <thierry.bravier@dassault-aviation.fr>
To: caml-list@inria.fr
Subject: Re: hacks using camlp4
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
(*
=========================================================================
*)
This archive was generated by hypermail 2b29 : Sun Jan 02 2000 - 11:58:13 MET