Stefan pushed to branch master at Stefan / Typer
Commits: fdcdf103 by Stefan Monnier at 2016-11-15T23:04:44-05:00 Add support -escaping chars; drop _ stickiness
* doc/manual.texi (Lexing): Document 's new meaning.
* src/lexer.ml (unescape): New function. (nexttoken): Don't treat _ specially. Instead add support -escaping chars in symbols.
* src/prelexer.ml (prelex): Add support -escaping chars.
* tests/sexp_test.ml: Test handling of -escapes in symbols.
- - - - -
5 changed files:
- doc/manual.texi - src/lexer.ml - src/prelexer.ml - tests/eval_test.ml - tests/sexp_test.ml
Changes:
===================================== doc/manual.texi ===================================== --- a/doc/manual.texi +++ b/doc/manual.texi @@ -80,6 +80,10 @@ whitespace characters, plus a configurable list of extra special characters, which by default is comprised of @code{,}, @code{;}, @code{(}, and @code{)}.
+The character @code{} is also special: it makes the next character +non-special, so it can be used to include characters like @code{"} +in symbols. + @itemize @item Comments start with a @code{%} (byte 37) and end with a @code{LF}
===================================== src/lexer.ml ===================================== --- a/src/lexer.ml +++ b/src/lexer.ml @@ -33,82 +33,85 @@ let digit_p char =
type num_part = | NPint | NPfrac | NPexp
+let unescape str = + let rec split b = + if b >= String.length str then [] + else let e = try String.index_from str b '\' + with Not_found -> String.length str in + String.sub str b (e - b) :: split (e + 1) + in String.concat "" (split 0) + let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos (* The returned Sexp may not be a Node. *) : sexp * pretoken list * bytepos * charpos = match pts with - | [] -> (internal_error "No next token!") - | (Preblock (sl, bpts, el) :: pts) -> (Block (sl, bpts, el), pts, 0, 0) - | (Prestring (loc, str) :: pts) -> (String (loc, str), pts, 0, 0) - | (Pretoken ({file;line;column}, name) :: pts') -> - if digit_p name.[bpos] then + | [] -> (internal_error "No next token!") + | (Preblock (sl, bpts, el) :: pts) -> (Block (sl, bpts, el), pts, 0, 0) + | (Prestring (loc, str) :: pts) -> (String (loc, str), pts, 0, 0) + | (Pretoken ({file;line;column}, name) :: pts') + -> if digit_p name.[bpos] then let rec lexnum bp cp (np : num_part) = if bp >= String.length name then ((if np == NPint then - Integer ({file;line;column=column+bpos}, + Integer ({file;line;column=column+cpos}, int_of_string (string_sub name bpos bp)) else - Float ({file;line;column=column+bpos}, + Float ({file;line;column=column+cpos}, float_of_string (string_sub name bpos bp))), pts', 0, 0) else match name.[bp] with - | ('0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9') - -> lexnum (bp+1) (cp+1) np - | '.' when np == NPint -> lexnum (bp+1) (cp+1) NPfrac - | ('e'|'E') when not (np == NPexp) -> lexnum (bp+1) (cp+1) NPexp - | ('+'|'-') - when np == NPexp && (name.[bp-1] == 'e' || name.[bp-1] == 'E') -> - lexnum (bp+1) (cp+1) NPexp - | _ -> - ((if np == NPint then - Integer ({file;line;column=column+bpos}, + | ('0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9') + -> lexnum (bp+1) (cp+1) np + | '.' when np == NPint -> lexnum (bp+1) (cp+1) NPfrac + | ('e'|'E') when not (np == NPexp) -> lexnum (bp+1) (cp+1) NPexp + | ('+'|'-') + when np == NPexp && (name.[bp-1] == 'e' || name.[bp-1] == 'E') + -> lexnum (bp+1) (cp+1) NPexp + | _ + -> ((if np == NPint then + Integer ({file;line;column=column+cpos}, int_of_string (string_sub name bpos bp)) else - Float ({file;line;column=column+bpos}, + Float ({file;line;column=column+cpos}, float_of_string (string_sub name bpos bp))), pts, bp, cp) in lexnum (bpos+1) (cpos+1) NPint else if bpos + 1 >= String.length name then - (hSymbol ({file;line;column=column+bpos}, + (hSymbol ({file;line;column=column+cpos}, string_sub name bpos (String.length name)), pts', 0, 0) - else if stt.(Char.code name.[bpos]) = CKseparate - && not (name.[bpos+1] == '_') then - (hSymbol ({file;line;column=column+bpos}, + else if stt.(Char.code name.[bpos]) = CKseparate then + (hSymbol ({file;line;column=column+cpos}, string_sub name bpos (bpos + 1)), pts, bpos+1, cpos+1) else - let rec lexsym bp cp = + let mksym epos escaped + = let rawstr = string_sub name bpos epos in + let str = if escaped then unescape rawstr else rawstr in + hSymbol ({file;line;column=column+cpos}, str) in + let rec lexsym bp cp escaped = if bp >= String.length name then - (hSymbol ({file;line;column=column+bpos}, - string_sub name bpos (String.length name)), - pts', 0, 0) + (mksym (String.length name) escaped, pts', 0, 0) else let char = name.[bp] in - if char == '_' - && bp + 1 < String.length name - && name.[bp + 1] != '_' then + if char == '\' && bp + 1 < String.length name then (* Skip next char, in case it's a special token. *) - (* For utf-8, this cp+2 is risky but actually works: _ counts + (* For utf-8, this cp+2 is risky but actually works: \ counts * as 1 and if the input is valid utf-8 the next byte has to - * be a leading byte, so it has to count as 1 as well ;-) *) - lexsym (bp+2) (cp+2) - else if stt.(Char.code name.[bp]) = CKseparate - && (bp + 1 >= String.length name - || not (name.[bp+1] == '_')) then - (hSymbol ({file;line;column=column+bpos}, - string_sub name bpos bp), - pts, bp, cp) - else lexsym (bp+1) (inc_cp cp char) - in lexsym bpos cpos + * be a leading byte, so it has to count as 1 as well ;-) *) + lexsym (bp+2) (cp+2) true + else if stt.(Char.code name.[bp]) = CKseparate then + (mksym bp escaped, pts, bp, cp) + else lexsym (bp+1) (inc_cp cp char) escaped + in lexsym bpos cpos false
let lex tenv (pts : pretoken list) : sexp list = let rec gettokens pts bpos cpos acc = match pts with - | [] -> List.rev acc - | _ -> let (tok, pts, bpos, cpos) = nexttoken tenv pts bpos cpos - in gettokens pts bpos cpos (tok :: acc) in + | [] -> List.rev acc + | _ -> let (tok, pts, bpos, cpos) = nexttoken tenv pts bpos cpos + in gettokens pts bpos cpos (tok :: acc) in gettokens pts 0 0 []
let _lex_str (str: string) tenv =
===================================== src/prelexer.ml ===================================== --- a/src/prelexer.ml +++ b/src/prelexer.ml @@ -53,7 +53,7 @@ let inc_cp (cp:charpos) (c:char) = if utf8_head_p c then cp+1 else cp
let rec prelex (file : string) (getline : unit -> string) ln ctx acc - : pretoken list = + : pretoken list = try (* let fin = open_in file in *) let line = getline () in @@ -63,69 +63,72 @@ let rec prelex (file : string) (getline : unit -> string) ln ctx acc let nexttok = prelex' ctx in if bpos >= limit then nextline ctx acc else match line.[bpos] with - | c when c <= ' ' -> nexttok (bpos+1) (cpos+1) acc - | '%' -> nextline ctx acc (* A comment. *) - | '"' -> (* A string. *) - let rec prestring bp cp chars = + | c when c <= ' ' -> nexttok (bpos+1) (cpos+1) acc + | '%' -> nextline ctx acc (* A comment. *) + | '"' (* A string. *) + -> let rec prestring bp cp chars = if bp >= limit then (prelexer_error {file=file; line=ln; column=cpos} - "Unterminated string"; + "Unterminated string"; nextline ctx (Prestring ({file=file; line=ln; column=cpos}, "") :: acc)) else match line.[bp] with - | '"' -> - nexttok (bp+1) (cp+1) - (Prestring ({file=file; line=ln; column=cpos}, - string_implode (List.rev chars)) - :: acc) - | '\' -> - (if bpos + 1 >= limit then - (prelexer_error {file=file; line=ln; column=cpos} - "Unterminated string"; - nextline ctx - (Prestring ({file=file; line=ln; column=cpos}, - "") - :: acc)) - else - match line.[bp + 1] with - | 't' -> prestring (bp+2) (cp+2) ('\t' :: chars) - | 'n' -> prestring (bp+2) (cp+2) ('\n' :: chars) - | 'r' -> prestring (bp+2) (cp+2) ('\r' :: chars) - | ('u' | 'U') -> - prelexer_error {file=file; line=ln; column=cp} - "Unimplemented unicode escape"; - prestring (bp+2) (cp+2) chars - | char -> prestring (bp+2) (cp+2) (char :: chars)) - | char -> prestring (bp+1) (inc_cp cp char) (char :: chars) + | '"' -> + nexttok (bp+1) (cp+1) + (Prestring ({file=file; line=ln; column=cpos}, + string_implode (List.rev chars)) + :: acc) + | '\' -> + (if bpos + 1 >= limit then + (prelexer_error {file=file; line=ln; column=cpos} + "Unterminated string"; + nextline ctx + (Prestring ({file=file; line=ln; column=cpos}, + "") + :: acc)) + else + match line.[bp + 1] with + | 't' -> prestring (bp+2) (cp+2) ('\t' :: chars) + | 'n' -> prestring (bp+2) (cp+2) ('\n' :: chars) + | 'r' -> prestring (bp+2) (cp+2) ('\r' :: chars) + | ('u' | 'U') -> + prelexer_error {file=file; line=ln; column=cp} + "Unimplemented unicode escape"; + prestring (bp+2) (cp+2) chars + | char -> prestring (bp+2) (cp+2) (char :: chars)) + | char -> prestring (bp+1) (inc_cp cp char) (char :: chars) in prestring (bpos+1) (cpos+1) [] - | '{' -> prelex' ((ln, cpos, bpos, acc) :: ctx) (bpos+1) (cpos+1) [] - | '}' -> - (match ctx with - | ((sln, scpos, sbpos, sacc) :: ctx) -> - prelex' ctx (bpos+1) (cpos+1) - (Preblock ({file=file; line=sln; column=scpos}, - List.rev acc, - {file=file; line=ln; column=(cpos + 1)}) - :: sacc) - | _ -> (prelexer_error {file=file; line=ln; column=cpos} - "Unmatched closing brace"; - prelex' ctx (bpos+1) (cpos+1) acc)) - | char -> (* A pretoken. *) - let rec pretok bp cp = + | '{' -> prelex' ((ln, cpos, bpos, acc) :: ctx) (bpos+1) (cpos+1) [] + | '}' + -> (match ctx with + | ((sln, scpos, sbpos, sacc) :: ctx) -> + prelex' ctx (bpos+1) (cpos+1) + (Preblock ({file=file; line=sln; column=scpos}, + List.rev acc, + {file=file; line=ln; column=(cpos + 1)}) + :: sacc) + | _ -> (prelexer_error {file=file; line=ln; column=cpos} + "Unmatched closing brace"; + prelex' ctx (bpos+1) (cpos+1) acc)) + | char (* A pretoken. *) + -> let rec pretok bp cp = if bp >= limit then nextline ctx (Pretoken ({file=file; line=ln; column=cpos}, string_sub line bpos bp) :: acc) else match line.[bp] with - | (' '|'\t'|'\n'|'\r'|'%'|'"'|'{'|'}' ) - -> nexttok bp cp - (Pretoken ({file=file; line=ln; column=cpos}, - string_sub line bpos bp) - :: acc) - | char -> pretok (bp+1) (inc_cp cp char) + | (' '|'\t'|'\n'|'\r'|'%'|'"'|'{'|'}' ) + -> nexttok bp cp + (Pretoken ({file=file; line=ln; column=cpos}, + string_sub line bpos bp) + :: acc) + | '\' when bp+1 < limit + -> let char = line.[bp + 1] in + pretok (bp + 2) (1 + inc_cp cp char) + | char -> pretok (bp+1) (inc_cp cp char) in pretok (bpos+1) (inc_cp cpos char) in prelex' ctx 0 1 acc (* Traditionally, column numbers start at 1 :-( *) with End_of_file ->
===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -345,10 +345,10 @@ let _ = test_eval_eqv_named
"case t | triplet (b := bf) cf => cf; case t | triplet (b := bf) _ => bf; - case t | triplet ( _ := bf) cf => cf; - case t | triplet ( _ := af) ( _ := bf) ( _ := cf) => bf; - case t | triplet ( _ := af) ( _ := bf) ( _ := cf) => cf; - case t | triplet ( _ := af) ( _ := bf) (d := df) cf => df; + case t | triplet (_ := bf) cf => cf; + case t | triplet (_ := af) (_ := bf) (_ := cf) => bf; + case t | triplet (_ := af) (_ := bf) (_ := cf) => cf; + case t | triplet (_ := af) (_ := bf) (d := df) cf => df; "
""hello"; 5.0; "hello"; 5.0; "hello"; 7"
===================================== tests/sexp_test.ml ===================================== --- a/tests/sexp_test.ml +++ b/tests/sexp_test.ml @@ -39,9 +39,11 @@ let _ = test_sexp_eqv "(x + y)" "_+_ x y" let _ = test_sexp_eqv "(x := y)" "_:=_ x y" let _ = test_sexp_eqv "if A then B else C -> D" "if A then B else (C -> D)" let _ = test_sexp_eqv "A : B -> C" "A : (B -> C)" -let _ = test_sexp_eqv "f __; y" "(f ( __; ) y)" +let _ = test_sexp_eqv "f __; y" "(f (__;) y)" let _ = test_sexp_eqv "case e | p1 => e1 | p2 => e2" - "case_ ( _|_ e ( _=>_ p1 e1) ( _=>_ p2 e2))" + "case_ (_|_ e (_=>_ p1 e1) (_=>_ p2 e2))" +let _ = test_sexp_eqv "a\b\c" "abc" +let _ = test_sexp_eqv "(a;b)" "(_;_ a b)"
(* run all tests *) let _ = run_all ()
View it on GitLab: https://gitlab.com/monnier/typer/commit/fdcdf1030644349b74fc9fbf72061690a69c...
Afficher les réponses par date