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
b31535c1
Commit
b31535c1
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-07-08 11:54:48 by afrisch] New system for operators
Original author: afrisch Date: 2004-07-08 11:54:50+00:00
parent
e87d00fa
Changes
11
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
b31535c1
...
...
@@ -86,6 +86,12 @@ and compile_aux env tail = function
(
match
env
.
cu
with
|
Some
cu
->
Var
(
External
(
cu
,
i
))
|
None
->
failwith
"Cannot compile externals in the toplevel"
)
|
Typed
.
Op
(
op
,
args
)
->
let
rec
aux
=
function
|
[
arg
]
->
[
compile
env
tail
arg
]
|
arg
::
l
->
(
compile
env
false
arg
)
::
(
aux
l
)
|
[]
->
[]
in
Op
(
op
,
aux
args
)
and
compile_abstr
env
a
=
let
fun_env
=
...
...
compile/lambda.ml
View file @
b31535c1
...
...
@@ -61,6 +61,7 @@ type expr =
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
|
Op
of
string
*
expr
list
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
...
...
@@ -210,6 +211,10 @@ module Put = struct
bits
nbits
s
18
;
expr
s
e
;
Types
.
Node
.
serialize
s
t
|
Op
(
op
,
args
)
->
bits
nbits
s
19
;
string
s
op
;
list
expr
s
args
and
branches
s
brs
=
list
(
pair
Patterns
.
Node
.
serialize
expr
)
s
brs
.
brs
;
...
...
@@ -327,6 +332,10 @@ module Get = struct
let
e
=
expr
s
in
let
t
=
Types
.
Node
.
deserialize
s
in
Ref
(
e
,
t
)
|
19
->
let
op
=
string
s
in
let
args
=
list
expr
s
in
Op
(
op
,
args
)
|
_
->
assert
false
and
branches
s
=
...
...
compile/lambda.mli
View file @
b31535c1
...
...
@@ -34,6 +34,7 @@ type expr =
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
|
Op
of
string
*
expr
list
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
...
...
compile/operators.ml
View file @
b31535c1
...
...
@@ -41,3 +41,8 @@ module Binary = struct
Lambda
.
Put
.
binary_op
:=
serialize
;;
Lambda
.
Get
.
binary_op
:=
deserialize
;;
end
let
register
op
typ
eval
=
Typer
.
register_op
op
typ
;
Eval
.
register_op
op
eval
compile/operators.mli
View file @
b31535c1
...
...
@@ -25,3 +25,8 @@ module Binary: sig
(
'
a
Serialize
.
Put
.
f
)
->
(
'
a
Serialize
.
Get
.
f
)
->
unit
end
val
register
:
string
->
(
type_fun
list
->
type_fun
)
->
(
Value
.
t
list
->
Value
.
t
)
->
unit
driver/cduce.ml
View file @
b31535c1
...
...
@@ -342,6 +342,26 @@ let eval s =
let
ppf
=
Format
.
formatter_of_buffer
b
in
print_exn
ppf
exn
;
Format
.
fprintf
ppf
"@."
;
raise
(
Value
.
CDuceExn
(
Value
.
ocaml2cduce_string
(
Buffer
.
contents
b
)))
Value
.
failwith'
(
Buffer
.
contents
b
)
let
()
=
Operators
.
register
"eval_expr"
(
function
|
[
tf
]
->
ignore
(
tf
Builtin_defs
.
string_latin1
false
);
fun
_
_
->
Types
.
any
|
_
->
Location
.
raise_generic
"eval needs exactly one argument"
)
(
function
|
[
v
]
->
(
match
eval
(
Value
.
cduce2ocaml_string
v
)
with
|
[
(
None
,
v
)
]
->
v
|
_
->
Value
.
failwith'
"eval: the string must evaluate to a single value"
)
|
_
->
assert
false
)
runtime/eval.ml
View file @
b31535c1
...
...
@@ -6,6 +6,10 @@ open Lambda
let
eval_unary_op
=
ref
(
fun
_
->
assert
false
)
let
eval_binary_op
=
ref
(
fun
_
_
->
assert
false
)
let
ops
=
Hashtbl
.
create
13
let
register_op
=
Hashtbl
.
add
ops
let
eval_op
=
Hashtbl
.
find
ops
(* To write tail-recursive map-like iteration *)
let
make_accu
()
=
Value
.
Pair
(
nil
,
Absent
)
...
...
@@ -127,6 +131,7 @@ let rec eval env = function
!
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
)
and
eval_abstraction
env
slots
iface
body
=
let
local_env
=
Array
.
map
(
eval_var
env
)
slots
in
...
...
runtime/eval.mli
View file @
b31535c1
...
...
@@ -4,6 +4,7 @@ open Lambda
val
eval_unary_op
:
(
int
->
(
t
->
t
))
ref
val
eval_binary_op
:
(
int
->
(
t
->
t
->
t
))
ref
val
register_op
:
string
->
(
t
list
->
t
)
->
unit
val
get_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
)
ref
val
set_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
->
unit
)
ref
...
...
typing/typed.ml
View file @
b31535c1
...
...
@@ -53,6 +53,7 @@ and texpr' =
|
BinaryOp
of
int
*
texpr
*
texpr
|
Ref
of
texpr
*
ttyp
|
External
of
Types
.
t
*
int
|
Op
of
string
*
texpr
list
and
abstr
=
{
fun_name
:
id
option
;
...
...
typing/typer.ml
View file @
b31535c1
...
...
@@ -857,6 +857,17 @@ let exp loc fv e =
Typed
.
exp_descr
=
e
;
}
let
ops
=
Hashtbl
.
create
13
let
is_op
=
Hashtbl
.
mem
ops
let
register_op
=
Hashtbl
.
add
ops
let
typ_op
=
Hashtbl
.
find
ops
let
rec
apply_op
args
=
function
|
Apply
(
e1
,
e2
)
->
apply_op
(
e2
::
args
)
e1
|
LocatedExpr
(
_
,
e
)
->
apply_op
args
e
|
Var
s
when
is_op
(
U
.
get_str
s
)
->
(
U
.
get_str
s
,
args
)
|
_
->
raise
Not_found
let
rec
expr
env
loc
=
function
|
LocatedExpr
(
loc
,
e
)
->
expr
env
loc
e
...
...
@@ -865,8 +876,15 @@ let rec expr env loc = function
exp
loc
fv
(
Typed
.
Forget
(
e
,
t
))
|
Var
s
->
var
env
loc
s
|
Apply
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
env
loc
e1
and
(
fv2
,
e2
)
=
expr
env
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Apply
(
e1
,
e2
))
(
try
let
(
op
,
args
)
=
apply_op
[
e2
]
e1
in
let
(
fvs
,
args
)
=
List
.
split
(
List
.
map
(
expr
env
loc
)
args
)
in
let
fv
=
List
.
fold_left
Fv
.
cup
Fv
.
empty
fvs
in
exp
loc
fv
(
Typed
.
Op
(
op
,
args
))
with
Not_found
->
let
(
fv1
,
e1
)
=
expr
env
loc
e1
and
(
fv2
,
e2
)
=
expr
env
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Apply
(
e1
,
e2
))
)
|
Abstraction
a
->
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
typ
env
t1
,
typ
env
t2
))
a
.
fun_iface
in
...
...
@@ -1188,6 +1206,12 @@ and type_check' loc env e constr precise = match e with
|
External
(
t
,
i
)
->
verify
loc
t
constr
|
Op
(
op
,
args
)
->
let
args
=
List
.
map
(
type_check
env
)
args
in
let
t
=
typ_op
op
args
constr
precise
in
verify
loc
t
constr
and
type_check_pair
?
(
kind
=
`Normal
)
loc
env
e1
e2
constr
precise
=
let
rects
=
Types
.
Product
.
normal
~
kind
constr
in
if
Types
.
Product
.
is_empty
rects
then
...
...
typing/typer.mli
View file @
b31535c1
...
...
@@ -79,3 +79,5 @@ val typ_unary_op: (int -> loc -> type_fun -> type_fun) ref
val
mk_binary_op
:
(
string
->
t
->
int
)
ref
val
typ_binary_op
:
(
int
->
loc
->
type_fun
->
type_fun
->
type_fun
)
ref
val
register_op
:
string
->
(
type_fun
list
->
type_fun
)
->
unit
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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