steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

modern: fix delimiter mismatch code.

locals-and-roots
Doug Coleman 2016-06-20 11:45:55 -07:00
parent 404ded9a42
commit 3dc1af8e44
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
core/modern/modern.factor
View File

@ -162,6 +162,15 @@ M: array collapse-decorators
drop f drop f
] if ; ] if ;
: delimiters-match? ( opening closing -- ? )
[
1 cut* over empty? [
nip matching-delimiter-string 1array
] [
matching-delimiter-string [ append ] [ nip ] 2bi 2array
] if
] dip '[ _ sequence= ] any? ;
ERROR: whitespace-expected-after n string ch ; ERROR: whitespace-expected-after n string ch ;
ERROR: expected-more-tokens n string expected ; ERROR: expected-more-tokens n string expected ;
@ -194,7 +203,6 @@ ERROR: string-expected-got-eof n string ;
delimiter >string >>delimiter delimiter >string >>delimiter
tag delimiter payload 3array >>seq ; inline tag delimiter payload 3array >>seq ; inline
ERROR: mismatched-closing opening closing ;
:: make-matched-literal ( payload closing tag opening-delimiter class -- literal ) :: make-matched-literal ( payload closing tag opening-delimiter class -- literal )
class new class new
tag >string >>tag tag >string >>tag
@ -202,11 +210,6 @@ ERROR: mismatched-closing opening closing ;
tag closing [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying tag closing [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying
opening-delimiter >string >>delimiter opening-delimiter >string >>delimiter
dup single-matched-literal? [ dup single-matched-literal? [
closing dup [ tag>> ] when length 1 > [
tag opening-delimiter append
matching-delimiter-string closing dup [ tag>> ] when sequence=
[ opening-delimiter closing tag>> mismatched-closing ] unless
] when
closing dup [ tag>> ] when >>closing-tag closing dup [ tag>> ] when >>closing-tag
] when ] when
tag opening-delimiter payload closing 4array >>seq ; inline tag opening-delimiter payload closing 4array >>seq ; inline
@ -306,9 +309,9 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
} cond } cond
] ; ] ;
: read-bracket ( lexer slice -- slice' ) char: \[ read-matched ; : read-bracket ( lexer slice -- slice' ) 2dup [ char: \[ read-matched ] with-tag ;
: read-brace ( lexer slice -- slice' ) char: \{ read-matched ; : read-brace ( lexer slice -- slice' ) 2dup [ char: \{ read-matched ] with-tag ;
: read-paren ( lexer slice -- slice' ) char: \( read-matched ; : read-paren ( lexer slice -- slice' ) 2dup [ char: \( read-matched ] with-tag ;
:: read-string-payload ( lexer -- n' string slice ) :: read-string-payload ( lexer -- n' string slice )
lexer dup ?lexer-nth [ lexer dup ?lexer-nth [
@ -418,10 +421,13 @@ ERROR: backslash-expects-whitespace slice ;
[ [ 1 + ] change-n lex-factor ] [ [ 1 + ] change-n lex-factor ]
[ nip make-tag-literal ] if-empty ; [ nip make-tag-literal ] if-empty ;
ERROR: mismatched-terminator n string slice ; ERROR: mismatched-terminator lexer slice ;
: read-terminator ( lexer slice -- slice ) : read-terminator ( lexer slice -- slice )
nip 2dup [ peek-tag ] dip delimiters-match? [
terminator-literal make-tag-class-literal ; nip terminator-literal make-tag-class-literal
] [
mismatched-terminator
] if ;
: ?blank? ( ch/f -- blank/f ) : ?blank? ( ch/f -- blank/f )
{ [ blank? ] [ f = ] } 1|| ; { [ blank? ] [ f = ] } 1|| ;