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

modern: Add a flag for interrupting FOO: words with another FOO:

modern-harvey2
Doug Coleman 2017-08-21 22:28:40 -05:00
parent 218530209f
commit f04c919e79
1 changed files with 28 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
extra/modern/modern.factor
View File

@ -10,6 +10,8 @@ IN: modern
ERROR: string-expected-got-eof n string ; ERROR: string-expected-got-eof n string ;
ERROR: long-opening-mismatch tag open n string ch ; ERROR: long-opening-mismatch tag open n string ch ;
SYMBOL: strict-upper
SYMBOL: delimiter-stack SYMBOL: delimiter-stack
: push-delimiter-stack ( obj -- ) delimiter-stack get push ; : push-delimiter-stack ( obj -- ) delimiter-stack get push ;
: pop-delimiter-stack ( -- obj ) delimiter-stack get pop ; : pop-delimiter-stack ( -- obj ) delimiter-stack get pop ;
@ -49,45 +51,21 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se
DEFER: lex-factor DEFER: lex-factor
ERROR: lex-expected-but-got-eof n string expected ; ERROR: lex-expected-but-got-eof n string expected ;
! For implementing [ { ( ! For implementing [ { (
: lex-until ( n string tags -- n' string payload closing ) : lex-until ( n string tags -- n' string payload )
pick [ '[
3dup '[ [
[ lex-factor dup [ , ] when* [
lex-factor dup , [ dup [
dup [ ! } gets a chance, but then also full seq { } after recursion...
! } gets a chance, but then also full seq { } after recursion... [ _ ] dip '[ _ sequence= ] any? not
[ _ ] dip '[ _ sequence= ] any? not
] [
drop t ! loop again?
] if
] [ ] [
_ _ _ lex-expected-but-got-eof drop t ! loop again?
] if* ] if
] loop ] [
] { } make unclip-last f
] [ ] if*
lex-expected-but-got-eof ] loop
] if ; ] { } make ;
: lex-colon-until ( n string tags -- n' string payload closing )
pick [
3dup '[
[
lex-factor dup [ , ] when* [
dup [
! } gets a chance, but then also full seq { } after recursion...
[ _ ] dip '[ _ sequence= ] any? not
] [
drop t ! loop again?
] if
] [
_ _ _ lex-expected-but-got-eof
] if*
] loop
] { } make unclip-last
] [
lex-expected-but-got-eof
] if ;
: split-double-dash ( seq -- seqs ) : split-double-dash ( seq -- seqs )
dup [ { [ "--" sequence= ] } 1&& ] split-when dup [ { [ "--" sequence= ] } 1&& ] split-when
@ -104,7 +82,7 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or (( { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
{ [ dup blank? ] [ { [ dup blank? ] [
drop dup '[ _ matching-delimiter-string closestr1 2array lex-until ] dip drop dup '[ _ matching-delimiter-string closestr1 2array lex-until ] dip
1 cut-slice* 2swap 4array ] } ! ( foo ) 1 cut-slice* -rot 3array ] } ! ( foo )
[ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo) [ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo)
} cond } cond
] ; ] ;
@ -139,8 +117,8 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
] if ; ] if ;
: read-til-semicolon ( n string slice -- n' string semi ) : read-til-semicolon ( n string slice -- n' string semi )
dup '[ but-last ";" append ";" 2array lex-colon-until ] dip dup '[ but-last ";" append ";" 2array lex-until ] dip
-rot 3array ; swap 2array ;
: read-word-or-til-semicolon ( n string slice -- n' string obj ) : read-word-or-til-semicolon ( n string slice -- n' string obj )
2over next-char-from* "\s\r\n" member? [ 2over next-char-from* "\s\r\n" member? [
@ -165,7 +143,7 @@ ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
] if ] if
] [ ] [
{ {
{ [ dup strict-upper? ] [ B read-til-semicolon ] } { [ dup strict-upper? ] [ strict-upper on read-til-semicolon strict-upper off ] }
[ read-lowercase-colon ] [ read-lowercase-colon ]
} cond } cond
] if ; ] if ;
@ -204,7 +182,14 @@ ERROR: mismatched-terminator n string slice ;
{ CHAR: " [ read-string ] } { CHAR: " [ read-string ] }
{ CHAR: \ [ read-backslash ] } { CHAR: \ [ read-backslash ] }
{ CHAR: ! [ read-exclamation ] } { CHAR: ! [ read-exclamation ] }
{ CHAR: : [ read-colon ] } { CHAR: : [
dup strict-upper? strict-upper get and [
length swap [ - ] dip f
strict-upper off
] [
read-colon
] if
] }
{ CHAR: [ [ read-bracket ] } { CHAR: [ [ read-bracket ] }
{ CHAR: { [ read-brace ] } { CHAR: { [ read-brace ] }
{ CHAR: ( [ read-paren ] } { CHAR: ( [ read-paren ] }