Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
cduce
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
19
Issues
19
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
cduce
cduce
Commits
45912cbb
Commit
45912cbb
authored
Jul 10, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[r2004-06-28 03:27:16 by afrisch] Call OCaml functions
Original author: afrisch Date: 2004-06-28 03:27:17+00:00
parent
81ba46b4
Changes
19
Hide whitespace changes
Inline
Side-by-side
Showing
19 changed files
with
115 additions
and
36 deletions
+115
-36
Makefile.distrib
Makefile.distrib
+1
-0
cdo2cmo/cdml.ml
cdo2cmo/cdml.ml
+4
-5
compile/compile.ml
compile/compile.ml
+8
-4
compile/compile.mli
compile/compile.mli
+3
-1
depend
depend
+11
-8
driver/librarian.ml
driver/librarian.ml
+3
-4
ocamliface/mlstub.ml
ocamliface/mlstub.ml
+39
-12
ocamliface/mlstub.mli
ocamliface/mlstub.mli
+2
-1
ocamliface/mltypes.ml
ocamliface/mltypes.ml
+12
-0
ocamliface/mltypes.mli
ocamliface/mltypes.mli
+3
-0
parser/ast.ml
parser/ast.ml
+1
-0
parser/parser.ml
parser/parser.ml
+4
-1
runtime/eval.ml
runtime/eval.ml
+1
-0
runtime/eval.mli
runtime/eval.mli
+1
-0
tests/ocaml/a.cd
tests/ocaml/a.cd
+7
-0
tests/ocaml/a.mli
tests/ocaml/a.mli
+6
-0
tests/ocaml/b.ml
tests/ocaml/b.ml
+3
-0
typing/typed.ml
typing/typed.ml
+1
-0
typing/typer.ml
typing/typer.ml
+5
-0
No files found.
Makefile.distrib
View file @
45912cbb
...
...
@@ -154,6 +154,7 @@ OBJECTS = \
\
compile/lambda.cmo
\
runtime/value.cmo
\
types/externals.cmo
\
\
schema/schema_types.cmo
\
schema/schema_xml.cmo
\
...
...
cdo2cmo/cdml.ml
View file @
45912cbb
...
...
@@ -8,11 +8,10 @@ type 'a ml2cd = 'a -> Value.t
let
initialize
modname
=
let
cu
=
Types
.
CompUnit
.
mk
(
Ident
.
U
.
mk_latin1
modname
)
in
(
try
Librarian
.
import
cu
;
with
Librarian
.
NoImplementation
_
->
failwith
(
"Cdml: no implementation found for CDuce module "
^
modname
));
Librarian
.
run
cu
;
cu
try
Librarian
.
import
cu
;
cu
with
Librarian
.
NoImplementation
_
->
failwith
(
"Cdml: no implementation found for CDuce module "
^
modname
)
let
identity
x
=
x
...
...
compile/compile.ml
View file @
45912cbb
...
...
@@ -17,9 +17,9 @@ let dump ppf env =
env
.
vars
let
mk
cu
=
{
cu
=
cu
;
vars
=
Env
.
empty
;
stack_size
=
0
;
global_size
=
0
}
let
empty_toplevel
=
mk
None
let
empty
x
=
mk
(
Some
x
)
let
mk
cu
g
=
{
cu
=
cu
;
vars
=
Env
.
empty
;
stack_size
=
0
;
global_size
=
g
}
let
empty_toplevel
=
mk
None
0
let
empty
x
g
=
mk
(
Some
x
)
g
let
serialize
s
env
=
...
...
@@ -45,7 +45,7 @@ let find x env =
let
find_slot
x
env
=
match
find
x
env
with
|
Lambda
.
Ext
(
_
,
slot
)
->
slot
|
Ext
(
_
,
slot
)
->
slot
|
_
->
assert
false
...
...
@@ -82,6 +82,10 @@ and compile_aux env tail = function
|
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
|
Some
cu
->
Var
(
Ext
(
cu
,
i
))
|
None
->
failwith
"Cannot compile externals in the toplevel"
)
and
compile_abstr
env
a
=
let
fun_env
=
...
...
compile/compile.mli
View file @
45912cbb
...
...
@@ -7,7 +7,9 @@ val from_comp_unit: (Types.CompUnit.t -> env) ref
val
dump
:
Format
.
formatter
->
env
->
unit
val
empty
:
Types
.
CompUnit
.
t
->
env
val
empty
:
Types
.
CompUnit
.
t
->
int
->
env
(* integer: number of already allocated globals *)
val
empty_toplevel
:
env
val
serialize
:
env
Serialize
.
Put
.
f
val
deserialize
:
env
Serialize
.
Get
.
f
...
...
depend
View file @
45912cbb
...
...
@@ -78,6 +78,8 @@ runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.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
types/externals.cmo: misc/custom.cmo types/externals.cmi
types/externals.cmx: misc/custom.cmx types/externals.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 \
...
...
@@ -129,15 +131,15 @@ parser/ast.cmx: types/builtin_defs.cmx types/chars.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_types.cmx types/sequence.cmx types/types.cmx
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
misc/encodings.cmi types/
ident.cmo types/intervals.cmi
\
parser/location.cmi misc/ns.cmi schema/schema_parser
.cmi \
types/sequence.cmi types/types.cmi parser/ulexer.cmi parser/url
.cmi \
parser/parser.cmi
misc/encodings.cmi types/
externals.cmi types/ident.cmo
\
types/intervals.cmi parser/location.cmi misc/ns
.cmi \
schema/schema_parser.cmi types/sequence.cmi types/types
.cmi \
parser/
ulexer.cmi parser/url.cmi parser/
parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
misc/encodings.cmx types/
ident.cmx types/intervals
.cmx \
parser/location.cmx misc/ns.cmx schema/schema_parser
.cmx \
types/sequence.cmx types/types.cmx parser/ulexer.cmx parser/url
.cmx \
parser/parser.cmi
misc/encodings.cmx types/
externals.cmx types/ident
.cmx \
types/intervals.cmx parser/location.cmx misc/ns
.cmx \
schema/schema_parser.cmx types/sequence.cmx types/types
.cmx \
parser/
ulexer.cmx parser/url.cmx parser/
parser.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
schema/schema_types.cmi types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
...
...
@@ -293,6 +295,7 @@ types/builtin_defs.cmi: types/atoms.cmi types/ident.cmo types/types.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
types/types.cmi
types/externals.cmi: types/types.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
...
...
driver/librarian.ml
View file @
45912cbb
...
...
@@ -165,7 +165,7 @@ let rec compile verbose name id src =
Compile
.
comp_unit
?
show
Builtin
.
env
(
Compile
.
empty
id
)
(
Compile
.
empty
id
(
Externals
.
nb_externals
()
)
)
p
in
let
stub
,
types
=
!
stub_ml
name
ty_env
c_env
in
...
...
@@ -246,9 +246,8 @@ let () =
Eval
.
get_global
:=
(
fun
cu
i
->
import_and_run
cu
;
(
load
cu
)
.
vals
.
(
i
));
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
let
cu
=
load
cu
in
match
cu
.
status
with
|
`Evaluating
->
cu
.
vals
.
(
i
)
<-
v
|
_
->
assert
false
);;
cu
.
vals
.
(
i
)
<-
v
)
let
registered_types
cu
=
(
load
cu
)
.
types
ocamliface/mlstub.ml
View file @
45912cbb
...
...
@@ -398,6 +398,8 @@ let global_transl () =
let
err_ppf
=
Format
.
err_formatter
let
exts
=
ref
[]
let
check_value
ty_env
c_env
(
s
,
caml_t
,
t
)
=
(* Find the type for the value in the CDuce module *)
let
id
=
Id
.
mk
(
U
.
mk
s
)
in
...
...
@@ -436,20 +438,31 @@ let check_value ty_env c_env (s,caml_t,t) =
let
stub
name
ty_env
c_env
values
=
let
items
=
List
.
map
(
check_value
ty_env
c_env
)
values
in
let
exts
=
List
.
map
(
fun
(
s
,
i
,
t
)
->
let
c
=
to_cd
<:
expr
<
$
lid
:
s
$
>>
t
in
<:
str_item
<
Eval
.
set_slot
cu
$
int
:
string_of_int
i
$
$
c
$
>>
)
!
exts
in
let
g
=
global_transl
()
in
(* open Cdml
open CDuce_all
let cu = Cdml.initialize <modname>
let rec <global translation functions>
<fills external slots>
<run the unit>
let <stubs for values>
*)
[
<:
str_item
<
open
Cdml
>>;
<:
str_item
<
open
CDuce_all
>>;
<:
str_item
<
value
cu
=
Cdml
.
initialize
$
str
:
String
.
escaped
name
$
>>;
<:
str_item
<
value
types
=
Librarian
.
registered_types
cu
>>
<:
str_item
<
value
types
=
Librarian
.
registered_types
cu
>>;
<:
str_item
<
declare
$
list
:
exts
$
end
>>;
<:
str_item
<
Librarian
.
run
cu
>>
]
@
(
if
g
=
[]
then
[]
else
[
<:
str_item
<
value
rec
$
list
:
g
$
>>
])
@
[
<:
str_item
<
value
$
list
:
items
$
>>
]
...
...
@@ -457,13 +470,27 @@ let stub name ty_env c_env values =
let
()
=
Librarian
.
stub_ml
:=
fun
cu
ty_env
c_env
->
try
let
name
=
String
.
capitalize
cu
in
let
(
prolog
,
values
)
=
Mltypes
.
read_cmi
name
in
let
code
=
stub
cu
ty_env
c_env
values
in
Some
(
Obj
.
magic
(
prolog
,
code
))
,
get_registered_types
()
with
|
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
|
Not_found
->
Printf
.
eprintf
"Warning: no caml interface
\n
"
;
None
,
[
||
]
Librarian
.
stub_ml
:=
(
fun
cu
ty_env
c_env
->
try
let
name
=
String
.
capitalize
cu
in
let
(
prolog
,
values
)
=
Mltypes
.
read_cmi
name
in
let
code
=
stub
cu
ty_env
c_env
values
in
Some
(
Obj
.
magic
(
prolog
,
code
))
,
get_registered_types
()
with
|
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
|
Not_found
->
Printf
.
eprintf
"Warning: no caml interface
\n
"
;
None
,
[
||
]
);
Externals
.
register_external
:=
(
fun
s
i
->
let
t
=
try
Mltypes
.
find_value
s
with
Not_found
->
Printf
.
eprintf
"Cannot resolve the external symbol %s
\n
"
s
;
exit
1
in
exts
:=
(
s
,
i
,
t
)
::
!
exts
;
fun
()
->
Types
.
descr
(
typ
t
)
)
ocamliface/mlstub.mli
View file @
45912cbb
(* nothing *)
ocamliface/mltypes.ml
View file @
45912cbb
...
...
@@ -178,3 +178,15 @@ let read_cmi name =
(
Buffer
.
contents
buf
,
!
values
)
let
print_ocaml
=
Printtyp
.
type_expr
let
rec
dump_li
=
function
|
Longident
.
Lident
s
->
print_endline
s
|
Longident
.
Ldot
(
li
,
s
)
->
dump_li
li
;
print_endline
s
|
_
->
assert
false
let
find_value
v
=
Config
.
load_path
:=
Config
.
standard_library
::
!
Librarian
.
obj_path
;
let
li
=
Longident
.
parse
v
in
let
(
p
,
vd
)
=
Env
.
lookup_value
li
Env
.
initial
in
unfold
vd
.
val_type
ocamliface/mltypes.mli
View file @
45912cbb
...
...
@@ -20,3 +20,6 @@ val read_cmi: string -> string * (string * Types.type_expr * t) list
val
print
:
Format
.
formatter
->
t
->
unit
val
print_ocaml
:
Format
.
formatter
->
Types
.
type_expr
->
unit
val
find_value
:
string
->
t
parser/ast.ml
View file @
45912cbb
...
...
@@ -72,6 +72,7 @@ and pexpr =
|
Forget
of
pexpr
*
ppat
|
Op
of
string
*
pexpr
list
|
Ref
of
pexpr
*
ppat
|
External
of
(
unit
->
Types
.
t
)
*
int
...
...
parser/parser.ml
View file @
45912cbb
...
...
@@ -193,7 +193,7 @@ EXTEND
|
"transform"
|
"fun"
|
"in"
|
"let"
|
"type"
|
"debug"
|
"include"
|
"and"
|
"validate"
|
"schema"
|
"namespace"
|
"ref"
|
"alias"
|
"not"
|
"as"
|
"where"
|
"not"
|
"as"
|
"where"
|
"external"
]
->
a
]
...
...
@@ -217,6 +217,9 @@ EXTEND
exp
loc
(
Validate
(
e
,
kind
,
schema
,
typ
))
|
"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
))
|
(
_
,
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/eval.ml
View file @
45912cbb
...
...
@@ -65,6 +65,7 @@ let get_global = ref (fun cu pos -> assert false)
let
set_global
=
ref
(
fun
cu
pos
->
assert
false
)
let
get_slot
cu
pos
=
!
get_global
cu
pos
let
set_slot
cu
pos
v
=
!
set_global
cu
pos
v
let
eval_var
env
=
function
|
Env
i
->
env
.
(
i
)
...
...
runtime/eval.mli
View file @
45912cbb
...
...
@@ -9,6 +9,7 @@ val get_global: (Types.CompUnit.t -> int -> t) ref
val
set_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
->
unit
)
ref
val
get_slot
:
Types
.
CompUnit
.
t
->
int
->
t
val
set_slot
:
Types
.
CompUnit
.
t
->
int
->
t
->
unit
val
dump
:
Format
.
formatter
->
unit
val
push
:
Value
.
t
->
unit
...
...
tests/ocaml/a.cd
View file @
45912cbb
...
...
@@ -14,3 +14,10 @@ let map_complex (f : (Float,Float)->Float)(c : { x = Float; y = Float })
let pp (x : Any) : Latin1 = string_of x
let exists = external "Sys.file_exists"
let i = 1
let home = external "Sys.getenv" "HOME"
tests/ocaml/a.mli
View file @
45912cbb
...
...
@@ -13,3 +13,9 @@ val map_complex : (float * float -> float) -> complex -> float
type
t
=
A
of
t
|
B
of
t
*
t
|
C
of
int
val
pp
:
t
->
string
val
i
:
int
val
exists
:
string
->
bool
val
home
:
string
tests/ocaml/b.ml
View file @
45912cbb
print_int
A
.
i
;;
print_endline
(
A
.
f
Char
.
uppercase
"Abc"
);;
print_endline
(
A
.
pp
(
A
.
A
(
A
.
C
2
)));;
print_endline
A
.
home
;;
print_newline
()
;;
typing/typed.ml
View file @
45912cbb
...
...
@@ -52,6 +52,7 @@ and texpr' =
|
UnaryOp
of
int
*
texpr
|
BinaryOp
of
int
*
texpr
*
texpr
|
Ref
of
texpr
*
ttyp
|
External
of
Types
.
t
*
int
and
abstr
=
{
fun_name
:
id
option
;
...
...
typing/typer.ml
View file @
45912cbb
...
...
@@ -939,6 +939,8 @@ 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
))
and
branches
env
b
=
let
fv
=
ref
Fv
.
empty
in
...
...
@@ -1149,6 +1151,9 @@ and type_check' loc env e constr precise = match e with
ignore
(
type_check
env
e
(
Types
.
descr
t
)
false
);
verify
loc
(
Builtin_defs
.
ref_type
t
)
constr
|
External
(
t
,
i
)
->
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
...
...
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