Commit f6287d25 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-26 00:19:23 by afrisch] new compilation (doesn't work yet)

Original author: afrisch
Date: 2004-12-26 00:19:24+00:00
parent 59336de9
......@@ -5,6 +5,9 @@ Since 0.2.1
- Back to the old semantics for default value patterns in regexps
(the non-capturing semantics is obtained with /(x:=c))
- bug fixes in configure/Makefile for Cygwin
- bug fix for the compilation of complex patterns with records
- new syntax { l = p else p' }
- fixed a little bit support for XML Schema, but still largely broken
0.2.1
......
......@@ -130,7 +130,7 @@ and compile_branches env tail (brs : Typed.branches) =
brs_tail = tail;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
brs_input = brs.Typed.br_typ;
brs_compiled = None
brs_compiled = None; brs_compiled2 = None
}
and compile_branch env tail br =
......
......@@ -69,7 +69,9 @@ and branches = {
brs_input: Types.t;
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
mutable brs_compiled2:
(Patterns.Compile2.dispatcher * (int list * expr) option array) option;
}
let rec dump_expr ppf = function
......@@ -337,7 +339,7 @@ module Get = struct
let accept_chars = bool s in
{ brs = brs; brs_tail = tail; brs_input = input;
brs_accept_chars = accept_chars;
brs_compiled = None
brs_compiled = None; brs_compiled2 = None
}
let code_item s =
......
......@@ -44,7 +44,9 @@ and branches = {
brs_input: Types.t;
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
mutable brs_compiled2:
(Patterns.Compile2.dispatcher * (int list * expr) option array) option;
}
type code_item =
......
......@@ -30,6 +30,15 @@ let dispatcher brs =
brs.brs_compiled <- Some x;
x
let dispatcher2 brs =
match brs.brs_compiled2 with
| Some d -> d
| None ->
Format.fprintf Format.std_formatter "Start compilation...@.";
let x = Patterns.Compile2.make_branches brs.brs_input brs.brs in
Format.fprintf Format.std_formatter "Done.@.";
brs.brs_compiled2 <- Some x;
x
let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
......@@ -165,6 +174,7 @@ and eval_apply_tail_rec f arg =
and eval_branches env brs arg =
let (disp, rhs) = dispatcher brs in
let (code, bindings) = Run_dispatch.run_dispatcher disp arg in
......@@ -182,6 +192,25 @@ and eval_branches env brs arg =
v
| Patterns.Compile.Fail -> Value.Absent
(*
and eval_branches env brs arg =
let (disp, rhs) = dispatcher2 brs in
let (code, bindings) = Run_dispatch.run_dispatcher2 disp arg in
match rhs.(code) with
| Some (bind,e) ->
let saved_sp = !sp in
List.iter
(fun i -> push (if (i == -1) then arg else bindings.(i)))
bind;
if brs.brs_tail
then eval env e
else
let v = eval env e in
sp := saved_sp;
v
| None -> Value.Absent
*)
and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e)
......
......@@ -32,6 +32,14 @@ let ensure_room n =
let buffer' = Array.create (l * 2 + n) Absent in
blit !buffer 0 buffer' 0 !cursor;
buffer := buffer'
let push v =
ensure_room 1;
!buffer.(!cursor) <- v;
incr cursor
(* Old dispatchers *)
let make_result_prod v1 r1 v2 r2 v (code,r) =
......@@ -296,11 +304,8 @@ let run_dispatcher d v =
let code = run_dispatcher d v in
cursor := 0;
(code,!buffer)
(* let r = Array.create !cursor Absent in
blit !buffer 0 r 0 !cursor;
cursor := 0;
(code,r) *)
let old_dispatcher = run_dispatcher
(*
......@@ -317,3 +322,249 @@ let check_overwrite r2 r =
*)
(* New dispatcher *)
open Patterns.Compile2
let make_result_basic v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
for a = 0 to n - 1 do
buf.(!cursor) <- begin match Array.unsafe_get r a with
| SrcCapture -> v
| SrcCst c -> const c
| _ -> assert false
end;
incr cursor
done);
code
let make_result_prod v1 r1 v2 r2 v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
let c = !cursor in
for a = 0 to n - 1 do
buf.(c + a) <- match Array.unsafe_get r a with
| SrcCapture -> v
| SrcLeft -> v1
| SrcRight -> v2
| SrcCst c -> const c
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i)
| SrcPair (l,r) ->
Pair (
(match l with
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false),
(match l with
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false))
| _ -> assert false
done;
if r1 != c then blit buf c buf r1 n;
cursor := r1 + n);
code
let make_result_record sp v (code,r) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
let buf = !buffer in
let c = !cursor in
for a = 0 to n - 1 do
buf.(c + a) <- match Array.unsafe_get r a with
| SrcLocal i -> buf.(sp+i)
| _ -> assert false
done;
if sp != c then blit buf c buf sp n;
cursor := sp + n);
code
let rec run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ -> assert false
let count = ref 0
let rec run_dispatcher d v =
(* Format.fprintf Format.std_formatter "Matching (%a)@." Value.print v; *)
(* Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(* print_string "."; flush stdout; *)
incr count;
print_int !count;
print_string "X"; flush stdout;
if !count = 9685 then
Format.fprintf Format.std_formatter "Matching (%a)@\n with:@\n%a@."
Value.print v
Patterns.Compile2.print_dispatcher d;
let res =
match actions d with
| AResult r -> make_result_basic v r
| AKind k -> run_disp_kind k v
in
print_string "Y"; flush stdout;
res
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) -> assert false
(* run_disp_string_latin1 i j s q actions *)
| String_utf8 (i,j,s,q) as v ->
print_string "N"; flush stdout;
run_disp_kind actions (Value.normalize v)
(* run_disp_string_utf8 i j s q actions *)
| Atom a -> make_result_basic v (Atoms.get_map a actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (iface,_)
| Abstraction2 (_,iface,_) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.basic
| Abstract (abs,_) ->
run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
actions.basic
| Absent -> assert false
| Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
| Delayed _ -> assert false
and run_disp_prod v v1 v2 = function
| Impossible -> assert false
| LeftRight rdd -> run_disp_prod' v v1 v2 rdd
| RightLeft rdd -> run_disp_prod' v v2 v1 rdd
and run_disp_prod' v v1 v2 = function
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
and run_disp_prod2 v1 r1 v v2 = function
| Ignore r -> make_result_prod v1 r1 v2 !cursor v r
| TailCall d2 -> run_dispatcher d2 v2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_dispatcher d2 v2 in
make_result_prod v1 r1 v2 r2 v b2.(code2)
and do_pushes v vl = function
| [] -> ()
| PushConst c :: rem -> push (const c); do_pushes v vl rem
| PushField :: rem -> push vl; do_pushes v vl rem
| PushCapture :: rem -> push v; do_pushes v vl rem
and do_record_tr sp other v vl fields (pushes,ct) =
print_string "*"; flush stdout;
do_pushes v vl pushes;
run_disp_record sp other v fields ct
and run_disp_record sp other v fields = function
| RecordLabel (l,d,cts,abs) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l ->
do_record_tr sp other v vl rem cts.(run_dispatcher d vl)
| rem -> do_record_tr sp other v Absent rem abs
in
aux other fields
| RecordLabelSkip (l,pr,abs) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l -> do_record_tr sp other v vl rem pr
| rem -> do_record_tr sp other v Absent rem abs
in
aux other fields
| RecordResult r ->
make_result_record sp v r
| RecordMore (nomore,more) ->
let other = other || (fields != []) in
make_result_record sp v (if other then more else nomore)
| RecordImpossible -> assert false
(*
and run_disp_string_latin1 i j s q actions =
if i == j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
| Ignore d2 -> run_disp_string_latin1_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
run_disp_string_latin1_2 r1 i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_latin1_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_latin1 i j s q r1 0 r
| TailCall d2 -> run_disp_string_latin1_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_latin1_loop i j s q d2 in
make_result_string_latin1 i j s q r1 r2 b2.(code2)
and run_disp_string_latin1_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_latin1 (succ i) j s q k
and run_disp_string_utf8 i j s q actions =
if Utf8.equal_index i j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
| Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
run_disp_string_utf8_2 r1 i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_utf8_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_utf8 i j s q r1 0 r
| TailCall d2 -> run_disp_string_utf8_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_utf8_loop i j s q d2 in
make_result_string_utf8 i j s q r1 r2 b2.(code2)
and run_disp_string_utf8_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
*)
let run_dispatcher2 d v =
print_string "+"; flush stdout;
let code = run_dispatcher d v in
cursor := 0;
print_string "-\n"; flush stdout;
(code,!buffer)
let run_dispatcher = old_dispatcher
open Value
val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
val run_dispatcher2: Patterns.Compile2.dispatcher -> t -> int * t array
This diff is collapsed.
......@@ -76,11 +76,61 @@ module Compile: sig
val make_branches : Types.t -> (node * 'a) list -> dispatcher * 'a rhs array
val print_dispatcher: Format.formatter -> dispatcher -> unit
(* val print_dispatcher: Format.formatter -> dispatcher -> unit *)
val debug_compile : Format.formatter -> Types.Node.t -> node list -> unit
end
module Compile2 : sig
type dispatcher
type source =
| SrcCapture
| SrcLeft | SrcRight
| SrcCst of Types.const
| SrcPair of source * source
| SrcFetchLeft of int
| SrcFetchRight of int
| SrcLocal of int
type push = PushConst of Types.const | PushField | PushCapture
type result = int * source array
type actions =
| AResult of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
atoms: result Atoms.map;
chars: result Chars.map;
prod: actions_prod;
xml: actions_prod;
record: actions_record;
}
and actions_record =
| RecordLabel of label * dispatcher * record_tr array * record_tr
| RecordLabelSkip of label * record_tr * record_tr
| RecordResult of result
| RecordMore of result * result (* nomore, more *)
| RecordImpossible
and record_tr = (push list * actions_record)
and actions_prod =
| LeftRight of result dispatch dispatch
| RightLeft of result dispatch dispatch
| Impossible
and 'a dispatch =
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
val actions: dispatcher -> actions
val make_branches :
Types.t -> (node * 'a) list ->
dispatcher * (int list * 'a) option array
val print_dispatcher: Format.formatter -> dispatcher -> unit
end
val approx :
descr ->
......
......@@ -53,6 +53,15 @@ some special regular expressions.
</sample>
</box>
<box title="First-class functions and XML together" link="funxml">
<p>
The program below illustrates the use of first-class functions stored
in (pseudo) XML documents.
</p>
<sample highlight="false">
<include-verbatim file="funxml.cd"/>
</sample>
</box>
<box title="CDuce quine" link="quine">
<p>
......
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