summaryrefslogtreecommitdiff
path: root/dev/ocamlweb-doc/parse.ml
diff options
context:
space:
mode:
authorGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:02:20 +0100
committerGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:02:20 +0100
commit97fefe1fcca363a1317e066e7f4b99b9c1e9987b (patch)
tree97ec6b7d831cc5fb66328b0c63a11db1cbb2f158 /dev/ocamlweb-doc/parse.ml
parent300293c119981054c95182a90c829058530a6b6f (diff)
Imported Upstream version 8.4~betaupstream/8.4_beta
Diffstat (limited to 'dev/ocamlweb-doc/parse.ml')
-rw-r--r--dev/ocamlweb-doc/parse.ml183
1 files changed, 0 insertions, 183 deletions
diff --git a/dev/ocamlweb-doc/parse.ml b/dev/ocamlweb-doc/parse.ml
deleted file mode 100644
index b145fffd..00000000
--- a/dev/ocamlweb-doc/parse.ml
+++ /dev/null
@@ -1,183 +0,0 @@
-
-open Ast
-
-type assoc = L | R | N
-
-let level = function
- | "--" -> 70,L
- | "=" -> 70,N
- | "+" -> 60,L
- | "++" -> 60,R
- | "+++" -> 60,R
- | "-" -> 60,L
- | "*" -> 50,L
- | "/" -> 50,L
- | "**" -> 40,R
- | ":" -> (100,R)
- | "->" -> (90,R)
- | s -> failwith ("unknowm operator '"^s^"'")
-
-let fixity = function
- | "--" -> [L]
- | "=" -> [N]
- | ("+"|"-"|"*"|"/") -> [L;N]
- | "++" -> [R]
- | _ -> [L;N;R]
-
-let ground_oper = function
- ("-"|"+") -> true
- | _ -> false
-
-let is_prefix op = List.mem L (fixity op)
-let is_infix op = List.mem N (fixity op)
-let is_postfix op = List.mem R (fixity op)
-
-let mk_inf op t1 t2 =
- if not (is_infix op) then failwith (op^" not infix");
- Infix(op,t1,t2)
-
-let mk_post op t =
- if not (is_postfix op) then failwith (op^" not postfix");
- Postfix(op,t)
-
-
-(* Pb avec ground_oper: pas de diff entre -1 et -(1) *)
-let mk_pre op t =
- if not (is_prefix op) then failwith (op^" not prefix");
- if ground_oper op then
- match t with
- | Int i -> Int (op^i)
- | _ -> Prefix(op,t)
- else Prefix(op,t)
-
-(* teste si on peut reduire op suivi d'un op de niveau (n,a)
- si la reponse est false, c'est que l'op (n,a) doit se reduire
- avant *)
-let red_left_op (nl,al) (nr,ar) =
- if nl < nr then true
- else
- if nl = nr then
- match al,ar with
- | (L|N), L -> true
- | R, (R|N) -> false
- | R, L -> failwith "conflit d'assoc: ambigu"
- | (L|N), (R|N) -> failwith "conflit d'assoc: blocage"
- else false
-
-
-type level = int * assoc
-type stack =
- | PrefixOper of string list
- | Term of constr_ast * stack
- | Oper of string list * string * constr_ast * stack
-
-let rec str_ast = function
- | Infix(op,t1,t2) -> str_ast t1 ^ " " ^ op ^ " " ^ str_ast t2
- | Postfix(op,t) -> str_ast t ^ " " ^ op
- | Prefix(op,t) -> op ^ " " ^ str_ast t
- | _ -> "_"
-
-let rec str_stack = function
- | PrefixOper ops -> String.concat " " (List.rev ops)
- | Term (t,s) -> str_stack s ^ " (" ^ str_ast t ^ ")"
- | Oper(ops,lop,t,s) ->
- str_stack (Term(t,s)) ^ " " ^ lop ^ " " ^
- String.concat " " (List.rev ops)
-
-let pps s = prerr_endline (str_stack s)
-let err s stk = failwith (s^": "^str_stack stk)
-
-
-let empty = PrefixOper []
-
-let check_fixity_term stk =
- match stk with
- Term _ -> err "2 termes successifs" stk
- | _ -> ()
-
-let shift_term t stk =
- check_fixity_term stk;
- Term(t,stk)
-
-let shift_oper op stk =
- match stk with
- | Oper(ops,lop,t,s) -> Oper(op::ops,lop,t,s)
- | Term(t,s) -> Oper([],op,t,s)
- | PrefixOper ops -> PrefixOper (op::ops)
-
-let is_reducible lv stk =
- match stk with
- | Oper([],iop,_,_) -> red_left_op (level iop) lv
- | Oper(op::_,_,_,_) -> red_left_op (level op) lv
- | PrefixOper(op::_) -> red_left_op (level op) lv
- | _ -> false
-
-let reduce_head (t,stk) =
- match stk with
- | Oper([],iop,t1,s) ->
- (Infix(iop,t1,t), s)
- | Oper(op::ops,lop,t',s) ->
- (mk_pre op t, Oper(ops,lop,t',s))
- | PrefixOper(op::ops) ->
- (Prefix(op,t), PrefixOper ops)
- | _ -> assert false
-
-let rec reduce_level lv (t,s) =
- if is_reducible lv s then reduce_level lv (reduce_head (t, s))
- else (t, s)
-
-let reduce_post op (t,s) =
- let (t',s') = reduce_level (level op) (t,s) in
- (mk_post op t', s')
-
-let reduce_posts stk =
- match stk with
- Oper(ops,iop,t,s) ->
- let pts1 = reduce_post iop (t,s) in
- List.fold_right reduce_post ops pts1
- | Term(t,s) -> (t,s)
- | PrefixOper _ -> failwith "reduce_posts"
-
-
-let shift_infix op stk =
- let (t,s) = reduce_level (level op) (reduce_posts stk) in
- Oper([],op,t,s)
-
-let is_better_infix op stk =
- match stk with
- | Oper(ops,iop,t,s) ->
- is_postfix iop &&
- List.for_all is_postfix ops &&
- (not (is_prefix op) || red_left_op (level iop) (level op))
- | Term _ -> false
- | _ -> assert false
-
-let parse_oper op stk =
- match stk with
- | PrefixOper _ ->
- if is_prefix op then shift_oper op stk else failwith "prefix_oper"
- | Oper _ ->
- if is_infix op then
- if is_better_infix op stk then shift_infix op stk
- else shift_oper op stk
- else if is_prefix op then shift_oper op stk
- else if is_postfix op then
- let (t,s) = reduce_post op (reduce_posts stk) in
- Term(t,s)
- else assert false
- | Term(t,s) ->
- if is_infix op then shift_infix op stk
- else if is_postfix op then
- let (t2,s2) = reduce_post op (t,s) in Term(t2,s2)
- else failwith "infix/postfix"
-
-let parse_term = shift_term
-
-let rec close_stack stk =
- match stk with
- Term(t,PrefixOper []) -> t
- | PrefixOper _ -> failwith "expression sans atomes"
- | _ ->
- let (t,s) = reduce_head (reduce_posts stk) in
- close_stack (Term(t,s))
-