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

modern: refactoring. 

realized that functors with names like ( T: int -- ) don't work like they are supposed to because of nesting.
modern-harvey2
Doug Coleman 2017-12-03 19:11:01 -06:00
parent 06e40a39bc
commit 7f51295293
1 changed files with 83 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
extra/modern/modern.factor
View File

@ -11,8 +11,6 @@ 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
! (( )) [[ ]] {{ }} ! (( )) [[ ]] {{ }}
MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) ) MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
open-ch dup matching-delimiter { open-ch dup matching-delimiter {
@ -46,14 +44,14 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se
: read-double-matched-bracket ( n string tag ch -- n' string seq ) char: \[ read-double-matched ; : read-double-matched-bracket ( n string tag ch -- n' string seq ) char: \[ read-double-matched ;
: read-double-matched-brace ( n string tag ch -- n' string seq ) char: \{ read-double-matched ; : read-double-matched-brace ( n string tag ch -- n' string seq ) char: \{ read-double-matched ;
DEFER: (lex-factor) DEFER: lex-factor-top
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 tag-sequence -- n' string payload ) : lex-until ( n string tag-sequence -- n' string payload )
3dup '[ 3dup '[
[ [
(lex-factor) dup f like [ , ] when* [ lex-factor-top dup f like [ , ] when* [
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
@ -66,13 +64,19 @@ ERROR: lex-expected-but-got-eof n string expected ;
] loop ] loop
] { } make ; ] { } make ;
DEFER: section-close?
DEFER: upper-colon?
: lex-colon-until ( n string tag-sequence -- n' string payload ) : lex-colon-until ( n string tag-sequence -- n' string payload )
'[ '[
[ [
(lex-factor) dup f like [ , ] when* [ lex-factor-top dup f like [ , ] when* [
dup [ dup [
dup { [ section-close? ] [ upper-colon? ] } 1|| [
drop f
] [
! } 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
] if
] [ ] [
drop t ! loop again? drop t ! loop again?
] if ] if
@ -156,10 +160,10 @@ ERROR: unexpected-terminator n string slice ;
{ {
[ [
[ [
{ [ char: A char: Z between? ] [ ":-" member? ] } 1|| { [ char: A char: Z between? ] [ ":-\\" member? ] } 1||
] all? ] all?
] ]
[ [ char: A char: Z between? ] any? ] [ [ char: A char: Z between? ] any? ] ! XXX: what?
} 1&& ; } 1&& ;
: strict-upper? ( string -- ? ) : strict-upper? ( string -- ? )
@ -174,6 +178,13 @@ ERROR: unexpected-terminator n string slice ;
[ ">" tail? not ] [ ">" tail? not ]
} 1&& ; } 1&& ;
: upper-colon? ( string -- ? )
{
[ length 2 >= ]
[ ":" tail? ]
[ dup [ char: : = ] find drop head strict-upper? ]
} 1&& ;
: section-close? ( string -- ? ) : section-close? ( string -- ? )
{ {
[ length 2 >= ] [ length 2 >= ]
@ -187,21 +198,26 @@ ERROR: unexpected-terminator n string slice ;
} 1&& ; } 1&& ;
: 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 { "--" ")" } append lex-colon-until ] dip
swap swap
! Remove the ; from the paylaod if present ! What ended the FOO: .. ; form?
dup ?last ";" tail? [ ! Remove the ; from the payload if present
unclip-last 3array ! Also in stack effects ( T: int -- ) can be ended by -- and )
] [ dup ?last {
2array { [ dup ";" tail? ] [ drop unclip-last 3array ] }
] if ; { [ dup "--" tail? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
{ [ dup ")" tail? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
{ [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
{ [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
[ drop 2array ]
} cond ;
ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ; ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
: read-colon ( n string slice -- n' string colon ) : read-colon ( n string slice -- n' string colon )
{ {
{ [ dup strict-upper? ] [ strict-upper on read-til-semicolon strict-upper off ] } { [ dup strict-upper? ] [ read-til-semicolon ] }
{ [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo: { [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo:
[ ] [ "here for some reason" throw ]
} cond ; } cond ;
: read-acute ( n string slice -- n' string acute ) : read-acute ( n string slice -- n' string acute )
@ -213,7 +229,7 @@ ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
[ take-comment ] [ merge-slice-til-whitespace ] if ; [ take-comment ] [ merge-slice-til-whitespace ] if ;
ERROR: no-backslash-payload n string slice ; ERROR: no-backslash-payload n string slice ;
: read-backslash ( n string slice -- n' string obj ) : (read-backslash) ( n string slice -- n' string obj )
merge-slice-til-whitespace dup "\\" tail? [ merge-slice-til-whitespace dup "\\" tail? [
! \ foo, M\ foo ! \ foo, M\ foo
dup [ char: \\ = ] count-tail dup [ char: \\ = ] count-tail
@ -224,60 +240,29 @@ ERROR: no-backslash-payload n string slice ;
] dip swap 2array ] dip swap 2array
] when ; ] when ;
DEFER: lex-factor-top*
: read-backslash ( n string slice -- n' string obj )
! foo\ so far, could be foo\bar{
! remove the \ and continue til delimiter/eof
[ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
over "\\" head? [
drop
! \ foo
dup "\\" sequence= [ (read-backslash) ] [ merge-slice-til-whitespace ] if
] [
! foo\ or foo\bar (?)
over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if
] if ;
! If the slice is 0 width, we stopped on whitespace. ! If the slice is 0 width, we stopped on whitespace.
! Advance the index and read again! ! Advance the index and read again!
: read-token-or-whitespace ( n string slice -- n' string slice/f ) : read-token-or-whitespace ( n string slice -- n' string slice/f )
dup length 0 = [ [ 1 + ] 2dip drop (lex-factor) ] when ; dup length 0 = [ [ 1 + ] 2dip drop lex-factor-top ] when ;
ERROR: mismatched-terminator n string slice ; ! Inside a FOO: or a <FOO FOO>
: read-terminator ( n string slice -- n' string slice ) ; : lex-factor-nested ( n/f string slice/f ch/f -- n'/f string literal )
! If we are at the end of the string, we need to be at position len instead of f
! after a read. Especially for "<FOO BAR: baz FOO>"
: ?length-and-string ( length/f string -- length string )
over [ nip [ length ] [ ] bi ] unless ; inline
: ((lex-factor)) ( n/f string slice/f ch/f -- n'/f string literal )
{ {
{ char: \" [ read-string ] } { char: \\ [ read-backslash ] }
{ char: \! [ read-exclamation ] }
{ char: \: [
merge-slice-til-whitespace
dup strict-upper? strict-upper get and [
length swap [ - ] dip f
strict-upper off
] [
read-colon
] if
] }
{ char: < [
! FOO: a b <BAR: ;BAR>
! FOO: a b <BAR BAR>
! FOO: a b <asdf>
! FOO: a b <asdf asdf>
! if we are in a FOO: and we hit a <BAR or <BAR:
! then end the FOO:
[ slice-til-whitespace drop ] dip span-slices
dup section-open? [
strict-upper get [
length swap [ - ] dip f strict-upper off
] [
read-acute
] if
] when
] }
{ char: > [
[ [ char: > = not ] slice-until ] dip merge-slices
dup section-close? [
strict-upper get [
[ ?length-and-string ] dip
length swap [ - ] dip f strict-upper off
] when
] [
[ slice-til-whitespace drop ] dip ?span-slices
] if
] }
{ char: \[ [ read-bracket ] } { char: \[ [ read-bracket ] }
{ char: \{ [ read-brace ] } { char: \{ [ read-brace ] }
{ char: \( [ read-paren ] } { char: \( [ read-paren ] }
@ -287,32 +272,38 @@ ERROR: mismatched-terminator n string slice ;
{ char: \s [ read-token-or-whitespace ] } { char: \s [ read-token-or-whitespace ] }
{ char: \r [ read-token-or-whitespace ] } { char: \r [ read-token-or-whitespace ] }
{ char: \n [ read-token-or-whitespace ] } { char: \n [ read-token-or-whitespace ] }
{ char: \" [ read-string ] }
{ char: \! [ read-exclamation ] }
{ char: > [
[ [ char: > = not ] slice-until ] dip merge-slices
dup section-close? [
[ slice-til-whitespace drop ] dip ?span-slices
] unless
] }
{ f [ ] } { f [ ] }
} case ; } case ;
: (lex-factor) ( n/f string -- n'/f string literal ) : lex-factor-top* ( n/f string slice/f ch/f -- n'/f string literal )
over [ {
{ char: \: [ merge-slice-til-whitespace read-colon ] }
{ char: < [
! FOO: a b <BAR: ;BAR>
! FOO: a b <BAR BAR>
! FOO: a b <asdf>
! FOO: a b <asdf asdf>
! if we are in a FOO: and we hit a <BAR or <BAR:
! then end the FOO:
[ slice-til-whitespace drop ] dip span-slices
dup section-open? [ read-acute ] when
] }
[ lex-factor-nested ]
} case ;
: lex-factor-top ( n/f string -- n'/f string literal )
! skip-whitespace ! skip-whitespace
"\"\\!:[{(]})<>\s\r\n" slice-til-either "\"\\!:[{(]})<>\s\r\n" slice-til-either
lex-factor-top* ; inline
! \foo foo\bar \foo{
dup char: \\ = [
drop
! foo\ so far, could be foo\bar{
! remove the \ and continue til delimiter/eof
[ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
over "\\" head? [
drop
dup "\\" sequence= [ read-backslash ] [ merge-slice-til-whitespace ] if
] [
over "\\" tail? [ drop read-backslash ] [ ((lex-factor)) ] if
] if
] [
((lex-factor))
] if
] [
f
] if ; inline
ERROR: compound-syntax-disallowed seq i obj ; ERROR: compound-syntax-disallowed seq i obj ;
: check-for-compound-syntax ( seq -- seq' ) : check-for-compound-syntax ( seq -- seq' )
@ -323,7 +314,8 @@ ERROR: compound-syntax-disallowed seq i obj ;
[ [
! Compound syntax loop ! Compound syntax loop
[ [
(lex-factor) f like [ , ] when* lex-factor-top
f like [ , ] when*
! concatenated syntax ( a )[ a 1 + ]( b ) ! concatenated syntax ( a )[ a 1 + ]( b )
[ ] [ ]
[ peek-from blank? ] [ peek-from blank? ]