Skip to content
GitLab
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
58c7c621
Commit
58c7c621
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-06-13 15:20:13 by afrisch] Simplifications
Original author: afrisch Date: 2005-06-13 15:20:14+00:00
parent
3cd1a52f
Changes
7
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
58c7c621
...
...
@@ -145,6 +145,7 @@ OBJECTS = \
misc/state.cmo misc/pool.cmo misc/encodings.cmo
\
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo
\
misc/html.cmo
\
misc/ptmap.cmo misc/hashset.cmo
\
\
types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo
\
types/intervals.cmo
\
...
...
depend
View file @
58c7c621
...
...
@@ -26,11 +26,13 @@ misc/imap.cmo: misc/imap.cmi
misc/imap.cmx: misc/imap.cmi
misc/html.cmo: misc/html.cmi
misc/html.cmx: misc/html.cmi
misc/ptmap.cmo: misc/ptmap.cmi
misc/ptmap.cmx: misc/ptmap.cmi
types/sortedList.cmo: misc/serialize.cmi misc/custom.cmo types/sortedList.cmi
types/sortedList.cmx: misc/serialize.cmx misc/custom.cmx types/sortedList.cmi
misc/bool.cmo:
types/sortedList
.cmi misc/
serialize
.cm
i
misc/custom.cmo \
misc/bool.cmo:
misc/serialize
.cmi misc/
hashset
.cm
o
misc/custom.cmo \
misc/bool.cmi
misc/bool.cmx:
types/sortedList
.cmx misc/
serialize
.cmx misc/custom.cmx \
misc/bool.cmx:
misc/serialize
.cmx misc/
hashset
.cmx misc/custom.cmx \
misc/bool.cmi
types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi
...
...
driver/cduce.ml
View file @
58c7c621
...
...
@@ -200,7 +200,7 @@ let debug ppf tenv cenv = function
Format
.
fprintf
ppf
"[DEBUG:compile]@."
;
let
t
=
Typer
.
typ
tenv
t
and
pl
=
List
.
map
(
Typer
.
pat
tenv
)
pl
in
Patterns
.
Compile
2
.
debug_compile
ppf
t
pl
;
Patterns
.
Compile
.
debug_compile
ppf
t
pl
;
Format
.
fprintf
ppf
"@."
;
(*
...
...
misc/bool.ml
View file @
58c7c621
This diff is collapsed.
Click to expand it.
misc/bool.mli
View file @
58c7c621
...
...
@@ -4,6 +4,7 @@ sig
type
elem
val
get
:
t
->
(
elem
list
*
elem
list
)
list
val
get'
:
t
->
(
elem
list
*
(
elem
list
)
list
)
list
val
empty
:
t
val
full
:
t
...
...
@@ -30,6 +31,7 @@ module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
module
Make
:
MAKE
(*
module type S' = sig
include S
type bdd = False | True | Br of elem * t * t
...
...
@@ -38,12 +40,10 @@ end
module MakeBdd(X : Custom.T) : S' with type elem = X.t
(*
module type S'' = sig
include S
type tree = Split of elem list * elem list * tree list option
val get_tree: t -> tree
val dnf: (elem list -> (elem list) list -> unit) -> t -> unit
end
module
Simplify
(X : Custom.T) : S'' with type elem = X.t
module
Make2
(X : Custom.T) : S'' with type elem = X.t
*)
types/patterns.ml
View file @
58c7c621
...
...
@@ -599,6 +599,8 @@ module Normal = struct
module
NodeSet
=
SortedList
.
Make
(
Node
)
module
Nnf
=
struct
include
Custom
.
Dummy
type
t
=
NodeSet
.
t
*
Types
.
t
*
IdSet
.
t
(* pl,t; t <= \accept{pl} *)
let
check
(
pl
,
t
,
xs
)
=
...
...
@@ -909,6 +911,13 @@ module Normal = struct
IdSet
.
empty
pl
let
factorize
t0
(
pl
,
t
,
xs
)
=
let
t0
=
if
Types
.
subtype
t
t0
then
t
else
Types
.
cap
t
t0
in
let
vs_var
=
facto
Factorize
.
var
t0
xs
pl
in
let
xs
=
IdSet
.
diff
xs
vs_var
in
let
vs_nil
=
facto
Factorize
.
nil
t0
xs
pl
in
(
vs_var
,
vs_nil
,
(
pl
,
t
,
xs
))
let
normal
f
l
t
pl
xs
=
let
a
=
nconstr
l
t
in
...
...
@@ -936,7 +945,7 @@ module Normal = struct
let
t
=
if
Types
.
subtype
t
t0
then
t
else
Types
.
cap
t
t0
in
(* let ppf = Format.std_formatter in
Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs); *)
Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs);
*)
normal
facto
lab
t
(
NodeSet
.
get
pl
)
xs
...
...
@@ -1000,7 +1009,7 @@ struct
and
dispatcher
=
{
id
:
int
;
t
:
Types
.
t
;
pl
:
Normal
.
t
array
;
pl
:
Normal
.
Nnf
.
t
array
;
label
:
label
option
;
interface
:
interface
;
codes
:
return_code
array
;
...
...
@@ -1112,10 +1121,10 @@ struct
let
cur_id
=
State
.
ref
"Patterns.cur_id"
0
(* TODO: save dispatchers ? *)
module
NfMap
=
Map
.
Make
(
Normal
)
module
NfSet
=
Set
.
Make
(
Normal
)
module
NfMap
=
Map
.
Make
(
Normal
.
Nnf
)
module
NfSet
=
Set
.
Make
(
Normal
.
Nnf
)
module
DispMap
=
Map
.
Make
(
Custom
.
Pair
(
Types
)(
Custom
.
Array
(
Normal
)))
module
DispMap
=
Map
.
Make
(
Custom
.
Pair
(
Types
)(
Custom
.
Array
(
Normal
.
Nnf
)))
(* Try with a hash-table ! *)
...
...
@@ -1136,7 +1145,7 @@ struct
let
ppf
=
Format
.
std_formatter
in
Format
.
fprintf
ppf
"Dispatcher t=%a@."
Types
.
Print
.
print
disp
.
t
;
Array
.
iter
(
fun
p
->
Format
.
fprintf
ppf
" pat %a@."
Normal
.
print
p
;
Format
.
fprintf
ppf
" pat %a@."
Normal
.
Nnf
.
print
p
;
)
disp
.
pl
let
dispatcher
t
pl
lab
:
dispatcher
=
...
...
@@ -1149,14 +1158,11 @@ struct
then
(
incr
nb
;
let
r
=
Array
.
of_list
(
List
.
rev
accu
)
in
codes
:=
(
t
,
arity
,
r
)
::!
codes
;
`Result
(
!
nb
-
1
))
else
let
p
=
pl
.
(
i
)
in
let
tp
=
p
.
Normal
.
na
in
let
(
_
,
tp
,
v
)
=
pl
.
(
i
)
in
let
a1
=
Types
.
cap
t
tp
in
if
Types
.
is_empty
a1
then
`Switch
(
`None
,
aux
t
arity
(
i
+
1
)
(
None
::
accu
))
else
let
v
=
p
.
Normal
.
nfv
in
let
a2
=
Types
.
diff
t
tp
in
let
accu'
=
Some
(
IdMap
.
num
arity
v
)
::
accu
in
if
Types
.
is_empty
a2
then
...
...
@@ -1243,9 +1249,9 @@ struct
|
(
l
,
r
)
->
Recompose
(
l
,
r
))
module
TypeList
=
SortedList
.
Make
(
Types
)
let
dispatch_basic
disp
:
(
Types
.
t
*
result
)
list
=
let
dispatch_basic
disp
pl
:
(
Types
.
t
*
result
)
list
=
(* TODO: try other algo, using disp.codes .... *)
let
pl
=
Array
.
map
(
fun
p
->
p
.
Normal
.
nbasic
)
disp
.
pl
in
let
pl
=
Array
.
map
(
fun
p
->
p
.
Normal
.
nbasic
)
pl
in
let
tests
=
let
accu
=
ref
[]
in
let
aux
i
(
res
,
x
)
=
accu
:=
(
x
,
[
i
,
res
])
::
!
accu
in
...
...
@@ -1280,24 +1286,31 @@ struct
let
get_tests
facto
pl
f
t
d
post
=
let
pl
=
Array
.
map
(
List
.
map
f
)
pl
in
let
lab
=
first_lab
t
pl
in
let
pl
=
Array
.
map
(
List
.
map
(
fun
(
x
,
info
)
->
Normal
.
nnf
facto
lab
t
x
,
info
))
pl
in
(* Collect all subrequests *)
let
aux
reqs
(
(
_
,_,
req
)
,_
)
=
NfSet
.
add
req
reqs
in
let
aux
reqs
(
req
,_
)
=
NfSet
.
add
req
reqs
in
let
reqs
=
Array
.
fold_left
(
List
.
fold_left
aux
)
NfSet
.
empty
pl
in
let
reqs
=
Array
.
of_list
(
NfSet
.
elements
reqs
)
in
(* Map subrequest -> idx in reqs *)
let
idx
=
ref
NfMap
.
empty
in
Array
.
iteri
(
fun
i
req
->
idx
:=
NfMap
.
add
req
i
!
idx
)
reqs
;
let
idx
=
!
idx
in
(* Build dispatcher *)
let
reqs_facto
=
if
facto
then
Array
.
map
(
Normal
.
factorize
t
)
reqs
else
Array
.
map
(
fun
r
->
[]
,
[]
,
r
)
reqs
in
let
reqs
=
Array
.
map
(
fun
(
_
,_,
req
)
->
req
)
reqs_facto
in
let
disp
=
dispatcher
t
reqs
lab
in
(* Build continuation *)
let
result
(
t
,
ar
,
m
)
=
let
get
a
((
vars
,
nils
,
req
)
,
info
)
=
match
m
.
(
NfMap
.
find
req
idx
)
with
Some
res
->
((
vars
,
nils
,
res
)
,
info
)
::
a
|
_
->
a
in
let
get
a
(
req
,
info
)
=
let
i
=
NfMap
.
find
req
idx
in
let
(
var
,
nil
,_
)
=
reqs_facto
.
(
i
)
in
match
m
.
(
i
)
with
Some
res
->
((
var
,
nil
,
res
)
,
info
)
::
a
|
_
->
a
in
let
pl
=
Array
.
map
(
List
.
fold_left
get
[]
)
pl
in
d
t
ar
pl
in
...
...
@@ -1310,8 +1323,9 @@ struct
let
t0
=
ref
t
in
let
aux
(
p
,
e
)
=
let
xs
=
fv
p
in
let
nnf
=
(
Normal
.
NodeSet
.
singleton
p
,
!
t0
,
xs
)
in
t0
:=
Types
.
diff
!
t0
(
Types
.
descr
(
accept
p
));
let
tp
=
Types
.
descr
(
accept
p
)
in
let
nnf
=
(
Normal
.
NodeSet
.
singleton
p
,
Types
.
cap
!
t0
tp
,
xs
)
in
t0
:=
Types
.
diff
!
t0
tp
;
[(
nnf
,
(
xs
,
e
))]
in
let
res
_
_
pl
=
let
aux
r
=
function
...
...
@@ -1324,12 +1338,12 @@ struct
get_tests
false
pl
(
fun
x
->
x
)
t
res
(
fun
x
->
x
)
let
rec
dispatch_prod
?
(
kind
=
`Normal
)
disp
=
let
rec
dispatch_prod
?
(
kind
=
`Normal
)
disp
pl
=
let
extr
=
match
kind
with
|
`Normal
->
fun
p
->
Normal
.
NLineProd
.
get
p
.
Normal
.
nprod
|
`XML
->
fun
p
->
Normal
.
NLineProd
.
get
p
.
Normal
.
nxml
in
let
t
=
Types
.
Product
.
get
~
kind
disp
.
t
in
dispatch_prod0
disp
t
(
Array
.
map
extr
disp
.
pl
)
dispatch_prod0
disp
t
(
Array
.
map
extr
pl
)
and
dispatch_prod0
disp
t
pl
=
get_tests
true
pl
(
fun
(
res
,
p
,
q
)
->
p
,
(
res
,
q
))
...
...
@@ -1348,7 +1362,7 @@ struct
return
disp
pl
aux_final
(
ar1
+
ar2
)
let
dispatch_record
disp
:
record
option
=
let
dispatch_record
disp
pl
:
record
option
=
let
t
=
disp
.
t
in
if
not
(
Types
.
Record
.
has_record
t
)
then
None
else
...
...
@@ -1360,7 +1374,7 @@ struct
let
pl
=
Array
.
map
(
fun
p
->
match
p
.
Normal
.
nrecord
with
|
Normal
.
RecNolabel
(
Some
x
,_
)
->
[
x
]
|
Normal
.
RecNolabel
(
None
,_
)
->
[]
|
_
->
assert
false
)
disp
.
pl
in
|
_
->
assert
false
)
pl
in
Some
(
return
disp
pl
(
IdMap
.
map_to_list
conv_source_basic
)
0
)
else
None
in
...
...
@@ -1369,7 +1383,7 @@ struct
let
pl
=
Array
.
map
(
fun
p
->
match
p
.
Normal
.
nrecord
with
|
Normal
.
RecNolabel
(
_
,
Some
x
)
->
[
x
]
|
Normal
.
RecNolabel
(
_
,
None
)
->
[]
|
_
->
assert
false
)
disp
.
pl
in
|
_
->
assert
false
)
pl
in
Some
(
return
disp
pl
(
IdMap
.
map_to_list
conv_source_basic
)
0
)
else
None
in
...
...
@@ -1379,7 +1393,7 @@ struct
let
pl
=
Array
.
map
(
fun
p
->
match
p
.
Normal
.
nrecord
with
|
Normal
.
RecLabel
(
_
,
l
)
->
Normal
.
NLineProd
.
get
l
|
_
->
assert
false
)
disp
.
pl
in
|
_
->
assert
false
)
pl
in
Some
(
RecLabel
(
lab
,
dispatch_prod0
disp
t
pl
))
let
iter_disp_disp
f
g
=
function
...
...
@@ -1402,11 +1416,16 @@ struct
match
disp
.
actions
with
|
Some
a
->
a
|
None
->
let
pl
=
Array
.
map
(
fun
n
->
let
_
,_,
p
=
Normal
.
nnf
false
disp
.
label
disp
.
t
n
in
p
)
disp
.
pl
in
let
a
=
combine_kind
(
dispatch_basic
disp
)
(
dispatch_prod
disp
)
(
dispatch_prod
~
kind
:
`XML
disp
)
(
dispatch_record
disp
)
(
dispatch_basic
disp
pl
)
(
dispatch_prod
disp
pl
)
(
dispatch_prod
~
kind
:
`XML
disp
pl
)
(
dispatch_record
disp
pl
)
in
disp
.
actions
<-
Some
a
;
iter_disp_actions
(
fun
d
->
to_generate
:=
d
::
!
to_generate
)
a
;
...
...
@@ -1585,13 +1604,8 @@ struct
(
Types
.
Record
.
first_label
t
)
pl
in
let
lab
=
if
lab
==
LabelPool
.
dummy_max
then
None
else
Some
lab
in
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
let
n
=
Normal
.
nnf
false
lab
t
([
p
]
,
t
,
fv
p
)
in
match
n
with
|
[]
,
[]
,
x
->
x
|
_
->
assert
false
)
pl
)
in
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
([
p
]
,
Types
.
cap
t
(
Types
.
descr
(
accept
p
))
,
fv
p
))
pl
)
in
show
ppf
t
pl
lab
;
Format
.
fprintf
ppf
"# compiled states: %i@
\n
"
!
generated
...
...
@@ -1612,7 +1626,6 @@ end
(****** More efficient compilation (less optimized) ******)
module
Compile2
=
struct
type
source
=
...
...
@@ -2032,6 +2045,41 @@ struct
|
None
->
map_filter
f
tl
|
Some
x
->
x
::
(
map_filter
f
tl
)
(*
let cup x y t =
match x t with
| `Binds _ as r1 -> r1
| `Fail -> y t
| r1 -> match y t with
| `Fail -> r1
| r2 -> `Cup (r1,r2)
let cap x y t =
match x t with
| `Fail -> `Fail
| `Binds b1 as r1 ->
(match y t with
| `Fail -> `Fail
| `Binds b2 -> `Binds (LabelMap.union_disj b1 b2)
| r2 -> `Cap (r1,r2))
| r1 -> match y t with
| `Fail -> `Fail
| r2 -> `Cap (r1,r2)
let rec prod_tests t0 d tests1 = match d with
| Req.RBinds b -> `Binds b
| Req.RTimes (q1,q2,xs,_) ->
`Times (reg_test tests1 (Types.Product.pi1 t0) q1 xs,q2,xs)
| Req.RCup (p1,p2) -> cup (prod_tests t0 p1) (prod_tests t0 p2) tests1
| Req.RCap (p2,p1) -> cap (prod_tests t0 p1) (prod_tests t0 p2) tests1
| Req.RConstr s ->
let rects = Types.Product.get ~kind:`Normal s in
let rects = List.map (fun (s1,s2) -> reg_test_type tests1 s1, s2) rects in
`Prod rects
| _ -> `Fail
*)
let
rec
prod_tests
t0
d
tests1
=
match
d
with
|
Req
.
RBinds
b
->
(
fun
t1
ar1
tests2
ar2
->
Some
b
)
|
Req
.
RTimes
(
q1
,
q2
,
xs
,_
)
->
...
...
web/site.cd
View file @
58c7c621
...
...
@@ -11,7 +11,6 @@ let (input,outdir) =
| [ s ("-o" o | /(o := "www")) ] -> (s,o)
| _ -> raise "Please use --arg to specify an input file on the command line"
(** Generic purpose functions **)
(* Recursive inclusion of XML files and verbatim text files *)
...
...
@@ -35,8 +34,6 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] =
print ['Invalid input document:\n' !err '\n'];
exit 2
(* Highlighting text between {{...}} *)
let highlight (String -> [ (Char | H.strong | H.i)* ] )
...
...
@@ -392,7 +389,7 @@ match page with
(
*
Preparing
left
panel
*
)
let
left
=
let
left
=
if
leftbar
then
let
navig
=
transform
items
with
<
left
>
c
->
[
c
]
in
let
left
=
match
navig
with
[]
->
[
[
<
boxes
-
toc
>
[]]
]
|
n
->
n
in
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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