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
4723621f
Commit
4723621f
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-05-11 18:16:30 by cvscast] Review identifier in lexer; removed more generic comparisons
Original author: cvscast Date: 2003-05-11 18:16:31+00:00
parent
59c2baee
Changes
13
Expand all
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
4723621f
...
...
@@ -5,6 +5,11 @@ let quiet = ref false
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Typer
.
Env
.
empty
let
rec
is_abstraction
=
function
|
Ast
.
Abstraction
_
->
true
|
Ast
.
LocatedExpr
(
_
,
e
)
->
is_abstraction
e
|
_
->
false
let
print_norm
ppf
d
=
Location
.
protect
ppf
(
fun
ppf
->
Types
.
Print
.
print_descr
ppf
((
*
Types
.
normalize
*
)
d
))
...
...
@@ -163,7 +168,7 @@ let run ppf ppf_err input =
let
v
=
Eval
.
eval
Eval
.
Env
.
empty
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"=> @[%a@]@
\n
@."
print_value
v
|
Ast
.
LetDecl
(
p
,
Ast
.
A
bstraction
_
)
->
()
|
Ast
.
LetDecl
(
p
,
e
)
when
is_a
bstraction
e
->
()
|
Ast
.
LetDecl
(
p
,
e
)
->
let
decl
=
Typer
.
let_decl
p
e
in
type_decl
decl
;
...
...
@@ -181,7 +186,7 @@ let run ppf ppf_err input =
List
.
iter
eval_decl
decls
in
let
rec
phrases
funs
=
function
|
{
descr
=
Ast
.
LetDecl
(
p
,
(
Ast
.
Abstraction
_
as
e
))
}
::
phs
->
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
phs
when
is_abstraction
e
->
phrases
((
p
,
e
)
::
funs
)
phs
|
ph
::
phs
->
do_fun_decls
funs
;
...
...
@@ -201,7 +206,7 @@ let run ppf ppf_err input =
List
.
fold_left
(
fun
((
typs
,
funs
)
as
accu
)
ph
->
match
ph
.
descr
with
|
Ast
.
TypeDecl
(
x
,
t
)
->
((
x
,
t
)
::
typs
,
funs
)
|
Ast
.
LetDecl
(
p
,
(
Ast
.
A
bstraction
_
as
e
))
->
|
Ast
.
LetDecl
(
p
,
e
)
when
is_a
bstraction
e
->
(
typs
,
(
p
,
e
)
::
funs
)
|
_
->
accu
)
([]
,
[]
)
p
in
...
...
parser/parser.ml
View file @
4723621f
...
...
@@ -125,6 +125,17 @@ EXTEND
]
];
keyword
:
[
[
a
=
[
"map"
|
"match"
|
"with"
|
"try"
|
"xtransform"
|
"if"
|
"then"
|
"else"
|
"transform"
|
"fun"
|
"in"
|
"let"
]
->
a
]
];
expr
:
[
"top"
RIGHTA
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Match
(
e
,
b
))
...
...
@@ -217,9 +228,9 @@ EXTEND
)
l
e
in
exp
loc
l
|
t
=
[
a
=
TAG
->
exp
loc
(
Cst
(
Types
.
Atom
(
Atoms
.
mk
a
)))
|
"<"
;
e
=
expr
LEVEL
"no_appl"
->
e
];
|
"<"
;
t
=
[
"("
;
e
=
expr
;
")"
->
e
|
a
=
[
LIDENT
|
UIDENT
|
keyword
]
->
exp
loc
(
Cst
(
Types
.
Atom
(
Atoms
.
mk
a
)))
];
a
=
expr_attrib_spec
;
">"
;
c
=
expr
->
exp
loc
(
Xml
(
t
,
Pair
(
a
,
c
)))
|
"{"
;
r
=
[
expr_record_spec
|
->
exp
loc
(
RecordLitt
LabelMap
.
empty
)
];
"}"
->
r
...
...
@@ -325,7 +336,7 @@ EXTEND
];
pat
:
[
[
x
=
pat
;
"where"
;
[
x
=
pat
;
LIDENT
"where"
;
b
=
LIST1
[
a
=
UIDENT
;
"="
;
y
=
pat
->
(
a
,
y
)]
SEP
"and"
->
mk
loc
(
Recurs
(
x
,
b
))
]
|
RIGHTA
[
x
=
pat
;
"->"
;
y
=
pat
->
mk
loc
(
Arrow
(
x
,
y
))
]
...
...
@@ -363,13 +374,11 @@ EXTEND
q
=
[
";"
;
q
=
pat
->
q
|
->
mknoloc
(
Internal
(
Sequence
.
nil_type
))
];
"]"
->
mk
loc
(
Regexp
(
r
,
q
))
|
t
=
[
[
"<"
;
LIDENT
"_"
->
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
any
)))
|
a
=
TAG
->
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
mk
a
))))
]
|
[
"<"
;
t
=
pat
->
t
]
];
|
"<"
;
t
=
[
x
=
[
LIDENT
|
UIDENT
|
keyword
]
->
let
a
=
if
x
=
"_"
then
Atoms
.
any
else
Atoms
.
atom
(
Atoms
.
mk
x
)
in
mk
loc
(
Internal
(
Types
.
atom
a
))
|
"("
;
t
=
pat
;
")"
->
t
];
a
=
attrib_spec
;
">"
;
c
=
pat
->
mk
loc
(
XmlT
(
t
,
multi_prod
loc
[
a
;
c
]))
|
s
=
STRING2
->
...
...
parser/wlexer.ml
View file @
4723621f
This diff is collapsed.
Click to expand it.
parser/wlexer.mll
View file @
4723621f
...
...
@@ -7,7 +7,13 @@ classes
blank
lowercase
uppercase
ascii_digit
"_<>=.,:;+-*/@&{}[]()|?`
\"\\\'
!"
unicode_base_char
unicode_ideographic
unicode_combining_char
unicode_digit
unicode_extender
{
let
keywords
=
Hashtbl
.
create
17
...
...
@@ -49,10 +55,17 @@ classes
let
numeric_char
s
=
int_of_string
(
String
.
sub
s
1
(
String
.
length
s
-
2
))
let
hexa_digit
=
function
|
'
0
'
..
'
9
'
as
c
->
(
Char
.
code
c
)
-
(
Char
.
code
'
0
'
)
|
'
a'
..
'
f'
as
c
->
(
Char
.
code
c
)
-
(
Char
.
code
'
a'
)
+
10
|
_
->
failwith
"Invalid hexadecimal digit"
(* TODO: error loc *)
let
hexa_char
s
=
let
rec
aux
i
accu
=
if
i
=
String
.
length
s
-
1
then
accu
else
aux
(
succ
i
)
(
accu
*
16
+
Char
.
code
s
.
[
i
]
-
Char
.
code
'
0
'
)
else
aux
(
succ
i
)
(
accu
*
16
+
hexa_digit
s
.
[
i
]
)
in
aux
0
0
...
...
@@ -63,28 +76,42 @@ classes
}
let
letter
=
lowercase
|
uppercase
|
unicode_base_char
|
unicode_ideographic
let
digit
=
ascii_digit
|
unicode_digit
let
character
=
[
^
encoding_error
]
let
ncname_char
=
letter
|
digit
|
[
".-_"
]
|
unicode_combining_char
|
unicode_extender
let
ncname
=
(
letter
|
'
_'
)
ncname_char
*
let
qname
=
(
ncname
'
:
'
)
?
ncname
(*
let lident = (lowercase | '_' | unicode_base_char | unicode_ideographic)
name_char*
let uident = uppercase name_char*
*)
(*
let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | '-'
let ident = identchar* ( ':' identchar+)*
*)
rule
token
=
parse
blank
+
{
token
engine
lexbuf
}
|
(
lowercase
|
'
_'
)
ident
{
let
s
=
Lexing
.
lexeme
lexbuf
in
if
Hashtbl
.
mem
keywords
s
then
""
,
s
else
"LIDENT"
,
s
}
|
uppercase
ident
{
"UIDENT"
,
Lexing
.
lexeme
lexbuf
}
|
'
-
'
?
ascii_digit
+
{
"INT"
,
Lexing
.
lexeme
lexbuf
}
|
"<"
blank
*
(
lowercase
|
uppercase
)
ident
{
let
s
=
Lexing
.
lexeme
lexbuf
in
"TAG"
,
tag_of_tag
s
1
}
|
qname
{
let
s
=
Lexing
.
lexeme
lexbuf
in
if
(
s
.
[
0
]
>=
'
A'
)
&&
(
s
.
[
0
]
<=
'
Z'
)
then
"UIDENT"
,
s
else
if
Hashtbl
.
mem
keywords
s
then
""
,
s
else
"LIDENT"
,
s
}
|
'
-
'
?
ascii_digit
+
{
"INT"
,
Lexing
.
lexeme
lexbuf
}
|
[
"<>=.,:;+-*/@&{}[]()|?`!"
]
|
"->"
|
"::"
|
";;"
|
"--"
|
":="
|
"
\\
"
|
"++"
|
"{|"
|
"|}"
|
"<="
|
">="
|
"<<"
|
">>"
|
[
"?+*"
]
"?"
{
""
,
Lexing
.
lexeme
lexbuf
}
|
'
"' | "
'
"
{ let string_start = Lexing.lexeme_start lexbuf in
string_start_pos := string_start;
...
...
@@ -167,7 +194,7 @@ and string ender = parse
string ender engine lexbuf }
and parse_hexa_char = parse
| ascii_digit+ ';'
|
(
ascii_digit
|lowercase)
+ ';'
{ store_len ~add:2 lexbuf;
store_code (hexa_char (Lexing.lexeme lexbuf)) }
| _
...
...
@@ -181,51 +208,160 @@ and parse_hexa_char = parse
let delta_loc = ref 0
let set_delta_loc dl = delta_loc := dl
let lexer_func_of_wlex lexfun lexengine cs =
let dl = !delta_loc in
delta_loc := 0;
let lb =
Lexing.from_function
(fun s n ->
try s.[0] <- Stream.next cs; 1 with Stream.Failure -> 0)
in
let next () =
let tok = lexfun lexengine lb in
let loc = (Lexing.lexeme_start lb + dl,
Lexing.lexeme_end lb + dl) in
(tok, loc)
in
Token.make_stream_and_location next
let register_kw (s1,s2) =
if s1 = "" then
match s2.[0] with
| 'a' .. 'z' when not (Hashtbl.mem keywords s2) ->
Hashtbl.add keywords s2 ()
| _ -> ()
let lexer lexfun lexengine =
{
Token.tok_func = lexer_func_of_wlex lexfun lexengine;
Token.tok_using = register_kw;
Token.tok_removing = (fun _ -> ());
Token.tok_match = Token.default_match;
Token.tok_text = Token.lexer_text
}
let lexer_func_of_wlex lexfun lexengine cs =
let dl = !delta_loc in
delta_loc := 0;
let lb =
Lexing.from_function
(fun s n ->
try s.[0] <- Stream.next cs; 1 with Stream.Failure -> 0)
in
let next () =
let tok = lexfun lexengine lb in
let loc = (Lexing.lexeme_start lb + dl,
Lexing.lexeme_end lb + dl) in
(tok, loc)
in
Token.make_stream_and_location next
let register_kw (s1,s2) =
if s1 = "" then
match s2.[0] with
| 'a' .. 'z' when not (Hashtbl.mem keywords s2) ->
Hashtbl.add keywords s2 ()
| _ -> ()
let lexer lexfun lexengine =
{
Token.tok_func = lexer_func_of_wlex lexfun lexengine;
Token.tok_using = register_kw;
Token.tok_removing = (fun _ -> ());
Token.tok_match = Token.default_match;
Token.tok_text = Token.lexer_text
}
let classes =
let c i = (i,i) in
let i ch1 ch2 = (Char.code ch1, Char.code ch2) in
[ (ascii_digit, [i '0' '9']);
(lowercase, [i 'a' 'z']);
(uppercase, [i 'A' 'Z']);
(blank, [c 8; c 9; c 10; c 13; c 32]);
[ unicode_base_char,
[ 0x00C0,0x00D6; 0x00D8,0x00F6;
0x00F8,0x00FF; 0x0100,0x0131; 0x0134,0x013E; 0x0141,0x0148;
0x014A,0x017E; 0x0180,0x01C3; 0x01CD,0x01F0; 0x01F4,0x01F5;
0x01FA,0x0217; 0x0250,0x02A8; 0x02BB,0x02C1; 0x0386,0x0386;
0x0388,0x038A; 0x038C,0x038C; 0x038E,0x03A1; 0x03A3,0x03CE;
0x03D0,0x03D6; 0x03DA,0x03DA; 0x03DC,0x03DC; 0x03DE,0x03DE;
0x03E0,0x03E0; 0x03E2,0x03F3;
0x0401,0x040C; 0x040E,0x044F; 0x0451,0x045C; 0x045E,0x0481;
0x0490,0x04C4; 0x04C7,0x04C8; 0x04CB,0x04CC; 0x04D0,0x04EB;
0x04EE,0x04F5; 0x04F8,0x04F9; 0x0531,0x0556; 0x0559,0x0559;
0x0561,0x0586; 0x05D0,0x05EA; 0x05F0,0x05F2; 0x0621,0x063A;
0x0641,0x064A; 0x0671,0x06B7; 0x06BA,0x06BE; 0x06C0,0x06CE;
0x06D0,0x06D3; 0x06D5,0x06D5; 0x06E5,0x06E6; 0x0905,0x0939;
0x093D,0x093D;
0x0958,0x0961; 0x0985,0x098C; 0x098F,0x0990; 0x0993,0x09A8;
0x09AA,0x09B0; 0x09B2,0x09B2; 0x09B6,0x09B9; 0x09DC,0x09DD;
0x09DF,0x09E1; 0x09F0,0x09F1; 0x0A05,0x0A0A; 0x0A0F,0x0A10;
0x0A13,0x0A28; 0x0A2A,0x0A30; 0x0A32,0x0A33; 0x0A35,0x0A36;
0x0A38,0x0A39; 0x0A59,0x0A5C; 0x0A5E,0x0A5E; 0x0A72,0x0A74;
0x0A85,0x0A8B; 0x0A8D,0x0A8D; 0x0A8F,0x0A91; 0x0A93,0x0AA8;
0x0AAA,0x0AB0; 0x0AB2,0x0AB3; 0x0AB5,0x0AB9; 0x0ABD,0x0ABD;
0x0AE0,0x0AE0;
0x0B05,0x0B0C; 0x0B0F,0x0B10; 0x0B13,0x0B28; 0x0B2A,0x0B30;
0x0B32,0x0B33; 0x0B36,0x0B39; 0x0B3D,0x0B3D; 0x0B5C,0x0B5D;
0x0B5F,0x0B61; 0x0B85,0x0B8A; 0x0B8E,0x0B90; 0x0B92,0x0B95;
0x0B99,0x0B9A; 0x0B9C,0x0B9C; 0x0B9E,0x0B9F; 0x0BA3,0x0BA4;
0x0BA8,0x0BAA; 0x0BAE,0x0BB5; 0x0BB7,0x0BB9; 0x0C05,0x0C0C;
0x0C0E,0x0C10; 0x0C12,0x0C28; 0x0C2A,0x0C33; 0x0C35,0x0C39;
0x0C60,0x0C61; 0x0C85,0x0C8C; 0x0C8E,0x0C90; 0x0C92,0x0CA8;
0x0CAA,0x0CB3; 0x0CB5,0x0CB9; 0x0CDE,0x0CDE; 0x0CE0,0x0CE1;
0x0D05,0x0D0C; 0x0D0E,0x0D10; 0x0D12,0x0D28; 0x0D2A,0x0D39;
0x0D60,0x0D61; 0x0E01,0x0E2E; 0x0E30,0x0E30; 0x0E32,0x0E33;
0x0E40,0x0E45; 0x0E81,0x0E82; 0x0E84,0x0E84; 0x0E87,0x0E88;
0x0E8A,0x0E8A;
0x0E8D,0x0E8D; 0x0E94,0x0E97; 0x0E99,0x0E9F; 0x0EA1,0x0EA3;
0x0EA5,0x0EA5;
0x0EA7,0x0EA7; 0x0EAA,0x0EAB; 0x0EAD,0x0EAE; 0x0EB0,0x0EB0;
0x0EB2,0x0EB3;
0x0EBD,0x0EBD; 0x0EC0,0x0EC4; 0x0F40,0x0F47; 0x0F49,0x0F69;
0x10A0,0x10C5; 0x10D0,0x10F6; 0x1100,0x1100; 0x1102,0x1103;
0x1105,0x1107; 0x1109,0x1109; 0x110B,0x110C; 0x110E,0x1112;
0x113C,0x113C;
0x113E,0x113E; 0x1140,0x1140; 0x114C,0x114C; 0x114E,0x114E;
0x1150,0x1150; 0x1154,0x1155; 0x1159,0x1159;
0x115F,0x1161; 0x1163,0x1163; 0x1165,0x1165; 0x1167,0x1167;
0x1169,0x1169; 0x116D,0x116E;
0x1172,0x1173; 0x1175,0x1175; 0x119E,0x119E; 0x11A8,0x11A8;
0x11AB,0x11AB; 0x11AE,0x11AF;
0x11B7,0x11B8; 0x11BA,0x11BA; 0x11BC,0x11C2; 0x11EB,0x11EB;
0x11F0,0x11F0; 0x11F9,0x11F9;
0x1E00,0x1E9B; 0x1EA0,0x1EF9; 0x1F00,0x1F15; 0x1F18,0x1F1D;
0x1F20,0x1F45; 0x1F48,0x1F4D; 0x1F50,0x1F57; 0x1F59,0x1F59;
0x1F5B,0x1F5B;
0x1F5D,0x1F5D; 0x1F5F,0x1F7D; 0x1F80,0x1FB4; 0x1FB6,0x1FBC;
0x1FBE,0x1FBE;
0x1FC2,0x1FC4; 0x1FC6,0x1FCC; 0x1FD0,0x1FD3; 0x1FD6,0x1FDB;
0x1FE0,0x1FEC; 0x1FF2,0x1FF4; 0x1FF6,0x1FFC; 0x2126,0x2126;
0x212A,0x212B; 0x212E,0x212E; 0x2180,0x2182; 0x3041,0x3094;
0x30A1,0x30FA; 0x3105,0x312C; (* 0xAC00,0xD7A3 *) ];
unicode_ideographic,
[ 0x3007,0x3007; 0x3021,0x3029 (* 0x4E00-0x9FA5 *) ];
unicode_combining_char,
[ 0x0300,0x0345; 0x0360,0x0361; 0x0483,0x0486; 0x0591,0x05A1;
0x05A3,0x05B9; 0x05BB,0x05BD; 0x05BF,0x05BF; 0x05C1,0x05C2;
0x05C4,0x05C4; 0x064B,0x0652; 0x0670,0x0670; 0x06D6,0x06DC;
0x06DD,0x06DF; 0x06E0,0x06E4; 0x06E7,0x06E8; 0x06EA,0x06ED;
0x0901,0x0903; 0x093C,0x093C; 0x093E,0x094C; 0x094D,0x094D;
0x0951,0x0954; 0x0962,0x0963; 0x0981,0x0983; 0x09BC,0x09BC;
0x09BE,0x09BE; 0x09BF,0x09BF; 0x09C0,0x09C4; 0x09C7,0x09C8;
0x09CB,0x09CD; 0x09D7,0x09D7; 0x09E2,0x09E3; 0x0A02,0x0A02;
0x0A3C,0x0A3C; 0x0A3E,0x0A3E; 0x0A3F,0x0A3F; 0x0A40,0x0A42;
0x0A47,0x0A48; 0x0A4B,0x0A4D; 0x0A70,0x0A71; 0x0A81,0x0A83;
0x0ABC,0x0ABC; 0x0ABE,0x0AC5; 0x0AC7,0x0AC9; 0x0ACB,0x0ACD;
0x0B01,0x0B03; 0x0B3C,0x0B3C; 0x0B3E,0x0B43; 0x0B47,0x0B48;
0x0B4B,0x0B4D; 0x0B56,0x0B57; 0x0B82,0x0B83; 0x0BBE,0x0BC2;
0x0BC6,0x0BC8; 0x0BCA,0x0BCD; 0x0BD7,0x0BD7; 0x0C01,0x0C03;
0x0C3E,0x0C44; 0x0C46,0x0C48; 0x0C4A,0x0C4D; 0x0C55,0x0C56;
0x0C82,0x0C83; 0x0CBE,0x0CC4; 0x0CC6,0x0CC8; 0x0CCA,0x0CCD;
0x0CD5,0x0CD6; 0x0D02,0x0D03; 0x0D3E,0x0D43; 0x0D46,0x0D48;
0x0D4A,0x0D4D; 0x0D57,0x0D57; 0x0E31,0x0E31; 0x0E34,0x0E3A;
0x0E47,0x0E4E; 0x0EB1,0x0EB1; 0x0EB4,0x0EB9; 0x0EBB,0x0EBC;
0x0EC8,0x0ECD; 0x0F18,0x0F19; 0x0F35,0x0F35; 0x0F37,0x0F37;
0x0F39,0x0F39; 0x0F3E,0x0F3E; 0x0F3F,0x0F3F; 0x0F71,0x0F84;
0x0F86,0x0F8B; 0x0F90,0x0F95; 0x0F97,0x0F97; 0x0F99,0x0FAD;
0x0FB1,0x0FB7; 0x0FB9,0x0FB9; 0x20D0,0x20DC; 0x20E1,0x20E1;
0x302A,0x302F; 0x3099,0x3099; 0x309A,0x309A ];
unicode_digit,
[ 0x0660,0x0669; 0x06F0,0x06F9; 0x0966,0x096F; 0x09E6,0x09EF;
0x0A66,0x0A6F; 0x0AE6,0x0AEF; 0x0B66,0x0B6F; 0x0BE7,0x0BEF;
0x0C66,0x0C6F; 0x0CE6,0x0CEF; 0x0D66,0x0D6F; 0x0E50,0x0E59;
0x0ED0,0x0ED9; 0x0F20,0x0F29 ];
unicode_extender,
[ 0x00B7,0x00B7; 0x02D0,0x02D1; 0x0387,0x0387; 0x0640,0x0640;
0x0E46,0x0E46; 0x0EC6,0x0EC6; 0x3005,0x3005; 0x3031,0x3035;
0x309D,0x309E; 0x30FC,0x30FE ];
ascii_digit,
[ i '0' '9'];
lowercase,
[i 'a' 'z'];
uppercase,
[i 'A' 'Z'];
blank,
[c 8; c 9; c 10; c 13; c 32]
]
let table =
assert(nb_classes <= 256);
let v = String.make
256
(Char.chr encoding_error) in
let v = String.make
0x312d
(Char.chr encoding_error) in
let fill_int c (i, j) = String.fill v i (j-i+1) c in
let fill_class (c, l) = List.iter (fill_int (Char.chr c)) l in
let fill_char (ch, cl) = v.[ch] <- Char.chr cl in
...
...
@@ -233,10 +369,17 @@ let lexer lexfun lexengine =
List.iter fill_char one_char_classes;
v
let utf8_engine = Lex_engines.engine_tiny_utf8 table
(fun c ->
if c>=0x10000 && c < 0x11000 then xml_char
else encoding_error)
let utf8_engine =
Lex_engines.engine_tiny_utf8 table
(fun code ->
if code >= 0x4E00 && code <= 0x9FA5 then
unicode_ideographic
else if code >= 0xAC00 && code <= 0xD7A3 then
unicode_base_char
else if code <= 0xD7FF || (code >= 0xE000 && code <= 0xFFFD) ||
(code >= 0x10000 && code <= 0x10FFFF) then
xml_char
else encoding_error)
let latin1_engine = Lex_engines.engine_tiny_8bit table
}
runtime/eval.ml
View file @
4723621f
...
...
@@ -100,7 +100,7 @@ and eval_branches env brs arg =
let
(
bind
,
e
)
=
rhs
.
(
code
)
in
let
env
=
List
.
fold_left
(
fun
env
(
x
,
i
)
->
if
(
i
=
-
1
)
then
Env
.
add
x
arg
env
if
(
i
=
=
-
1
)
then
Env
.
add
x
arg
env
else
Env
.
add
x
bindings
.
(
i
)
env
)
env
(
IdMap
.
get
bind
)
in
eval
env
e
...
...
@@ -108,7 +108,7 @@ and eval_let_decl env l =
let
v
=
eval
env
l
.
Typed
.
let_body
in
let
(
disp
,
bind
)
=
Typed
.
dispatcher_let_decl
l
in
let
(
_
,
bindings
)
=
run_dispatcher
disp
v
in
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
=
-
1
)
then
v
else
bindings
.
(
i
)))
(
IdMap
.
get
bind
)
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
=
=
-
1
)
then
v
else
bindings
.
(
i
)))
(
IdMap
.
get
bind
)
and
eval_map
env
brs
=
function
|
Pair
(
x
,
y
)
->
...
...
@@ -233,7 +233,7 @@ and eval_string_of v =
and
eval_equal
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
=
0
)
Value
.
vbool
(
Value
.
compare
v1
v2
=
=
0
)
and
eval_lt
v1
v2
=
let
c
=
Value
.
compare
v1
v2
in
...
...
runtime/run_dispatch.ml
View file @
4723621f
...
...
@@ -5,6 +5,10 @@
(precompute this ...)
*)
(*
let (<) : int -> int -> bool = (<);;
*)
open
Value
open
Ident
open
Patterns
.
Compile
...
...
@@ -31,7 +35,7 @@ let ensure_room n =
let
make_result_prod
v1
r1
v2
r2
v
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
if
n
=
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
let
c
=
!
cursor
in
...
...
@@ -47,13 +51,13 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
in
buf
.
(
c
+
a
)
<-
x
done
;
if
r1
<>
c
then
blit
buf
c
buf
r1
n
;
if
r1
!=
c
then
blit
buf
c
buf
r1
n
;
cursor
:=
r1
+
n
;
(* clean space for GC ? *)
code
)
let
make_result_basic
v
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
if
n
=
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
...
...
@@ -70,7 +74,7 @@ let make_result_basic v (code,r) =
let
make_result_char
ch
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
if
n
=
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
...
...
@@ -85,11 +89,11 @@ let make_result_char ch (code,r) =
code
)
let
tail_string_latin1
i
j
s
q
=
if
i
+
1
=
j
then
q
else
String_latin1
(
i
+
1
,
j
,
s
,
q
)
if
i
+
1
=
=
j
then
q
else
String_latin1
(
i
+
1
,
j
,
s
,
q
)
let
make_result_string_latin1
i
j
s
q
r1
r2
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
if
n
=
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
...
...
@@ -104,7 +108,7 @@ let make_result_string_latin1 i j s q r1 r2 (code,r) =
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
if
r1
<>
!
cursor
then
blit
buf
!
cursor
buf
r1
n
;
if
r1
!=
!
cursor
then
blit
buf
!
cursor
buf
r1
n
;
cursor
:=
r1
+
n
;
code
)
...
...
@@ -114,7 +118,7 @@ let tail_string_utf8 i j s q =
let
make_result_string_utf8
i
j
s
q
r1
r2
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
=
0
then
code
else
(
if
n
=
=
0
then
code
else
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
...
...
@@ -129,7 +133,7 @@ let make_result_string_utf8 i j s q r1 r2 (code,r) =
in
buf
.
(
!
cursor
+
a
)
<-
x
done
;
if
r1
<>
!
cursor
then
blit
buf
!
cursor
buf
r1
n
;
if
r1
!=
!
cursor
then
blit
buf
!
cursor
buf
r1
n
;
cursor
:=
r1
+
n
;
code
)
...
...
@@ -191,7 +195,7 @@ and run_disp_record other v fields = function
|
Some
(
RecLabel
(
l
,
d
))
->
let
rec
aux
other
=
function
|
(
l1
,_
)
::
rem
when
l1
<
l
->
aux
true
rem
|
(
l1
,
vl
)
::
rem
when
l1
=
l
->
|
(
l1
,
vl
)
::
rem
when
l1
=
=
l
->
run_disp_record1
other
vl
rem
d
|
rem
->
run_disp_record1
other
Absent
rem
d
...
...
@@ -228,7 +232,7 @@ and run_disp_record_loop other rem d =
and
run_disp_string_latin1
i
j
s
q
actions
=
if
i
=
j
then
run_disp_kind
actions
q
if
i
=
=
j
then
run_disp_kind
actions
q
else
match
actions
.
prod
with
|
Impossible
->
assert
false
|
TailCall
d1
->
run_disp_string_latin1_char
d1
(
Chars
.
mk_char
s
.
[
i
])
...
...
types/chars.ml
View file @
4723621f
...
...
@@ -48,6 +48,16 @@ let rec equal l1 l2 =
|
(
i1
,
j1
)
::
l1
,
(
i2
,
j2
)
::
l2
->
(
i1
==
i2
)
&&
(
j1
==
j2
)
&&
(
equal
l1
l2
)
|
_
->
false
let
rec
compare
(
l1
:
t
)
(
l2
:
t
)
=
match
(
l1
,
l2
)
with
|
(
i1
,
j1
)
::
l1
,
(
i2
,
j2
)
::
l2
->
let
c
=
vcompare
i1
i2
in
if
c
<>
0
then
c
else
let
c
=
vcompare
j1
j2
in
if
c
<>
0
then
c
else
compare
l1
l2
|
[]
,
[]
->
0
|
_
::_,
[]
->
-
1
|
_
->
1
let
from_int
c
=
if
(
c
<
0
)
||
(
c
>
max_char
)
then
failwith
"Chars.from_int: code point out of bound"
;
...
...
types/chars.mli
View file @
4723621f
...
...
@@ -12,6 +12,7 @@ type t (* = (Unichar.t * Unichar.t) list *)
val
equal
:
t
->
t
->
bool
val
hash
:
int
->
t
->
int
val
print
:
t
->
(
Format
.
formatter
->
unit
)
list
val
compare
:
t
->
t
->
int
val
empty
:
t
val
any
:
t
...
...
types/intervals.ml
View file @
4723621f
...
...
@@ -25,6 +25,32 @@ type interval =
type
t
=
interval
list
let
rec
compare
l1
l2
=
match
(
l1
,
l2
)
with
|
[]
,
[]
->
0
|
[]
,_
->
-
1
|
_
,
[]
->
1
|
Bounded
(
a1
,
b1
)
::
l1
,
Bounded
(
a2
,
b2
)
::
l2
->
let
c
=
vcompare
a1
a2
in
if
c
<>
0
then
c
else
let
c
=
vcompare
b1
b2
in
if
c
<>
0
then
c
else
compare
l1
l2
|
Bounded
(
_
,_
)
::
_
,
_
->
-
1
|
_
,
Bounded
(
_
,_
)
::
_
->
1
|
Left
a1
::
l1
,
Left
a2
::
l2
->
let
c
=
vcompare
a1
a2
in
if
c
<>
0
then
c
else
compare
l1
l2
|
Left
_
::
_
,
_
->
-
1
|
_
,
Left
_
::
_
->
1
|
Right
a1
::
l1
,
Right
a2
::
l2
->
let
c
=
vcompare
a1
a2
in
if
c
<>
0
then
c
else
compare
l1
l2
|
Right
_
::
_
,
_
->
-
1
|
_
,
Right
_
::
_
->
1
|
Any
::
_
,
Any
::
_
->
0
let
rec
equal
l1
l2
=
(
l1
==
l2
)
||
...
...
types/intervals.mli
View file @
4723621f
...
...
@@ -16,6 +16,7 @@ type t
val
equal
:
t
->
t
->
bool
val
hash
:
int
->
t
->
int
val
print
:
t
->
(
Format
.
formatter
->
unit
)
list
val
compare
:
t
->
t
->
int
val
empty
:
t
val
any
:
t
...
...
types/patterns.ml
View file @
4723621f
...
...
@@ -3,9 +3,13 @@ open Ident
(*
To be sure not to use generic comparison ...
let (=) x y = 1
let (<) : int -> int -> bool = (<)
*)
let
(
=
)
:
int
->
int
->
bool
=
(
==
)