Commit 28897209 authored by Pietro Abate's avatar Pietro Abate

[r2005-03-04 12:11:52 by afrisch] cduce_mktop

Original author: afrisch
Date: 2005-03-04 12:11:54+00:00
parent 1d59613c
version="%VER%"
requires="%REQ% camlp4.gramlib"
description="Runtime support for CDuce"
archive(byte)="cduce_lib.cma"
archive(native)="cduce_lib.cmxa"
include Makefile.conf
VERSION = 0.2.3b1
all: cduce dtd2cduce validate cdo2ml cduce_lib.cma
all: cduce dtd2cduce cduce_validate cdo2ml mlcduce_wrapper cduce_lib.cma
ifeq ($(NATIVE),true)
all: cduce_lib.cmxa
endif
......@@ -87,16 +87,14 @@ install_bin:
@echo "Install binaries"
$(HIDE)mkdir -p $(BINDIR)
$(HIDE)$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) \
validate$(EXE) cdo2ml$(EXE) $(BINDIR)/
cduce_validate$(EXE) cdo2ml$(EXE) \
mlcduce_wrapper$(EXE) \
cduce_mktop $(BINDIR)/
install_lib:
@echo "Build META"
$(HIDE)echo 'version="$(VERSION)"' > META
$(HIDE)echo 'requires="$(PACKAGES) camlp4.gramlib"' >> META
$(HIDE)echo 'description="Runtime support for CDuce"' >> META
$(HIDE)echo 'archive(byte)="cduce_lib.cma"' >> META
$(HIDE)echo 'archive(native)="cduce_lib.cmxa"' >> META
$(HIDE)(sed "s/%REQ%/$(PACKAGES)/" < META.in | sed "s/%VER%/$(VERSION)/" > META)
$(HIDE)-$(OCAMLFIND) remove cduce
$(HIDE)-$(OCAMLFIND) install cduce META \
cduce_lib.cmi $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) \
......@@ -104,9 +102,10 @@ install_lib:
uninstall:
rm -f $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) \
$(BINDIR)/validate$(EXE) $(BINDIR)/cdo2ml$(EXE)
$(BINDIR)/cduce_validate$(EXE) $(BINDIR)/cdo2ml$(EXE) \
$(BINDIR)/mlcduce_wrapper$(EXE) $(BINDIR)/cduce_mktop
rm -f $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 \
$(MANDIR)/man1/validate.1 $(MANDIR)/man1/cdo2ml.1
$(MANDIR)/man1/cduce_validate.1 $(MANDIR)/man1/cdo2ml.1
rm -Rf $(DOCDIR)
ocamlfind remove cduce
......@@ -114,7 +113,7 @@ help:
@echo "GOALS"
@echo " cduce : compiles the CDuce command line interpreter"
@echo " dtd2cduce : compiles the dtd2cduce tools"
@echo " validate : compiles the schema validation tool"
@echo " cduce_validate : compiles the schema validation tool"
@echo " doc : build the documentation"
@echo " all : build binaries and libraries"
@echo " install : install binaries, man pages, documentation"
......@@ -212,7 +211,8 @@ OBJECTS += $(CQL_OBJECTS)
VALIDATE_OBJECTS := $(shell for o in $(OBJECTS); do echo $$o; if [ "$$o" = "schema/schema_parser.cmo" ]; then exit 0; fi; done) # all objects until schema_parser.cmo
CDUCE = $(OBJECTS) $(CQL_OBJECTS_RUN) driver/run.cmo
OBJECTS += $(CQL_OBJECTS_RUN) driver/run.cmo
CDUCE = $(OBJECTS) driver/start.cmo
DTD2CDUCE = tools/dtd2cduce.cmo
ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \
......@@ -255,10 +255,14 @@ dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^
validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
cduce_validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^
mlcduce_wrapper: $(OBJECTS:.cmo=.$(EXTENSION)) ocamliface/mlcduce_wrapper.ml
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ odyl.cma camlp4.cma pr_o.cmo $^ $(EXTRA_LINK_OPTS)
cdo2ml: ocamliface/cdo2ml.ml
@echo "Build $@"
$(HIDE)ocamlc -o $@ -pp camlp4o -I +camlp4 odyl.cma camlp4.cma pr_o.cmo $^
......@@ -277,7 +281,7 @@ clean:
rm -f `find . -name "*~"`
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~ META
rm -f cduce$(EXE) ocamlprof.dump
rm -f dtd2cduce$(EXE) webiface$(EXE) validate$(EXE) cdo2ml$(EXE) evaluator$(EXE)
rm -f dtd2cduce$(EXE) webiface$(EXE) cduce_validate$(EXE) cdo2ml$(EXE) evaluator$(EXE)
rm -Rf prepro package
rm -f web/www/*.html web/*~
rm -f web/*.cdo
......
#!/bin/sh
TARG=$1
PRIMS=$2
if [ "${TARG}" = "" ] || [ "${PRIMS}" = "" ]; then
echo "Usage: cduce_mktop <target> <primitive file>"
exit 2
fi
exec ocamlfind ocamlc -package cduce -o $TARG -linkpkg -pp mlcduce_wrapper -impl $PRIMS
......@@ -83,10 +83,12 @@ and compile_aux env tail = function
| Typed.Dot (e,l) -> Dot (compile env tail e, l)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
| Typed.External (t,i) ->
| Typed.External (t,`Ext i) ->
(match env.cu with
| Some cu -> Var (External (cu,i))
| None -> failwith "Cannot compile externals in the toplevel")
| Typed.External (t,`Builtin s) ->
Var (Builtin s)
| Typed.Op (op,_,args) ->
let rec aux = function
| [arg] -> [ compile env tail arg ]
......@@ -110,7 +112,7 @@ and compile_abstr env a =
p::slots,
succ nb_slots,
Env.add x (Env nb_slots) fun_env;
| Global _ | Ext _ | External _ as p ->
| Global _ | Ext _ | External _ | Builtin _ as p ->
slots,
nb_slots,
Env.add x p fun_env
......
......@@ -6,6 +6,7 @@ type var_loc =
| Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
| External of Types.CompUnit.t * int
(* If pos < 0, the first arg is the value *)
| Builtin of string
| Global of int (* Only for the toplevel *)
| Dummy
......@@ -14,6 +15,7 @@ let print_var_loc ppf = function
| Env i -> Format.fprintf ppf "Env %i" i
| Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
| External (cu,i) -> Format.fprintf ppf "External (_,%i)" i
| Builtin s -> Format.fprintf ppf "Builtin (%s,_)" s
| Global i -> Format.fprintf ppf "Global %i" i
| Dummy -> Format.fprintf ppf "Dummy"
......@@ -123,14 +125,18 @@ module Put = struct
Types.CompUnit.serialize s cu;
int s i
| External (cu,i) ->
assert (i >= 0);
bits 3 s 2;
Types.CompUnit.serialize s cu;
int s i
| Env i ->
| Builtin b ->
bits 3 s 3;
Serialize.Put.string s b
| Env i ->
bits 3 s 4;
int s i
| Dummy ->
bits 3 s 4
bits 3 s 5
| Global _ -> assert false
let rec expr s = function
......@@ -258,8 +264,11 @@ module Get = struct
let cu = Types.CompUnit.deserialize s in
let pos = int s in
External (cu,pos)
| 3 -> Env (int s)
| 4 -> Dummy
| 3 ->
let s = Serialize.Get.string s in
Builtin s
| 4 -> Env (int s)
| 5 -> Dummy
| _ -> assert false
let rec expr s =
......
......@@ -6,6 +6,7 @@ type var_loc =
| Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
| External of Types.CompUnit.t * int
(* If pos < 0, the first arg is the value *)
| Builtin of string
| Global of int (* Only for the toplevel *)
| Dummy
......
......@@ -46,7 +46,7 @@ let register_cst op t v =
let register_fun op dom codom eval =
register_cst op
(Types.arrow (Types.cons dom) (Types.cons codom))
(Value.Abstraction ([(dom,codom)],eval))
(Value.Abstraction (Some [(dom,codom)],eval))
let register_op op ?(expect=Types.any) typ eval =
register_unary op
......
This diff is collapsed.
......@@ -182,7 +182,7 @@ let rec compile verbose name id src =
p
in
let stub,types = !stub_ml name ty_env c_env in
let ext = Externals.nb () > 0 in
let ext = Externals.has () in
let cu = mk (cu,types,ext) in
cu.stub <- stub;
C.Tbl.add tbl id cu;
......@@ -279,16 +279,30 @@ let import_check id chk = ignore (load_check id chk)
let import_and_run id = import id; run id
let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
let static_externals = Hashtbl.create 17
let register_static_external n v =
print_endline ("Builtin " ^ n);
Hashtbl.add static_externals n v
let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Typer.has_comp_unit := has_obj;
Typer.has_static_external := Hashtbl.mem static_externals;
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
Eval.get_external := (fun cu i -> (load cu).exts.(i))
Eval.get_external := (fun cu i -> (load cu).exts.(i));
Eval.get_builtin := Hashtbl.find static_externals
let set_externals cu a = (load cu).exts <- a
let registered_types cu = (load cu).types
let pack_types typs =
Serialize.Put.run (Serialize.Put.array Types.serialize) typs
let unpack_types typs =
Serialize.Get.run (Serialize.Get.array Types.deserialize) typs
......@@ -27,3 +27,9 @@ val set_externals: Types.CompUnit.t -> Value.t array -> unit
type stub_ml
val stub_ml : (string -> Typer.t -> Compile.env ->
stub_ml option * Types.t array) ref
val pack_types: Types.t array -> string
val unpack_types: string -> Types.t array
val register_static_external: string -> Value.t -> unit
......@@ -181,10 +181,11 @@ let save () =
| None -> ()
let main () =
at_exit (fun () -> Stats.dump Format.std_formatter);
Location.set_viewport (Html.create false);
match mode () with
| `Toplevel args ->
Config.inhibit "ocaml";
(* Config.inhibit "ocaml"; *)
Config.init_all ();
Builtin.argv := argv args;
restore ();
......@@ -202,6 +203,4 @@ let main () =
Builtin.argv := argv args;
Cduce.run f
let () =
at_exit (fun () -> Stats.dump Format.std_formatter);
main ()
let loc = (Lexing.dummy_pos, Lexing.dummy_pos)
let usage =
"Usage: mlcduce_wrapper <primitive file>
"
let err s = prerr_endline s; prerr_endline usage; exit 1
let () =
if Array.length Sys.argv != 2 then err "";
let fn = Sys.argv.(1) in
let ic =
try open_in fn
with Sys_error s -> err s in
let v = ref [] in
(try while true do
let s = input_line ic in
if s = "" then raise End_of_file;
match s.[0] with
| 'A'..'Z' -> v := s :: !v
| _ -> err "Names must start with a capitalized letter"
done
with End_of_file -> ());
let s = Mlstub.gen_wrapper !v in
!Pcaml.print_implem [ s,loc ]
......@@ -113,11 +113,14 @@ let protect e f =
(* Registered types *)
let gen_types = ref true
module HashTypes = Hashtbl.Make(Types)
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0
let register_type t =
assert(!gen_types);
let n =
try HashTypes.find registered_types t
with Not_found ->
......@@ -200,9 +203,13 @@ and to_cd_descr e = function
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd (call_lab y l arg) s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Value.Abstraction ([($tt$,$ss$)],$abs$) >>
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
)
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
......@@ -230,7 +237,13 @@ and to_cd_descr e = function
let cases =
List.map
(function
| (lab,[]) -> <:patt< $lid:p^lab$ >>, atom_ascii lab
| (lab,[]) ->
let pat = match lab with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
| "false" -> <:patt< False >>
| lab -> <:patt< $lid:p^lab$ >>
in
pat, atom_ascii lab
| (lab,tl) ->
let vars = mk_vars tl in
<:patt< $lid:p^lab$ $pat_tuple vars$ >>,
......@@ -249,7 +262,7 @@ and to_cd_descr e = function
l
in
<:expr< Value.record $list_lit l$ >>)
| Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
| Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
| Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
......@@ -265,7 +278,11 @@ and to_cd_descr e = function
protect e
(fun e ->
let y = mk_var () in
let tt = register_type (Types.descr (typ t)) in
let tt = if !gen_types then
let t = register_type (Types.descr (typ t)) in
<:expr< Some $t$ >>
else
<:expr< None >> in
let get_x = <:expr< $e$.val >> in
let get = <:expr< fun () -> $to_cd get_x t$ >> in
let tr_y = to_ml <:expr< $lid:y$ >> t in
......@@ -475,6 +492,7 @@ let check_value ty_env c_env (s,caml_t,t) =
<:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
let stub name ty_env c_env values =
gen_types := true;
let items = List.map (check_value ty_env c_env) values in
let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
......@@ -502,8 +520,7 @@ let stub name ty_env c_env values =
[ <:str_item< open Cduce_lib >>;
<:str_item< Config.init_all () >>;
<:str_item< value types = Librarian.registered_types cu >> ] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
[ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @ [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
<:str_item< Librarian.run cu >> ] @
(if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
......@@ -514,44 +531,110 @@ let stub name ty_env c_env values =
<:patt< ($list:items_pat$) >>, m, items_expr
let stub_ml cu ty_env c_env =
try
let name = String.capitalize cu in
let (prolog, values) =
try Mltypes.read_cmi name
with Not_found -> ("",[]) in
let code = stub cu ty_env c_env values in
Some (Obj.magic (prolog,code)),
get_registered_types ()
with Mltypes.Error s -> raise (Location.Generic s)
let register b s args =
try
let (t,n) = Mltypes.find_value s in
let m = List.length args in
if n <> m then
Location.raise_generic
(Printf.sprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
let i = if b then
let i = List.length !exts in
exts := (s, t) :: !exts;
i
else
0 in
vars := Array.of_list args;
let cdt = Types.descr (typ t) in
vars := [| |];
i,cdt
with Not_found ->
Location.raise_generic
(Printf.sprintf "Cannot resolve ocaml external %s" s)
(* Generation of wrappers *)
let wrapper values =
gen_types := false;
let exts = List.rev_map
(fun (s,t) ->
let v = to_cd <:expr< $lid:s$ >> t in
<:str_item<
Librarian.register_static_external $str:String.escaped s$ $v$ >>)
values in
let g = global_transl () in
let m = if g = [] then exts else <:str_item< value rec $list:g$ >>::exts in
let m = [ <:str_item< open Cduce_lib >>;
<:str_item< Config.init_all () >>] @ m @
[ <:str_item< Run.main () >> ] in
<:str_item< declare $list:m$ end >>
let gen_wrapper vals =
try
let values = List.fold_left
(fun accu s ->
try (s,fst (Mltypes.find_value s)) :: accu
with Not_found ->
let vals =
try Mltypes.load_cmi s
with Not_found ->
failwith ("Cannot resolve " ^ s)
in
vals @ accu
) [] vals in
wrapper values
with Mltypes.Error s -> raise (Location.Generic s)
(* Dynamic coercions *)
(*
let to_cd_dyn = function
| Link t -> to_cd_dyn e t
| Arrow (l,t,s) ->
let tt = Types.descr (typ t) in
let ss = Types.descr (typ s) in
let tf = to_ml_dyn t in
let sf = to_cd_dyn t in
(fun (f : Obj.repr) ->
let f = (Obj.magic f : Obj.repr -> Obj.repr) in
Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
| Tuple tl ->
let fs = List.map to_cd_dyn tl in
(fun (x : Obj.repr) ->
let x = (Obj.magic x : Obj.repr array) in
let rec aux i = function
| [] -> assert false
| [f] -> f x.(i)
| f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
aux 0 fs)
*)
let register () =
Typer.has_ocaml_unit :=
(fun cu -> Mltypes.has_cmi (U.get_str cu));
Librarian.stub_ml :=
(fun cu ty_env c_env ->
try
let name = String.capitalize cu in
let (prolog, values) =
try Mltypes.read_cmi name
with Not_found ->
(* Printf.eprintf "Warning: no caml interface\n"; *)
("",[]) in
let code = stub cu ty_env c_env values in
Some (Obj.magic (prolog,code)),
get_registered_types ()
with Mltypes.Error s -> raise (Location.Generic s)
);
Externals.register :=
(fun i s args ->
try
let (t,n) = Mltypes.find_value s in
let m = List.length args in
if n <> m then
Location.raise_generic
(Printf.sprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
exts := (s, t) :: !exts;
vars := Array.of_list args;
let cdt = Types.descr (typ t) in
vars := [| |];
cdt
with Not_found ->
Location.raise_generic
(Printf.sprintf "Cannot resolve ocaml external %s" s)
)
Librarian.stub_ml := stub_ml;
Externals.register := register
let () =
Config.register
......
val gen_wrapper: string list -> MLast.str_item
......@@ -6,6 +6,8 @@ open Types
(* Unfolding of OCaml types *)
exception PolyAbstract of string
let ocaml_env = ref Env.initial
type t = { uid : int; mutable recurs : int; mutable def : def }
......@@ -166,7 +168,7 @@ let rec unfold seen constrs ty =
| Type_abstract, None ->
(match args with
| [] -> Abstract pn
| _ -> failwith ("Polymorphic abstract type: " ^ pn))))
| _ -> raise (PolyAbstract pn))))
| _ -> failwith "Unsupported feature"
);
slot
......@@ -188,6 +190,33 @@ let has_cmi name =
try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
with Not_found -> false
let load_cmi name =
Config.load_path := Config.standard_library :: !Librarian.obj_path;
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
let sg = Env.read_signature name filename in
ocaml_env := Env.add_signature sg Env.initial;
let values = ref [] in
List.iter
(function
| Tsig_value (id, {val_type=t;val_kind=Val_reg|Val_prim _}) ->
let n = name ^ "." ^ (Ident.name id) in
(try
let (t,_) = unfold t in
values := (name ^ "." ^ (Ident.name id), t) :: !values
with PolyAbstract _ -> ())
| _ -> ()
) sg;
!values
let load_cmi name =
try load_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 read_cmi name =
Config.load_path := Config.standard_library :: !Librarian.obj_path;
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
......
......@@ -17,6 +17,11 @@ and def =
| Var of int
(* Load an external .cmi *)
val has_cmi: string -> bool
val load_cmi: string -> (string * t) list
(* Load the .cmi corresponding to a CDuce compilation unit *)
val read_cmi: string -> string * (string * Types.type_expr * t) list
val print : Format.formatter -> t -> unit
......@@ -25,4 +30,3 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t * int
val has_cmi: string -> bool
......@@ -62,7 +62,7 @@ and pexpr =
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
| Dot of pexpr * label
| Dot of pexpr * label * ppat list
| RemoveField of pexpr * label
(* Exceptions *)
......@@ -73,7 +73,6 @@ and pexpr =
| Forget of pexpr * ppat
| Check of pexpr * ppat
| Ref of pexpr * ppat
| External of string * ppat list
......
......@@ -216,7 +216,7 @@ EXTEND
| "transform" | "fun" | "in"
| "let" | "type" | "debug" | "include"
| "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
| "not" | "as" | "where" | "external"
| "not" | "as" | "where"
]
-> a
]
......@@ -240,10 +240,6 @@ EXTEND
exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| "external"; s = STRING2 ->
exp loc (External (s,[]))
| "external"; "{"; s = STRING2; pl = LIST0 pat; "}" ->
exp loc (External (s,pl))
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......@@ -260,7 +256,7 @@ EXTEND
]
|
[ e1 = expr; ":="; e2 = expr ->
exp loc (Apply (Dot (e1, U.mk "set"), e2))
exp loc (Apply (Dot (e1, U.mk "set", []), e2))
]
|
[ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
......@@ -291,8 +287,10 @@ EXTEND
exp loc (Transform (e,[b]))
]
|
[ e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e, label l))
[ e = expr; "."; l = [IDENT | keyword ];
tyargs = [ "with"; "{"; pl = LIST0 pat; "}" -> pl | -> [] ]
->
exp loc (Dot (e, label l,tyargs))
]
| [
e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
......@@ -328,7 +326,7 @@ EXTEND
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = IDENT -> exp loc (Var (U.mk a))
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
exp loc (Apply (Dot (e, U.mk "get", []), cst_nil))
| i = INT -> exp loc (Integer (Intervals.V.mk i))
| "`"; a = tag -> a
| c = char -> exp loc (Char c)
......
......@@ -151,7 +151,7 @@ let rec string_of_pexpr x =
^string_of_branches(b) ^ ")"
| Xtrans(e,b) -> "(xtransform" ^string_of_pexpr e ^ " with"
^string_of_branches(b) ^ ")"
| Dot(e1,_) -> "Dot(" ^ string_of_pexpr e1 ^",lbl)"
| Dot(e1,_,_) -> "Dot(" ^ string_of_pexpr e1 ^",lbl)"
| RemoveField (e,l) -> "RF(" ^ string_of_pexpr e ^",lbl)"
| Const (Types.Atom a) -> (match (Atoms.V.value a) with
(_,utf) -> "`"^U.get_str utf )
......
......@@ -63,8 +63,8 @@ EXTEND
in exp loc (Transform (e,[t]))
| e = expr; "//" ; p = pat -> (* projections sur tous les descendants *)
let assign=
exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set"),
(op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set",[]),
(op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
in let branche=Pair(Var id_dummy,cst_nil)
in let branches= exp loc (Match(assign,[pat_nil,branche]))
in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(None,U.mk "$$$")),p))),branches]))
......@@ -73,7 +73,7 @@ EXTEND
in exp loc(Match(rf,[mk loc(PatVar(None,U.mk"$stack")),
exp loc(Match(xt,
[mk loc(Internal Types.any),
exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil))]))
exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil))]))
]))
(* equivalent as:
......
......@@ -88,6 +88,8 @@ let set_external = ref (fun cu pos -> assert false)
let get_slot cu pos = !get_global cu pos
let set_slot cu pos v = !set_global cu pos v
let get_builtin = ref (fun _ -> assert false)
let eval_var env = function
| Env i -> env.(i)
| Stack i -> !stack.(!frame + i)
......@@ -107,6 +109,8 @@ let eval_var env = function
Obj.set_field x 0 (Obj.repr v);
Obj.set_field x 1 (Obj.repr (-1));
v
| Builtin s ->
!get_builtin s
let tag_op_resolved = Obj.tag (Obj.repr (OpResolved (Obj.repr 0, [])))
......