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
c66d89b5
Commit
c66d89b5
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-08 15:10:01 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-08 15:10:03+00:00
parent
2a116016
Changes
19
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
c66d89b5
...
...
@@ -15,6 +15,7 @@ TYPING = typing/typed.cmo typing/typer.cmo
TYPES
=
\
types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo
\
types/ident.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo
\
types/normal.cmo
\
types/types.cmo
\
...
...
depend
View file @
c66d89b5
...
...
@@ -4,28 +4,28 @@ misc/pool.cmo: misc/state.cmi misc/pool.cmi
misc/pool.cmx: misc/state.cmx misc/pool.cmi
misc/state.cmo: misc/state.cmi
misc/state.cmx: misc/state.cmi
parser/ast.cmo:
parser/location.cmi types/patterns
.cmi types/types.cmi
parser/ast.cmx:
parser/location.cmx types/patterns
.cmx types/types.cmx
parser/ast.cmo:
types/ident.cmo parser/location
.cmi types/types.cmi
parser/ast.cmx:
types/ident.cmx parser/location
.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/intervals.cmi parser/location.cmi
types/sequence.cmi
\
types/types.cmi parser/wlexer.cmo parser/parser.cmi
types/ident.cmo
types/intervals.cmi parser/location.cmi \
types/sequence.cmi
types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/intervals.cmx parser/location.cmx
types/sequence.cmx
\
types/types.cmx parser/wlexer.cmx parser/parser.cmi
types/ident.cmx
types/intervals.cmx parser/location.cmx \
types/sequence.cmx
types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/wlexer.cmo: parser/location.cmi
parser/wlexer.cmx: parser/location.cmx
typing/typed.cmo: parser/location.cmi types/patterns.cmi
types/sortedMap.cmi
\
types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx
types/sortedMap.cmx
\
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/int
ervals
.cm
i
\
parser/location.cmi types/patterns.cmi
types/sequence.cmi
\
types/s
ortedList
.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/int
ervals
.cmx \
parser/location.cmx types/patterns.cmx
types/sequence.cmx
\
types/s
ortedList
.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
typing/typed.cmo:
types/ident.cmo
parser/location.cmi types/patterns.cmi \
types/sortedMap.cmi
types/types.cmi
typing/typed.cmx:
types/ident.cmx
parser/location.cmx types/patterns.cmx \
types/sortedMap.cmx
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/i
de
nt.cm
o
\
types/intervals.cmi
parser/location.cmi types/patterns.cmi \
types/s
equence
.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/i
de
nt.cmx \
types/intervals.cmx
parser/location.cmx types/patterns.cmx \
types/s
equence
.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
types/atoms.cmo: misc/pool.cmi types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/pool.cmx types/sortedList.cmx types/atoms.cmi
types/boolean.cmo: types/sortedList.cmi types/boolean.cmi
...
...
@@ -36,14 +36,16 @@ types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
types/types.cmx
types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/ident.cmo: misc/pool.cmi types/sortedList.cmi
types/ident.cmx: misc/pool.cmx types/sortedList.cmx
types/intervals.cmo: types/intervals.cmi
types/intervals.cmx: types/intervals.cmi
types/normal.cmo: types/normal.cmi
types/normal.cmx: types/normal.cmi
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi
misc/state.cmi
\
types/types.cmi types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx
misc/state.cmx
\
types/types.cmx types/patterns.cmi
types/patterns.cmo:
types/ident.cmo
types/sortedList.cmi types/sortedMap.cmi \
misc/state.cmi
types/types.cmi types/patterns.cmi
types/patterns.cmx:
types/ident.cmx
types/sortedList.cmx types/sortedMap.cmx \
misc/state.cmx
types/types.cmx types/patterns.cmi
types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo misc/state.cmi
...
...
@@ -56,20 +58,20 @@ types/sortedMap.cmo: types/sortedMap.cmi
types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/b
dd
.cm
o
types/
boolean
.cmi \
types/chars.cmi
types/intervals.cmi types/normal.cmi misc/pool.cmi \
types/recursive.cmo
types/sortedList.cmi types/sortedMap.cmi
\
misc/state
.cm
i
types/
types.cmi
types/
type
s.cmx
:
types/
atoms.cmx types/bdd
.cmx types/
boolean
.cmx \
types/
chars
.cmx types/
intervals.cmx types/normal.cmx misc/pool.cmx \
types/recursive
.cm
x
types/
sortedLis
t.cm
x
types/
sortedMap
.cm
x
\
misc/state.cmx types/types.cmi
runtime/
eval.cmo: types/atoms.cmi types/intervals.cmi runtime/load_xml
.cm
i
\
parser/location.cmi runtime/print_xml
.cm
o
runtime/
run_dispatch
.cmi
\
misc/state
.cm
i
typ
ing/typed.cmo runtime/value.cmi runtime/e
val.cm
i
runtime/
eval.cmx: types/atoms.cmx types/intervals
.cmx runtime/
load
_xml.cmx \
parser/location.cmx runtime/print_xml.cmx runtime/run_dispatch
.cmx \
misc/state.cmx typing/typed.cmx
runtime/value.cmx runtime/eval.cmi
types/types.cmo: types/atoms.cmi types/b
oolean
.cm
i
types/
chars
.cmi \
types/intervals.cmi types/normal.cmi misc/pool.cmi
types/recursive.cmo
\
types/sortedList.cmi types/sortedMap.cmi
misc/state.cmi types/types.cmi
types/types.cmx: types/atoms
.cm
x
types/
boolean.cmx types/chars.cmx \
types/
interval
s.cmx types/
normal.cmx misc/pool
.cmx types/
recursive
.cmx \
types/
sortedList
.cmx types/
sortedMap.cmx misc/state.cmx types/types.cmi
runtime/eval.cmo: types/atoms
.cm
i
types/
iden
t.cm
o
types/
intervals
.cm
i
\
runtime/load_xml.cmi parser/location.cmi runtime/print_xml.cmo \
runtime/
run_dispatch.cmi misc/state.cmi typing/typed
.cm
o
\
runtime/value
.cm
i
runtime/
eval
.cmi
runtime/eval
.cm
x:
typ
es/atoms.cmx types/ident.cmx types/inter
val
s
.cm
x \
runtime/
load_xml.cmx parser/location
.cmx runtime/
print
_xml.cmx \
runtime/run_dispatch.cmx misc/state.cmx typing/typed
.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/atoms.cmi parser/location.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: types/atoms.cmx parser/location.cmx types/sortedMap.cmx \
...
...
@@ -87,13 +89,13 @@ runtime/value.cmo: types/atoms.cmi types/chars.cmi types/intervals.cmi \
runtime/value.cmx: types/atoms.cmx types/chars.cmx types/intervals.cmx \
types/sequence.cmx types/sortedMap.cmx types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi
misc/state.cmi
\
typing/typed.cmo typing/typer.cmi types/types.cmi
runtime/value.cmi
\
parser/wlexer.cmo driver/cduce.cmi
types/ident.cmo
parser/location.cmi parser/parser.cmi types/patterns.cmi \
misc/state.cmi
typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi
parser/wlexer.cmo driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx
misc/state.cmx
\
typing/typed.cmx typing/typer.cmx types/types.cmx
runtime/value.cmx
\
parser/wlexer.cmx driver/cduce.cmi
types/ident.cmx
parser/location.cmx parser/parser.cmx types/patterns.cmx \
misc/state.cmx
typing/typed.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
parser/wlexer.cmx driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi \
types/types.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx \
...
...
@@ -105,16 +107,17 @@ driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \
toplevel/toploop.cmo: parser/parser.cmi
toplevel/toploop.cmx: parser/parser.cmx
parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
typing/typer.cmi: parser/ast.cmo types/ident.cmo typing/typed.cmo \
types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/normal.cmi: types/boolean.cmi
types/patterns.cmi: types/
sortedList.cmi types/sortedMap.cmi
types/types.cmi
types/patterns.cmi: types/
ident.cmo
types/types.cmi
types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
misc/pool.cmi types/sortedMap.cmi
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/eval.cmi:
types/ident.cmo
typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
...
...
driver/cduce.ml
View file @
c66d89b5
open
Location
open
Ident
let
quiet
=
ref
false
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Typer
.
Env
.
empty
let
glb_env
=
State
.
ref
"Cduce.glb_env"
Typer
.
Env
.
empty
let
glb_env
=
State
.
ref
"Cduce.glb_env"
Typer
.
Type
Env
.
empty
let
eval_env
=
Eval
.
global_env
let
print_norm
ppf
d
=
...
...
@@ -15,13 +16,13 @@ let print_value ppf v =
let
dump_env
ppf
=
Format
.
fprintf
ppf
"Global types:"
;
Typer
.
Env
.
iter
(
fun
x
_
->
Format
.
fprintf
ppf
" %s"
x
)
!
glb_env
;
Typer
.
Type
Env
.
iter
(
fun
x
_
->
Format
.
fprintf
ppf
" %s"
x
)
!
glb_env
;
Format
.
fprintf
ppf
".@
\n
"
;
Eval
.
Env
.
iter
(
fun
x
v
->
let
t
=
Typer
.
Env
.
find
x
!
typing_env
in
Format
.
fprintf
ppf
"@[|- %s : %a@ => %a@]@
\n
"
x
(
Id
.
value
x
)
print_norm
t
print_value
v
)
...
...
@@ -95,7 +96,7 @@ let debug ppf = function
and
p
=
Typer
.
pat
!
glb_env
p
in
let
f
=
Patterns
.
filter
(
Types
.
descr
t
)
p
in
List
.
iter
(
fun
(
x
,
t
)
->
Format
.
fprintf
ppf
" %s:%a@
\n
"
x
Format
.
fprintf
ppf
" %s:%a@
\n
"
(
Id
.
value
x
)
print_norm
(
Types
.
descr
t
))
f
|
`Compile2
(
t
,
pl
)
->
Format
.
fprintf
ppf
"[DEBUG:compile2]@
\n
"
;
...
...
@@ -181,7 +182,7 @@ let run ppf ppf_err input =
List
.
iter
(
fun
(
x
,
t
)
->
typing_env
:=
Typer
.
Env
.
add
x
t
!
typing_env
;
if
not
!
quiet
then
Format
.
fprintf
ppf
"|- %s : %a@
\n
@."
x
print_norm
t
)
Format
.
fprintf
ppf
"|- %s : %a@
\n
@."
(
Id
.
value
x
)
print_norm
t
)
in
let
type_decl
decl
=
...
...
@@ -194,7 +195,7 @@ let run ppf ppf_err input =
(
fun
(
x
,
v
)
->
Eval
.
enter_global
x
v
;
if
not
!
quiet
then
Format
.
fprintf
ppf
"=> %s : @[%a@]@
\n
@."
x
print_value
v
Format
.
fprintf
ppf
"=> %s : @[%a@]@
\n
@."
(
Id
.
value
x
)
print_value
v
)
bindings
in
...
...
misc/pool.ml
View file @
c66d89b5
...
...
@@ -20,21 +20,23 @@ struct
type
t
=
int
type
value
=
H
.
t
let
cache
=
State
.
ref
"Pool.cache"
(
Hashtbl
.
create
63
)
module
Tbl
=
Hashtbl
.
Make
(
H
)
let
cache
=
State
.
ref
"Pool.cache"
(
Tbl
.
create
63
)
let
values
=
State
.
ref
"Pool.values"
(
Array
.
create
63
None
)
let
counter
=
State
.
ref
"Pool.counter"
0
let
clear
()
=
Hasht
bl
.
clear
!
cache
;
T
bl
.
clear
!
cache
;
values
:=
Array
.
create
63
None
;
counter
:=
0
let
mk
x
=
try
Hasht
bl
.
find
!
cache
x
try
T
bl
.
find
!
cache
x
with
Not_found
->
let
n
=
!
counter
in
incr
counter
;
Hasht
bl
.
add
!
cache
x
n
;
T
bl
.
add
!
cache
x
n
;
if
(
n
=
Array
.
length
!
values
)
then
(
let
new_values
=
Array
.
create
(
2
*
Array
.
length
!
values
)
None
in
...
...
parser/ast.ml
View file @
c66d89b5
(* Abstract syntax as produced by the parsed *)
open
Location
open
Ident
type
pprog
=
pmodule_item
list
...
...
@@ -26,7 +27,7 @@ and pexpr = pexpr' located
and
pexpr'
=
|
Forget
of
pexpr
*
ppat
(* CDuce is a Lambda-calculus ... *)
|
Var
of
string
|
Var
of
id
|
Apply
of
pexpr
*
pexpr
|
Abstraction
of
abstr
...
...
@@ -46,7 +47,7 @@ and pexpr' =
|
Try
of
pexpr
*
branches
and
abstr
=
{
fun_name
:
string
option
;
fun_name
:
id
option
;
fun_iface
:
(
ppat
*
ppat
)
list
;
fun_body
:
branches
}
...
...
@@ -67,8 +68,8 @@ and ppat' =
|
XmlT
of
ppat
*
ppat
|
Arrow
of
ppat
*
ppat
|
Record
of
bool
*
(
Types
.
label
*
bool
*
ppat
)
list
|
Capture
of
Patterns
.
capture
|
Constant
of
Patterns
.
capture
*
Types
.
const
|
Capture
of
id
|
Constant
of
id
*
Types
.
const
|
Regexp
of
regexp
*
ppat
and
regexp
=
...
...
@@ -78,5 +79,5 @@ and regexp =
|
Alt
of
regexp
*
regexp
|
Star
of
regexp
|
WeakStar
of
regexp
|
SeqCapture
of
Patterns
.
capture
*
regexp
|
SeqCapture
of
id
*
regexp
parser/parser.ml
View file @
c66d89b5
open
Location
open
Ast
open
Ident
(*
let () = Grammar.error_verbose := true
...
...
@@ -87,12 +88,12 @@ EXTEND
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Match
(
e
,
b
))
|
"try"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
(
mk
noloc
(
Capture
"x"
)
,
mk
noloc
(
Op
(
"raise"
,
[
mk
noloc
(
Var
"x"
)])))
in
(
mk
noloc
(
Capture
(
ident
"x"
)
)
,
mk
noloc
(
Op
(
"raise"
,
[
mk
noloc
(
Var
(
ident
"x"
)
)
])))
in
mk
loc
(
Try
(
e
,
b
@
[
default
]))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Map
(
e
,
b
))
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
mk
noloc
(
Capture
"x"
)
,
cst_nil
in
let
default
=
mk
noloc
(
Capture
(
ident
"x"
)
)
,
cst_nil
in
mk
loc
(
Op
(
"flatten"
,
[
mk
loc
(
Map
(
e
,
b
@
[
default
]))]))
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
mk
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
...
...
@@ -113,10 +114,10 @@ EXTEND
let
tag
=
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
any
)))
in
let
att
=
mk
loc
(
Internal
Types
.
Record
.
any
)
in
let
any
=
mk
loc
(
Internal
(
Types
.
any
))
in
let
re
=
Star
(
Alt
(
SeqCapture
(
"x"
,
Elem
p
)
,
Elem
any
))
in
let
re
=
Star
(
Alt
(
SeqCapture
(
ident
"x"
,
Elem
p
)
,
Elem
any
))
in
let
ct
=
mk
loc
(
Regexp
(
re
,
any
))
in
let
p
=
mk
loc
(
XmlT
(
tag
,
multi_prod
loc
[
att
;
ct
]))
in
let
b
=
(
p
,
mk
loc
(
Var
"x"
))
in
let
b
=
(
p
,
mk
loc
(
Var
(
ident
"x"
))
)
in
mk
loc
(
Op
(
"flatten"
,
[
mk
loc
(
Map
(
e
,
[
b
]))]))
]
|
...
...
@@ -161,7 +162,7 @@ EXTEND
|
"{"
;
r
=
[
expr_record_spec
|
->
mk
loc
(
RecordLitt
[]
)
];
"}"
->
r
|
s
=
STRING2
->
tuple
loc
(
char_list
loc
s
@
[
cst_nil
])
|
a
=
LIDENT
->
mk
loc
(
Var
a
)
|
a
=
LIDENT
->
mk
loc
(
Var
(
ident
a
)
)
]
];
...
...
@@ -190,7 +191,7 @@ EXTEND
fun_decl
:
[
(* need an hack to do this, because both productions would
match [ OPT LIDENT; "("; pat ] .... *)
[
f
=
OPT
LIDENT
;
"("
;
p1
=
pat
LEVEL
"no_arrow"
;
[
f
=
OPT
[
x
=
LIDENT
->
ident
x
]
;
"("
;
p1
=
pat
LEVEL
"no_arrow"
;
res
=
[
"->"
;
p2
=
pat
;
a
=
[
";"
;
a
=
LIST0
arrow
SEP
";"
->
a
|
->
[]
];
")"
;
b
=
branches
->
`Classic
(
p2
,
a
,
b
)
...
...
@@ -228,7 +229,7 @@ EXTEND
regexp
:
[
[
x
=
regexp
;
"|"
;
y
=
regexp
->
Alt
(
x
,
y
)
]
|
[
x
=
regexp
;
y
=
regexp
->
Seq
(
x
,
y
)
]
|
[
a
=
LIDENT
;
"::"
;
x
=
regexp
->
SeqCapture
(
a
,
x
)
]
|
[
a
=
LIDENT
;
"::"
;
x
=
regexp
->
SeqCapture
(
ident
a
,
x
)
]
|
[
x
=
regexp
;
"*"
->
Star
x
|
x
=
regexp
;
"*?"
->
WeakStar
x
|
x
=
regexp
;
"+"
->
Seq
(
x
,
Star
x
)
...
...
@@ -236,7 +237,8 @@ EXTEND
|
x
=
regexp
;
"?"
->
Alt
(
x
,
Epsilon
)
|
x
=
regexp
;
"??"
->
Alt
(
Epsilon
,
x
)
]
|
[
"("
;
x
=
regexp
;
")"
->
x
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
Elem
(
mk
loc
(
Constant
(
a
,
c
)))
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
Elem
(
mk
loc
(
Constant
((
ident
a
,
c
))))
|
UIDENT
"PCDATA"
->
string_regexp
|
i
=
STRING1
;
"--"
;
j
=
STRING1
->
let
i
=
Chars
.
mk_char
(
parse_char
loc
i
)
...
...
@@ -267,8 +269,9 @@ EXTEND
[
"{"
;
r
=
record_spec
;
"}"
->
mk
loc
(
Record
(
true
,
r
))
|
"{|"
;
r
=
record_spec
;
"|}"
->
mk
loc
(
Record
(
false
,
r
))
|
LIDENT
"_"
->
mk
loc
(
Internal
Types
.
any
)
|
a
=
LIDENT
->
mk
loc
(
Capture
a
)
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
mk
loc
(
Constant
(
a
,
c
))
|
a
=
LIDENT
->
mk
loc
(
Capture
(
ident
a
))
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
mk
loc
(
Constant
(
ident
a
,
c
))
|
a
=
UIDENT
->
mk
loc
(
PatVar
a
)
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Intervals
.
mk
i
...
...
runtime/eval.ml
View file @
c66d89b5
open
Value
open
Run_dispatch
open
Ident
module
Env
=
Map
.
Make
(
struct
type
t
=
string
let
compare
=
compare
en
d
)
module
Env
=
Map
.
Make
(
Ident
.
I
d
)
type
env
=
t
Env
.
t
let
global_env
=
State
.
ref
"Eval.global_env"
Env
.
empty
...
...
@@ -27,7 +28,7 @@ let rec eval env e0 =
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
let
env
=
Lis
t
.
fold
_left
IdSe
t
.
fold
(
fun
accu
x
->
try
Env
.
add
x
(
Env
.
find
x
env
)
accu
with
Not_found
->
accu
(* global *)
)
...
...
@@ -86,15 +87,15 @@ and eval_branches env brs arg =
let
(
bind
,
e
)
=
rhs
.
(
code
)
in
let
env
=
List
.
fold_left
(
fun
env
(
x
,
i
)
->
if
(
i
=
-
1
)
then
Env
.
add
x
arg
env
else
Env
.
add
x
bindings
.
(
i
)
env
)
env
bind
in
if
(
i
=
-
1
)
then
Env
.
add
x
arg
env
else
Env
.
add
x
bindings
.
(
i
)
env
)
env
(
IdMap
.
get
bind
)
in
eval
env
e
and
eval_let_decl
env
l
=
let
v
=
eval
env
l
.
Typed
.
let_body
in
let
(
disp
,
bind
)
=
Typed
.
dispatcher_let_decl
l
in
let
(
_
,
bindings
)
=
run_dispatcher
disp
v
in
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
=
-
1
)
then
v
else
bindings
.
(
i
)))
bind
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
=
-
1
)
then
v
else
bindings
.
(
i
)))
(
IdMap
.
get
bind
)
and
eval_map
env
brs
=
function
|
Pair
(
x
,
y
)
->
Pair
(
eval_branches
env
brs
x
,
eval_map
env
brs
y
)
...
...
runtime/eval.mli
View file @
c66d89b5
open
Value
open
Ident
module
Env
:
Map
.
S
with
type
key
=
string
module
Env
:
Map
.
S
with
type
key
=
id
type
env
=
t
Env
.
t
val
global_env
:
env
ref
val
enter_global
:
string
->
t
->
unit
val
enter_global
:
id
->
t
->
unit
val
eval
:
env
->
Typed
.
texpr
->
t
val
eval_let_decl
:
env
->
Typed
.
let_decl
->
(
string
*
t
)
list
val
eval_let_decl
:
env
->
Typed
.
let_decl
->
(
id
*
t
)
list
tests/xhtml.cd
View file @
c66d89b5
...
...
@@ -250,5 +250,7 @@ type X_head =
];;
type
X_html
=
<
html
>
[
(
X_head
X_body
)
];;
match
load_xml
"
tests/xhtml.xml
"
with
X_html
->
`Ok | _ -> `
Not_ok
;;
(
*
match
load_xml
"
tests/xhtml.xml
"
with
x
->
x
;;
*
)
types/atoms.ml
View file @
c66d89b5
module
HashedString
=
struct
type
t
=
string
let
hash
=
Hashtbl
.
hash
let
equal
=
(
=
)
end
module
AtomPool
=
Pool
.
Make
(
HashedString
)
module
AtomPool
=
Pool
.
Make
(
SortedList
.
String
)
type
v
=
AtomPool
.
t
let
value
=
AtomPool
.
value
let
mk
=
AtomPool
.
mk
module
SList
=
SortedList
.
Make
(
struct
type
'
a
t
=
v
let
compare
=
AtomPool
.
compare
let
hash
=
AtomPool
.
hash
let
equal
=
AtomPool
.
equal
end
)
module
SList
=
SortedList
.
Make_transp
(
SortedList
.
Lift
(
AtomPool
))
type
t
=
Finite
of
unit
SList
.
t
|
Cofinite
of
unit
SList
.
t
let
empty
=
Finite
[]
...
...
types/boolean.ml
View file @
c66d89b5
...
...
@@ -17,7 +17,7 @@ sig
val
atom
:
'
a
elem
->
'
a
t
val
map
:
(
'
a
elem
->
'
b
elem
)
->
'
a
t
->
'
b
t
val
iter
:
(
'
a
elem
->
unit
)
->
'
a
t
->
unit
val
iter
:
(
'
a
elem
->
unit
)
->
'
a
t
->
unit
val
compute
:
empty
:
'
d
->
full
:
'
c
->
cup
:
(
'
d
->
'
c
->
'
d
)
->
cap
:
(
'
c
->
'
b
->
'
c
)
->
diff
:
(
'
c
->
'
b
->
'
c
)
->
atom
:
(
'
a
elem
->
'
b
)
->
'
a
t
->
'
d
...
...
@@ -32,8 +32,8 @@ end
module
Make
(
X
:
SortedList
.
ARG
)
=
struct
type
'
a
elem
=
'
a
X
.
t
module
SList
=
SortedList
.
Make
(
X
)
module
SSList
=
SortedList
.
Make
module
SList
=
SortedList
.
Make
_transp
(
X
)
module
SSList
=
SortedList
.
Make
_transp
(
struct
type
'
a
t
=
'
a
SList
.
t
*
'
a
SList
.
t
let
compare
(
x1
,
y1
)
(
x2
,
y2
)
=
...
...
@@ -53,24 +53,27 @@ module Make(X : SortedList.ARG) = struct
let
empty
=
[
]
let
full
=
[
[]
,
[]
]
let
full
=
[
([]
,
[]
)
]
let
atom
x
=
[
([
x
]
,
[]
)
]
let
atom
x
=
[
[
x
]
,
[]
]
let
may_remove
(
p1
,
n1
)
(
p2
,
n2
)
=
(
SList
.
subset
p2
p1
)
&&
(
SList
.
subset
n2
n1
)
let
cup
t
s
=
if
t
==
s
then
t
else
if
t
=
empty
then
s
else
if
s
=
empty
then
t
else
if
(
t
=
full
)
||
(
s
=
full
)
then
full
else
let
s
=
List
.
filter
(
fun
(
p
,
n
)
->
not
(
List
.
exists
(
may_remove
(
p
,
n
))
t
))
s
in
let
t
=
List
.
filter
(
fun
(
p
,
n
)
->
not
(
List
.
exists
(
may_remove
(
p
,
n
))
s
))
t
in
SSList
.
cup
s
t
else
match
(
t
,
s
)
with
|
[]
,
s
->
s
|
t
,
[]
->
t
|
[
[]
,
[]
]
,
_
|
_
,
[
[]
,
[]
]
->
full
|
_
->
let
s
=
SSList
.
filter
(
fun
(
p
,
n
)
->
not
(
SSList
.
exists
(
may_remove
(
p
,
n
))
t
))
s
in
let
t
=
SSList
.
filter
(
fun
(
p
,
n
)
->
not
(
SSList
.
exists
(
may_remove
(
p
,
n
))
s
))
t
in
SSList
.
cup
s
t
let
tot
=
ref
0
let
clean
accu
t
=
...
...
@@ -108,7 +111,7 @@ let cap s t =
then
(
SList
.
cup
p1
p2
,
SList
.
cup
n1
n2
)
::
lines
else
lines
in
clean
common
(
fold2
aux
[]
lines1
lines2
)
clean
(
SSList
.
get
common
)
(
fold2
aux
[]
(
SSList
.
get
lines1
)
(
SSList
.
get
lines2
)
)
let
diff
c1
c2
=
if
c2
==
full
then
empty
...
...
@@ -116,11 +119,11 @@ let diff c1 c2 =
else
let
c1
=
SSList
.
diff
c1
c2
in
let
line
(
p
,
n
)
=
let
acc
=
List
.
fold
_left
(
fun
acc
a
->
([]
,
[
a
])
::
acc
)
[]
p
in
let
acc
=
List
.
fold
_left
(
fun
acc
a
->
([
a
]
,
[]
)
::
acc
)
acc
n
in
let
acc
=
S
List
.
fold
(
fun
acc
a
->
([]
,
[
a
])
::
acc
)
[]
p
in
let
acc
=
S
List
.
fold
(
fun
acc
a
->
([
a
]
,
[]
)
::
acc
)
acc
n
in
SSList
.
from_list
acc
in
List
.
fold
_left
(
fun
c1
l
->
cap
c1
(
line
l
))
c1
c2
SS
List
.
fold
(
fun
c1
l
->
cap
c1
(
line
l
))
c1
c2
let
rec
map
f
t
=
...
...
@@ -135,7 +138,7 @@ let rec map f t =
SSList
.
from_list
lines
let
iter
f
t
=
List
.
iter
(
fun
(
p
,
n
)
->
List
.
iter
f
p
;
List
.
iter
f
n
)
t
SS
List
.
iter
(
fun
(
p
,
n
)
->
S
List
.
iter
f
p
;
S
List
.
iter
f
n
)
t
let
compute
~
empty
~
full
~
cup
~
cap
~
diff
~
atom
t
=
let
line
(
p
,
n
)
=
...
...
@@ -170,15 +173,17 @@ let print any f =
)
)
let
check
b
=
let
check
b
=
()
(*
SSList.check b;
List
.
iter
SS
List.iter
(fun (p,n) ->
SList.check p;
SList.check n;
assert (SList.disjoint p n)
)
b
*)
end
...
...
types/patterns.ml
View file @
c66d89b5
This diff is collapsed.
Click to expand it.
types/patterns.mli
View file @
c66d89b5
type
capture
=
string
type
fv
=
capture
SortedList
.
t
exception
Error
of
string
open
Ident
(* Pattern algebra *)
...
...
@@ -19,8 +17,8 @@ val times : node -> node -> descr
val
xml
:
node
->
node
->
descr
val
record
:
Types
.
label
->
node
->
descr
val
capture
:
capture
->
descr
val
constant
:
capture
->
Types
.
const
->
descr
val
capture
:
id
->
descr
val
constant
:
id
->
Types
.
const
->
descr
val
id
:
node
->
int
val
descr
:
node
->
descr
...
...
@@ -29,7 +27,7 @@ val fv : node -> fv
(* Pattern matching: static semantics *)
val
accept
:
node
->
Types
.
node
val
filter
:
Types
.
descr
->
node
->
(
capture
,
Types
.
node
)
SortedMap
.
t
val
filter
:
Types
.
descr
->
node
->
(
id
*
Types
.
node
)
lis
t
(*
...
...
@@ -78,7 +76,7 @@ module Compile: sig
val
make_branches
:
Types
.
descr
->
(
node
*
'
a
)
list
->
dispatcher
*
(
(
capture
,
int
)
SortedMap
.
t
*
'
a
)
array
dispatcher
*
(
int
id_map
*
'
a
)
array
val
debug_compile
:
Format
.
formatter
->
Types
.
node
->
node
list
->
unit
end
types/sortedList.ml
View file @
c66d89b5
...
...
@@ -5,6 +5,22 @@ module type ARG = sig
val
compare
:
'
a
t
->
'
a
t
->
int
end
module
type
ARG0
=
sig
type
t
val
equal
:
t
->
t
->
bool
val
hash
:
t
->
int
val
compare
:
t
->
t
->
int
end
module
Lift
(
X
:
ARG0
)
=
struct
type
'
a
t
=
X
.
t
let
equal
=
X
.
equal
let
hash
=
X
.
hash