diff options
Diffstat (limited to 'dev/doc/parse.ml')
-rw-r--r-- | dev/doc/parse.ml | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/dev/doc/parse.ml b/dev/doc/parse.ml new file mode 100644 index 00000000..e537b1f2 --- /dev/null +++ b/dev/doc/parse.ml @@ -0,0 +1,183 @@ + +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)) + |