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
8b575b91
Commit
8b575b91
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-05-25 10:34:50 by cvscast] review Builtin
Original author: cvscast Date: 2003-05-25 10:34:50+00:00
parent
25a01d55
Changes
14
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
8b575b91
...
...
@@ -47,7 +47,7 @@ OBJECTS = \
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo
\
types/types.cmo types/patterns.cmo types/sequence.cmo
types/builtin.cmo
\
types/types.cmo types/patterns.cmo types/sequence.cmo
\
types/sample.cmo
\
\
parser/location.cmo parser/wlexer.cmo parser/ast.cmo parser/parser.cmo
\
...
...
@@ -57,7 +57,7 @@ OBJECTS = \
runtime/value.cmo runtime/load_xml.cmo runtime/run_dispatch.cmo
\
runtime/print_xml.cmo runtime/eval.cmo
\
\
driver/cduce.cmo
types/builtin.cmo
driver/cduce.cmo
CDUCE
=
$(OBJECTS)
driver/run.cmo
WEBIFACE
=
$(OBJECTS)
driver/examples.cmo driver/webiface.cmo
...
...
depend
View file @
8b575b91
...
...
@@ -12,38 +12,42 @@ 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/
builtin
.cm
o
\
types/chars.cmi
misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/
chars
.cm
i
\
misc/encodings.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/
builtin
.cmx \
types/chars.cmx
misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/
chars
.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/location.cmx types/sequence.cmx types/types.cmx parser/wlexer.cmx \
parser/parser.cmi
parser/wlexer.cmo: misc/encodings.cmi parser/location.cmi
parser/wlexer.cmx: misc/encodings.cmx parser/location.cmx
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi
types/types.cmi
runtime/value.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/
builtin
.cmo \
types/ident.cmo
types/intervals.cmi parser/location.cmi \
types/patterns.cmi
types/sequence.cmi misc/state.cmi typing/typed.cmo \
types/types.cmi
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/
builtin
.cmx \
types/ident.cmx
types/intervals.cmx parser/location.cmx \
types/patterns.cmx
types/sequence.cmx misc/state.cmx typing/typed.cmx \
types/types.cmx
typing/typer.cmi
types/types.cmx
runtime/value.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/
ident
.cmo \
types/intervals.cmi parser/location.cmi
types/patterns.cmi
\
types/sequence.cmi misc/state.cmi typing/typed.cmo
types/types.cmi
\
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/
ident
.cmx \
types/intervals.cmx parser/location.cmx
types/patterns.cmx
\
types/sequence.cmx misc/state.cmx typing/typed.cmx
types/types.cmx
\
typing/typer.cmi
types/atoms.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
types/atoms.cmi
types/atoms.cmx: misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
types/atoms.cmi
types/boolean.cmo: types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx types/boolean.cmi
types/builtin.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
types/types.cmi
types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
types/types.cmx
types/builtin.cmo: types/atoms.cmi types/chars.cmi runtime/eval.cmi \
types/ident.cmo runtime/load_xml.cmi parser/location.cmi \
runtime/print_xml.cmo types/sequence.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi
types/builtin.cmx: types/atoms.cmx types/chars.cmx runtime/eval.cmx \
types/ident.cmx runtime/load_xml.cmx parser/location.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/ident.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi
...
...
@@ -90,12 +94,12 @@ runtime/run_dispatch.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
runtime/run_dispatch.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/value.cmo: types/atoms.cmi types/
builtin.cmo types/char
s.cmi \
misc/encodings.cmi
types/ident.cmo types/intervals.cmi types/sequence.cmi \
types/types.cmi
runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/
builtin.cmx types/char
s.cmx \
misc/encodings.cmx
types/ident.cmx types/intervals.cmx types/sequence.cmx \
types/types.cmx
runtime/value.cmi
runtime/value.cmo: types/atoms.cmi types/
chars.cmi misc/encoding
s.cmi \
types/ident.cmo types/intervals.cmi types/sequence.cmi
types/types.cmi
\
runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/
chars.cmx misc/encoding
s.cmx \
types/ident.cmx types/intervals.cmx types/sequence.cmx
types/types.cmx
\
runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \
...
...
driver/cduce.ml
View file @
8b575b91
...
...
@@ -5,11 +5,11 @@ let version = "0.0.9 (alpha)"
let
quiet
=
ref
false
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Typer
.
Env
.
empty
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Env
.
empty
let
enter_global_value
x
v
t
=
Eval
.
enter_global
x
v
;
typing_env
:=
Typer
.
Env
.
add
x
t
!
typing_env
typing_env
:=
Env
.
add
x
t
!
typing_env
let
rec
is_abstraction
=
function
|
Ast
.
Abstraction
_
->
true
...
...
@@ -27,9 +27,9 @@ let dump_env ppf =
Format
.
fprintf
ppf
"Global types:"
;
Typer
.
dump_global_types
ppf
;
Format
.
fprintf
ppf
".@
\n
"
;
Eval
.
Env
.
iter
Env
.
iter
(
fun
x
v
->
let
t
=
Typer
.
Env
.
find
x
!
typing_env
in
let
t
=
Env
.
find
x
!
typing_env
in
Format
.
fprintf
ppf
"@[|- %a : %a@ => %a@]@
\n
"
U
.
print
(
Id
.
value
x
)
print_norm
t
...
...
@@ -63,7 +63,9 @@ let rec print_exn ppf = function
print_norm
t1
msg
print_norm
t2
|
Typer
.
Constraint
(
s
,
t
,
msg
)
->
|
Typer
.
Error
s
->
Format
.
fprintf
ppf
"%s@
\n
"
s
|
Typer
.
Constraint
(
s
,
t
)
->
Format
.
fprintf
ppf
"This expression should have type:@
\n
%a@
\n
"
print_norm
t
;
Format
.
fprintf
ppf
"but its inferred type is:@
\n
%a@
\n
"
...
...
@@ -72,7 +74,7 @@ let rec print_exn ppf = function
Location
.
protect
ppf
(
fun
ppf
->
Sample
.
print
ppf
(
Sample
.
get
(
Types
.
diff
s
t
)));
Format
.
fprintf
ppf
"@
\n
%s@
\n
"
msg
Format
.
fprintf
ppf
"@
\n
"
|
Typer
.
NonExhaustive
t
->
Format
.
fprintf
ppf
"This pattern matching is not exhaustive@
\n
"
;
Format
.
fprintf
ppf
"Residual type:@
\n
%a@
\n
"
...
...
@@ -131,18 +133,12 @@ let debug ppf = function
let
mk_builtin
()
=
let
bi
=
List
.
map
(
fun
(
n
,
t
)
->
[
n
,
mknoloc
(
Ast
.
Internal
t
)])
Builtin
.
types
in
List
.
iter
Typer
.
register_global_types
bi
let
()
=
mk_builtin
()
let
run
ppf
ppf_err
input
=
let
insert_type_bindings
=
List
.
iter
(
fun
(
x
,
t
)
->
typing_env
:=
Typer
.
Env
.
add
x
t
!
typing_env
;
typing_env
:=
Env
.
add
x
t
!
typing_env
;
if
not
!
quiet
then
Format
.
fprintf
ppf
"|- %a : %a@
\n
@."
U
.
print
(
Id
.
value
x
)
print_norm
t
)
in
...
...
@@ -153,7 +149,7 @@ let run ppf ppf_err input =
in
let
eval_decl
decl
=
let
bindings
=
Eval
.
eval_let_decl
Eval
.
Env
.
empty
decl
in
let
bindings
=
Eval
.
eval_let_decl
Env
.
empty
decl
in
List
.
iter
(
fun
(
x
,
v
)
->
Eval
.
enter_global
x
v
;
...
...
@@ -171,7 +167,7 @@ let run ppf ppf_err input =
Location
.
dump_loc
ppf
e
.
Typed
.
exp_loc
;
if
not
!
quiet
then
Format
.
fprintf
ppf
"|- %a@
\n
@."
print_norm
t
;
let
v
=
Eval
.
eval
Eval
.
Env
.
empty
e
in
let
v
=
Eval
.
eval
Env
.
empty
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"=> @[%a@]@
\n
@."
print_value
v
|
Ast
.
LetDecl
(
p
,
e
)
when
is_abstraction
e
->
()
...
...
parser/ast.ml
View file @
8b575b91
...
...
@@ -26,6 +26,7 @@ and pexpr =
|
LocatedExpr
of
loc
*
pexpr
|
Forget
of
pexpr
*
ppat
|
Op
of
string
*
pexpr
list
(* CDuce is a Lambda-calculus ... *)
|
Var
of
id
...
...
@@ -39,9 +40,9 @@ and pexpr =
|
RecordLitt
of
pexpr
label_map
(* Data destructors *)
|
Op
of
string
*
pexpr
list
|
Match
of
pexpr
*
branches
|
Map
of
bool
*
pexpr
*
branches
|
Map
of
pexpr
*
branches
|
Transform
of
pexpr
*
branches
|
Xtrans
of
pexpr
*
branches
|
Dot
of
pexpr
*
label
|
RemoveField
of
pexpr
*
label
...
...
parser/parser.ml
View file @
8b575b91
...
...
@@ -8,6 +8,10 @@ let () = Grammar.error_verbose := true
let
gram
=
Grammar
.
gcreate
(
Wlexer
.
lexer
Wlexer
.
token
Wlexer
.
latin1_engine
)
let
true
_atom
=
Atoms
.
mk_ascii
"true"
let
false
_atom
=
Atoms
.
mk_ascii
"false"
let
true
_type
=
Types
.
atom
(
Atoms
.
atom
true
_atom
)
let
false
_type
=
Types
.
atom
(
Atoms
.
atom
false
_atom
)
let
parse_ident
=
Encodings
.
Utf8
.
mk_latin1
...
...
@@ -145,20 +149,23 @@ EXTEND
expr
:
[
"top"
RIGHTA
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Match
(
e
,
b
))
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Match
(
e
,
b
))
|
"try"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
mknoloc
(
Capture
id_dummy
)
,
Op
(
"raise"
,
[
Var
id_dummy
])
in
Op
(
"raise"
,
[
Var
id_dummy
])
in
exp
loc
(
Try
(
e
,
b
@
[
default
]))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Map
(
false
,
e
,
b
))
|
"xtransform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Xtrans
(
e
,
b
))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Map
(
e
,
b
))
|
"xtransform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Xtrans
(
e
,
b
))
|
"if"
;
e
=
SELF
;
"then"
;
e1
=
SELF
;
"else"
;
e2
=
SELF
->
let
p1
=
mk
loc
(
Internal
(
Builtin
.
true_type
)
)
and
p2
=
mk
loc
(
Internal
(
Builtin
.
false_type
)
)
in
let
p1
=
mk
loc
(
Internal
true
_type
)
and
p2
=
mk
loc
(
Internal
false
_type
)
in
exp
loc
(
Match
(
e
,
[
p1
,
e1
;
p2
,
e2
]))
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Op
(
"flatten"
,
[
Map
(
true
,
e
,
b
)
])
)
exp
loc
(
Transform
(
e
,
b
))
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
(
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
...
...
@@ -194,7 +201,7 @@ EXTEND
let
ct
=
mk
loc
(
Regexp
(
re
,
any
))
in
let
p
=
mk
loc
(
XmlT
(
tag
,
multi_prod
loc
[
att
;
ct
]))
in
let
b
=
(
p
,
Var
id_dummy
)
in
exp
loc
(
Op
(
"flatten"
,
[
Map
(
false
,
e
,
[
b
])
])
)
exp
loc
(
Transform
(
e
,
[
b
]))
]
|
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
|
keyword
]
->
...
...
@@ -208,10 +215,10 @@ EXTEND
|
LIDENT
"load_html"
|
LIDENT
"print_xml"
|
LIDENT
"print_xml_utf8"
|
LIDENT
"print"
|
LIDENT
"raise"
|
LIDENT
"int_of"
|
LIDENT
"string_of"
|
LIDENT
"atom_of"
|
LIDENT
"raise"
];
e
=
expr
->
exp
loc
(
Op
(
op
,
[
e
]))
|
op
=
[
LIDENT
"dump_to_file"
|
LIDENT
"dump_to_file_utf8"
];
...
...
runtime/eval.ml
View file @
8b575b91
...
...
@@ -3,7 +3,6 @@ open Run_dispatch
open
Ident
exception
MultipleDeclaration
of
id
module
Env
=
Map
.
Make
(
Ident
.
Id
)
type
env
=
t
Env
.
t
let
global_env
=
State
.
ref
"Eval.global_env"
Env
.
empty
...
...
@@ -14,9 +13,6 @@ let enter_global x v =
global_env
:=
Env
.
add
x
v
!
global_env
let
exn_int_of
=
CDuceExn
(
Pair
(
Atom
(
Atoms
.
mk_ascii
"Invalid_argument"
)
,
string_latin1
"int_of"
))
let
exn_load_file_utf8
=
CDuceExn
(
Pair
(
...
...
@@ -31,7 +27,7 @@ let rec eval env e0 =
|
Typed
.
Forget
(
e
,_
)
->
eval
env
e
|
Typed
.
Var
s
->
(
try
Env
.
find
s
env
with
Not_found
->
Env
.
find
s
!
global_env
)
with
Not_found
->
Env
.
find
s
!
global_env
)
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
let
env
=
...
...
@@ -57,51 +53,22 @@ let rec eval env e0 =
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
})
->
Xml
(
eval
env
e1
,
eval
env
e2
,
eval
env
e3
)
|
Typed
.
Xml
(
_
,_
)
->
assert
false
|
Typed
.
Cst
c
->
const
c
|
Typed
.
Match
(
arg
,
brs
)
->
eval_branches
env
brs
(
eval
env
arg
)
|
Typed
.
Map
(
false
,
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
|
Typed
.
Map
(
true
,_,_
)
->
assert
false
|
Typed
.
Map
(
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
|
Typed
.
Xtrans
(
arg
,
brs
)
->
eval_xtrans
env
brs
(
eval
env
arg
)
|
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
(
true
,
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
)
|
Typed
.
Op
(
"*"
,
[
e1
;
e2
])
->
eval_mul
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"-"
,
[
e1
;
e2
])
->
eval_sub
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"/"
,
[
e1
;
e2
])
->
eval_div
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"mod"
,
[
e1
;
e2
])
->
eval_mod
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"load_xml"
,
[
e
])
->
eval_load_xml
(
eval
env
e
)
|
Typed
.
Op
(
"load_html"
,
[
e
])
->
eval_load_html
(
eval
env
e
)
|
Typed
.
Op
(
"load_file"
,
[
e
])
->
eval_load_file
~
utf8
:
false
(
eval
env
e
)
|
Typed
.
Op
(
"load_file_utf8"
,
[
e
])
->
eval_load_file
~
utf8
:
true
(
eval
env
e
)
|
Typed
.
Op
(
"print_xml"
,
[
e
])
->
Print_xml
.
print_xml
~
utf8
:
false
(
eval
env
e
)
|
Typed
.
Op
(
"print_xml_utf8"
,
[
e
])
->
Print_xml
.
print_xml
~
utf8
:
true
(
eval
env
e
)
|
Typed
.
Op
(
"print"
,
[
e
])
->
eval_print
(
eval
env
e
)
|
Typed
.
Op
(
"int_of"
,
[
e
])
->
eval_int_of
(
eval
env
e
)
|
Typed
.
Op
(
"atom_of"
,
[
e
])
->
eval_atom_of
(
eval
env
e
)
|
Typed
.
Op
(
"string_of"
,
[
e
])
->
eval_string_of
(
eval
env
e
)
|
Typed
.
Op
(
"dump_to_file"
,
[
e1
;
e2
])
->
eval_dump_to_file
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"dump_to_file_utf8"
,
[
e1
;
e2
])
->
eval_dump_to_file_utf8
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"="
,
[
e1
;
e2
])
->
eval_equal
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"<"
,
[
e1
;
e2
])
->
eval_lt
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"<="
,
[
e1
;
e2
])
->
eval_lte
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
">"
,
[
e1
;
e2
])
->
eval_gt
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
">="
,
[
e1
;
e2
])
->
eval_gte
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Try
(
arg
,
brs
)
->
(
try
eval
env
arg
with
CDuceExn
v
->
eval_branches
env
brs
v
)
|
Typed
.
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
Typed
.
Op
(
o
,
_
)
->
failwith
(
"Unknown operator "
^
o
)
|
_
->
assert
false
|
Typed
.
Unary
Op
(
o
,
e
)
->
o
.
Typed
.
un_op_eval
(
eval
env
e
)
|
Typed
.
BinaryOp
(
o
,
e1
,
e2
)
->
o
.
Typed
.
bin_op_eval
(
eval
env
e1
)
(
eval
env
e2
)
and
eval_apply
f
arg
=
match
f
with
|
Abstraction
(
_
,
clos
)
->
clos
arg
|
_
->
eval_concat
f
arg
|
_
->
assert
false
and
eval_branches'
env_ref
brs
arg
=
eval_branches
!
env_ref
brs
arg
...
...
@@ -132,14 +99,11 @@ and eval_map env brs = function
eval_map
env
brs
(
normalize
v
)
|
q
->
q
and
eval_flatten
=
function
|
Pair
(
x
,
y
)
->
eval_concat
x
(
eval_flatten
y
)
|
q
->
q
and
eval_transform
env
brs
=
function
|
Pair
(
x
,
y
)
->
let
x
=
match
eval_branches
env
brs
x
with
Value
.
Absent
->
Value
.
nil
|
x
->
x
in
eval_
concat
x
(
eval_transform
env
brs
y
)
concat
x
(
eval_transform
env
brs
y
)
|
String_latin1
(
_
,_,_,
q
)
|
String_utf8
(
_
,_,_,
q
)
as
v
->
if
Types
.
Char
.
is_empty
(
brs
.
Typed
.
br_accept
)
then
eval_transform
env
brs
q
...
...
@@ -167,15 +131,9 @@ and eval_xtrans env brs = function
Pair
(
x
,
y
)
|
x
->
let
y
=
eval_xtrans
env
brs
y
in
eval_
concat
x
y
)
concat
x
y
)
|
q
->
q
and
eval_concat
l1
l2
=
match
l1
with
|
Pair
(
x
,
y
)
->
Pair
(
x
,
eval_concat
y
l2
)
|
String_latin1
(
s
,
i
,
j
,
q
)
->
String_latin1
(
s
,
i
,
j
,
eval_concat
q
l2
)
|
String_utf8
(
s
,
i
,
j
,
q
)
->
String_utf8
(
s
,
i
,
j
,
eval_concat
q
l2
)
|
q
->
l2
and
eval_dot
l
=
function
|
Record
r
->
LabelMap
.
assoc
l
r
|
_
->
assert
false
...
...
@@ -183,102 +141,3 @@ and eval_dot l = function
and
eval_remove_field
l
=
function
|
Record
r
->
Record
(
LabelMap
.
remove
l
r
)
|
_
->
assert
false
and
eval_add
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vadd
x
y
)
|
Record
r1
,
Record
r2
->
Record
(
LabelMap
.
merge
(
fun
x
y
->
y
)
r1
r2
)
|
_
->
assert
false
and
eval_mul
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vmult
x
y
)
|
_
->
assert
false
and
eval_sub
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vsub
x
y
)
|
_
->
assert
false
and
eval_div
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vdiv
x
y
)
|
_
->
assert
false
and
eval_mod
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vmod
x
y
)
|
_
->
assert
false
and
eval_load_xml
e
=
Load_xml
.
load_xml
(
get_string_latin1
e
)
(* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
encoding has a non negligible overhead with PXP *)
and
eval_load_html
e
=
Load_xml
.
load_html
(
get_string_latin1
e
)
and
eval_load_file
~
utf8
e
=
Location
.
protect_op
"load_file"
;
let
ic
=
open_in
(
get_string_latin1
e
)
in
let
len
=
in_channel_length
ic
in
let
s
=
String
.
create
len
in
really_input
ic
s
0
len
;
close_in
ic
;
if
utf8
then
if
U
.
check
s
then
Value
.
string_utf8
(
U
.
mk
s
)
else
raise
exn_load_file_utf8
else
Value
.
string_latin1
s
and
eval_int_of
e
=
let
(
s
,_
)
=
get_string_utf8
e
in
try
Integer
(
Intervals
.
mk
(
U
.
get_str
s
))
(* UTF-8 is ASCII compatible ! *)
with
Failure
_
->
raise
exn_int_of
and
eval_atom_of
e
=
let
(
s
,_
)
=
get_string_utf8
e
in
(* TODO: check that s is a correct Name wrt XML *)
Atom
(
Atoms
.
mk
s
)
and
eval_print
v
=
Location
.
protect_op
"print"
;
print_string
(
get_string_latin1
v
);
flush
stdout
;
Value
.
nil
and
eval_dump_to_file
f
v
=
Location
.
protect_op
"dump_to_file"
;
let
oc
=
open_out
(
get_string_latin1
f
)
in
output_string
oc
(
get_string_latin1
v
);
close_out
oc
;
Value
.
nil
and
eval_dump_to_file_utf8
f
v
=
Location
.
protect_op
"dump_to_file_utf8"
;
let
oc
=
open_out
(
get_string_latin1
f
)
in
let
(
v
,_
)
=
get_string_utf8
v
in
output_string
oc
(
U
.
get_str
v
);
close_out
oc
;
Value
.
nil
and
eval_string_of
v
=
let
b
=
Buffer
.
create
16
in
let
ppf
=
Format
.
formatter_of_buffer
b
in
Value
.
print
ppf
v
;
Format
.
pp_print_flush
ppf
()
;
string_latin1
(
Buffer
.
contents
b
)
and
eval_equal
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
==
0
)
and
eval_lt
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
<
0
)
and
eval_lte
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
<=
0
)
and
eval_gt
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
>
0
)
and
eval_gte
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
>=
0
)
runtime/eval.mli
View file @
8b575b91
...
...
@@ -2,7 +2,6 @@ open Value
open
Ident
exception
MultipleDeclaration
of
id
module
Env
:
Map
.
S
with
type
key
=
id
type
env
=
t
Env
.
t
val
global_env
:
env
ref
...
...
runtime/value.ml
View file @
8b575b91
...
...
@@ -19,14 +19,24 @@ exception CDuceExn of t
let
nil
=
Atom
Sequence
.
nil_atom
let
string_latin1
s
=
String_latin1
(
0
,
String
.
length
s
,
s
,
nil
)
let
string_utf8
s
=
String_utf8
(
Utf8
.
start_index
s
,
Utf8
.
end_index
s
,
s
,
nil
)
let
vtrue
=
Atom
Builtin
.
true_atom
let
vfalse
=
Atom
Builtin
.
false_atom
let
vtrue
=
Atom
(
Atoms
.
mk_ascii
"true"
)
let
vfalse
=
Atom
(
Atoms
.
mk_ascii
"false"
)
let
vbool
x
=
if
x
then
vtrue
else
vfalse
let
rec
sequence
=
function
|
[]
->
nil
|
h
::
t
->
Pair
(
h
,
sequence
t
)
let
rec
concat
l1
l2
=
match
l1
with
|
Pair
(
x
,
y
)
->
Pair
(
x
,
concat
y
l2
)
|
String_latin1
(
s
,
i
,
j
,
q
)
->
String_latin1
(
s
,
i
,
j
,
concat
q
l2
)
|
String_utf8
(
s
,
i
,
j
,
q
)
->
String_utf8
(
s
,
i
,
j
,
concat
q
l2
)
|
q
->
l2
let
rec
flatten
=
function
|
Pair
(
x
,
y
)
->
concat
x
(
flatten
y
)
|
q
->
q
let
const
=
function
|
Types
.
Integer
i
->
Integer
i
|
Types
.
Atom
a
->
Atom
a
...
...
runtime/value.mli
View file @
8b575b91
...
...
@@ -35,6 +35,8 @@ val vfalse : t
val
vbool
:
bool
->
t
val
sequence
:
t
list
->
t
val
concat
:
t
->
t
->
t
val
flatten
:
t
->
t
val
get_string_latin1
:
t
->
string
val
get_string_utf8
:
t
->
U
.
t
*
t
...
...
types/builtin.ml
View file @
8b575b91
...
...
@@ -18,22 +18,302 @@ let true_type = Types.atom (Atoms.atom true_atom)
let
false
_type
=
Types
.
atom
(
Atoms
.
atom
false
_atom
)
let
bool
=
Types
.
cup
true
_type
false
_type
let
nil
=
Sequence
.
nil_type
let
string
=
Sequence
.
string
let
any
=
Types
.
any
let
int
=
Types
.
Int
.
any
let
atom
=
Types
.
atom
Atoms
.
any
let
char_latin1
=
Types
.
char
(
Chars
.
mk_classes
[
(
0
,
255
)
])
let
string_latin1
=
Sequence
.
star
char_latin1
(* Types *)
let
types
=
[
"Empty"
,
Types
.
empty
;
"Any"
,
Types
.
any
;
"Int"
,
Types
.
Int
.
any
;
"Any"
,
any
;
"Int"
,
int
;
"Char"
,
Types
.
char
Chars
.
any
;
"Byte"
,
char_latin1
;
"Atom"
,
Types
.
atom
Atoms
.
any
;
"Atom"
,
atom
;
"Pair"
,
Types
.
Product
.
any
;
"Arrow"
,
Types
.
Arrow
.
any
;
"Record"
,
Types
.
Record
.
any
;
"String"
,
Sequence
.
string
;
"String"
,
string
;
"Latin1"
,
string_latin1
;
"Bool"
,
bool
];
]
let
()
=
List
.
iter
(
fun
(
n
,
t
)
->
Typer
.
register_global_types
[
n
,
Location
.
mknoloc
(
Ast
.
Internal
t
)])
types
(* Operators *)
let
binary_op_gen
name
typ
run
=
Typed
.
register_op
name
(
`Binary
{
Typed
.
bin_op_typer
=
typ
;
Typed
.
bin_op_eval
=
run
})
let
unary_op_gen
name
typ
run
=
Typed
.
register_op
name
(
`Unary
{
Typed
.
un_op_typer
=
typ
;
Typed
.
un_op_eval
=
run
})
let
binary_op
name
t1
t2
f
run
=
binary_op_gen
name
(
fun
loc
arg1
arg2
constr
precise
->
f
(
arg1
t1
true
)
(
arg2
t2
true
))
run
let
binary_op_cst
name
t1
t2
t
run
=
binary_op_gen
name
(
fun
loc
arg1
arg2
constr
precise
->
ignore
(
arg1
t1
false
);
ignore
(
arg2
t2
false
);
t
)
run
let
binary_op_warning2
name
t1
t2
w2
t
run
=
binary_op_gen
name
(
fun
loc
arg1
arg2
constr
precise
->
ignore
(
arg1
t1
false
);
let
r
=
arg2
t2
true
in
if
not
(
Types
.
subtype
r
w2
)
then
Typer
.
warning
loc
"This operator may fail"