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
8c96ed41
Commit
8c96ed41
authored
May 28, 2014
by
Pietro Abate
Browse files
Add Env debugging printers to eval
update .ocamlinit with parse_expr
parent
555e7a7f
Changes
3
Hide whitespace changes
Inline
Side-by-side
.ocamlinit
View file @
8c96ed41
...
...
@@ -39,4 +39,48 @@ let mk_s ll =
Tallying.CS.union (mk_prod l) acc1
) Tallying.CS.S.empty ll
module BIN = struct
open Builtin_defs
(* Types *)
let stringn = Types.cons string
let namespaces =
Sequence.star (Types.times stringn stringn)
let types =
[
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char Chars.any;
"Byte", char_latin1;
"Atom", atom;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
"String", string;
"Latin1", string_latin1;
"Bool", bool;
"Float", float;
"AnyXml", any_xml;
"Namespaces", namespaces;
"Caml_int", caml_int;
]
let env =
List.fold_left
(fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global "" n t;
Typer.enter_type (Ident.ident n) t accu
)
Typer.empty_env
types
end
let parse_expr s =
let astexpr = Parser.expr (Stream.of_string s) in
let texpr = fst (Typer.type_expr BIN.env astexpr) in
texpr
;;
runtime/eval.ml
View file @
8c96ed41
...
...
@@ -63,11 +63,72 @@ let eval_var env locals = function
let
tag_op_resolved
=
Obj
.
tag
(
Obj
.
repr
(
OpResolved
((
fun
_
->
assert
false
)
,
[]
)))
let
tag_const
=
Obj
.
tag
(
Obj
.
repr
(
Const
(
Obj
.
magic
0
)))
(* ------------ Debugging printer *)
let
print_lst
f
ppf
l
=
let
rec
aux
ppf
=
function
|
[]
->
Format
.
fprintf
ppf
"@."
|
[
h
]
->
Format
.
fprintf
ppf
"%a"
f
h
|
h
::
t
->
Format
.
fprintf
ppf
"%a,%a"
f
h
aux
t
in
match
l
with
|
[]
->
Format
.
fprintf
ppf
""
|_
->
Format
.
fprintf
ppf
"%a"
aux
l
let
rec
pp_sigma
ppf
=
let
pp_aux
ppf
=
print_lst
(
fun
ppf
(
t1
,
t2
)
->
Format
.
fprintf
ppf
"(%a -> %a)"
Types
.
Print
.
print
t1
Types
.
Print
.
print
t2
)
ppf
in
function
|
Value
.
List
ll
->
Types
.
Tallying
.
CS
.
pp_sl
ppf
ll
|
Value
.
Comp
(
s1
,
s2
)
->
Format
.
fprintf
ppf
"Comp(%a,%a)"
pp_sigma
s1
pp_sigma
s2
|
Value
.
Sel
(
x
,
iface
,
s
)
->
Format
.
fprintf
ppf
"Sel(%d,%a,%a)"
x
pp_aux
iface
pp_sigma
s
|
Value
.
Identity
->
Format
.
fprintf
ppf
"Id"
and
pp_value
ppf
=
function
|
Value
.
Pair
(
v1
,
v2
,
sigma
)
->
Format
.
fprintf
ppf
"(%a,%a,%a)"
pp_value
v1
pp_value
v2
pp_sigma
sigma
|
Xml
(
_
,_,_,
sigma
)
->
Format
.
fprintf
ppf
"Xml(%a)"
pp_sigma
sigma
|
XmlNs
(
_
,_,_,_,
sigma
)
->
Format
.
fprintf
ppf
"XmlNs(%a)"
pp_sigma
sigma
|
Record
(
_
,
sigma
)
->
Format
.
fprintf
ppf
"Record(%a)"
pp_sigma
sigma
|
Atom
(
a
)
->
Format
.
fprintf
ppf
"Atom(%a)"
Atoms
.
V
.
print
a
|
Integer
(
i
)
->
Format
.
fprintf
ppf
"%d"
(
Big_int
.
int_of_big_int
i
)
|
Char
(
i
)
->
Format
.
fprintf
ppf
"Char()"
|
Abstraction
(
None
,
_
,
sigma
)
->
Format
.
fprintf
ppf
"Abstraction(None,%a)"
pp_sigma
sigma
|
Abstraction
(
Some
t
,
_
,
sigma
)
->
Format
.
fprintf
ppf
"Abstraction(%a,%a)"
pp_iface
t
pp_sigma
sigma
|
Abstract
((
name
,
_
))
->
Format
.
fprintf
ppf
"Abstract(%s)"
name
|
String_latin1
(
_
,_,
s
,_
)
->
Format
.
fprintf
ppf
"
\"
%s
\"
"
s
|
String_utf8
(
_
,_,
s
,_
)
->
Format
.
fprintf
ppf
"
\"
%s
\"
"
s
|
Concat
(
v1
,
v2
)
->
Format
.
fprintf
ppf
"Concat(%a, %a)"
pp_value
v1
pp_value
v2
|
Absent
->
Format
.
fprintf
ppf
"Absent"
and
pp_iface
ppf
l
=
let
f
ppf
(
t1
,
t2
)
=
Format
.
fprintf
ppf
"(%a,%a)"
Types
.
Print
.
print
t1
Types
.
Print
.
print
t2
in
print_lst
f
ppf
l
let
pp_lambda_env
ppf
env
locals
=
let
aux
a
=
let
l
=
Array
.
to_list
a
in
let
sl
=
List
.
mapi
(
fun
i
v
->
Format
.
fprintf
Format
.
str_formatter
"%d : %a@."
i
Value
.
print
v
;
Format
.
fprintf
Format
.
str_formatter
"%d : %a@."
i
pp_value
v
;
Format
.
flush_str_formatter
()
)
l
in
...
...
@@ -75,6 +136,8 @@ let pp_lambda_env ppf env locals =
in
Format
.
fprintf
ppf
"env = {%s}; locals = {%s}"
(
aux
env
)
(
aux
locals
)
(* ---------------- *)
let
apply_sigma
sigma
=
function
|
Value
.
Pair
(
v1
,
v2
,
sigma'
)
->
Value
.
Pair
(
v1
,
v2
,
Value
.
comp
sigma
sigma'
)
|
Value
.
Abstraction
(
iface
,
f
,
sigma'
)
->
Value
.
Abstraction
(
iface
,
f
,
Value
.
comp
sigma
sigma'
)
...
...
typing/typer.ml
View file @
8c96ed41
...
...
@@ -852,7 +852,6 @@ let flatten arg constr precise =
let
rec
type_check
env
e
constr
precise
=
Printf
.
printf
"aaaa
\n
%!"
;
let
(
ed
,
d
)
=
type_check'
e
.
exp_loc
env
e
.
exp_descr
constr
precise
in
let
d
=
if
precise
then
d
else
constr
in
e
.
exp_typ
<-
Types
.
cup
e
.
exp_typ
d
;
...
...
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