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
2fef8c49
Commit
2fef8c49
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-07-08 15:50:08 by afrisch] Clean up: delete old system for operators
Original author: afrisch Date: 2004-07-08 15:51:05+00:00
parent
cf300014
Changes
16
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
2fef8c49
...
...
@@ -79,8 +79,6 @@ and compile_aux env tail = function
|
Typed
.
RemoveField
(
e
,
l
)
->
RemoveField
(
compile
env
tail
e
,
l
)
|
Typed
.
Dot
(
e
,
l
)
->
Dot
(
compile
env
tail
e
,
l
)
|
Typed
.
Try
(
e
,
brs
)
->
Try
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
|
Typed
.
UnaryOp
(
op
,
e
)
->
UnaryOp
(
op
,
compile
env
tail
e
)
|
Typed
.
BinaryOp
(
op
,
e1
,
e2
)
->
BinaryOp
(
op
,
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Ref
(
e
,
t
)
->
Ref
(
compile
env
tail
e
,
t
)
|
Typed
.
External
(
t
,
i
)
->
(
match
env
.
cu
with
...
...
@@ -92,6 +90,8 @@ and compile_aux env tail = function
|
arg
::
l
->
(
compile
env
false
arg
)
::
(
aux
l
)
|
[]
->
[]
in
Op
(
op
,
aux
args
)
|
Typed
.
NsTable
(
ns
,
e
)
->
NsTable
(
ns
,
compile_aux
env
tail
e
)
and
compile_abstr
env
a
=
let
fun_env
=
...
...
compile/lambda.ml
View file @
2fef8c49
...
...
@@ -58,10 +58,9 @@ type expr =
|
Validate
of
expr
*
schema_component_kind
*
string
*
U
.
t
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
|
Op
of
string
*
expr
list
|
NsTable
of
Ns
.
table
*
expr
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
...
...
@@ -198,15 +197,6 @@ module Put = struct
bits
nbits
s
15
;
expr
s
e
;
LabelPool
.
serialize
s
l
|
UnaryOp
(
op
,
e
)
->
bits
nbits
s
16
;
!
unary_op
s
op
;
expr
s
e
|
BinaryOp
(
op
,
e1
,
e2
)
->
bits
nbits
s
17
;
!
binary_op
s
op
;
expr
s
e1
;
expr
s
e2
|
Ref
(
e
,
t
)
->
bits
nbits
s
18
;
expr
s
e
;
...
...
@@ -215,6 +205,10 @@ module Put = struct
bits
nbits
s
19
;
string
s
op
;
list
expr
s
args
|
NsTable
(
ns
,
e
)
->
bits
nbits
s
20
;
Ns
.
serialize_table
s
ns
;
expr
s
e
and
branches
s
brs
=
list
(
pair
Patterns
.
Node
.
serialize
expr
)
s
brs
.
brs
;
...
...
@@ -319,15 +313,6 @@ module Get = struct
let
e
=
expr
s
in
let
l
=
LabelPool
.
deserialize
s
in
Dot
(
e
,
l
)
|
16
->
let
op
=
!
unary_op
s
in
let
e
=
expr
s
in
UnaryOp
(
op
,
e
)
|
17
->
let
op
=
!
binary_op
s
in
let
e1
=
expr
s
in
let
e2
=
expr
s
in
BinaryOp
(
op
,
e1
,
e2
)
|
18
->
let
e
=
expr
s
in
let
t
=
Types
.
Node
.
deserialize
s
in
...
...
@@ -336,6 +321,10 @@ module Get = struct
let
op
=
string
s
in
let
args
=
list
expr
s
in
Op
(
op
,
args
)
|
20
->
let
ns
=
Ns
.
deserialize_table
s
in
let
e
=
expr
s
in
NsTable
(
ns
,
e
)
|
_
->
assert
false
and
branches
s
=
...
...
compile/lambda.mli
View file @
2fef8c49
...
...
@@ -31,10 +31,9 @@ type expr =
|
Validate
of
expr
*
schema_component_kind
*
string
*
U
.
t
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
|
Op
of
string
*
expr
list
|
Op
of
string
*
expr
list
(* the string is replaced at runtime by eval function *)
|
NsTable
of
Ns
.
table
*
expr
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
...
...
compile/operators.ml
View file @
2fef8c49
open
Location
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
module
Unary
=
struct
module
Op
=
struct
type
t
=
(
loc
->
type_fun
->
type_fun
)
*
(
Value
.
t
->
Value
.
t
)
end
module
Proxy
=
Custom
.
Proxy
(
Custom
.
String
)(
Typer
)(
Op
)
include
Pool
.
NoHash
(
Proxy
)
let
register
name
make
typ
run
ser
deser
=
Proxy
.
register
name
make
{
Proxy
.
content
=
(
fun
x
->
(
typ
x
,
run
x
));
Proxy
.
serialize
=
ser
;
Proxy
.
deserialize
=
deser
};;
Typer
.
mk_unary_op
:=
(
fun
name
env
->
mk
(
Proxy
.
instantiate
name
env
));;
Typer
.
typ_unary_op
:=
(
fun
i
->
fst
(
Proxy
.
content
(
value
i
)));;
Eval
.
eval_unary_op
:=
(
fun
i
->
snd
(
Proxy
.
content
(
value
i
)));;
Lambda
.
Put
.
unary_op
:=
serialize
;;
Lambda
.
Get
.
unary_op
:=
deserialize
;;
end
module
Binary
=
struct
module
Op
=
struct
type
t
=
(
loc
->
type_fun
->
type_fun
->
type_fun
)
*
(
Value
.
t
->
Value
.
t
->
Value
.
t
)
end
module
Proxy
=
Custom
.
Proxy
(
Custom
.
String
)(
Typer
)(
Op
)
include
Pool
.
NoHash
(
Proxy
)
let
register
name
make
typ
run
ser
deser
=
Proxy
.
register
name
make
{
Proxy
.
content
=
(
fun
x
->
(
typ
x
,
run
x
));
Proxy
.
serialize
=
ser
;
Proxy
.
deserialize
=
deser
};;
Typer
.
mk_binary_op
:=
(
fun
name
env
->
mk
(
Proxy
.
instantiate
name
env
));;
Typer
.
typ_binary_op
:=
(
fun
i
->
fst
(
Proxy
.
content
(
value
i
)));;
Eval
.
eval_binary_op
:=
(
fun
i
->
snd
(
Proxy
.
content
(
value
i
)));;
Lambda
.
Put
.
binary_op
:=
serialize
;;
Lambda
.
Get
.
binary_op
:=
deserialize
;;
end
let
register
op
arity
typ
eval
=
Typer
.
register_op
op
arity
typ
;
Eval
.
register_op
op
eval
...
...
@@ -62,7 +20,7 @@ let register_unary op typ eval =
)
let
register_binary
op
typ
eval
=
register
op
1
register
op
2
(
function
|
[
tf1
;
tf2
]
->
typ
tf1
tf2
...
...
@@ -94,3 +52,8 @@ let register_op op ?(expect=Types.any) typ eval =
register_unary
op
(
fun
tf
_
_
->
let
t
=
tf
expect
true
in
typ
t
)
eval
let
register_op2
op
t1
t2
s
eval
=
register_binary
op
(
fun
tf1
tf2
_
_
->
ignore
(
tf1
t1
false
);
ignore
(
tf2
t2
false
);
s
)
eval
compile/operators.mli
View file @
2fef8c49
open
Location
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
module
Unary
:
sig
include
Custom
.
T
with
type
t
=
int
val
register
:
string
->
(
Typer
.
t
->
'
a
)
->
(
'
a
->
loc
->
type_fun
->
type_fun
)
->
(
'
a
->
Value
.
t
->
Value
.
t
)
->
(
'
a
Serialize
.
Put
.
f
)
->
(
'
a
Serialize
.
Get
.
f
)
->
unit
end
module
Binary
:
sig
include
Custom
.
T
with
type
t
=
int
val
register
:
string
->
(
Typer
.
t
->
'
a
)
->
(
'
a
->
loc
->
type_fun
->
type_fun
->
type_fun
)
->
(
'
a
->
Value
.
t
->
Value
.
t
->
Value
.
t
)
->
(
'
a
Serialize
.
Put
.
f
)
->
(
'
a
Serialize
.
Get
.
f
)
->
unit
end
val
register
:
string
->
int
->
(
type_fun
list
->
type_fun
)
->
(
Value
.
t
list
->
Value
.
t
)
->
unit
...
...
@@ -36,5 +10,9 @@ val register_binary:
string
->
(
type_fun
->
type_fun
->
type_fun
)
->
(
Value
.
t
->
Value
.
t
->
Value
.
t
)
->
unit
val
register_fun
:
string
->
Types
.
t
->
Types
.
t
->
(
Value
.
t
->
Value
.
t
)
->
unit
val
register_op
:
string
->
?
expect
:
Types
.
t
->
(
Types
.
t
->
Types
.
t
)
->
(
Value
.
t
->
Value
.
t
)
->
unit
val
register_op2
:
string
->
Types
.
t
->
Types
.
t
->
Types
.
t
->
(
Value
.
t
->
Value
.
t
->
Value
.
t
)
->
unit
driver/cduce.ml
View file @
2fef8c49
...
...
@@ -343,16 +343,13 @@ let eval s =
print_exn
ppf
exn
;
Format
.
fprintf
ppf
"@."
;
Value
.
failwith'
(
Buffer
.
contents
b
)
let
()
=
let
()
=
Operators
.
register_fun
"eval_expr"
Builtin_defs
.
string_latin1
Types
.
any
(
fun
v
->
match
eval
(
Value
.
cduce2ocaml_string
v
)
with
|
[
(
None
,
v
)
]
->
v
|
_
->
Value
.
failwith'
"eval: the string must evaluate to a single value"
)
(
fun
v
->
match
eval
(
Value
.
cduce2ocaml_string
v
)
with
|
[
(
None
,
v
)
]
->
v
|
_
->
Value
.
failwith'
"eval: the string must evaluate to a single value"
)
parser/ast.ml
View file @
2fef8c49
...
...
@@ -70,7 +70,7 @@ and pexpr =
(* Other *)
|
NamespaceIn
of
U
.
t
*
Ns
.
t
*
pexpr
|
Forget
of
pexpr
*
ppat
|
Op
of
string
*
pexpr
list
(*
| Op of string * pexpr list
*)
|
Ref
of
pexpr
*
ppat
|
External
of
string
*
ppat
list
...
...
parser/parser.ml
View file @
2fef8c49
...
...
@@ -88,6 +88,9 @@ let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
let
logical_and
e1
e2
=
if_then_else
e1
e2
cst_false
let
logical_or
e1
e2
=
if_then_else
e1
cst_true
e2
let
logical_not
e
=
if_then_else
e
cst_false
cst_true
let
apply_op2_noloc
op
e1
e2
=
Apply
(
Apply
(
Var
(
parse_ident
op
)
,
e1
)
,
e2
)
let
apply_op2
loc
op
e1
e2
=
exp
loc
(
apply_op2_noloc
op
e1
e2
)
EXTEND
...
...
@@ -240,18 +243,17 @@ EXTEND
|
"<<"
->
"<"
|
">>"
->
">"
|
s
->
s
in
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
apply_op2
loc
op
e1
e2
]
|
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
apply_op2
loc
op
e1
e2
|
e1
=
expr
;
"||"
;
e2
=
expr
->
exp
loc
(
logical_or
e1
e2
)
|
e
=
expr
;
"
\\
"
;
l
=
[
IDENT
|
keyword
]
->
exp
loc
(
RemoveField
(
e
,
label
l
))
]
|
[
e1
=
expr
;
op
=
[
"*"
];
e2
=
expr
->
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
[
e1
=
expr
;
op
=
[
"*"
];
e2
=
expr
->
apply_op2
loc
op
e1
e2
|
e1
=
expr
;
"&&"
;
e2
=
expr
->
exp
loc
(
logical_and
e1
e2
)
|
e
=
expr
;
op
=
"/"
;
p
=
pat
LEVEL
"simple"
->
let
tag
=
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
any
)))
in
...
...
@@ -267,14 +269,9 @@ EXTEND
[
e
=
expr
;
"."
;
l
=
[
IDENT
|
keyword
]
->
exp
loc
(
Dot
(
e
,
label
l
))
]
|
[
op
=
[
IDENT
"print_xml"
|
IDENT
"print_xml_utf8"
];
e
=
expr
->
exp
loc
(
Op
(
op
,
[
e
]))
|
op
=
[
IDENT
"dump_to_file"
|
IDENT
"dump_to_file_utf8"
];
e1
=
expr
LEVEL
"no_appl"
;
e2
=
expr
->
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e1
=
SELF
;
IDENT
"div"
;
e2
=
expr
->
exp
loc
(
Op
(
"/"
,
[
e1
;
e2
]))
|
e1
=
SELF
;
IDENT
"mod"
;
e2
=
expr
->
exp
loc
(
Op
(
"mod"
,
[
e1
;
e2
]))
|
[
e1
=
SELF
;
IDENT
"div"
;
e2
=
expr
->
apply_op2
loc
"/"
e1
e2
|
e1
=
SELF
;
IDENT
"mod"
;
e2
=
expr
->
apply_op2
loc
"mod"
e1
e2
|
e1
=
SELF
;
e2
=
expr
->
exp
loc
(
Apply
(
e1
,
e2
))
]
...
...
@@ -291,7 +288,7 @@ EXTEND
match
x
with
|
`String
(
loc
,
i
,
j
,
s
)
->
exp
loc
(
String
(
i
,
j
,
s
,
q
))
|
`Elems
((
loc
,_
)
,
x
)
->
exp
(
loc
,
loc_end
)
(
Pair
(
x
,
q
))
|
`Explode
x
->
Op
(
"@"
,
[
x
;
q
])
|
`Explode
x
->
apply_op2_noloc
"@"
x
q
)
l
e
in
exp
loc
l
...
...
query/query.ml
View file @
2fef8c49
...
...
@@ -128,8 +128,6 @@ let rec string_of_pexpr x =
in
match
x
with
|
Integer
i
->
string_of_int
(
Intervals
.
V
.
get_int
(
i
))
|
Atom
a
->
"`"
^
U
.
get_str
(
a
)
|
Op
(
op
,
[
e1
;
e2
])
->
string_of_pexpr
e1
^
" "
^
op
^
" "
^
string_of_pexpr
e2
|
Op
(
op
,
[
e1
])
->
op
^
"("
^
string_of_pexpr
e1
^
") "
|
Var
(
s
)
->
U
.
get_str
(
s
)
|
Xml
(
e1
,
e2
)
->
" <"
^
string_of_pexpr
e1
^
">"
^
string_of_pexpr
e2
|
Pair
(
e1
,
e2
)
->
"("
^
string_of_pexpr
e1
^
","
^
string_of_pexpr
e2
^
")"
...
...
@@ -157,8 +155,6 @@ let rec string_of_pexpr x =
let
rec
var_of_pexpr
x
=
match
x
with
LocatedExpr
(
_
,
x
)
->
var_of_pexpr
x
|
Op
(
_
,
[
e1
;
e2
])
->
var_of_pexpr
e1
@
var_of_pexpr
e2
|
Op
(
_
,
[
e1
])
->
var_of_pexpr
e1
|
Var
(
s
)
->
[
ident
s
]
|
Pair
(
e1
,
e2
)
->
var_of_pexpr
e1
@
var_of_pexpr
e2
|
Apply
(
e1
,
e2
)
->
var_of_pexpr
e2
...
...
query/query_parse.ml
View file @
2fef8c49
...
...
@@ -24,6 +24,8 @@ let rec multi_prod loc = function
let
if_then_else
cond
e1
e2
=
Match
(
cond
,
[
pat_true
,
e1
;
pat_false
,
e2
])
let
op2
op
e1
e2
=
Apply
(
Apply
(
Var
(
U
.
mk
op
)
,
e1
)
,
e2
)
EXTEND
GLOBAL
:
expr
pat
keyword
;
...
...
@@ -58,8 +60,7 @@ EXTEND
|
e
=
expr
;
"//"
;
p
=
pat
->
(* projections sur tous les descendants *)
let
assign
=
exp
loc
(
Apply
(
Dot
(
Var
(
U
.
mk
"$stack"
)
,
U
.
mk
"set"
)
,
(
Op
(
"@"
,
[(
Apply
(
Dot
(
Var
(
U
.
mk
"$stack"
)
,
U
.
mk
"get"
)
,
cst_nil
));
Pair
(
Var
(
U
.
mk
"$$$"
)
,
cst_nil
)]))))
(
op2
"@"
(
Apply
(
Dot
(
Var
(
U
.
mk
"$stack"
)
,
U
.
mk
"get"
)
,
cst_nil
))
(
Pair
(
Var
(
U
.
mk
"$$$"
)
,
cst_nil
)))))
in
let
branche
=
Pair
(
Var
(
Id
.
value
id_dummy
)
,
cst_nil
)
in
let
branches
=
exp
loc
(
Match
(
assign
,
[
pat_nil
,
branche
]))
in
let
xt
=
exp
loc
(
Xtrans
(
e
,
[(
mk
loc
(
And
(
mk
loc
(
PatVar
(
U
.
mk
"$$$"
))
,
p
)))
,
branches
]))
...
...
@@ -100,8 +101,7 @@ EXTEND
fun_body
=
[
(
mk
loc
(
Prod
(
mk
loc
(
PatVar
(
s
))
,
mk
loc
(
Regexp
(
Elem
(
mk
loc
(
PatVar
(
h
)))
,
mk
loc
(
PatVar
(
t
))))))
,
exp
loc
(
if_then_else
(
exp
loc
(
Op
(
"="
,
[(
exp
loc
(
Var
(
s
)));(
exp
loc
(
Var
(
h
)))])))
cst_true
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"member"
))
,
exp
loc
(
if_then_else
(
op2
"="
(
Var
s
)
(
Var
h
))
cst_true
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"member"
))
,
exp
loc
(
Pair
(
exp
loc
(
Var
(
s
))
,
exp
loc
(
Var
(
t
)))))))));(
any
,
cst_false
)]}
in
let
e
=
exp
loc
(
Abstraction
abst
)
in
((
exp
loc
(
Match
(
e
,
[
p
,
exp
loc
(
Apply
(
exp
loc
...
...
@@ -130,7 +130,7 @@ EXTEND
fun_iface
=
[
multi_prod
loc
[
mk
loc
(
Regexp
(
Star
(
Elem
(
int
))
,
pat_nil
));
int
]
,
int
];
fun_body
=
[
(
mk
loc
(
Prod
(
mk
loc
(
Regexp
(
Elem
(
mk
loc
(
PatVar
(
h
)))
,
mk
loc
(
PatVar
(
t
))))
,
mk
loc
(
PatVar
(
a
))))
,
exp
loc
(
if_then_else
(
exp
loc
(
Op
(
">"
,
[(
exp
loc
(
Var
(
a
)
));(
exp
loc
(
Var
(
h
))
)])))
exp
loc
(
if_then_else
(
op2
">"
(
Var
a
)
(
Var
h
))
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"aux"
))
,
exp
loc
(
Pair
(
exp
loc
(
Var
(
t
))
,
exp
loc
(
Var
(
h
)))))))
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"aux"
))
,
...
...
@@ -176,7 +176,7 @@ EXTEND
fun_iface
=
[
multi_prod
loc
[
mk
loc
(
Regexp
(
Star
(
Elem
(
int
))
,
pat_nil
));
int
]
,
int
];
fun_body
=
[
(
mk
loc
(
Prod
(
mk
loc
(
Regexp
(
Elem
(
mk
loc
(
PatVar
(
h
)))
,
mk
loc
(
PatVar
(
t
))))
,
mk
loc
(
PatVar
(
a
))))
,
exp
loc
(
if_then_else
(
exp
loc
(
Op
(
"<"
,
[(
exp
loc
(
Var
(
a
)
));(
exp
loc
(
Var
(
h
))
)])))
exp
loc
(
if_then_else
(
op2
"<"
(
Var
a
)
(
Var
h
))
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"aux"
))
,
exp
loc
(
Pair
(
exp
loc
(
Var
(
t
))
,
exp
loc
(
Var
(
h
)))))))
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"aux"
))
,
...
...
@@ -223,7 +223,7 @@ EXTEND
fun_body
=
[
(
mk
loc
(
Prod
(
mk
loc
(
Regexp
(
Elem
(
mk
loc
(
PatVar
(
h
)))
,
mk
loc
(
PatVar
(
t
))))
,
mk
loc
(
PatVar
(
a
))))
,
(
exp
loc
(
Apply
(
exp
loc
(
Var
(
U
.
mk
"aux"
))
,
exp
loc
(
Pair
(
exp
loc
(
Var
(
t
))
,
exp
loc
(
Op
(
"+"
,
[(
exp
loc
(
Var
(
a
)
));(
exp
loc
(
Var
(
h
)))
]
)))
))))
exp
loc
(
Pair
(
exp
loc
(
Var
(
t
))
,
op2
"+"
(
Var
a
)
(
Var
h
))))))
);
(
mk
loc
(
Prod
(
any
,
mk
loc
(
PatVar
(
a
))))
,
exp
loc
(
Var
(
a
)))
]}
in
...
...
runtime/eval.ml
View file @
2fef8c49
...
...
@@ -3,8 +3,7 @@ open Run_dispatch
open
Ident
open
Lambda
let
eval_unary_op
=
ref
(
fun
_
->
assert
false
)
let
eval_binary_op
=
ref
(
fun
_
_
->
assert
false
)
let
ns_table
=
ref
Ns
.
empty_table
let
ops
=
Hashtbl
.
create
13
let
register_op
=
Hashtbl
.
add
ops
...
...
@@ -124,14 +123,19 @@ let rec eval env = function
|
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
UnaryOp
(
op
,
e
)
->
!
eval_unary_op
op
(
eval
env
e
)
|
BinaryOp
(
op
,
e1
,
e2
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
!
eval_binary_op
op
v1
v2
|
Validate
(
e
,
kind
,
schema
,
name
)
->
eval_validate
env
e
kind
schema
name
|
Ref
(
e
,
t
)
->
eval_ref
env
e
t
|
Op
(
op
,
args
)
->
eval_op
op
(
List
.
map
(
eval
env
)
args
)
|
Op
(
op
,
args
)
as
e
->
let
args
=
List
.
map
(
eval
env
)
args
in
(* eval_op op args *)
if
Obj
.
tag
(
Obj
.
repr
op
)
=
Obj
.
string_tag
then
let
eval_fun
=
eval_op
op
in
Obj
.
set_field
(
Obj
.
repr
e
)
0
(
Obj
.
repr
eval_fun
);
eval_fun
args
else
(
Obj
.
magic
op
)
args
|
NsTable
(
ns
,
e
)
->
ns_table
:=
ns
;
eval
env
e
and
eval_abstraction
env
slots
iface
body
=
let
local_env
=
Array
.
map
(
eval_var
env
)
slots
in
...
...
runtime/eval.mli
View file @
2fef8c49
...
...
@@ -2,8 +2,8 @@ open Value
open
Ident
open
Lambda
val
eval_unary_op
:
(
int
->
(
t
->
t
))
ref
val
eval_binary_op
:
(
int
->
(
t
->
t
->
t
))
ref
val
ns_table
:
Ns
.
table
ref
val
register_op
:
string
->
(
t
list
->
t
)
->
unit
val
get_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
)
ref
...
...
types/builtin.ml
View file @
2fef8c49
...
...
@@ -35,14 +35,7 @@ let env =
open
Operators
let
binary_op_gen
name
typ
run
=
Binary
.
register
name
(
fun
_
->
()
)
(
fun
()
->
typ
)
(
fun
()
->
run
)
(
fun
s
()
->
()
)
(
fun
s
->
()
)
let
binary_op_gen
=
register_binary
let
unary_op_gen
=
register_unary
...
...
@@ -50,25 +43,20 @@ let unary_op_gen = register_unary
let
binary_op
name
t1
t2
f
run
=
binary_op_gen
name
(
fun
loc
arg1
arg2
constr
precise
->
(
fun
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_cst
=
register_op2
let
binary_op_warning2
name
t1
t2
w2
t
run
=
binary_op_gen
name
(
fun
loc
arg1
arg2
constr
precise
->
(
fun
arg1
arg2
constr
precise
->
ignore
(
arg1
t1
false
);
let
r
=
arg2
t2
true
in
if
not
(
Types
.
subtype
r
w2
)
then
Typer
.
w
arning
loc
"This operator may fail"
;
raise
(
Typer
.
W
arning
(
"This operator may fail"
,
t
))
;
t
)
run
...
...
@@ -192,23 +180,13 @@ register_fun "argv" nil (Sequence.star string_latin1)
!
argv
);;
Unary
.
register
"print_xml"
(
fun
tenv
->
Typer
.
get_ns_table
tenv
)
(
fun
ns_table
loc
arg
constr
precise
->
ignore
(
arg
Types
.
any
false
);
string_latin1
)
(
Print_xml
.
print_xml
~
utf8
:
false
)
Ns
.
serialize_table
Ns
.
deserialize_table
;;
Unary
.
register
"print_xml_utf8"
(
fun
tenv
->
Typer
.
get_ns_table
tenv
)
(
fun
ns_table
loc
arg
constr
precise
->
ignore
(
arg
Types
.
any
false
);
string
)
(
Print_xml
.
print_xml
~
utf8
:
true
)
Ns
.
serialize_table
Ns
.
deserialize_table
;;
register_fun
"print_xml"
Types
.
any
string_latin1
(
fun
v
->
Print_xml
.
print_xml
~
utf8
:
false
!
Eval
.
ns_table
v
);;
register_fun
"print_xml_utf8"
Types
.
any
string
(
fun
v
->
Print_xml
.
print_xml
~
utf8
:
true
!
Eval
.
ns_table
v
);;
register_fun
"print"
string_latin1
nil
...
...
@@ -264,7 +242,7 @@ binary_op_cst "dump_to_file_utf8"
(* Integer operators *)
binary_op_gen
"+"
(
fun
loc
arg1
arg2
constr
precise
->
(
fun
arg1
arg2
constr
precise
->
let
t1
=
arg1
(
Types
.
cup
int
Types
.
Record
.
any
)
true
in
if
Types
.
subtype
t1
int
then
(
...
...
@@ -277,7 +255,7 @@ binary_op_gen "+"
let
t2
=
arg2
Types
.
Record
.
any
true
in
Types
.
Record
.
merge
t1
t2
)
else
Typer
.
e
rror
loc
"The first argument mixes integers and records"
)
else
raise
(
Typer
.
E
rror
"The first argument mixes integers and records"
)
)
(
fun
v1
v2
->
match
(
v1
,
v2
)
with
|
(
Value
.
Integer
x
,
Value
.
Integer
y
)
->
Value
.
Integer
(
Intervals
.
V
.
add
x
y
)
|
(
Value
.
Record
r1
,
Value
.
Record
r2
)
->
Value
.
Record
(
LabelMap
.
merge
(
fun
x
y
->
y
)
r1
r2
)
...
...
@@ -312,7 +290,7 @@ binary_op_cst "mod"
binary_op_gen
"@"
(
fun
loc
arg1
arg2
constr
precise
->
(
fun
arg1
arg2
constr
precise
->
let
constr'
=
Sequence
.
star
(
Sequence
.
approx
(
Types
.
cap
Sequence
.
any
constr
))
in
let
exact
=
Types
.
subtype
constr'
constr
in
...
...
@@ -336,4 +314,3 @@ unary_op_gen "flatten"
register_fun
"raise"
any
Types
.
empty
(
fun
v
->
raise
(
Value
.
CDuceExn
v
));;
typing/typed.ml
View file @
2fef8c49
...
...
@@ -49,11 +49,10 @@ and texpr' =
(* Exception *)
|
Try
of
texpr
*
branches
|
UnaryOp
of
int
*
texpr
|
BinaryOp
of
int
*
texpr
*
texpr
|
Ref
of
texpr
*
ttyp
|
External
of
Types
.
t
*
int
|
Op
of
string
*
int
*
texpr
list
|
NsTable
of
Ns
.
table
*
texpr'
and
abstr
=
{
fun_name
:
id
option
;
...
...
typing/typer.ml
View file @
2fef8c49
...
...
@@ -843,12 +843,6 @@ let pat env p =
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
let
typ_cst
=
ref
(
fun
_
->
assert
false
)
let
mk_unary_op
=
ref
(
fun
_
_
->
assert
false
)
let
typ_unary_op
=
ref
(
fun
_
_
_
->
assert
false
)
let
mk_binary_op
=
ref
(
fun
_
_
->
assert
false
)
let
typ_binary_op
=
ref
(
fun
_
_
_
_
->
assert
false
)
module
Fv
=
IdSet
...
...
@@ -913,15 +907,6 @@ let rec expr env loc = function
|
String
(
i
,
j
,
s
,
e
)
->
let
(
fv
,
e
)
=
expr
env
loc
e
in
exp
loc
fv
(
Typed
.
String
(
i
,
j
,
s
,
e
))
|
Op
(
op
,
le
)
->
let
(
fvs
,
ltes
)
=
List
.
split
(
List
.
map
(
expr
env
loc
)
le
)
in
let
fv
=
List
.
fold_left
Fv
.
cup
Fv
.
empty
fvs
in
(
try
(
match
ltes
with
|
[
e
]
->
exp
loc
fv
(
Typed
.
UnaryOp
(
!
mk_unary_op
op
env
,
e
))
|
[
e1
;
e2
]
->
exp
loc
fv
(
Typed
.
BinaryOp
(
!
mk_binary_op
op
env
,
e1
,
e2
))
|
_
->
assert
false
)
with
Not_found
->
assert
false
)
|
Match
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
env
loc
e
and
(
fv2
,
b
)
=
branches
env
b
in
...
...
@@ -964,7 +949,11 @@ and extern loc env s args =
and
var
env
loc
s
=
match
is_op
env
s
with
|
Some
(
s
,
arity
)
->
exp
loc
Fv
.
empty
(
Typed
.
Op
(
s
,
arity
,
[]
))
|
Some
(
s
,
arity
)
->
let
need_ns
=
s
=
"print_xml"
||
s
=
"print_xml_utf8"
in
let
e
=
Typed
.
Op
(
s
,
arity
,
[]
)
in
let
e
=
if
need_ns
then
Typed
.
NsTable
(
env
.
ns
,
e
)
else
e
in
exp
loc
Fv
.
empty
e
|
None
->
match
Ns
.
split_qname
s
with
|
""
,
id
->
...
...
@@ -1175,15 +1164,6 @@ and type_check' loc env e constr precise = match e with
in
verify
loc
res
constr
|
UnaryOp
(
o
,
e
)
->
let
t
=
!
typ_unary_op
o
loc
(
type_check
env
e
)
constr
precise
in
verify
loc
t
constr
|
BinaryOp
(
o
,
e1
,
e2
)
->
let
t
=
!
typ_binary_op
o
loc
(
type_check
env
e1
)
(
typ