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
0a3f7c1b
Commit
0a3f7c1b
authored
Jul 10, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[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
84721bb3
Changes
36
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
36 changed files
with
484 additions
and
381 deletions
+484
-381
Makefile.distrib
Makefile.distrib
+5
-5
compile/compile.ml
compile/compile.ml
+1
-1
compile/operators.ml
compile/operators.ml
+1
-1
compile/operators.mli
compile/operators.mli
+1
-1
depend
depend
+123
-139
driver/cduce.ml
driver/cduce.ml
+7
-7
driver/cduce_config.ml
driver/cduce_config.ml
+0
-0
driver/cduce_config.mli
driver/cduce_config.mli
+0
-0
driver/evaluator.ml
driver/evaluator.ml
+5
-5
driver/librarian.ml
driver/librarian.ml
+6
-6
driver/run.ml
driver/run.ml
+11
-11
driver/webiface.ml
driver/webiface.ml
+4
-4
misc/q_symbol.ml
misc/q_symbol.ml
+17
-11
ocamliface/mlstub.ml
ocamliface/mlstub.ml
+19
-28
parser/ast.ml
parser/ast.ml
+5
-5
parser/cduce_curl.ml
parser/cduce_curl.ml
+1
-1
parser/cduce_loc.ml
parser/cduce_loc.ml
+5
-2
parser/cduce_loc.mli
parser/cduce_loc.mli
+3
-1
parser/cduce_netclient.ml
parser/cduce_netclient.ml
+1
-1
parser/parser.ml
parser/parser.ml
+55
-53
parser/parser.mli
parser/parser.mli
+5
-3
parser/ulexer.ml
parser/ulexer.ml
+155
-56
parser/ulexer.mli
parser/ulexer.mli
+17
-3
parser/url.ml
parser/url.ml
+1
-1
parser/wlexer.ml
parser/wlexer.ml
+2
-2
runtime/cduce_expat.ml
runtime/cduce_expat.ml
+1
-1
runtime/cduce_pxp.ml
runtime/cduce_pxp.ml
+1
-1
runtime/load_xml.ml
runtime/load_xml.ml
+1
-1
runtime/run_dispatch.ml
runtime/run_dispatch.ml
+0
-2
runtime/system.ml
runtime/system.ml
+4
-4
types/builtin.ml
types/builtin.ml
+10
-10
types/externals.ml
types/externals.ml
+1
-1
types/types.ml
types/types.ml
+3
-1
typing/typed.ml
typing/typed.ml
+1
-1
typing/typer.ml
typing/typer.ml
+7
-7
typing/typer.mli
typing/typer.mli
+5
-5
No files found.
Makefile.distrib
View file @
0a3f7c1b
...
...
@@ -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
camlp4lib.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
camlp4lib.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/c
duce_c
onfig.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
camlp4orf
$<
.ml.cmo
:
@
echo
"Build
$@
"
...
...
compile/compile.ml
View file @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
open
Location
open
Cduce_loc
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
let
register
op
arity
typ
eval
=
...
...
compile/operators.mli
View file @
0a3f7c1b
open
Location
open
Cduce_loc
type
type_fun
=
Types
.
t
->
bool
->
Types
.
t
val
register
:
...
...
depend
View file @
0a3f7c1b
This diff is collapsed.
Click to expand it.
driver/cduce.ml
View file @
0a3f7c1b
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/c
duce_c
onfig.ml
View file @
0a3f7c1b
File moved
driver/config.mli
→
driver/c
duce_c
onfig.mli
View file @
0a3f7c1b
File moved
driver/evaluator.ml
View file @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
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 @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
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
:
Pcaml
.
str_item
;
EXTEND
Caml_syntax
.
Gram
GLOBAL
:
Caml_syntax
.
str_item
;
Pcaml
.
str_item
:
FIRST
Caml_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
)
;
Pcaml
.
add_option
"-symbol"
(
Arg
.
String
define
)
Quotation
.
add
"symbol"
Quotation
.
DynAst
.
expr_tag
expr
;
Camlp4
.
Options
.
add
"-symbol"
(
Arg
.
String
define
)
"<symbol=value> Define a symbol"
ocamliface/mlstub.ml
View file @
0a3f7c1b
...
...
@@ -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
<
Config
.
init_all
()
>>
]
@
m
in
<:
str_item
<
declare
$
list
:
m
$
end
>>
<:
str_item
<
open
Cduce_lib
;
Cduce_config
.
init_all
()
;
value
rec
$
biAnd_of_list
g
$;
$
stSem_of_list
exts
$;
>>
let
gen_wrapper
vals
=
try
...
...
parser/ast.ml
View file @
0a3f7c1b
(* 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 @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
(* 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 @
0a3f7c1b
...
...
@@ -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 @
0a3f7c1b
#
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
gram
"prog"
let
top_phrases
=
Gram
mar
.
Entry
.
create
gram
"toplevel phrases"
let
expr
=
Gram
mar
.
Entry
.
create
gram
"expression"
let
pat
=
Gram
mar
.
Entry
.
create
gram
"type/pattern expression"
let
regexp
=
Gram
mar
.
Entry
.
create
gram
"type/pattern regexp"
let
keyword
=
Gram
mar
.
Entry
.
create
gram
"keyword"
let
prog
=
Gram
.
Entry
.
mk
"prog"
let
top_phrases
=
Gram
.
Entry
.
mk
"toplevel phrases"
let
expr
=
Gram
.
Entry
.
mk
"expression"
let
pat
=
Gram
.
Entry
.
mk
"type/pattern expression"
let
regexp
=
Gram
.
Entry
.
mk
"type/pattern regexp"
let
keyword
=
Gram
.
Entry
.
mk
"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
)
]
|
"include"
;
s
=
STRING2
->
protect_op
"File inclusion"
;
let
s
=
Location
.
resolve_filename
s
in
let
s
=
Cduce_loc
.
resolve_filename
s
in
(* avoid looping; should issue an error ? *)
(* it is possible to have looping with x/../x/../x/.. ....
Need to canonicalize filename *)
if
List
.
mem
s
!
include_stack
then
[]
else
(
include_stack
:=
s
::
!
include_stack
;
Location
.
push_source
(
`File
s
);
Cduce_loc
.
push_source
(
`File
s
);
let
saved_enc
=
!
Ulexer
.
enc
in
Ulexer
.
enc
:=
Ulexing
.
Latin1
;
protect_exn
...
...
@@ -193,11 +197,11 @@ EXTEND
protect_exn
(
fun
()
->
let
input
=
Stream
.
of_channel
chan
in
localize_exn
(
fun
()
->
Gram
mar
.
Entry
.
parse
prog
input
))
localize_exn
(
fun
()
->
Gram
.
parse
prog
Ulexer
.
Loc
.
ghost
input
))
(
fun
()
->
close_in
chan
))
(
fun
()
->
Ulexer
.
enc
:=
saved_enc
;
Location
.
pop_source
()
;