[r2004-05-23 11:00:56 by afrisch] Simplify idents

Original author: afrisch
Date: 2004-05-23 11:00:57+00:00

compile/compile.ml

@@ -125,7 +125,7 @@ and compile_branch env tail br =
 	     vars = Env.add x (Stack env.stack_size) env.vars;
 	     stack_size = env.stack_size + 1 }
 
-      ) env (Patterns.fv_list br.Typed.br_pat) in
+      ) env (Patterns.fv br.Typed.br_pat) in
   (br.Typed.br_pat, compile env tail br.Typed.br_body)
 
 
@@ -159,7 +159,7 @@ let compile_eval env e = [ Push (compile_expr env e); Pop ]
 
 let compile_let_decl env decl =
   let pat = decl.Typed.let_pat in
-  let (env,code) = enter_globals env (Patterns.fv_list pat) in
+  let (env,code) = enter_globals env (Patterns.fv pat) in
   (env, (Push (compile_expr env decl.Typed.let_body)) :: (Split pat) :: code)
 
 let compile_rec_funs env funs =

driver/cduce.ml

@@ -275,6 +275,7 @@ let run rule ppf ppf_err input =
   with exn -> catch_exn ppf_err exn; false
 
 let topinput = run Parser.top_phrases
+let script = run Parser.prog
 
 ifdef ML_INTERFACE then 
   let check_ml cu id out_dir out =

driver/cduce.mli

 val toplevel: bool ref
 val verbose: bool ref
 
+val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
 val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
 
 val dump_env : Format.formatter -> unit

misc/custom.ml

@@ -40,8 +40,21 @@ module String : T with type t = string = struct
   type t = string
   let dump = Format.pp_print_string
   let check s = ()
-  let equal : t -> t -> bool = (=)
-  let compare : t -> t -> int = Pervasives.compare
+
+  let rec compare_string_aux s1 s2 l =
+    if (l == 0) then 0 
+    else
+      let l = pred l in
+      let c1 = Char.code (String.unsafe_get s1 l)
+      and c2 = Char.code (String.unsafe_get s2 l) in
+      if c1 != c2 then c2 - c1 else compare_string_aux s1 s2 l
+
+  let compare s1 s2 =
+    let l1 = String.length s1 and l2 = String.length s2 in
+    if l1 != l2 then l2 - l1 else compare_string_aux s1 s2 l1
+
+
+  let equal x y = compare x y = 0
   let hash = Hashtbl.hash
   let serialize = Serialize.Put.string
   let deserialize = Serialize.Get.string

schema/schema_parser.mli

@@ -4,11 +4,13 @@
 open Schema_types
 open Schema_xml
 
+(*
   (** parse a schema from a PXP source *)
 val parse_schema: Pxp_types.source -> schema
 
   (** parse a schema from a PXP node *)
 val schema_of_node: pxp_node -> schema
+*)
 
   (** shortand for "parse_schema (Pxp_types.from_file <fname>)" *)
 val schema_of_file: string -> schema

types/ident.ml

 module U = Encodings.Utf8
-module Id = Pool.Make(U)
+
+module IdPool = Weak.Make(U)
+let id_pool = IdPool.create 17
+
+module Id = struct
+  include U
+  let mk = IdPool.merge id_pool
+  let value x = x
+end
+type id = U.t
+let ident = Id.mk
+let to_string id = U.to_string (Id.value id)
+let print ppf id = Format.fprintf ppf "%s" (to_string id)
+
 module IdSet = SortedList.Make(Id)
 module IdMap = IdSet.Map
 module Env = Map.Make(Id)
-type id = Id.t
 type 'a id_map = 'a IdMap.map
 type fv = IdSet.t
 
-let ident = Id.mk
-
-let to_string id =
-  U.to_string (Id.value id)
 
-let print ppf id =
-  Format.fprintf ppf "%s" (to_string id)
 
 module Label = Ns.QName
 

types/patterns.ml

@@ -27,8 +27,7 @@ and node = {
   id : int;
   mutable descr : descr;
   accept : Types.Node.t;
-  fv : fv;
-  fv_list : id list;
+  fv : fv
 } and descr = Types.t * fv * d
 
 
@@ -36,7 +35,6 @@ and node = {
 let id x = x.id
 let descr x = x.descr
 let fv x = x.fv
-let fv_list x = x.fv_list
 let accept x = Types.internalize x.accept
 
 let printed = ref []
@@ -83,9 +81,7 @@ let counter = State.ref "Patterns.counter" 0
 let dummy = (Types.empty,IdSet.empty,Dummy)
 let make fv =
   incr counter;
-  { id = !counter; descr = dummy; accept = Types.make (); fv = fv;
-    fv_list = fv;
-  }
+  { id = !counter; descr = dummy; accept = Types.make (); fv = fv }
 
 let define x ((accept,fv,_) as d) =
   (* assert (x.fv = fv); *)
@@ -146,7 +142,6 @@ module Node = struct
       l := SMemo.add n.id !l;
       Types.Node.serialize t n.accept;
       IdSet.serialize t n.fv;
-      Serialize.Put.list Id.serialize t n.fv_list;
       serialize_descr t n.descr
     )
   and serialize_descr s (_,_,d) =
@@ -193,10 +188,8 @@ module Node = struct
     with Not_found ->
       let accept = Types.Node.deserialize t in
       let fv = IdSet.deserialize t in
-      let fv_list = Serialize.Get.list Id.deserialize t in
       incr counter;
-      let n = { id = !counter; descr = dummy; accept = accept; fv = fv; 
-		fv_list = fv_list } in
+      let n = { id = !counter; descr = dummy; accept = accept; fv = fv } in
       l := DMemo.add id n !l;
       n.descr <- deserialize_descr t;
       n
@@ -1058,7 +1051,7 @@ struct
 	     if Types.is_empty (Types.cap t td) then t else
 	       Types.diff t td in*)
 	   let t' = Types.diff t (Types.descr (accept p)) in
-	   (t', (p',(fv_list p, e)) :: brs)
+	   (t', (p',(fv p, e)) :: brs)
 	) (t,[]) brs in
 	
     let pl = Array.map (fun x -> [x]) (Array.of_list brs) in

types/patterns.mli

@@ -24,11 +24,6 @@ val constant: id -> Types.const -> descr
 val id: node -> int
 val descr: node -> descr
 val fv : node -> fv
-val fv_list : node -> id list
-  (* fv_list retains the original order of fv, which can
-     change during serialization/deserialization --> issue
-     with compilation *)
-
 
 (* Pattern matching: static semantics *)
 

web/examples/build.cd

@@ -11,7 +11,7 @@ type Example  = <example code=Latin1 title=Latin1>Latin1
 (** Command line **)
 
 let input =
-  match argv with
+  match argv [] with
   | [ s ] -> s
   | _ -> raise "Please specify an input file on the command line"