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
3e7c40a6
Commit
3e7c40a6
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-06-28 12:37:21 by afrisch] Calling polymorphic OCaml functions
Original author: afrisch Date: 2004-06-28 12:37:21+00:00
parent
abf4fba2
Changes
9
Hide whitespace changes
Inline
Side-by-side
driver/librarian.ml
View file @
3e7c40a6
...
...
@@ -167,7 +167,7 @@ let rec compile verbose name id src =
Compile
.
comp_unit
?
show
Builtin
.
env
(
Compile
.
empty
id
(
Externals
.
nb
_externals
()
))
(
Compile
.
empty
id
(
Externals
.
nb
()
))
p
in
let
stub
,
types
=
!
stub_ml
name
ty_env
c_env
in
...
...
ocamliface/mlstub.ml
View file @
3e7c40a6
...
...
@@ -18,6 +18,8 @@ module IntHash =
(* Compute CDuce type *)
let
vars
=
ref
[
||
]
let
memo_typ
=
IntHash
.
create
13
let
atom
lab
=
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
lab
))
...
...
@@ -49,6 +51,7 @@ and typ_descr = function
|
Builtin
(
"Pervasives.ref"
,
[
t
])
->
Builtin_defs
.
ref_type
(
typ
t
)
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
Types
.
any
|
Builtin
(
"unit"
,
[]
)
->
Sequence
.
nil_type
|
Var
i
->
Types
.
descr
(
!
vars
)
.
(
i
)
|
_
->
assert
false
and
pvariant
=
function
...
...
@@ -248,6 +251,7 @@ and to_cd_descr e = function
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
e
|
Builtin
(
"unit"
,
[]
)
->
<:
expr
<
do
{
$
e
$;
Value
.
nil
}
>>
|
Var
_
->
e
|
_
->
assert
false
and
tuple_to_cd
tl
vars
=
List
.
map2
(
fun
t
id
->
to_cd
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
...
...
@@ -365,6 +369,7 @@ and to_ml_descr e = function
<:
expr
<
Pervasives
.
ref
$
to_ml
e
t
$
>>
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
e
|
Builtin
(
"unit"
,
[]
)
->
<:
expr
<
ignore
$
e
$
>>
|
Var
_
->
e
|
_
->
assert
false
and
tuple_to_ml
tl
vars
=
List
.
map2
(
fun
t
id
->
to_ml
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
...
...
@@ -496,14 +501,26 @@ let () =
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
);
Externals
.
re
gister_external
:=
(
fun
s
i
->
let
t
=
Externals
.
re
solve
:=
(
fun
i
s
args
->
let
(
t
,
n
)
=
try
Mltypes
.
find_value
s
with
Not_found
->
Printf
.
eprintf
"Cannot resolve the external symbol %s
\n
"
s
;
exit
1
in
let
m
=
List
.
length
args
in
if
n
<>
m
then
(
Printf
.
eprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)
\n
"
s
n
m
;
exit
1
);
exts
:=
(
s
,
i
,
t
)
::
!
exts
;
fun
()
->
Types
.
descr
(
typ
t
)
vars
:=
Array
.
of_list
args
;
let
cdt
=
Types
.
descr
(
typ
t
)
in
(* Format.fprintf Format.std_formatter "Instance: %a@."
Types.Print.print cdt; *)
vars
:=
[
|
|
];
cdt
)
ocamliface/mltypes.ml
View file @
3e7c40a6
...
...
@@ -18,6 +18,7 @@ and def =
|
Record
of
(
string
*
t
)
list
*
bool
|
Builtin
of
string
*
t
list
|
Abstract
of
string
|
Var
of
int
module
IntMap
=
Map
.
Make
(
struct
type
t
=
int
let
compare
:
t
->
t
->
int
=
compare
end
)
...
...
@@ -53,6 +54,7 @@ and print_def ppf = function
|
Record
(
l
,_
)
->
Format
.
fprintf
ppf
"{%a}"
(
print_sep
print_field
" ; "
)
l
|
Builtin
(
p
,
tl
)
->
Format
.
fprintf
ppf
"%s(%a)"
p
(
print_sep
print_slot
","
)
tl
|
Abstract
s
->
Format
.
fprintf
ppf
"%s"
s
|
Var
i
->
Format
.
fprintf
ppf
"'a%i"
i
and
print_palt
ppf
=
function
...
...
@@ -80,6 +82,15 @@ let builtins =
List
.
fold_left
(
fun
m
x
->
StringMap
.
add
x
()
m
)
StringMap
.
empty
[
"list"
;
"Pervasives.ref"
;
"CDuce_all.Value.t"
;
"unit"
]
let
vars
=
ref
[]
let
get_var
id
=
try
List
.
assq
id
!
vars
with
Not_found
->
let
i
=
List
.
length
!
vars
in
vars
:=
(
id
,
i
)
::
!
vars
;
i
let
rec
unfold
seen
constrs
ty
=
try
let
t
=
IntMap
.
find
ty
.
id
seen
in
...
...
@@ -103,7 +114,9 @@ let rec unfold seen constrs ty =
|
_
->
assert
false
)
rd
.
row_fields
in
PVariant
fields
|
Tvar
->
failwith
"Polymorphic value"
|
Tvar
->
Var
(
get_var
ty
.
id
)
(* failwith "Polymorphic value"*)
|
Tconstr
(
p
,
args
,_
)
->
let
args
=
List
.
map
loop
args
in
let
pn
=
Path
.
name
p
in
...
...
@@ -147,7 +160,12 @@ let rec unfold seen constrs ty =
);
slot
let
unfold
=
unfold
IntMap
.
empty
StringMap
.
empty
let
unfold
ty
=
vars
:=
[]
;
let
t
=
unfold
IntMap
.
empty
StringMap
.
empty
ty
in
let
n
=
List
.
length
!
vars
in
vars
:=
[]
;
(
t
,
n
)
(* Reading .cmi *)
...
...
@@ -165,7 +183,9 @@ let read_cmi name =
List
.
iter
(
function
|
Tsig_value
(
id
,
{
val_type
=
t
;
val_kind
=
Val_reg
})
->
values
:=
(
Ident
.
name
id
,
t
,
unfold
t
)
::
!
values
let
(
unf
,
n
)
=
unfold
t
in
if
n
!=
0
then
unsupported
"polymorphic value"
;
values
:=
(
Ident
.
name
id
,
t
,
unf
)
::
!
values
|
Tsig_type
(
id
,
t
)
->
Format
.
fprintf
ppf
"%a@."
(
Printtyp
.
type_declaration
id
)
t
|
Tsig_value
(
_
,_
)
->
unsupported
"external value"
...
...
ocamliface/mltypes.mli
View file @
3e7c40a6
...
...
@@ -14,6 +14,7 @@ and def =
|
Record
of
(
string
*
t
)
list
*
bool
|
Builtin
of
string
*
t
list
|
Abstract
of
string
|
Var
of
int
val
read_cmi
:
string
->
string
*
(
string
*
Types
.
type_expr
*
t
)
list
...
...
@@ -22,4 +23,4 @@ val print : Format.formatter -> t -> unit
val
print_ocaml
:
Format
.
formatter
->
Types
.
type_expr
->
unit
val
find_value
:
string
->
t
val
find_value
:
string
->
t
*
int
parser/ast.ml
View file @
3e7c40a6
...
...
@@ -72,7 +72,7 @@ and pexpr =
|
Forget
of
pexpr
*
ppat
|
Op
of
string
*
pexpr
list
|
Ref
of
pexpr
*
ppat
|
External
of
(
unit
->
Types
.
t
)
*
int
|
External
of
string
*
ppat
list
*
int
...
...
parser/parser.ml
View file @
3e7c40a6
...
...
@@ -218,8 +218,9 @@ EXTEND
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
"external"
;
s
=
STRING2
->
let
(
t
,
i
)
=
Externals
.
parse
s
in
exp
loc
(
External
(
t
,
i
))
exp
loc
(
External
(
s
,
[]
,
Externals
.
alloc
()
))
|
"external"
;
"{"
;
s
=
STRING2
;
pl
=
LIST0
pat
;
"}"
->
exp
loc
(
External
(
s
,
pl
,
Externals
.
alloc
()
))
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
...
...
runtime/value.ml
View file @
3e7c40a6
...
...
@@ -172,7 +172,7 @@ let normalize = function
|
String_latin1
(
i
,
j
,
s
,
q
)
->
normalize_string_latin1
i
j
s
q
|
String_utf8
(
i
,
j
,
s
,
q
)
->
normalize_string_utf8
i
j
s
q
|
Concat
(
_
,_
)
as
v
->
eval_lazy_concat
v
;
v
|
v
->
assert
false
|
v
->
v
...
...
tests/ocaml/a.cd
View file @
3e7c40a6
...
...
@@ -28,4 +28,9 @@ let str_len = external "String.length"
let _ = unix_write stdin home 0 (str_len home)
let [] = external "Unix.sleep" 3
let [] = external "Unix.sleep" 1
let listmap = external { "List.map" Int Int }
let lst = listmap (fun (x : Int) : Int = x * 2) [ 10 20 30 ] in
print (string_of lst)
typing/typer.ml
View file @
3e7c40a6
...
...
@@ -939,8 +939,10 @@ let rec expr env loc = function
|
Ref
(
e
,
t
)
->
let
(
fv
,
e
)
=
expr
env
loc
e
and
t
=
typ
env
t
in
exp
loc
fv
(
Typed
.
Ref
(
e
,
t
))
|
External
(
t
,
i
)
->
exp
loc
Fv
.
empty
(
Typed
.
External
(
t
()
,
i
))
|
External
(
s
,
args
,
i
)
->
let
args
=
List
.
map
(
typ
env
)
args
in
let
t
=
!
Externals
.
resolve
i
s
args
in
exp
loc
Fv
.
empty
(
Typed
.
External
(
t
,
i
))
and
branches
env
b
=
let
fv
=
ref
Fv
.
empty
in
...
...
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