lambda.ml

open Ident

type var_loc =
  | Stack of int
  | Env of int
  | 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 *)
  | Global of int (* Only for the toplevel *)
  | Dummy

let print_var_loc ppf = function
  | Stack i -> Format.fprintf ppf "Stack %i" i
  | 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
  | Global i -> Format.fprintf ppf "Global %i" i
  | Dummy -> Format.fprintf ppf "Dummy"

type schema_component_kind =
  [ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option

let serialize_schema_component_kind s x =
  Serialize.Put.bits 3 s (match x with
	    | Some `Type -> 0
	    | Some `Element -> 1
	    | Some `Attribute -> 2
	    | Some `Attribute_group -> 3
	    | Some `Model_group -> 4
	    | None -> 5)

let deserialize_schema_component_kind s =
  match Serialize.Get.bits 3 s with
    | 0 -> Some `Type
    | 1 -> Some `Element
    | 2 -> Some `Attribute
    | 3 -> Some `Attribute_group
    | 4 -> Some `Model_group
    | 5 -> None
    | _ -> assert false

type expr = 
  | Var of var_loc
  | Apply of bool * expr * expr
  | Abstraction of var_loc array * (Types.t * Types.t) list * branches
  | Check of Types.t * expr * Types.Node.t 

  | Const of Types.Const.t
  | Pair of expr * expr
  | Xml of expr * expr * expr
  | Record of expr label_map
  | String of U.uindex * U.uindex * U.t * expr

  | Match of expr * branches
  | Map of expr * branches
  | Transform of expr * branches
  | Xtrans of expr * branches
  | Try of expr * branches
  | Validate of expr * string * Ns.qname
  | RemoveField of expr * label
  | Dot of expr * label
  | Ref of expr * Types.Node.t
  | Op of string * expr list
  | OpResolved of Obj.t * expr list
  | NsTable of Ns.table * expr

and branches = {
  brs: (Patterns.node * expr) list;
  brs_tail: bool;
  brs_input: Types.t;
  brs_accept_chars: bool;
  mutable brs_compiled: 
    (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
  | Var v -> print_var_loc ppf v
  | Apply (tr,f,x) -> Format.fprintf ppf "Apply (%b,%a,%a)" tr dump_expr f dump_expr x
  | Abstraction (env,iface,brs) ->
      Format.fprintf ppf "Abstraction ([";
      for i = 0 to Array.length env - 1 do
	Format.fprintf ppf "{%a}," print_var_loc env.(i);
      done;
      Format.fprintf ppf "],%a)" dump_branches brs
  | _ -> Format.fprintf ppf "other expr";

and dump_branches ppf brs =
  List.iter (fun (p,e) -> Format.fprintf ppf "_ -> %a |" dump_expr e) brs.brs

type code_item =
  | Push of expr
  | Pop
  | Split of Patterns.node
  | SetGlobal of Types.CompUnit.t * int

let print_code_item ppf = function
  | Push _ -> Format.fprintf ppf "Push@."
  | Pop -> Format.fprintf ppf "Pop@."
  | Split _ -> Format.fprintf ppf "Split@."
  | SetGlobal (_,_) -> Format.fprintf ppf "SetGlobal@."

type code = code_item list


let nbits = 5

let magic_compunit = "CDUCE:0.3:COMPUNIT"

module Put = struct
  let unary_op = ref (fun _ _ -> assert false; ())
  let binary_op = ref (fun _ _ -> assert false; ())

  open Serialize.Put

  let var_loc s = function
    | Stack i ->
	bits 3 s 0;
	int s i
    | Ext (cu,i) ->
	bits 3 s 1;
	Types.CompUnit.serialize s cu;
	int s i
    | External (cu,i) ->
	bits 3 s 2;
	Types.CompUnit.serialize s cu;
	int s i
    | Env i ->
	bits 3 s 3;
	int s i
    | Dummy ->
	bits 3 s 4
    | Global _ -> assert false
	
  let rec expr s = function
    | Var v -> 
	bits nbits s 0;
	var_loc s v
    | Apply (tail,e1,e2) ->
	bits nbits s 1;
	bool s tail;
	expr s e1;
	expr s e2
    | Abstraction (slots,iface,brs) ->
	bits nbits s 2;
	array var_loc s slots;
	list (pair Types.serialize Types.serialize) s iface;
	branches s brs
    | Const c ->
	bits nbits s 3;
	Types.Const.serialize s c
    | Pair (e1,e2) ->
	bits nbits s 4;
	expr s e1;
	expr s e2
    | Xml (e1,e2,e3) ->
	bits nbits s 5;
	expr s e1;
	expr s e2;
	expr s e3
    | Record r ->
	bits nbits s 6;
	LabelMap.serialize expr s r
    | String (i,j,st,q) ->
	bits nbits s 7;
	U.serialize_sub s st i j;
	expr s q
    | Match (e,brs) ->
	bits nbits s 8;
	expr s e;
	branches s brs
    | Map (e,brs) ->
	bits nbits s 9;
	expr s e;
	branches s brs
    | Transform (e,brs) ->
	bits nbits s 10;
	expr s e;
	branches s brs
    | Xtrans (e,brs) ->
	bits nbits s 11;
	expr s e;
	branches s brs
    | Try (e,brs) ->
	bits nbits s 12;
	expr s e;
	branches s brs
    | Validate (e,sch,t) ->
	bits nbits s 13;
	expr s e;
	string s sch;
	Ns.QName.serialize s t
(*	assert false (* TODO:Need to store a pointer to the schema ... *) *)
    | RemoveField (e,l) ->
	bits nbits s 14;
	expr s e;
	LabelPool.serialize s l
    | Dot (e,l) ->
	bits nbits s 15;
	expr s e;
	LabelPool.serialize s l
    | Ref (e,t) ->
	bits nbits s 18;
	expr s e;
	Types.Node.serialize s t
    | Op (op,args) ->
	bits nbits s 19;
	string s op;
	list expr s args
    | OpResolved _ ->
	assert false
    | NsTable (ns,e) ->
	bits nbits s 20;
	Ns.serialize_table s ns;
	expr s e
    | Check (t0,e,t) ->
	bits nbits s 21;
	Types.serialize s t0;
	expr s e;
	Types.Node.serialize s t
	
	  
  and branches s brs =
    list (pair Patterns.Node.serialize expr) s brs.brs;
    bool s brs.brs_tail;
    Types.serialize s brs.brs_input;
    bool s brs.brs_accept_chars

  let code_item s = function
    | Push e -> bits 2 s 0; expr s e
    | Pop -> bits 2 s 1
    | Split p -> bits 2 s 2; Patterns.Node.serialize s p
    | SetGlobal (cu,i) -> bits 2 s 3; Types.CompUnit.serialize s cu; int s i

  let codes = list code_item

  let compunit s c =
    magic s magic_compunit;
    codes s c
end
	

module Get = struct
  let unary_op = ref (fun _ -> assert false)
  let binary_op = ref (fun _ -> assert false)

  open Serialize.Get

  let var_loc s =
    match bits 3 s with
      | 0 -> Stack (int s)
      | 1 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  Ext (cu,pos)
      | 2 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  External (cu,pos)
      | 3 -> Env (int s)
      | 4 -> Dummy
      | _ -> assert false

  let rec expr s =
    match bits nbits s with
      | 0 -> Var (var_loc s)
      | 1 ->
	  let recurs = bool s in
	  let e1 = expr s in
	  let e2 = expr s in
	  Apply (recurs,e1,e2)
      | 2 ->
	  let slots = array var_loc s in
	  let iface = list (pair Types.deserialize Types.deserialize) s in
	  let brs = branches s in
	  Abstraction (slots,iface,brs)
      | 3 -> Const (Types.Const.deserialize s)
      | 4 ->
	  let e1 = expr s in
	  let e2 = expr s in
	  Pair (e1,e2)
      | 5 ->
	  let e1 = expr s in
	  let e2 = expr s in
	  let e3 = expr s in
	  Xml (e1,e2,e3)
      | 6 -> Record (LabelMap.deserialize expr s)
      | 7 -> 
	  let st = U.deserialize s in
	  let e = expr s in
	  String (U.start_index st, U.end_index st, st, e)
      | 8 ->
	  let e = expr s in
	  let brs = branches s in
	  Match (e,brs)
      | 9 ->
	  let e = expr s in
	  let brs = branches s in
	  Map (e,brs)
      | 10 ->
	  let e = expr s in
	  let brs = branches s in
	  Transform (e,brs)
      | 11 ->
	  let e = expr s in
	  let brs = branches s in
	  Xtrans (e,brs)
      | 12 ->
	  let e = expr s in
	  let brs = branches s in
	  Try (e,brs)
      | 13 -> 
	  let e = expr s in
	  let sch = string s in
	  let t = Ns.QName.deserialize s in
	  Validate (e,sch,t)
      | 14 ->
	  let e = expr s in
	  let l = LabelPool.deserialize s in
	  RemoveField (e,l)
      | 15 ->
	  let e = expr s in
	  let l = LabelPool.deserialize s in
	  Dot (e,l)
      | 18 ->
	  let e = expr s in
	  let t = Types.Node.deserialize s in
	  Ref (e,t)
      | 19 ->
	  let op = string s in
	  let args = list expr s in
	  Op (op,args)
      | 20 ->
	  let ns = Ns.deserialize_table s in
	  let e = expr s in
	  NsTable (ns,e)
      | 21 ->
	  let t0 = Types.deserialize s in
	  let e = expr s in
	  let t = Types.Node.deserialize s in
	  Check (t0,e,t)
      | _ -> assert false

  and branches s =
    let brs = list (pair Patterns.Node.deserialize expr) s in
    let tail = bool s in
    let input = Types.deserialize s in
    let accept_chars = bool s in
    { brs = brs; brs_tail = tail; brs_input = input; 
      brs_accept_chars = accept_chars;
      brs_compiled = None; brs_compiled2 = None
    }

  let code_item s =
    match bits 2 s with
      | 0 -> Push (expr s)
      | 1 -> Pop
      | 2 -> Split (Patterns.Node.deserialize s)
      | 3 -> 
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  SetGlobal (cu,pos)
      | _ -> assert false

  let codes = list code_item

  let compunit s =
    magic s magic_compunit;
    codes s

end