[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

CHANGES

@@ -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
 

compile/compile.ml

@@ -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 =

compile/lambda.ml

@@ -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 =

compile/lambda.mli

@@ -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 =

runtime/eval.ml

@@ -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)
 

runtime/run_dispatch.ml

@@ -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

runtime/run_dispatch.mli

 open Value
 
 val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
+
+val run_dispatcher2: Patterns.Compile2.dispatcher -> t -> int * t array

types/patterns.mli

@@ -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 ->

web/examples.xml

@@ -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>