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
9ef60e2b
Commit
9ef60e2b
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-11-21 09:27:59 by afrisch] Opt
Original author: afrisch Date: 2003-11-21 09:27:59+00:00
parent
5a075557
Changes
5
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
9ef60e2b
...
...
@@ -127,7 +127,7 @@ OBJECTS = \
\
types/builtin.cmo driver/librarian.cmo driver/cduce.cmo
\
\
query/query_parse.cmo
#
query/query_parse.cmo
VALIDATE_OBJECTS
:=
$(
shell
for
o
in
$(OBJECTS)
;
do
echo
$$
o
;
if
[
"
$$
o"
=
"schema/schema_parser.cmo"
]
;
then
exit
0
;
fi
;
done
)
# all objects until schema_parser.cmo
...
...
@@ -158,7 +158,7 @@ webiface: $(WEBIFACE:.cmo=.$(EXTENSION))
dtd2cduce
:
$(DTD2CDUCE:.cmo=.$(EXTENSION))
$(LINK)
$(INCLUDES)
-o
$@
$^
validate
:
$(VALIDATE_OBJECTS) tools/validate.
cmo
validate
:
$(VALIDATE_OBJECTS
:.cmo=.$(EXTENSION)
) tools/validate.
$(EXTENSION)
$(LINK)
$(INCLUDES)
-o
$@
$^
.PHONY
:
compute_depend
...
...
driver/cduce.ml
View file @
9ef60e2b
...
...
@@ -95,9 +95,6 @@ let rec print_exn ppf = function
|
Value
.
CDuceExn
v
->
Format
.
fprintf
ppf
"Uncaught CDuce exception: @[%a@]@."
print_value
v
|
Eval
.
MultipleDeclaration
v
->
Format
.
fprintf
ppf
"Multiple declaration for global value %a@."
U
.
print
(
Id
.
value
v
)
|
Typer
.
WrongLabel
(
t
,
l
)
->
Format
.
fprintf
ppf
"Wrong record selection; field %a "
Label
.
print
(
LabelPool
.
value
l
);
...
...
runtime/eval.ml
View file @
9ef60e2b
...
...
@@ -2,7 +2,6 @@ open Value
open
Run_dispatch
open
Ident
exception
MultipleDeclaration
of
id
type
env
=
t
Env
.
t
let
empty
=
Env
.
empty
...
...
@@ -289,7 +288,14 @@ let dispatcher brs =
match
brs
.
brs_compiled
with
|
Some
d
->
d
|
None
->
(* Format.fprintf Format.std_formatter "Start compilation...@.";
let time = Unix.gettimeofday() in*)
let
x
=
Patterns
.
Compile
.
make_branches
brs
.
brs_input
brs
.
brs
in
(* let time = Unix.gettimeofday() -. time in
if time > 1.0 then
Format.fprintf Format.std_formatter "%a@."
Patterns.Compile.print_dispatcher (fst x);
Format.fprintf Format.std_formatter "(%f ms).@." time; *)
brs
.
brs_compiled
<-
Some
x
;
x
...
...
runtime/eval.mli
View file @
9ef60e2b
open
Value
open
Ident
exception
MultipleDeclaration
of
id
type
env
val
empty
:
env
...
...
types/patterns.ml
View file @
9ef60e2b
...
...
@@ -872,30 +872,53 @@ struct
(* Try with a hash-table ! *)
let
dispatchers
=
ref
DispMap
.
empty
let
timer_disp
=
Stats
.
Timer
.
create
"Patterns.dispatcher loop"
let
dispatcher
t
pl
lab
:
dispatcher
=
try
DispMap
.
find
(
t
,
pl
)
!
dispatchers
with
Not_found
->
let
nb
=
ref
0
in
let
codes
=
ref
[]
in
let
rec
aux
t
arity
i
accu
=
if
Types
.
is_empty
t
then
`None
if
i
==
Array
.
length
pl
then
(
incr
nb
;
codes
:=
(
t
,
arity
,
accu
)
::!
codes
;
`Result
(
!
nb
-
1
))
else
if
i
==
Array
.
length
pl
then
(
incr
nb
;
codes
:=
(
t
,
arity
,
accu
)
::!
codes
;
`Result
(
!
nb
-
1
))
let
p
=
pl
.
(
i
)
in
let
tp
=
p
.
Normal
.
na
in
(* let tp = Types.normalize tp in *)
let
a1
=
Types
.
cap
t
tp
in
if
Types
.
is_empty
a1
then
`Switch
(
`None
,
aux
t
arity
(
i
+
1
)
accu
)
else
let
p
=
pl
.
(
i
)
in
let
tp
=
p
.
Normal
.
na
in
let
v
=
p
.
Normal
.
nfv
in
(*
let
tp
= Types.
normalize
tp in
*)
let
a2
=
Types
.
diff
t
tp
in
let
accu'
=
(
i
,
IdMap
.
num
arity
v
)
::
accu
in
if
Types
.
is_empty
a2
then
`Switch
(
aux
t
(
arity
+
(
IdSet
.
length
v
))
(
i
+
1
)
accu'
,
`None
)
else
`Switch
(
aux
a1
(
arity
+
(
IdSet
.
length
v
))
(
i
+
1
)
accu'
,
aux
a2
arity
(
i
+
1
)
accu
)
(* Unopt version:
`Switch
(
aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
aux (Types.diff t tp) arity (i+1) accu
)
*)
in
let
iface
=
aux
t
0
0
[]
in
(* Array.iteri (fun i p ->
Format.fprintf Format.std_formatter
"Pattern %i/%i accepts %a@." i (Array.length pl)
Types.Print.print p.Normal.na) pl; *)
Stats
.
Timer
.
start
timer_disp
;
let
iface
=
if
Types
.
is_empty
t
then
`None
else
aux
t
0
0
[]
in
Stats
.
Timer
.
stop
timer_disp
()
;
let
res
=
{
id
=
!
cur_id
;
t
=
t
;
label
=
lab
;
...
...
@@ -1029,6 +1052,10 @@ struct
List
.
fold_left
(
fun
(
t
,
brs
)
(
p
,
e
)
->
let
p'
=
(
Normal
.
NodeSet
.
singleton
p
,
t
)
in
(* let td = Types.descr (accept p) in
let t' =
if Types.is_empty (Types.cap t td) then t else
Types.diff t td in*)
let
t'
=
Types
.
diff
t
(
Types
.
descr
(
accept
p
))
in
(
t'
,
(
p'
,
(
fv_list
p
,
e
))
::
brs
)
)
(
t
,
[]
)
brs
in
...
...
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