[r2004-07-05 13:19:51 by afrisch] eval

Original author: afrisch
Date: 2004-07-05 13:19:52+00:00

Makefile

@@ -35,7 +35,7 @@ charme_build:
 
 install_web_distant:
 	$(MAKE) webpages
-	scp CHANGES  INSTALL INSTALL.WIN32 web/www/*.html web/cduce.css cduce@iris:public_html/
+	scp CHANGES  INSTALL INSTALL.WIN32 web/www/*.html web/cduce.css cduce@iris.ens.fr:public_html/
 
 SCRIPT =
 INCLUDES_DEB = $(INCLUDES) $(shell ocamlfind query -i-format -recursive $(PACKAGES))

Makefile.distrib

@@ -81,6 +81,7 @@ INSTALL := $(shell which install)
 
 
 ifeq ($(NATIVE),true)
+.PHONY: cduce_lib.cma
 cduce_lib.cma:
 	$(HIDE)$(MAKE) NATIVE=false $@
 endif
@@ -233,8 +234,9 @@ cduce_packed: cduce_packed.$(EXTENSION)
 
 
 cduce_lib.$(EXTENSION_LIB): $(OBJECTS:.cmo=.$(EXTENSION))
-	@echo "Build $@"
+	@echo "Pack cduce_lib.$(EXTENSION)"
 	$(HIDE)$(COMPILE) -o cduce_lib.$(EXTENSION) -pack $^
+	@echo "Build $@"
 	$(HIDE)$(COMPILE) -a -o $@ cduce_lib.$(EXTENSION)
 
 

depend

@@ -210,12 +210,12 @@ types/builtin.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
     types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
     parser/location.cmi misc/ns.cmi compile/operators.cmi \
     runtime/print_xml.cmi types/sequence.cmi typing/typer.cmi types/types.cmi \
-    runtime/value.cmi types/builtin.cmi 
+    parser/ulexer.cmi parser/url.cmi runtime/value.cmi types/builtin.cmi 
 types/builtin.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
     types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
     parser/location.cmx misc/ns.cmx compile/operators.cmx \
     runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
-    runtime/value.cmx types/builtin.cmi 
+    parser/ulexer.cmx parser/url.cmx runtime/value.cmx types/builtin.cmi 
 driver/librarian.cmo: types/builtin.cmi compile/compile.cmi \
     misc/encodings.cmi runtime/eval.cmi types/externals.cmi types/ident.cmo \
     compile/lambda.cmi parser/location.cmi parser/parser.cmi \
@@ -239,10 +239,10 @@ driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
     misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
     runtime/value.cmx driver/cduce.cmi 
 ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
-    types/ident.cmo driver/librarian.cmi types/types.cmi \
+    types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
     ocamliface/mltypes.cmi 
 ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
-    types/ident.cmx driver/librarian.cmx types/types.cmx \
+    types/ident.cmx driver/librarian.cmx parser/location.cmx types/types.cmx \
     ocamliface/mltypes.cmi 
 ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
     compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
@@ -291,10 +291,10 @@ tools/validate.cmo: schema/schema_common.cmi schema/schema_parser.cmi \
 tools/validate.cmx: schema/schema_common.cmx schema/schema_parser.cmx \
     schema/schema_types.cmx 
 ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
-    types/ident.cmo driver/librarian.cmi types/types.cmi \
+    types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
     ocamliface/mltypes.cmi 
 ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
-    types/ident.cmx driver/librarian.cmx types/types.cmx \
+    types/ident.cmx driver/librarian.cmx parser/location.cmx types/types.cmx \
     ocamliface/mltypes.cmi 
 ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
     compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
@@ -367,6 +367,7 @@ compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
 types/builtin.cmi: typing/typer.cmi runtime/value.cmi 
 driver/librarian.cmi: compile/compile.cmi types/ident.cmo typing/typer.cmi \
     types/types.cmi runtime/value.cmi 
+driver/cduce.cmi: misc/encodings.cmi runtime/value.cmi 
 ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi 
 query/query.cmi: parser/ast.cmo 
 ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi 

driver/cduce.ml

@@ -315,3 +315,33 @@ let run obj =
 
 
 let dump_env ppf = dump_env ppf !typing_env !compile_env
+
+let eval s =
+  let st = Stream.of_string s in
+  let phs = parse Parser.prog st in
+  let vals = ref [] in
+  let show id t v =
+    match id,v with
+      | Some id, Some v -> 
+	  let id = Id.value id in
+	  vals := (Some id,v) :: !vals
+      | None, Some v ->
+	  vals := (None,v) :: !vals
+      | _ -> assert false
+  in
+  let r () = 
+    ignore (Compile.comp_unit 
+	      ~run:true ~show Builtin.env Compile.empty_toplevel phs) in
+  Eval.new_stack r ();
+  List.rev !vals
+  
+let eval s =
+  try eval s
+  with exn -> 
+    let b = Buffer.create 1024 in
+    let ppf = Format.formatter_of_buffer b in
+    print_exn ppf exn;
+    Format.fprintf ppf "@.";
+    raise (Value.CDuceExn (Value.ocaml2cduce_string (Buffer.contents b)))
+
+

driver/cduce.mli

@@ -11,3 +11,7 @@ val compile_run: string -> unit
 val run: string -> unit
 
 val print_exn: Format.formatter -> exn -> unit
+
+
+val eval: string -> (Encodings.Utf8.t option * Value.t) list
+  (* Can be used from CDuce units *)

ocamliface/mlstub.ml

@@ -50,6 +50,7 @@ and typ_descr = function
   | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
   | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
   | Builtin ("Cduce_lib.Value.t", []) -> Types.any
+  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
   | Builtin ("unit", []) -> Sequence.nil_type
   | Var i -> Types.descr (!vars).(i)
   | _ -> assert false
@@ -272,6 +273,8 @@ and to_cd_descr e = function
       )
 
   | Builtin ("Cduce_lib.Value.t", []) -> e
+  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
+      <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
   | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
   | Var _ -> e
   | _ -> assert false
@@ -393,6 +396,8 @@ and to_ml_descr e = function
       let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
       <:expr< Pervasives.ref $to_ml e t$ >>
   | Builtin ("Cduce_lib.Value.t", []) -> e
+  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
+      <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
   | Builtin ("unit", []) -> <:expr< ignore $e$ >>
   | Var _ -> e
   | _ -> assert false

ocamliface/mltypes.ml

@@ -80,7 +80,11 @@ let new_slot () =
 
 let builtins =
   List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
-    ["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit"; "array" ]
+    [
+      "list"; "Pervasives.ref"; 
+      "unit"; "array";
+      "Cduce_lib.Value.t"; "Cduce_lib.Encodings.Utf8.t"
+    ]
 
 let vars = ref []
 
@@ -203,6 +207,16 @@ let read_cmi name =
     ) sg;
   (Buffer.contents buf, !values)
 
+let read_cmi name =
+  try read_cmi name
+  with Env.Error e ->
+    Env.report_error Format.str_formatter e;
+    let s = Format.flush_str_formatter () in
+    let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
+	      name s in
+    raise (Location.Generic s)
+
+
 let print_ocaml = Printtyp.type_expr
 
 

runtime/eval.ml

@@ -334,3 +334,12 @@ let code_items =
   protect_eval (List.iter eval)
 
 
+let new_stack f x =
+  let old_stack = !stack and old_frame = !frame and old_sp = !sp in
+  stack := Array.create 1024 Value.Absent;
+  frame := 0;
+  sp := 0;
+  let restore () = stack := old_stack; frame := old_frame; sp := old_sp in
+  try let v = f x in  restore (); v
+  with exn -> restore (); raise exn
+  

runtime/eval.mli

@@ -22,3 +22,6 @@ val eval_apply: t -> t -> t
 val code_items: code_item list -> unit
 
 val stack: t array ref
+
+val new_stack: ('a -> 'b) -> 'a -> 'b
+

runtime/value.ml

@@ -601,9 +601,18 @@ let ocaml2cduce_string = string_latin1
 
 let cduce2ocaml_string = get_string_latin1
 
+let ocaml2cduce_string_utf8 = string_utf8
+
+let cduce2ocaml_string_utf8 s = fst (get_string_utf8 s)
+
 let ocaml2cduce_char c =
   Char (Chars.V.mk_char c)
 
 let cduce2ocaml_char = function
   | Char c -> Chars.V.to_char c 
   | _ -> assert false
+
+
+let print_utf8 v =
+  print_string (U.get_str v);
+  flush stdout

runtime/value.mli

@@ -108,5 +108,10 @@ val ocaml2cduce_int : int -> t
 val cduce2ocaml_int : t -> int
 val ocaml2cduce_string : string -> t
 val cduce2ocaml_string : t -> string
+val ocaml2cduce_string_utf8 : U.t -> t
+val cduce2ocaml_string_utf8 : t -> U.t
 val ocaml2cduce_char : char -> t
 val cduce2ocaml_char : t -> char
+
+
+val print_utf8: U.t -> unit

tests/ocaml/Makefile

@@ -31,5 +31,13 @@ cdmysql:
 	./$@
 
 
+.PHONY: eval
+eval:
+	$(CDUCE) --compile $@.cd -I `ocamlfind query cduce`
+	ocamlfind $(CAML) -o $@ -pp "$(CDO2ML) -static" -impl $@.cdo -package cduce -linkpkg
+	./$@
+
+
+
 clean:
 	rm -f *.cmo *.cmx *.o *.cdo *.cmi a.ml *~ a

tests/ocaml/eval.cd

+let pr = Cduce_lib.Value.print_utf8
+
+try 
+ let l = Cduce_lib.Cduce.eval 
+  "let fun f (x : Int) : Int = x + 1;;
+   let fun g (x : Int) : Int = 2 * x;;
+   let x = Sys.getenv ['HOME'];;
+   f;; g;; 
+   let a = g (f 10);;
+  "
+ in
+ transform l with
+  | ((`Some,id),v) -> 
+	pr [ !id ' = ' !(string_of v) '\n' ]
+  | (`None, f & (Int -> Int)) ->
+        pr [ !(string_of (f 100)) '\n' ]
+  | (`None,v) -> 
+	pr [ !(string_of v) '\n' ]
+with (exn & Latin1) ->
+  print [ 'Exception: ' !exn  '\n' ]
\ No newline at end of file

types/builtin.ml

 open Builtin_defs
 
+let eval = ref (fun ppf err s -> assert false)
+
 (* Types *)
 
 let types =
@@ -337,4 +339,5 @@ unary_op_gen "flatten"
 
 unary_op_cst "raise"
   any Types.empty
-  (fun v -> raise (Value.CDuceExn v))
+  (fun v -> raise (Value.CDuceExn v));;
+

types/builtin.mli

@@ -3,3 +3,4 @@ val env: Typer.t
 
 
 val argv: Value.t ref
+

typing/typer.ml

@@ -500,21 +500,7 @@ module SlotTable = Hashtbl.Make(
 
 
 let rec derecurs env p = match p.descr with
-  | PatVar v ->
-      (match Ns.split_qname v with
-	 | "", v ->
-	     let v = ident v in
-	     (try PAlias (Env.find v env.penv_derec)
-	      with Not_found -> 
-		try PType (find_type v env.penv_tenv)
-		with Not_found -> PCapture v)
-	 | cu, v -> 
-	     try 
-	       let cu = U.mk cu in
-	       PType (find_type_global p.loc cu (ident v) env.penv_tenv)
-	     with Not_found ->
-	       raise_loc_generic p.loc 
-	       ("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)))
+  | PatVar v -> derecurs_var env p.loc v
   | SchemaVar (kind, schema_name, component_name) ->
       PType (find_schema_descr env.penv_tenv kind schema_name component_name)
   | Recurs (p,b) -> derecurs (derecurs_def env b) p
@@ -553,6 +539,23 @@ and derecurs_regexp vars env = function
   | SeqCapture (x,p) -> 
       derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
 
+and derecurs_var env loc v =
+  match Ns.split_qname v with
+    | "", v ->
+	let v = ident v in
+	(try PAlias (Env.find v env.penv_derec)
+	 with Not_found -> 
+	   try PType (find_type v env.penv_tenv)
+	   with Not_found -> PCapture v)
+    | cu, v -> 
+	try 
+	  let cu = U.mk cu in
+	  PType (find_type_global loc cu (ident v) env.penv_tenv)
+	with Not_found ->
+	  raise_loc_generic loc 
+	  ("Unbound external type " ^ cu ^ ":" ^ (U.to_string v))
+
+
 
 and derecurs_def env b =
   let b = List.map (fun (v,p) -> (v,p,mk_derecurs_slot p.loc)) b in
@@ -834,6 +837,7 @@ let pat env p =
 
 
 type type_fun = Types.t -> bool -> Types.t
+let typ_cst = ref (fun _ -> assert false)
 let mk_unary_op = ref (fun _ _ -> assert false)
 let typ_unary_op = ref (fun _ _ _ -> assert false)
 let mk_binary_op = ref (fun _ _ -> assert false)
@@ -859,18 +863,7 @@ let rec expr env loc = function
   | Forget (e,t) ->
       let (fv,e) = expr env loc e and t = typ env t in
       exp loc fv (Typed.Forget (e,t))
-  | Var s -> 
-      (match Ns.split_qname s with
-	| "", id -> 
-	    let s = U.get_str id in
-	    if String.contains s '.' then
-	      extern loc env s []
-	    else
-	      let id = ident id in
-	      exp loc (Fv.singleton id) (Typed.Var id)
-	| cu, id -> 
-	    let cu = find_cu (U.mk cu) env in
-	    exp loc Fv.empty (Typed.ExtVar (cu, ident id)))
+  | Var s -> var env loc s
   | Apply (e1,e2) -> 
       let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
       exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
@@ -969,6 +962,19 @@ let rec expr env loc = function
       let (i,t) = Externals.resolve s args in
       exp loc Fv.empty (Typed.External (t,i))
     with exn -> raise_loc loc exn
+
+  and var env loc s =
+  match Ns.split_qname s with
+    | "", id -> 
+	let s = U.get_str id in
+	if String.contains s '.' then
+	  extern loc env s []
+	else
+	  let id = ident id in
+	  exp loc (Fv.singleton id) (Typed.Var id)
+    | cu, id -> 
+	let cu = find_cu (U.mk cu) env in
+	exp loc Fv.empty (Typed.ExtVar (cu, ident id))
 	      
   and branches env b = 
     let fv = ref Fv.empty in

typing/typer.mli

@@ -73,9 +73,9 @@ val get_schema_names: t -> U.t list  (** registered schema names *)
 (* Operators *)
 
 type type_fun = Types.t -> bool -> Types.t
+
 val mk_unary_op: (string -> t -> int) ref
 val typ_unary_op: (int -> loc -> type_fun -> type_fun) ref
 
 val mk_binary_op: (string -> t -> int) ref
 val typ_binary_op: (int -> loc -> type_fun -> type_fun -> type_fun) ref
-

web/manual/interface.xml

@@ -102,6 +102,8 @@ The type <code>Cduce_lib.Value.t</code> is translated to the CDuce
 type <code>Any</code>. The corresponding translation functions are the
 identity. This can be used to avoid multiple copies when translating
 a complex value back and forth between CDuce and OCaml.
+The type <code>Cduce_lib.Encodings.Utf8.t</code> is translated to the CDuce
+type <code>String</code>.
 </li>
 
 <li>
@@ -154,6 +156,7 @@ The canonical translation is summarized in the following box:
 <td><tt>ref T(<i>t</i>)</tt></td></tr>
 
 <tr><td><tt>Cduce_lib.Value.t</tt></td><td><tt>Any</tt></td></tr>
+<tr><td><tt>Cduce_lib.Encodings.Utf8.t</tt></td><td><tt>String</tt></td></tr>
 </table>
 
 <p>
@@ -378,7 +381,7 @@ compile and link it with:
 <sample>
 cduce --compile cdsdl.cd -I `ocamlfind query ocamlsdl`
 ocamlfind ocamlc -o cdsdl -pp "cdo2ml -static" -impl cdsdl.cdo   \ 
--package cduce,ocamlsdl -linkpkg
+  -package cduce,ocamlsdl -linkpkg
 </sample>
 
 
@@ -413,7 +416,53 @@ compile and link it with:
 <sample>
 cduce --compile cdmysql.cd -I `ocamlfind query mysql`
 ocamlfind ocamlc -o cdmysql -pp "cdo2ml -static" -impl cdmysql.cdo   \ 
--package cduce,mysql -linkpkg
+  -package cduce,mysql -linkpkg
+</sample>
+
+</section>
+
+
+
+<section title="Evaluating CDuce expressions">
+
+<p>
+This example demonstrates how to dynamically compile
+and evaluate CDuce programs contained in a string.
+</p>
+
+<sample>
+<![CDATA[
+let pr = Cduce_lib.Value.print_utf8
+
+try 
+ let l = Cduce_lib.Cduce.eval 
+  "let fun f (x : Int) : Int = x + 1;;
+   let fun g (x : Int) : Int = 2 * x;;
+   f;; g;; 
+   let a = g (f 10);;
+  "
+ in
+ transform l with
+  | ((`Some,id),v) -> 
+	pr [ !id ' = ' !(string_of v) '\n' ]
+  | (`None, f & (Int -> Int)) ->
+        pr [ !(string_of (f 100)) '\n' ]
+  | (`None,v) -> 
+	pr [ !(string_of v) '\n' ]
+with (exn & Latin1) ->
+  print [ 'Exception: ' !exn  '\n' ]
+]]>
+</sample>
+
+<p>
+If you put these lines in a file <code>cdmysql.cd</code>, you can
+compile and link it with:
+</p>
+
+<sample>
+cduce --compile eval.cd -I `ocamlfind query cduce`
+ocamlfind ocamlc -o eval -pp "cdo2ml -static" -impl eval.cdo   \ 
+  -package cduce -linkpkg
 </sample>
 
 </section>