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
5dd9400e
Commit
5dd9400e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2007-06-12 12:58:41 by afrisch] starting to upgrade to OCaml 3.10
Original author: afrisch Date: 2007-06-12 12:59:44+00:00
parent
36908774
Changes
36
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
5dd9400e
...
...
@@ -66,14 +66,14 @@ ifeq ($(NATIVE), true)
EXTENSION_LIB
=
cmxa
CAML
=
ocamlopt
COMPILE
=
$(CAMLOPT)
LINK
=
$(CAMLOPT)
-linkpkg
gramlib.cmxa
camlp4.cmxa
pr_o.cmx
LINK
=
$(CAMLOPT)
-linkpkg
camlp4
lib
.cmxa
SYNTAX
+=
-symbol
ocaml_compiler
=
\"
native
\"
else
EXTENSION
=
cmo
EXTENSION_LIB
=
cma
COMPILE
=
$(CAMLC)
CAML
=
ocamlc
LINK
=
$(CAMLC)
-custom
-linkpkg
gramlib.cma
camlp4.cma
pr_o.cmo
LINK
=
$(CAMLC)
-custom
-linkpkg
camlp4
lib
.cma
SYNTAX
+=
-symbol
ocaml_compiler
=
\"
bytecode
\"
endif
...
...
@@ -131,7 +131,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
OBJECTS
=
\
driver/config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo
\
driver/
cduce_
config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo
\
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo
\
\
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo
\
...
...
@@ -151,7 +151,7 @@ OBJECTS = \
compile/lambda.cmo
\
runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo
\
\
parser/
location
.cmo parser/url.cmo
\
parser/
cduce_loc
.cmo parser/url.cmo
\
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo
\
\
typing/typed.cmo typing/typepat.cmo types/externals.cmo typing/typer.cmo
\
...
...
@@ -281,7 +281,7 @@ $(ALL_INTERFACES): misc/q_symbol.cmo
misc/q_symbol.cmo
:
misc/q_symbol.ml
@
echo
"Build
$@
"
$(HIDE)$(CAMLC)
-c
-pp
'
camlp4o
pa_extend.cmo q_MLast.cmo'
$<
$(HIDE)$(CAMLC)
-c
-pp
camlp4o
rf
$<
.ml.cmo
:
@
echo
"Build
$@
"
...
...
compile/compile.ml
View file @
5dd9400e
...
...
@@ -174,7 +174,7 @@ let compile_rec_funs env funs =
(****************************************)
open
Location
open
Cduce_loc
let
eval
~
run
~
show
(
tenv
,
cenv
,
codes
)
e
=
let
(
e
,
t
)
=
Typer
.
type_expr
tenv
e
in
...
...
compile/operators.ml
View file @
5dd9400e
open
Location
open
Cduce_loc
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
let
register
op
arity
typ
eval
=
...
...
compile/operators.mli
View file @
5dd9400e
open
Location
open
Cduce_loc
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
val
register
:
...
...
depend
View file @
5dd9400e
This diff is collapsed.
Click to expand it.
driver/cduce.ml
View file @
5dd9400e
open
Location
open
Cduce_loc
open
Ident
let
()
=
Stats
.
gettimeofday
:=
Unix
.
gettimeofday
...
...
@@ -79,8 +79,8 @@ let directive_help ppf =
let
rec
print_exn
ppf
=
function
|
Location
(
loc
,
w
,
exn
)
->
Location
.
print_loc
ppf
(
loc
,
w
);
Location
.
html_hilight
(
loc
,
w
);
Cduce_loc
.
print_loc
ppf
(
loc
,
w
);
Cduce_loc
.
html_hilight
(
loc
,
w
);
print_exn
ppf
exn
|
Value
.
CDuceExn
v
->
Format
.
fprintf
ppf
"Uncaught CDuce exception: @[%a@]@."
...
...
@@ -121,9 +121,9 @@ let rec print_exn ppf = function
U
.
print
(
Librarian
.
name
cu
)
Ident
.
print
x
|
Ulexer
.
Error
(
i
,
j
,
s
)
->
let
loc
=
Location
.
loc_of_pos
(
i
,
j
)
,
`Full
in
Location
.
print_loc
ppf
loc
;
Location
.
html_hilight
loc
;
let
loc
=
Cduce_loc
.
loc_of_pos
(
i
,
j
)
,
`Full
in
Cduce_loc
.
print_loc
ppf
loc
;
Cduce_loc
.
html_hilight
loc
;
Format
.
fprintf
ppf
"%s"
s
|
Parser
.
Error
s
|
Stream
.
Error
s
->
Format
.
fprintf
ppf
"Parsing error: %a@."
print_protect
s
...
...
@@ -145,7 +145,7 @@ let rec print_exn ppf = function
Format
.
fprintf
ppf
"Invalid object file %s@."
f
|
Librarian
.
CannotOpen
f
->
Format
.
fprintf
ppf
"Cannot open file %s@."
f
|
Location
.
Generic
s
->
|
Cduce_loc
.
Generic
s
->
Format
.
fprintf
ppf
"%a@."
print_protect
s
|
Ns
.
Label
.
Not_unique
((
ns1
,
s1
)
,
(
ns2
,
s2
))
->
Format
.
fprintf
ppf
"Collision on label hash: {%a}:%a, {%a}:%a"
...
...
driver/config.ml
→
driver/
cduce_
config.ml
View file @
5dd9400e
File moved
driver/config.mli
→
driver/
cduce_
config.mli
View file @
5dd9400e
File moved
driver/evaluator.ml
View file @
5dd9400e
...
...
@@ -35,19 +35,19 @@ let () =
ignore
(
Unix
.
alarm
10
);
Sys
.
set_signal
Sys
.
sigalrm
(
Sys
.
Signal_handle
(
fun
_
->
raise
(
Cduce
.
Escape
Timeout
)));
let
v
=
Location
.
get_viewport
()
in
let
v
=
Cduce_loc
.
get_viewport
()
in
let
ppf
=
Html
.
ppf
v
and
input
=
Stream
.
of_string
src
in
Format
.
pp_set_margin
ppf
60
;
Location
.
push_source
(
`String
src
);
Location
.
set_protected
true
;
Config
.
init_all
()
;
Cduce_loc
.
push_source
(
`String
src
);
Cduce_loc
.
set_protected
true
;
C
duce_c
onfig
.
init_all
()
;
let
ok
=
Cduce
.
script
ppf
ppf
input
in
if
ok
then
Format
.
fprintf
ppf
"@
\n
Ok.@
\n
"
;
Html
.
get
v
in
Location
.
set_viewport
(
Html
.
create
true
);
Cduce_loc
.
set_viewport
(
Html
.
create
true
);
let
prog
=
Buffer
.
create
1024
in
(
try
while
true
do
Buffer
.
add_string
prog
(
read_line
()
);
Buffer
.
add_string
prog
"
\n
"
done
;
with
End_of_file
->
()
);
...
...
driver/librarian.ml
View file @
5dd9400e
open
Location
open
Cduce_loc
open
Ident
...
...
@@ -77,17 +77,17 @@ let show ppf id t v =
let
compile
verbose
name
src
=
protect_op
"Compile external file"
;
let
ic
=
if
src
=
""
then
(
Location
.
push_source
`Stream
;
stdin
)
if
src
=
""
then
(
Cduce_loc
.
push_source
`Stream
;
stdin
)
else
try
Location
.
push_source
(
`File
src
);
open_in
src
try
Cduce_loc
.
push_source
(
`File
src
);
open_in
src
with
Sys_error
_
->
raise
(
CannotOpen
src
)
in
let
input
=
Stream
.
of_channel
ic
in
let
p
=
try
Parser
.
prog
input
with
|
Stdpp
.
Exc_located
(
_
,
(
Location
_
|
Ulexer
.
Error
_
as
e
))
->
raise
e
|
Stdpp
.
Exc_located
((
i
,
j
)
,
e
)
->
raise_loc
i
.
Lexing
.
pos_cnum
j
.
Lexing
.
pos_cnum
e
|
Ulexer
.
Loc
.
Exc_located
(
_
,
(
Location
_
|
Ulexer
.
Error
_
as
e
))
->
raise
e
|
Ulexer
.
Loc
.
Exc_located
((
i
,
j
)
,
e
)
->
raise_loc
i
j
e
in
if
src
<>
""
then
close_in
ic
;
...
...
driver/run.ml
View file @
5dd9400e
...
...
@@ -15,7 +15,7 @@ let version () =
Printf
.
eprintf
"built on %s
\n
"
<:
symbol
<
build_date
>>;
Printf
.
eprintf
"using OCaml %s compiler
\n
"
<:
symbol
<
ocaml_compiler
>>;
Printf
.
eprintf
"Supported features:
\n
"
;
List
.
iter
(
fun
(
n
,
d
)
->
Printf
.
eprintf
"- %s: %s
\n
"
n
d
)
(
Config
.
descrs
()
);
List
.
iter
(
fun
(
n
,
d
)
->
Printf
.
eprintf
"- %s: %s
\n
"
n
d
)
(
C
duce_c
onfig
.
descrs
()
);
exit
0
let
specs
=
...
...
@@ -29,7 +29,7 @@ let specs =
"(for --compile) show types of exported values"
;
"--obj-dir"
,
Arg
.
String
(
fun
s
->
out_dir
:=
s
::
!
out_dir
)
,
"(for --compile) directory for the compiled .cdo file"
;
"-I"
,
Arg
.
String
(
fun
s
->
Location
.
obj_path
:=
s
::!
Location
.
obj_path
)
,
"-I"
,
Arg
.
String
(
fun
s
->
Cduce_loc
.
obj_path
:=
s
::!
Cduce_loc
.
obj_path
)
,
" add one directory to the lookup path for .cdo/.cmi and include files"
;
"--stdin"
,
Arg
.
Unit
(
fun
()
->
src
:=
""
::
!
src
)
,
" read CDuce script on standard input"
;
...
...
@@ -40,7 +40,7 @@ let specs =
src
:=
s
::
!
src
)
else
args
:=
s
::
!
args
)
,
" the first argument after is the source, then the arguments"
;
"--no"
,
Arg
.
String
Config
.
inhibit
,
"--no"
,
Arg
.
String
C
duce_c
onfig
.
inhibit
,
" disable a feature (cduce -v to get a list of features)"
;
"--debug"
,
Arg
.
Unit
(
fun
()
->
Stats
.
set_verbosity
Stats
.
Summary
)
,
" print profiling/debugging information"
;
...
...
@@ -124,7 +124,7 @@ let toploop () =
Cduce
.
toplevel
:=
true
;
Librarian
.
run_loaded
:=
true
;
let
buf_in
=
Buffer
.
create
1024
in
Location
.
push_source
(
`Buffer
buf_in
);
Cduce_loc
.
push_source
(
`Buffer
buf_in
);
let
read
_i
=
if
!
bol
then
if
!
Ulexer
.
in_comment
then
outflush
"* "
else
outflush
"> "
;
...
...
@@ -151,26 +151,26 @@ let argv args =
let
main
()
=
at_exit
(
fun
()
->
Stats
.
dump
Format
.
std_formatter
);
Location
.
set_viewport
(
Html
.
create
false
);
Cduce_loc
.
set_viewport
(
Html
.
create
false
);
match
mode
()
with
|
`Toplevel
args
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
Builtin
.
argv
:=
argv
args
;
toploop
()
|
`Script
(
f
,
args
)
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
Builtin
.
argv
:=
argv
args
;
Cduce
.
compile_run
f
|
`Compile
(
f
,
o
)
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
Cduce
.
compile
f
o
|
`Run
(
f
,
args
)
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
Builtin
.
argv
:=
argv
args
;
Cduce
.
run
f
|
`Mlstub
f
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
Librarian
.
prepare_stub
f
|
`Topstub
f
->
Config
.
init_all
()
;
C
duce_c
onfig
.
init_all
()
;
!
Librarian
.
make_wrapper
f
driver/webiface.ml
View file @
5dd9400e
...
...
@@ -129,11 +129,11 @@ let main (cgi : Netcgi.std_activation) =
let
dialog
content
=
html_form
p
content
in
let
exec
src
=
let
v
=
Location
.
get_viewport
()
in
let
v
=
Cduce_loc
.
get_viewport
()
in
let
ppf
=
Html
.
ppf
v
and
input
=
Stream
.
of_string
src
in
Location
.
push_source
(
`String
src
);
Location
.
set_protected
true
;
Cduce_loc
.
push_source
(
`String
src
);
Cduce_loc
.
set_protected
true
;
let
ok
=
Cduce
.
script
ppf
ppf
input
in
if
ok
then
Format
.
fprintf
ppf
"@
\n
Ok.@
\n
"
;
...
...
@@ -144,7 +144,7 @@ let main (cgi : Netcgi.std_activation) =
dialog
src
in
Location
.
set_viewport
(
Html
.
create
true
);
Cduce_loc
.
set_viewport
(
Html
.
create
true
);
html_header
p
;
let
prog
=
cgi
#
argument_value
"prog"
in
(
match
cmd
with
...
...
misc/q_symbol.ml
View file @
5dd9400e
open
Camlp4
.
PreCast
module
Caml_syntax
=
Syntax
let
symbols
=
ref
[]
let
define
s
=
let
i
=
try
String
.
index
s
'
=
'
with
Not_found
->
failwith
(
"Invalid symbol definition :"
^
s
)
in
symbols
:=
(
String
.
sub
s
0
i
,
String
.
sub
s
(
i
+
1
)
(
String
.
length
s
-
i
-
1
))
::
!
symbols
let
symbol
=
String
.
sub
s
0
i
in
let
value
=
Gram
.
parse_string
Caml_syntax
.
expr
(
Loc
.
mk
"<from-string>"
)
(
String
.
sub
s
(
i
+
1
)
(
String
.
length
s
-
i
-
1
))
in
symbols
:=
(
symbol
,
value
)
::
!
symbols
EXTEND
GLOBAL
:
Pc
aml
.
str_item
;
EXTEND
Caml_syntax
.
Gram
GLOBAL
:
C
aml
_syntax
.
str_item
;
Pc
aml
.
str_item
:
FIRST
C
aml
_syntax
.
str_item
:
FIRST
[
[
"ifdef"
;
c
=
UIDENT
;
"then"
;
e1
=
SELF
;
"else"
;
e2
=
SELF
->
if
List
.
mem_assoc
c
!
symbols
then
e1
else
e2
|
"ifdef"
;
c
=
UIDENT
;
"then"
;
e1
=
SELF
->
if
List
.
mem_assoc
c
!
symbols
then
e1
else
<:
str_item
<
declare
end
>>
if
List
.
mem_assoc
c
!
symbols
then
e1
else
<:
str_item
<>>
|
"ifndef"
;
c
=
UIDENT
;
"then"
;
e1
=
SELF
;
"else"
;
e2
=
SELF
->
if
List
.
mem_assoc
c
!
symbols
then
e2
else
e1
|
"ifndef"
;
c
=
UIDENT
;
"then"
;
e1
=
SELF
->
if
List
.
mem_assoc
c
!
symbols
then
<:
str_item
<
declare
end
>>
else
e1
if
List
.
mem_assoc
c
!
symbols
then
<:
str_item
<>>
else
e1
]
];
END
let
expr
_
s
=
let
expr
_
_
s
=
try
List
.
assoc
s
!
symbols
with
Not_found
->
failwith
(
"No definition for symbol "
^
s
)
let
_
=
Quotation
.
add
"symbol"
(
Quotation
.
ExStr
expr
)
;
Pc
aml
.
add_option
"-symbol"
(
Arg
.
String
define
)
Quotation
.
add
"symbol"
Quotation
.
DynAst
.
expr_tag
expr
;
C
aml
p4
.
Options
.
add
"-symbol"
(
Arg
.
String
define
)
"<symbol=value> Define a symbol"
ocamliface/mlstub.ml
View file @
5dd9400e
...
...
@@ -516,29 +516,20 @@ let stub ty_env c_env exts values mk prolog =
let
items_expr
=
List
.
map
(
fun
(
_
,
e
,_
)
->
e
)
items
in
let
items_pat
=
List
.
map
(
fun
(
p
,_,_
)
->
p
)
items
in
let
m
=
[
<:
str_item
<
open
Cduce_lib
>>;
<:
str_item
<
Config
.
init_all
()
>>;
<:
str_item
<
value
(
types
,
set_externals
,
slots
,
run
)
=
Librarian
.
ocaml_stub
$
str
:
String
.
escaped
raw
$
>>
]
@
(
if
g
=
[]
then
[]
else
[
<:
str_item
<
value
rec
$
list
:
g
$
>>
])
@
[
<:
str_item
<
set_externals
[
|$
list
:
exts
$|
]
>>;
<:
str_item
<
run
()
>>
]
@
(
if
items
=
[]
then
[]
else
[
<:
str_item
<
value
$
list
:
items_def
$
>>
])
in
let
items_expr
=
match
items_expr
with
|
[]
->
<:
expr
<
()
>>
|
l
->
<:
expr
<
(
$
list
:
l
$
)
>>
in
let
str_items
=
[
<:
str_item
<
value
(
$
list
:
items_pat
$
)
=
let
module
C
=
struct
$
list
:
m
$
end
in
$
items_expr
$
>>,
(
Lexing
.
dummy_pos
,
Lexing
.
dummy_pos
)
]
in
<:
str_item
<
value
(
$
paCom_of_list
items_pat
$
)
=
let
module
C
=
struct
open
Cduce_lib
;
Cduce_config
.
init_all
()
;
value
(
types
,
set_externals
,
slots
,
run
)
=
Librarian
.
ocaml_stub
$
str
:
String
.
escaped
raw
$;
value
rec
$
biAnd_of_list
g
$;
set_externals
[
|$
exSem_of_list
exts
$|
];
run
()
;
value
$
biAnd_of_list
items_def
$;
end
in
(
$
exCom_of_list
items_expr
$
)
>>
in
print_endline
prolog
;
!
Pcaml
.
print_implem
str_items
(* let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in
...
...
@@ -599,12 +590,12 @@ let wrapper values =
values
in
let
g
=
global_transl
()
in
let
m
=
if
g
=
[]
then
exts
else
<:
str_item
<
value
rec
$
list
:
g
$
>>::
exts
in
let
m
=
[
<:
str_item
<
open
Cduce_lib
>>
;
<:
str_item
<
C
onfig
.
init_all
()
>>
]
@
m
in
<:
str_item
<
declare
$
list
:
m
$
end
>>
<:
str_item
<
open
Cduce_lib
;
Cduce_c
onfig
.
init_all
()
;
value
rec
$
biAnd_of_list
g
$;
$
stSem_of_list
exts
$;
>>
let
gen_wrapper
vals
=
try
...
...
parser/ast.ml
View file @
5dd9400e
(* Abstract syntax as produced by the parser *)
open
Location
open
Cduce_loc
open
Ident
type
ns_expr
=
[
`Uri
of
Ns
.
Uri
.
t
|
`Path
of
U
.
t
list
]
...
...
@@ -9,7 +9,7 @@ type pprog = pmodule_item list
and
pmodule_item
=
pmodule_item'
located
and
pmodule_item'
=
|
TypeDecl
of
(
Location
.
loc
*
U
.
t
)
*
ppat
|
TypeDecl
of
(
Cduce_loc
.
loc
*
U
.
t
)
*
ppat
|
SchemaDecl
of
U
.
t
*
string
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
...
...
@@ -86,7 +86,7 @@ and pexpr =
and
label
=
U
.
t
and
abstr
=
{
fun_name
:
(
Location
.
loc
*
U
.
t
)
option
;
fun_name
:
(
Cduce_loc
.
loc
*
U
.
t
)
option
;
fun_iface
:
(
ppat
*
ppat
)
list
;
fun_body
:
branches
}
...
...
@@ -100,7 +100,7 @@ and ppat' =
|
PatVar
of
U
.
t
list
|
Cst
of
pexpr
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
Location
.
loc
*
U
.
t
*
ppat
)
list
|
Recurs
of
ppat
*
(
Cduce_loc
.
loc
*
U
.
t
*
ppat
)
list
|
Internal
of
Types
.
descr
|
Or
of
ppat
*
ppat
|
And
of
ppat
*
ppat
...
...
@@ -123,7 +123,7 @@ and regexp =
|
Alt
of
regexp
*
regexp
|
Star
of
regexp
|
WeakStar
of
regexp
|
SeqCapture
of
Location
.
loc
*
U
.
t
*
regexp
|
SeqCapture
of
Cduce_loc
.
loc
*
U
.
t
*
regexp
let
pat_true
=
mknoloc
(
Internal
Builtin_defs
.
true_type
)
...
...
parser/cduce_curl.ml
View file @
5dd9400e
...
...
@@ -11,7 +11,7 @@ let load_url s =
let
()
=
Config
.
register
C
duce_c
onfig
.
register
"curl"
"Load external URLs with curl"
(
fun
()
->
Url
.
url_loader
:=
load_url
)
parser/
location
.ml
→
parser/
cduce_loc
.ml
View file @
5dd9400e
...
...
@@ -108,7 +108,7 @@ let extr s i j =
try
let
n
=
min
(
String
.
length
s
)
j
-
i
in
if
n
<=
0
then
""
else
String
.
sub
s
i
n
with
e
->
failwith
(
Printf
.
sprintf
"
Location
.extr len=%i i=%i j=%i"
with
e
->
failwith
(
Printf
.
sprintf
"
Cduce_loc
.extr len=%i i=%i j=%i"
(
String
.
length
s
)
i
j
)
let
dump_loc
((
src
,
i
,
j
)
,
w
)
=
...
...
@@ -152,7 +152,7 @@ let html_hilight ((src,i,j),w) =
type
'
a
located
=
{
loc
:
loc
;
descr
:
'
a
}
let
mk
(
i
,
j
)
x
=
{
loc
=
(
!
source
,
i
,
j
);
descr
=
x
}
let
mk
_located
(
i
,
j
)
x
=
{
loc
=
(
!
source
,
i
,
j
);
descr
=
x
}
let
mk_loc
loc
x
=
{
loc
=
loc
;
descr
=
x
}
let
mknoloc
x
=
{
loc
=
noloc
;
descr
=
x
}
let
loc_of_pos
(
i
,
j
)
=
(
!
source
,
i
,
j
)
...
...
@@ -178,3 +178,6 @@ let resolve_filename s =
Filename
.
concat
p
s
with
Not_found
->
s
else
s
include
Camlp4
.
PreCast
.
Loc
parser/
location
.mli
→
parser/
cduce_loc
.mli
View file @
5dd9400e
(* Locations in source file,
and presentation of results and errors *)
(* include Camlp4.Sig.Loc *)
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
|
`Buffer
of
Buffer
.
t
]
...
...
@@ -37,7 +39,7 @@ val dump_loc: loc * precise -> unit
val
html_hilight
:
loc
*
precise
->
unit
type
'
a
located
=
{
loc
:
loc
;
descr
:
'
a
}
val
mk
:
int
*
int
->
'
a
->
'
a
located
val
mk
_located
:
int
*
int
->
'
a
->
'
a
located
val
mk_loc
:
loc
->
'
a
->
'
a
located
val
mknoloc
:
'
a
->
'
a
located
...
...
parser/cduce_netclient.ml
View file @
5dd9400e
...
...
@@ -29,7 +29,7 @@ let load_url s =
error
msg
let
()
=
Config
.
register
C
duce_c
onfig
.
register
"netclient"
"Load external URLs with netclient"
(
fun
()
->
Url
.
url_loader
:=
load_url
)
parser/parser.ml
View file @
5dd9400e
#
load
"pa_extend.cmo"
;;
open
Location
open
Cduce_loc
(* let raise = Pervasives.raise *)
open
Ast
open
Ident
open
Printf
open
Ulexer
(*
let () = Grammar.error_verbose := true
*)
let
tloc
(
i
,
j
)
=
(
i
.
Lexing
.
pos_cnum
,
j
.
Lexing
.
pos_cnum
)
let
nopos
=
(
Lexing
.
dummy_pos
,
Lexing
.
dummy_pos
)
let
tloc
(
i
,
j
)
=
(
i
,
j
)
let
nopos
=
(
-
1
,-
1
)
let
mk
loc
x
=
Location
.
mk
(
tloc
loc
)
x
let
mk
loc
x
=
Cduce_loc
.
mk_located
(
tloc
loc
)
x
exception
Error
of
string
let
error
(
i
,
j
)
s
=
Location
.
raise_loc
i
j
(
Error
s
)
let
error
(
i
,
j
)
s
=
Cduce_loc
.
raise_loc
i
j
(
Error
s
)
let
error
loc
s
=
error
(
tloc
loc
)
s
let
gram
=
Grammar
.
gcreate
Ulexer
.
lex
module
Gram
=
Camlp4
.
Struct
.
Grammar
.
Static
.
Make
(
Ulexer
)
let
id_dummy
=
U
.
mk
"$$$"
...
...
@@ -36,14 +38,14 @@ let ident s =
let
label
s
=
U
.
mk
(
ident
s
)
let
ident
s
=
U
.
mk
(
ident
s
)
let
prog
=
Gram
mar
.
Entry
.
create
gra
m
"prog"
let
top_phrases
=
Gram
mar
.
Entry
.
create
gra
m
"toplevel phrases"
let
expr
=
Gram
mar
.
Entry
.
create
gra
m
"expression"
let
pat
=
Gram
mar
.
Entry
.
create
gra
m
"type/pattern expression"
let
regexp
=
Gram
mar
.
Entry
.
create
gra
m
"type/pattern regexp"
let
keyword
=
Gram
mar
.
Entry
.
create
gra
m
"keyword"
let
prog
=
Gram
.
Entry
.
m
k
"prog"
let
top_phrases
=
Gram
.
Entry
.
m
k
"toplevel phrases"
let
expr
=
Gram
.
Entry
.
m
k
"expression"
let
pat
=
Gram
.
Entry
.
m
k
"type/pattern expression"
let
regexp
=
Gram
.
Entry
.
m
k
"type/pattern regexp"
let
keyword
=
Gram
.
Entry
.
m
k
"keyword"
let
lop
pos
=
loc_of_pos
(
tloc
pos
)
let
lop
pos
=
Cduce_loc
.
loc_of_pos
(
tloc
pos
)
let
exp
pos
e
=
LocatedExpr
(
lop
pos
,
e
)
let
rec
multi_prod
loc
=
function
...
...
@@ -86,24 +88,26 @@ let protect_exn f g =
let
localize_exn
f
=
try
f
()
with
|
Stdpp
.
Exc_located
(
_
,
(
Location
_
as
e
))
->
raise
e
(* | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e *)
|
Stdpp
.
Exc_located
((
i
,
j
)
,
e
)
->
raise_loc
i
.
Lexing
.
pos_cnum
j
.
Lexing
.
pos_cnum
e
|
Ulexer
.
Loc
.
Exc_located
(
_
,
(
Location
_
as
e
))
->
raise
e
(* | Camlp4.PreCast.Loc.Exc_located ((i,j), e) -> raise_loc i j e *)
|
Ulexer
.
Loc
.
Exc_located
(
loc
,
e
)
->
let
i
,
j
=
Ulexer
.
Loc
.
start_off
loc
,
Ulexer
.
Loc
.
stop_off
loc
in
raise_loc
i
j
e
let
is_fun_decl
=
Gram
mar
.
Entry
.
of_parser
gram
"[is_fun_decl]"
Gram
.
Entry
.
of_parser
"[is_fun_decl]"
(
fun
strm
->
match
Stream
.
npeek
3
strm
with
|
[
(
""
,
"fun"
);
(
"
IDENT
"
,
_
)
;
(
""
,
"("
)
]
|
[
(
"
IDENT
"
,
_
)
;
(
""
,
"("
)
;
_
]
->
()
|
[
KEYWORD
"fun"
,
_
;
IDENT
_
,
_
;
KEYWORD
"("
,
_
]
|
[
IDENT
_
,
_
;
KEYWORD
"("
,
_
;
_
]
->
()
|
_
->
raise
Stream
.
Failure
)
let
is_capture
=
Gram
mar
.
Entry
.
of_parser
gram
"[is_capture]"
Gram
.
Entry
.
of_parser
"[is_capture]"
(
fun
strm
->
match
Stream
.
npeek
2
strm
with
|
[
(
"
IDENT
"
,
_
)
;
(
""
,
"::"
)
;
_
]
->
()
|
[
IDENT
_
,
_
;
KEYWORD
"::"
,
_
;
_
]
->
()
|
_
->
raise
Stream
.
Failure
)
...
...
@@ -123,7 +127,7 @@ let let_in e1 p e2 = Match (e1, [p,e2])
let
seq
e1
e2
=
let_in
e1
pat_nil
e2
let
concat
e1
e2
=
apply_op2_noloc
"@"
e1
e2
EXTEND
EXTEND
Gram
GLOBAL
:
top_phrases
prog
expr
pat
regexp
keyword
;
top_phrases
:
[
...
...
@@ -131,7 +135,7 @@ EXTEND
];
prog
:
[
[
l
=
LIST0
[
p
=
phrase
;
OPT
";;"
->
p
];
EOI
->
List
.
flatten
l
]
[
l
=
LIST0
[
p
=
phrase
;
OPT
";;"
->
p
];
`
EOI
->
List
.
flatten
l
]
];
phrase
:
[
...
...
@@ -141,9 +145,9 @@ EXTEND
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
[
mk
_loc
(
EvalStatement
(
exp
_loc
(
let_in
e1
p
e2
)))
]
|
"type"
;
x
=
located_ident
;
"="
;
t
=
pat
->
[
mk
_loc
(
TypeDecl
(
x
,
t
))
]
|
"using"
;
name
=
IDENT
;
"="
;
cu
=
[
IDENT
|
STRING2
]
->
|
"using"
;
name
=
IDENT
;
"="
;
cu
=
[
x
=
IDENT
->
x
|
x
=
STRING2
->
x
]
->
[
mk
_loc
(
Using
(
U
.
mk
name
,
U
.
mk
cu
))
]
|
"open"
;
ids
=
LIST1
[
IDENT
|
keyword
]
SEP
"."
->
|
"open"
;
ids
=
LIST1
ident_or_
keyword
SEP
"."
->
let
ids
=
List
.
map
(
fun
x
->
ident
x
)
ids
in
[
mk
_loc
(
Open
ids
)
]
|
"schema"
;
name
=
IDENT
;
"="
;
uri
=
STRING2
->
...
...
@@ -177,14 +181,14 @@ EXTEND
|
"#"
;
IDENT
"builtins"
->
[
mk
_loc
(
Directive
`Builtins
)
]