Commit 3c4ae863 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-26 01:35:24 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 01:35:24+00:00
parent b95f6802
......@@ -70,6 +70,29 @@ let rec print_exn ppf = function
| exn ->
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
let debug = function
| `Filter (t,p) ->
Format.fprintf ppf "[DEBUG:filter]@\n";
let t = Typer.typ t
and p = Typer.pat p in
let f = Patterns.filter (Types.descr t) p in
List.iter (fun (x,t) ->
Format.fprintf ppf " x:%a@\n"
print_norm (Types.descr t)) f
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@\n";
let p = Typer.pat p in
let t = Patterns.accept p in
Format.fprintf ppf " %a@\n" Types.Print.print t
| `Compile (t,pl) ->
Format.fprintf ppf "[DEBUG:compile]@\n";
let t = Typer.typ t
and pl = List.map Typer.pat pl in
let pl = Array.of_list
(List.map (fun p -> Patterns.Compile.normal
(Patterns.descr p)) pl) in
Patterns.Compile.show ppf (Types.descr t) pl
| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
......@@ -77,6 +100,7 @@ let phrase ph =
let t = Typer.type_check Typer.Env.empty e Types.any true in
Format.fprintf ppf "%a@\n" print_norm t
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug l
| _ -> assert false
let () =
......
......@@ -11,7 +11,12 @@ and pmodule_item' =
| FunDecl of abstr
| LetDecl of ppat * pexpr
| EvalStatement of pexpr
| Debug of string * ([`Pat of ppat | `Expr of pexpr] list)
| Debug of debug_directive
and debug_directive =
[ `Filter of ppat * ppat
| `Accept of ppat
| `Compile of ppat * ppat list ]
and pexpr = pexpr' located
and pexpr' =
......
......@@ -43,7 +43,16 @@ EXTEND
phrase: [
[ e = expr -> EvalStatement e
| "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
| "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
| "debug"; d = debug_directive -> Debug d
]
];
debug_directive: [
[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| LIDENT "accept"; p = pat -> `Accept p;
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
]
];
expr: [
......
......@@ -4,5 +4,8 @@ let types =
"Any", Types.any;
"Int", Types.Int.any;
"Char", Types.char Chars.any;
"Atom", Types.atom Atoms.any
"Atom", Types.atom Atoms.any;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
];
......@@ -79,5 +79,6 @@ let print =
then fun ppf ->
Unichar.print ppf a
else fun ppf ->
if a = 0 && b = max_char then Format.fprintf ppf "Char" else
Format.fprintf ppf "%a--%a" Unichar.print a Unichar.print b
)
......@@ -67,7 +67,7 @@ let rec iadd_bounded l a b = match l with
iadd_bounded l' (min_big_int a a1) (max_big_int b b1)
| Left b1 :: l' ->
iadd_left l' b
| Right a1 :: _ -> [Right a]
| Right a1 :: _ -> [Right (min_big_int a a1)]
| Any :: _ -> any
let rec iadd_right l a = match l with
......
This diff is collapsed.
......@@ -34,16 +34,10 @@ val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
(* Pattern matching: compilation *)
module NF : sig
type nf
type normal
val nf : descr -> nf
val normal : nf -> normal
module Disp : sig
val show : Format.formatter -> Types.descr -> normal array -> unit
end
(*
val show : Format.formatter -> Types.descr -> nf list -> unit
val get : int -> Types.descr * normal list
*)
module Compile: sig
type normal
val normal : descr -> normal
type dispatcher
val show : Format.formatter -> Types.descr -> normal array -> unit
end
......@@ -638,10 +638,10 @@ struct
print_union ppf
(Intervals.print d.ints @
Chars.print d.chars @
Atoms.print "AnyAtom" print_atom d.atoms @
Boolean.print "(Any,Any)" print_times d.times @
Boolean.print "(Empty -> Any)" print_arrow d.arrow @
Boolean.print "{ }" print_record d.record
Atoms.print "Atom" print_atom d.atoms @
Boolean.print "Pair" print_times d.times @
Boolean.print "Arrow" print_arrow d.arrow @
Boolean.print "Record" print_record d.record
)
and print_times ppf (t1,t2) =
Format.fprintf ppf "@[(%a,%a)@]" print t1 print t2
......
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