Commit ce32adc0 authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2004-07-05 13:19:52+00:00
parent df3eeed8
......@@ -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))
......
......@@ -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)
......
......@@ -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
......
......@@ -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)))
......@@ -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 *)
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......@@ -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
......@@ -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
......@@ -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
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
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));;
......@@ -3,3 +3,4 @@ val env: Typer.t
val argv: Value.t ref
......@@ -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
......
......@@ -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
......@@ -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>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment