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

modern: working on fix for TAG:

locals-and-roots
Doug Coleman 2016-06-08 16:11:36 -07:00
parent 190680a76a
commit 339799453a
2 changed files with 31 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
core/modern/modern.factor
View File

@ -5,7 +5,7 @@ combinators.short-circuit constructors continuations fry
io.encodings.utf8 io.files kernel locals macros make math io.encodings.utf8 io.files kernel locals macros make math
math.order modern.paths modern.slices multiline namespaces math.order modern.paths modern.slices multiline namespaces
quotations sequences sequences.extras splitting quotations sequences sequences.extras splitting
splitting.monotonic strings unicode ; splitting.monotonic strings unicode generalizations ;
in: modern in: modern
<< <<
@ -112,6 +112,10 @@ M: array collapse-decorators
collapse-decorators make-compound-literals ; collapse-decorators make-compound-literals ;
: strict-upper? ( string -- ? )
[ { [ char: A char: Z between? ] [ "#:-" member? ] } 1|| ] all? ;
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 ;
ERROR: string-expected-got-eof n string ; ERROR: string-expected-got-eof n string ;
@ -212,27 +216,32 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se
defer: lex defer: lex
defer: lex-factor defer: lex-factor
ERROR: lex-expected-but-got-eof n string expected ;
! make lex-top-level and lex-matched
! lex-top-level lexes til FOO; ; or TAG:, on TAG: leave n' at start of TAG:
! lex-matched lexes til foo) foo} foo] ) } ] or TAG:, on TAG: throw error
ERROR: lex-expected-but-got-eof n string expected nested? ;
! For implementing [ { ( ! For implementing [ { (
: lex-until ( n string tags -- n' string payload closing ) : lex-until ( n string tags nested? -- n' string payload closing )
pick [ 4 npick [ lex-expected-but-got-eof ] unless
3dup '[ 4dup '[
[ [
lex-factor dup , [ lex-factor dup , [
dup tag-literal? [ dup tag-literal? [
! } gets a chance, but then also full seq { } after recursion... ! } gets a chance, but then also full seq { } after recursion...
[ _ ] dip underlying>> '[ _ sequence= ] any? not [ _ ] dip underlying>> '[ _ sequence= ] any? not
_ drop
] [ ] [
drop t ! loop again? drop t ! loop again?
] if ] if
] [ ] [
_ _ _ lex-expected-but-got-eof _ _ _ _ lex-expected-but-got-eof
] if* ] if*
] loop ] loop
] { } make unclip-last ] { } make unclip-last ;
] [
lex-expected-but-got-eof
] if ;
MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) ) MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
ch dup matching-delimiter { ch dup matching-delimiter {
@ -243,7 +252,7 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
n string tag n string tag
2over nth-check-eof { 2over nth-check-eof {
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or (( { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
{ [ dup blank? ] [ drop dup '[ _ matching-delimiter-string closestr1 2array lex-until ] dip 1 cut-slice* single-matched-literal make-matched-literal ] } ! ( foo ) { [ dup blank? ] [ drop dup '[ _ matching-delimiter-string closestr1 2array t lex-until ] dip 1 cut-slice* single-matched-literal make-matched-literal ] } ! ( foo )
[ drop [ slice-til-whitespace drop ] dip span-slices make-tag-literal ] ! (foo) [ drop [ slice-til-whitespace drop ] dip span-slices make-tag-literal ] ! (foo)
} cond } cond
] ; ] ;
@ -285,7 +294,7 @@ 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-until ] dip dup '[ but-last ";" append ";" 2array f lex-until ] dip
1 cut-slice* uppercase-colon-literal make-matched-literal ; 1 cut-slice* uppercase-colon-literal make-matched-literal ;
: read-word-or-til-semicolon ( n string slice -- n' string obj ) : read-word-or-til-semicolon ( n string slice -- n' string obj )
@ -299,9 +308,6 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
[ lex-factor dup ] dip 1 cut-slice* [ lex-factor dup ] dip 1 cut-slice*
lowercase-colon-literal make-delimited-literal ; lowercase-colon-literal make-delimited-literal ;
: strict-upper? ( string -- ? )
[ { [ char: A char: Z between? ] [ "#:-" member? ] } 1|| ] all? ;
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 length 1 = [ dup length 1 = [

1
core/syntax/arity/arity.factor
View File

@ -1,6 +1,5 @@
! Copyright (C) 2016 Doug Coleman. ! Copyright (C) 2016 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: ;
IN: syntax.arity IN: syntax.arity
ARITY: \ IN: 1 ARITY: \ IN: 1