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
e68f3926
Commit
e68f3926
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-05-18 14:42:51 by cvscast] Clean-up
Original author: cvscast Date: 2003-05-18 14:44:17+00:00
parent
ca2fcfac
Changes
13
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
e68f3926
...
...
@@ -8,14 +8,14 @@ CLEAN_DIRS = $(DIRS) tools tests
MISC
=
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo
\
misc/pretty.cmo
PARSER
=
parser/lexer.cmo
parser/location.cmo
\
PARSER
=
parser/location.cmo
\
parser/wlexer.cmo
\
parser/ast.cmo parser/parser.cmo
TYPING
=
typing/typed.cmo typing/typer.cmo
TYPES
=
\
types/sortedList.cmo
types/sortedMap.cmo
types/boolean.cmo
\
types/sortedList.cmo types/boolean.cmo
\
types/ident.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo
\
types/normal.cmo
\
...
...
driver/cduce.ml
View file @
e68f3926
...
...
@@ -12,7 +12,7 @@ let rec is_abstraction = function
let
print_norm
ppf
d
=
Location
.
protect
ppf
(
fun
ppf
->
Types
.
Print
.
print
_descr
ppf
((
*
Types
.
normalize
*
)
d
))
(
fun
ppf
->
Types
.
Print
.
print
ppf
((
*
Types
.
normalize
*
)
d
))
let
print_value
ppf
v
=
Location
.
protect
ppf
(
fun
ppf
->
Value
.
print
ppf
v
)
...
...
@@ -120,7 +120,7 @@ let debug ppf = function
Format
.
fprintf
ppf
"[DEBUG:accept]@
\n
"
;
let
p
=
Typer
.
pat
p
in
let
t
=
Patterns
.
accept
p
in
Format
.
fprintf
ppf
" %a@
\n
"
Types
.
Print
.
print
t
Format
.
fprintf
ppf
" %a@
\n
"
Types
.
Print
.
print
(
Types
.
descr
t
)
|
`Compile
(
t
,
pl
)
->
Format
.
fprintf
ppf
"[DEBUG:compile]@
\n
"
;
let
t
=
Typer
.
typ
t
...
...
driver/run.ml
View file @
e68f3926
...
...
@@ -67,4 +67,5 @@ let main () =
let
()
=
main
()
;
Types
.
print_stat
ppf_err
let
()
=
main
()
parser/lexer.ml
deleted
100644 → 0
View file @
ca2fcfac
(* Modified from Camlp4 Plexer module *)
open
Stdpp
open
Token
let
no_quotations
=
ref
false
(* The string buffering machinery *)
let
buff
=
ref
(
String
.
create
80
)
let
store
len
x
=
if
len
>=
String
.
length
!
buff
then
buff
:=
!
buff
^
String
.
create
(
String
.
length
!
buff
);
!
buff
.
[
len
]
<-
x
;
succ
len
let
mstore
len
s
=
let
rec
add_rec
len
i
=
if
i
==
String
.
length
s
then
len
else
add_rec
(
store
len
s
.
[
i
])
(
succ
i
)
in
add_rec
len
0
let
get_buff
len
=
String
.
sub
!
buff
0
len
(* The lexer *)
let
rec
ident
len
=
parser
[
<
''
A'
..
'
Z'
|
'
a'
..
'
z'
|
'\192'
..
'\214'
|
'\216'
..
'\246'
|
'\248'
..
'\255'
|
'
0
'
..
'
9
'
|
'
_'
|
'\''
as
c
;
s
>
]
->
ident
(
store
len
c
)
s
|
[
<
>
]
->
len
and
ident2
len
=
parser
[
<
''
!
'
|
'
?
'
|
'
~
'
|
'
=
'
|
'
@
'
|
'
^
'
|
'
&
'
|
'
+
'
|
'
-
'
|
'
*
'
|
'
/
'
|
'
%
'
|
'.'
|
'
:
'
|
'
<
'
|
'
>
'
|
'
|
'
|
'
$
'
as
c
;
s
>
]
->
ident2
(
store
len
c
)
s
|
[
<
>
]
->
len
and
ident3
len
=
parser
[
<
''
0
'
..
'
9
'
|
'
A'
..
'
Z'
|
'
a'
..
'
z'
|
'\192'
..
'\214'
|
'\216'
..
'\246'
|
'\248'
..
'\255'
|
'
_'
|
'
!
'
|
'
%
'
|
'
&
'
|
'
*
'
|
'
+
'
|
'
-
'
|
'.'
|
'
/
'
|
'
:
'
|
'
<
'
|
'
=
'
|
'
>
'
|
'
?
'
|
'
@
'
|
'
^
'
|
'
|
'
|
'
~
'
|
'\''
|
'
$
'
as
c
;
s
>
]
->
ident3
(
store
len
c
)
s
|
[
<
>
]
->
len
and
base_number
len
=
parser
[
<
''
o'
|
'
O'
;
s
>
]
->
octal_digits
(
store
len
'
o'
)
s
|
[
<
''
x'
|
'
X'
;
s
>
]
->
hexa_digits
(
store
len
'
x'
)
s
|
[
<
''
b'
|
'
B'
;
s
>
]
->
binary_digits
(
store
len
'
b'
)
s
|
[
<
a
=
number
len
>
]
->
a
and
octal_digits
len
=
parser
[
<
''
0
'
..
'
7
'
as
d
;
s
>
]
->
octal_digits
(
store
len
d
)
s
|
[
<
>
]
->
"INT"
,
get_buff
len
and
hexa_digits
len
=
parser
[
<
''
0
'
..
'
9
'
|
'
a'
..
'
f'
|
'
A'
..
'
F'
as
d
;
s
>
]
->
hexa_digits
(
store
len
d
)
s
|
[
<
>
]
->
"INT"
,
get_buff
len
and
binary_digits
len
=
parser
[
<
''
0
'
..
'
1
'
as
d
;
s
>
]
->
binary_digits
(
store
len
d
)
s
|
[
<
>
]
->
"INT"
,
get_buff
len
and
number
len
=
parser
[
<
''
0
'
..
'
9
'
as
c
;
s
>
]
->
number
(
store
len
c
)
s
|
[
<
'
'.'
;
s
>
]
->
decimal_part
(
store
len
'.'
)
s
|
[
<
''
e'
|
'
E'
;
s
>
]
->
exponent_part
(
store
len
'
E'
)
s
|
[
<
>
]
->
"INT"
,
get_buff
len
and
decimal_part
len
=
parser
[
<
''
0
'
..
'
9
'
as
c
;
s
>
]
->
decimal_part
(
store
len
c
)
s
|
[
<
''
e'
|
'
E'
;
s
>
]
->
exponent_part
(
store
len
'
E'
)
s
|
[
<
>
]
->
"FLOAT"
,
get_buff
len
and
exponent_part
len
=
parser
[
<
''
+
'
|
'
-
'
as
c
;
s
>
]
->
end_exponent_part
(
store
len
c
)
s
|
[
<
a
=
end_exponent_part
len
>
]
->
a
and
end_exponent_part
len
=
parser
[
<
''
0
'
..
'
9
'
as
c
;
s
>
]
->
end_exponent_part
(
store
len
c
)
s
|
[
<
>
]
->
"FLOAT"
,
get_buff
len
let
rec
skip_spaces
=
parser
[
<
''
'
|
'\010'
|
'\013'
|
'\t'
|
'\026'
|
'\012'
;
s
>
]
->
skip_spaces
s
|
[
<
>
]
->
()
let
error_on_unknown_keywords
=
ref
false
let
err
loc
msg
=
raise_with_loc
loc
(
Token
.
Error
msg
)
let
next_token_fun
dfa
find_kwd
=
let
keyword_or_error
loc
s
=
try
(
""
,
find_kwd
s
)
,
loc
with
Not_found
->
if
!
error_on_unknown_keywords
then
err
loc
(
"illegal token: "
^
s
)
else
(
""
,
s
)
,
loc
in
let
rec
next_token
=
parser
bp
[
<
''
'
|
'\010'
|
'\013'
|
'\t'
|
'\026'
|
'\012'
;
s
>
]
->
next_token
s
|
[
<
''
(
'
;
s
>
]
->
left_paren
bp
s
|
[
<
''
#
'
;
s
>
]
->
spaces_tabs
s
;
linenum
bp
s
|
[
<
''
A'
..
'
Z'
|
'\192'
..
'\214'
|
'\216'
..
'\222'
as
c
;
s
>
]
->
let
id
=
get_buff
(
ident
(
store
0
c
)
s
)
in
let
loc
=
bp
,
Stream
.
count
s
in
(
try
""
,
find_kwd
id
with
Not_found
->
"UIDENT"
,
id
)
,
loc
|
[
<
''
a'
..
'
z'
|
'\223'
..
'\246'
|
'\248'
..
'\255'
|
'
_'
as
c
;
s
>
]
->
let
id
=
get_buff
(
ident
(
store
0
c
)
s
)
in
let
loc
=
bp
,
Stream
.
count
s
in
(
try
""
,
find_kwd
id
with
Not_found
->
"LIDENT"
,
id
)
,
loc
|
[
<
''
1
'
..
'
9
'
as
c
;
s
>
]
->
let
tok
=
number
(
store
0
c
)
s
in
let
loc
=
bp
,
Stream
.
count
s
in
tok
,
loc
|
[
<
''
0
'
;
s
>
]
->
let
tok
=
base_number
(
store
0
'
0
'
)
s
in
let
loc
=
bp
,
Stream
.
count
s
in
tok
,
loc
|
[
<
'
'\''
;
s
>
]
->
(* begin match Stream.npeek 2 s with
[_; '\''] | ['\\'; _] -> *)
let
tok
=
"CHAR"
,
get_buff
(
char
bp
0
s
)
in
let
loc
=
bp
,
Stream
.
count
s
in
tok
,
loc
(* | _ -> keyword_or_error (bp, Stream.count s) "'"
end *)
|
[
<
'
'\"'
;
s
>
]
->
let
tok
=
"STRING"
,
get_buff
(
string
bp
0
s
)
in
let
loc
=
bp
,
Stream
.
count
s
in
tok
,
loc
|
[
<
''
$
'
;
s
>
]
->
let
tok
=
dollar
bp
0
s
in
let
loc
=
bp
,
Stream
.
count
s
in
tok
,
loc
|
[
<
''
!
'
|
'
=
'
|
'
@
'
|
'
^
'
|
'
&
'
|
'
+
'
|
'
-
'
|
'
*
'
|
'
/
'
|
'
%
'
as
c
;
s
>
]
->
let
id
=
get_buff
(
ident2
(
store
0
c
)
s
)
in
keyword_or_error
(
bp
,
Stream
.
count
s
)
id
|
[
<
''
~
'
as
c
;
a
=
parser
[
<
''
a'
..
'
z'
as
c
;
len
=
ident
(
store
0
c
)
>
]
ep
->
(
"TILDEIDENT"
,
get_buff
len
)
,
(
bp
,
ep
)
|
[
<
s
>
]
->
let
id
=
get_buff
(
ident2
(
store
0
c
)
s
)
in
keyword_or_error
(
bp
,
Stream
.
count
s
)
id
>
]
->
a
|
[
<
''
?
'
as
c
;
a
=
parser
[
<
''
a'
..
'
z'
as
c
;
len
=
ident
(
store
0
c
)
>
]
ep
->
(
"QUESTIONIDENT"
,
get_buff
len
)
,
(
bp
,
ep
)
|
[
<
s
>
]
->
let
id
=
get_buff
(
ident2
(
store
0
c
)
s
)
in
keyword_or_error
(
bp
,
Stream
.
count
s
)
id
>
]
->
a
|
[
<
''
<
'
;
s
>
]
->
less
bp
s
|
[
<
''
:
'
as
c1
;
len
=
parser
[
<
''
]
'
|
'
:
'
|
'
=
'
|
'
>
'
as
c2
>
]
->
store
(
store
0
c1
)
c2
|
[
<
>
]
->
store
0
c1
>
]
ep
->
let
id
=
get_buff
len
in
keyword_or_error
(
bp
,
ep
)
id
|
[
<
''
>
'
|
'
|
'
as
c1
;
len
=
parser
[
<
''
]
'
|
'
}
'
as
c2
>
]
->
store
(
store
0
c1
)
c2
|
[
<
a
=
ident2
(
store
0
c1
)
>
]
->
a
>
]
ep
->
let
id
=
get_buff
len
in
keyword_or_error
(
bp
,
ep
)
id
|
[
<
''
[
'
|
'
{
'
as
c1
;
s
>
]
->
let
len
=
match
Stream
.
npeek
2
s
with
[
'
<
'
;
'
<
'
|
'
:
'
]
->
store
0
c1
|
_
->
match
s
with
parser
[
<
''
|
'
|
'
<
'
|
'
:
'
as
c2
>
]
->
store
(
store
0
c1
)
c2
|
[
<
>
]
->
store
0
c1
in
let
ep
=
Stream
.
count
s
in
let
id
=
get_buff
len
in
keyword_or_error
(
bp
,
ep
)
id
|
[
<
'
'.'
;
id
=
parser
[
<
'
'.'
>
]
->
".."
|
[
<
>
]
->
"."
>
]
ep
->
keyword_or_error
(
bp
,
ep
)
id
|
[
<
''
;
'
;
id
=
parser
[
<
''
;
'
>
]
->
";;"
|
[
<
>
]
->
";"
>
]
ep
->
keyword_or_error
(
bp
,
ep
)
id
|
[
<
'
'\\'
;
s
>
]
ep
->
(
"LIDENT"
,
get_buff
(
ident3
0
s
))
,
(
bp
,
ep
)
|
[
<
'
c
>
]
ep
->
keyword_or_error
(
bp
,
ep
)
(
String
.
make
1
c
)
|
[
<
_
=
Stream
.
empty
>
]
->
(
"EOI"
,
""
)
,
(
bp
,
succ
bp
)
and
less
bp
strm
=
if
!
no_quotations
then
match
strm
with
parser
[
<
len
=
ident2
(
store
0
'
<
'
)
>
]
ep
->
let
id
=
get_buff
len
in
keyword_or_error
(
bp
,
ep
)
id
else
match
strm
with
parser
[
<
''
<
'
;
len
=
quotation
bp
0
>
]
ep
->
(
"QUOTATION"
,
":"
^
get_buff
len
)
,
(
bp
,
ep
)
|
[
<
''
:
'
;
i
=
(
parser
[
<
len
=
ident
0
>
]
->
get_buff
len
);
''
<
'
??
"character '<' expected"
;
len
=
quotation
bp
0
>
]
ep
->
(
"QUOTATION"
,
i
^
":"
^
get_buff
len
)
,
(
bp
,
ep
)
|
[
<
len
=
ident2
(
store
0
'
<
'
)
>
]
ep
->
let
id
=
get_buff
len
in
keyword_or_error
(
bp
,
ep
)
id
and
string
bp
len
=
parser
[
<
'
'\"'
>
]
->
len
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
string
bp
(
store
(
store
len
'\\'
)
c
)
s
|
[
<
'
c
;
s
>
]
->
string
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"string not terminated"
and
char
bp
len
=
parser
[
<
'
'\''
;
s
>
]
->
if
len
=
0
then
char
bp
(
store
len
'\''
)
s
else
len
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
char
bp
(
store
(
store
len
'\\'
)
c
)
s
|
[
<
'
c
;
s
>
]
->
char
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"char not terminated"
and
dollar
bp
len
=
parser
[
<
''
$
'
>
]
->
"ANTIQUOT"
,
":"
^
get_buff
len
|
[
<
''
a'
..
'
z'
|
'
A'
..
'
Z'
as
c
;
s
>
]
->
antiquot
bp
(
store
len
c
)
s
|
[
<
''
0
'
..
'
9
'
as
c
;
s
>
]
->
maybe_locate
bp
(
store
len
c
)
s
|
[
<
''
:
'
;
s
>
]
->
let
k
=
get_buff
len
in
"ANTIQUOT"
,
k
^
":"
^
locate_or_antiquot_rest
bp
0
s
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
s
>
]
->
if
dfa
then
match
s
with
parser
[
<
'
c
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"antiquotation not terminated"
else
""
,
get_buff
(
ident2
(
store
0
'
$
'
)
s
)
and
maybe_locate
bp
len
=
parser
[
<
''
$
'
>
]
->
"ANTIQUOT"
,
":"
^
get_buff
len
|
[
<
''
0
'
..
'
9
'
as
c
;
s
>
]
->
maybe_locate
bp
(
store
len
c
)
s
|
[
<
''
:
'
;
s
>
]
->
"LOCATE"
,
get_buff
len
^
":"
^
locate_or_antiquot_rest
bp
0
s
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
'
c
;
s
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"antiquotation not terminated"
and
antiquot
bp
len
=
parser
[
<
''
$
'
>
]
->
"ANTIQUOT"
,
":"
^
get_buff
len
|
[
<
''
a'
..
'
z'
|
'
A'
..
'
Z'
|
'
0
'
..
'
9
'
as
c
;
s
>
]
->
antiquot
bp
(
store
len
c
)
s
|
[
<
''
:
'
;
s
>
]
->
let
k
=
get_buff
len
in
"ANTIQUOT"
,
k
^
":"
^
locate_or_antiquot_rest
bp
0
s
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
'
c
;
s
>
]
->
"ANTIQUOT"
,
":"
^
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"antiquotation not terminated"
and
locate_or_antiquot_rest
bp
len
=
parser
[
<
''
$
'
>
]
->
get_buff
len
|
[
<
'
'\\'
;
'
c
;
s
>
]
->
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
'
c
;
s
>
]
->
locate_or_antiquot_rest
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"antiquotation not terminated"
and
quotation
bp
len
=
parser
[
<
''
>
'
;
s
>
]
->
maybe_end_quotation
bp
len
s
|
[
<
''
<
'
;
s
>
]
->
quotation
bp
(
maybe_nested_quotation
bp
(
store
len
'
<
'
)
strm__
)
s
|
[
<
'
'\\'
;
len
=
(
parser
[
<
''
>
'
|
'
<
'
|
'\\'
as
c
>
]
->
store
len
c
|
[
<
>
]
->
store
len
'\\'
);
s
>
]
->
quotation
bp
len
s
|
[
<
'
c
;
s
>
]
->
quotation
bp
(
store
len
c
)
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"quotation not terminated"
and
maybe_nested_quotation
bp
len
=
parser
[
<
''
<
'
;
s
>
]
->
mstore
(
quotation
bp
(
store
len
'
<
'
)
s
)
">>"
|
[
<
''
:
'
;
len
=
ident
(
store
len
'
:
'
);
a
=
parser
[
<
''
<
'
;
s
>
]
->
mstore
(
quotation
bp
(
store
len
'
<
'
)
s
)
">>"
|
[
<
>
]
->
len
>
]
->
a
|
[
<
>
]
->
len
and
maybe_end_quotation
bp
len
=
parser
[
<
''
>
'
>
]
->
len
|
[
<
a
=
quotation
bp
(
store
len
'
>
'
)
>
]
->
a
and
left_paren
bp
=
parser
[
<
''
*
'
;
_
=
comment
bp
;
a
=
next_token
>
]
->
a
|
[
<
>
]
ep
->
keyword_or_error
(
bp
,
ep
)
"("
and
comment
bp
=
parser
[
<
''
(
'
;
s
>
]
->
left_paren_in_comment
bp
s
|
[
<
''
*
'
;
s
>
]
->
star_in_comment
bp
s
|
[
<
'
'\"'
;
_
=
string
bp
0
;
s
>
]
->
comment
bp
s
|
[
<
'
'\''
;
s
>
]
->
quote_in_comment
bp
s
|
[
<
'
c
;
s
>
]
->
comment
bp
s
|
[
<
>
]
ep
->
err
(
bp
,
ep
)
"comment not terminated"
and
quote_in_comment
bp
=
parser
[
<
'
'\''
;
s
>
]
->
comment
bp
s
|
[
<
'
'\\'
;
s
>
]
->
quote_antislash_in_comment
bp
0
s
|
[
<
'
_
;
s
>
]
->
quote_any_in_comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
quote_any_in_comment
bp
=
parser
[
<
'
'\''
;
s
>
]
->
comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
quote_antislash_in_comment
bp
len
=
parser
[
<
'
'\''
;
s
>
]
->
comment
bp
s
|
[
<
'
'\\'
|
'\"'
|
'
n'
|
'
t'
|
'
b'
|
'
r'
;
s
>
]
->
quote_any_in_comment
bp
s
|
[
<
''
0
'
..
'
9
'
;
s
>
]
->
quote_antislash_digit_in_comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
quote_antislash_digit_in_comment
bp
=
parser
[
<
''
0
'
..
'
9
'
;
s
>
]
->
quote_antislash_digit2_in_comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
quote_antislash_digit2_in_comment
bp
=
parser
[
<
''
0
'
..
'
9
'
;
s
>
]
->
quote_any_in_comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
left_paren_in_comment
bp
=
parser
[
<
''
*
'
;
s
>
]
->
comment
bp
s
;
comment
bp
s
|
[
<
a
=
comment
bp
>
]
->
a
and
star_in_comment
bp
=
parser
[
<
''
)
'
>
]
->
()
|
[
<
a
=
comment
bp
>
]
->
a
and
linenum
bp
=
parser
[
<
''
0
'
..
'
9
'
;
_
=
digits
;
_
=
spaces_tabs
;
'
'\"'
;
_
=
any_to_nl
;
s
>
]
->
next_token
s
|
[
<
>
]
->
keyword_or_error
(
bp
,
bp
+
1
)
"#"
and
spaces_tabs
=
parser
[
<
''
'
|
'\t'
;
s
>
]
->
spaces_tabs
s
|
[
<
>
]
->
()
and
digits
=
parser
[
<
''
0
'
..
'
9
'
;
s
>
]
->
digits
s
|
[
<
>
]
->
()
and
any_to_nl
=
parser
[
<
'
'\013'
|
'\010'
>
]
->
()
|
[
<
'
_
;
s
>
]
->
any_to_nl
s
|
[
<
>
]
->
()
in
fun
cstrm
->
try
next_token
cstrm
with
Stream
.
Error
str
->
err
(
Stream
.
count
cstrm
,
Stream
.
count
cstrm
+
1
)
str
let
dollar_for_antiquotation
=
ref
true
let
func
kwd_table
=
let
find
=
Hashtbl
.
find
kwd_table
in
let
dfa
=
!
dollar_for_antiquotation
in
Token
.
lexer_func_of_parser
(
next_token_fun
dfa
find
)
let
rec
check_keyword_stream
=
parser
[
<
_
=
check
;
_
=
Stream
.
empty
>
]
->
true
and
check
=
parser
[
<
''
A'
..
'
Z'
|
'
a'
..
'
z'
|
'\192'
..
'\214'
|
'\216'
..
'\246'
|
'\248'
..
'\255'
;
s
>
]
->
check_ident
s
|
[
<
''
!
'
|
'
?
'
|
'
~
'
|
'
=
'
|
'
@
'
|
'
^
'
|
'
&
'
|
'
+
'
|
'
-
'
|
'
*
'
|
'
/
'
|
'
%
'
|
'.'
;
s
>
]
->
check_ident2
s
|
[
<
''
<
'
;
s
>
]
->
begin
match
Stream
.
npeek
1
s
with
[
'
:
'
|
'
<
'
]
->
()
|
_
->
check_ident2
s
end
|
[
<
''
:
'
;
_
=
parser
[
<
''
]
'
|
'
:
'
|
'
=
'
|
'
>
'
>
]
->
()
|
[
<
>
]
->
()
>
]
ep
->
()
|
[
<
''
>
'
|
'
|
'
;
_
=
parser
[
<
''
]
'
|
'
}
'
>
]
->
()
|
[
<
a
=
check_ident2
>
]
->
a
>
]
->
()
|
[
<
''
[
'
|
'
{
'
;
s
>
]
->
begin
match
Stream
.
npeek
2
s
with
[
'
<
'
;
'
<
'
|
'
:
'
]
->
()
|
_
->
match
s
with
parser
[
<
''
|
'
|
'
<
'
|
'
:
'
>
]
->
()
|
[
<
>
]
->
()
end
|
[
<
''
;
'
;
_
=
parser
[
<
''
;
'
>
]
->
()
|
[
<
>
]
->
()
>
]
->
()
|
[
<
'
_
>
]
->
()
and
check_ident
=
parser
[
<
''
A'
..
'
Z'
|
'
a'
..
'
z'
|
'\192'
..
'\214'
|
'\216'
..
'\246'
|
'\248'
..
'\255'
|
'
0
'
..
'
9
'
|
'
_'
|
'\''
;
s
>
]
->
check_ident
s
|
[
<
>
]
->
()
and
check_ident2
=
parser
[
<
''
!
'
|
'
?
'
|
'
~
'
|
'
=
'
|
'
@
'
|
'
^
'
|
'
&
'
|
'
+
'
|
'
-
'
|
'
*
'
|
'
/
'
|
'
%
'
|
'.'
|
'
:
'
|
'
<
'
|
'
>
'
|
'
|
'
;
s
>
]
->
check_ident2
s
|
[
<
>
]
->
()
let
check_keyword
s
=
try
check_keyword_stream
(
Stream
.
of_string
s
)
with
_
->
false
let
error_no_respect_rules
p_con
p_prm
=
raise
(
Token
.
Error
(
"the token "
^
(
if
p_con
=
""
then
"
\"
"
^
p_prm
^
"
\"
"
else
if
p_prm
=
""
then
p_con
else
p_con
^
"
\"
"
^
p_prm
^
"
\"
"
)
^
" does not respect Plexer rules"
))
let
error_ident_and_keyword
p_con
p_prm
=
raise
(
Token
.
Error
(
"the token
\"
"
^
p_prm
^
"
\"
is used as "
^
p_con
^
" and as keyword"
))
let
using_token
kwd_table
ident_table
(
p_con
,
p_prm
)
=
match
p_con
with
""
->
if
not
(
Hashtbl
.
mem
kwd_table
p_prm
)
then
if
check_keyword
p_prm
then
if
Hashtbl
.
mem
ident_table
p_prm
then
error_ident_and_keyword
(
Hashtbl
.
find
ident_table
p_prm
)
p_prm
else
Hashtbl
.
add
kwd_table
p_prm
p_prm
else
error_no_respect_rules
p_con
p_prm
|
"LIDENT"
->
if
p_prm
=
""
then
()
else
begin
match
p_prm
.
[
0
]
with
'
A'
..
'
Z'
->
error_no_respect_rules
p_con
p_prm
|
_
->
if
Hashtbl
.
mem
kwd_table
p_prm
then
error_ident_and_keyword
p_con
p_prm
else
Hashtbl
.
add
ident_table
p_prm
p_con
end
|
"UIDENT"
->
if
p_prm
=
""
then
()
else
begin
match
p_prm
.
[
0
]
with
'
a'
..
'
z'
->
error_no_respect_rules
p_con
p_prm
|
_
->
if
Hashtbl
.
mem
kwd_table
p_prm
then
error_ident_and_keyword
p_con
p_prm
else
Hashtbl
.
add
ident_table
p_prm
p_con
end
|
"TILDEIDENT"
|
"QUESTIONIDENT"
|
"INT"
|
"FLOAT"
|
"CHAR"
|
"STRING"
|
"QUOTATION"
|
"ANTIQUOT"
|
"LOCATE"
|
"EOI"
->
()
|
_
->
raise
(
Token
.
Error
(
"the constructor
\"
"
^
p_con
^
"
\"
is not recognized by Plexer"
))
let
removing_token
kwd_table
ident_table
(
p_con
,
p_prm
)
=
match
p_con
with
""
->
Hashtbl
.
remove
kwd_table
p_prm
|
"LIDENT"
|
"UIDENT"
->
if
p_prm
<>
""
then
Hashtbl
.
remove
ident_table
p_prm
|
_
->
()
let
text
=
function
""
,
t
->
"'"
^
t
^
"'"
|
"LIDENT"
,
""
->
"lowercase identifier"
|
"LIDENT"
,
t
->
"'"
^
t
^
"'"
|
"UIDENT"
,
""
->
"uppercase identifier"
|
"UIDENT"
,
t
->
"'"
^
t
^
"'"
|
"INT"
,
""
->
"integer"
|
"INT"
,
s
->
"'"
^
s
^
"'"
|
"FLOAT"
,
""
->
"float"
|
"STRING"
,
""
->
"string"
|
"CHAR"
,
""
->
"char"
|
"QUOTATION"
,
""
->
"quotation"
|
"ANTIQUOT"
,
k
->
"antiquot
\"
"
^
k
^
"
\"
"
|
"LOCATE"
,
""
->
"locate"
|
"EOI"
,
""
->
"end of input"
|
con
,
""
->
con
|
con
,
prm
->
con
^
"
\"
"
^
prm
^
"
\"
"
let
eq_before_colon
p
e
=
let
rec
loop
i
=
if
i
==
String
.
length
e
then
failwith
"Internal error in Plexer: incorrect ANTIQUOT"
else
if
i
==
String
.
length
p
then
e
.
[
i
]
==
'
:
'
else
if
p
.
[
i
]
==
e
.
[
i
]
then
loop
(
i
+
1
)
else
false
in
loop
0
let
after_colon
e
=
try
let
i
=
String
.
index
e
'
:
'
in
String
.
sub
e
(
i
+
1
)
(
String
.
length
e
-
i
-
1
)
with
Not_found
->
""
let
tok_match
=
function
"ANTIQUOT"
,
p_prm
->
begin
function
"ANTIQUOT"
,
prm
when
eq_before_colon
p_prm
prm
->
after_colon
prm
|
_
->
raise
Stream
.
Failure
end
|
tok
->
Token
.
default_match
tok