Commit 155d0e52 authored by Giuseppe Castagna's avatar Giuseppe Castagna

Merge branch 'master' of https://git.cduce.org/cduce

parents b5cae60a 6d5a5fb7
......@@ -370,8 +370,8 @@ let rec collect_funs accu = function
| rest -> (List.rev accu,rest)
let rec collect_types accu = function
| { descr = Ast.TypeDecl ((loc,x),t) } :: rest ->
collect_types ((loc,x,t) :: accu) rest
| { descr = Ast.TypeDecl (x,pl,t) } :: rest ->
collect_types ((x,pl,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases ~run ~show ~directive =
......@@ -380,7 +380,7 @@ let rec phrases ~run ~show ~directive =
| { descr = Ast.FunDecl _ } :: _ ->
let (funs,rest) = collect_funs [] phs in
loop (let_funs ~run ~show accu funs) rest
| { descr = Ast.TypeDecl (_,_) } :: _ ->
| { descr = Ast.TypeDecl (_,_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in
loop (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
......
open Cduce_loc
open Ident
exception InconsistentCrc of U.t
exception InvalidObject of string
exception CannotOpen of string
......@@ -23,13 +22,11 @@ type t = {
mutable exts: Value.t array;
mutable depends: (U.t * string) list;
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
}
let digest c = match c.digest with None -> assert false | Some x -> x
module Tbl = Hashtbl.Make(U)
let tbl = Tbl.create 64
......@@ -117,7 +114,6 @@ let set_hash c =
Compunit.set_hash c.descr (succ max_rank) h
(* This invalidates all hash tables on types ! *)
let compile_save verbose name src out =
protect_op "Save compilation unit";
......
......@@ -5,11 +5,14 @@ open Ident
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
(* located ident *)
type lident = (Cduce_loc.loc * U.t)
type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of (Cduce_loc.loc * U.t) * ppat
| TypeDecl of (lident * U.t list * ppat)
| SchemaDecl of U.t * string
| LetDecl of ppat * pexpr
| FunDecl of pexpr
......@@ -86,17 +89,9 @@ and pexpr =
and label = U.t
and abstr = {
fun_name : (Cduce_loc.loc * U.t) option;
fun_name : lident option;
fun_iface : (ppat * ppat) list;
fun_body : branches
(* add deco : (sigma) symbolic representation of set type substitutions *)
(* plus a flag that is true if interesection of the free varbialbes of S that are not intruduced
* by the lambda astractions are domain of sigma.
* if oldvar(S) ^ dom(sigma) = empty then s < t else s[eval(sigma, env)] < t
* (biginter_{sigma_i \in eval} s (sigma_i) ) < t
*
* see Evaluation, section 5.3 Article part 1
* *)
}
and branches = (ppat * pexpr) list
......@@ -105,10 +100,10 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of U.t list
| PatVar of (U.t list * ppat list)
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (Cduce_loc.loc * U.t * ppat) list
| Recurs of ppat * (lident * U.t list * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
......@@ -131,8 +126,7 @@ and regexp =
| Alt of regexp * regexp
| Star of regexp
| WeakStar of regexp
| SeqCapture of Cduce_loc.loc * U.t * regexp
| SeqCapture of lident * regexp
let pat_true = mknoloc (Internal Builtin_defs.true_type)
let pat_false = mknoloc (Internal Builtin_defs.false_type)
......
This diff is collapsed.
......@@ -51,6 +51,7 @@ type token =
| CHAR of string
| STRING of string
| STRING2 of string
| PVAR of string
| PTYPE of string
| EOI
......@@ -71,6 +72,7 @@ module Token = struct
| STRING s -> sf "STRING \"%s\"" s
| STRING2 s -> sf "STRING \'%s\'" s
(* here it's not %S since the string is already escaped *)
| PVAR s -> sf "PVAR \'%S\'" s
| PTYPE s -> sf "PTYPE \'%S\'" s
| ANY_IN_NS s -> sf "ANY_IN_NS %S" s
| EOI -> sf "EOI"
......@@ -84,7 +86,7 @@ module Token = struct
let extract_string =
function
| KEYWORD s | IDENT s | INT s | CHAR s | STRING s | STRING2 s | PTYPE s |
| PTYPE s | KEYWORD s | IDENT s | INT s | CHAR s | STRING s | STRING2 s | PVAR s |
ANY_IN_NS s -> s
| tok ->
invalid_arg ("Cannot extract a string from this token: "^
......@@ -178,7 +180,6 @@ let parse_char lexbuf base i =
done;
!r
let regexp ncname_char =
xml_letter | xml_digit | [ '-' '_' ] | xml_combining_char | xml_extender | "\\."
let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+)
......@@ -203,6 +204,9 @@ let return_loc i j tok = (tok, (i,j))
let rec token = lexer
| xml_blank+ -> token lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -239,7 +243,7 @@ let rec token = lexer
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......@@ -257,6 +261,9 @@ let rec token = lexer
and token2 = lexer
| xml_blank+ -> token2 lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -300,11 +307,11 @@ and token2 = lexer
(try String.index s '\t' with _ -> len))
(try String.index s ')' with _ -> len) in
let s = String.sub s 0 idend in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......@@ -322,6 +329,9 @@ and token2 = lexer
and token2toplevel = lexer
| xml_blank+ -> token2toplevel lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -365,11 +375,11 @@ and token2toplevel = lexer
(try String.index s '\t' with _ -> len))
(try String.index s ')' with _ -> len) in
let s = String.sub s 0 idend in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......
......@@ -8,6 +8,7 @@ type token =
| CHAR of string
| STRING of string
| STRING2 of string
| PVAR of string
| PTYPE of string
| EOI
......
......@@ -171,7 +171,7 @@ let load_schema schema_name uri =
let schema_name = schema_name ^ "." in
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global schema_name name cd_type;
Types.Print.register_global (schema_name,name,[||]) cd_type;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
......
type t( 'a ) = [ 'a* ]
let length (l : t( 'a ) ) : Int =
let aux (l : ['a*])(res : Int) : Int = match l with
| [] -> res
| [_; rest] -> aux rest (res + 1) in
aux l 0
let hd (['a+] -> 'a) [el _*] -> el
let tl (t( 'a ) -> ['a*])
| [] -> []
| [_; rest] -> rest
let nth (l : t( 'a ))(n : Int) : 'a =
let aux (l : ['a*])(n : Int) : 'a = match l with
| [] -> raise "Failure \"List.nth\""
| [el; rest] -> if n >> 0 then aux rest (n - 1) else el in
if n << 0 then raise "Invalid_argument \"List.nth\"" else aux l n
let rev (l : t( 'a )) : t( 'a ) =
let aux (l : ['a*])(res : t('a)) : ['a*] = match l with
| [] -> res
| [el; rest] -> aux rest ([el] @ res) in
aux l []
let append (l1 : t( 'a ))(l2 : t( 'a )) : t( 'a ) = l1 @ l2
let rev_append (l1 : t( 'a ))(l2 : t( 'a )) : t( 'a ) = (rev l1) @ l2
let concat (l : [(t( 'a ))*]) : t( 'a ) =
let aux (l : [(t( 'a ))*])(res : t( 'a )) : t( 'a ) = match l with
| [] -> res
| [el; rest] -> aux rest (res @ el) in
aux l []
let flatten = concat
(* Iterators *)
let iter (f : ('a -> []))(l : t( 'a )) : [] = match l with
| [] -> []
| [el; rest] -> f el; iter f rest
let iteri (f : (Int -> 'a -> []))(l : t( 'a )) : [] =
let aux (f : (Int -> 'a -> []))(l : t( 'a ))(pos : Int) : [] = match l with
| [] -> []
| [el; rest] -> f pos el; aux f rest (pos + 1)
in
aux f l 0
let mapf (f : 'a -> 'b)(l : t( 'a )) : t( 'b ) =
let aux (f : 'a -> 'b)(l : t( 'a ))(acc : t( 'b )) : t( 'b ) = match l with
| [] -> acc
| [el; rest] -> aux f rest (acc @ [(f el)]) in
aux f l []
let mapi (f : Int -> 'a -> 'b)(l : t( 'a )) : t( 'b ) =
let aux (f : Int -> 'a -> 'b)(l : t( 'a ))(pos : Int)(acc : t( 'b )) : t( 'b ) =
match l with
| [] -> acc
| [el; rest] -> aux f rest (pos + 1) (acc @ [(f pos el)]) in
aux f l 0 []
let rev_map (f : 'a -> 'b)(l : t( 'a )) : t( 'b ) = rev (mapf f l)
(* List scanning *)
include "list.cd"
include "list-par.cd"
let nb_success = ref Int (0)
let nb_tests = ref Int (0)
......
......@@ -165,7 +165,7 @@ OCAMLDIR=$ROOT/ocaml
MAKECONF=$ROOT/../Makefile.conf
WITHOCAML=false
test -f $MAKECONF && WITHOCAML=`cat $MAKECONF | grep ML_INTERFACE | cut -d '=' -f 2`
test -f $MAKECONF && WITHOCAML=`cat $MAKECONF | grep "ML_INTERFACE=" | cut -d '=' -f 2`
if test $WITHOCAML = "true"; then
......
......@@ -32,7 +32,7 @@ let env =
List.fold_left
(fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global "" n t;
Types.Print.register_global ("",n,[||]) t;
Typer.enter_type (Ident.ident n) t accu
)
Typer.empty_env
......
This diff is collapsed.
......@@ -165,6 +165,7 @@ module Positive : sig
val xml: v -> v -> v
val substitute : t -> (Var.var * t) -> t
val substitute_list : t -> (Var.var * t) list -> t
val substituterec : t -> Var.var -> t
val solve: v -> Node.t
val substitutefree : Var.Set.t -> t -> t
......@@ -329,9 +330,9 @@ val cond_partition: t -> (t * t) list -> t list
The result is a partition of the first argument which is precise enough
to answer all the questions. *)
module Print :
sig
val register_global : string -> Ns.QName.t -> t -> unit
module Print : sig
type gname = string * Ns.QName.t * t array
val register_global : gname -> t -> unit
val pp_const : Format.formatter -> const -> unit
val pp_type: Format.formatter -> t -> unit
val pp_node: Format.formatter -> Node.t -> unit
......@@ -344,8 +345,7 @@ sig
val printf : t -> unit
end
module Service :
sig
module Service : sig
val to_service_params: t -> service_params
val to_string: service_params -> string
end
......
......@@ -37,7 +37,7 @@ type schema = {
type item =
(* These are really exported by CDuce units: *)
| Type of Types.t
| Type of (Types.t * Var.t array)
| Val of Types.t
| ECDuce of Compunit.t
| ESchema of schema
......@@ -58,7 +58,11 @@ type t = {
let pp_env ppf env =
let pp_item ppf (s,t) = match t with
|Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
|Type t -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_type t
|Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
|Type (t,al) ->
Format.fprintf ppf "type %s(%a) = %a" s
(Utils.pp_list ~delim:("","") Var.pp) (Array.to_list al)
Types.Print.pp_noname t
|_ -> ()
in
let t = [
......@@ -141,10 +145,13 @@ let type_using env loc x cu =
with Not_found ->
error loc ("Cannot find external unit " ^ (U.to_string cu))
let enter_type id t env = enter_id id (Type t) env
let enter_type id t env = enter_id id (Type (t,[||])) env
let enter_types l env =
{ env with ids =
List.fold_left (fun accu (id,t) -> Env.add id (Type t) accu) env.ids l }
List.fold_left (fun accu (id,t,al) ->
Env.add id (Type (t,al)) accu
) env.ids l
}
let find_id env0 env loc head x =
let id = ident env0 loc x in
......@@ -185,9 +192,10 @@ let iter_values env f =
| _ -> ()) env.ids
let register_types cu env =
Env.iter (fun x t -> match t with
| Type t -> Types.Print.register_global cu (Ident.value x) t
| _ -> ()) env.ids
Env.iter (fun x -> function
| Type (t,_) -> Types.Print.register_global (cu,(Ident.value x),[||]) t
| _ -> ()
) env.ids
let rec const env loc = function
| LocatedExpr (loc,e) -> const env loc e
......@@ -216,10 +224,12 @@ let navig loc env0 (env,comp) id =
let env = !from_comp_unit cu in
let c =
try find_id env0 env loc false id
with Not_found -> error loc "Unbound identifier" in
with Not_found -> error loc "Unbound identifier"
in
let c = match c with
| Val t -> EVal (cu,ident env0 loc id,t)
| c -> c in
| c -> c
in
env,c
| EOCaml cu ->
let s = cu ^ "." ^ (U.get_str id) in
......@@ -261,7 +271,8 @@ let type_ns env loc p ns =
let find_global_type env loc ids =
match find_global env loc ids with
| Type t | ESchemaComponent (t,_) -> t
| Type (t,pargs) -> (t,pargs)
| ESchemaComponent (t,_) -> (t,[||]) (* XXX *)
| _ -> error loc "This path does not refer to a type"
let find_global_schema_component env loc ids =
......@@ -271,7 +282,7 @@ let find_global_schema_component env loc ids =
let find_local_type env loc id =
match Env.find id env.ids with
| Type t -> t
| Type (t,pargs) -> (t,pargs)
| _ -> raise Not_found
let find_value id env =
......@@ -365,33 +376,45 @@ module IType = struct
| Alt (p1,p2) -> mk_alt (derecurs_regexp env p1) (derecurs_regexp env p2)
| Star p -> mk_star (derecurs_regexp env p)
| WeakStar p -> mk_weakstar (derecurs_regexp env p)
| SeqCapture (loc,x,p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
| SeqCapture ((loc,x),p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
and derecurs_var env loc ids =
match ids with
| [v] ->
| ([v],a) ->
let v = ident env.penv_tenv loc v in
(try Env.find v env.penv_derec
with Not_found ->
try mk_type (find_local_type env.penv_tenv loc v)
with Not_found -> mk_capture v)
| ids ->
mk_type (find_global_type env.penv_tenv loc ids)
begin
try Env.find v env.penv_derec
with Not_found ->
try
let (t,pargs) = find_local_type env.penv_tenv loc v in
let palen = Array.length pargs in
if palen <> List.length a then
raise_loc_generic loc
(Printf.sprintf "Parametric type %s is not fully qualified" (Ident.to_string v));
let a = Array.of_list a in
let l = ref [] in
for i=0 to (Array.length pargs) - 1 do
l := (pargs.(i), typ(derecurs env a.(i)))::!l
done;
mk_type (Types.Positive.substitute_list t !l)
with Not_found -> mk_capture v
end
| (ids,_) ->
mk_type (fst(find_global_type env.penv_tenv loc ids))
and derecurs_def env b =
let seen = ref IdSet.empty in
let b =
List.map
(fun (loc,v,p) ->
List.map (fun ((loc,v),_,p) ->
let v = ident env.penv_tenv loc v in
if IdSet.mem !seen v then
raise_loc_generic loc
("Multiple definitions for the type identifer " ^
(Ident.to_string v));
seen := IdSet.add v !seen;
(v,p,delayed loc))
b in
(v,p,delayed loc)
) b
in
let n = List.fold_left (fun env (v,p,s) -> Env.add v s env) env.penv_derec b in
let env = { env with penv_derec = n } in
List.iter (fun (v,p,s) -> link s (derecurs env p)) b;
......@@ -424,14 +447,22 @@ module IType = struct
with Patterns.Error s -> raise_loc_generic loc s
in
let b =
List.map2
(fun (loc,v,p) (v',_,d) ->
let t = aux loc d in
if (loc <> noloc) && (Types.is_empty t) then
warning loc
("This definition yields an empty type for " ^ (U.to_string v));
(v',t)) b b' in
List.iter (fun (v,t) -> Types.Print.register_global "" v t) b;
List.map2 (fun ((loc,v),pl,p) (v',_,d) ->
let t = aux loc d in
if (loc <> noloc) && (Types.is_empty t) then
warning loc
("This definition yields an empty type for " ^ (U.to_string v));
let al =
let a = Array.make (List.length pl) (Var.mk "dummy")in
List.iteri (fun i v -> a.(i) <- Var.mk (Ident.U.to_string v)) pl;
a
in
(v',t,al)
) b b'
in
List.iter (fun (v,t,al) ->
Types.Print.register_global ("",v,Array.map Types.var al) t
) b;
enter_types b env
let type_defs env b =
......
......@@ -38,7 +38,8 @@ val type_keep_ns : t -> bool -> t
val type_expr: t -> Ast.pexpr -> Typed.texpr * Types.descr
val type_defs: t -> (Cduce_loc.loc * U.t * Ast.ppat) list -> t
(* val type_defs: t -> (Cduce_loc.loc * U.t * Ast.ppat) list -> t *)
val type_defs: t -> (Ast.lident * U.t list * Ast.ppat) list -> t
val type_let_decl: t -> Ast.ppat -> Ast.pexpr ->
t * Typed.let_decl * (id * Types.t) list
......
......@@ -90,7 +90,7 @@ let url_of_page (Page -> String)
| <page url=u ..>_ -> u
| <page name=n ..>_ -> n @ ".html"
let render(a : String)(p : {presenter=?"yes"|"no" ..}) : H.Flow =
let render (a : String)(p : {presenter=?"yes"|"no" ..}) : H.Flow =
match p with
| {presenter="yes" ..} -> [<strong class="ocaml">a]
| _ -> a
......@@ -126,9 +126,9 @@ let compute_sitemap ((Page|External) -> Tree)
| <external name=name href=h title>[] ->
{ name url=h title children=[] boxes=[] }
let ul([H.li*] -> [H.ul?]) [] -> [] | l -> [ <ul>l ]
let ul ([H.li*] -> [H.ul?]) [] -> [] | l -> [ <ul>l ]
let ol(([H.li*],{style=?String}) -> [H.ol?])
let ol (([H.li*],{style=?String}) -> [H.ol?])
| ([],_) -> []
| (l,s) -> [ <ol (s)>l ]
......@@ -160,15 +160,15 @@ let box (x : H.Flow) : H.Block = <div>[ !x ]
type PageO = Page | []
let button(title : String)(onclick : String) : H.Inline =
let button (title : String)(onclick : String) : H.Inline =
<input type="submit" style="font-size:8px;" value=title onclick=onclick>[]
let button_id(id : String)(title : String)(onclick : String)(style : String)
let button_id (id : String)(title : String)(onclick : String)(style : String)
: H.Inline =
<input type="submit" id=id
style=("font-size:8px;"@style) value=title
onclick=onclick>[]
let demo(no : Int)(name : String)(prefix : String)(txt : String) : H.Flow =
let demo (no : Int)(name : String)(prefix : String)(txt : String) : H.Flow =
let n = [ 'a' !name '_' ] in
let prefix = if prefix = "" then "" else [ 'a' !prefix '_' ] in
[ !(if (no = 1) then [<script src="demo.js" type="text/javascript">" "]
......@@ -203,12 +203,12 @@ let demo(no : Int)(name : String)(prefix : String)(txt : String) : H.Flow =
(* returns the last page of the descendance *)
let thumbnail(w : String, h : String)
let thumbnail (w : String, h : String)
(url : String)(title : String) : H.Inlines =
[ <a href=url>[
<img src=url width=w height=h alt="Click to enlarge" title=title>[] ] ]
let thumbwh({ width=?IntStr height=?IntStr ..} ->
let thumbwh ({ width=?IntStr height=?IntStr ..} ->
(String -> String ->H.Inlines))
| { width = w; height = h } ->
let w = int_of w in let h = int_of h in
......@@ -324,7 +324,7 @@ match page with
[ <ul>[ (display_sitemap sitemap) ] ]
| <local-links href=s>[] ->
ul (transform (split_comma s) with x ->
match local_link(sitemap,x,"") with [] -> [] | x -> [<li>x])
match local_link (sitemap,x,"") with [] -> [] | x -> [<li>x])
| <two-columns>[ <left>x <right>y ] ->
[ <table width="100%">[
<tr>[
......
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