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
770a37b9
Commit
770a37b9
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-07-30 09:27:30 by afrisch] New printer for locations
Original author: afrisch Date: 2005-07-30 09:27:30+00:00
parent
885263ab
Changes
6
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
770a37b9
...
...
@@ -79,7 +79,7 @@ let directive_help ppf =
let
rec
print_exn
ppf
=
function
|
Location
(
loc
,
w
,
exn
)
->
Format
.
fprintf
ppf
"Error %a:@."
Location
.
print_loc
(
loc
,
w
);
Location
.
print_loc
ppf
(
loc
,
w
);
Location
.
html_hilight
(
loc
,
w
);
print_exn
ppf
exn
|
Value
.
CDuceExn
v
->
...
...
@@ -122,7 +122,7 @@ let rec print_exn ppf = function
Ident
.
print
x
|
Ulexer
.
Error
(
i
,
j
,
s
)
->
let
loc
=
Location
.
loc_of_pos
(
i
,
j
)
,
`Full
in
Format
.
fprintf
ppf
"Error %a:@."
Location
.
print_loc
loc
;
Location
.
print_loc
ppf
loc
;
Location
.
html_hilight
loc
;
Format
.
fprintf
ppf
"%s"
s
|
Parser
.
Error
s
|
Stream
.
Error
s
->
...
...
driver/librarian.ml
View file @
770a37b9
...
...
@@ -88,9 +88,9 @@ let compile verbose name src =
let
p
=
try
Parser
.
prog
input
with
|
Stdpp
.
Exc_located
(
_
,
(
Location
_
as
e
))
->
raise
e
|
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
raise_loc
i
.
Lexing
.
pos_cnum
j
.
Lexing
.
pos_cnum
e
in
if
src
<>
""
then
close_in
ic
;
...
...
driver/run.ml
View file @
770a37b9
...
...
@@ -121,12 +121,14 @@ let toploop () =
Sys
.
catch_break
true
;
Cduce
.
toplevel
:=
true
;
Librarian
.
run_loaded
:=
true
;
Location
.
push_source
`Stream
;
let
read
i
=
let
buf_in
=
Buffer
.
create
1024
in
Location
.
push_source
(
`Buffer
buf_in
);
let
read
_i
=
if
!
bol
then
if
!
Ulexer
.
in_comment
then
outflush
"* "
else
outflush
"> "
;
try
let
c
=
input_char
stdin
in
Buffer
.
add_char
buf_in
c
;
bol
:=
c
=
'\n'
;
Some
c
with
Sys
.
Break
->
quit
()
...
...
@@ -135,6 +137,7 @@ let toploop () =
let
rec
loop
()
=
outflush
"# "
;
bol
:=
false
;
Buffer
.
clear
buf_in
;
ignore
(
Cduce
.
topinput
ppf
ppf_err
input
);
while
(
input_char
stdin
!=
'\n'
)
do
()
done
;
loop
()
in
...
...
parser/location.ml
View file @
770a37b9
(* TODO: handle encodings of the input for pretty printing
fragments of code *)
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
]
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
|
`Buffer
of
Buffer
.
t
]
type
loc
=
source
*
int
*
int
type
precise
=
[
`Full
|
`Char
of
int
]
...
...
@@ -43,13 +44,10 @@ let get_viewport () = !viewport
The clean solution is probably to have the real lexer
count the lines. *)
let
get_line_number
src
i
=
let
enc
=
ref
Ulexing
.
Latin1
in
let
ic
=
open_in_bin
src
in
let
lb
=
Ulexing
.
from_var_enc_channel
enc
ic
in
let
get_line_start
enc
lb
i
=
let
rec
count
line
start
=
lexer
|
'\n'
|
"
\n\r
"
|
'\r'
->
if
(
Ulexing
.
lexeme_start
lb
>=
i
)
then
(
line
,
i
-
start
)
if
(
Ulexing
.
lexeme_start
lb
>=
i
)
then
(
line
,
start
)
else
aux
(
line
+
1
)
(
Ulexing
.
lexeme_end
lb
)
|
"#utf8"
->
...
...
@@ -62,35 +60,49 @@ let get_line_number src i =
enc
:=
Ulexing
.
Latin1
;
aux
line
start
|
eof
->
(
line
,
i
-
start
)
(
line
,
start
)
|
_
->
aux
line
start
and
aux
line
start
=
if
(
Ulexing
.
lexeme_start
lb
>=
i
)
then
(
line
,
i
-
start
)
if
(
Ulexing
.
lexeme_start
lb
>=
i
)
then
(
line
,
start
)
else
count
line
start
lb
in
let
r
=
aux
1
0
in
aux
1
0
let
get_line_number
src
i
=
let
enc
=
ref
Ulexing
.
Latin1
in
let
ic
=
open_in_bin
src
in
let
lb
=
Ulexing
.
from_var_enc_channel
enc
ic
in
let
r
=
get_line_start
enc
lb
i
in
close_in
ic
;
r
let
get_line_number_str
src
i
=
let
enc
=
ref
Ulexing
.
Latin1
in
let
lb
=
Ulexing
.
from_var_enc_string
enc
src
in
get_line_start
enc
lb
i
let
print_precise
ppf
=
function
|
`Full
->
()
|
`Char
i
->
Format
.
fprintf
ppf
"
(c
har
# %i)
"
i
|
`Char
i
->
Format
.
fprintf
ppf
"
C
har
%i of the string:@
\n
"
i
let
print_loc
ppf
((
src
,
i
,
j
)
,
w
)
=
match
src
with
|
`None
->
Format
.
fprintf
ppf
"somewhere (no source defined !)"
|
`None
->
()
(*
Format.fprintf ppf "somewhere (no source defined !)"
*)
|
`Stream
|
`String
_
->
Format
.
fprintf
ppf
"at chars %i-%i%a"
i
j
print_precise
w
Format
.
fprintf
ppf
"At chars %i-%i:@
\n
%a"
i
j
print_precise
w
|
`Buffer
b
->
let
b
=
Buffer
.
contents
b
in
let
(
l1
,
start1
)
=
get_line_number_str
b
i
in
Format
.
fprintf
ppf
"Line %i, characters %i-%i:@
\n
%a"
l1
(
i
-
start1
)
(
j
-
start1
)
print_precise
w
|
`File
fn
->
let
(
l1
,
c1
)
=
get_line_number
fn
i
and
(
l2
,
c2
)
=
get_line_number
fn
j
in
if
l1
=
l2
then
Format
.
fprintf
ppf
"at line %i (chars %i-%i)%a, file %s"
l1
c1
c2
print_precise
w
fn
else
Format
.
fprintf
ppf
"at lines %i (char %i) - %i (char %i)%a, file %s"
l1
c1
l2
c2
print_precise
w
fn
let
(
l1
,
start1
)
=
get_line_number
fn
i
in
Format
.
fprintf
ppf
"File
\"
%s
\"
, line %i, characters %i-%i:@
\n
%a"
fn
l1
(
i
-
start1
)
(
j
-
start1
)
print_precise
w
let
extr
s
i
j
=
try
...
...
parser/location.mli
View file @
770a37b9
(* Locations in source file,
and presentation of results and errors *)
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
]
type
source
=
[
`None
|
`File
of
string
|
`Stream
|
`String
of
string
|
`Buffer
of
Buffer
.
t
]
type
loc
=
source
*
int
*
int
type
precise
=
[
`Full
|
`Char
of
int
]
exception
Location
of
loc
*
precise
*
exn
exception
Generic
of
string
val
noloc
:
loc
val
nopos
:
int
*
int
...
...
typing/typer.ml
View file @
770a37b9
...
...
@@ -11,9 +11,9 @@ let (>) (x:int) y = x > y
let
warning
loc
msg
=
let
v
=
Location
.
get_viewport
()
in
let
ppf
=
if
Html
.
is_html
v
then
Html
.
ppf
v
else
Format
.
err_formatter
in
Format
.
fprintf
ppf
"Warning %a:@
\n
"
Location
.
print_loc
(
loc
,
`Full
);
Location
.
print_loc
ppf
(
loc
,
`Full
);
Location
.
html_hilight
(
loc
,
`Full
);
Format
.
fprintf
ppf
"%s@."
msg
Format
.
fprintf
ppf
"
Warning:
%s@."
msg
exception
NonExhaustive
of
Types
.
descr
exception
Constraint
of
Types
.
descr
*
Types
.
descr
...
...
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