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
a52e7583
Commit
a52e7583
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-16 11:35:09 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-16 11:35:09+00:00
parent
eea1d6fb
Changes
6
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
a52e7583
...
...
@@ -46,6 +46,10 @@ PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
OCAMLCP
=
ocamlc
OCAMLC
=
ocamlfind
$(OCAMLCP)
-package
$(PACKAGES)
OCAMLOPT
=
ocamlfind ocamlopt
-package
$(PACKAGES)
# extra options:
# -inline 25
# -p (profiling)
# -noassert
DEPEND
=
$
(
DIRS:
=
/
*
.ml
)
$
(
DIRS:
=
/
*
.mli
)
INCLUDES
=
$
(
DIRS:%
=
-I
%
)
...
...
runtime/eval.ml
View file @
a52e7583
...
...
@@ -55,6 +55,8 @@ let rec eval env e0 =
|
Typed
.
Op
(
"raise"
,
[
e
])
->
raise
(
CDuceExn
(
eval
env
e
))
|
Typed
.
Try
(
arg
,
brs
)
->
(
try
eval
env
arg
with
CDuceExn
v
->
eval_branches
env
brs
v
)
|
Typed
.
Op
(
"flatten"
,
[{
Typed
.
exp_descr
=
Typed
.
Map
(
arg
,
brs
)}])
->
eval_transform
env
brs
(
eval
env
arg
)
|
Typed
.
Op
(
"flatten"
,
[
e
])
->
eval_flatten
(
eval
env
e
)
|
Typed
.
Op
(
"@"
,
[
e1
;
e2
])
->
eval_concat
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"+"
,
[
e1
;
e2
])
->
eval_add
(
eval
env
e1
)
(
eval
env
e2
)
...
...
@@ -112,6 +114,11 @@ and eval_flatten = function
|
Pair
(
x
,
y
)
->
eval_concat
x
(
eval_flatten
y
)
|
q
->
q
and
eval_transform
env
brs
=
function
|
Pair
(
x
,
y
)
->
eval_concat
(
eval_branches
env
brs
x
)
(
eval_transform
env
brs
y
)
|
String
(
_
,_,_,_
)
as
v
->
eval_transform
env
brs
(
normalize
v
)
|
q
->
q
and
eval_concat
l1
l2
=
match
l1
with
|
Pair
(
x
,
y
)
->
Pair
(
x
,
eval_concat
y
l2
)
|
String
(
s
,
i
,
j
,
q
)
->
String
(
s
,
i
,
j
,
eval_concat
q
l2
)
...
...
runtime/run_dispatch.ml
View file @
a52e7583
(* Running dispatchers *)
(* Possible simple optimizations:
- in make_result_prod, see if buffer can be simply overwritten
(precompute this ...)
*)
open
Value
open
Ident
open
Patterns
.
Compile
(*
module Array = struct
include Array
let get = unsafe_get
end
*)
let
buffer
=
ref
(
Array
.
create
127
Absent
)
let
cursor
=
ref
0
let
blit
a1
ofs1
a2
ofs2
len
=
for
i
=
0
to
len
-
1
do
Array
.
unsafe_set
a2
(
ofs2
+
i
)
(
Array
.
unsafe_get
a1
(
ofs1
+
i
))
done
let
ensure_room
n
=
let
l
=
Array
.
length
!
buffer
in
if
!
cursor
+
n
>
l
then
let
buffer'
=
Array
.
create
(
l
*
2
+
n
)
Absent
in
blit
!
buffer
0
buffer'
0
!
cursor
;
buffer
:=
buffer'
let
make_result_prod
v1
r1
v2
r2
v
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
Catch
->
v
|
Const
c
->
const
c
|
Left
i
->
if
(
i
<
0
)
then
v1
else
r1
.
(
i
)
|
Right
j
->
if
(
j
<
0
)
then
v2
else
r2
.
(
j
)
|
Recompose
(
i
,
j
)
->
Pair
((
if
(
i
<
0
)
then
v1
else
r1
.
(
i
))
,
(
if
(
j
<
0
)
then
v2
else
r2
.
(
j
)))
)
r
in
(
code
,
ret
)
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
let
x
=
match
Array
.
unsafe_get
r
a
with
|
Catch
->
v
|
Const
c
->
const
c
|
Left
i
->
if
(
i
<
0
)
then
v1
else
buf
.
(
r1
+
i
)
|
Right
j
->
if
(
j
<
0
)
then
v2
else
buf
.
(
r2
+
j
)
|
Recompose
(
i
,
j
)
->
Pair
((
if
(
i
<
0
)
then
v1
else
buf
.
(
r1
+
i
))
,
(
if
(
j
<
0
)
then
v2
else
buf
.
(
r2
+
j
)))
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
(* if r1 <> !cursor then *)
blit
buf
!
cursor
buf
r1
n
;
cursor
:=
r1
+
n
;
(* clean space for GC ? *)
code
)
let
make_result_basic
v
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
Catch
->
v
|
Const
c
->
const
c
|
_
->
assert
false
)
r
in
(
code
,
ret
)
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
let
x
=
match
Array
.
unsafe_get
r
a
with
|
Catch
->
v
|
Const
c
->
const
c
|
_
->
assert
false
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
code
)
let
make_result_char
ch
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
Catch
->
Char
ch
|
Const
c
->
const
c
|
_
->
assert
false
)
r
in
(
code
,
ret
)
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
let
x
=
match
Array
.
unsafe_get
r
a
with
|
Catch
->
Char
ch
|
Const
c
->
const
c
|
_
->
assert
false
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
code
)
let
tail_string
i
j
s
q
=
if
i
+
1
=
j
then
q
else
String
(
i
+
1
,
j
,
s
,
q
)
let
make_result_string
i
j
s
q
r1
r2
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
Catch
->
String
(
i
,
j
,
s
,
q
)
|
Const
c
->
const
c
|
Left
n
->
if
(
n
<
0
)
then
Char
(
Chars
.
mk_char
s
.
[
i
])
else
r1
.
(
n
)
|
Right
m
->
if
(
m
<
0
)
then
tail_string
i
j
s
q
else
r2
.
(
m
)
|
Recompose
(
n
,
m
)
->
Pair
((
if
(
n
<
0
)
then
Char
(
Chars
.
mk_char
s
.
[
i
])
else
r1
.
(
n
))
,
(
if
(
m
<
0
)
then
tail_string
i
j
s
q
else
r2
.
(
m
)))
)
r
in
(
code
,
ret
)
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
let
x
=
match
Array
.
unsafe_get
r
a
with
|
Catch
->
String
(
i
,
j
,
s
,
q
)
|
Const
c
->
const
c
|
Left
n
->
if
(
n
<
0
)
then
Char
(
Chars
.
mk_char
s
.
[
i
])
else
buf
.
(
r1
+
n
)
|
Right
m
->
if
(
m
<
0
)
then
tail_string
i
j
s
q
else
buf
.
(
r2
+
m
)
|
Recompose
(
n
,
m
)
->
Pair
((
if
(
n
<
0
)
then
Char
(
Chars
.
mk_char
s
.
[
i
])
else
buf
.
(
r1
+
n
))
,
(
if
(
m
<
0
)
then
tail_string
i
j
s
q
else
buf
.
(
r2
+
m
)))
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
blit
buf
!
cursor
buf
r1
n
;
cursor
:=
r1
+
n
;
code
)
let
rec
run_disp_basic
v
f
=
function
...
...
@@ -64,7 +109,7 @@ let rec run_disp_basic v f = function
|
(
t
,
r
)
::
rem
->
if
f
t
then
make_result_basic
v
r
else
run_disp_basic
v
f
rem
|
_
->
assert
false
let
dummy_r
=
[
||
]
let
dummy_r
=
0
let
rec
run_dispatcher
d
v
=
(*
...
...
@@ -90,9 +135,9 @@ and run_disp_kind actions v =
actions
.
basic
|
Absent
->
run_disp_basic
v
(
fun
t
->
Types
.
Record
.
has_absent
t
)
actions
.
basic
|
v
->
(*
| v ->
run_disp_kind actions (normalize v)
*)
and
run_disp_prod
v
v1
v2
=
function
...
...
@@ -100,7 +145,8 @@ and run_disp_prod v v1 v2 = function
|
TailCall
d1
->
run_dispatcher
d1
v1
|
Ignore
d2
->
run_disp_prod2
v1
dummy_r
v
v2
d2
|
Dispatch
(
d1
,
b1
)
->
let
(
code1
,
r1
)
=
run_dispatcher
d1
v1
in
let
r1
=
!
cursor
in
let
code1
=
run_dispatcher
d1
v1
in
run_disp_prod2
v1
r1
v
v2
b1
.
(
code1
)
and
run_disp_prod2
v1
r1
v
v2
=
function
...
...
@@ -108,7 +154,8 @@ and run_disp_prod2 v1 r1 v v2 = function
|
Ignore
r
->
make_result_prod
v1
r1
v2
dummy_r
v
r
|
TailCall
d2
->
run_dispatcher
d2
v2
|
Dispatch
(
d2
,
b2
)
->
let
(
code2
,
r2
)
=
run_dispatcher
d2
v2
in
let
r2
=
!
cursor
in
let
code2
=
run_dispatcher
d2
v2
in
make_result_prod
v1
r1
v2
r2
v
b2
.
(
code2
)
and
run_disp_record
other
v
fields
=
function
...
...
@@ -133,7 +180,8 @@ and run_disp_record1 other v1 rem = function
|
TailCall
d1
->
run_dispatcher
d1
v1
|
Ignore
d2
->
run_disp_record2
other
v1
dummy_r
rem
d2
|
Dispatch
(
d1
,
b1
)
->
let
(
code1
,
r1
)
=
run_dispatcher
d1
v1
in
let
r1
=
!
cursor
in
let
code1
=
run_dispatcher
d1
v1
in
run_disp_record2
other
v1
r1
rem
b1
.
(
code1
)
and
run_disp_record2
other
v1
r1
rem
=
function
...
...
@@ -141,7 +189,8 @@ and run_disp_record2 other v1 r1 rem = function
|
Ignore
r
->
make_result_prod
v1
r1
Absent
dummy_r
Absent
r
|
TailCall
d2
->
run_disp_record_loop
other
rem
d2
|
Dispatch
(
d2
,
b2
)
->
let
(
code2
,
r2
)
=
run_disp_record_loop
other
rem
d2
in
let
r2
=
!
cursor
in
let
code2
=
run_disp_record_loop
other
rem
d2
in
make_result_prod
v1
r1
Absent
r2
Absent
b2
.
(
code2
)
and
run_disp_record_loop
other
rem
d
=
...
...
@@ -157,7 +206,8 @@ and run_disp_string i j s q actions =
|
TailCall
d1
->
run_disp_string_char
d1
(
Chars
.
mk_char
s
.
[
i
])
|
Ignore
d2
->
run_disp_string2
dummy_r
i
j
s
q
d2
|
Dispatch
(
d1
,
b1
)
->
let
(
code1
,
r1
)
=
run_disp_string_char
d1
(
Chars
.
mk_char
s
.
[
i
])
in
let
r1
=
!
cursor
in
let
code1
=
run_disp_string_char
d1
(
Chars
.
mk_char
s
.
[
i
])
in
run_disp_string2
r1
i
j
s
q
b1
.
(
code1
)
and
run_disp_string_char
d
ch
=
match
actions
d
with
...
...
@@ -169,12 +219,37 @@ and run_disp_string2 r1 i j s q = function
make_result_string
i
j
s
q
r1
dummy_r
r
|
TailCall
d2
->
run_disp_string_loop
i
j
s
q
d2
|
Dispatch
(
d2
,
b2
)
->
let
(
code2
,
r2
)
=
run_disp_string_loop
i
j
s
q
d2
in
let
r2
=
!
cursor
in
let
code2
=
run_disp_string_loop
i
j
s
q
d2
in
make_result_string
i
j
s
q
r1
r2
b2
.
(
code2
)
and
run_disp_string_loop
i
j
s
q
d
=
match
actions
d
with
|
AIgnore
r
->
make_result_basic
Absent
r
|
AKind
k
->
run_disp_string
(
succ
i
)
j
s
q
k
let
run_dispatcher
d
v
=
let
code
=
run_dispatcher
d
v
in
(* for unknown reasons, it seems to be faster to copy the intersting prefix... *)
(* cursor := 0;
(code,!buffer) *)
let
r
=
Array
.
create
!
cursor
Absent
in
blit
!
buffer
0
r
0
!
cursor
;
cursor
:=
0
;
(
code
,
r
)
(*
let rec check_overwrite_aux r i =
if i < 0 then true
else match r.(i) with
| Right j | Recompose (_,j) ->
if (j < 0) || (j >=i ) then check_overwrite_aux r (i - 1) else false
| _ -> check_overwrite_aux r (i - 1)
(* TODO: finir d'implmenter les capture pour les string ... *)
let check_overwrite r2 r =
(Array.length r2 = Array.length r) && (check_overwrite_aux r (Array.length r - 1))
*)
types/atoms.ml
View file @
a52e7583
...
...
@@ -92,7 +92,10 @@ let equal t1 t2 = match (t1,t2) with
(* TODO: optimize map lookup *)
(* Optimize lookup:
- decision tree
- merge adjacent segment with same result
*)
type
'
a
map
=
(
v
*
'
a
)
list
*
'
a
option
let
mk_map
l
=
...
...
types/chars.ml
View file @
a52e7583
...
...
@@ -100,6 +100,10 @@ let print =
)
type
'
a
map
=
(
int
*
'
a
)
list
(* Optimize lookup:
- decision tree
- merge adjacent segment with same result
*)
let
mk_map
l
=
let
m
=
...
...
types/types.ml
View file @
a52e7583
...
...
@@ -461,6 +461,7 @@ let rec iter_s s f = function
let
set
s
=
s
.
status
<-
NEmpty
;
notify
s
.
notify
;
(* s.notify <- Nothing; *)
raise
NotEmpty
let
rec
big_conj
f
l
n
=
...
...
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