Commit ac09ecd0 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-26 17:05:30 by cvscast] Evaluateur tourne !

Original author: cvscast
Date: 2002-10-26 17:05:31+00:00
parent b8755776
......@@ -17,14 +17,14 @@ RUNTIME = runtime/value.cmo
DRIVER = driver/cduce.cmo
DIRS = parser typing types driver
DIRS = parser typing types runtime driver
OBJECTS = $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
XOBJECTS = $(OBJECTS:.cmo=.cmx)
XDRIVER = $(DRIVER:.cmo=.cmx)
DEPEND = parser/*.ml parser/*.mli typing/*.ml typing/*.mli types/*.ml types/*.mli runtime/*.mli runtime/*.ml driver/*.mli driver/*.ml
INCLUDES = -I +camlp4 -I parser -I types -I typing
INCLUDES = -I +camlp4 -I parser -I types -I runtime -I typing
SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
......
......@@ -98,7 +98,9 @@ let phrase ph =
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check Typer.Env.empty e Types.any true in
Format.fprintf ppf "%a@\n" print_norm t
Format.fprintf ppf "|- %a@\n" print_norm t;
let v = Value.eval Value.empty_env e in
Format.fprintf ppf "=> %a@\n" Value.print v
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug l
| _ -> assert false
......
type t
type env
val empty_env : env
val print: Format.formatter -> t -> unit
......
......@@ -376,7 +376,7 @@ struct
in
aux f a 0
let combine disp act =
let combine (disp,act) =
if Array.length act = 0 then `None
else
if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes)
......@@ -575,8 +575,32 @@ struct
d t selected unselect
in
let res = Array.map result disp.codes in
post (combine disp res)
post (disp,res)
let make_branches t brs =
let (_,brs) =
List.fold_left
(fun (t,brs) (p,e) ->
let p = Normal.restrict t (Normal.nf p) in
let t = Types.diff t (p.Normal.a) in
(t, (p,e) :: brs)
) (t,[]) brs in
let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
get_tests
pl
(fun x -> [x],[])
t
(fun _ pl _ ->
let r = ref None in
let aux = function
| [x] -> assert (!r = None); r := Some x
| [] -> () | _ -> assert false in
Array.iter aux pl;
let r = match !r with None -> assert false | Some x -> x in
r
)
(fun x -> x)
let rec dispatch_prod disp =
......@@ -586,14 +610,14 @@ struct
(fun (res,(p,q)) -> [p, (res,q)], [])
(Types.Product.pi1 t)
(dispatch_prod1 disp t)
detect_left_tail_call
(fun x -> detect_left_tail_call (combine x))
and dispatch_prod1 disp t t1 pl _ =
let t = Types.Product.restrict_1 t t1 in
get_tests pl
(fun (ret1, (res,q)) -> [q, (ret1,res)], [] )
(Types.Product.pi2 t)
(dispatch_prod2 disp t)
detect_right_tail_call
(fun x -> detect_right_tail_call (combine x))
and dispatch_prod2 disp t t2 pl _ =
let aux_final (ret2, (ret1, res)) =
List.map (conv_source_prod ret1 ret2) res in
......@@ -656,7 +680,7 @@ struct
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t)
(fun x -> x)
(fun x -> combine x)
in
let absent =
let pl = label_not_found l pl in
......
......@@ -66,4 +66,8 @@ module Compile: sig
val actions: dispatcher -> actions
val show : Format.formatter -> Types.descr -> normal array -> unit
val make_branches :
Types.descr -> (descr * 'a) list ->
dispatcher * ((capture, int) SortedMap.t * 'a) array
end
......@@ -57,7 +57,18 @@ and branch = {
br_pat : tpat;
br_body : texpr
}
and compiled_branches = {
actions : Patterns.Compile.actions;
rhs : (texpr * (string * int) list) array
}
and compiled_branches =
Patterns.Compile.dispatcher * ((string * int) list * texpr) array
let dispatcher brs =
match brs.br_compiled with
| Some d -> d
| None ->
let aux b = Patterns.descr b.br_pat, b.br_body in
let x = Patterns.Compile.make_branches
brs.br_typ
(List.map aux brs.br_branches) in
brs.br_compiled <- Some x;
x
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