Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
5d2625ae
Commit
5d2625ae
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-23 11:34:36 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-23 11:34:37+00:00
parent
7bab897a
Changes
6
Hide whitespace changes
Inline
Side-by-side
parser/ast.ml
View file @
5d2625ae
...
...
@@ -86,3 +86,66 @@ and regexp =
|
WeakStar
of
regexp
|
SeqCapture
of
id
*
regexp
let
rec
equal_ppat
p1
p2
=
let
p1
=
p1
.
descr
and
p2
=
p2
.
descr
in
(
p1
==
p2
)
||
match
(
p1
,
p2
)
with
|
PatVar
x1
,
PatVar
x2
->
x1
=
x2
|
Internal
x1
,
Internal
x2
->
Types
.
equal_descr
x1
x2
|
Or
(
x1
,
y1
)
,
Or
(
x2
,
y2
)
|
And
(
x1
,
y1
)
,
And
(
x2
,
y2
)
|
Diff
(
x1
,
y1
)
,
Diff
(
x2
,
y2
)
|
Prod
(
x1
,
y1
)
,
Prod
(
x2
,
y2
)
|
XmlT
(
x1
,
y1
)
,
XmlT
(
x2
,
y2
)
|
Arrow
(
x1
,
y1
)
,
Arrow
(
x2
,
y2
)
->
(
equal_ppat
x1
x2
)
&&
(
equal_ppat
y1
y2
)
|
Optional
x1
,
Optional
x2
->
equal_ppat
x1
x2
|
Record
(
o1
,
r1
)
,
Record
(
o2
,
r2
)
->
(
o1
==
o2
)
&&
(
LabelMap
.
equal
equal_ppat
r1
r2
)
|
Capture
x1
,
Capture
x2
->
x1
==
x2
|
Constant
(
x1
,
y1
)
,
Constant
(
x2
,
y2
)
->
(
x1
==
x2
)
&&
(
Types
.
equal_const
y1
y2
)
|
Regexp
(
x1
,
y1
)
,
Regexp
(
x2
,
y2
)
->
(
equal_regexp
x1
x2
)
&&
(
equal_ppat
y1
y2
)
(* todo: Recurs *)
|
_
->
false
and
equal_regexp
r1
r2
=
(
r1
==
r2
)
||
match
(
r1
,
r2
)
with
|
Elem
x1
,
Elem
x2
->
equal_ppat
x1
x2
|
Seq
(
x1
,
y1
)
,
Seq
(
x2
,
y2
)
|
Alt
(
x1
,
y1
)
,
Alt
(
x2
,
y2
)
->
(
equal_regexp
x1
x2
)
&&
(
equal_regexp
y1
y2
)
|
Star
x1
,
Star
x2
|
WeakStar
x1
,
WeakStar
x2
->
equal_regexp
x1
x2
|
SeqCapture
(
x1
,
y1
)
,
SeqCapture
(
x2
,
y2
)
->
(
x1
==
x2
)
&&
(
equal_regexp
y1
y2
)
|
_
->
false
let
rec
hash_ppat
p
=
match
p
.
descr
with
|
PatVar
x
->
1
+
17
*
(
Hashtbl
.
hash
x
)
|
Internal
x
->
2
+
17
*
(
Types
.
hash_descr
x
)
|
Or
(
x
,
y
)
->
3
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
And
(
x
,
y
)
->
4
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
Diff
(
x
,
y
)
->
5
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
Prod
(
x
,
y
)
->
6
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
XmlT
(
x
,
y
)
->
7
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
Arrow
(
x
,
y
)
->
8
+
17
*
(
hash_ppat
x
)
+
257
*
(
hash_ppat
y
)
|
Optional
x
->
9
+
17
*
(
hash_ppat
x
)
|
Record
(
o
,
r
)
->
(
if
o
then
10
else
11
)
+
(
LabelMap
.
hash
hash_ppat
r
)
|
Capture
x
->
12
+
17
*
(
Id
.
hash
x
)
|
Constant
(
x
,
y
)
->
13
+
17
*
(
Id
.
hash
x
)
+
257
*
(
Types
.
hash_const
y
)
|
Regexp
(
x
,
y
)
->
14
+
17
*
(
hash_regexp
x
)
+
16637
*
(
hash_ppat
y
)
|
Recurs
(
x
,
l
)
->
15
+
17
*
(
hash_ppat
x
)
(* todo: hash l *)
and
hash_regexp
=
function
|
Epsilon
->
1
|
Elem
x
->
2
+
17
*
(
hash_ppat
x
)
|
Seq
(
x
,
y
)
->
3
+
17
*
(
hash_regexp
x
)
+
257
*
(
hash_regexp
y
)
|
Alt
(
x
,
y
)
->
4
+
17
*
(
hash_regexp
x
)
+
257
*
(
hash_regexp
y
)
|
Star
x
->
5
+
17
*
(
hash_regexp
x
)
|
WeakStar
x
->
6
+
17
*
(
hash_regexp
x
)
|
SeqCapture
(
x
,
y
)
->
7
+
17
*
(
Id
.
hash
x
)
+
257
*
(
hash_regexp
y
)
types/sortedList.ml
View file @
5d2625ae
...
...
@@ -84,6 +84,7 @@ sig
val
compare
:
(
'
b
->
'
b
->
int
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
int
val
hash
:
(
'
b
->
int
)
->
(
'
a
,
'
b
)
map
->
int
val
equal
:
(
'
b
->
'
b
->
bool
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
bool
end
end
...
...
@@ -386,6 +387,14 @@ module Map = struct
let
rec
hash
f
=
function
|
[]
->
1
|
(
x
,
y
)
::
l
->
X
.
hash
x
+
17
*
(
f
y
)
+
257
*
(
hash
f
l
)
let
rec
equal
f
l1
l2
=
(
l1
==
l2
)
||
match
(
l1
,
l2
)
with
|
(
x1
,
y1
)
::
l1
,
(
x2
,
y2
)
::
l2
->
(
X
.
equal
x1
x2
)
&&
(
f
y1
y2
)
&&
(
equal
f
l1
l2
)
|
_
->
false
end
end
...
...
types/sortedList.mli
View file @
5d2625ae
...
...
@@ -80,6 +80,7 @@ sig
val
assoc_present
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
'
b
val
compare
:
(
'
b
->
'
b
->
int
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
int
val
hash
:
(
'
b
->
int
)
->
(
'
a
,
'
b
)
map
->
int
val
equal
:
(
'
b
->
'
b
->
bool
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
bool
end
end
...
...
types/types.ml
View file @
5d2625ae
...
...
@@ -44,6 +44,8 @@ let hash_const = function
|
Atom
x
->
Atoms
.
vhash
x
|
Char
x
->
Chars
.
vhash
x
let
equal_const
c1
c2
=
compare_const
c1
c2
=
0
type
pair_kind
=
[
`Normal
|
`XML
]
type
'
a
node0
=
{
id
:
int
;
mutable
descr
:
'
a
}
...
...
types/types.mli
View file @
5d2625ae
...
...
@@ -6,6 +6,7 @@ type const = | Integer of Intervals.v
val
compare_const
:
const
->
const
->
int
val
hash_const
:
const
->
int
val
equal_const
:
const
->
const
->
bool
(** Algebra **)
...
...
typing/typer.ml
View file @
5d2625ae
(* TODO:
rewrite type-checking of operators to propagate constraint *)
- rewrite type-checking of operators to propagate constraint
- rewrite translation of types and patterns -> hash cons
*)
(* I. Transform the abstract syntax of types and patterns into
the internal form *)
...
...
@@ -165,65 +168,6 @@ module Regexp = struct
defs
:=
(
n
,
d
)
::
!
defs
;
v
(*
type trans = [ `Alt of gnode * gnode | `Elem of Ast.ppat * gnode | `Final ]
and gnode =
{
mutable seen : bool;
mutable compile : bool;
name : string;
mutable trans : trans;
}
let new_node() = { seen = false; compile = false;
name = name(); trans = `Final }
let to_compile = ref []
let rec compile after = function
| `Epsilon -> after
| `Elem (_,p) ->
if not after.compile then (after.compile <- true;
to_compile := after :: !to_compile);
{ new_node () with trans = `Elem (p, after) }
| `Seq(r1,r2) -> compile (compile after r2) r1
| `Alt(r1,r2) ->
let r1 = compile after r1 and r2 = compile after r2 in
{ new_node () with trans = `Alt (r1,r2) }
| `Star r ->
let n = new_node() in
n.trans <- `Alt (compile n r, after);
n
| `WeakStar r ->
let n = new_node() in
n.trans <- `Alt (after, compile n r);
n
let seens = ref []
let rec collect_aux accu n =
if n.seen then accu
else ( seens := n :: !seens;
match n.trans with
| `Alt (n1,n2) -> collect_aux (collect_aux accu n2) n1
| _ -> n :: accu
)
let collect fin n =
let l = collect_aux [] n in
List.iter (fun n -> n.seen <- false) !seens;
let l = List.map (fun n ->
match n.trans with
| `Final -> fin
| `Elem (p,a) ->
mk !re_loc (Prod(p, mk !re_loc (PatVar a.name)))
| _ -> assert false
) l in
match l with
| h::t ->
List.fold_left (fun accu p -> mk !re_loc (Or (accu,p))) h t
| _ -> assert false
*)
let
constant_nil
t
v
=
mk_loc
!
re_loc
(
And
(
t
,
(
mk_loc
!
re_loc
(
Constant
(
v
,
Types
.
Atom
Sequence
.
nil_atom
)))))
...
...
@@ -237,15 +181,29 @@ module Regexp = struct
memo
:=
Memo
.
empty
;
let
d
=
!
defs
in
defs
:=
[]
;
mk_loc
!
re_loc
(
Recurs
(
n
,
d
))
(*
let after = new_node() in
let n = collect queue (compile after re) in
let d = List.map (fun n -> (n.name, collect queue n)) !to_compile in
to_compile := [];
*)
module
H
=
Hashtbl
.
Make
(
struct
type
t
=
Ast
.
regexp
*
Ast
.
ppat
let
equal
(
r1
,
p1
)
(
r2
,
p2
)
=
(
Ast
.
equal_regexp
r1
r2
)
&&
(
Ast
.
equal_ppat
p1
p2
)
let
hash
(
r
,
p
)
=
(
Ast
.
hash_regexp
r
)
+
16637
*
(
Ast
.
hash_ppat
p
)
end
)
let
hash
=
H
.
create
67
mk_loc
!
re_loc
(
Recurs
(
n
,
d
))
let
compile
loc
regexp
queue
:
ppat
=
try
let
c
=
H
.
find
hash
(
regexp
,
queue
)
in
(* Printf.eprintf "regexp cached\n"; flush stderr; *)
c
with
Not_found
->
let
c
=
compile
loc
regexp
queue
in
H
.
add
hash
(
regexp
,
queue
)
c
;
c
end
let
compile_regexp
=
Regexp
.
compile
noloc
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment