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
566498a2
Commit
566498a2
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-06-28 01:53:47 by afrisch] References, avoid let x1 = x2 in ...
Original author: afrisch Date: 2004-06-28 01:53:48+00:00
parent
d79cbfda
Changes
5
Hide whitespace changes
Inline
Side-by-side
depend
View file @
566498a2
...
...
@@ -72,12 +72,12 @@ compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
types/types.cmi
compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx
runtime/value.cmo: types/atoms.cmi types/
chars.cmi misc/encoding
s.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmo
misc/ns.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 compile/lambda.cmx
misc/ns.cmx
\
types/sequence.cmx types/types.cmx runtime/value.cmi
runtime/value.cmo: types/atoms.cmi types/
builtin_defs.cmi types/char
s.cmi \
misc/encodings.cmi
types/ident.cmo types/intervals.cmi compile/lambda.cmo \
misc/ns.cmi
types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/
builtin_defs.cmx types/char
s.cmx \
misc/encodings.cmx
types/ident.cmx types/intervals.cmx compile/lambda.cmx \
misc/ns.cmx
types/sequence.cmx types/types.cmx runtime/value.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
...
...
@@ -180,14 +180,14 @@ runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_builtin.cmx types/sequence.cmx runtime/value.cmx \
runtime/print_xml.cmi
runtime/eval.cmo:
types/builtin_defs.cmi
types/ident.cmo compile/lambda.cmo \
types/patterns.cmi
runtime/run_dispatch.cmi schema/schema_common.cmi \
schema/schema_
types.cmi schema/schema_validator.cmi types/sequence
.cmi \
typing/typer.cmi types/types.cmi
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx:
types/builtin_defs.cmx
types/ident.cmx compile/lambda.cmx \
types/patterns.cmx
runtime/run_dispatch.cmx schema/schema_common.cmx \
schema/schema_
types.cmx schema/schema_validator.cmx types/sequence
.cmx \
typing/typer.cmx types/types.cmx
runtime/value.cmx runtime/eval.cmi
runtime/eval.cmo: types/ident.cmo compile/lambda.cmo
types/patterns.cmi
\
runtime/run_dispatch.cmi schema/schema_common.cmi
schema/schema_types.cmi
\
schema/schema_
validator.cmi typing/typer.cmi types/types
.cmi \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: types/ident.cmx compile/lambda.cmx
types/patterns.cmx
\
runtime/run_dispatch.cmx schema/schema_common.cmx
schema/schema_types.cmx
\
schema/schema_
validator.cmx typing/typer.cmx types/types
.cmx \
runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: parser/ast.cmo runtime/eval.cmi types/ident.cmo \
compile/lambda.cmo parser/location.cmi types/patterns.cmi \
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
...
...
@@ -226,12 +226,12 @@ ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx \
driver/librarian.cmx types/types.cmx ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi types/ident.cmo driver/librarian.cmi \
ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi
typing/typer.cmi
\
types/types.cmi ocamliface/mlstub.cmi
parser/location.cmi
ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi \
typing/typer.cmi
types/types.cmi ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
compile/compile.cmx types/ident.cmx driver/librarian.cmx \
ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx
typing/typer.cmx
\
types/types.cmx ocamliface/mlstub.cmi
parser/location.cmx
ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx \
typing/typer.cmx
types/types.cmx ocamliface/mlstub.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi misc/ns.cmi parser/parser.cmi \
...
...
@@ -318,9 +318,8 @@ compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cmo \
compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: types/types.cmi
driver/librarian.cmi:
compile/compile.cmi typing/typer.cmi
types/types.cmi
ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi
ocamliface/mlstub.cmi: ocamliface/mltypes.cmi types/types.cmi
query/query.cmi: parser/ast.cmo
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
...
...
ocamliface/mlstub.ml
View file @
566498a2
...
...
@@ -103,6 +103,14 @@ let rec matches ine oute = function
let
list_lit
el
=
List
.
fold_right
(
fun
a
e
->
<:
expr
<
[
$
a
$
::
$
e
$
]
>>
)
el
<:
expr
<
[]
>>
let
protect
e
f
=
match
e
with
|
<:
expr
<
$
lid
:
x
$
>>
->
f
e
|
e
->
let
x
=
mk_var
()
in
let
r
=
f
<:
expr
<
$
lid
:
x
$
>>
in
<:
expr
<
let
$
lid
:
x
$
=
$
e
$
in
$
r
$
>>
(* Registered types *)
module
HashTypes
=
Hashtbl
.
Make
(
Types
)
...
...
@@ -166,14 +174,16 @@ and to_cd_descr e = function
|
Link
t
->
to_cd
e
t
|
Arrow
(
t
,
s
)
->
(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y (t(x))) *)
let
y
=
mk_var
()
in
let
x
=
mk_var
()
in
let
arg
=
to_ml
<:
expr
<
$
lid
:
x
$
>>
t
in
let
res
=
to_cd
<:
expr
<
$
lid
:
y
$
$
arg
$
>>
s
in
let
abs
=
<:
expr
<
fun
$
lid
:
x
$
->
$
res
$
>>
in
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
ss
=
register_type
(
Types
.
descr
(
typ
s
))
in
<:
expr
<
let
$
lid
:
y
$
=
$
e
$
in
Value
.
Abstraction
([(
$
tt
$,$
ss
$
)]
,$
abs
$
)
>>
protect
e
(
fun
y
->
let
x
=
mk_var
()
in
let
arg
=
to_ml
<:
expr
<
$
lid
:
x
$
>>
t
in
let
res
=
to_cd
<:
expr
<
$
y
$
$
arg
$
>>
s
in
let
abs
=
<:
expr
<
fun
$
lid
:
x
$
->
$
res
$
>>
in
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
ss
=
register_type
(
Types
.
descr
(
typ
s
))
in
<:
expr
<
Value
.
Abstraction
([(
$
tt
$,$
ss
$
)]
,$
abs
$
)
>>
)
|
Tuple
tl
->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let
vars
=
mk_vars
tl
in
...
...
@@ -209,15 +219,16 @@ and to_cd_descr e = function
pmatch
e
cases
|
Record
(
l
,_
)
->
(* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
let
x
=
mk_var
()
in
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
let
e
=
to_cd
<:
expr
<$
lid
:
x
$.$
lid
:
lab
$>>
t
in
<:
expr
<
(
$
label_ascii
lab
$,
$
e
$
)
>>
)
l
in
let_in
<:
patt
<
$
lid
:
x
$
>>
e
<:
expr
<
Value
.
record
$
list_lit
l
$
>>
protect
e
(
fun
x
->
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
let
e
=
to_cd
<:
expr
<$
x
$.$
lid
:
lab
$>>
t
in
<:
expr
<
(
$
label_ascii
lab
$,
$
e
$
)
>>
)
l
in
<:
expr
<
Value
.
record
$
list_lit
l
$
>>
)
|
Abstract
"int"
->
<:
expr
<
ocaml2cduce_int
$
e
$
>>
|
Abstract
"char"
->
<:
expr
<
ocaml2cduce_char
$
e
$
>>
...
...
@@ -227,7 +238,19 @@ and to_cd_descr e = function
(* Value.sequence_rev (List.rev_map fun_t <...>) *)
<:
expr
<
Value
.
sequence_rev
(
List
.
rev_map
$
lid
:
to_cd_fun
t
$
$
e
$
)
>>
|
Builtin
(
"Pervasives.ref"
,
[
t
])
->
failwith
"to_cd: Reference. TODO"
(* let x = <...> in
Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
protect
e
(
fun
e
->
let
y
=
mk_var
()
in
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
get_x
=
<:
expr
<
$
e
$.
val
>>
in
let
get
=
<:
expr
<
fun
()
->
$
to_cd
get_x
t
$
>>
in
let
tr_y
=
to_ml
<:
expr
<
$
lid
:
y
$
>>
t
in
let
set
=
<:
expr
<
fun
$
lid
:
y
$
->
$
e
$.
val
:=
$
tr_y
$
>>
in
<:
expr
<
Value
.
mk_ext_ref
$
tt
$
$
get
$
$
set
$
>>
)
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
e
|
Builtin
(
"unit"
,
[]
)
->
<:
expr
<
do
{
$
e
$;
Value
.
nil
}
>>
|
_
->
assert
false
...
...
@@ -248,11 +271,13 @@ and to_ml_descr e = function
|
Link
t
->
to_ml
e
t
|
Arrow
(
t
,
s
)
->
(* let y = <...> in fun x -> s(Eval.eval_apply y (t(x))) *)
let
y
=
mk_var
()
in
let
x
=
mk_var
()
in
let
arg
=
to_cd
<:
expr
<
$
lid
:
x
$
>>
t
in
let
res
=
to_ml
<:
expr
<
Eval
.
eval_apply
$
lid
:
y
$
$
arg
$
>>
s
in
<:
expr
<
let
$
lid
:
y
$
=
$
e
$
in
fun
$
lid
:
x
$
->
$
res
$
>>
protect
e
(
fun
y
->
let
x
=
mk_var
()
in
let
arg
=
to_cd
<:
expr
<
$
lid
:
x
$
>>
t
in
let
res
=
to_ml
<:
expr
<
Eval
.
eval_apply
$
y
$
$
arg
$
>>
s
in
<:
expr
<
fun
$
lid
:
x
$
->
$
res
$
>>
)
|
Tuple
tl
->
(* let (x1,r) = Value.get_pair <...> in
...
...
@@ -318,13 +343,15 @@ and to_ml_descr e = function
|
Record
(
l
,
true
)
->
(* let x = <...> in
{ l1 = t1(Value.get_field x "l1"); ... } *)
let
x
=
mk_var
()
in
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
(
<:
patt
<
$
uid
:
lab
$>>,
to_ml
<:
expr
<
Value
.
get_field
$
lid
:
x
$
$
label_ascii
lab
$
>>
t
))
l
in
let_in
<:
patt
<
$
lid
:
x
$
>>
e
<:
expr
<
{
$
list
:
l
$
}
>>
protect
e
(
fun
x
->
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
(
<:
patt
<
$
uid
:
lab
$>>,
to_ml
<:
expr
<
Value
.
get_field
$
x
$
$
label_ascii
lab
$
>>
t
))
l
in
<:
expr
<
{
$
list
:
l
$
}
>>
)
|
Abstract
"int"
->
<:
expr
<
cduce2ocaml_int
$
e
$
>>
|
Abstract
"char"
->
<:
expr
<
cduce2ocaml_char
$
e
$
>>
...
...
runtime/eval.ml
View file @
566498a2
...
...
@@ -164,13 +164,7 @@ and eval_branches env brs arg =
|
Patterns
.
Compile
.
Fail
->
Value
.
Absent
and
eval_ref
env
e
t
=
let
r
=
ref
(
eval
env
e
)
in
let
get
=
Value
.
Abstraction
([
Sequence
.
nil_type
,
Types
.
descr
t
]
,
fun
_
->
!
r
)
and
set
=
Value
.
Abstraction
([
Types
.
descr
t
,
Sequence
.
nil_type
]
,
fun
x
->
r
:=
x
;
nil
)
in
Value
.
Record
(
Builtin_defs
.
mk_ref
~
get
~
set
)
Value
.
mk_ref
(
Types
.
descr
t
)
(
eval
env
e
)
and
eval_validate
env
e
kind
schema_name
name
=
let
schema
=
Typer
.
get_schema
schema_name
in
...
...
runtime/value.ml
View file @
566498a2
...
...
@@ -576,3 +576,16 @@ let get_abstract = function
|
Abstract
(
_
,
v
)
->
Obj
.
magic
v
|
_
->
assert
false
let
mk_ref
t
v
=
let
r
=
ref
v
in
let
get
=
Abstraction
([
Sequence
.
nil_type
,
t
]
,
fun
_
->
!
r
)
and
set
=
Abstraction
([
t
,
Sequence
.
nil_type
]
,
fun
x
->
r
:=
x
;
nil
)
in
Record
(
Builtin_defs
.
mk_ref
~
get
~
set
)
let
mk_ext_ref
t
get
set
=
let
get
=
Abstraction
([
Sequence
.
nil_type
,
t
]
,
fun
_
->
get
()
)
and
set
=
Abstraction
([
t
,
Sequence
.
nil_type
]
,
fun
v
->
set
v
;
nil
)
in
Record
(
Builtin_defs
.
mk_ref
~
get
~
set
)
runtime/value.mli
View file @
566498a2
...
...
@@ -64,6 +64,9 @@ val get_variant : t -> string * t option
val
abstract
:
Types
.
Abstract
.
abs
->
'
a
->
t
val
get_abstract
:
t
->
'
a
val
mk_ref
:
Types
.
t
->
t
->
t
val
mk_ext_ref
:
Types
.
t
->
(
unit
->
t
)
->
(
t
->
unit
)
->
t
(* iterator on the content of an Xml value. First callback is invoked on Utf8
character children; second callback is invoked on other children values *)
val
iter_xml
:
(
U
.
t
->
unit
)
->
(
t
->
unit
)
->
t
->
unit
...
...
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